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