diff options
Diffstat (limited to 'gcc/ada/exp_strm.adb')
| -rw-r--r-- | gcc/ada/exp_strm.adb | 1472 |
1 files changed, 1472 insertions, 0 deletions
diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb new file mode 100644 index 0000000..92ff393 --- /dev/null +++ b/gcc/ada/exp_strm.adb @@ -0,0 +1,1472 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S T R M -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.39 $ +-- -- +-- Copyright (C) 1992-2001, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Lib; use Lib; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +with Exp_Tss; use Exp_Tss; +with Uintp; use Uintp; + +package body Exp_Strm is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Build_Array_Read_Write_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id); + -- Common routine shared to build either an array Read procedure or an + -- array Write procedure, Nam is Name_Read or Name_Write to select which. + -- Pnam is the defining identifier for the constructed procedure. The + -- other parameters are as for Build_Array_Read_Procedure except that + -- the first parameter Nod supplies the Sloc to be used to generate code. + + procedure Build_Record_Read_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id); + -- Common routine shared to build a record Read Write procedure, Nam + -- is Name_Read or Name_Write to select which. Pnam is the defining + -- identifier for the constructed procedure. The other parameters are + -- as for Build_Record_Read_Procedure. + + procedure Build_Stream_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : Entity_Id; + Decls : List_Id; + Stms : List_Id); + -- Called to build an array or record stream function. The first three + -- arguments are the same as Build_Record_Or_Elementary_Input_Function. + -- Decls and Stms are the declarations and statements for the body and + -- The parameter Fnam is the name of the constructed function. + + procedure Build_Stream_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Stms : List_Id; + Outp : Boolean); + -- Called to build an array or record stream procedure. The first three + -- arguments are the same as Build_Record_Or_Elementary_Output_Procedure. + -- Stms is the list of statements for the body (the declaration list is + -- always null), and Pnam is the name of the constructed procedure. + + function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean; + -- This function is used to test U_Type, which is a type + -- Returns True if U_Type has a standard representation for stream + -- purposes, i.e. there is no non-standard enumeration representation + -- clause, and the size of the first subtype is the same as the size + -- of the root type. + + function Stream_Base_Type (E : Entity_Id) return Entity_Id; + -- Stream attributes work on the basis of the base type except for the + -- array case. For the array case, we do not go to the base type, but + -- to the first subtype if it is constrained. This avoids problems with + -- incorrect conversions in the packed array case. Stream_Base_Type is + -- exactly this function (returns the base type, unless we have an array + -- type whose first subtype is constrained, in which case it returns the + -- first subtype). + + -------------------------------- + -- Build_Array_Input_Function -- + -------------------------------- + + -- The function we build looks like + + -- function InputN (S : access RST) return Typ is + -- L1 : constant Index_Type_1 := Index_Type_1'Input (S); + -- H1 : constant Index_Type_1 := Index_Type_1'Input (S); + -- L2 : constant Index_Type_2 := Index_Type_2'Input (S); + -- H2 : constant Index_Type_2 := Index_Type_2'Input (S); + -- .. + -- Ln : constant Index_Type_n := Index_Type_n'Input (S); + -- Hn : constant Index_Type_n := Index_Type_n'Input (S); + -- + -- V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn) + + -- begin + -- Typ'Read (S, V); + -- return V; + -- end InputN + + procedure Build_Array_Input_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Dim : constant Pos := Number_Dimensions (Typ); + Lnam : Name_Id; + Hnam : Name_Id; + Decls : List_Id; + Ranges : List_Id; + Stms : List_Id; + Indx : Node_Id; + + begin + Decls := New_List; + Ranges := New_List; + Indx := First_Index (Typ); + + for J in 1 .. Dim loop + Lnam := New_External_Name ('L', J); + Hnam := New_External_Name ('H', J); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Lnam), + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etype (Indx), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Input, + Expressions => New_List (Make_Identifier (Loc, Name_S))))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Hnam), + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Input, + Expressions => New_List (Make_Identifier (Loc, Name_S))))); + + Append_To (Ranges, + Make_Range (Loc, + Low_Bound => Make_Identifier (Loc, Lnam), + High_Bound => Make_Identifier (Loc, Hnam))); + + Next_Index (Indx); + end loop; + + -- If the first subtype is constrained, use it directly. Otherwise + -- build a subtype indication with the proper bounds. + + if Is_Constrained (Stream_Base_Type (Typ)) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => + New_Occurrence_Of (Stream_Base_Type (Typ), Loc))); + else + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Stream_Base_Type (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Ranges)))); + end if; + + Stms := New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))), + + Make_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Name_V))); + + Fnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uInput, ' ', Increment_Serial_Number)); + + Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms); + end Build_Array_Input_Function; + + ---------------------------------- + -- Build_Array_Output_Procedure -- + ---------------------------------- + + procedure Build_Array_Output_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Stms : List_Id; + Indx : Node_Id; + + begin + -- Build series of statements to output bounds + + Indx := First_Index (Typ); + Stms := New_List; + + for J in 1 .. Number_Dimensions (Typ) loop + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))))); + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Last, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))))); + + Next_Index (Indx); + end loop; + + -- Append Write attribute to write array elements + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V)))); + + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uOutput, ' ', Increment_Serial_Number)); + + Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False); + end Build_Array_Output_Procedure; + + -------------------------------- + -- Build_Array_Read_Procedure -- + -------------------------------- + + procedure Build_Array_Read_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + begin + Pnam := + Make_Defining_Identifier (Loc, + New_External_Name + (Name_uRead, ' ', Increment_Serial_Number)); + + Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read); + end Build_Array_Read_Procedure; + + -------------------------------------- + -- Build_Array_Read_Write_Procedure -- + -------------------------------------- + + -- The form of the array read/write procedure is as follows: + + -- procedure pnam (S : access RST, V : [out] Typ) is + -- begin + -- for L1 in V'Range (1) loop + -- for L2 in V'Range (2) loop + -- ... + -- for Ln in V'Range (n) loop + -- Component_Type'Read/Write (S, V (L1, L2, .. Ln)); + -- end loop; + -- .. + -- end loop; + -- end loop + -- end pnam; + + -- The out keyword for V is supplied in the Read case + + procedure Build_Array_Read_Write_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + Ndim : constant Pos := Number_Dimensions (Typ); + Ctyp : constant Entity_Id := Component_Type (Typ); + + Stm : Node_Id; + Exl : List_Id; + RW : Entity_Id; + + begin + -- First build the inner attribute call + + Exl := New_List; + + for J in 1 .. Ndim loop + Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', J))); + end loop; + + Stm := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Base_Type (Ctyp), Loc), + Attribute_Name => Nam, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Expressions => Exl))); + + -- The corresponding stream attribute for the component type of the + -- array may be user-defined, and be frozen after the type for which + -- we are generating the stream subprogram. In that case, freeze the + -- stream attribute of the component type, whose declaration could not + -- generate any additional freezing actions in any case. See 5509-003. + + if Nam = Name_Read then + RW := TSS (Base_Type (Ctyp), Name_uRead); + else + RW := TSS (Base_Type (Ctyp), Name_uWrite); + end if; + + if Present (RW) + and then not Is_Frozen (RW) + then + Set_Is_Frozen (RW); + end if; + + -- Now this is the big loop to wrap that statement up in a sequence + -- of loops. The first time around, Stm is the attribute call. The + -- second and subsequent times, Stm is an inner loop. + + for J in 1 .. Ndim loop + Stm := + Make_Implicit_Loop_Statement (Nod, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => New_External_Name ('L', Ndim - J + 1)), + + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Range, + + Expressions => New_List ( + Make_Integer_Literal (Loc, Ndim - J + 1))))), + + Statements => New_List (Stm)); + + end loop; + + Build_Stream_Procedure + (Loc, Typ, Decl, Pnam, New_List (Stm), Nam = Name_Read); + end Build_Array_Read_Write_Procedure; + + --------------------------------- + -- Build_Array_Write_Procedure -- + --------------------------------- + + procedure Build_Array_Write_Procedure + (Nod : Node_Id; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + begin + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uWrite, ' ', Increment_Serial_Number)); + + Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write); + end Build_Array_Write_Procedure; + + --------------------------------- + -- Build_Elementary_Input_Call -- + --------------------------------- + + function Build_Elementary_Input_Call (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + P_Type : constant Entity_Id := Entity (Prefix (N)); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Rt_Type : constant Entity_Id := Root_Type (U_Type); + FST : constant Entity_Id := First_Subtype (U_Type); + P_Size : constant Uint := Esize (FST); + Strm : constant Node_Id := First (Expressions (N)); + Lib_RE : RE_Id; + + begin + -- Check first for Boolean and Character. These are enumeration types, + -- but we treat them specially, since they may require special handling + -- in the transfer protocol. However, this special handling only applies + -- if they have standard representation, otherwise they are treated like + -- any other enumeration type. + + if Rt_Type = Standard_Boolean + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_I_B; + + elsif Rt_Type = Standard_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_I_C; + + elsif Rt_Type = Standard_Wide_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_I_WC; + + -- Floating point types + + elsif Is_Floating_Point_Type (U_Type) then + + if Rt_Type = Standard_Short_Float then + Lib_RE := RE_I_SF; + + elsif Rt_Type = Standard_Float then + Lib_RE := RE_I_F; + + elsif Rt_Type = Standard_Long_Float then + Lib_RE := RE_I_LF; + + else pragma Assert (Rt_Type = Standard_Long_Long_Float); + Lib_RE := RE_I_LLF; + end if; + + -- Signed integer types. Also includes signed fixed-point types and + -- enumeration types with a signed representation. + + -- Note on signed integer types. We do not consider types as signed for + -- this purpose if they have no negative numbers, or if they have biased + -- representation. The reason is that the value in either case basically + -- represents an unsigned value. + + -- For example, consider: + + -- type W is range 0 .. 2**32 - 1; + -- for W'Size use 32; + + -- This is a signed type, but the representation is unsigned, and may + -- be outside the range of a 32-bit signed integer, so this must be + -- treated as 32-bit unsigned. + + -- Similarly, if we have + + -- type W is range -1 .. +254; + -- for W'Size use 8; + + -- then the representation is unsigned + + elsif not Is_Unsigned_Type (FST) + and then + (Is_Fixed_Point_Type (U_Type) + or else + Is_Enumeration_Type (U_Type) + or else + (Is_Signed_Integer_Type (U_Type) + and then not Has_Biased_Representation (FST))) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_I_SSI; + + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_I_SI; + + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_I_I; + + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_I_LI; + + else + Lib_RE := RE_I_LLI; + end if; + + -- Unsigned integer types, also includes unsigned fixed-point types + -- and enumeration types with an unsigned representation (note that + -- we know they are unsigned because we already tested for signed). + + -- Also includes signed integer types that are unsigned in the sense + -- that they do not include negative numbers. See above for details. + + elsif Is_Modular_Integer_Type (U_Type) + or else Is_Fixed_Point_Type (U_Type) + or else Is_Enumeration_Type (U_Type) + or else Is_Signed_Integer_Type (U_Type) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_I_SSU; + + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_I_SU; + + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_I_U; + + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_I_LU; + + else + Lib_RE := RE_I_LLU; + end if; + + else pragma Assert (Is_Access_Type (U_Type)); + if P_Size > System_Address_Size then + Lib_RE := RE_I_AD; + else + Lib_RE := RE_I_AS; + end if; + end if; + + -- Call the function, and do an unchecked conversion of the result + -- to the actual type of the prefix. + + return + Unchecked_Convert_To (P_Type, + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Lib_RE), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Strm)))); + + end Build_Elementary_Input_Call; + + --------------------------------- + -- Build_Elementary_Write_Call -- + --------------------------------- + + function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + P_Type : constant Entity_Id := Entity (Prefix (N)); + U_Type : constant Entity_Id := Underlying_Type (P_Type); + Rt_Type : constant Entity_Id := Root_Type (U_Type); + FST : constant Entity_Id := First_Subtype (U_Type); + P_Size : constant Uint := Esize (FST); + Strm : constant Node_Id := First (Expressions (N)); + Item : constant Node_Id := Next (Strm); + Lib_RE : RE_Id; + Libent : Entity_Id; + + begin + -- Find the routine to be called + + -- Check for First Boolean and Character. These are enumeration types, + -- but we treat them specially, since they may require special handling + -- in the transfer protocol. However, this special handling only applies + -- if they have standard representation, otherwise they are treated like + -- any other enumeration type. + + if Rt_Type = Standard_Boolean + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_W_B; + + elsif Rt_Type = Standard_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_W_C; + + elsif Rt_Type = Standard_Wide_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_W_WC; + + -- Floating point types + + elsif Is_Floating_Point_Type (U_Type) then + + if Rt_Type = Standard_Short_Float then + Lib_RE := RE_W_SF; + + elsif Rt_Type = Standard_Float then + Lib_RE := RE_W_F; + + elsif Rt_Type = Standard_Long_Float then + Lib_RE := RE_W_LF; + + else pragma Assert (Rt_Type = Standard_Long_Long_Float); + Lib_RE := RE_W_LLF; + end if; + + -- Signed integer types. Also includes signed fixed-point types and + -- signed enumeration types share this circuitry. + + -- Note on signed integer types. We do not consider types as signed for + -- this purpose if they have no negative numbers, or if they have biased + -- representation. The reason is that the value in either case basically + -- represents an unsigned value. + + -- For example, consider: + + -- type W is range 0 .. 2**32 - 1; + -- for W'Size use 32; + + -- This is a signed type, but the representation is unsigned, and may + -- be outside the range of a 32-bit signed integer, so this must be + -- treated as 32-bit unsigned. + + -- Similarly, if we have + + -- type W is range -1 .. +254; + -- for W'Size use 8; + + -- then the representation is also unsigned. + + elsif not Is_Unsigned_Type (FST) + and then + (Is_Fixed_Point_Type (U_Type) + or else + Is_Enumeration_Type (U_Type) + or else + (Is_Signed_Integer_Type (U_Type) + and then not Has_Biased_Representation (FST))) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_W_SSI; + + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_W_SI; + + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_W_I; + + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_W_LI; + + else + Lib_RE := RE_W_LLI; + end if; + + -- Unsigned integer types, also includes unsigned fixed-point types + -- and unsigned enumeration types (note we know they are unsigned + -- because we already tested for signed above). + + -- Also includes signed integer types that are unsigned in the sense + -- that they do not include negative numbers. See above for details. + + elsif Is_Modular_Integer_Type (U_Type) + or else Is_Fixed_Point_Type (U_Type) + or else Is_Enumeration_Type (U_Type) + or else Is_Signed_Integer_Type (U_Type) + then + if P_Size <= Standard_Short_Short_Integer_Size then + Lib_RE := RE_W_SSU; + + elsif P_Size <= Standard_Short_Integer_Size then + Lib_RE := RE_W_SU; + + elsif P_Size <= Standard_Integer_Size then + Lib_RE := RE_W_U; + + elsif P_Size <= Standard_Long_Integer_Size then + Lib_RE := RE_W_LU; + + else + Lib_RE := RE_W_LLU; + end if; + + else pragma Assert (Is_Access_Type (U_Type)); + + if P_Size > System_Address_Size then + Lib_RE := RE_W_AD; + else + Lib_RE := RE_W_AS; + end if; + end if; + + -- Unchecked-convert parameter to the required type (i.e. the type of + -- the corresponding parameter, and call the appropriate routine. + + Libent := RTE (Lib_RE); + + return + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Libent, Loc), + Parameter_Associations => New_List ( + Relocate_Node (Strm), + Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))), + Relocate_Node (Item)))); + + end Build_Elementary_Write_Call; + + ----------------------------------------- + -- Build_Mutable_Record_Read_Procedure -- + ----------------------------------------- + + procedure Build_Mutable_Record_Read_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Stms : List_Id; + Disc : Entity_Id; + Comp : Node_Id; + + begin + Stms := New_List; + Disc := First_Discriminant (Typ); + + -- Generate Reads for the discriminants of the type. + + while Present (Disc) loop + Comp := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + + Set_Assignment_OK (Comp); + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Disc), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Comp))); + + Next_Discriminant (Disc); + end loop; + + -- A mutable type cannot be a tagged type, so we generate a new name + -- for the stream procedure. + + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uRead, ' ', Increment_Serial_Number)); + + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + + -- Read the discriminants before the rest of the components, so + -- that discriminant values are properly set of variants, etc. + -- If this is an empty record with discriminants, there are no + -- previous statements. If this is an unchecked union, the stream + -- procedure is erroneous, because there are no discriminants to read. + + if Is_Unchecked_Union (Typ) then + Stms := New_List (Make_Raise_Program_Error (Loc)); + end if; + + if Is_Non_Empty_List ( + Statements (Handled_Statement_Sequence (Decl))) + then + Insert_List_Before + (First (Statements (Handled_Statement_Sequence (Decl))), Stms); + else + Set_Statements (Handled_Statement_Sequence (Decl), Stms); + end if; + end Build_Mutable_Record_Read_Procedure; + + ------------------------------------------ + -- Build_Mutable_Record_Write_Procedure -- + ------------------------------------------ + + procedure Build_Mutable_Record_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Stms : List_Id; + Disc : Entity_Id; + + begin + Stms := New_List; + Disc := First_Discriminant (Typ); + + -- Generate Writes for the discriminants of the type. + + while Present (Disc) loop + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Disc), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (Disc, Loc))))); + + Next_Discriminant (Disc); + end loop; + + -- A mutable type cannot be a tagged type, so we generate a new name + -- for the stream procedure. + + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uWrite, ' ', Increment_Serial_Number)); + + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); + + -- Write the discriminants before the rest of the components, so + -- that discriminant values are properly set of variants, etc. + -- If this is an unchecked union, the stream procedure is erroneous + -- because there are no discriminants to write. + + if Is_Unchecked_Union (Typ) then + Stms := New_List (Make_Raise_Program_Error (Loc)); + end if; + + if Is_Non_Empty_List ( + Statements (Handled_Statement_Sequence (Decl))) + then + Insert_List_Before + (First (Statements (Handled_Statement_Sequence (Decl))), Stms); + else + Set_Statements (Handled_Statement_Sequence (Decl), Stms); + end if; + end Build_Mutable_Record_Write_Procedure; + + ----------------------------------------------- + -- Build_Record_Or_Elementary_Input_Function -- + ----------------------------------------------- + + -- The function we build looks like + + -- function InputN (S : access RST) return Typ is + -- C1 : constant Disc_Type_1 := Discr_Type_1'Input (S); + -- C2 : constant Disc_Type_1 := Discr_Type_2'Input (S); + -- ... + -- Cn : constant Disc_Type_1 := Discr_Type_n'Input (S); + -- V : Typ (C1, C2, .. Cn) + + -- begin + -- Typ'Read (S, V); + -- return V; + -- end InputN + + -- The discriminants are of course only present in the case of a record + -- with discriminants. In the case of a record with no discriminants, or + -- an elementary type, then no Cn constants are defined. + + procedure Build_Record_Or_Elementary_Input_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Cn : Name_Id; + J : Pos; + Decls : List_Id; + Constr : List_Id; + Stms : List_Id; + Discr : Entity_Id; + Odef : Node_Id; + + begin + Decls := New_List; + Constr := New_List; + + J := 1; + + if Has_Discriminants (Typ) then + Discr := First_Discriminant (Typ); + + while Present (Discr) loop + Cn := New_External_Name ('C', J); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Cn), + Object_Definition => New_Occurrence_Of (Etype (Discr), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Stream_Base_Type (Etype (Discr)), Loc), + Attribute_Name => Name_Input, + Expressions => New_List (Make_Identifier (Loc, Name_S))))); + + Append_To (Constr, Make_Identifier (Loc, Cn)); + + Next_Discriminant (Discr); + J := J + 1; + end loop; + + Odef := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constr)); + + -- If no discriminants, then just use the type with no constraint + + else + Odef := New_Occurrence_Of (Typ, Loc); + end if; + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => Odef)); + + Stms := New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))), + + Make_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Name_V))); + + -- For tagged types, we use a canonical name so that it matches the + -- primitive spec. For all other cases, we use a serialized name so + -- that multiple generations of the same procedure do not clash. + + if Is_Tagged_Type (Typ) then + Fnam := Make_Defining_Identifier (Loc, Name_uInput); + else + Fnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uInput, ' ', Increment_Serial_Number)); + end if; + + Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms); + end Build_Record_Or_Elementary_Input_Function; + + ------------------------------------------------- + -- Build_Record_Or_Elementary_Output_Procedure -- + ------------------------------------------------- + + procedure Build_Record_Or_Elementary_Output_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + Stms : List_Id; + Disc : Entity_Id; + + begin + Stms := New_List; + + -- Note that of course there will be no discriminants for the + -- elementary type case, so Has_Discriminants will be False. + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + + while Present (Disc) loop + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (Disc, Loc))))); + + Next_Discriminant (Disc); + end loop; + end if; + + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V)))); + + -- For tagged types, we use a canonical name so that it matches the + -- primitive spec. For all other cases, we use a serialized name so + -- that multiple generations of the same procedure do not clash. + + if Is_Tagged_Type (Typ) then + Pnam := Make_Defining_Identifier (Loc, Name_uOutput); + else + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name + (Name_uOutput, ' ', Increment_Serial_Number)); + end if; + + Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False); + end Build_Record_Or_Elementary_Output_Procedure; + + --------------------------------- + -- Build_Record_Read_Procedure -- + --------------------------------- + + procedure Build_Record_Read_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + begin + -- For tagged types, we use a canonical name so that it matches the + -- primitive spec. For all other cases, we use a serialized name so + -- that multiple generations of the same procedure do not clash. + + if Is_Tagged_Type (Typ) then + Pnam := Make_Defining_Identifier (Loc, Name_uRead); + else + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uRead, ' ', Increment_Serial_Number)); + end if; + + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + end Build_Record_Read_Procedure; + + --------------------------------------- + -- Build_Record_Read_Write_Procedure -- + --------------------------------------- + + -- The form of the record read/write procedure is as shown by the + -- following example for a case with one discriminant case variant: + + -- procedure pnam (S : access RST, V : [out] Typ) is + -- begin + -- Component_Type'Read/Write (S, V.component); + -- Component_Type'Read/Write (S, V.component); + -- ... + -- Component_Type'Read/Write (S, V.component); + -- + -- case V.discriminant is + -- when choices => + -- Component_Type'Read/Write (S, V.component); + -- Component_Type'Read/Write (S, V.component); + -- ... + -- Component_Type'Read/Write (S, V.component); + -- + -- when choices => + -- Component_Type'Read/Write (S, V.component); + -- Component_Type'Read/Write (S, V.component); + -- ... + -- Component_Type'Read/Write (S, V.component); + -- ... + -- end case; + -- end pnam; + + -- The out keyword for V is supplied in the Read case + + procedure Build_Record_Read_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Nam : Name_Id) + is + Rdef : Node_Id; + Stms : List_Id; + Typt : Entity_Id; + + function Make_Component_List_Attributes (CL : Node_Id) return List_Id; + -- Returns a sequence of attributes to process the components that + -- are referenced in the given component list. + + function Make_Field_Attribute (C : Entity_Id) return Node_Id; + -- Given C, the entity for a discriminant or component, build + -- an attribute for the corresponding field values. + + function Make_Field_Attributes (Clist : List_Id) return List_Id; + -- Given Clist, a component items list, construct series of attributes + -- for fieldwise processing of the corresponding components. + + ------------------------------------ + -- Make_Component_List_Attributes -- + ------------------------------------ + + function Make_Component_List_Attributes (CL : Node_Id) return List_Id is + CI : constant List_Id := Component_Items (CL); + VP : constant Node_Id := Variant_Part (CL); + + Result : List_Id; + Alts : List_Id; + V : Node_Id; + DC : Node_Id; + DCH : List_Id; + + begin + Result := Make_Field_Attributes (CI); + + -- If a component is an unchecked union, there is no discriminant + -- and we cannot generate a read/write procedure for it. + + if Present (VP) then + if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then + return New_List (Make_Raise_Program_Error (Sloc (VP))); + end if; + + V := First_Non_Pragma (Variants (VP)); + Alts := New_List; + while Present (V) loop + + DCH := New_List; + DC := First (Discrete_Choices (V)); + while Present (DC) loop + Append_To (DCH, New_Copy_Tree (DC)); + Next (DC); + end loop; + + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => DCH, + Statements => + Make_Component_List_Attributes (Component_List (V)))); + Next_Non_Pragma (V); + end loop; + + -- Note: in the following, we make sure that we use new occurrence + -- of for the selector, since there are cases in which we make a + -- reference to a hidden discriminant that is not visible. + + Append_To (Result, + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => + New_Occurrence_Of (Entity (Name (VP)), Loc)), + Alternatives => Alts)); + + end if; + + return Result; + end Make_Component_List_Attributes; + + -------------------------- + -- Make_Field_Attribute -- + -------------------------- + + function Make_Field_Attribute (C : Entity_Id) return Node_Id is + begin + return + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Base_Type (Etype (C)), Loc), + Attribute_Name => Nam, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (C, Loc)))); + end Make_Field_Attribute; + + --------------------------- + -- Make_Field_Attributes -- + --------------------------- + + function Make_Field_Attributes (Clist : List_Id) return List_Id is + Item : Node_Id; + Result : List_Id; + + begin + Result := New_List; + + if Present (Clist) then + Item := First (Clist); + + -- Loop through components, skipping all internal components, + -- which are not part of the value (e.g. _Tag), except that we + -- don't skip the _Parent, since we do want to process that + -- recursively. + + while Present (Item) loop + if Nkind (Item) = N_Component_Declaration + and then + (Chars (Defining_Identifier (Item)) = Name_uParent + or else + not Is_Internal_Name (Chars (Defining_Identifier (Item)))) + then + Append_To + (Result, + Make_Field_Attribute (Defining_Identifier (Item))); + end if; + + Next (Item); + end loop; + end if; + + return Result; + end Make_Field_Attributes; + + -- Start of processing for Build_Record_Read_Write_Procedure + + begin + -- For the protected type case, use corresponding record + + if Is_Protected_Type (Typ) then + Typt := Corresponding_Record_Type (Typ); + else + Typt := Typ; + end if; + + -- Note that we do nothing with the discriminants, since Read and + -- Write do not read or write the discriminant values. All handling + -- of discriminants occurs in the Input and Output subprograms. + + Rdef := Type_Definition (Declaration_Node (Underlying_Type (Typt))); + Stms := Empty_List; + + -- In record extension case, the fields we want, including the _Parent + -- field representing the parent type, are to be found in the extension. + -- Note that we will naturally process the _Parent field using the type + -- of the parent, and hence its stream attributes, which is appropriate. + + if Nkind (Rdef) = N_Derived_Type_Definition then + Rdef := Record_Extension_Part (Rdef); + end if; + + if Present (Component_List (Rdef)) then + Append_List_To (Stms, + Make_Component_List_Attributes (Component_List (Rdef))); + end if; + + Build_Stream_Procedure + (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read); + + end Build_Record_Read_Write_Procedure; + + ---------------------------------- + -- Build_Record_Write_Procedure -- + ---------------------------------- + + procedure Build_Record_Write_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : out Entity_Id) + is + begin + -- For tagged types, we use a canonical name so that it matches the + -- primitive spec. For all other cases, we use a serialized name so + -- that multiple generations of the same procedure do not clash. + + if Is_Tagged_Type (Typ) then + Pnam := Make_Defining_Identifier (Loc, Name_uWrite); + else + Pnam := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Name_uWrite, ' ', Increment_Serial_Number)); + end if; + + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); + end Build_Record_Write_Procedure; + + ------------------------------- + -- Build_Stream_Attr_Profile -- + ------------------------------- + + function Build_Stream_Attr_Profile + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : Name_Id) + return List_Id + is + Profile : List_Id; + + begin + Profile := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => New_Reference_To ( + Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))); + + if Nam /= Name_uInput then + Append_To (Profile, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Out_Present => (Nam = Name_uRead), + Parameter_Type => New_Reference_To (Typ, Loc))); + end if; + + return Profile; + end Build_Stream_Attr_Profile; + + --------------------------- + -- Build_Stream_Function -- + --------------------------- + + procedure Build_Stream_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : Entity_Id; + Decls : List_Id; + Stms : List_Id) + is + Spec : Node_Id; + + begin + -- Construct function specification + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => New_Reference_To ( + Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))), + + Subtype_Mark => New_Occurrence_Of (Typ, Loc)); + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + + end Build_Stream_Function; + + ---------------------------- + -- Build_Stream_Procedure -- + ---------------------------- + + procedure Build_Stream_Procedure + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Pnam : Entity_Id; + Stms : List_Id; + Outp : Boolean) + is + Spec : Node_Id; + + begin + -- Construct procedure specification + + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Pnam, + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => New_Reference_To ( + Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Out_Present => Outp, + Parameter_Type => New_Occurrence_Of (Typ, Loc)))); + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + + end Build_Stream_Procedure; + + ----------------------------- + -- Has_Stream_Standard_Rep -- + ----------------------------- + + function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is + begin + if Has_Non_Standard_Rep (U_Type) then + return False; + + else + return + Esize (First_Subtype (U_Type)) = Esize (Root_Type (U_Type)); + end if; + end Has_Stream_Standard_Rep; + + ---------------------- + -- Stream_Base_Type -- + ---------------------- + + function Stream_Base_Type (E : Entity_Id) return Entity_Id is + begin + if Is_Array_Type (E) + and then Is_First_Subtype (E) + then + return E; + + else + return Base_Type (E); + end if; + end Stream_Base_Type; + +end Exp_Strm; |