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