gcc/ada/exp_strm.adb

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