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