URL https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [exp_strm.adb] - Blame information for rev 848

Go to most recent revision | Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         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;
Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [exp_strm.adb] - Blame information for rev 848

Line No.	Rev	Author	Line
1	706	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- E X P _ S T R M --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING3. If not, go to --`
19			`-- http://www.gnu.org/licenses for a complete copy of the license. --`
20			`-- --`
21			`-- GNAT was originally developed by the GNAT team at New York University. --`
22			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
23			`-- --`
24			`------------------------------------------------------------------------------`
25
26			`with Atree; use Atree;`
27			`with Einfo; use Einfo;`
28			`with Elists; use Elists;`
29			`with Exp_Util; use Exp_Util;`
30			`with Namet; use Namet;`
31			`with Nlists; use Nlists;`
32			`with Nmake; use Nmake;`
33			`with Rtsfind; use Rtsfind;`
34			`with Sem_Aux; use Sem_Aux;`
35			`with Sem_Util; use Sem_Util;`
36			`with Sinfo; use Sinfo;`
37			`with Snames; use Snames;`
38			`with Stand; use Stand;`
39			`with Tbuild; use Tbuild;`
40			`with Ttypes; use Ttypes;`