diff options
Diffstat (limited to 'gcc-4.8.3/gcc/ada/exp_strm.adb')
| -rw-r--r-- | gcc-4.8.3/gcc/ada/exp_strm.adb | 1770 |
1 files changed, 1770 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/exp_strm.adb b/gcc-4.8.3/gcc/ada/exp_strm.adb new file mode 100644 index 000000000..987556a84 --- /dev/null +++ b/gcc-4.8.3/gcc/ada/exp_strm.adb @@ -0,0 +1,1770 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ S T R M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2011, 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 3, 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 COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Exp_Util; use Exp_Util; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Stand; use Stand; +with Tbuild; use Tbuild; +with Ttypes; use Ttypes; +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. + + function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean; + -- This function is used to test the type U_Type, to determine if it has + -- a standard representation from a streaming point of view. Standard means + -- that it has a standard representation (e.g. no enumeration rep clause), + -- and the size of the root type is the same as the streaming size (which + -- is defined as value specified by a Stream_Size clause if present, or + -- the Esize of U_Type if not). + + function Make_Stream_Subprogram_Name + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : TSS_Name_Type) return Entity_Id; + -- Return the entity that identifies the stream subprogram for type Typ + -- that is identified by the given Nam. This procedure deals with the + -- difference between tagged types (where a single subprogram associated + -- with the type is generated) and all other cases (where a subprogram + -- is generated at the point of the stream attribute reference). The + -- Loc parameter is used as the Sloc of the created entity. + + 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 typSI[_nnn] (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 typSI[_nnn] + + -- Note: the suffix [_nnn] is present for non-tagged types, where we + -- generate a local subprogram at the point of the occurrence of the + -- attribute reference, so the name must be unique. + + 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; + Rstmt : Node_Id; + Indx : Node_Id; + Odecl : 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 type is constrained, use it directly. Otherwise build a + -- subtype indication with the proper bounds. + + if Is_Constrained (Typ) then + Odecl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + else + Odecl := + 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, Ranges))); + end if; + + Rstmt := + 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))); + + Stms := New_List ( + Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Odecl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, New_List (Rstmt)))); + + Fnam := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input)); + + 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 => Make_TSS_Name_Local (Typ, TSS_Stream_Output)); + + 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, + Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read)); + 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. + + if Nam = Name_Read then + RW := TSS (Base_Type (Ctyp), TSS_Stream_Read); + else + RW := TSS (Base_Type (Ctyp), TSS_Stream_Write); + 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 => Make_TSS_Name_Local (Typ, TSS_Stream_Write)); + 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); + Strm : constant Node_Id := First (Expressions (N)); + Targ : constant Node_Id := Next (Strm); + P_Size : constant Uint := Get_Stream_Size (FST); + Res : Node_Id; + 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; + + elsif Rt_Type = Standard_Wide_Wide_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_I_WWC; + + -- Floating point types + + elsif Is_Floating_Point_Type (U_Type) then + + -- Question: should we use P_Size or Rt_Type to distinguish between + -- possible floating point types? If a non-standard size or a stream + -- size is specified, then we should certainly use the size. But if + -- we have two types the same (notably Short_Float_Size = Float_Size + -- which is close to universally true, and Long_Long_Float_Size = + -- Long_Float_Size, true on most targets except the x86), then we + -- would really rather use the root type, so that if people want to + -- fiddle with System.Stream_Attributes to get inter-target portable + -- streams, they get the size they expect. Consider in particular the + -- case of a stream written on an x86, with 96-bit Long_Long_Float + -- being read into a non-x86 target with 64 bit Long_Long_Float. A + -- special version of System.Stream_Attributes can deal with this + -- provided the proper type is always used. + + -- To deal with these two requirements we add the special checks + -- on equal sizes and use the root type to distinguish. + + if P_Size <= Standard_Short_Float_Size + and then (Standard_Short_Float_Size /= Standard_Float_Size + or else Rt_Type = Standard_Short_Float) + then + Lib_RE := RE_I_SF; + + elsif P_Size <= Standard_Float_Size then + Lib_RE := RE_I_F; + + elsif P_Size <= Standard_Long_Float_Size + and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size + or else Rt_Type = Standard_Long_Float) + then + Lib_RE := RE_I_LF; + + else + 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) + + -- The following set of tests gets repeated many times, we should + -- have an abstraction defined ??? + + 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. If the target is a discriminant, + -- and we are in the body of the default implementation of a 'Read + -- attribute, set target type to force a constraint check (13.13.2(35)). + -- If the type of the discriminant is currently private, add another + -- unchecked conversion from the full view. + + if Nkind (Targ) = N_Identifier + and then Is_Internal_Name (Chars (Targ)) + and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read) + then + Res := + Unchecked_Convert_To (Base_Type (U_Type), + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (Lib_RE), Loc), + Parameter_Associations => New_List ( + Relocate_Node (Strm)))); + + Set_Do_Range_Check (Res); + if Base_Type (P_Type) /= Base_Type (U_Type) then + Res := Unchecked_Convert_To (Base_Type (P_Type), Res); + end if; + + return Res; + + else + 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 if; + 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); + Strm : constant Node_Id := First (Expressions (N)); + Item : constant Node_Id := Next (Strm); + P_Size : Uint; + Lib_RE : RE_Id; + Libent : Entity_Id; + + begin + + -- Compute the size of the stream element. This is either the size of + -- the first subtype or if given the size of the Stream_Size attribute. + + if Has_Stream_Size_Clause (FST) then + P_Size := Static_Integer (Expression (Stream_Size_Clause (FST))); + else + P_Size := Esize (FST); + end if; + + -- 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; + + elsif Rt_Type = Standard_Wide_Wide_Character + and then Has_Stream_Standard_Rep (U_Type) + then + Lib_RE := RE_W_WWC; + + -- Floating point types + + elsif Is_Floating_Point_Type (U_Type) then + + -- Question: should we use P_Size or Rt_Type to distinguish between + -- possible floating point types? If a non-standard size or a stream + -- size is specified, then we should certainly use the size. But if + -- we have two types the same (notably Short_Float_Size = Float_Size + -- which is close to universally true, and Long_Long_Float_Size = + -- Long_Float_Size, true on most targets except the x86), then we + -- would really rather use the root type, so that if people want to + -- fiddle with System.Stream_Attributes to get inter-target portable + -- streams, they get the size they expect. Consider in particular the + -- case of a stream written on an x86, with 96-bit Long_Long_Float + -- being read into a non-x86 target with 64 bit Long_Long_Float. A + -- special version of System.Stream_Attributes can deal with this + -- provided the proper type is always used. + + -- To deal with these two requirements we add the special checks + -- on equal sizes and use the root type to distinguish. + + if P_Size <= Standard_Short_Float_Size + and then (Standard_Short_Float_Size /= Standard_Float_Size + or else Rt_Type = Standard_Short_Float) + then + Lib_RE := RE_W_SF; + + elsif P_Size <= Standard_Float_Size then + Lib_RE := RE_W_F; + + elsif P_Size <= Standard_Long_Float_Size + and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size + or else Rt_Type = Standard_Long_Float) + then + Lib_RE := RE_W_LF; + + else + 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, the representation is also unsigned if we have: + + -- type W is range -1 .. +254; + -- for W'Size use 8; + + -- forcing a biased and unsigned representation + + 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 + Out_Formal : Node_Id; + -- Expression denoting the out formal parameter + + Dcls : constant List_Id := New_List; + -- Declarations for the 'Read body + + Stms : constant List_Id := New_List; + -- Statements for the 'Read body + + Disc : Entity_Id; + -- Entity of the discriminant being processed + + Tmp_For_Disc : Entity_Id; + -- Temporary object used to read the value of Disc + + Tmps_For_Discs : constant List_Id := New_List; + -- List of object declarations for temporaries holding the read values + -- for the discriminants. + + Cstr : constant List_Id := New_List; + -- List of constraints to be applied on temporary record + + Discriminant_Checks : constant List_Id := New_List; + -- List of discriminant checks to be performed if the actual object + -- is constrained. + + Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V); + -- Temporary record must hide formal (assignments to components of the + -- record are always generated with V as the identifier for the record). + + Constrained_Stms : List_Id := New_List; + -- Statements within the block where we have the constrained temporary + + begin + -- A mutable type cannot be a tagged type, so we generate a new name + -- for the stream procedure. + + Pnam := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read)); + + if Is_Unchecked_Union (Typ) then + + -- If this is an unchecked union, the stream procedure is erroneous, + -- because there are no discriminants to read. + + -- This should generate a warning ??? + + Append_To (Stms, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + + Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => True); + return; + end if; + + Disc := First_Discriminant (Typ); + + Out_Formal := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pnam, Loc), + Selector_Name => Make_Identifier (Loc, Name_V)); + + -- Generate Reads for the discriminants of the type. The discriminants + -- need to be read before the rest of the components, so that variants + -- are initialized correctly. The discriminants must be read into temp + -- variables so an incomplete Read (interrupted by an exception, for + -- example) does not alter the passed object. + + while Present (Disc) loop + Tmp_For_Disc := Make_Defining_Identifier (Loc, + New_External_Name (Chars (Disc), "D")); + + Append_To (Tmps_For_Discs, + Make_Object_Declaration (Loc, + Defining_Identifier => Tmp_For_Disc, + Object_Definition => New_Occurrence_Of (Etype (Disc), Loc))); + Set_No_Initialization (Last (Tmps_For_Discs)); + + 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), + New_Occurrence_Of (Tmp_For_Disc, Loc)))); + + Append_To (Cstr, + Make_Discriminant_Association (Loc, + Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)), + Expression => New_Occurrence_Of (Tmp_For_Disc, Loc))); + + Append_To (Discriminant_Checks, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Tmp_For_Disc, Loc), + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Out_Formal), + Selector_Name => New_Occurrence_Of (Disc, Loc))), + Reason => CE_Discriminant_Check_Failed)); + Next_Discriminant (Disc); + end loop; + + -- Generate reads for the components of the record (including those + -- that depend on discriminants). + + Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); + + -- Save original statement sequence for component assignments, and + -- replace it with Stms. + + Constrained_Stms := Statements (Handled_Statement_Sequence (Decl)); + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + + -- If Typ has controlled components (i.e. if it is classwide + -- or Has_Controlled), or components constrained using the discriminants + -- of Typ, then we need to ensure that all component assignments + -- are performed on an object that has been appropriately constrained + -- prior to being initialized. To this effect, we wrap the component + -- assignments in a block where V is a constrained temporary. + + Append_To (Dcls, + Make_Object_Declaration (Loc, + Defining_Identifier => Tmp, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Cstr)))); + + -- AI05-023-1: Insert discriminant check prior to initialization of the + -- constrained temporary. + + Append_To (Stms, + Make_Implicit_If_Statement (Pnam, + Condition => + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Out_Formal), + Attribute_Name => Name_Constrained), + Then_Statements => Discriminant_Checks)); + + -- Now insert back original component assignments, wrapped in a block + -- in which V is the constrained temporary. + + Append_To (Stms, + Make_Block_Statement (Loc, + Declarations => Dcls, + Handled_Statement_Sequence => Parent (Constrained_Stms))); + + Append_To (Constrained_Stms, + Make_Assignment_Statement (Loc, + Name => Out_Formal, + Expression => Make_Identifier (Loc, Name_V))); + + Set_Declarations (Decl, Tmps_For_Discs); + 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; + D_Ref : Node_Id; + + begin + Stms := New_List; + Disc := First_Discriminant (Typ); + + -- Generate Writes for the discriminants of the type + -- If the type is an unchecked union, use the default values of + -- the discriminants, because they are not stored. + + while Present (Disc) loop + if Is_Unchecked_Union (Typ) then + D_Ref := + New_Copy_Tree (Discriminant_Default_Value (Disc)); + else + D_Ref := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + end if; + + 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), + D_Ref))); + + 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 => Make_TSS_Name_Local (Typ, TSS_Stream_Write)); + 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 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'Read (S, C1); + -- C2 : constant Disc_Type_2; + -- Discr_Type_2'Read (S, C2); + -- ... + -- Cn : constant Disc_Type_n; + -- Discr_Type_n'Read (S, Cn); + -- 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 + B_Typ : constant Entity_Id := Base_Type (Typ); + Cn : Name_Id; + Constr : List_Id; + Decls : List_Id; + Discr : Entity_Id; + Discr_Elmt : Elmt_Id := No_Elmt; + J : Pos; + Obj_Decl : Node_Id; + Odef : Node_Id; + Stms : List_Id; + + begin + Decls := New_List; + Constr := New_List; + + J := 1; + + if Has_Discriminants (B_Typ) then + Discr := First_Discriminant (B_Typ); + + -- If the prefix subtype is constrained, then retrieve the first + -- element of its constraint. + + if Is_Constrained (Typ) then + Discr_Elmt := First_Elmt (Discriminant_Constraint (Typ)); + end if; + + while Present (Discr) loop + Cn := New_External_Name ('C', J); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Cn), + Object_Definition => + New_Occurrence_Of (Etype (Discr), Loc)); + + -- If this is an access discriminant, do not perform default + -- initialization. The discriminant is about to get its value + -- from Read, and if the type is null excluding we do not want + -- spurious warnings on an initial null value. + + if Is_Access_Type (Etype (Discr)) then + Set_No_Initialization (Decl); + end if; + + Append_To (Decls, Decl); + Append_To (Decls, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etype (Discr), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Cn)))); + + Append_To (Constr, Make_Identifier (Loc, Cn)); + + -- If the prefix subtype imposes a discriminant constraint, then + -- check that each discriminant value equals the value read. + + if Present (Discr_Elmt) then + Append_To (Decls, + Make_Raise_Constraint_Error (Loc, + Condition => Make_Op_Ne (Loc, + Left_Opnd => + New_Reference_To + (Defining_Identifier (Decl), Loc), + Right_Opnd => + New_Copy_Tree (Node (Discr_Elmt))), + Reason => CE_Discriminant_Check_Failed)); + + Next_Elmt (Discr_Elmt); + end if; + + Next_Discriminant (Discr); + J := J + 1; + end loop; + + Odef := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (B_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 (B_Typ, Loc); + end if; + + -- Create an extended return statement encapsulating the result object + -- and 'Read call, which is needed in general for proper handling of + -- build-in-place results (such as when the result type is inherently + -- limited). + + Obj_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Object_Definition => Odef); + + -- If the type is an access type, do not perform default initialization. + -- The object is about to get its value from Read, and if the type is + -- null excluding we do not want spurious warnings on an initial null. + + if Is_Access_Type (B_Typ) then + Set_No_Initialization (Obj_Decl); + end if; + + Stms := New_List ( + Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Obj_Decl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (B_Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))))))); + + Fnam := Make_Stream_Subprogram_Name (Loc, B_Typ, TSS_Stream_Input); + + Build_Stream_Function (Loc, B_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; + Disc_Ref : Node_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 + + -- If the type is an unchecked union, it must have default + -- discriminants (this is checked earlier), and those defaults + -- are written out to the stream. + + if Is_Unchecked_Union (Typ) then + Disc_Ref := New_Copy_Tree (Discriminant_Default_Value (Disc)); + + else + Disc_Ref := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + end if; + + 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), + Disc_Ref))); + + 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)))); + + Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output); + + 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 + Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read); + 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; + + In_Limited_Extension : Boolean := False; + -- Set to True while processing the record extension definition + -- for an extension of a limited type (for which an ancestor type + -- has an explicit Nam attribute definition). + + 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; + D_Ref : Node_Id; + + begin + Result := Make_Field_Attributes (CI); + + if Present (VP) then + Alts := New_List; + + V := First_Non_Pragma (Variants (VP)); + 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. + + -- If the enclosing record is an unchecked_union, we use the + -- default expressions for the discriminant (it must exist) + -- because we cannot generate a reference to it, given that + -- it is not stored. + + if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then + D_Ref := + New_Copy_Tree + (Discriminant_Default_Value (Entity (Name (VP)))); + else + D_Ref := + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Selector_Name => + New_Occurrence_Of (Entity (Name (VP)), Loc)); + end if; + + Append_To (Result, + Make_Case_Statement (Loc, + Expression => D_Ref, + 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 + Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C)); + + TSS_Names : constant array (Name_Input .. Name_Write) of + TSS_Name_Type := + (Name_Read => TSS_Stream_Read, + Name_Write => TSS_Stream_Write, + Name_Input => TSS_Stream_Input, + Name_Output => TSS_Stream_Output, + others => TSS_Null); + pragma Assert (TSS_Names (Nam) /= TSS_Null); + + begin + if In_Limited_Extension + and then Is_Limited_Type (Field_Typ) + and then No (Find_Inherited_TSS (Field_Typ, TSS_Names (Nam))) + then + -- The declaration is illegal per 13.13.2(9/1), and this is + -- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the caller + -- happy by returning a null statement. + + return Make_Null_Statement (Loc); + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Field_Typ, 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. If _Parent is an interface type, being abstract + -- with no components there is no need to handle it. + + while Present (Item) loop + if Nkind (Item) = N_Component_Declaration + and then + ((Chars (Defining_Identifier (Item)) = Name_uParent + and then not Is_Interface + (Etype (Defining_Identifier (Item)))) + 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 (Base_Type (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); + + if Is_Limited_Type (Typt) then + In_Limited_Extension := True; + end if; + 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 + Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write); + 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 : TSS_Name_Type) return List_Id + is + Profile : List_Id; + + begin + -- (Ada 2005: AI-441): Set the null-excluding attribute because it has + -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005. + + Profile := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), + Parameter_Type => + Make_Access_Definition (Loc, + Null_Exclusion_Present => True, + Subtype_Mark => New_Reference_To ( + Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))); + + if Nam /= TSS_Stream_Input then + Append_To (Profile, + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), + Out_Present => (Nam = TSS_Stream_Read), + 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 + + -- (Ada 2005: AI-441): Set the null-excluding attribute because it has + -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005. + + 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, + Null_Exclusion_Present => True, + Subtype_Mark => New_Reference_To ( + Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))), + + Result_Definition => 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 + + -- (Ada 2005: AI-441): Set the null-excluding attribute because it has + -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005. + + 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, + Null_Exclusion_Present => True, + 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 + Siz : Uint; + + begin + if Has_Non_Standard_Rep (U_Type) then + return False; + end if; + + if Has_Stream_Size_Clause (U_Type) then + Siz := Static_Integer (Expression (Stream_Size_Clause (U_Type))); + else + Siz := Esize (First_Subtype (U_Type)); + end if; + + return Siz = Esize (Root_Type (U_Type)); + end Has_Stream_Standard_Rep; + + --------------------------------- + -- Make_Stream_Subprogram_Name -- + --------------------------------- + + function Make_Stream_Subprogram_Name + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : TSS_Name_Type) return Entity_Id + is + Sname : Name_Id; + + begin + -- For tagged types, we are dealing with a TSS associated with the + -- declaration, so we use the standard primitive function name. For + -- other types, generate a local TSS name since we are generating + -- the subprogram at the point of use. + + if Is_Tagged_Type (Typ) then + Sname := Make_TSS_Name (Typ, Nam); + else + Sname := Make_TSS_Name_Local (Typ, Nam); + end if; + + return Make_Defining_Identifier (Loc, Sname); + end Make_Stream_Subprogram_Name; + + ---------------------- + -- 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; |