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