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-2003, 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, if we have
 683
 684       --     type W is range -1 .. +254;
 685       --     for W'Size use 8;
 686
 687       --  then the representation is also unsigned.
 688
 689       elsif not Is_Unsigned_Type (FST)
 690         and then
 691           (Is_Fixed_Point_Type (U_Type)
 692              or else
 693            Is_Enumeration_Type (U_Type)
 694              or else
 695            (Is_Signed_Integer_Type (U_Type)
 696               and then not Has_Biased_Representation (FST)))
 697       then
 698          if P_Size <= Standard_Short_Short_Integer_Size then
 699             Lib_RE := RE_W_SSI;
 700
 701          elsif P_Size <= Standard_Short_Integer_Size then
 702             Lib_RE := RE_W_SI;
 703
 704          elsif P_Size <= Standard_Integer_Size then
 705             Lib_RE := RE_W_I;
 706
 707          elsif P_Size <= Standard_Long_Integer_Size then
 708             Lib_RE := RE_W_LI;
 709
 710          else
 711             Lib_RE := RE_W_LLI;
 712          end if;
 713
 714       --  Unsigned integer types, also includes unsigned fixed-point types
 715       --  and unsigned enumeration types (note we know they are unsigned
 716       --  because we already tested for signed above).
 717
 718       --  Also includes signed integer types that are unsigned in the sense
 719       --  that they do not include negative numbers. See above for details.
 720
 721       elsif Is_Modular_Integer_Type    (U_Type)
 722         or else Is_Fixed_Point_Type    (U_Type)
 723         or else Is_Enumeration_Type    (U_Type)
 724         or else Is_Signed_Integer_Type (U_Type)
 725       then
 726          if P_Size <= Standard_Short_Short_Integer_Size then
 727             Lib_RE := RE_W_SSU;
 728
 729          elsif P_Size <= Standard_Short_Integer_Size then
 730             Lib_RE := RE_W_SU;
 731
 732          elsif P_Size <= Standard_Integer_Size then
 733             Lib_RE := RE_W_U;
 734
 735          elsif P_Size <= Standard_Long_Integer_Size then
 736             Lib_RE := RE_W_LU;
 737
 738          else
 739             Lib_RE := RE_W_LLU;
 740          end if;
 741
 742       else pragma Assert (Is_Access_Type (U_Type));
 743
 744          if P_Size > System_Address_Size then
 745             Lib_RE := RE_W_AD;
 746          else
 747             Lib_RE := RE_W_AS;
 748          end if;
 749       end if;
 750
 751       --  Unchecked-convert parameter to the required type (i.e. the type of
 752       --  the corresponding parameter, and call the appropriate routine.
 753
 754       Libent := RTE (Lib_RE);
 755
 756       return
 757         Make_Procedure_Call_Statement (Loc,
 758           Name => New_Occurrence_Of (Libent, Loc),
 759           Parameter_Associations => New_List (
 760             Relocate_Node (Strm),
 761             Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))),
 762               Relocate_Node (Item))));
 763    end Build_Elementary_Write_Call;
 764
 765    -----------------------------------------
 766    -- Build_Mutable_Record_Read_Procedure --
 767    -----------------------------------------
 768
 769    procedure Build_Mutable_Record_Read_Procedure
 770      (Loc  : Source_Ptr;
 771       Typ  : Entity_Id;
 772       Decl : out Node_Id;
 773       Pnam : out Entity_Id)
 774    is
 775       Stms  : List_Id;
 776       Disc  : Entity_Id;
 777       Comp  : Node_Id;
 778
 779    begin
 780       Stms := New_List;
 781       Disc := First_Discriminant (Typ);
 782
 783       --  Generate Reads for the discriminants of the type.
 784
 785       while Present (Disc) loop
 786          Comp :=
 787            Make_Selected_Component (Loc,
 788              Prefix => Make_Identifier (Loc, Name_V),
 789              Selector_Name => New_Occurrence_Of (Disc, Loc));
 790
 791          Set_Assignment_OK (Comp);
 792
 793          Append_To (Stms,
 794            Make_Attribute_Reference (Loc,
 795              Prefix => New_Occurrence_Of (Etype (Disc), Loc),
 796                Attribute_Name => Name_Read,
 797                Expressions => New_List (
 798                  Make_Identifier (Loc, Name_S),
 799                  Comp)));
 800
 801          Next_Discriminant (Disc);
 802       end loop;
 803
 804       --  A mutable type cannot be a tagged type, so we generate a new name
 805       --  for the stream procedure.
 806
 807       Pnam :=
 808         Make_Defining_Identifier (Loc,
 809           Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
 810       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
 811
 812       --  Read the discriminants before the rest of the components, so
 813       --  that discriminant values are properly set of variants, etc.
 814       --  If this is an empty record with discriminants, there are no
 815       --  previous statements. If this is an unchecked union, the stream
 816       --  procedure is erroneous, because there are no discriminants to read.
 817
 818       if Is_Unchecked_Union (Typ) then
 819          Stms :=
 820            New_List (
 821              Make_Raise_Program_Error (Loc,
 822                Reason => PE_Unchecked_Union_Restriction));
 823       end if;
 824
 825       if Is_Non_Empty_List (
 826         Statements (Handled_Statement_Sequence (Decl)))
 827       then
 828          Insert_List_Before
 829            (First (Statements (Handled_Statement_Sequence (Decl))), Stms);
 830       else
 831          Set_Statements (Handled_Statement_Sequence (Decl), Stms);
 832       end if;
 833    end Build_Mutable_Record_Read_Procedure;
 834
 835    ------------------------------------------
 836    -- Build_Mutable_Record_Write_Procedure --
 837    ------------------------------------------
 838
 839    procedure Build_Mutable_Record_Write_Procedure
 840      (Loc  : Source_Ptr;
 841       Typ  : Entity_Id;
 842       Decl : out Node_Id;
 843       Pnam : out Entity_Id)
 844    is
 845       Stms  : List_Id;
 846       Disc  : Entity_Id;
 847
 848    begin
 849       Stms := New_List;
 850       Disc := First_Discriminant (Typ);
 851
 852       --  Generate Writes for the discriminants of the type.
 853
 854       while Present (Disc) loop
 855
 856          Append_To (Stms,
 857            Make_Attribute_Reference (Loc,
 858              Prefix => New_Occurrence_Of (Etype (Disc), Loc),
 859                Attribute_Name => Name_Write,
 860                Expressions => New_List (
 861                  Make_Identifier (Loc, Name_S),
 862                  Make_Selected_Component (Loc,
 863                    Prefix => Make_Identifier (Loc, Name_V),
 864                    Selector_Name => New_Occurrence_Of (Disc, Loc)))));
 865
 866          Next_Discriminant (Disc);
 867       end loop;
 868
 869       --  A mutable type cannot be a tagged type, so we generate a new name
 870       --  for the stream procedure.
 871
 872       Pnam :=
 873         Make_Defining_Identifier (Loc,
 874           Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
 875       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
 876
 877       --  Write the discriminants before the rest of the components, so
 878       --  that discriminant values are properly set of variants, etc.
 879       --  If this is an unchecked union, the stream procedure is erroneous
 880       --  because there are no discriminants to write.
 881
 882       if Is_Unchecked_Union (Typ) then
 883          Stms :=
 884            New_List (
 885              Make_Raise_Program_Error (Loc,
 886                Reason => PE_Unchecked_Union_Restriction));
 887       end if;
 888
 889       if Is_Non_Empty_List (
 890         Statements (Handled_Statement_Sequence (Decl)))
 891       then
 892          Insert_List_Before
 893             (First (Statements (Handled_Statement_Sequence (Decl))), Stms);
 894       else
 895          Set_Statements (Handled_Statement_Sequence (Decl), Stms);
 896       end if;
 897    end Build_Mutable_Record_Write_Procedure;
 898
 899    -----------------------------------------------
 900    -- Build_Record_Or_Elementary_Input_Function --
 901    -----------------------------------------------
 902
 903    --  The function we build looks like
 904
 905    --    function InputN (S : access RST) return Typ is
 906    --      C1 : constant Disc_Type_1;
 907    --      Discr_Type_1'Read (S, C1);
 908    --      C2 : constant Disc_Type_2;
 909    --      Discr_Type_2'Read (S, C2);
 910    --      ...
 911    --      Cn : constant Disc_Type_n;
 912    --      Discr_Type_n'Read (S, Cn);
 913    --      V : Typ (C1, C2, .. Cn)
 914
 915    --    begin
 916    --      Typ'Read (S, V);
 917    --      return V;
 918    --    end InputN
 919
 920    --  The discriminants are of course only present in the case of a record
 921    --  with discriminants. In the case of a record with no discriminants, or
 922    --  an elementary type, then no Cn constants are defined.
 923
 924    procedure Build_Record_Or_Elementary_Input_Function
 925      (Loc  : Source_Ptr;
 926       Typ  : Entity_Id;
 927       Decl : out Node_Id;
 928       Fnam : out Entity_Id)
 929    is
 930       Cn     : Name_Id;
 931       J      : Pos;
 932       Decls  : List_Id;
 933       Constr : List_Id;
 934       Stms   : List_Id;
 935       Discr  : Entity_Id;
 936       Odef   : Node_Id;
 937
 938    begin
 939       Decls  := New_List;
 940       Constr := New_List;
 941
 942       J := 1;
 943
 944       if Has_Discriminants (Typ) then
 945          Discr := First_Discriminant (Typ);
 946
 947          while Present (Discr) loop
 948             Cn := New_External_Name ('C', J);
 949
 950             Append_To (Decls,
 951               Make_Object_Declaration (Loc,
 952                 Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
 953                 Object_Definition =>
 954                  New_Occurrence_Of (Etype (Discr), Loc)));
 955
 956             Append_To (Decls,
 957               Make_Attribute_Reference (Loc,
 958                 Prefix => New_Occurrence_Of (Etype (Discr), Loc),
 959                 Attribute_Name => Name_Read,
 960                 Expressions => New_List (
 961                   Make_Identifier (Loc, Name_S),
 962                   Make_Identifier (Loc, Cn))));
 963
 964             Append_To (Constr, Make_Identifier (Loc, Cn));
 965
 966             Next_Discriminant (Discr);
 967             J := J + 1;
 968          end loop;
 969
 970          Odef :=
 971            Make_Subtype_Indication (Loc,
 972              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
 973              Constraint =>
 974                Make_Index_Or_Discriminant_Constraint (Loc,
 975                  Constraints => Constr));
 976
 977       --  If no discriminants, then just use the type with no constraint
 978
 979       else
 980          Odef := New_Occurrence_Of (Typ, Loc);
 981       end if;
 982
 983       Append_To (Decls,
 984         Make_Object_Declaration (Loc,
 985           Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
 986           Object_Definition => Odef));
 987
 988       Stms := New_List (
 989          Make_Attribute_Reference (Loc,
 990            Prefix => New_Occurrence_Of (Typ, Loc),
 991            Attribute_Name => Name_Read,
 992            Expressions => New_List (
 993              Make_Identifier (Loc, Name_S),
 994              Make_Identifier (Loc, Name_V))),
 995
 996          Make_Return_Statement (Loc,
 997            Expression => Make_Identifier (Loc, Name_V)));
 998
 999       Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
1000
1001       Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
1002    end Build_Record_Or_Elementary_Input_Function;
1003
1004    -------------------------------------------------
1005    -- Build_Record_Or_Elementary_Output_Procedure --
1006    -------------------------------------------------
1007
1008    procedure Build_Record_Or_Elementary_Output_Procedure
1009      (Loc  : Source_Ptr;
1010       Typ  : Entity_Id;
1011       Decl : out Node_Id;
1012       Pnam : out Entity_Id)
1013    is
1014       Stms : List_Id;
1015       Disc : Entity_Id;
1016
1017    begin
1018       Stms := New_List;
1019
1020       --  Note that of course there will be no discriminants for the
1021       --  elementary type case, so Has_Discriminants will be False.
1022
1023       if Has_Discriminants (Typ) then
1024          Disc := First_Discriminant (Typ);
1025
1026          while Present (Disc) loop
1027             Append_To (Stms,
1028               Make_Attribute_Reference (Loc,
1029                 Prefix =>
1030                   New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc),
1031                 Attribute_Name => Name_Write,
1032                 Expressions => New_List (
1033                   Make_Identifier (Loc, Name_S),
1034                   Make_Selected_Component (Loc,
1035                     Prefix => Make_Identifier (Loc, Name_V),
1036                     Selector_Name => New_Occurrence_Of (Disc, Loc)))));
1037
1038             Next_Discriminant (Disc);
1039          end loop;
1040       end if;
1041
1042       Append_To (Stms,
1043         Make_Attribute_Reference (Loc,
1044           Prefix => New_Occurrence_Of (Typ, Loc),
1045           Attribute_Name => Name_Write,
1046           Expressions => New_List (
1047             Make_Identifier (Loc, Name_S),
1048             Make_Identifier (Loc, Name_V))));
1049
1050       Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output);
1051
1052       Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
1053    end Build_Record_Or_Elementary_Output_Procedure;
1054
1055    ---------------------------------
1056    -- Build_Record_Read_Procedure --
1057    ---------------------------------
1058
1059    procedure Build_Record_Read_Procedure
1060      (Loc  : Source_Ptr;
1061       Typ  : Entity_Id;
1062       Decl : out Node_Id;
1063       Pnam : out Entity_Id)
1064    is
1065    begin
1066       Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read);
1067       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
1068    end Build_Record_Read_Procedure;
1069
1070    ---------------------------------------
1071    -- Build_Record_Read_Write_Procedure --
1072    ---------------------------------------
1073
1074    --  The form of the record read/write procedure is as shown by the
1075    --  following example for a case with one discriminant case variant:
1076
1077    --    procedure pnam (S : access RST, V : [out] Typ) is
1078    --    begin
1079    --       Component_Type'Read/Write (S, V.component);
1080    --       Component_Type'Read/Write (S, V.component);
1081    --       ...
1082    --       Component_Type'Read/Write (S, V.component);
1083    --
1084    --       case V.discriminant is
1085    --          when choices =>
1086    --             Component_Type'Read/Write (S, V.component);
1087    --             Component_Type'Read/Write (S, V.component);
1088    --             ...
1089    --             Component_Type'Read/Write (S, V.component);
1090    --
1091    --          when choices =>
1092    --             Component_Type'Read/Write (S, V.component);
1093    --             Component_Type'Read/Write (S, V.component);
1094    --             ...
1095    --             Component_Type'Read/Write (S, V.component);
1096    --          ...
1097    --       end case;
1098    --    end pnam;
1099
1100    --  The out keyword for V is supplied in the Read case
1101
1102    procedure Build_Record_Read_Write_Procedure
1103      (Loc  : Source_Ptr;
1104       Typ  : Entity_Id;
1105       Decl : out Node_Id;
1106       Pnam : Entity_Id;
1107       Nam  : Name_Id)
1108    is
1109       Rdef : Node_Id;
1110       Stms : List_Id;
1111       Typt : Entity_Id;
1112
1113       function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
1114       --  Returns a sequence of attributes to process the components that
1115       --  are referenced in the given component list.
1116
1117       function Make_Field_Attribute (C : Entity_Id) return Node_Id;
1118       --  Given C, the entity for a discriminant or component, build
1119       --  an attribute for the corresponding field values.
1120
1121       function Make_Field_Attributes (Clist : List_Id) return List_Id;
1122       --  Given Clist, a component items list, construct series of attributes
1123       --  for fieldwise processing of the corresponding components.
1124
1125       ------------------------------------
1126       -- Make_Component_List_Attributes --
1127       ------------------------------------
1128
1129       function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
1130          CI : constant List_Id := Component_Items (CL);
1131          VP : constant Node_Id := Variant_Part (CL);
1132
1133          Result : List_Id;
1134          Alts   : List_Id;
1135          V      : Node_Id;
1136          DC     : Node_Id;
1137          DCH    : List_Id;
1138
1139       begin
1140          Result := Make_Field_Attributes (CI);
1141
1142          --  If a component is an unchecked union, there is no discriminant
1143          --  and we cannot generate a read/write procedure for it.
1144
1145          if Present (VP) then
1146             if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
1147                return New_List (
1148                  Make_Raise_Program_Error (Sloc (VP),
1149                    Reason => PE_Unchecked_Union_Restriction));
1150             end if;
1151
1152             V := First_Non_Pragma (Variants (VP));
1153             Alts := New_List;
1154             while Present (V) loop
1155
1156                DCH := New_List;
1157                DC := First (Discrete_Choices (V));
1158                while Present (DC) loop
1159                   Append_To (DCH, New_Copy_Tree (DC));
1160                   Next (DC);
1161                end loop;
1162
1163                Append_To (Alts,
1164                  Make_Case_Statement_Alternative (Loc,
1165                    Discrete_Choices => DCH,
1166                    Statements =>
1167                      Make_Component_List_Attributes (Component_List (V))));
1168                Next_Non_Pragma (V);
1169             end loop;
1170
1171             --  Note: in the following, we make sure that we use new occurrence
1172             --  of for the selector, since there are cases in which we make a
1173             --  reference to a hidden discriminant that is not visible.
1174
1175             Append_To (Result,
1176               Make_Case_Statement (Loc,
1177                 Expression =>
1178                   Make_Selected_Component (Loc,
1179                     Prefix => Make_Identifier (Loc, Name_V),
1180                     Selector_Name =>
1181                       New_Occurrence_Of (Entity (Name (VP)), Loc)),
1182                 Alternatives => Alts));
1183
1184          end if;
1185
1186          return Result;
1187       end Make_Component_List_Attributes;
1188
1189       --------------------------
1190       -- Make_Field_Attribute --
1191       --------------------------
1192
1193       function Make_Field_Attribute (C : Entity_Id) return Node_Id is
1194       begin
1195          return
1196            Make_Attribute_Reference (Loc,
1197              Prefix =>
1198                New_Occurrence_Of (Stream_Base_Type (Etype (C)), Loc),
1199              Attribute_Name => Nam,
1200              Expressions => New_List (
1201                Make_Identifier (Loc, Name_S),
1202                Make_Selected_Component (Loc,
1203                  Prefix => Make_Identifier (Loc, Name_V),
1204                  Selector_Name => New_Occurrence_Of (C, Loc))));
1205       end Make_Field_Attribute;
1206
1207       ---------------------------
1208       -- Make_Field_Attributes --
1209       ---------------------------
1210
1211       function Make_Field_Attributes (Clist : List_Id) return List_Id is
1212          Item   : Node_Id;
1213          Result : List_Id;
1214
1215       begin
1216          Result := New_List;
1217
1218          if Present (Clist) then
1219             Item := First (Clist);
1220
1221             --  Loop through components, skipping all internal components,
1222             --  which are not part of the value (e.g. _Tag), except that we
1223             --  don't skip the _Parent, since we do want to process that
1224             --  recursively.
1225
1226             while Present (Item) loop
1227                if Nkind (Item) = N_Component_Declaration
1228                  and then
1229                    (Chars (Defining_Identifier (Item)) = Name_uParent
1230                      or else
1231                     not Is_Internal_Name (Chars (Defining_Identifier (Item))))
1232                then
1233                   Append_To
1234                     (Result,
1235                      Make_Field_Attribute (Defining_Identifier (Item)));
1236                end if;
1237
1238                Next (Item);
1239             end loop;
1240          end if;
1241
1242          return Result;
1243       end Make_Field_Attributes;
1244
1245    --  Start of processing for Build_Record_Read_Write_Procedure
1246
1247    begin
1248       --  For the protected type case, use corresponding record
1249
1250       if Is_Protected_Type (Typ) then
1251          Typt := Corresponding_Record_Type (Typ);
1252       else
1253          Typt := Typ;
1254       end if;
1255
1256       --  Note that we do nothing with the discriminants, since Read and
1257       --  Write do not read or write the discriminant values. All handling
1258       --  of discriminants occurs in the Input and Output subprograms.
1259
1260       Rdef := Type_Definition
1261                 (Declaration_Node (Base_Type (Underlying_Type (Typt))));
1262       Stms := Empty_List;
1263
1264       --  In record extension case, the fields we want, including the _Parent
1265       --  field representing the parent type, are to be found in the extension.
1266       --  Note that we will naturally process the _Parent field using the type
1267       --  of the parent, and hence its stream attributes, which is appropriate.
1268
1269       if Nkind (Rdef) = N_Derived_Type_Definition then
1270          Rdef := Record_Extension_Part (Rdef);
1271       end if;
1272
1273       if Present (Component_List (Rdef)) then
1274          Append_List_To (Stms,
1275            Make_Component_List_Attributes (Component_List (Rdef)));
1276       end if;
1277
1278       Build_Stream_Procedure
1279         (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read);
1280    end Build_Record_Read_Write_Procedure;
1281
1282    ----------------------------------
1283    -- Build_Record_Write_Procedure --
1284    ----------------------------------
1285
1286    procedure Build_Record_Write_Procedure
1287      (Loc  : Source_Ptr;
1288       Typ  : Entity_Id;
1289       Decl : out Node_Id;
1290       Pnam : out Entity_Id)
1291    is
1292    begin
1293       Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write);
1294       Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
1295    end Build_Record_Write_Procedure;
1296
1297    -------------------------------
1298    -- Build_Stream_Attr_Profile --
1299    -------------------------------
1300
1301    function Build_Stream_Attr_Profile
1302      (Loc : Source_Ptr;
1303       Typ : Entity_Id;
1304       Nam : TSS_Name_Type) return List_Id
1305    is
1306       Profile : List_Id;
1307
1308    begin
1309       Profile := New_List (
1310         Make_Parameter_Specification (Loc,
1311           Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
1312           Parameter_Type      =>
1313           Make_Access_Definition (Loc,
1314              Subtype_Mark => New_Reference_To (
1315                Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
1316
1317       if Nam /= TSS_Stream_Input then
1318          Append_To (Profile,
1319            Make_Parameter_Specification (Loc,
1320              Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1321              Out_Present         => (Nam = TSS_Stream_Read),
1322              Parameter_Type      => New_Reference_To (Typ, Loc)));
1323       end if;
1324
1325       return Profile;
1326    end Build_Stream_Attr_Profile;
1327
1328    ---------------------------
1329    -- Build_Stream_Function --
1330    ---------------------------
1331
1332    procedure Build_Stream_Function
1333      (Loc   : Source_Ptr;
1334       Typ   : Entity_Id;
1335       Decl  : out Node_Id;
1336       Fnam  : Entity_Id;
1337       Decls : List_Id;
1338       Stms  : List_Id)
1339    is
1340       Spec : Node_Id;
1341
1342    begin
1343       --  Construct function specification
1344
1345       Spec :=
1346         Make_Function_Specification (Loc,
1347           Defining_Unit_Name => Fnam,
1348
1349           Parameter_Specifications => 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           Subtype_Mark => New_Occurrence_Of (Typ, Loc));
1358
1359       Decl :=
1360         Make_Subprogram_Body (Loc,
1361           Specification => Spec,
1362           Declarations => Decls,
1363           Handled_Statement_Sequence =>
1364             Make_Handled_Sequence_Of_Statements (Loc,
1365               Statements => Stms));
1366    end Build_Stream_Function;
1367
1368    ----------------------------
1369    -- Build_Stream_Procedure --
1370    ----------------------------
1371
1372    procedure Build_Stream_Procedure
1373      (Loc  : Source_Ptr;
1374       Typ  : Entity_Id;
1375       Decl : out Node_Id;
1376       Pnam : Entity_Id;
1377       Stms : List_Id;
1378       Outp : Boolean)
1379    is
1380       Spec : Node_Id;
1381
1382    begin
1383       --  Construct procedure specification
1384
1385       Spec :=
1386         Make_Procedure_Specification (Loc,
1387           Defining_Unit_Name => Pnam,
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             Make_Parameter_Specification (Loc,
1398               Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
1399               Out_Present         => Outp,
1400               Parameter_Type      => New_Occurrence_Of (Typ, Loc))));
1401
1402       Decl :=
1403         Make_Subprogram_Body (Loc,
1404           Specification => Spec,
1405           Declarations => Empty_List,
1406           Handled_Statement_Sequence =>
1407             Make_Handled_Sequence_Of_Statements (Loc,
1408               Statements => Stms));
1409    end Build_Stream_Procedure;
1410
1411    -----------------------------
1412    -- Has_Stream_Standard_Rep --
1413    -----------------------------
1414
1415    function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is
1416    begin
1417       if Has_Non_Standard_Rep (U_Type) then
1418          return False;
1419       else
1420          return
1421            Esize (First_Subtype (U_Type)) = Esize (Root_Type (U_Type));
1422       end if;
1423    end Has_Stream_Standard_Rep;
1424
1425    ---------------------------------
1426    -- Make_Stream_Subprogram_Name --
1427    ---------------------------------
1428
1429    function Make_Stream_Subprogram_Name
1430      (Loc : Source_Ptr;
1431       Typ : Entity_Id;
1432       Nam : TSS_Name_Type) return Entity_Id
1433    is
1434       Sname : Name_Id;
1435
1436    begin
1437       --  For tagged types, we are dealing with a TSS associated with the
1438       --  declaration, so we use the standard primitive function name. For
1439       --  other types, generate a local TSS name since we are generating
1440       --  the subprogram at the point of use.
1441
1442       if Is_Tagged_Type (Typ) then
1443          Sname := Make_TSS_Name (Typ, Nam);
1444       else
1445          Sname := Make_TSS_Name_Local (Typ, Nam);
1446       end if;
1447
1448       return Make_Defining_Identifier (Loc, Sname);
1449    end Make_Stream_Subprogram_Name;
1450
1451    ----------------------
1452    -- Stream_Base_Type --
1453    ----------------------
1454
1455    function Stream_Base_Type (E : Entity_Id) return Entity_Id is
1456    begin
1457       if Is_Array_Type (E)
1458         and then Is_First_Subtype (E)
1459       then
1460          return E;
1461       else
1462          return Base_Type (E);
1463       end if;
1464    end Stream_Base_Type;
1465
1466 end Exp_Strm;