aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.3/gcc/ada/exp_strm.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.3/gcc/ada/exp_strm.adb')
-rw-r--r--gcc-4.4.3/gcc/ada/exp_strm.adb1746
1 files changed, 0 insertions, 1746 deletions
diff --git a/gcc-4.4.3/gcc/ada/exp_strm.adb b/gcc-4.4.3/gcc/ada/exp_strm.adb
deleted file mode 100644
index d0b1b7f43..000000000
--- a/gcc-4.4.3/gcc/ada/exp_strm.adb
+++ /dev/null
@@ -1,1746 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- E X P _ S T R M --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2008, 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 Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Rtsfind; use Rtsfind;
-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;
- 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_Simple_Return_Statement (Loc,
- Expression => Make_Identifier (Loc, Name_V)));
-
- 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 : Uint;
- Res : Node_Id;
- Lib_RE : RE_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;
-
- -- 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)
- 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 : 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
-
- Disc := First_Discriminant (Typ);
-
- -- 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));
-
- 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 temporary 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);
-
- -- 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))));
-
- Constrained_Stms := Statements (Handled_Statement_Sequence (Decl));
- Append_To (Stms,
- Make_Block_Statement (Loc,
- Declarations => Dcls,
- Handled_Statement_Sequence => Parent (Constrained_Stms)));
-
- Append_To (Constrained_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));
-
- Append_To (Constrained_Stms,
- Make_Assignment_Statement (Loc,
- Name => Out_Formal,
- Expression => Make_Identifier (Loc, Name_V)));
-
- 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 ???
-
- Stms :=
- New_List (
- Make_Raise_Program_Error (Loc,
- Reason => PE_Unchecked_Union_Restriction));
- end if;
-
- Set_Declarations (Decl, Tmps_For_Discs);
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stms));
- 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
- Cn : Name_Id;
- J : Pos;
- Decls : List_Id;
- Constr : List_Id;
- Obj_Decl : Node_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);
-
- 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));
-
- 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;
-
- -- For Ada 2005 we 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).
-
- -- Perhaps we should just generate an extended return in all cases???
-
- 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 (Typ) then
- Set_No_Initialization (Obj_Decl);
- end if;
-
- if Ada_Version >= Ada_05 then
- Stms := New_List (
- Make_Extended_Return_Statement (Loc,
- Return_Object_Declarations => New_List (Obj_Decl),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- 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)))))));
-
- else
- Append_To (Decls, Obj_Decl);
-
- 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_Simple_Return_Statement (Loc,
- Expression => Make_Identifier (Loc, Name_V)));
- end if;
-
- Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
-
- 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;
- 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 Ada2005.
-
- 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 Ada2005.
-
- 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 Ada2005.
-
- 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;