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