gcc/ada/exp_strm.adb

   1 ------------------------------------------------------------------------------
   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-2008, 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 Namet;    use Namet;
  29 with Nlists;   use Nlists;
  30 with Nmake;    use Nmake;
  31 with Opt;      use Opt;
  32 with Rtsfind;  use Rtsfind;
  33 with Sem_Aux;  use Sem_Aux;
  34 with Sem_Util; use Sem_Util;
  35 with Sinfo;    use Sinfo;
  36 with Snames;   use Snames;
  37 with Stand;    use Stand;
  38 with Tbuild;   use Tbuild;
  39 with Ttypes;   use Ttypes;
  40 with Uintp;    use Uintp;
  41
  42 package body Exp_Strm is
  43
  44    -----------------------
  45    -- Local Subprograms --
  46    -----------------------
  47
  48    procedure Build_Array_Read_Write_Procedure
  49      (Nod  : Node_Id;
  50       Typ  : Entity_Id;
  51       Decl : out Node_Id;
  52       Pnam : Entity_Id;
  53       Nam  : Name_Id);
  54    --  Common routine shared to build either an array Read procedure or an
  55    --  array Write procedure, Nam is Name_Read or Name_Write to select which.
  56    --  Pnam is the defining identifier for the constructed procedure. The
  57    --  other parameters are as for Build_Array_Read_Procedure except that
  58    --  the first parameter Nod supplies the Sloc to be used to generate code.
  59
  60    procedure Build_Record_Read_Write_Procedure
  61      (Loc  : Source_Ptr;
  62       Typ  : Entity_Id;
  63       Decl : out Node_Id;
  64       Pnam : Entity_Id;
  65       Nam  : Name_Id);
  66    --  Common routine shared to build a record Read Write procedure, Nam
  67    --  is Name_Read or Name_Write to select which. Pnam is the defining
  68    --  identifier for the constructed procedure. The other parameters are
  69    --  as for Build_Record_Read_Procedure.
  70
  71    procedure Build_Stream_Function
  72      (Loc   : Source_Ptr;
  73       Typ   : Entity_Id;
  74       Decl  : out Node_Id;
  75       Fnam  : Entity_Id;
  76       Decls : List_Id;
  77       Stms  : List_Id);
  78    --  Called to build an array or record stream function. The first three
  79    --  arguments are the same as Build_Record_Or_Elementary_Input_Function.
  80    --  Decls and Stms are the declarations and statements for the body and
  81    --  The parameter Fnam is the name of the constructed function.
  82
  83    function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean;
  84    --  This function is used to test the type U_Type, to determine if it has
  85    --  a standard representation from a streaming point of view. Standard means
  86    --  that it has a standard representation (e.g. no enumeration rep clause),
  87    --  and the size of the root type is the same as the streaming size (which
  88    --  is defined as value specified by a Stream_Size clause if present, or
  89    --  the Esize of U_Type if not).
  90
  91    function Make_Stream_Subprogram_Name
  92      (Loc : Source_Ptr;
  93       Typ : Entity_Id;
  94       Nam : TSS_Name_Type) return Entity_Id;
  95    --  Return the entity that identifies the stream subprogram for type Typ
  96    --  that is identified by the given Nam. This procedure deals with the
  97    --  difference between tagged types (where a single subprogram associated
  98    --  with the type is generated) and all other cases (where a subprogram
  99    --  is generated at the point of the stream attribute reference). The
 100    --  Loc parameter is used as the Sloc of the created entity.
 101
 102    function Stream_Base_Type (E : Entity_Id) return Entity_Id;
 103    --  Stream attributes work on the basis of the base type except for the
 104    --  array case. For the array case, we do not go to the base type, but
 105    --  to the first subtype if it is constrained. This avoids problems with
 106    --  incorrect conversions in the packed array case. Stream_Base_Type is
 107    --  exactly this function (returns the base type, unless we have an array
 108    --  type whose first subtype is constrained, in which case it returns the
 109    --  first subtype).
 110
 111    --------------------------------
 112    -- Build_Array_Input_Function --
 113    --------------------------------
 114
 115    --  The function we build looks like
 116
 117    --    function typSI[_nnn] (S : access RST) return Typ is
 118    --      L1 : constant Index_Type_1 := Index_Type_1'Input (S);
 119    --      H1 : constant Index_Type_1 := Index_Type_1'Input (S);
 120    --      L2 : constant Index_Type_2 := Index_Type_2'Input (S);
 121    --      H2 : constant Index_Type_2 := Index_Type_2'Input (S);
 122    --      ..
 123    --      Ln : constant Index_Type_n := Index_Type_n'Input (S);
 124    --      Hn : constant Index_Type_n := Index_Type_n'Input (S);
 125    --
 126    --      V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn)
 127
 128    --    begin
 129    --      Typ'Read (S, V);
 130    --      return V;
 131    --    end typSI[_nnn]
 132
 133    --  Note: the suffix [_nnn] is present for non-tagged types, where we
 134    --  generate a local subprogram at the point of the occurrence of the
 135    --  attribute reference, so the name must be unique.
 136
 137    procedure Build_Array_Input_Function
 138      (Loc  : Source_Ptr;
 139       Typ  : Entity_Id;
 140       Decl : out Node_Id;
 141       Fnam : out Entity_Id)
 142    is
 143       Dim    : constant Pos := Number_Dimensions (Typ);
 144       Lnam   : Name_Id;
 145       Hnam   : Name_Id;
 146       Decls  : List_Id;
 147       Ranges : List_Id;
 148       Stms   : List_Id;
 149       Indx   : Node_Id;
 150
 151    begin
 152       Decls := New_List;
 153       Ranges := New_List;
 154       Indx  := First_Index (Typ);
 155
 156       for J in 1 .. Dim loop
 157          Lnam := New_External_Name ('L', J);
 158          Hnam := New_External_Name ('H', J);
 159
 160          Append_To (Decls,
 161            Make_Object_Declaration (Loc,
 162              Defining_Identifier => Make_Defining_Identifier (Loc, Lnam),
 163              Constant_Present    => True,
 164              Object_Definition   => New_Occurrence_Of (Etype (Indx), Loc),
 165              Expression =>
 166                Make_Attribute_Reference (Loc,
 167                  Prefix =>
 168                    New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
 169                  Attribute_Name => Name_Input,
 170                  Expressions => New_List (Make_Identifier (Loc, Name_S)))));
 171
 172          Append_To (Decls,
 173            Make_Object_Declaration (Loc,
 174              Defining_Identifier => Make_Defining_Identifier (Loc, Hnam),
 175              Constant_Present    => True,
 176              Object_Definition   =>
 177                    New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
 178              Expression =>
 179                Make_Attribute_Reference (Loc,
 180                  Prefix =>
 181                    New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
 182                  Attribute_Name => Name_Input,
 183                  Expressions => New_List (Make_Identifier (Loc, Name_S)))));
 184
 185          Append_To (Ranges,
 186            Make_Range (Loc,
 187              Low_Bound  => Make_Identifier (Loc, Lnam),
 188              High_Bound => Make_Identifier (Loc, Hnam)));
 189
 190          Next_Index (Indx);
 191       end loop;
 192
 193       --  If the first subtype is constrained, use it directly. Otherwise
 194       --  build a subtype indication with the proper bounds.
 195
 196       if Is_Constrained (Stream_Base_Type (Typ)) then
 197          Append_To (Decls,
 198            Make_Object_Declaration (Loc,
 199              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
 200              Object_Definition =>
 201                New_Occurrence_Of (Stream_Base_Type (Typ), Loc)));
 202       else
 203          Append_To (Decls,
 204            Make_Object_Declaration (Loc,
 205              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
 206              Object_Definition =>
 207                Make_Subtype_Indication (Loc,
 208                  Subtype_Mark =>
 209                    New_Occurrence_Of (Stream_Base_Type (Typ), Loc),
 210                  Constraint =>
 211                    Make_Index_Or_Discriminant_Constraint (Loc,
 212                      Constraints => Ranges))));
 213       end if;
 214
 215       Stms := New_List (
 216          Make_Attribute_Reference (Loc,
 217            Prefix => New_Occurrence_Of (Typ, Loc),
 218            Attribute_Name => Name_Read,
 219            Expressions => New_List (
 220              Make_Identifier (Loc, Name_S),
 221              Make_Identifier (Loc, Name_V))),
 222
 223          Make_Simple_Return_Statement (Loc,
 224            Expression => Make_Identifier (Loc, Name_V)));
 225
 226       Fnam :=
 227         Make_Defining_Identifier (Loc,
 228           Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input));
 229
 230       Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
 231    end Build_Array_Input_Function;
 232
 233    ----------------------------------
 234    -- Build_Array_Output_Procedure --
 235    ----------------------------------
 236
 237    procedure Build_Array_Output_Procedure
 238      (Loc  : Source_Ptr;
 239       Typ  : Entity_Id;
 240       Decl : out Node_Id;
 241       Pnam : out Entity_Id)
 242    is
 243       Stms : List_Id;
 244       Indx : Node_Id;
 245
 246    begin
 247       --  Build series of statements to output bounds
 248
 249       Indx := First_Index (Typ);
 250       Stms := New_List;
 251
 252       for J in 1 .. Number_Dimensions (Typ) loop
 253          Append_To (Stms,
 254            Make_Attribute_Reference (Loc,
 255              Prefix =>
 256                New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
 257              Attribute_Name => Name_Write,
 258              Expressions => New_List (
 259                Make_Identifier (Loc, Name_S),
 260                Make_Attribute_Reference (Loc,
 261                  Prefix => Make_Identifier (Loc, Name_V),
 262                  Attribute_Name => Name_First,
 263                  Expressions => New_List (
 264                    Make_Integer_Literal (Loc, J))))));
 265
 266          Append_To (Stms,
 267            Make_Attribute_Reference (Loc,
 268              Prefix =>
 269                New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
 270              Attribute_Name => Name_Write,
 271              Expressions => New_List (
 272                Make_Identifier (Loc, Name_S),
 273                Make_Attribute_Reference (Loc,
 274                  Prefix => Make_Identifier (Loc, Name_V),
 275                  Attribute_Name => Name_Last,
 276                  Expressions => New_List (
 277                    Make_Integer_Literal (Loc, J))))));
 278
 279          Next_Index (Indx);
 280       end loop;
 281
 282       --  Append Write attribute to write array elements
 283
 284       Append_To (Stms,
 285         Make_Attribute_Reference (Loc,
 286           Prefix => New_Occurrence_Of (Typ, Loc),
 287           Attribute_Name => Name_Write,
 288           Expressions => New_List (
 289             Make_Identifier (Loc, Name_S),
 290             Make_Identifier (Loc, Name_V))));
 291
 292       Pnam :=
 293         Make_Defining_Identifier (Loc,
 294           Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output));
 295
 296       Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
 297    end Build_Array_Output_Procedure;
 298
 299    --------------------------------
 300    -- Build_Array_Read_Procedure --
 301    --------------------------------
 302
 303    procedure Build_Array_Read_Procedure
 304      (Nod  : Node_Id;
 305       Typ  : Entity_Id;
 306       Decl : out Node_Id;
 307       Pnam : out Entity_Id)
 308    is
 309       Loc : constant Source_Ptr := Sloc (Nod);
 310
 311    begin
 312       Pnam :=
 313         Make_Defining_Identifier (Loc,
 314           Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
 315       Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read);
 316    end Build_Array_Read_Procedure;
 317
 318    --------------------------------------
 319    -- Build_Array_Read_Write_Procedure --
 320    --------------------------------------
 321
 322    --  The form of the array read/write procedure is as follows:
 323
 324    --    procedure pnam (S : access RST, V : [out] Typ) is
 325    --    begin
 326    --       for L1 in V'Range (1) loop
 327    --          for L2 in V'Range (2) loop
 328    --             ...
 329    --                for Ln in V'Range (n) loop
 330    --                   Component_Type'Read/Write (S, V (L1, L2, .. Ln));
 331    --                end loop;
 332    --             ..
 333    --          end loop;
 334    --       end loop
 335    --    end pnam;
 336
 337    --  The out keyword for V is supplied in the Read case
 338
 339    procedure Build_Array_Read_Write_Procedure
 340      (Nod  : Node_Id;
 341       Typ  : Entity_Id;
 342       Decl : out Node_Id;
 343       Pnam : Entity_Id;
 344       Nam  : Name_Id)
 345    is
 346       Loc  : constant Source_Ptr := Sloc (Nod);
 347       Ndim : constant Pos        := Number_Dimensions (Typ);
 348       Ctyp : constant Entity_Id  := Component_Type (Typ);
 349
 350       Stm  : Node_Id;
 351       Exl  : List_Id;
 352       RW   : Entity_Id;
 353
 354    begin
 355       --  First build the inner attribute call
 356
 357       Exl := New_List;
 358
 359       for J in 1 .. Ndim loop
 360          Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', J)));
 361       end loop;
 362
 363       Stm :=
 364         Make_Attribute_Reference (Loc,
 365           Prefix => New_Occurrence_Of (Stream_Base_Type (Ctyp), Loc),
 366           Attribute_Name => Nam,
 367           Expressions => New_List (
 368             Make_Identifier (Loc, Name_S),
 369             Make_Indexed_Component (Loc,
 370               Prefix => Make_Identifier (Loc, Name_V),
 371               Expressions => Exl)));
 372
 373       --  The corresponding stream attribute for the component type of the
 374       --  array may be user-defined, and be frozen after the type for which
 375       --  we are generating the stream subprogram. In that case, freeze the
 376       --  stream attribute of the component type, whose declaration could not
 377       --  generate any additional freezing actions in any case.
 378
 379       if Nam = Name_Read then
 380          RW := TSS (Base_Type (Ctyp), TSS_Stream_Read);
 381       else
 382          RW := TSS (Base_Type (Ctyp), TSS_Stream_Write);
 383       end if;
 384
 385       if Present (RW)
 386         and then not Is_Frozen (RW)
 387       then
 388          Set_Is_Frozen (RW);
 389       end if;
 390
 391       --  Now this is the big loop to wrap that statement up in a sequence
 392       --  of loops. The first time around, Stm is the attribute call. The
 393       --  second and subsequent times, Stm is an inner loop.
 394
 395       for J in 1 .. Ndim loop
 396          Stm :=
 397            Make_Implicit_Loop_Statement (Nod,
 398              Iteration_Scheme =>
 399                Make_Iteration_Scheme (Loc,
 400                  Loop_Parameter_Specification =>
 401                    Make_Loop_Parameter_Specification (Loc,
 402                      Defining_Identifier =>
 403                        Make_Defining_Identifier (Loc,
 404                          Chars => New_External_Name ('L', Ndim - J + 1)),
 405
 406                      Discrete_Subtype_Definition =>
 407                        Make_Attribute_Reference (Loc,
 408                          Prefix => Make_Identifier (Loc, Name_V),
 409                          Attribute_Name => Name_Range,
 410
 411                          Expressions => New_List (
 412                            Make_Integer_Literal (Loc, Ndim - J + 1))))),
 413
 414              Statements => New_List (Stm));
 415
 416       end loop;
 417
 418       Build_Stream_Procedure
 419         (Loc, Typ, Decl, Pnam, New_List (Stm), Nam = Name_Read);
 420    end Build_Array_Read_Write_Procedure;
 421
 422    ---------------------------------
 423    -- Build_Array_Write_Procedure --
 424    ---------------------------------
 425
 426    procedure Build_Array_Write_Procedure
 427      (Nod  : Node_Id;
 428       Typ  : Entity_Id;
 429       Decl : out Node_Id;
 430       Pnam : out Entity_Id)
 431    is
 432       Loc : constant Source_Ptr := Sloc (Nod);
 433
 434    begin
 435       Pnam :=
 436         Make_Defining_Identifier (Loc,
 437           Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
 438       Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write);
 439    end Build_Array_Write_Procedure;
 440
 441    ---------------------------------
 442    -- Build_Elementary_Input_Call --
 443    ---------------------------------
 444
 445    function Build_Elementary_Input_Call (N : Node_Id) return Node_Id is
 446       Loc     : constant Source_Ptr := Sloc (N);
 447       P_Type  : constant Entity_Id  := Entity (Prefix (N));
 448       U_Type  : constant Entity_Id  := Underlying_Type (P_Type);
 449       Rt_Type : constant Entity_Id  := Root_Type (U_Type);
 450       FST     : constant Entity_Id  := First_Subtype (U_Type);
 451       Strm    : constant Node_Id    := First (Expressions (N));
 452       Targ    : constant Node_Id    := Next (Strm);
 453       P_Size  : Uint;
 454       Res     : Node_Id;
 455       Lib_RE  : RE_Id;
 456
 457    begin
 458       --  Compute the size of the stream element. This is either the size of
 459       --  the first subtype or if given the size of the Stream_Size attribute.
 460
 461       if Has_Stream_Size_Clause (FST) then
 462          P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
 463       else
 464          P_Size := Esize (FST);
 465       end if;
 466
 467       --  Check first for Boolean and Character. These are enumeration types,
 468       --  but we treat them specially, since they may require special handling
 469       --  in the transfer protocol. However, this special handling only applies
 470       --  if they have standard representation, otherwise they are treated like
 471       --  any other enumeration type.
 472
 473       if Rt_Type = Standard_Boolean
 474         and then Has_Stream_Standard_Rep (U_Type)
 475       then
 476          Lib_RE := RE_I_B;
 477
 478       elsif Rt_Type = Standard_Character
 479         and then Has_Stream_Standard_Rep (U_Type)
 480       then
 481          Lib_RE := RE_I_C;
 482
 483       elsif Rt_Type = Standard_Wide_Character
 484         and then Has_Stream_Standard_Rep (U_Type)
 485       then
 486          Lib_RE := RE_I_WC;
 487
 488       elsif Rt_Type = Standard_Wide_Wide_Character
 489         and then Has_Stream_Standard_Rep (U_Type)
 490       then
 491          Lib_RE := RE_I_WWC;
 492
 493       --  Floating point types
 494
 495       elsif Is_Floating_Point_Type (U_Type) then
 496
 497          --  Question: should we use P_Size or Rt_Type to distinguish between
 498          --  possible floating point types? If a non-standard size or a stream
 499          --  size is specified, then we should certainly use the size. But if
 500          --  we have two types the same (notably Short_Float_Size = Float_Size
 501          --  which is close to universally true, and Long_Long_Float_Size =
 502          --  Long_Float_Size, true on most targets except the x86), then we
 503          --  would really rather use the root type, so that if people want to
 504          --  fiddle with System.Stream_Attributes to get inter-target portable
 505          --  streams, they get the size they expect. Consider in particular the
 506          --  case of a stream written on an x86, with 96-bit Long_Long_Float
 507          --  being read into a non-x86 target with 64 bit Long_Long_Float. A
 508          --  special version of System.Stream_Attributes can deal with this
 509          --  provided the proper type is always used.
 510
 511          --  To deal with these two requirements we add the special checks
 512          --  on equal sizes and use the root type to distinguish.
 513
 514          if P_Size <= Standard_Short_Float_Size
 515            and then (Standard_Short_Float_Size /= Standard_Float_Size
 516                      or else Rt_Type = Standard_Short_Float)
 517          then
 518             Lib_RE := RE_I_SF;
 519
 520          elsif P_Size <= Standard_Float_Size then
 521             Lib_RE := RE_I_F;
 522
 523          elsif P_Size <= Standard_Long_Float_Size
 524            and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size
 525                        or else Rt_Type = Standard_Long_Float)
 526          then
 527             Lib_RE := RE_I_LF;
 528
 529          else
 530             Lib_RE := RE_I_LLF;
 531          end if;
 532
 533       --  Signed integer types. Also includes signed fixed-point types and
 534       --  enumeration types with a signed representation.
 535
 536       --  Note on signed integer types. We do not consider types as signed for
 537       --  this purpose if they have no negative numbers, or if they have biased
 538       --  representation. The reason is that the value in either case basically
 539       --  represents an unsigned value.
 540
 541       --  For example, consider:
 542
 543       --     type W is range 0 .. 2**32 - 1;
 544       --     for W'Size use 32;
 545
 546       --  This is a signed type, but the representation is unsigned, and may
 547       --  be outside the range of a 32-bit signed integer, so this must be
 548       --  treated as 32-bit unsigned.
 549
 550       --  Similarly, if we have
 551
 552       --     type W is range -1 .. +254;
 553       --     for W'Size use 8;
 554
 555       --  then the representation is unsigned
 556
 557       elsif not Is_Unsigned_Type (FST)
 558         and then
 559           (Is_Fixed_Point_Type (U_Type)
 560              or else
 561            Is_Enumeration_Type (U_Type)
 562              or else
 563            (Is_Signed_Integer_Type (U_Type)
 564               and then not Has_Biased_Representation (FST)))
 565       then
 566          if P_Size <= Standard_Short_Short_Integer_Size then
 567             Lib_RE := RE_I_SSI;
 568
 569          elsif P_Size <= Standard_Short_Integer_Size then
 570             Lib_RE := RE_I_SI;
 571
 572          elsif P_Size <= Standard_Integer_Size then
 573             Lib_RE := RE_I_I;
 574
 575          elsif P_Size <= Standard_Long_Integer_Size then
 576             Lib_RE := RE_I_LI;
 577
 578          else
 579             Lib_RE := RE_I_LLI;
 580          end if;
 581
 582       --  Unsigned integer types, also includes unsigned fixed-point types
 583       --  and enumeration types with an unsigned representation (note that
 584       --  we know they are unsigned because we already tested for signed).
 585
 586       --  Also includes signed integer types that are unsigned in the sense
 587       --  that they do not include negative numbers. See above for details.
 588
 589       elsif Is_Modular_Integer_Type    (U_Type)
 590         or else Is_Fixed_Point_Type    (U_Type)
 591         or else Is_Enumeration_Type    (U_Type)
 592         or else Is_Signed_Integer_Type (U_Type)
 593       then
 594          if P_Size <= Standard_Short_Short_Integer_Size then
 595             Lib_RE := RE_I_SSU;
 596
 597          elsif P_Size <= Standard_Short_Integer_Size then
 598             Lib_RE := RE_I_SU;
 599
 600          elsif P_Size <= Standard_Integer_Size then
 601             Lib_RE := RE_I_U;
 602
 603          elsif P_Size <= Standard_Long_Integer_Size then
 604             Lib_RE := RE_I_LU;
 605
 606          else
 607             Lib_RE := RE_I_LLU;
 608          end if;
 609
 610       else pragma Assert (Is_Access_Type (U_Type));
 611          if P_Size > System_Address_Size then
 612             Lib_RE := RE_I_AD;
 613          else
 614             Lib_RE := RE_I_AS;
 615          end if;
 616       end if;
 617
 618       --  Call the function, and do an unchecked conversion of the result
 619       --  to the actual type of the prefix. If the target is a discriminant,
 620       --  and we are in the body of the default implementation of a 'Read
 621       --  attribute, set target type to force a constraint check (13.13.2(35)).
 622       --  If the type of the discriminant is currently private, add another
 623       --  unchecked conversion from the full view.
 624
 625       if Nkind (Targ) = N_Identifier
 626         and then Is_Internal_Name (Chars (Targ))
 627         and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read)
 628       then
 629          Res :=
 630            Unchecked_Convert_To (Base_Type (U_Type),
 631              Make_Function_Call (Loc,
 632                Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
 633                Parameter_Associations => New_List (
 634                  Relocate_Node (Strm))));
 635
 636          Set_Do_Range_Check (Res);
 637          if Base_Type (P_Type) /= Base_Type (U_Type) then
 638             Res := Unchecked_Convert_To (Base_Type (P_Type), Res);
 639          end if;
 640
 641          return Res;
 642
 643       else
 644          return
 645            Unchecked_Convert_To (P_Type,
 646              Make_Function_Call (Loc,
 647                Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
 648                Parameter_Associations => New_List (
 649                  Relocate_Node (Strm))));
 650       end if;
 651    end Build_Elementary_Input_Call;
 652
 653    ---------------------------------
 654    -- Build_Elementary_Write_Call --
 655    ---------------------------------
 656
 657    function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is
 658       Loc     : constant Source_Ptr := Sloc (N);
 659       P_Type  : constant Entity_Id  := Entity (Prefix (N));
 660       U_Type  : constant Entity_Id  := Underlying_Type (P_Type);
 661       Rt_Type : constant Entity_Id  := Root_Type (U_Type);
 662       FST     : constant Entity_Id  := First_Subtype (U_Type);
 663       Strm    : constant Node_Id    := First (Expressions (N));
 664       Item    : constant Node_Id    := Next (Strm);
 665       P_Size  : Uint;
 666       Lib_RE  : RE_Id;
 667       Libent  : Entity_Id;
 668
 669    begin
 670       --  Compute the size of the stream element. This is either the size of
 671       --  the first subtype or if given the size of the Stream_Size attribute.
 672
 673       if Has_Stream_Size_Clause (FST) then
 674          P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
 675       else
 676          P_Size := Esize (FST);
 677       end if;
 678
 679       --  Find the routine to be called
 680
 681       --  Check for First Boolean and Character. These are enumeration types,
 682       --  but we treat them specially, since they may require special handling
 683       --  in the transfer protocol. However, this special handling only applies
 684       --  if they have standard representation, otherwise they are treated like
 685       --  any other enumeration type.
 686
 687       if Rt_Type = Standard_Boolean
 688         and then Has_Stream_Standard_Rep (U_Type)
 689       then
 690          Lib_RE := RE_W_B;
 691
 692       elsif Rt_Type = Standard_Character
 693         and then Has_Stream_Standard_Rep (U_Type)
 694       then
 695          Lib_RE := RE_W_C;
 696
 697       elsif Rt_Type = Standard_Wide_Character
 698         and then Has_Stream_Standard_Rep (U_Type)
 699       then
 700          Lib_RE := RE_W_WC;
 701
 702       elsif Rt_Type = Standard_Wide_Wide_Character
 703         and then Has_Stream_Standard_Rep (U_Type)
 704       then
 705          Lib_RE := RE_W_WWC;
 706
 707       --  Floating point types
 708
 709       elsif Is_Floating_Point_Type (U_Type) then
 710
 711          --  Question: should we use P_Size or Rt_Type to distinguish between
 712          --  possible floating point types? If a non-standard size or a stream
 713          --  size is specified, then we should certainly use the size. But if
 714          --  we have two types the same (notably Short_Float_Size = Float_Size
 715          --  which is close to universally true, and Long_Long_Float_Size =
 716          --  Long_Float_Size, true on most targets except the x86), then we
 717          --  would really rather use the root type, so that if people want to
 718          --  fiddle with System.Stream_Attributes to get inter-target portable
 719          --  streams, they get the size they expect. Consider in particular the
 720          --  case of a stream written on an x86, with 96-bit Long_Long_Float
 721          --  being read into a non-x86 target with 64 bit Long_Long_Float. A
 722          --  special version of System.Stream_Attributes can deal with this
 723          --  provided the proper type is always used.
 724
 725          --  To deal with these two requirements we add the special checks
 726          --  on equal sizes and use the root type to distinguish.
 727
 728          if P_Size <= Standard_Short_Float_Size
 729            and then (Standard_Short_Float_Size /= Standard_Float_Size
 730                       or else Rt_Type = Standard_Short_Float)
 731          then
 732             Lib_RE := RE_W_SF;
 733
 734          elsif P_Size <= Standard_Float_Size then
 735             Lib_RE := RE_W_F;
 736
 737          elsif P_Size <= Standard_Long_Float_Size
 738            and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size
 739                       or else Rt_Type = Standard_Long_Float)
 740          then
 741             Lib_RE := RE_W_LF;
 742
 743          else
 744             Lib_RE := RE_W_LLF;
 745          end if;
 746
 747       --  Signed integer types. Also includes signed fixed-point types and
 748       --  signed enumeration types share this circuitry.
 749
 750       --  Note on signed integer types. We do not consider types as signed for
 751       --  this purpose if they have no negative numbers, or if they have biased
 752       --  representation. The reason is that the value in either case basically
 753       --  represents an unsigned value.
 754
 755       --  For example, consider:
 756
 757       --     type W is range 0 .. 2**32 - 1;
 758       --     for W'Size use 32;
 759
 760       --  This is a signed type, but the representation is unsigned, and may
 761       --  be outside the range of a 32-bit signed integer, so this must be
 762       --  treated as 32-bit unsigned.
 763
 764       --  Similarly, the representation is also unsigned if we have:
 765
 766       --     type W is range -1 .. +254;
 767       --     for W'Size use 8;
 768
 769       --  forcing a biased and unsigned representation
 770
 771       elsif not Is_Unsigned_Type (FST)
 772         and then
 773           (Is_Fixed_Point_Type (U_Type)
 774              or else
 775            Is_Enumeration_Type (U_Type)
 776              or else
 777            (Is_Signed_Integer_Type (U_Type)
 778               and then not Has_Biased_Representation (FST)))
 779       then
 780          if P_Size <= Standard_Short_Short_Integer_Size then
 781             Lib_RE := RE_W_SSI;
 782          elsif P_Size <= Standard_Short_Integer_Size then
 783             Lib_RE := RE_W_SI;
 784          elsif P_Size <= Standard_Integer_Size then
 785             Lib_RE := RE_W_I;
 786          elsif P_Size <= Standard_Long_Integer_Size then
 787             Lib_RE := RE_W_LI;
 788          else
 789             Lib_RE := RE_W_LLI;
 790          end if;
 791
 792       --  Unsigned integer types, also includes unsigned fixed-point types
 793       --  and unsigned enumeration types (note we know they are unsigned
 794       --  because we already tested for signed above).
 795
 796       --  Also includes signed integer types that are unsigned in the sense
 797       --  that they do not include negative numbers. See above for details.
 798
 799       elsif Is_Modular_Integer_Type    (U_Type)
 800         or else Is_Fixed_Point_Type    (U_Type)
 801         or else Is_Enumeration_Type    (U_Type)
 802         or else Is_Signed_Integer_Type (U_Type)
 803       then
 804          if P_Size <= Standard_Short_Short_Integer_Size then
 805             Lib_RE := RE_W_SSU;
 806          elsif P_Size <= Standard_Short_Integer_Size then
 807             Lib_RE := RE_W_SU;
 808          elsif P_Size <= Standard_Integer_Size then
 809             Lib_RE := RE_W_U;
 810          elsif P_Size <= Standard_Long_Integer_Size then
 811             Lib_RE := RE_W_LU;
 812          else
 813             Lib_RE := RE_W_LLU;
 814          end if;
 815
 816       else pragma Assert (Is_Access_Type (U_Type));
 817
 818          if P_Size > System_Address_Size then
 819             Lib_RE := RE_W_AD;
 820          else
 821             Lib_RE := RE_W_AS;
 822          end if;
 823       end if;
 824
 825       --  Unchecked-convert parameter to the required type (i.e. the type of
 826       --  the corresponding parameter, and call the appropriate routine.
 827
 828       Libent := RTE (Lib_RE);
 829
 830       return
 831         Make_Procedure_Call_Statement (Loc,
 832           Name => New_Occurrence_Of (Libent, Loc),
 833           Parameter_Associations => New_List (
 834             Relocate_Node (Strm),
 835             Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))),
 836               Relocate_Node (Item))));
 837    end Build_Elementary_Write_Call;
 838
 839    -----------------------------------------
 840    -- Build_Mutable_Record_Read_Procedure --
 841    -----------------------------------------
 842
 843    procedure Build_Mutable_Record_Read_Procedure
 844      (Loc  : Source_Ptr;
 845       Typ  : Entity_Id;
 846       Decl : out Node_Id;
 847       Pnam : out Entity_Id)
 848    is
 849       Out_Formal : Node_Id;
 850       --  Expression denoting the out formal parameter
 851
 852       Dcls : constant List_Id := New_List;
 853       --  Declarations for the 'Read body
 854
 855       Stms : List_Id := New_List;
 856       --  Statements for the 'Read body
 857
 858       Disc : Entity_Id;
 859       --  Entity of the discriminant being processed
 860
 861       Tmp_For_Disc : Entity_Id;
 862       --  Temporary object used to read the value of Disc
 863
 864       Tmps_For_Discs : constant List_Id := New_List;
 865       --  List of object declarations for temporaries holding the read values
 866       --  for the discriminants.
 867
 868       Cstr : constant List_Id := New_List;
 869       --  List of constraints to be applied on temporary record
 870
 871       Discriminant_Checks : constant List_Id := New_List;
 872       --  List of discriminant checks to be performed if the actual object
 873       --  is constrained.
 874
 875       Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V);
 876       --  Temporary record must hide formal (assignments to components of the
 877       --  record are always generated with V as the identifier for the record).
 878
 879       Constrained_Stms : List_Id := New_List;
 880       --  Statements within the block where we have the constrained temporary
 881
 882    begin
 883
 884       Disc := First_Discriminant (Typ);
 885
 886       --  A mutable type cannot be a tagged type, so we generate a new name
 887       --  for the stream procedure.
 888
 889       Pnam :=
 890         Make_Defining_Identifier (Loc,
 891           Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
 892
 893       Out_Formal :=
 894         Make_Selected_Component (Loc,
 895           Prefix => New_Occurrence_Of (Pnam, Loc),
 896           Selector_Name => Make_Identifier (Loc, Name_V));
 897
 898       --  Generate Reads for the discriminants of the type. The discriminants
 899       --  need to be read before the rest of the components, so that
 900       --  variants are initialized correctly. The discriminants must be read
 901       --  into temporary variables so an incomplete Read (interrupted by an
 902       --  exception, for example) does not alter the passed object.
 903
 904       while Present (Disc) loop
 905          Tmp_For_Disc := Make_Defining_Identifier (Loc,
 906                            New_External_Name (Chars (Disc), "D"));
 907
 908          Append_To (Tmps_For_Discs,
 909            Make_Object_Declaration (Loc,
 910              Defining_Identifier => Tmp_For_Disc,
 911              Object_Definition   => New_Occurrence_Of (Etype (Disc), Loc)));
 912          Set_No_Initialization (Last (Tmps_For_Discs));
 913
 914          Append_To (Stms,
 915            Make_Attribute_Reference (Loc,
 916              Prefix => New_Occurrence_Of (Etype (Disc), Loc),
 917              Attribute_Name => Name_Read,
 918              Expressions => New_List (
 919                Make_Identifier (Loc, Name_S),
 920                New_Occurrence_Of (Tmp_For_Disc, Loc))));
 921
 922          Append_To (Cstr,
 923            Make_Discriminant_Association (Loc,
 924              Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)),
 925              Expression     => New_Occurrence_Of (Tmp_For_Disc, Loc)));
 926
 927          Append_To (Discriminant_Checks,
 928            Make_Raise_Constraint_Error (Loc,
 929              Condition =>
 930                Make_Op_Ne (Loc,
 931                  Left_Opnd  => New_Occurrence_Of (Tmp_For_Disc, Loc),
 932                  Right_Opnd =>
 933                    Make_Selected_Component (Loc,
 934                      Prefix => New_Copy_Tree (Out_Formal),
 935                      Selector_Name => New_Occurrence_Of (Disc, Loc))),
 936              Reason => CE_Discriminant_Check_Failed));
 937          Next_Discriminant (Disc);
 938       end loop;
 939
 940       --  Generate reads for the components of the record (including
 941       --  those that depend on discriminants).
 942
 943       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
 944
 945       --  If Typ has controlled components (i.e. if it is classwide
 946       --  or Has_Controlled), or components constrained using the discriminants
 947       --  of Typ, then we need to ensure that all component assignments
 948       --  are performed on an object that has been appropriately constrained
 949       --  prior to being initialized. To this effect, we wrap the component
 950       --  assignments in a block where V is a constrained temporary.
 951
 952       Append_To (Dcls,
 953         Make_Object_Declaration (Loc,
 954           Defining_Identifier => Tmp,
 955           Object_Definition   =>
 956             Make_Subtype_Indication (Loc,
 957               Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 958               Constraint =>
 959                 Make_Index_Or_Discriminant_Constraint (Loc,
 960                   Constraints => Cstr))));
 961
 962       Constrained_Stms := Statements (Handled_Statement_Sequence (Decl));
 963       Append_To (Stms,
 964         Make_Block_Statement (Loc,
 965           Declarations => Dcls,
 966           Handled_Statement_Sequence => Parent (Constrained_Stms)));
 967
 968       Append_To (Constrained_Stms,
 969         Make_Implicit_If_Statement (Pnam,
 970           Condition =>
 971             Make_Attribute_Reference (Loc,
 972               Prefix => New_Copy_Tree (Out_Formal),
 973               Attribute_Name => Name_Constrained),
 974           Then_Statements => Discriminant_Checks));
 975
 976       Append_To (Constrained_Stms,
 977         Make_Assignment_Statement (Loc,
 978           Name => Out_Formal,
 979           Expression => Make_Identifier (Loc, Name_V)));
 980
 981       if Is_Unchecked_Union (Typ) then
 982
 983          --  If this is an unchecked union, the stream procedure is erroneous,
 984          --  because there are no discriminants to read.
 985
 986          --  This should generate a warning ???
 987
 988          Stms :=
 989            New_List (
 990              Make_Raise_Program_Error (Loc,
 991                Reason => PE_Unchecked_Union_Restriction));
 992       end if;
 993
 994       Set_Declarations (Decl, Tmps_For_Discs);
 995       Set_Handled_Statement_Sequence (Decl,
 996         Make_Handled_Sequence_Of_Statements (Loc,
 997           Statements => Stms));
 998    end Build_Mutable_Record_Read_Procedure;
 999
1000    ------------------------------------------
1001    -- Build_Mutable_Record_Write_Procedure --
1002    ------------------------------------------
1003
1004    procedure Build_Mutable_Record_Write_Procedure
1005      (Loc  : Source_Ptr;
1006       Typ  : Entity_Id;
1007       Decl : out Node_Id;
1008       Pnam : out Entity_Id)
1009    is
1010       Stms  : List_Id;
1011       Disc  : Entity_Id;
1012       D_Ref : Node_Id;
1013
1014    begin
1015       Stms := New_List;
1016       Disc := First_Discriminant (Typ);
1017
1018       --  Generate Writes for the discriminants of the type
1019       --  If the type is an unchecked union, use the default values of
1020       --  the discriminants, because they are not stored.
1021
1022       while Present (Disc) loop
1023          if Is_Unchecked_Union (Typ) then
1024             D_Ref :=
1025                New_Copy_Tree (Discriminant_Default_Value (Disc));
1026          else
1027             D_Ref :=
1028               Make_Selected_Component (Loc,
1029                 Prefix => Make_Identifier (Loc, Name_V),
1030                 Selector_Name => New_Occurrence_Of (Disc, Loc));
1031          end if;
1032
1033          Append_To (Stms,
1034            Make_Attribute_Reference (Loc,
1035              Prefix => New_Occurrence_Of (Etype (Disc), Loc),
1036                Attribute_Name => Name_Write,
1037                Expressions => New_List (
1038                  Make_Identifier (Loc, Name_S),
1039                  D_Ref)));
1040
1041          Next_Discriminant (Disc);
1042       end loop;
1043
1044       --  A mutable type cannot be a tagged type, so we generate a new name
1045       --  for the stream procedure.
1046
1047       Pnam :=
1048         Make_Defining_Identifier (Loc,
1049           Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
1050       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
1051
1052       --  Write the discriminants before the rest of the components, so
1053       --  that discriminant values are properly set of variants, etc.
1054
1055       if Is_Non_Empty_List (
1056         Statements (Handled_Statement_Sequence (Decl)))
1057       then
1058          Insert_List_Before
1059             (First (Statements (Handled_Statement_Sequence (Decl))), Stms);
1060       else
1061          Set_Statements (Handled_Statement_Sequence (Decl), Stms);
1062       end if;
1063    end Build_Mutable_Record_Write_Procedure;
1064
1065    -----------------------------------------------
1066    -- Build_Record_Or_Elementary_Input_Function --
1067    -----------------------------------------------
1068
1069    --  The function we build looks like
1070
1071    --    function InputN (S : access RST) return Typ is
1072    --      C1 : constant Disc_Type_1;
1073    --      Discr_Type_1'Read (S, C1);
1074    --      C2 : constant Disc_Type_2;
1075    --      Discr_Type_2'Read (S, C2);
1076    --      ...
1077    --      Cn : constant Disc_Type_n;
1078    --      Discr_Type_n'Read (S, Cn);
1079    --      V : Typ (C1, C2, .. Cn)
1080
1081    --    begin
1082    --      Typ'Read (S, V);
1083    --      return V;
1084    --    end InputN
1085
1086    --  The discriminants are of course only present in the case of a record
1087    --  with discriminants. In the case of a record with no discriminants, or
1088    --  an elementary type, then no Cn constants are defined.
1089
1090    procedure Build_Record_Or_Elementary_Input_Function
1091      (Loc  : Source_Ptr;
1092       Typ  : Entity_Id;
1093       Decl : out Node_Id;
1094       Fnam : out Entity_Id)
1095    is
1096       Cn       : Name_Id;
1097       J        : Pos;
1098       Decls    : List_Id;
1099       Constr   : List_Id;
1100       Obj_Decl : Node_Id;
1101       Stms     : List_Id;
1102       Discr    : Entity_Id;
1103       Odef     : Node_Id;
1104
1105    begin
1106       Decls  := New_List;
1107       Constr := New_List;
1108
1109       J := 1;
1110
1111       if Has_Discriminants (Typ) then
1112          Discr := First_Discriminant (Typ);
1113
1114          while Present (Discr) loop
1115             Cn := New_External_Name ('C', J);
1116
1117             Decl :=
1118               Make_Object_Declaration (Loc,
1119                 Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
1120                 Object_Definition =>
1121                   New_Occurrence_Of (Etype (Discr), Loc));
1122
1123             --  If this is an access discriminant, do not perform default
1124             --  initialization. The discriminant is about to get its value
1125             --  from Read, and if the type is null excluding we do not want
1126             --  spurious warnings on an initial null value.
1127
1128             if Is_Access_Type (Etype (Discr)) then
1129                Set_No_Initialization (Decl);
1130             end if;
1131
1132             Append_To (Decls, Decl);
1133             Append_To (Decls,
1134               Make_Attribute_Reference (Loc,
1135                 Prefix => New_Occurrence_Of (Etype (Discr), Loc),
1136                 Attribute_Name => Name_Read,
1137                 Expressions => New_List (
1138                   Make_Identifier (Loc, Name_S),
1139                   Make_Identifier (Loc, Cn))));
1140
1141             Append_To (Constr, Make_Identifier (Loc, Cn));
1142
1143             Next_Discriminant (Discr);
1144             J := J + 1;
1145          end loop;
1146
1147          Odef :=
1148            Make_Subtype_Indication (Loc,
1149              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1150              Constraint =>
1151                Make_Index_Or_Discriminant_Constraint (Loc,
1152                  Constraints => Constr));
1153
1154       --  If no discriminants, then just use the type with no constraint
1155
1156       else
1157          Odef := New_Occurrence_Of (Typ, Loc);
1158       end if;
1159
1160       --  For Ada 2005 we create an extended return statement encapsulating
1161       --  the result object and 'Read call, which is needed in general for
1162       --  proper handling of build-in-place results (such as when the result
1163       --  type is inherently limited).
1164
1165       --  Perhaps we should just generate an extended return in all cases???
1166
1167       Obj_Decl :=
1168         Make_Object_Declaration (Loc,
1169           Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1170           Object_Definition => Odef);
1171
1172       --  If the type is an access type, do not perform default initialization.
1173       --  The object is about to get its value from Read, and if the type is
1174       --  null excluding we do not want spurious warnings on an initial null.
1175
1176       if Is_Access_Type (Typ) then
1177          Set_No_Initialization (Obj_Decl);
1178       end if;
1179
1180       if Ada_Version >= Ada_05 then
1181          Stms := New_List (
1182            Make_Extended_Return_Statement (Loc,
1183              Return_Object_Declarations => New_List (Obj_Decl),
1184              Handled_Statement_Sequence =>
1185                Make_Handled_Sequence_Of_Statements (Loc,
1186                  New_List (Make_Attribute_Reference (Loc,
1187                              Prefix => New_Occurrence_Of (Typ, Loc),
1188                              Attribute_Name => Name_Read,
1189                              Expressions => New_List (
1190                                Make_Identifier (Loc, Name_S),
1191                                Make_Identifier (Loc, Name_V)))))));
1192
1193       else
1194          Append_To (Decls, Obj_Decl);
1195
1196          Stms := New_List (
1197             Make_Attribute_Reference (Loc,
1198               Prefix => New_Occurrence_Of (Typ, Loc),
1199               Attribute_Name => Name_Read,
1200               Expressions => New_List (
1201                 Make_Identifier (Loc, Name_S),
1202                 Make_Identifier (Loc, Name_V))),
1203
1204             Make_Simple_Return_Statement (Loc,
1205               Expression => Make_Identifier (Loc, Name_V)));
1206       end if;
1207
1208       Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
1209
1210       Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
1211    end Build_Record_Or_Elementary_Input_Function;
1212
1213    -------------------------------------------------
1214    -- Build_Record_Or_Elementary_Output_Procedure --
1215    -------------------------------------------------
1216
1217    procedure Build_Record_Or_Elementary_Output_Procedure
1218      (Loc  : Source_Ptr;
1219       Typ  : Entity_Id;
1220       Decl : out Node_Id;
1221       Pnam : out Entity_Id)
1222    is
1223       Stms     : List_Id;
1224       Disc     : Entity_Id;
1225       Disc_Ref : Node_Id;
1226
1227    begin
1228       Stms := New_List;
1229
1230       --  Note that of course there will be no discriminants for the
1231       --  elementary type case, so Has_Discriminants will be False.
1232
1233       if Has_Discriminants (Typ) then
1234          Disc := First_Discriminant (Typ);
1235
1236          while Present (Disc) loop
1237
1238             --  If the type is an unchecked union, it must have default
1239             --  discriminants (this is checked earlier), and those defaults
1240             --  are written out to the stream.
1241
1242             if Is_Unchecked_Union (Typ) then
1243                Disc_Ref := New_Copy_Tree (Discriminant_Default_Value (Disc));
1244
1245             else
1246                Disc_Ref :=
1247                  Make_Selected_Component (Loc,
1248                    Prefix => Make_Identifier (Loc, Name_V),
1249                    Selector_Name => New_Occurrence_Of (Disc, Loc));
1250             end if;
1251
1252             Append_To (Stms,
1253               Make_Attribute_Reference (Loc,
1254                 Prefix =>
1255                   New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc),
1256                 Attribute_Name => Name_Write,
1257                 Expressions => New_List (
1258                   Make_Identifier (Loc, Name_S),
1259                   Disc_Ref)));
1260
1261             Next_Discriminant (Disc);
1262          end loop;
1263       end if;
1264
1265       Append_To (Stms,
1266         Make_Attribute_Reference (Loc,
1267           Prefix => New_Occurrence_Of (Typ, Loc),
1268           Attribute_Name => Name_Write,
1269           Expressions => New_List (
1270             Make_Identifier (Loc, Name_S),
1271             Make_Identifier (Loc, Name_V))));
1272
1273       Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output);
1274
1275       Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
1276    end Build_Record_Or_Elementary_Output_Procedure;
1277
1278    ---------------------------------
1279    -- Build_Record_Read_Procedure --
1280    ---------------------------------
1281
1282    procedure Build_Record_Read_Procedure
1283      (Loc  : Source_Ptr;
1284       Typ  : Entity_Id;
1285       Decl : out Node_Id;
1286       Pnam : out Entity_Id)
1287    is
1288    begin
1289       Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read);
1290       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
1291    end Build_Record_Read_Procedure;
1292
1293    ---------------------------------------
1294    -- Build_Record_Read_Write_Procedure --
1295    ---------------------------------------
1296
1297    --  The form of the record read/write procedure is as shown by the
1298    --  following example for a case with one discriminant case variant:
1299
1300    --    procedure pnam (S : access RST, V : [out] Typ) is
1301    --    begin
1302    --       Component_Type'Read/Write (S, V.component);
1303    --       Component_Type'Read/Write (S, V.component);
1304    --       ...
1305    --       Component_Type'Read/Write (S, V.component);
1306    --
1307    --       case V.discriminant is
1308    --          when choices =>
1309    --             Component_Type'Read/Write (S, V.component);
1310    --             Component_Type'Read/Write (S, V.component);
1311    --             ...
1312    --             Component_Type'Read/Write (S, V.component);
1313    --
1314    --          when choices =>
1315    --             Component_Type'Read/Write (S, V.component);
1316    --             Component_Type'Read/Write (S, V.component);
1317    --             ...
1318    --             Component_Type'Read/Write (S, V.component);
1319    --          ...
1320    --       end case;
1321    --    end pnam;
1322
1323    --  The out keyword for V is supplied in the Read case
1324
1325    procedure Build_Record_Read_Write_Procedure
1326      (Loc  : Source_Ptr;
1327       Typ  : Entity_Id;
1328       Decl : out Node_Id;
1329       Pnam : Entity_Id;
1330       Nam  : Name_Id)
1331    is
1332       Rdef : Node_Id;
1333       Stms : List_Id;
1334       Typt : Entity_Id;
1335
1336       In_Limited_Extension : Boolean := False;
1337       --  Set to True while processing the record extension definition
1338       --  for an extension of a limited type (for which an ancestor type
1339       --  has an explicit Nam attribute definition).
1340
1341       function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
1342       --  Returns a sequence of attributes to process the components that
1343       --  are referenced in the given component list.
1344
1345       function Make_Field_Attribute (C : Entity_Id) return Node_Id;
1346       --  Given C, the entity for a discriminant or component, build
1347       --  an attribute for the corresponding field values.
1348
1349       function Make_Field_Attributes (Clist : List_Id) return List_Id;
1350       --  Given Clist, a component items list, construct series of attributes
1351       --  for fieldwise processing of the corresponding components.
1352
1353       ------------------------------------
1354       -- Make_Component_List_Attributes --
1355       ------------------------------------
1356
1357       function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
1358          CI : constant List_Id := Component_Items (CL);
1359          VP : constant Node_Id := Variant_Part (CL);
1360
1361          Result : List_Id;
1362          Alts   : List_Id;
1363          V      : Node_Id;
1364          DC     : Node_Id;
1365          DCH    : List_Id;
1366          D_Ref  : Node_Id;
1367
1368       begin
1369          Result := Make_Field_Attributes (CI);
1370
1371          if Present (VP) then
1372             Alts := New_List;
1373
1374             V := First_Non_Pragma (Variants (VP));
1375             while Present (V) loop
1376                DCH := New_List;
1377
1378                DC := First (Discrete_Choices (V));
1379                while Present (DC) loop
1380                   Append_To (DCH, New_Copy_Tree (DC));
1381                   Next (DC);
1382                end loop;
1383
1384                Append_To (Alts,
1385                  Make_Case_Statement_Alternative (Loc,
1386                    Discrete_Choices => DCH,
1387                    Statements =>
1388                      Make_Component_List_Attributes (Component_List (V))));
1389                Next_Non_Pragma (V);
1390             end loop;
1391
1392             --  Note: in the following, we make sure that we use new occurrence
1393             --  of for the selector, since there are cases in which we make a
1394             --  reference to a hidden discriminant that is not visible.
1395
1396             --  If the enclosing record is an unchecked_union, we use the
1397             --  default expressions for the discriminant (it must exist)
1398             --  because we cannot generate a reference to it, given that
1399             --  it is not stored..
1400
1401             if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
1402                D_Ref :=
1403                  New_Copy_Tree
1404                    (Discriminant_Default_Value (Entity (Name (VP))));
1405             else
1406                D_Ref :=
1407                   Make_Selected_Component (Loc,
1408                     Prefix => Make_Identifier (Loc, Name_V),
1409                     Selector_Name =>
1410                       New_Occurrence_Of (Entity (Name (VP)), Loc));
1411             end if;
1412
1413             Append_To (Result,
1414               Make_Case_Statement (Loc,
1415                 Expression => D_Ref,
1416                 Alternatives => Alts));
1417          end if;
1418
1419          return Result;
1420       end Make_Component_List_Attributes;
1421
1422       --------------------------
1423       -- Make_Field_Attribute --
1424       --------------------------
1425
1426       function Make_Field_Attribute (C : Entity_Id) return Node_Id is
1427          Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C));
1428
1429          TSS_Names : constant array (Name_Input .. Name_Write) of
1430                        TSS_Name_Type :=
1431                         (Name_Read   => TSS_Stream_Read,
1432                          Name_Write  => TSS_Stream_Write,
1433                          Name_Input  => TSS_Stream_Input,
1434                          Name_Output => TSS_Stream_Output,
1435                          others      => TSS_Null);
1436          pragma Assert (TSS_Names (Nam) /= TSS_Null);
1437
1438       begin
1439          if In_Limited_Extension
1440            and then Is_Limited_Type (Field_Typ)
1441            and then No (Find_Inherited_TSS (Field_Typ, TSS_Names (Nam)))
1442          then
1443             --  The declaration is illegal per 13.13.2(9/1), and this is
1444             --  enforced in Exp_Ch3.Check_Stream_Attributes. Keep the caller
1445             --  happy by returning a null statement.
1446
1447             return Make_Null_Statement (Loc);
1448          end if;
1449
1450          return
1451            Make_Attribute_Reference (Loc,
1452              Prefix =>
1453                New_Occurrence_Of (Field_Typ, Loc),
1454              Attribute_Name => Nam,
1455              Expressions => New_List (
1456                Make_Identifier (Loc, Name_S),
1457                Make_Selected_Component (Loc,
1458                  Prefix => Make_Identifier (Loc, Name_V),
1459                  Selector_Name => New_Occurrence_Of (C, Loc))));
1460       end Make_Field_Attribute;
1461
1462       ---------------------------
1463       -- Make_Field_Attributes --
1464       ---------------------------
1465
1466       function Make_Field_Attributes (Clist : List_Id) return List_Id is
1467          Item   : Node_Id;
1468          Result : List_Id;
1469
1470       begin
1471          Result := New_List;
1472
1473          if Present (Clist) then
1474             Item := First (Clist);
1475
1476             --  Loop through components, skipping all internal components,
1477             --  which are not part of the value (e.g. _Tag), except that we
1478             --  don't skip the _Parent, since we do want to process that
1479             --  recursively. If _Parent is an interface type, being abstract
1480             --  with no components there is no need to handle it.
1481
1482             while Present (Item) loop
1483                if Nkind (Item) = N_Component_Declaration
1484                  and then
1485                    ((Chars (Defining_Identifier (Item)) = Name_uParent
1486                        and then not Is_Interface
1487                                       (Etype (Defining_Identifier (Item))))
1488                      or else
1489                     not Is_Internal_Name (Chars (Defining_Identifier (Item))))
1490                then
1491                   Append_To
1492                     (Result,
1493                      Make_Field_Attribute (Defining_Identifier (Item)));
1494                end if;
1495
1496                Next (Item);
1497             end loop;
1498          end if;
1499
1500          return Result;
1501       end Make_Field_Attributes;
1502
1503    --  Start of processing for Build_Record_Read_Write_Procedure
1504
1505    begin
1506       --  For the protected type case, use corresponding record
1507
1508       if Is_Protected_Type (Typ) then
1509          Typt := Corresponding_Record_Type (Typ);
1510       else
1511          Typt := Typ;
1512       end if;
1513
1514       --  Note that we do nothing with the discriminants, since Read and
1515       --  Write do not read or write the discriminant values. All handling
1516       --  of discriminants occurs in the Input and Output subprograms.
1517
1518       Rdef := Type_Definition
1519                 (Declaration_Node (Base_Type (Underlying_Type (Typt))));
1520       Stms := Empty_List;
1521
1522       --  In record extension case, the fields we want, including the _Parent
1523       --  field representing the parent type, are to be found in the extension.
1524       --  Note that we will naturally process the _Parent field using the type
1525       --  of the parent, and hence its stream attributes, which is appropriate.
1526
1527       if Nkind (Rdef) = N_Derived_Type_Definition then
1528          Rdef := Record_Extension_Part (Rdef);
1529
1530          if Is_Limited_Type (Typt) then
1531             In_Limited_Extension := True;
1532          end if;
1533       end if;
1534
1535       if Present (Component_List (Rdef)) then
1536          Append_List_To (Stms,
1537            Make_Component_List_Attributes (Component_List (Rdef)));
1538       end if;
1539
1540       Build_Stream_Procedure
1541         (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read);
1542    end Build_Record_Read_Write_Procedure;
1543
1544    ----------------------------------
1545    -- Build_Record_Write_Procedure --
1546    ----------------------------------
1547
1548    procedure Build_Record_Write_Procedure
1549      (Loc  : Source_Ptr;
1550       Typ  : Entity_Id;
1551       Decl : out Node_Id;
1552       Pnam : out Entity_Id)
1553    is
1554    begin
1555       Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write);
1556       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
1557    end Build_Record_Write_Procedure;
1558
1559    -------------------------------
1560    -- Build_Stream_Attr_Profile --
1561    -------------------------------
1562
1563    function Build_Stream_Attr_Profile
1564      (Loc : Source_Ptr;
1565       Typ : Entity_Id;
1566       Nam : TSS_Name_Type) return List_Id
1567    is
1568       Profile : List_Id;
1569
1570    begin
1571       --  (Ada 2005: AI-441): Set the null-excluding attribute because it has
1572       --  no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1573
1574       Profile := New_List (
1575         Make_Parameter_Specification (Loc,
1576           Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1577           Parameter_Type      =>
1578           Make_Access_Definition (Loc,
1579              Null_Exclusion_Present => True,
1580              Subtype_Mark => New_Reference_To (
1581                Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
1582
1583       if Nam /= TSS_Stream_Input then
1584          Append_To (Profile,
1585            Make_Parameter_Specification (Loc,
1586              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1587              Out_Present         => (Nam = TSS_Stream_Read),
1588              Parameter_Type      => New_Reference_To (Typ, Loc)));
1589       end if;
1590
1591       return Profile;
1592    end Build_Stream_Attr_Profile;
1593
1594    ---------------------------
1595    -- Build_Stream_Function --
1596    ---------------------------
1597
1598    procedure Build_Stream_Function
1599      (Loc   : Source_Ptr;
1600       Typ   : Entity_Id;
1601       Decl  : out Node_Id;
1602       Fnam  : Entity_Id;
1603       Decls : List_Id;
1604       Stms  : List_Id)
1605    is
1606       Spec : Node_Id;
1607
1608    begin
1609       --  Construct function specification
1610
1611       --  (Ada 2005: AI-441): Set the null-excluding attribute because it has
1612       --  no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1613
1614       Spec :=
1615         Make_Function_Specification (Loc,
1616           Defining_Unit_Name => Fnam,
1617
1618           Parameter_Specifications => New_List (
1619             Make_Parameter_Specification (Loc,
1620               Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1621               Parameter_Type =>
1622                 Make_Access_Definition (Loc,
1623                   Null_Exclusion_Present => True,
1624                   Subtype_Mark => New_Reference_To (
1625                     Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
1626
1627           Result_Definition => New_Occurrence_Of (Typ, Loc));
1628
1629       Decl :=
1630         Make_Subprogram_Body (Loc,
1631           Specification => Spec,
1632           Declarations => Decls,
1633           Handled_Statement_Sequence =>
1634             Make_Handled_Sequence_Of_Statements (Loc,
1635               Statements => Stms));
1636    end Build_Stream_Function;
1637
1638    ----------------------------
1639    -- Build_Stream_Procedure --
1640    ----------------------------
1641
1642    procedure Build_Stream_Procedure
1643      (Loc  : Source_Ptr;
1644       Typ  : Entity_Id;
1645       Decl : out Node_Id;
1646       Pnam : Entity_Id;
1647       Stms : List_Id;
1648       Outp : Boolean)
1649    is
1650       Spec : Node_Id;
1651
1652    begin
1653       --  Construct procedure specification
1654
1655       --  (Ada 2005: AI-441): Set the null-excluding attribute because it has
1656       --  no semantic meaning in Ada 95 but it is a requirement in Ada2005.
1657
1658       Spec :=
1659         Make_Procedure_Specification (Loc,
1660           Defining_Unit_Name => Pnam,
1661
1662           Parameter_Specifications => New_List (
1663             Make_Parameter_Specification (Loc,
1664               Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1665               Parameter_Type =>
1666                 Make_Access_Definition (Loc,
1667                   Null_Exclusion_Present => True,
1668                   Subtype_Mark => New_Reference_To (
1669                     Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))),
1670
1671             Make_Parameter_Specification (Loc,
1672               Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1673               Out_Present         => Outp,
1674               Parameter_Type      => New_Occurrence_Of (Typ, Loc))));
1675
1676       Decl :=
1677         Make_Subprogram_Body (Loc,
1678           Specification => Spec,
1679           Declarations => Empty_List,
1680           Handled_Statement_Sequence =>
1681             Make_Handled_Sequence_Of_Statements (Loc,
1682               Statements => Stms));
1683    end Build_Stream_Procedure;
1684
1685    -----------------------------
1686    -- Has_Stream_Standard_Rep --
1687    -----------------------------
1688
1689    function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is
1690       Siz : Uint;
1691
1692    begin
1693       if Has_Non_Standard_Rep (U_Type) then
1694          return False;
1695       end if;
1696
1697       if Has_Stream_Size_Clause (U_Type) then
1698          Siz := Static_Integer (Expression (Stream_Size_Clause (U_Type)));
1699       else
1700          Siz := Esize (First_Subtype (U_Type));
1701       end if;
1702
1703       return Siz = Esize (Root_Type (U_Type));
1704    end Has_Stream_Standard_Rep;
1705
1706    ---------------------------------
1707    -- Make_Stream_Subprogram_Name --
1708    ---------------------------------
1709
1710    function Make_Stream_Subprogram_Name
1711      (Loc : Source_Ptr;
1712       Typ : Entity_Id;
1713       Nam : TSS_Name_Type) return Entity_Id
1714    is
1715       Sname : Name_Id;
1716
1717    begin
1718       --  For tagged types, we are dealing with a TSS associated with the
1719       --  declaration, so we use the standard primitive function name. For
1720       --  other types, generate a local TSS name since we are generating
1721       --  the subprogram at the point of use.
1722
1723       if Is_Tagged_Type (Typ) then
1724          Sname := Make_TSS_Name (Typ, Nam);
1725       else
1726          Sname := Make_TSS_Name_Local (Typ, Nam);
1727       end if;
1728
1729       return Make_Defining_Identifier (Loc, Sname);
1730    end Make_Stream_Subprogram_Name;
1731
1732    ----------------------
1733    -- Stream_Base_Type --
1734    ----------------------
1735
1736    function Stream_Base_Type (E : Entity_Id) return Entity_Id is
1737    begin
1738       if Is_Array_Type (E)
1739         and then Is_First_Subtype (E)
1740       then
1741          return E;
1742       else
1743          return Base_Type (E);
1744       end if;
1745    end Stream_Base_Type;
1746
1747 end Exp_Strm;