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-2020, 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 3, 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 COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Elists; use Elists; 29with Exp_Util; use Exp_Util; 30with Namet; use Namet; 31with Nlists; use Nlists; 32with Nmake; use Nmake; 33with Rtsfind; use Rtsfind; 34with Sem_Aux; use Sem_Aux; 35with Sem_Util; use Sem_Util; 36with Sinfo; use Sinfo; 37with Snames; use Snames; 38with Stand; use Stand; 39with Tbuild; use Tbuild; 40with Ttypes; use Ttypes; 41with Uintp; use Uintp; 42 43package body Exp_Strm is 44 45 ----------------------- 46 -- Local Subprograms -- 47 ----------------------- 48 49 procedure Build_Array_Read_Write_Procedure 50 (Nod : Node_Id; 51 Typ : Entity_Id; 52 Decl : out Node_Id; 53 Pnam : Entity_Id; 54 Nam : Name_Id); 55 -- Common routine shared to build either an array Read procedure or an 56 -- array Write procedure, Nam is Name_Read or Name_Write to select which. 57 -- Pnam is the defining identifier for the constructed procedure. The 58 -- other parameters are as for Build_Array_Read_Procedure except that 59 -- the first parameter Nod supplies the Sloc to be used to generate code. 60 61 procedure Build_Record_Read_Write_Procedure 62 (Loc : Source_Ptr; 63 Typ : Entity_Id; 64 Decl : out Node_Id; 65 Pnam : Entity_Id; 66 Nam : Name_Id); 67 -- Common routine shared to build a record Read Write procedure, Nam 68 -- is Name_Read or Name_Write to select which. Pnam is the defining 69 -- identifier for the constructed procedure. The other parameters are 70 -- as for Build_Record_Read_Procedure. 71 72 procedure Build_Stream_Function 73 (Loc : Source_Ptr; 74 Typ : Entity_Id; 75 Decl : out Node_Id; 76 Fnam : Entity_Id; 77 Decls : List_Id; 78 Stms : List_Id); 79 -- Called to build an array or record stream function. The first three 80 -- arguments are the same as Build_Record_Or_Elementary_Input_Function. 81 -- Decls and Stms are the declarations and statements for the body and 82 -- The parameter Fnam is the name of the constructed function. 83 84 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean; 85 -- This function is used to test the type U_Type, to determine if it has 86 -- a standard representation from a streaming point of view. Standard means 87 -- that it has a standard representation (e.g. no enumeration rep clause), 88 -- and the size of the root type is the same as the streaming size (which 89 -- is defined as value specified by a Stream_Size clause if present, or 90 -- the Esize of U_Type if not). 91 92 function Make_Stream_Subprogram_Name 93 (Loc : Source_Ptr; 94 Typ : Entity_Id; 95 Nam : TSS_Name_Type) return Entity_Id; 96 -- Return the entity that identifies the stream subprogram for type Typ 97 -- that is identified by the given Nam. This procedure deals with the 98 -- difference between tagged types (where a single subprogram associated 99 -- with the type is generated) and all other cases (where a subprogram 100 -- is generated at the point of the stream attribute reference). The 101 -- Loc parameter is used as the Sloc of the created entity. 102 103 function Stream_Base_Type (E : Entity_Id) return Entity_Id; 104 -- Stream attributes work on the basis of the base type except for the 105 -- array case. For the array case, we do not go to the base type, but 106 -- to the first subtype if it is constrained. This avoids problems with 107 -- incorrect conversions in the packed array case. Stream_Base_Type is 108 -- exactly this function (returns the base type, unless we have an array 109 -- type whose first subtype is constrained, in which case it returns the 110 -- first subtype). 111 112 -------------------------------- 113 -- Build_Array_Input_Function -- 114 -------------------------------- 115 116 -- The function we build looks like 117 118 -- function typSI[_nnn] (S : access RST) return Typ is 119 -- L1 : constant Index_Type_1 := Index_Type_1'Input (S); 120 -- H1 : constant Index_Type_1 := Index_Type_1'Input (S); 121 -- L2 : constant Index_Type_2 := Index_Type_2'Input (S); 122 -- H2 : constant Index_Type_2 := Index_Type_2'Input (S); 123 -- .. 124 -- Ln : constant Index_Type_n := Index_Type_n'Input (S); 125 -- Hn : constant Index_Type_n := Index_Type_n'Input (S); 126 -- 127 -- V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn) 128 129 -- begin 130 -- Typ'Read (S, V); 131 -- return V; 132 -- end typSI[_nnn] 133 134 -- Note: the suffix [_nnn] is present for untagged types, where we generate 135 -- a local subprogram at the point of the occurrence of the attribute 136 -- reference, so the name must be unique. 137 138 procedure Build_Array_Input_Function 139 (Loc : Source_Ptr; 140 Typ : Entity_Id; 141 Decl : out Node_Id; 142 Fnam : out Entity_Id) 143 is 144 Dim : constant Pos := Number_Dimensions (Typ); 145 Lnam : Name_Id; 146 Hnam : Name_Id; 147 Decls : List_Id; 148 Ranges : List_Id; 149 Stms : List_Id; 150 Rstmt : Node_Id; 151 Indx : Node_Id; 152 Odecl : Node_Id; 153 154 begin 155 Decls := New_List; 156 Ranges := New_List; 157 Indx := First_Index (Typ); 158 for J in 1 .. Dim loop 159 Lnam := New_External_Name ('L', J); 160 Hnam := New_External_Name ('H', J); 161 162 Append_To (Decls, 163 Make_Object_Declaration (Loc, 164 Defining_Identifier => Make_Defining_Identifier (Loc, Lnam), 165 Constant_Present => True, 166 Object_Definition => New_Occurrence_Of (Etype (Indx), Loc), 167 Expression => 168 Make_Attribute_Reference (Loc, 169 Prefix => 170 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), 171 Attribute_Name => Name_Input, 172 Expressions => New_List (Make_Identifier (Loc, Name_S))))); 173 174 Append_To (Decls, 175 Make_Object_Declaration (Loc, 176 Defining_Identifier => Make_Defining_Identifier (Loc, Hnam), 177 Constant_Present => True, 178 Object_Definition => 179 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), 180 Expression => 181 Make_Attribute_Reference (Loc, 182 Prefix => 183 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), 184 Attribute_Name => Name_Input, 185 Expressions => New_List (Make_Identifier (Loc, Name_S))))); 186 187 Append_To (Ranges, 188 Make_Range (Loc, 189 Low_Bound => Make_Identifier (Loc, Lnam), 190 High_Bound => Make_Identifier (Loc, Hnam))); 191 192 Next_Index (Indx); 193 end loop; 194 195 -- If the type is constrained, use it directly. Otherwise build a 196 -- subtype indication with the proper bounds. 197 198 if Is_Constrained (Typ) then 199 Odecl := 200 Make_Object_Declaration (Loc, 201 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 202 Object_Definition => New_Occurrence_Of (Typ, Loc)); 203 204 else 205 Odecl := 206 Make_Object_Declaration (Loc, 207 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 208 Object_Definition => 209 Make_Subtype_Indication (Loc, 210 Subtype_Mark => 211 New_Occurrence_Of (Stream_Base_Type (Typ), Loc), 212 Constraint => 213 Make_Index_Or_Discriminant_Constraint (Loc, Ranges))); 214 end if; 215 216 Rstmt := 217 Make_Attribute_Reference (Loc, 218 Prefix => New_Occurrence_Of (Typ, Loc), 219 Attribute_Name => Name_Read, 220 Expressions => New_List ( 221 Make_Identifier (Loc, Name_S), 222 Make_Identifier (Loc, Name_V))); 223 224 Stms := New_List ( 225 Make_Extended_Return_Statement (Loc, 226 Return_Object_Declarations => New_List (Odecl), 227 Handled_Statement_Sequence => 228 Make_Handled_Sequence_Of_Statements (Loc, New_List (Rstmt)))); 229 230 Fnam := 231 Make_Defining_Identifier (Loc, 232 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input)); 233 234 Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms); 235 end Build_Array_Input_Function; 236 237 ---------------------------------- 238 -- Build_Array_Output_Procedure -- 239 ---------------------------------- 240 241 procedure Build_Array_Output_Procedure 242 (Loc : Source_Ptr; 243 Typ : Entity_Id; 244 Decl : out Node_Id; 245 Pnam : out Entity_Id) 246 is 247 Stms : List_Id; 248 Indx : Node_Id; 249 250 begin 251 -- Build series of statements to output bounds 252 253 Indx := First_Index (Typ); 254 Stms := New_List; 255 256 for J in 1 .. Number_Dimensions (Typ) loop 257 Append_To (Stms, 258 Make_Attribute_Reference (Loc, 259 Prefix => 260 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), 261 Attribute_Name => Name_Write, 262 Expressions => New_List ( 263 Make_Identifier (Loc, Name_S), 264 Make_Attribute_Reference (Loc, 265 Prefix => Make_Identifier (Loc, Name_V), 266 Attribute_Name => Name_First, 267 Expressions => New_List ( 268 Make_Integer_Literal (Loc, J)))))); 269 270 Append_To (Stms, 271 Make_Attribute_Reference (Loc, 272 Prefix => 273 New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc), 274 Attribute_Name => Name_Write, 275 Expressions => New_List ( 276 Make_Identifier (Loc, Name_S), 277 Make_Attribute_Reference (Loc, 278 Prefix => Make_Identifier (Loc, Name_V), 279 Attribute_Name => Name_Last, 280 Expressions => New_List ( 281 Make_Integer_Literal (Loc, J)))))); 282 283 Next_Index (Indx); 284 end loop; 285 286 -- Append Write attribute to write array elements 287 288 Append_To (Stms, 289 Make_Attribute_Reference (Loc, 290 Prefix => New_Occurrence_Of (Typ, Loc), 291 Attribute_Name => Name_Write, 292 Expressions => New_List ( 293 Make_Identifier (Loc, Name_S), 294 Make_Identifier (Loc, Name_V)))); 295 296 Pnam := 297 Make_Defining_Identifier (Loc, 298 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output)); 299 300 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False); 301 end Build_Array_Output_Procedure; 302 303 -------------------------------- 304 -- Build_Array_Read_Procedure -- 305 -------------------------------- 306 307 procedure Build_Array_Read_Procedure 308 (Nod : Node_Id; 309 Typ : Entity_Id; 310 Decl : out Node_Id; 311 Pnam : out Entity_Id) 312 is 313 Loc : constant Source_Ptr := Sloc (Nod); 314 315 begin 316 Pnam := 317 Make_Defining_Identifier (Loc, 318 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read)); 319 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read); 320 end Build_Array_Read_Procedure; 321 322 -------------------------------------- 323 -- Build_Array_Read_Write_Procedure -- 324 -------------------------------------- 325 326 -- The form of the array read/write procedure is as follows: 327 328 -- procedure pnam (S : access RST, V : [out] Typ) is 329 -- begin 330 -- for L1 in V'Range (1) loop 331 -- for L2 in V'Range (2) loop 332 -- ... 333 -- for Ln in V'Range (n) loop 334 -- Component_Type'Read/Write (S, V (L1, L2, .. Ln)); 335 -- end loop; 336 -- .. 337 -- end loop; 338 -- end loop 339 -- end pnam; 340 341 -- The out keyword for V is supplied in the Read case 342 343 procedure Build_Array_Read_Write_Procedure 344 (Nod : Node_Id; 345 Typ : Entity_Id; 346 Decl : out Node_Id; 347 Pnam : Entity_Id; 348 Nam : Name_Id) 349 is 350 Loc : constant Source_Ptr := Sloc (Nod); 351 Ndim : constant Pos := Number_Dimensions (Typ); 352 Ctyp : constant Entity_Id := Component_Type (Typ); 353 354 Stm : Node_Id; 355 Exl : List_Id; 356 RW : Entity_Id; 357 358 begin 359 -- First build the inner attribute call 360 361 Exl := New_List; 362 363 for J in 1 .. Ndim loop 364 Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', J))); 365 end loop; 366 367 Stm := 368 Make_Attribute_Reference (Loc, 369 Prefix => New_Occurrence_Of (Stream_Base_Type (Ctyp), Loc), 370 Attribute_Name => Nam, 371 Expressions => New_List ( 372 Make_Identifier (Loc, Name_S), 373 Make_Indexed_Component (Loc, 374 Prefix => Make_Identifier (Loc, Name_V), 375 Expressions => Exl))); 376 377 -- The corresponding stream attribute for the component type of the 378 -- array may be user-defined, and be frozen after the type for which 379 -- we are generating the stream subprogram. In that case, freeze the 380 -- stream attribute of the component type, whose declaration could not 381 -- generate any additional freezing actions in any case. 382 383 if Nam = Name_Read then 384 RW := TSS (Base_Type (Ctyp), TSS_Stream_Read); 385 else 386 RW := TSS (Base_Type (Ctyp), TSS_Stream_Write); 387 end if; 388 389 if Present (RW) 390 and then not Is_Frozen (RW) 391 then 392 Set_Is_Frozen (RW); 393 end if; 394 395 -- Now this is the big loop to wrap that statement up in a sequence 396 -- of loops. The first time around, Stm is the attribute call. The 397 -- second and subsequent times, Stm is an inner loop. 398 399 for J in 1 .. Ndim loop 400 Stm := 401 Make_Implicit_Loop_Statement (Nod, 402 Iteration_Scheme => 403 Make_Iteration_Scheme (Loc, 404 Loop_Parameter_Specification => 405 Make_Loop_Parameter_Specification (Loc, 406 Defining_Identifier => 407 Make_Defining_Identifier (Loc, 408 Chars => New_External_Name ('L', Ndim - J + 1)), 409 410 Discrete_Subtype_Definition => 411 Make_Attribute_Reference (Loc, 412 Prefix => Make_Identifier (Loc, Name_V), 413 Attribute_Name => Name_Range, 414 415 Expressions => New_List ( 416 Make_Integer_Literal (Loc, Ndim - J + 1))))), 417 418 Statements => New_List (Stm)); 419 420 end loop; 421 422 Build_Stream_Procedure 423 (Loc, Typ, Decl, Pnam, New_List (Stm), Outp => Nam = Name_Read); 424 end Build_Array_Read_Write_Procedure; 425 426 --------------------------------- 427 -- Build_Array_Write_Procedure -- 428 --------------------------------- 429 430 procedure Build_Array_Write_Procedure 431 (Nod : Node_Id; 432 Typ : Entity_Id; 433 Decl : out Node_Id; 434 Pnam : out Entity_Id) 435 is 436 Loc : constant Source_Ptr := Sloc (Nod); 437 begin 438 Pnam := 439 Make_Defining_Identifier (Loc, 440 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write)); 441 Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write); 442 end Build_Array_Write_Procedure; 443 444 --------------------------------- 445 -- Build_Elementary_Input_Call -- 446 --------------------------------- 447 448 function Build_Elementary_Input_Call (N : Node_Id) return Node_Id is 449 Loc : constant Source_Ptr := Sloc (N); 450 P_Type : constant Entity_Id := Entity (Prefix (N)); 451 U_Type : constant Entity_Id := Underlying_Type (P_Type); 452 Rt_Type : constant Entity_Id := Root_Type (U_Type); 453 FST : constant Entity_Id := First_Subtype (U_Type); 454 Strm : constant Node_Id := First (Expressions (N)); 455 Targ : constant Node_Id := Next (Strm); 456 P_Size : constant Uint := Get_Stream_Size (FST); 457 Res : Node_Id; 458 Lib_RE : RE_Id; 459 460 begin 461 462 -- Check first for Boolean and Character. These are enumeration types, 463 -- but we treat them specially, since they may require special handling 464 -- in the transfer protocol. However, this special handling only applies 465 -- if they have standard representation, otherwise they are treated like 466 -- any other enumeration type. 467 468 if Rt_Type = Standard_Boolean 469 and then Has_Stream_Standard_Rep (U_Type) 470 then 471 Lib_RE := RE_I_B; 472 473 elsif Rt_Type = Standard_Character 474 and then Has_Stream_Standard_Rep (U_Type) 475 then 476 Lib_RE := RE_I_C; 477 478 elsif Rt_Type = Standard_Wide_Character 479 and then Has_Stream_Standard_Rep (U_Type) 480 then 481 Lib_RE := RE_I_WC; 482 483 elsif Rt_Type = Standard_Wide_Wide_Character 484 and then Has_Stream_Standard_Rep (U_Type) 485 then 486 Lib_RE := RE_I_WWC; 487 488 -- Floating point types 489 490 elsif Is_Floating_Point_Type (U_Type) then 491 492 -- Question: should we use P_Size or Rt_Type to distinguish between 493 -- possible floating point types? If a non-standard size or a stream 494 -- size is specified, then we should certainly use the size. But if 495 -- we have two types the same (notably Short_Float_Size = Float_Size 496 -- which is close to universally true, and Long_Long_Float_Size = 497 -- Long_Float_Size, true on most targets except the x86), then we 498 -- would really rather use the root type, so that if people want to 499 -- fiddle with System.Stream_Attributes to get inter-target portable 500 -- streams, they get the size they expect. Consider in particular the 501 -- case of a stream written on an x86, with 96-bit Long_Long_Float 502 -- being read into a non-x86 target with 64 bit Long_Long_Float. A 503 -- special version of System.Stream_Attributes can deal with this 504 -- provided the proper type is always used. 505 506 -- To deal with these two requirements we add the special checks 507 -- on equal sizes and use the root type to distinguish. 508 509 if P_Size <= Standard_Short_Float_Size 510 and then (Standard_Short_Float_Size /= Standard_Float_Size 511 or else Rt_Type = Standard_Short_Float) 512 then 513 Lib_RE := RE_I_SF; 514 515 elsif P_Size <= Standard_Float_Size then 516 Lib_RE := RE_I_F; 517 518 elsif P_Size <= Standard_Long_Float_Size 519 and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size 520 or else Rt_Type = Standard_Long_Float) 521 then 522 Lib_RE := RE_I_LF; 523 524 else 525 Lib_RE := RE_I_LLF; 526 end if; 527 528 -- Signed integer types. Also includes signed fixed-point types and 529 -- enumeration types with a signed representation. 530 531 -- Note on signed integer types. We do not consider types as signed for 532 -- this purpose if they have no negative numbers, or if they have biased 533 -- representation. The reason is that the value in either case basically 534 -- represents an unsigned value. 535 536 -- For example, consider: 537 538 -- type W is range 0 .. 2**32 - 1; 539 -- for W'Size use 32; 540 541 -- This is a signed type, but the representation is unsigned, and may 542 -- be outside the range of a 32-bit signed integer, so this must be 543 -- treated as 32-bit unsigned. 544 545 -- Similarly, if we have 546 547 -- type W is range -1 .. +254; 548 -- for W'Size use 8; 549 550 -- then the representation is unsigned 551 552 elsif not Is_Unsigned_Type (FST) 553 554 -- The following set of tests gets repeated many times, we should 555 -- have an abstraction defined ??? 556 557 and then 558 (Is_Fixed_Point_Type (U_Type) 559 or else 560 Is_Enumeration_Type (U_Type) 561 or else 562 (Is_Signed_Integer_Type (U_Type) 563 and then not Has_Biased_Representation (FST))) 564 565 then 566 if P_Size <= Standard_Short_Short_Integer_Size then 567 Lib_RE := RE_I_SSI; 568 569 elsif P_Size <= Standard_Short_Integer_Size then 570 Lib_RE := RE_I_SI; 571 572 elsif P_Size = 24 then 573 Lib_RE := RE_I_I24; 574 575 elsif P_Size <= Standard_Integer_Size then 576 Lib_RE := RE_I_I; 577 578 elsif P_Size <= Standard_Long_Integer_Size then 579 Lib_RE := RE_I_LI; 580 581 elsif P_Size <= Standard_Long_Long_Integer_Size then 582 Lib_RE := RE_I_LLI; 583 584 else 585 Lib_RE := RE_I_LLLI; 586 end if; 587 588 -- Unsigned integer types, also includes unsigned fixed-point types 589 -- and enumeration types with an unsigned representation (note that 590 -- we know they are unsigned because we already tested for signed). 591 592 -- Also includes signed integer types that are unsigned in the sense 593 -- that they do not include negative numbers. See above for details. 594 595 elsif Is_Modular_Integer_Type (U_Type) 596 or else Is_Fixed_Point_Type (U_Type) 597 or else Is_Enumeration_Type (U_Type) 598 or else Is_Signed_Integer_Type (U_Type) 599 then 600 if P_Size <= Standard_Short_Short_Integer_Size then 601 Lib_RE := RE_I_SSU; 602 603 elsif P_Size <= Standard_Short_Integer_Size then 604 Lib_RE := RE_I_SU; 605 606 elsif P_Size = 24 then 607 Lib_RE := RE_I_U24; 608 609 elsif P_Size <= Standard_Integer_Size then 610 Lib_RE := RE_I_U; 611 612 elsif P_Size <= Standard_Long_Integer_Size then 613 Lib_RE := RE_I_LU; 614 615 elsif P_Size <= Standard_Long_Long_Integer_Size then 616 Lib_RE := RE_I_LLU; 617 618 else 619 Lib_RE := RE_I_LLLU; 620 end if; 621 622 else pragma Assert (Is_Access_Type (U_Type)); 623 if P_Size > System_Address_Size then 624 Lib_RE := RE_I_AD; 625 else 626 Lib_RE := RE_I_AS; 627 end if; 628 end if; 629 630 -- Call the function, and do an unchecked conversion of the result 631 -- to the actual type of the prefix. If the target is a discriminant, 632 -- and we are in the body of the default implementation of a 'Read 633 -- attribute, set target type to force a constraint check (13.13.2(35)). 634 -- If the type of the discriminant is currently private, add another 635 -- unchecked conversion from the full view. 636 637 if Nkind (Targ) = N_Identifier 638 and then Is_Internal_Name (Chars (Targ)) 639 and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read) 640 then 641 Res := 642 Unchecked_Convert_To (Base_Type (U_Type), 643 Make_Function_Call (Loc, 644 Name => New_Occurrence_Of (RTE (Lib_RE), Loc), 645 Parameter_Associations => New_List ( 646 Relocate_Node (Strm)))); 647 648 Set_Do_Range_Check (Res); 649 650 if Base_Type (P_Type) /= Base_Type (U_Type) then 651 Res := Unchecked_Convert_To (Base_Type (P_Type), Res); 652 end if; 653 654 return Res; 655 656 else 657 Res := 658 Make_Function_Call (Loc, 659 Name => New_Occurrence_Of (RTE (Lib_RE), Loc), 660 Parameter_Associations => New_List ( 661 Relocate_Node (Strm))); 662 663 -- Now convert to the base type if we do not have a biased type. Note 664 -- that we did not do this in some older versions, and the result was 665 -- losing a required range check in the case where 'Input is being 666 -- called from 'Read. 667 668 if not Has_Biased_Representation (P_Type) then 669 return Unchecked_Convert_To (Base_Type (P_Type), Res); 670 671 -- For the biased case, the conversion to the base type loses the 672 -- biasing, so just convert to Ptype. This is not quite right, and 673 -- for example may lose a corner case CE test, but it is such a 674 -- rare case that for now we ignore it ??? 675 676 else 677 return Unchecked_Convert_To (P_Type, Res); 678 end if; 679 end if; 680 end Build_Elementary_Input_Call; 681 682 --------------------------------- 683 -- Build_Elementary_Write_Call -- 684 --------------------------------- 685 686 function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is 687 Loc : constant Source_Ptr := Sloc (N); 688 P_Type : constant Entity_Id := Entity (Prefix (N)); 689 U_Type : constant Entity_Id := Underlying_Type (P_Type); 690 Rt_Type : constant Entity_Id := Root_Type (U_Type); 691 FST : constant Entity_Id := First_Subtype (U_Type); 692 Strm : constant Node_Id := First (Expressions (N)); 693 Item : constant Node_Id := Next (Strm); 694 P_Size : Uint; 695 Lib_RE : RE_Id; 696 Libent : Entity_Id; 697 698 begin 699 -- Compute the size of the stream element. This is either the size of 700 -- the first subtype or if given the size of the Stream_Size attribute. 701 702 if Has_Stream_Size_Clause (FST) then 703 P_Size := Static_Integer (Expression (Stream_Size_Clause (FST))); 704 else 705 P_Size := Esize (FST); 706 end if; 707 708 -- Find the routine to be called 709 710 -- Check for First Boolean and Character. These are enumeration types, 711 -- but we treat them specially, since they may require special handling 712 -- in the transfer protocol. However, this special handling only applies 713 -- if they have standard representation, otherwise they are treated like 714 -- any other enumeration type. 715 716 if Rt_Type = Standard_Boolean 717 and then Has_Stream_Standard_Rep (U_Type) 718 then 719 Lib_RE := RE_W_B; 720 721 elsif Rt_Type = Standard_Character 722 and then Has_Stream_Standard_Rep (U_Type) 723 then 724 Lib_RE := RE_W_C; 725 726 elsif Rt_Type = Standard_Wide_Character 727 and then Has_Stream_Standard_Rep (U_Type) 728 then 729 Lib_RE := RE_W_WC; 730 731 elsif Rt_Type = Standard_Wide_Wide_Character 732 and then Has_Stream_Standard_Rep (U_Type) 733 then 734 Lib_RE := RE_W_WWC; 735 736 -- Floating point types 737 738 elsif Is_Floating_Point_Type (U_Type) then 739 740 -- Question: should we use P_Size or Rt_Type to distinguish between 741 -- possible floating point types? If a non-standard size or a stream 742 -- size is specified, then we should certainly use the size. But if 743 -- we have two types the same (notably Short_Float_Size = Float_Size 744 -- which is close to universally true, and Long_Long_Float_Size = 745 -- Long_Float_Size, true on most targets except the x86), then we 746 -- would really rather use the root type, so that if people want to 747 -- fiddle with System.Stream_Attributes to get inter-target portable 748 -- streams, they get the size they expect. Consider in particular the 749 -- case of a stream written on an x86, with 96-bit Long_Long_Float 750 -- being read into a non-x86 target with 64 bit Long_Long_Float. A 751 -- special version of System.Stream_Attributes can deal with this 752 -- provided the proper type is always used. 753 754 -- To deal with these two requirements we add the special checks 755 -- on equal sizes and use the root type to distinguish. 756 757 if P_Size <= Standard_Short_Float_Size 758 and then (Standard_Short_Float_Size /= Standard_Float_Size 759 or else Rt_Type = Standard_Short_Float) 760 then 761 Lib_RE := RE_W_SF; 762 763 elsif P_Size <= Standard_Float_Size then 764 Lib_RE := RE_W_F; 765 766 elsif P_Size <= Standard_Long_Float_Size 767 and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size 768 or else Rt_Type = Standard_Long_Float) 769 then 770 Lib_RE := RE_W_LF; 771 772 else 773 Lib_RE := RE_W_LLF; 774 end if; 775 776 -- Signed integer types. Also includes signed fixed-point types and 777 -- signed enumeration types share this circuitry. 778 779 -- Note on signed integer types. We do not consider types as signed for 780 -- this purpose if they have no negative numbers, or if they have biased 781 -- representation. The reason is that the value in either case basically 782 -- represents an unsigned value. 783 784 -- For example, consider: 785 786 -- type W is range 0 .. 2**32 - 1; 787 -- for W'Size use 32; 788 789 -- This is a signed type, but the representation is unsigned, and may 790 -- be outside the range of a 32-bit signed integer, so this must be 791 -- treated as 32-bit unsigned. 792 793 -- Similarly, the representation is also unsigned if we have: 794 795 -- type W is range -1 .. +254; 796 -- for W'Size use 8; 797 798 -- forcing a biased and unsigned representation 799 800 elsif not Is_Unsigned_Type (FST) 801 and then 802 (Is_Fixed_Point_Type (U_Type) 803 or else 804 Is_Enumeration_Type (U_Type) 805 or else 806 (Is_Signed_Integer_Type (U_Type) 807 and then not Has_Biased_Representation (FST))) 808 then 809 if P_Size <= Standard_Short_Short_Integer_Size then 810 Lib_RE := RE_W_SSI; 811 812 elsif P_Size <= Standard_Short_Integer_Size then 813 Lib_RE := RE_W_SI; 814 815 elsif P_Size = 24 then 816 Lib_RE := RE_W_I24; 817 818 elsif P_Size <= Standard_Integer_Size then 819 Lib_RE := RE_W_I; 820 821 elsif P_Size <= Standard_Long_Integer_Size then 822 Lib_RE := RE_W_LI; 823 824 elsif P_Size <= Standard_Long_Long_Integer_Size then 825 Lib_RE := RE_W_LLI; 826 827 else 828 Lib_RE := RE_W_LLLI; 829 end if; 830 831 -- Unsigned integer types, also includes unsigned fixed-point types 832 -- and unsigned enumeration types (note we know they are unsigned 833 -- because we already tested for signed above). 834 835 -- Also includes signed integer types that are unsigned in the sense 836 -- that they do not include negative numbers. See above for details. 837 838 elsif Is_Modular_Integer_Type (U_Type) 839 or else Is_Fixed_Point_Type (U_Type) 840 or else Is_Enumeration_Type (U_Type) 841 or else Is_Signed_Integer_Type (U_Type) 842 then 843 if P_Size <= Standard_Short_Short_Integer_Size then 844 Lib_RE := RE_W_SSU; 845 846 elsif P_Size <= Standard_Short_Integer_Size then 847 Lib_RE := RE_W_SU; 848 849 elsif P_Size = 24 then 850 Lib_RE := RE_W_U24; 851 852 elsif P_Size <= Standard_Integer_Size then 853 Lib_RE := RE_W_U; 854 855 elsif P_Size <= Standard_Long_Integer_Size then 856 Lib_RE := RE_W_LU; 857 858 elsif P_Size <= Standard_Long_Long_Integer_Size then 859 Lib_RE := RE_W_LLU; 860 861 else 862 Lib_RE := RE_W_LLLU; 863 end if; 864 865 else pragma Assert (Is_Access_Type (U_Type)); 866 867 if P_Size > System_Address_Size then 868 Lib_RE := RE_W_AD; 869 else 870 Lib_RE := RE_W_AS; 871 end if; 872 end if; 873 874 -- Unchecked-convert parameter to the required type (i.e. the type of 875 -- the corresponding parameter, and call the appropriate routine. 876 877 Libent := RTE (Lib_RE); 878 879 return 880 Make_Procedure_Call_Statement (Loc, 881 Name => New_Occurrence_Of (Libent, Loc), 882 Parameter_Associations => New_List ( 883 Relocate_Node (Strm), 884 Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))), 885 Relocate_Node (Item)))); 886 end Build_Elementary_Write_Call; 887 888 ----------------------------------------- 889 -- Build_Mutable_Record_Read_Procedure -- 890 ----------------------------------------- 891 892 procedure Build_Mutable_Record_Read_Procedure 893 (Loc : Source_Ptr; 894 Typ : Entity_Id; 895 Decl : out Node_Id; 896 Pnam : out Entity_Id) 897 is 898 Out_Formal : Node_Id; 899 -- Expression denoting the out formal parameter 900 901 Dcls : constant List_Id := New_List; 902 -- Declarations for the 'Read body 903 904 Stms : constant List_Id := New_List; 905 -- Statements for the 'Read body 906 907 Disc : Entity_Id; 908 -- Entity of the discriminant being processed 909 910 Tmp_For_Disc : Entity_Id; 911 -- Temporary object used to read the value of Disc 912 913 Tmps_For_Discs : constant List_Id := New_List; 914 -- List of object declarations for temporaries holding the read values 915 -- for the discriminants. 916 917 Cstr : constant List_Id := New_List; 918 -- List of constraints to be applied on temporary record 919 920 Discriminant_Checks : constant List_Id := New_List; 921 -- List of discriminant checks to be performed if the actual object 922 -- is constrained. 923 924 Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V); 925 -- Temporary record must hide formal (assignments to components of the 926 -- record are always generated with V as the identifier for the record). 927 928 Constrained_Stms : List_Id := New_List; 929 -- Statements within the block where we have the constrained temporary 930 931 begin 932 -- A mutable type cannot be a tagged type, so we generate a new name 933 -- for the stream procedure. 934 935 Pnam := 936 Make_Defining_Identifier (Loc, 937 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read)); 938 939 if Is_Unchecked_Union (Typ) then 940 941 -- If this is an unchecked union, the stream procedure is erroneous, 942 -- because there are no discriminants to read. 943 944 -- This should generate a warning ??? 945 946 Append_To (Stms, 947 Make_Raise_Program_Error (Loc, 948 Reason => PE_Unchecked_Union_Restriction)); 949 950 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => True); 951 return; 952 end if; 953 954 Disc := First_Discriminant (Typ); 955 956 Out_Formal := 957 Make_Selected_Component (Loc, 958 Prefix => New_Occurrence_Of (Pnam, Loc), 959 Selector_Name => Make_Identifier (Loc, Name_V)); 960 961 -- Generate Reads for the discriminants of the type. The discriminants 962 -- need to be read before the rest of the components, so that variants 963 -- are initialized correctly. The discriminants must be read into temp 964 -- variables so an incomplete Read (interrupted by an exception, for 965 -- example) does not alter the passed object. 966 967 while Present (Disc) loop 968 Tmp_For_Disc := Make_Defining_Identifier (Loc, 969 New_External_Name (Chars (Disc), "D")); 970 971 Append_To (Tmps_For_Discs, 972 Make_Object_Declaration (Loc, 973 Defining_Identifier => Tmp_For_Disc, 974 Object_Definition => New_Occurrence_Of (Etype (Disc), Loc))); 975 Set_No_Initialization (Last (Tmps_For_Discs)); 976 977 Append_To (Stms, 978 Make_Attribute_Reference (Loc, 979 Prefix => New_Occurrence_Of (Etype (Disc), Loc), 980 Attribute_Name => Name_Read, 981 Expressions => New_List ( 982 Make_Identifier (Loc, Name_S), 983 New_Occurrence_Of (Tmp_For_Disc, Loc)))); 984 985 Append_To (Cstr, 986 Make_Discriminant_Association (Loc, 987 Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)), 988 Expression => New_Occurrence_Of (Tmp_For_Disc, Loc))); 989 990 Append_To (Discriminant_Checks, 991 Make_Raise_Constraint_Error (Loc, 992 Condition => 993 Make_Op_Ne (Loc, 994 Left_Opnd => New_Occurrence_Of (Tmp_For_Disc, Loc), 995 Right_Opnd => 996 Make_Selected_Component (Loc, 997 Prefix => New_Copy_Tree (Out_Formal), 998 Selector_Name => New_Occurrence_Of (Disc, Loc))), 999 Reason => CE_Discriminant_Check_Failed)); 1000 Next_Discriminant (Disc); 1001 end loop; 1002 1003 -- Generate reads for the components of the record (including those 1004 -- that depend on discriminants). 1005 1006 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); 1007 1008 -- Save original statement sequence for component assignments, and 1009 -- replace it with Stms. 1010 1011 Constrained_Stms := Statements (Handled_Statement_Sequence (Decl)); 1012 Set_Handled_Statement_Sequence (Decl, 1013 Make_Handled_Sequence_Of_Statements (Loc, 1014 Statements => Stms)); 1015 1016 -- If Typ has controlled components (i.e. if it is classwide or 1017 -- Has_Controlled), or components constrained using the discriminants 1018 -- of Typ, then we need to ensure that all component assignments are 1019 -- performed on an object that has been appropriately constrained 1020 -- prior to being initialized. To this effect, we wrap the component 1021 -- assignments in a block where V is a constrained temporary. 1022 1023 Append_To (Dcls, 1024 Make_Object_Declaration (Loc, 1025 Defining_Identifier => Tmp, 1026 Object_Definition => 1027 Make_Subtype_Indication (Loc, 1028 Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc), 1029 Constraint => 1030 Make_Index_Or_Discriminant_Constraint (Loc, 1031 Constraints => Cstr)))); 1032 1033 -- AI05-023-1: Insert discriminant check prior to initialization of the 1034 -- constrained temporary. 1035 1036 Append_To (Stms, 1037 Make_Implicit_If_Statement (Pnam, 1038 Condition => 1039 Make_Attribute_Reference (Loc, 1040 Prefix => New_Copy_Tree (Out_Formal), 1041 Attribute_Name => Name_Constrained), 1042 Then_Statements => Discriminant_Checks)); 1043 1044 -- Now insert back original component assignments, wrapped in a block 1045 -- in which V is the constrained temporary. 1046 1047 Append_To (Stms, 1048 Make_Block_Statement (Loc, 1049 Declarations => Dcls, 1050 Handled_Statement_Sequence => Parent (Constrained_Stms))); 1051 1052 Append_To (Constrained_Stms, 1053 Make_Assignment_Statement (Loc, 1054 Name => Out_Formal, 1055 Expression => Make_Identifier (Loc, Name_V))); 1056 1057 Set_Declarations (Decl, Tmps_For_Discs); 1058 end Build_Mutable_Record_Read_Procedure; 1059 1060 ------------------------------------------ 1061 -- Build_Mutable_Record_Write_Procedure -- 1062 ------------------------------------------ 1063 1064 procedure Build_Mutable_Record_Write_Procedure 1065 (Loc : Source_Ptr; 1066 Typ : Entity_Id; 1067 Decl : out Node_Id; 1068 Pnam : out Entity_Id) 1069 is 1070 Stms : List_Id; 1071 Disc : Entity_Id; 1072 D_Ref : Node_Id; 1073 1074 begin 1075 Stms := New_List; 1076 Disc := First_Discriminant (Typ); 1077 1078 -- Generate Writes for the discriminants of the type 1079 -- If the type is an unchecked union, use the default values of 1080 -- the discriminants, because they are not stored. 1081 1082 while Present (Disc) loop 1083 if Is_Unchecked_Union (Typ) then 1084 D_Ref := 1085 New_Copy_Tree (Discriminant_Default_Value (Disc)); 1086 else 1087 D_Ref := 1088 Make_Selected_Component (Loc, 1089 Prefix => Make_Identifier (Loc, Name_V), 1090 Selector_Name => New_Occurrence_Of (Disc, Loc)); 1091 end if; 1092 1093 Append_To (Stms, 1094 Make_Attribute_Reference (Loc, 1095 Prefix => New_Occurrence_Of (Etype (Disc), Loc), 1096 Attribute_Name => Name_Write, 1097 Expressions => New_List ( 1098 Make_Identifier (Loc, Name_S), 1099 D_Ref))); 1100 1101 Next_Discriminant (Disc); 1102 end loop; 1103 1104 -- A mutable type cannot be a tagged type, so we generate a new name 1105 -- for the stream procedure. 1106 1107 Pnam := 1108 Make_Defining_Identifier (Loc, 1109 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write)); 1110 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); 1111 1112 -- Write the discriminants before the rest of the components, so 1113 -- that discriminant values are properly set of variants, etc. 1114 1115 if Is_Non_Empty_List ( 1116 Statements (Handled_Statement_Sequence (Decl))) 1117 then 1118 Insert_List_Before 1119 (First (Statements (Handled_Statement_Sequence (Decl))), Stms); 1120 else 1121 Set_Statements (Handled_Statement_Sequence (Decl), Stms); 1122 end if; 1123 end Build_Mutable_Record_Write_Procedure; 1124 1125 ----------------------------------------------- 1126 -- Build_Record_Or_Elementary_Input_Function -- 1127 ----------------------------------------------- 1128 1129 -- The function we build looks like 1130 1131 -- function InputN (S : access RST) return Typ is 1132 -- C1 : constant Disc_Type_1; 1133 -- Discr_Type_1'Read (S, C1); 1134 -- C2 : constant Disc_Type_2; 1135 -- Discr_Type_2'Read (S, C2); 1136 -- ... 1137 -- Cn : constant Disc_Type_n; 1138 -- Discr_Type_n'Read (S, Cn); 1139 -- V : Typ (C1, C2, .. Cn) 1140 1141 -- begin 1142 -- Typ'Read (S, V); 1143 -- return V; 1144 -- end InputN 1145 1146 -- The discriminants are of course only present in the case of a record 1147 -- with discriminants. In the case of a record with no discriminants, or 1148 -- an elementary type, then no Cn constants are defined. 1149 1150 procedure Build_Record_Or_Elementary_Input_Function 1151 (Loc : Source_Ptr; 1152 Typ : Entity_Id; 1153 Decl : out Node_Id; 1154 Fnam : out Entity_Id) 1155 is 1156 B_Typ : constant Entity_Id := Underlying_Type (Base_Type (Typ)); 1157 Cn : Name_Id; 1158 Constr : List_Id; 1159 Decls : List_Id; 1160 Discr : Entity_Id; 1161 Discr_Elmt : Elmt_Id := No_Elmt; 1162 J : Pos; 1163 Obj_Decl : Node_Id; 1164 Odef : Node_Id; 1165 Stms : List_Id; 1166 1167 begin 1168 Decls := New_List; 1169 Constr := New_List; 1170 1171 J := 1; 1172 1173 -- In the presence of multiple instantiations (as in uses of the Booch 1174 -- components) the base type may be private, and the underlying type 1175 -- already constrained, in which case there's no discriminant constraint 1176 -- to construct. 1177 1178 if Has_Discriminants (Typ) 1179 and then No (Discriminant_Default_Value (First_Discriminant (Typ))) 1180 and then not Is_Constrained (Underlying_Type (B_Typ)) 1181 then 1182 Discr := First_Discriminant (B_Typ); 1183 1184 -- If the prefix subtype is constrained, then retrieve the first 1185 -- element of its constraint. 1186 1187 if Is_Constrained (Typ) then 1188 Discr_Elmt := First_Elmt (Discriminant_Constraint (Typ)); 1189 end if; 1190 1191 while Present (Discr) loop 1192 Cn := New_External_Name ('C', J); 1193 1194 Decl := 1195 Make_Object_Declaration (Loc, 1196 Defining_Identifier => Make_Defining_Identifier (Loc, Cn), 1197 Object_Definition => 1198 New_Occurrence_Of (Etype (Discr), Loc)); 1199 1200 -- If this is an access discriminant, do not perform default 1201 -- initialization. The discriminant is about to get its value 1202 -- from Read, and if the type is null excluding we do not want 1203 -- spurious warnings on an initial null value. 1204 1205 if Is_Access_Type (Etype (Discr)) then 1206 Set_No_Initialization (Decl); 1207 end if; 1208 1209 Append_To (Decls, Decl); 1210 Append_To (Decls, 1211 Make_Attribute_Reference (Loc, 1212 Prefix => New_Occurrence_Of (Etype (Discr), Loc), 1213 Attribute_Name => Name_Read, 1214 Expressions => New_List ( 1215 Make_Identifier (Loc, Name_S), 1216 Make_Identifier (Loc, Cn)))); 1217 1218 Append_To (Constr, Make_Identifier (Loc, Cn)); 1219 1220 -- If the prefix subtype imposes a discriminant constraint, then 1221 -- check that each discriminant value equals the value read. 1222 1223 if Present (Discr_Elmt) then 1224 Append_To (Decls, 1225 Make_Raise_Constraint_Error (Loc, 1226 Condition => Make_Op_Ne (Loc, 1227 Left_Opnd => 1228 New_Occurrence_Of 1229 (Defining_Identifier (Decl), Loc), 1230 Right_Opnd => 1231 New_Copy_Tree (Node (Discr_Elmt))), 1232 Reason => CE_Discriminant_Check_Failed)); 1233 1234 Next_Elmt (Discr_Elmt); 1235 end if; 1236 1237 Next_Discriminant (Discr); 1238 J := J + 1; 1239 end loop; 1240 1241 Odef := 1242 Make_Subtype_Indication (Loc, 1243 Subtype_Mark => New_Occurrence_Of (B_Typ, Loc), 1244 Constraint => 1245 Make_Index_Or_Discriminant_Constraint (Loc, 1246 Constraints => Constr)); 1247 1248 -- If no discriminants, then just use the type with no constraint 1249 1250 else 1251 Odef := New_Occurrence_Of (B_Typ, Loc); 1252 end if; 1253 1254 -- Create an extended return statement encapsulating the result object 1255 -- and 'Read call, which is needed in general for proper handling of 1256 -- build-in-place results (such as when the result type is inherently 1257 -- limited). 1258 1259 Obj_Decl := 1260 Make_Object_Declaration (Loc, 1261 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 1262 Object_Definition => Odef); 1263 1264 -- If the type is an access type, do not perform default initialization. 1265 -- The object is about to get its value from Read, and if the type is 1266 -- null excluding we do not want spurious warnings on an initial null. 1267 1268 if Is_Access_Type (B_Typ) then 1269 Set_No_Initialization (Obj_Decl); 1270 end if; 1271 1272 Stms := New_List ( 1273 Make_Extended_Return_Statement (Loc, 1274 Return_Object_Declarations => New_List (Obj_Decl), 1275 Handled_Statement_Sequence => 1276 Make_Handled_Sequence_Of_Statements (Loc, 1277 Statements => New_List ( 1278 Make_Attribute_Reference (Loc, 1279 Prefix => New_Occurrence_Of (B_Typ, Loc), 1280 Attribute_Name => Name_Read, 1281 Expressions => New_List ( 1282 Make_Identifier (Loc, Name_S), 1283 Make_Identifier (Loc, Name_V))))))); 1284 1285 Fnam := Make_Stream_Subprogram_Name (Loc, B_Typ, TSS_Stream_Input); 1286 1287 Build_Stream_Function (Loc, B_Typ, Decl, Fnam, Decls, Stms); 1288 end Build_Record_Or_Elementary_Input_Function; 1289 1290 ------------------------------------------------- 1291 -- Build_Record_Or_Elementary_Output_Procedure -- 1292 ------------------------------------------------- 1293 1294 procedure Build_Record_Or_Elementary_Output_Procedure 1295 (Loc : Source_Ptr; 1296 Typ : Entity_Id; 1297 Decl : out Node_Id; 1298 Pnam : out Entity_Id) 1299 is 1300 Stms : List_Id; 1301 Disc : Entity_Id; 1302 Disc_Ref : Node_Id; 1303 1304 begin 1305 Stms := New_List; 1306 1307 -- Note that of course there will be no discriminants for the elementary 1308 -- type case, so Has_Discriminants will be False. Note that the language 1309 -- rules do not allow writing the discriminants in the defaulted case, 1310 -- because those are written by 'Write. 1311 1312 if Has_Discriminants (Typ) 1313 and then No (Discriminant_Default_Value (First_Discriminant (Typ))) 1314 then 1315 Disc := First_Discriminant (Typ); 1316 while Present (Disc) loop 1317 1318 -- If the type is an unchecked union, it must have default 1319 -- discriminants (this is checked earlier), and those defaults 1320 -- are written out to the stream. 1321 1322 if Is_Unchecked_Union (Typ) then 1323 Disc_Ref := New_Copy_Tree (Discriminant_Default_Value (Disc)); 1324 1325 else 1326 Disc_Ref := 1327 Make_Selected_Component (Loc, 1328 Prefix => Make_Identifier (Loc, Name_V), 1329 Selector_Name => New_Occurrence_Of (Disc, Loc)); 1330 end if; 1331 1332 Append_To (Stms, 1333 Make_Attribute_Reference (Loc, 1334 Prefix => 1335 New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc), 1336 Attribute_Name => Name_Write, 1337 Expressions => New_List ( 1338 Make_Identifier (Loc, Name_S), 1339 Disc_Ref))); 1340 1341 Next_Discriminant (Disc); 1342 end loop; 1343 end if; 1344 1345 Append_To (Stms, 1346 Make_Attribute_Reference (Loc, 1347 Prefix => New_Occurrence_Of (Typ, Loc), 1348 Attribute_Name => Name_Write, 1349 Expressions => New_List ( 1350 Make_Identifier (Loc, Name_S), 1351 Make_Identifier (Loc, Name_V)))); 1352 1353 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output); 1354 1355 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => False); 1356 end Build_Record_Or_Elementary_Output_Procedure; 1357 1358 --------------------------------- 1359 -- Build_Record_Read_Procedure -- 1360 --------------------------------- 1361 1362 procedure Build_Record_Read_Procedure 1363 (Loc : Source_Ptr; 1364 Typ : Entity_Id; 1365 Decl : out Node_Id; 1366 Pnam : out Entity_Id) 1367 is 1368 begin 1369 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read); 1370 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); 1371 end Build_Record_Read_Procedure; 1372 1373 --------------------------------------- 1374 -- Build_Record_Read_Write_Procedure -- 1375 --------------------------------------- 1376 1377 -- The form of the record read/write procedure is as shown by the 1378 -- following example for a case with one discriminant case variant: 1379 1380 -- procedure pnam (S : access RST, V : [out] Typ) is 1381 -- begin 1382 -- Component_Type'Read/Write (S, V.component); 1383 -- Component_Type'Read/Write (S, V.component); 1384 -- ... 1385 -- Component_Type'Read/Write (S, V.component); 1386 -- 1387 -- case V.discriminant is 1388 -- when choices => 1389 -- Component_Type'Read/Write (S, V.component); 1390 -- Component_Type'Read/Write (S, V.component); 1391 -- ... 1392 -- Component_Type'Read/Write (S, V.component); 1393 -- 1394 -- when choices => 1395 -- Component_Type'Read/Write (S, V.component); 1396 -- Component_Type'Read/Write (S, V.component); 1397 -- ... 1398 -- Component_Type'Read/Write (S, V.component); 1399 -- ... 1400 -- end case; 1401 -- end pnam; 1402 1403 -- The out keyword for V is supplied in the Read case 1404 1405 procedure Build_Record_Read_Write_Procedure 1406 (Loc : Source_Ptr; 1407 Typ : Entity_Id; 1408 Decl : out Node_Id; 1409 Pnam : Entity_Id; 1410 Nam : Name_Id) 1411 is 1412 Rdef : Node_Id; 1413 Stms : List_Id; 1414 Typt : Entity_Id; 1415 1416 In_Limited_Extension : Boolean := False; 1417 -- Set to True while processing the record extension definition 1418 -- for an extension of a limited type (for which an ancestor type 1419 -- has an explicit Nam attribute definition). 1420 1421 function Make_Component_List_Attributes (CL : Node_Id) return List_Id; 1422 -- Returns a sequence of attributes to process the components that 1423 -- are referenced in the given component list. 1424 1425 function Make_Field_Attribute (C : Entity_Id) return Node_Id; 1426 -- Given C, the entity for a discriminant or component, build 1427 -- an attribute for the corresponding field values. 1428 1429 function Make_Field_Attributes (Clist : List_Id) return List_Id; 1430 -- Given Clist, a component items list, construct series of attributes 1431 -- for fieldwise processing of the corresponding components. 1432 1433 ------------------------------------ 1434 -- Make_Component_List_Attributes -- 1435 ------------------------------------ 1436 1437 function Make_Component_List_Attributes (CL : Node_Id) return List_Id is 1438 CI : constant List_Id := Component_Items (CL); 1439 VP : constant Node_Id := Variant_Part (CL); 1440 1441 Result : List_Id; 1442 Alts : List_Id; 1443 V : Node_Id; 1444 DC : Node_Id; 1445 DCH : List_Id; 1446 D_Ref : Node_Id; 1447 1448 begin 1449 Result := Make_Field_Attributes (CI); 1450 1451 if Present (VP) then 1452 Alts := New_List; 1453 1454 V := First_Non_Pragma (Variants (VP)); 1455 while Present (V) loop 1456 DCH := New_List; 1457 1458 DC := First (Discrete_Choices (V)); 1459 while Present (DC) loop 1460 Append_To (DCH, New_Copy_Tree (DC)); 1461 Next (DC); 1462 end loop; 1463 1464 Append_To (Alts, 1465 Make_Case_Statement_Alternative (Loc, 1466 Discrete_Choices => DCH, 1467 Statements => 1468 Make_Component_List_Attributes (Component_List (V)))); 1469 Next_Non_Pragma (V); 1470 end loop; 1471 1472 -- Note: in the following, we make sure that we use new occurrence 1473 -- of for the selector, since there are cases in which we make a 1474 -- reference to a hidden discriminant that is not visible. 1475 1476 -- If the enclosing record is an unchecked_union, we use the 1477 -- default expressions for the discriminant (it must exist) 1478 -- because we cannot generate a reference to it, given that 1479 -- it is not stored. 1480 1481 if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then 1482 D_Ref := 1483 New_Copy_Tree 1484 (Discriminant_Default_Value (Entity (Name (VP)))); 1485 else 1486 D_Ref := 1487 Make_Selected_Component (Loc, 1488 Prefix => Make_Identifier (Loc, Name_V), 1489 Selector_Name => 1490 New_Occurrence_Of (Entity (Name (VP)), Loc)); 1491 end if; 1492 1493 Append_To (Result, 1494 Make_Case_Statement (Loc, 1495 Expression => D_Ref, 1496 Alternatives => Alts)); 1497 end if; 1498 1499 return Result; 1500 end Make_Component_List_Attributes; 1501 1502 -------------------------- 1503 -- Make_Field_Attribute -- 1504 -------------------------- 1505 1506 function Make_Field_Attribute (C : Entity_Id) return Node_Id is 1507 Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C)); 1508 1509 TSS_Names : constant array (Name_Input .. Name_Write) of 1510 TSS_Name_Type := 1511 (Name_Read => TSS_Stream_Read, 1512 Name_Write => TSS_Stream_Write, 1513 Name_Input => TSS_Stream_Input, 1514 Name_Output => TSS_Stream_Output, 1515 others => TSS_Null); 1516 pragma Assert (TSS_Names (Nam) /= TSS_Null); 1517 1518 begin 1519 if In_Limited_Extension 1520 and then Is_Limited_Type (Field_Typ) 1521 and then No (Find_Inherited_TSS (Field_Typ, TSS_Names (Nam))) 1522 then 1523 -- The declaration is illegal per 13.13.2(9/1), and this is 1524 -- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the caller 1525 -- happy by returning a null statement. 1526 1527 return Make_Null_Statement (Loc); 1528 end if; 1529 1530 return 1531 Make_Attribute_Reference (Loc, 1532 Prefix => New_Occurrence_Of (Field_Typ, Loc), 1533 Attribute_Name => Nam, 1534 Expressions => New_List ( 1535 Make_Identifier (Loc, Name_S), 1536 Make_Selected_Component (Loc, 1537 Prefix => Make_Identifier (Loc, Name_V), 1538 Selector_Name => New_Occurrence_Of (C, Loc)))); 1539 end Make_Field_Attribute; 1540 1541 --------------------------- 1542 -- Make_Field_Attributes -- 1543 --------------------------- 1544 1545 function Make_Field_Attributes (Clist : List_Id) return List_Id is 1546 Item : Node_Id; 1547 Result : List_Id; 1548 1549 begin 1550 Result := New_List; 1551 1552 if Present (Clist) then 1553 Item := First (Clist); 1554 1555 -- Loop through components, skipping all internal components, 1556 -- which are not part of the value (e.g. _Tag), except that we 1557 -- don't skip the _Parent, since we do want to process that 1558 -- recursively. If _Parent is an interface type, being abstract 1559 -- with no components there is no need to handle it. 1560 1561 while Present (Item) loop 1562 if Nkind (Item) = N_Component_Declaration 1563 and then 1564 ((Chars (Defining_Identifier (Item)) = Name_uParent 1565 and then not Is_Interface 1566 (Etype (Defining_Identifier (Item)))) 1567 or else 1568 not Is_Internal_Name (Chars (Defining_Identifier (Item)))) 1569 then 1570 Append_To 1571 (Result, 1572 Make_Field_Attribute (Defining_Identifier (Item))); 1573 end if; 1574 1575 Next (Item); 1576 end loop; 1577 end if; 1578 1579 return Result; 1580 end Make_Field_Attributes; 1581 1582 -- Start of processing for Build_Record_Read_Write_Procedure 1583 1584 begin 1585 -- For the protected type case, use corresponding record 1586 1587 if Is_Protected_Type (Typ) then 1588 Typt := Corresponding_Record_Type (Typ); 1589 else 1590 Typt := Typ; 1591 end if; 1592 1593 -- Note that we do nothing with the discriminants, since Read and 1594 -- Write do not read or write the discriminant values. All handling 1595 -- of discriminants occurs in the Input and Output subprograms. 1596 1597 Rdef := Type_Definition 1598 (Declaration_Node (Base_Type (Underlying_Type (Typt)))); 1599 Stms := Empty_List; 1600 1601 -- In record extension case, the fields we want, including the _Parent 1602 -- field representing the parent type, are to be found in the extension. 1603 -- Note that we will naturally process the _Parent field using the type 1604 -- of the parent, and hence its stream attributes, which is appropriate. 1605 1606 if Nkind (Rdef) = N_Derived_Type_Definition then 1607 Rdef := Record_Extension_Part (Rdef); 1608 1609 if Is_Limited_Type (Typt) then 1610 In_Limited_Extension := True; 1611 end if; 1612 end if; 1613 1614 if Present (Component_List (Rdef)) then 1615 Append_List_To (Stms, 1616 Make_Component_List_Attributes (Component_List (Rdef))); 1617 end if; 1618 1619 Build_Stream_Procedure 1620 (Loc, Typ, Decl, Pnam, Stms, Outp => Nam = Name_Read); 1621 end Build_Record_Read_Write_Procedure; 1622 1623 ---------------------------------- 1624 -- Build_Record_Write_Procedure -- 1625 ---------------------------------- 1626 1627 procedure Build_Record_Write_Procedure 1628 (Loc : Source_Ptr; 1629 Typ : Entity_Id; 1630 Decl : out Node_Id; 1631 Pnam : out Entity_Id) 1632 is 1633 begin 1634 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write); 1635 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); 1636 end Build_Record_Write_Procedure; 1637 1638 ------------------------------- 1639 -- Build_Stream_Attr_Profile -- 1640 ------------------------------- 1641 1642 function Build_Stream_Attr_Profile 1643 (Loc : Source_Ptr; 1644 Typ : Entity_Id; 1645 Nam : TSS_Name_Type) return List_Id 1646 is 1647 Profile : List_Id; 1648 1649 begin 1650 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has 1651 -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005. 1652 1653 Profile := New_List ( 1654 Make_Parameter_Specification (Loc, 1655 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), 1656 Parameter_Type => 1657 Make_Access_Definition (Loc, 1658 Null_Exclusion_Present => True, 1659 Subtype_Mark => New_Occurrence_Of ( 1660 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))); 1661 1662 if Nam /= TSS_Stream_Input then 1663 Append_To (Profile, 1664 Make_Parameter_Specification (Loc, 1665 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 1666 Out_Present => (Nam = TSS_Stream_Read), 1667 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 1668 end if; 1669 1670 return Profile; 1671 end Build_Stream_Attr_Profile; 1672 1673 --------------------------- 1674 -- Build_Stream_Function -- 1675 --------------------------- 1676 1677 procedure Build_Stream_Function 1678 (Loc : Source_Ptr; 1679 Typ : Entity_Id; 1680 Decl : out Node_Id; 1681 Fnam : Entity_Id; 1682 Decls : List_Id; 1683 Stms : List_Id) 1684 is 1685 Spec : Node_Id; 1686 1687 begin 1688 -- Construct function specification 1689 1690 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has 1691 -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005. 1692 1693 Spec := 1694 Make_Function_Specification (Loc, 1695 Defining_Unit_Name => Fnam, 1696 1697 Parameter_Specifications => New_List ( 1698 Make_Parameter_Specification (Loc, 1699 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), 1700 Parameter_Type => 1701 Make_Access_Definition (Loc, 1702 Null_Exclusion_Present => True, 1703 Subtype_Mark => 1704 New_Occurrence_Of 1705 (Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))), 1706 1707 Result_Definition => New_Occurrence_Of (Typ, Loc)); 1708 1709 Decl := 1710 Make_Subprogram_Body (Loc, 1711 Specification => Spec, 1712 Declarations => Decls, 1713 Handled_Statement_Sequence => 1714 Make_Handled_Sequence_Of_Statements (Loc, 1715 Statements => Stms)); 1716 end Build_Stream_Function; 1717 1718 ---------------------------- 1719 -- Build_Stream_Procedure -- 1720 ---------------------------- 1721 1722 procedure Build_Stream_Procedure 1723 (Loc : Source_Ptr; 1724 Typ : Entity_Id; 1725 Decl : out Node_Id; 1726 Pnam : Entity_Id; 1727 Stms : List_Id; 1728 Outp : Boolean) 1729 is 1730 Spec : Node_Id; 1731 1732 begin 1733 -- Construct procedure specification 1734 1735 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has 1736 -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005. 1737 1738 Spec := 1739 Make_Procedure_Specification (Loc, 1740 Defining_Unit_Name => Pnam, 1741 1742 Parameter_Specifications => New_List ( 1743 Make_Parameter_Specification (Loc, 1744 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), 1745 Parameter_Type => 1746 Make_Access_Definition (Loc, 1747 Null_Exclusion_Present => True, 1748 Subtype_Mark => 1749 New_Occurrence_Of 1750 (Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))), 1751 1752 Make_Parameter_Specification (Loc, 1753 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 1754 Out_Present => Outp, 1755 Parameter_Type => New_Occurrence_Of (Typ, Loc)))); 1756 1757 Decl := 1758 Make_Subprogram_Body (Loc, 1759 Specification => Spec, 1760 Declarations => Empty_List, 1761 Handled_Statement_Sequence => 1762 Make_Handled_Sequence_Of_Statements (Loc, 1763 Statements => Stms)); 1764 end Build_Stream_Procedure; 1765 1766 ----------------------------- 1767 -- Has_Stream_Standard_Rep -- 1768 ----------------------------- 1769 1770 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is 1771 Siz : Uint; 1772 1773 begin 1774 if Has_Non_Standard_Rep (U_Type) then 1775 return False; 1776 end if; 1777 1778 if Has_Stream_Size_Clause (U_Type) then 1779 Siz := Static_Integer (Expression (Stream_Size_Clause (U_Type))); 1780 else 1781 Siz := Esize (First_Subtype (U_Type)); 1782 end if; 1783 1784 return Siz = Esize (Root_Type (U_Type)); 1785 end Has_Stream_Standard_Rep; 1786 1787 --------------------------------- 1788 -- Make_Stream_Subprogram_Name -- 1789 --------------------------------- 1790 1791 function Make_Stream_Subprogram_Name 1792 (Loc : Source_Ptr; 1793 Typ : Entity_Id; 1794 Nam : TSS_Name_Type) return Entity_Id 1795 is 1796 Sname : Name_Id; 1797 1798 begin 1799 -- For tagged types, we are dealing with a TSS associated with the 1800 -- declaration, so we use the standard primitive function name. For 1801 -- other types, generate a local TSS name since we are generating 1802 -- the subprogram at the point of use. 1803 1804 if Is_Tagged_Type (Typ) then 1805 Sname := Make_TSS_Name (Typ, Nam); 1806 else 1807 Sname := Make_TSS_Name_Local (Typ, Nam); 1808 end if; 1809 1810 return Make_Defining_Identifier (Loc, Sname); 1811 end Make_Stream_Subprogram_Name; 1812 1813 ---------------------- 1814 -- Stream_Base_Type -- 1815 ---------------------- 1816 1817 function Stream_Base_Type (E : Entity_Id) return Entity_Id is 1818 begin 1819 if Is_Array_Type (E) 1820 and then Is_First_Subtype (E) 1821 then 1822 return E; 1823 else 1824 return Base_Type (E); 1825 end if; 1826 end Stream_Base_Type; 1827 1828end Exp_Strm; 1829