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-2005, 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Einfo;    use Einfo;
  29 with Exp_Tss;  use Exp_Tss;
  30 with Namet;    use Namet;
  31 with Nlists;   use Nlists;
  32 with Nmake;    use Nmake;
  33 with Rtsfind;  use Rtsfind;
  34 with Sem_Util; use Sem_Util;
  35 with Sinfo;    use Sinfo;
  36 with Snames;   use Snames;
  37 with Stand;    use Stand;
  38 with Tbuild;   use Tbuild;
  39 with Ttypes;   use Ttypes;
  40 with Uintp;    use Uintp;
  41
  42 package body Exp_Strm is
  43
  44    -----------------------
  45    -- Local Subprograms --
  46    -----------------------
  47
  48    procedure Build_Array_Read_Write_Procedure
  49      (Nod  : Node_Id;
  50       Typ  : Entity_Id;
  51       Decl : out Node_Id;
  52       Pnam : Entity_Id;
  53       Nam  : Name_Id);
  54    --  Common routine shared to build either an array Read procedure or an
  55    --  array Write procedure, Nam is Name_Read or Name_Write to select which.
  56    --  Pnam is the defining identifier for the constructed procedure. The
  57    --  other parameters are as for Build_Array_Read_Procedure except that
  58    --  the first parameter Nod supplies the Sloc to be used to generate code.
  59
  60    procedure Build_Record_Read_Write_Procedure
  61      (Loc  : Source_Ptr;
  62       Typ  : Entity_Id;
  63       Decl : out Node_Id;
  64       Pnam : Entity_Id;
  65       Nam  : Name_Id);
  66    --  Common routine shared to build a record Read Write procedure, Nam
  67    --  is Name_Read or Name_Write to select which. Pnam is the defining
  68    --  identifier for the constructed procedure. The other parameters are
  69    --  as for Build_Record_Read_Procedure.
  70
  71    procedure Build_Stream_Function
  72      (Loc   : Source_Ptr;
  73       Typ   : Entity_Id;
  74       Decl  : out Node_Id;
  75       Fnam  : Entity_Id;
  76       Decls : List_Id;
  77       Stms  : List_Id);
  78    --  Called to build an array or record stream function. The first three
  79    --  arguments are the same as Build_Record_Or_Elementary_Input_Function.
  80    --  Decls and Stms are the declarations and statements for the body and
  81    --  The parameter Fnam is the name of the constructed function.
  82
  83    function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean;
  84    --  This function is used to test U_Type, which is a type
  85    --  Returns True if U_Type has a standard representation for stream
  86    --  purposes, i.e. there is no non-standard enumeration representation
  87    --  clause, and the size of the first subtype is the same as the size
  88    --  of the root type.
  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_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. See 5509-003.
 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 Is_Elementary_Type (FST) and then 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          if P_Size <= Standard_Short_Float_Size then
 496             Lib_RE := RE_I_SF;
 497
 498          elsif P_Size <= Standard_Float_Size then
 499             Lib_RE := RE_I_F;
 500
 501          elsif P_Size <= Standard_Long_Float_Size then
 502             Lib_RE := RE_I_LF;
 503
 504          else
 505             Lib_RE := RE_I_LLF;
 506          end if;
 507
 508       --  Signed integer types. Also includes signed fixed-point types and
 509       --  enumeration types with a signed representation.
 510
 511       --  Note on signed integer types. We do not consider types as signed for
 512       --  this purpose if they have no negative numbers, or if they have biased
 513       --  representation. The reason is that the value in either case basically
 514       --  represents an unsigned value.
 515
 516       --  For example, consider:
 517
 518       --     type W is range 0 .. 2**32 - 1;
 519       --     for W'Size use 32;
 520
 521       --  This is a signed type, but the representation is unsigned, and may
 522       --  be outside the range of a 32-bit signed integer, so this must be
 523       --  treated as 32-bit unsigned.
 524
 525       --  Similarly, if we have
 526
 527       --     type W is range -1 .. +254;
 528       --     for W'Size use 8;
 529
 530       --  then the representation is unsigned
 531
 532       elsif not Is_Unsigned_Type (FST)
 533         and then
 534           (Is_Fixed_Point_Type (U_Type)
 535              or else
 536            Is_Enumeration_Type (U_Type)
 537              or else
 538            (Is_Signed_Integer_Type (U_Type)
 539               and then not Has_Biased_Representation (FST)))
 540       then
 541          if P_Size <= Standard_Short_Short_Integer_Size then
 542             Lib_RE := RE_I_SSI;
 543
 544          elsif P_Size <= Standard_Short_Integer_Size then
 545             Lib_RE := RE_I_SI;
 546
 547          elsif P_Size <= Standard_Integer_Size then
 548             Lib_RE := RE_I_I;
 549
 550          elsif P_Size <= Standard_Long_Integer_Size then
 551             Lib_RE := RE_I_LI;
 552
 553          else
 554             Lib_RE := RE_I_LLI;
 555          end if;
 556
 557       --  Unsigned integer types, also includes unsigned fixed-point types
 558       --  and enumeration types with an unsigned representation (note that
 559       --  we know they are unsigned because we already tested for signed).
 560
 561       --  Also includes signed integer types that are unsigned in the sense
 562       --  that they do not include negative numbers. See above for details.
 563
 564       elsif Is_Modular_Integer_Type    (U_Type)
 565         or else Is_Fixed_Point_Type    (U_Type)
 566         or else Is_Enumeration_Type    (U_Type)
 567         or else Is_Signed_Integer_Type (U_Type)
 568       then
 569          if P_Size <= Standard_Short_Short_Integer_Size then
 570             Lib_RE := RE_I_SSU;
 571
 572          elsif P_Size <= Standard_Short_Integer_Size then
 573             Lib_RE := RE_I_SU;
 574
 575          elsif P_Size <= Standard_Integer_Size then
 576             Lib_RE := RE_I_U;
 577
 578          elsif P_Size <= Standard_Long_Integer_Size then
 579             Lib_RE := RE_I_LU;
 580
 581          else
 582             Lib_RE := RE_I_LLU;
 583          end if;
 584
 585       else pragma Assert (Is_Access_Type (U_Type));
 586          if P_Size > System_Address_Size then
 587             Lib_RE := RE_I_AD;
 588          else
 589             Lib_RE := RE_I_AS;
 590          end if;
 591       end if;
 592
 593       --  Call the function, and do an unchecked conversion of the result
 594       --  to the actual type of the prefix. If the target is a discriminant,
 595       --  and we are in the body of the default implementation of a 'Read
 596       --  attribute, set target type to force a constraint check (13.13.2(35)).
 597
 598       if Nkind (Targ) = N_Identifier
 599         and then Is_Internal_Name (Chars (Targ))
 600         and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read)
 601       then
 602          Res :=
 603            Unchecked_Convert_To (Base_Type (P_Type),
 604              Make_Function_Call (Loc,
 605                Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
 606                Parameter_Associations => New_List (
 607                  Relocate_Node (Strm))));
 608
 609          Set_Do_Range_Check (Res);
 610          return Res;
 611
 612       else
 613          return
 614            Unchecked_Convert_To (P_Type,
 615              Make_Function_Call (Loc,
 616                Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
 617                Parameter_Associations => New_List (
 618                  Relocate_Node (Strm))));
 619       end if;
 620    end Build_Elementary_Input_Call;
 621
 622    ---------------------------------
 623    -- Build_Elementary_Write_Call --
 624    ---------------------------------
 625
 626    function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is
 627       Loc     : constant Source_Ptr := Sloc (N);
 628       P_Type  : constant Entity_Id  := Entity (Prefix (N));
 629       U_Type  : constant Entity_Id  := Underlying_Type (P_Type);
 630       Rt_Type : constant Entity_Id  := Root_Type (U_Type);
 631       FST     : constant Entity_Id  := First_Subtype (U_Type);
 632       Strm    : constant Node_Id    := First (Expressions (N));
 633       Item    : constant Node_Id    := Next (Strm);
 634       P_Size  : Uint;
 635       Lib_RE  : RE_Id;
 636       Libent  : Entity_Id;
 637
 638    begin
 639       --  Compute the size of the stream element. This is either the size of
 640       --  the first subtype or if given the size of the Stream_Size attribute.
 641
 642       if Is_Elementary_Type (FST) and then Has_Stream_Size_Clause (FST) then
 643          P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
 644       else
 645          P_Size := Esize (FST);
 646       end if;
 647
 648       --  Find the routine to be called
 649
 650       --  Check for First Boolean and Character. These are enumeration types,
 651       --  but we treat them specially, since they may require special handling
 652       --  in the transfer protocol. However, this special handling only applies
 653       --  if they have standard representation, otherwise they are treated like
 654       --  any other enumeration type.
 655
 656       if Rt_Type = Standard_Boolean
 657         and then Has_Stream_Standard_Rep (U_Type)
 658       then
 659          Lib_RE := RE_W_B;
 660
 661       elsif Rt_Type = Standard_Character
 662         and then Has_Stream_Standard_Rep (U_Type)
 663       then
 664          Lib_RE := RE_W_C;
 665
 666       elsif Rt_Type = Standard_Wide_Character
 667         and then Has_Stream_Standard_Rep (U_Type)
 668       then
 669          Lib_RE := RE_W_WC;
 670
 671       elsif Rt_Type = Standard_Wide_Wide_Character
 672         and then Has_Stream_Standard_Rep (U_Type)
 673       then
 674          Lib_RE := RE_W_WWC;
 675
 676       --  Floating point types
 677
 678       elsif Is_Floating_Point_Type (U_Type) then
 679          if P_Size <= Standard_Short_Float_Size then
 680             Lib_RE := RE_W_SF;
 681          elsif P_Size <= Standard_Float_Size then
 682             Lib_RE := RE_W_F;
 683          elsif P_Size <= Standard_Long_Float_Size then
 684             Lib_RE := RE_W_LF;
 685          else
 686             Lib_RE := RE_W_LLF;
 687          end if;
 688
 689       --  Signed integer types. Also includes signed fixed-point types and
 690       --  signed enumeration types share this circuitry.
 691
 692       --  Note on signed integer types. We do not consider types as signed for
 693       --  this purpose if they have no negative numbers, or if they have biased
 694       --  representation. The reason is that the value in either case basically
 695       --  represents an unsigned value.
 696
 697       --  For example, consider:
 698
 699       --     type W is range 0 .. 2**32 - 1;
 700       --     for W'Size use 32;
 701
 702       --  This is a signed type, but the representation is unsigned, and may
 703       --  be outside the range of a 32-bit signed integer, so this must be
 704       --  treated as 32-bit unsigned.
 705
 706       --  Similarly, the representation is also unsigned if we have:
 707
 708       --     type W is range -1 .. +254;
 709       --     for W'Size use 8;
 710
 711       elsif not Is_Unsigned_Type (FST)
 712         and then
 713           (Is_Fixed_Point_Type (U_Type)
 714              or else
 715            Is_Enumeration_Type (U_Type)
 716              or else
 717            (Is_Signed_Integer_Type (U_Type)
 718               and then not Has_Biased_Representation (FST)))
 719       then
 720          if P_Size <= Standard_Short_Short_Integer_Size then
 721             Lib_RE := RE_W_SSI;
 722          elsif P_Size <= Standard_Short_Integer_Size then
 723             Lib_RE := RE_W_SI;
 724          elsif P_Size <= Standard_Integer_Size then
 725             Lib_RE := RE_W_I;
 726          elsif P_Size <= Standard_Long_Integer_Size then
 727             Lib_RE := RE_W_LI;
 728          else
 729             Lib_RE := RE_W_LLI;
 730          end if;
 731
 732       --  Unsigned integer types, also includes unsigned fixed-point types
 733       --  and unsigned enumeration types (note we know they are unsigned
 734       --  because we already tested for signed above).
 735
 736       --  Also includes signed integer types that are unsigned in the sense
 737       --  that they do not include negative numbers. See above for details.
 738
 739       elsif Is_Modular_Integer_Type    (U_Type)
 740         or else Is_Fixed_Point_Type    (U_Type)
 741         or else Is_Enumeration_Type    (U_Type)
 742         or else Is_Signed_Integer_Type (U_Type)
 743       then
 744          if P_Size <= Standard_Short_Short_Integer_Size then
 745             Lib_RE := RE_W_SSU;
 746          elsif P_Size <= Standard_Short_Integer_Size then
 747             Lib_RE := RE_W_SU;
 748          elsif P_Size <= Standard_Integer_Size then
 749             Lib_RE := RE_W_U;
 750          elsif P_Size <= Standard_Long_Integer_Size then
 751             Lib_RE := RE_W_LU;
 752          else
 753             Lib_RE := RE_W_LLU;
 754          end if;
 755
 756       else pragma Assert (Is_Access_Type (U_Type));
 757
 758          if P_Size > System_Address_Size then
 759             Lib_RE := RE_W_AD;
 760          else
 761             Lib_RE := RE_W_AS;
 762          end if;
 763       end if;
 764
 765       --  Unchecked-convert parameter to the required type (i.e. the type of
 766       --  the corresponding parameter, and call the appropriate routine.
 767
 768       Libent := RTE (Lib_RE);
 769
 770       return
 771         Make_Procedure_Call_Statement (Loc,
 772           Name => New_Occurrence_Of (Libent, Loc),
 773           Parameter_Associations => New_List (
 774             Relocate_Node (Strm),
 775             Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))),
 776               Relocate_Node (Item))));
 777    end Build_Elementary_Write_Call;
 778
 779    -----------------------------------------
 780    -- Build_Mutable_Record_Read_Procedure --
 781    -----------------------------------------
 782
 783    procedure Build_Mutable_Record_Read_Procedure
 784      (Loc  : Source_Ptr;
 785       Typ  : Entity_Id;
 786       Decl : out Node_Id;
 787       Pnam : out Entity_Id)
 788    is
 789       Out_Formal : Node_Id;
 790       --  Expression denoting the out formal parameter
 791
 792       Dcls : constant List_Id := New_List;
 793       --  Declarations for the 'Read body
 794
 795       Stms : List_Id := New_List;
 796       --  Statements for the 'Read body
 797
 798       Disc : Entity_Id;
 799       --  Entity of the discriminant being processed
 800
 801       Tmp_For_Disc : Entity_Id;
 802       --  Temporary object used to read the value of Disc
 803
 804       Tmps_For_Discs : constant List_Id := New_List;
 805       --  List of object declarations for temporaries holding the read values
 806       --  for the discriminants.
 807
 808       Cstr : constant List_Id := New_List;
 809       --  List of constraints to be applied on temporary record
 810
 811       Discriminant_Checks : constant List_Id := New_List;
 812       --  List of discriminant checks to be performed if the actual object
 813       --  is constrained.
 814
 815       Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V);
 816       --  Temporary record must hide formal (assignments to components of the
 817       --  record are always generated with V as the identifier for the record).
 818
 819       Constrained_Stms : List_Id := New_List;
 820       --  Statements within the block where we have the constrained temporary
 821
 822    begin
 823
 824       Disc := First_Discriminant (Typ);
 825
 826       --  A mutable type cannot be a tagged type, so we generate a new name
 827       --  for the stream procedure.
 828
 829       Pnam :=
 830         Make_Defining_Identifier (Loc,
 831           Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
 832
 833       Out_Formal :=
 834         Make_Selected_Component (Loc,
 835           Prefix => New_Occurrence_Of (Pnam, Loc),
 836           Selector_Name => Make_Identifier (Loc, Name_V));
 837
 838       --  Generate Reads for the discriminants of the type. The discriminants
 839       --  need to be read before the rest of the components, so that
 840       --  variants are initialized correctly. The discriminants must be read
 841       --  into temporary variables so an incomplete Read (interrupted by an
 842       --  exception, for example) does not alter the passed object.
 843
 844       while Present (Disc) loop
 845          Tmp_For_Disc := Make_Defining_Identifier (Loc,
 846                            New_External_Name (Chars (Disc), "D"));
 847
 848          Append_To (Tmps_For_Discs,
 849            Make_Object_Declaration (Loc,
 850              Defining_Identifier => Tmp_For_Disc,
 851              Object_Definition   => New_Occurrence_Of (Etype (Disc), Loc)));
 852          Set_No_Initialization (Last (Tmps_For_Discs));
 853
 854          Append_To (Stms,
 855            Make_Attribute_Reference (Loc,
 856              Prefix => New_Occurrence_Of (Etype (Disc), Loc),
 857              Attribute_Name => Name_Read,
 858              Expressions => New_List (
 859                Make_Identifier (Loc, Name_S),
 860                New_Occurrence_Of (Tmp_For_Disc, Loc))));
 861
 862          Append_To (Cstr,
 863            Make_Discriminant_Association (Loc,
 864              Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)),
 865              Expression     => New_Occurrence_Of (Tmp_For_Disc, Loc)));
 866
 867          Append_To (Discriminant_Checks,
 868            Make_Raise_Constraint_Error (Loc,
 869              Condition =>
 870                Make_Op_Ne (Loc,
 871                  Left_Opnd  => New_Occurrence_Of (Tmp_For_Disc, Loc),
 872                  Right_Opnd =>
 873                    Make_Selected_Component (Loc,
 874                      Prefix => New_Copy_Tree (Out_Formal),
 875                      Selector_Name => New_Occurrence_Of (Disc, Loc))),
 876              Reason => CE_Discriminant_Check_Failed));
 877          Next_Discriminant (Disc);
 878       end loop;
 879
 880       --  Generate reads for the components of the record (including
 881       --  those that depend on discriminants).
 882
 883       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
 884
 885       --  If Typ has controlled components (i.e. if it is classwide
 886       --  or Has_Controlled), or components constrained using the discriminants
 887       --  of Typ, then we need to ensure that all component assignments
 888       --  are performed on an object that has been appropriately constrained
 889       --  prior to being initialized. To this effect, we wrap the component
 890       --  assignments in a block where V is a constrained temporary.
 891
 892       Append_To (Dcls,
 893         Make_Object_Declaration (Loc,
 894           Defining_Identifier => Tmp,
 895           Object_Definition   =>
 896             Make_Subtype_Indication (Loc,
 897               Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 898               Constraint =>
 899                 Make_Index_Or_Discriminant_Constraint (Loc,
 900                   Constraints => Cstr))));
 901
 902       Constrained_Stms := Statements (Handled_Statement_Sequence (Decl));
 903       Append_To (Stms,
 904         Make_Block_Statement (Loc,
 905           Declarations => Dcls,
 906           Handled_Statement_Sequence => Parent (Constrained_Stms)));
 907
 908       Append_To (Constrained_Stms,
 909         Make_Implicit_If_Statement (Pnam,
 910           Condition =>
 911             Make_Attribute_Reference (Loc,
 912               Prefix => New_Copy_Tree (Out_Formal),
 913               Attribute_Name => Name_Constrained),
 914           Then_Statements => Discriminant_Checks));
 915
 916       Append_To (Constrained_Stms,
 917         Make_Assignment_Statement (Loc,
 918           Name => Out_Formal,
 919           Expression => Make_Identifier (Loc, Name_V)));
 920
 921       if Is_Unchecked_Union (Typ) then
 922
 923          --  If this is an unchecked union, the stream procedure is erroneous,
 924          --  because there are no discriminants to read.
 925
 926          --  This should generate a warning ???
 927
 928          Stms :=
 929            New_List (
 930              Make_Raise_Program_Error (Loc,
 931                Reason => PE_Unchecked_Union_Restriction));
 932       end if;
 933
 934       Set_Declarations (Decl, Tmps_For_Discs);
 935       Set_Handled_Statement_Sequence (Decl,
 936         Make_Handled_Sequence_Of_Statements (Loc,
 937           Statements => Stms));
 938    end Build_Mutable_Record_Read_Procedure;
 939
 940    ------------------------------------------
 941    -- Build_Mutable_Record_Write_Procedure --
 942    ------------------------------------------
 943
 944    procedure Build_Mutable_Record_Write_Procedure
 945      (Loc  : Source_Ptr;
 946       Typ  : Entity_Id;
 947       Decl : out Node_Id;
 948       Pnam : out Entity_Id)
 949    is
 950       Stms  : List_Id;
 951       Disc  : Entity_Id;
 952
 953    begin
 954       Stms := New_List;
 955       Disc := First_Discriminant (Typ);
 956
 957       --  Generate Writes for the discriminants of the type
 958
 959       while Present (Disc) loop
 960
 961          Append_To (Stms,
 962            Make_Attribute_Reference (Loc,
 963              Prefix => New_Occurrence_Of (Etype (Disc), Loc),
 964                Attribute_Name => Name_Write,
 965                Expressions => New_List (
 966                  Make_Identifier (Loc, Name_S),
 967                  Make_Selected_Component (Loc,
 968                    Prefix => Make_Identifier (Loc, Name_V),
 969                    Selector_Name => New_Occurrence_Of (Disc, Loc)))));
 970
 971          Next_Discriminant (Disc);
 972       end loop;
 973
 974       --  A mutable type cannot be a tagged type, so we generate a new name
 975       --  for the stream procedure.
 976
 977       Pnam :=
 978         Make_Defining_Identifier (Loc,
 979           Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
 980       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
 981
 982       --  Write the discriminants before the rest of the components, so
 983       --  that discriminant values are properly set of variants, etc.
 984       --  If this is an unchecked union, the stream procedure is erroneous
 985       --  because there are no discriminants to write.
 986
 987       if Is_Unchecked_Union (Typ) then
 988          Stms :=
 989            New_List (
 990              Make_Raise_Program_Error (Loc,
 991                Reason => PE_Unchecked_Union_Restriction));
 992       end if;
 993
 994       if Is_Non_Empty_List (
 995         Statements (Handled_Statement_Sequence (Decl)))
 996       then
 997          Insert_List_Before
 998             (First (Statements (Handled_Statement_Sequence (Decl))), Stms);
 999       else
1000          Set_Statements (Handled_Statement_Sequence (Decl), Stms);
1001       end if;
1002    end Build_Mutable_Record_Write_Procedure;
1003
1004    -----------------------------------------------
1005    -- Build_Record_Or_Elementary_Input_Function --
1006    -----------------------------------------------
1007
1008    --  The function we build looks like
1009
1010    --    function InputN (S : access RST) return Typ is
1011    --      C1 : constant Disc_Type_1;
1012    --      Discr_Type_1'Read (S, C1);
1013    --      C2 : constant Disc_Type_2;
1014    --      Discr_Type_2'Read (S, C2);
1015    --      ...
1016    --      Cn : constant Disc_Type_n;
1017    --      Discr_Type_n'Read (S, Cn);
1018    --      V : Typ (C1, C2, .. Cn)
1019
1020    --    begin
1021    --      Typ'Read (S, V);
1022    --      return V;
1023    --    end InputN
1024
1025    --  The discriminants are of course only present in the case of a record
1026    --  with discriminants. In the case of a record with no discriminants, or
1027    --  an elementary type, then no Cn constants are defined.
1028
1029    procedure Build_Record_Or_Elementary_Input_Function
1030      (Loc  : Source_Ptr;
1031       Typ  : Entity_Id;
1032       Decl : out Node_Id;
1033       Fnam : out Entity_Id)
1034    is
1035       Cn     : Name_Id;
1036       J      : Pos;
1037       Decls  : List_Id;
1038       Constr : List_Id;
1039       Stms   : List_Id;
1040       Discr  : Entity_Id;
1041       Odef   : Node_Id;
1042
1043    begin
1044       Decls  := New_List;
1045       Constr := New_List;
1046
1047       J := 1;
1048
1049       if Has_Discriminants (Typ) then
1050          Discr := First_Discriminant (Typ);
1051
1052          while Present (Discr) loop
1053             Cn := New_External_Name ('C', J);
1054
1055             Append_To (Decls,
1056               Make_Object_Declaration (Loc,
1057                 Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
1058                 Object_Definition =>
1059                  New_Occurrence_Of (Etype (Discr), Loc)));
1060
1061             Append_To (Decls,
1062               Make_Attribute_Reference (Loc,
1063                 Prefix => New_Occurrence_Of (Etype (Discr), Loc),
1064                 Attribute_Name => Name_Read,
1065                 Expressions => New_List (
1066                   Make_Identifier (Loc, Name_S),
1067                   Make_Identifier (Loc, Cn))));
1068
1069             Append_To (Constr, Make_Identifier (Loc, Cn));
1070
1071             Next_Discriminant (Discr);
1072             J := J + 1;
1073          end loop;
1074
1075          Odef :=
1076            Make_Subtype_Indication (Loc,
1077              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1078              Constraint =>
1079                Make_Index_Or_Discriminant_Constraint (Loc,
1080                  Constraints => Constr));
1081
1082       --  If no discriminants, then just use the type with no constraint
1083
1084       else
1085          Odef := New_Occurrence_Of (Typ, Loc);
1086       end if;
1087
1088       Append_To (Decls,
1089         Make_Object_Declaration (Loc,
1090           Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1091           Object_Definition => Odef));
1092
1093       Stms := New_List (
1094          Make_Attribute_Reference (Loc,
1095            Prefix => New_Occurrence_Of (Typ, Loc),
1096            Attribute_Name => Name_Read,
1097            Expressions => New_List (
1098              Make_Identifier (Loc, Name_S),
1099              Make_Identifier (Loc, Name_V))),
1100
1101          Make_Return_Statement (Loc,
1102            Expression => Make_Identifier (Loc, Name_V)));
1103
1104       Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
1105
1106       Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
1107    end Build_Record_Or_Elementary_Input_Function;
1108
1109    -------------------------------------------------
1110    -- Build_Record_Or_Elementary_Output_Procedure --
1111    -------------------------------------------------
1112
1113    procedure Build_Record_Or_Elementary_Output_Procedure
1114      (Loc  : Source_Ptr;
1115       Typ  : Entity_Id;
1116       Decl : out Node_Id;
1117       Pnam : out Entity_Id)
1118    is
1119       Stms : List_Id;
1120       Disc : Entity_Id;
1121
1122    begin
1123       Stms := New_List;
1124
1125       --  Note that of course there will be no discriminants for the
1126       --  elementary type case, so Has_Discriminants will be False.
1127
1128       if Has_Discriminants (Typ) then
1129          Disc := First_Discriminant (Typ);
1130
1131          while Present (Disc) loop
1132             Append_To (Stms,
1133               Make_Attribute_Reference (Loc,
1134                 Prefix =>
1135                   New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc),
1136                 Attribute_Name => Name_Write,
1137                 Expressions => New_List (
1138                   Make_Identifier (Loc, Name_S),
1139                   Make_Selected_Component (Loc,
1140                     Prefix => Make_Identifier (Loc, Name_V),
1141                     Selector_Name => New_Occurrence_Of (Disc, Loc)))));
1142
1143             Next_Discriminant (Disc);
1144          end loop;
1145       end if;
1146
1147       Append_To (Stms,
1148         Make_Attribute_Reference (Loc,
1149           Prefix => New_Occurrence_Of (Typ, Loc),
1150           Attribute_Name => Name_Write,
1151           Expressions => New_List (
1152             Make_Identifier (Loc, Name_S),
1153             Make_Identifier (Loc, Name_V))));
1154
1155       Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output);
1156
1157       Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
1158    end Build_Record_Or_Elementary_Output_Procedure;
1159
1160    ---------------------------------
1161    -- Build_Record_Read_Procedure --
1162    ---------------------------------
1163
1164    procedure Build_Record_Read_Procedure
1165      (Loc  : Source_Ptr;
1166       Typ  : Entity_Id;
1167       Decl : out Node_Id;
1168       Pnam : out Entity_Id)
1169    is
1170    begin
1171       Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read);
1172       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
1173    end Build_Record_Read_Procedure;
1174
1175    ---------------------------------------
1176    -- Build_Record_Read_Write_Procedure --
1177    ---------------------------------------
1178
1179    --  The form of the record read/write procedure is as shown by the
1180    --  following example for a case with one discriminant case variant:
1181
1182    --    procedure pnam (S : access RST, V : [out] Typ) is
1183    --    begin
1184    --       Component_Type'Read/Write (S, V.component);
1185    --       Component_Type'Read/Write (S, V.component);
1186    --       ...
1187    --       Component_Type'Read/Write (S, V.component);
1188    --
1189    --       case V.discriminant is
1190    --          when choices =>
1191    --             Component_Type'Read/Write (S, V.component);
1192    --             Component_Type'Read/Write (S, V.component);
1193    --             ...
1194    --             Component_Type'Read/Write (S, V.component);
1195    --
1196    --          when choices =>
1197    --             Component_Type'Read/Write (S, V.component);
1198    --             Component_Type'Read/Write (S, V.component);
1199    --             ...
1200    --             Component_Type'Read/Write (S, V.component);
1201    --          ...
1202    --       end case;
1203    --    end pnam;
1204
1205    --  The out keyword for V is supplied in the Read case
1206
1207    procedure Build_Record_Read_Write_Procedure
1208      (Loc  : Source_Ptr;
1209       Typ  : Entity_Id;
1210       Decl : out Node_Id;
1211       Pnam : Entity_Id;
1212       Nam  : Name_Id)
1213    is
1214       Rdef : Node_Id;
1215       Stms : List_Id;
1216       Typt : Entity_Id;
1217
1218       In_Limited_Extension : Boolean := False;
1219       --  Set to True while processing the record extension definition
1220       --  for an extension of a limited type (for which an ancestor type
1221       --  has an explicit Nam attribute definition).
1222
1223       function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
1224       --  Returns a sequence of attributes to process the components that
1225       --  are referenced in the given component list.
1226
1227       function Make_Field_Attribute (C : Entity_Id) return Node_Id;
1228       --  Given C, the entity for a discriminant or component, build
1229       --  an attribute for the corresponding field values.
1230
1231       function Make_Field_Attributes (Clist : List_Id) return List_Id;
1232       --  Given Clist, a component items list, construct series of attributes
1233       --  for fieldwise processing of the corresponding components.
1234
1235       ------------------------------------
1236       -- Make_Component_List_Attributes --
1237       ------------------------------------
1238
1239       function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
1240          CI : constant List_Id := Component_Items (CL);
1241          VP : constant Node_Id := Variant_Part (CL);
1242
1243          Result : List_Id;
1244          Alts   : List_Id;
1245          V      : Node_Id;
1246          DC     : Node_Id;
1247          DCH    : List_Id;
1248
1249       begin
1250          Result := Make_Field_Attributes (CI);
1251
1252          --  If a component is an unchecked union, there is no discriminant
1253          --  and we cannot generate a read/write procedure for it.
1254
1255          if Present (VP) then
1256             if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
1257                return New_List (
1258                  Make_Raise_Program_Error (Sloc (VP),
1259                    Reason => PE_Unchecked_Union_Restriction));
1260             end if;
1261
1262             V := First_Non_Pragma (Variants (VP));
1263             Alts := New_List;
1264             while Present (V) loop
1265
1266                DCH := New_List;
1267                DC := First (Discrete_Choices (V));
1268                while Present (DC) loop
1269                   Append_To (DCH, New_Copy_Tree (DC));
1270                   Next (DC);
1271                end loop;
1272
1273                Append_To (Alts,
1274                  Make_Case_Statement_Alternative (Loc,
1275                    Discrete_Choices => DCH,
1276                    Statements =>
1277                      Make_Component_List_Attributes (Component_List (V))));
1278                Next_Non_Pragma (V);
1279             end loop;
1280
1281             --  Note: in the following, we make sure that we use new occurrence
1282             --  of for the selector, since there are cases in which we make a
1283             --  reference to a hidden discriminant that is not visible.
1284
1285             Append_To (Result,
1286               Make_Case_Statement (Loc,
1287                 Expression =>
1288                   Make_Selected_Component (Loc,
1289                     Prefix => Make_Identifier (Loc, Name_V),
1290                     Selector_Name =>
1291                       New_Occurrence_Of (Entity (Name (VP)), Loc)),
1292                 Alternatives => Alts));
1293
1294          end if;
1295
1296          return Result;
1297       end Make_Component_List_Attributes;
1298
1299       --------------------------
1300       -- Make_Field_Attribute --
1301       --------------------------
1302
1303       function Make_Field_Attribute (C : Entity_Id) return Node_Id is
1304          Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C));
1305
1306          TSS_Names : constant array (Name_Input .. Name_Write) of
1307                        TSS_Name_Type :=
1308                         (Name_Read   => TSS_Stream_Read,
1309                          Name_Write  => TSS_Stream_Write,
1310                          Name_Input  => TSS_Stream_Input,
1311                          Name_Output => TSS_Stream_Output,
1312                          others      => TSS_Null);
1313          pragma Assert (TSS_Names (Nam) /= TSS_Null);
1314
1315       begin
1316          if In_Limited_Extension
1317            and then Is_Limited_Type (Field_Typ)
1318            and then No (Find_Inherited_TSS (Field_Typ, TSS_Names (Nam)))
1319          then
1320             --  The declaration is illegal per 13.13.2(9/1), and this is
1321             --  enforced in Exp_Ch3.Check_Stream_Attributes. Keep the
1322             --  caller happy by returning a null statement.
1323
1324             return Make_Null_Statement (Loc);
1325          end if;
1326
1327          return
1328            Make_Attribute_Reference (Loc,
1329              Prefix =>
1330                New_Occurrence_Of (Stream_Base_Type (Etype (C)), Loc),
1331              Attribute_Name => Nam,
1332              Expressions => New_List (
1333                Make_Identifier (Loc, Name_S),
1334                Make_Selected_Component (Loc,
1335                  Prefix => Make_Identifier (Loc, Name_V),
1336                  Selector_Name => New_Occurrence_Of (C, Loc))));
1337       end Make_Field_Attribute;
1338
1339       ---------------------------
1340       -- Make_Field_Attributes --
1341       ---------------------------
1342
1343       function Make_Field_Attributes (Clist : List_Id) return List_Id is
1344          Item   : Node_Id;
1345          Result : List_Id;
1346
1347       begin
1348          Result := New_List;
1349
1350          if Present (Clist) then
1351             Item := First (Clist);
1352
1353             --  Loop through components, skipping all internal components,
1354             --  which are not part of the value (e.g. _Tag), except that we
1355             --  don't skip the _Parent, since we do want to process that
1356             --  recursively.
1357
1358             while Present (Item) loop
1359                if Nkind (Item) = N_Component_Declaration
1360                  and then
1361                    (Chars (Defining_Identifier (Item)) = Name_uParent
1362                      or else
1363                     not Is_Internal_Name (Chars (Defining_Identifier (Item))))
1364                then
1365                   Append_To
1366                     (Result,
1367                      Make_Field_Attribute (Defining_Identifier (Item)));
1368                end if;
1369
1370                Next (Item);
1371             end loop;
1372          end if;
1373
1374          return Result;
1375       end Make_Field_Attributes;
1376
1377    --  Start of processing for Build_Record_Read_Write_Procedure
1378
1379    begin
1380       --  For the protected type case, use corresponding record
1381
1382       if Is_Protected_Type (Typ) then
1383          Typt := Corresponding_Record_Type (Typ);
1384       else
1385          Typt := Typ;
1386       end if;
1387
1388       --  Note that we do nothing with the discriminants, since Read and
1389       --  Write do not read or write the discriminant values. All handling
1390       --  of discriminants occurs in the Input and Output subprograms.
1391
1392       Rdef := Type_Definition
1393                 (Declaration_Node (Base_Type (Underlying_Type (Typt))));
1394       Stms := Empty_List;
1395
1396       --  In record extension case, the fields we want, including the _Parent
1397       --  field representing the parent type, are to be found in the extension.
1398       --  Note that we will naturally process the _Parent field using the type
1399       --  of the parent, and hence its stream attributes, which is appropriate.
1400
1401       if Nkind (Rdef) = N_Derived_Type_Definition then
1402          Rdef := Record_Extension_Part (Rdef);
1403
1404          if Is_Limited_Type (Typt) then
1405             In_Limited_Extension := True;
1406          end if;
1407       end if;
1408
1409       if Present (Component_List (Rdef)) then
1410          Append_List_To (Stms,
1411            Make_Component_List_Attributes (Component_List (Rdef)));
1412       end if;
1413
1414       Build_Stream_Procedure
1415         (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read);
1416    end Build_Record_Read_Write_Procedure;
1417
1418    ----------------------------------
1419    -- Build_Record_Write_Procedure --
1420    ----------------------------------
1421
1422    procedure Build_Record_Write_Procedure
1423      (Loc  : Source_Ptr;
1424       Typ  : Entity_Id;
1425       Decl : out Node_Id;
1426       Pnam : out Entity_Id)
1427    is
1428    begin
1429       Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write);
1430       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
1431    end Build_Record_Write_Procedure;
1432
1433    -------------------------------
1434    -- Build_Stream_Attr_Profile --
1435    -------------------------------
1436
1437    function Build_Stream_Attr_Profile
1438      (Loc : Source_Ptr;
1439       Typ : Entity_Id;
1440       Nam : TSS_Name_Type) return List_Id
1441    is
1442       Profile : List_Id;
1443
1444    begin
1445       Profile := New_List (
1446         Make_Parameter_Specification (Loc,
1447           Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1448           Parameter_Type      =>
1449           Make_Access_Definition (Loc,
1450              Subtype_Mark => New_Reference_To (
1451                Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
1452
1453       if Nam /= TSS_Stream_Input then
1454          Append_To (Profile,
1455            Make_Parameter_Specification (Loc,
1456              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1457              Out_Present         => (Nam = TSS_Stream_Read),
1458              Parameter_Type      => New_Reference_To (Typ, Loc)));
1459       end if;
1460
1461       return Profile;
1462    end Build_Stream_Attr_Profile;
1463
1464    ---------------------------
1465    -- Build_Stream_Function --
1466    ---------------------------
1467
1468    procedure Build_Stream_Function
1469      (Loc   : Source_Ptr;
1470       Typ   : Entity_Id;
1471       Decl  : out Node_Id;
1472       Fnam  : Entity_Id;
1473       Decls : List_Id;
1474       Stms  : List_Id)
1475    is
1476       Spec : Node_Id;
1477
1478    begin
1479       --  Construct function specification
1480
1481       Spec :=
1482         Make_Function_Specification (Loc,
1483           Defining_Unit_Name => Fnam,
1484
1485           Parameter_Specifications => New_List (
1486             Make_Parameter_Specification (Loc,
1487               Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1488               Parameter_Type =>
1489                 Make_Access_Definition (Loc,
1490                   Subtype_Mark => New_Reference_To (
1491                     Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
1492
1493           Subtype_Mark => New_Occurrence_Of (Typ, Loc));
1494
1495       Decl :=
1496         Make_Subprogram_Body (Loc,
1497           Specification => Spec,
1498           Declarations => Decls,
1499           Handled_Statement_Sequence =>
1500             Make_Handled_Sequence_Of_Statements (Loc,
1501               Statements => Stms));
1502    end Build_Stream_Function;
1503
1504    ----------------------------
1505    -- Build_Stream_Procedure --
1506    ----------------------------
1507
1508    procedure Build_Stream_Procedure
1509      (Loc  : Source_Ptr;
1510       Typ  : Entity_Id;
1511       Decl : out Node_Id;
1512       Pnam : Entity_Id;
1513       Stms : List_Id;
1514       Outp : Boolean)
1515    is
1516       Spec : Node_Id;
1517
1518    begin
1519       --  Construct procedure specification
1520
1521       Spec :=
1522         Make_Procedure_Specification (Loc,
1523           Defining_Unit_Name => Pnam,
1524
1525           Parameter_Specifications => New_List (
1526             Make_Parameter_Specification (Loc,
1527               Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1528               Parameter_Type =>
1529                 Make_Access_Definition (Loc,
1530                   Subtype_Mark => New_Reference_To (
1531                     Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))),
1532
1533             Make_Parameter_Specification (Loc,
1534               Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1535               Out_Present         => Outp,
1536               Parameter_Type      => New_Occurrence_Of (Typ, Loc))));
1537
1538       Decl :=
1539         Make_Subprogram_Body (Loc,
1540           Specification => Spec,
1541           Declarations => Empty_List,
1542           Handled_Statement_Sequence =>
1543             Make_Handled_Sequence_Of_Statements (Loc,
1544               Statements => Stms));
1545    end Build_Stream_Procedure;
1546
1547    -----------------------------
1548    -- Has_Stream_Standard_Rep --
1549    -----------------------------
1550
1551    function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is
1552    begin
1553       if Has_Non_Standard_Rep (U_Type) then
1554          return False;
1555       else
1556          return
1557            Esize (First_Subtype (U_Type)) = Esize (Root_Type (U_Type));
1558       end if;
1559    end Has_Stream_Standard_Rep;
1560
1561    ---------------------------------
1562    -- Make_Stream_Subprogram_Name --
1563    ---------------------------------
1564
1565    function Make_Stream_Subprogram_Name
1566      (Loc : Source_Ptr;
1567       Typ : Entity_Id;
1568       Nam : TSS_Name_Type) return Entity_Id
1569    is
1570       Sname : Name_Id;
1571
1572    begin
1573       --  For tagged types, we are dealing with a TSS associated with the
1574       --  declaration, so we use the standard primitive function name. For
1575       --  other types, generate a local TSS name since we are generating
1576       --  the subprogram at the point of use.
1577
1578       if Is_Tagged_Type (Typ) then
1579          Sname := Make_TSS_Name (Typ, Nam);
1580       else
1581          Sname := Make_TSS_Name_Local (Typ, Nam);
1582       end if;
1583
1584       return Make_Defining_Identifier (Loc, Sname);
1585    end Make_Stream_Subprogram_Name;
1586
1587    ----------------------
1588    -- Stream_Base_Type --
1589    ----------------------
1590
1591    function Stream_Base_Type (E : Entity_Id) return Entity_Id is
1592    begin
1593       if Is_Array_Type (E)
1594         and then Is_First_Subtype (E)
1595       then
1596          return E;
1597       else
1598          return Base_Type (E);
1599       end if;
1600    end Stream_Base_Type;
1601
1602 end Exp_Strm;