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-2019, 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, 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), 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 <= Standard_Integer_Size then 573 Lib_RE := RE_I_I; 574 575 elsif P_Size <= Standard_Long_Integer_Size then 576 Lib_RE := RE_I_LI; 577 578 else 579 Lib_RE := RE_I_LLI; 580 end if; 581 582 -- Unsigned integer types, also includes unsigned fixed-point types 583 -- and enumeration types with an unsigned representation (note that 584 -- we know they are unsigned because we already tested for signed). 585 586 -- Also includes signed integer types that are unsigned in the sense 587 -- that they do not include negative numbers. See above for details. 588 589 elsif Is_Modular_Integer_Type (U_Type) 590 or else Is_Fixed_Point_Type (U_Type) 591 or else Is_Enumeration_Type (U_Type) 592 or else Is_Signed_Integer_Type (U_Type) 593 then 594 if P_Size <= Standard_Short_Short_Integer_Size then 595 Lib_RE := RE_I_SSU; 596 597 elsif P_Size <= Standard_Short_Integer_Size then 598 Lib_RE := RE_I_SU; 599 600 elsif P_Size <= Standard_Integer_Size then 601 Lib_RE := RE_I_U; 602 603 elsif P_Size <= Standard_Long_Integer_Size then 604 Lib_RE := RE_I_LU; 605 606 else 607 Lib_RE := RE_I_LLU; 608 end if; 609 610 else pragma Assert (Is_Access_Type (U_Type)); 611 if P_Size > System_Address_Size then 612 Lib_RE := RE_I_AD; 613 else 614 Lib_RE := RE_I_AS; 615 end if; 616 end if; 617 618 -- Call the function, and do an unchecked conversion of the result 619 -- to the actual type of the prefix. If the target is a discriminant, 620 -- and we are in the body of the default implementation of a 'Read 621 -- attribute, set target type to force a constraint check (13.13.2(35)). 622 -- If the type of the discriminant is currently private, add another 623 -- unchecked conversion from the full view. 624 625 if Nkind (Targ) = N_Identifier 626 and then Is_Internal_Name (Chars (Targ)) 627 and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read) 628 then 629 Res := 630 Unchecked_Convert_To (Base_Type (U_Type), 631 Make_Function_Call (Loc, 632 Name => New_Occurrence_Of (RTE (Lib_RE), Loc), 633 Parameter_Associations => New_List ( 634 Relocate_Node (Strm)))); 635 636 Set_Do_Range_Check (Res); 637 638 if Base_Type (P_Type) /= Base_Type (U_Type) then 639 Res := Unchecked_Convert_To (Base_Type (P_Type), Res); 640 end if; 641 642 return Res; 643 644 else 645 Res := 646 Make_Function_Call (Loc, 647 Name => New_Occurrence_Of (RTE (Lib_RE), Loc), 648 Parameter_Associations => New_List ( 649 Relocate_Node (Strm))); 650 651 -- Now convert to the base type if we do not have a biased type. Note 652 -- that we did not do this in some older versions, and the result was 653 -- losing a required range check in the case where 'Input is being 654 -- called from 'Read. 655 656 if not Has_Biased_Representation (P_Type) then 657 return Unchecked_Convert_To (Base_Type (P_Type), Res); 658 659 -- For the biased case, the conversion to the base type loses the 660 -- biasing, so just convert to Ptype. This is not quite right, and 661 -- for example may lose a corner case CE test, but it is such a 662 -- rare case that for now we ignore it ??? 663 664 else 665 return Unchecked_Convert_To (P_Type, Res); 666 end if; 667 end if; 668 end Build_Elementary_Input_Call; 669 670 --------------------------------- 671 -- Build_Elementary_Write_Call -- 672 --------------------------------- 673 674 function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is 675 Loc : constant Source_Ptr := Sloc (N); 676 P_Type : constant Entity_Id := Entity (Prefix (N)); 677 U_Type : constant Entity_Id := Underlying_Type (P_Type); 678 Rt_Type : constant Entity_Id := Root_Type (U_Type); 679 FST : constant Entity_Id := First_Subtype (U_Type); 680 Strm : constant Node_Id := First (Expressions (N)); 681 Item : constant Node_Id := Next (Strm); 682 P_Size : Uint; 683 Lib_RE : RE_Id; 684 Libent : Entity_Id; 685 686 begin 687 -- Compute the size of the stream element. This is either the size of 688 -- the first subtype or if given the size of the Stream_Size attribute. 689 690 if Has_Stream_Size_Clause (FST) then 691 P_Size := Static_Integer (Expression (Stream_Size_Clause (FST))); 692 else 693 P_Size := Esize (FST); 694 end if; 695 696 -- Find the routine to be called 697 698 -- Check for First Boolean and Character. These are enumeration types, 699 -- but we treat them specially, since they may require special handling 700 -- in the transfer protocol. However, this special handling only applies 701 -- if they have standard representation, otherwise they are treated like 702 -- any other enumeration type. 703 704 if Rt_Type = Standard_Boolean 705 and then Has_Stream_Standard_Rep (U_Type) 706 then 707 Lib_RE := RE_W_B; 708 709 elsif Rt_Type = Standard_Character 710 and then Has_Stream_Standard_Rep (U_Type) 711 then 712 Lib_RE := RE_W_C; 713 714 elsif Rt_Type = Standard_Wide_Character 715 and then Has_Stream_Standard_Rep (U_Type) 716 then 717 Lib_RE := RE_W_WC; 718 719 elsif Rt_Type = Standard_Wide_Wide_Character 720 and then Has_Stream_Standard_Rep (U_Type) 721 then 722 Lib_RE := RE_W_WWC; 723 724 -- Floating point types 725 726 elsif Is_Floating_Point_Type (U_Type) then 727 728 -- Question: should we use P_Size or Rt_Type to distinguish between 729 -- possible floating point types? If a non-standard size or a stream 730 -- size is specified, then we should certainly use the size. But if 731 -- we have two types the same (notably Short_Float_Size = Float_Size 732 -- which is close to universally true, and Long_Long_Float_Size = 733 -- Long_Float_Size, true on most targets except the x86), then we 734 -- would really rather use the root type, so that if people want to 735 -- fiddle with System.Stream_Attributes to get inter-target portable 736 -- streams, they get the size they expect. Consider in particular the 737 -- case of a stream written on an x86, with 96-bit Long_Long_Float 738 -- being read into a non-x86 target with 64 bit Long_Long_Float. A 739 -- special version of System.Stream_Attributes can deal with this 740 -- provided the proper type is always used. 741 742 -- To deal with these two requirements we add the special checks 743 -- on equal sizes and use the root type to distinguish. 744 745 if P_Size <= Standard_Short_Float_Size 746 and then (Standard_Short_Float_Size /= Standard_Float_Size 747 or else Rt_Type = Standard_Short_Float) 748 then 749 Lib_RE := RE_W_SF; 750 751 elsif P_Size <= Standard_Float_Size then 752 Lib_RE := RE_W_F; 753 754 elsif P_Size <= Standard_Long_Float_Size 755 and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size 756 or else Rt_Type = Standard_Long_Float) 757 then 758 Lib_RE := RE_W_LF; 759 760 else 761 Lib_RE := RE_W_LLF; 762 end if; 763 764 -- Signed integer types. Also includes signed fixed-point types and 765 -- signed enumeration types share this circuitry. 766 767 -- Note on signed integer types. We do not consider types as signed for 768 -- this purpose if they have no negative numbers, or if they have biased 769 -- representation. The reason is that the value in either case basically 770 -- represents an unsigned value. 771 772 -- For example, consider: 773 774 -- type W is range 0 .. 2**32 - 1; 775 -- for W'Size use 32; 776 777 -- This is a signed type, but the representation is unsigned, and may 778 -- be outside the range of a 32-bit signed integer, so this must be 779 -- treated as 32-bit unsigned. 780 781 -- Similarly, the representation is also unsigned if we have: 782 783 -- type W is range -1 .. +254; 784 -- for W'Size use 8; 785 786 -- forcing a biased and unsigned representation 787 788 elsif not Is_Unsigned_Type (FST) 789 and then 790 (Is_Fixed_Point_Type (U_Type) 791 or else 792 Is_Enumeration_Type (U_Type) 793 or else 794 (Is_Signed_Integer_Type (U_Type) 795 and then not Has_Biased_Representation (FST))) 796 then 797 if P_Size <= Standard_Short_Short_Integer_Size then 798 Lib_RE := RE_W_SSI; 799 elsif P_Size <= Standard_Short_Integer_Size then 800 Lib_RE := RE_W_SI; 801 elsif P_Size <= Standard_Integer_Size then 802 Lib_RE := RE_W_I; 803 elsif P_Size <= Standard_Long_Integer_Size then 804 Lib_RE := RE_W_LI; 805 else 806 Lib_RE := RE_W_LLI; 807 end if; 808 809 -- Unsigned integer types, also includes unsigned fixed-point types 810 -- and unsigned enumeration types (note we know they are unsigned 811 -- because we already tested for signed above). 812 813 -- Also includes signed integer types that are unsigned in the sense 814 -- that they do not include negative numbers. See above for details. 815 816 elsif Is_Modular_Integer_Type (U_Type) 817 or else Is_Fixed_Point_Type (U_Type) 818 or else Is_Enumeration_Type (U_Type) 819 or else Is_Signed_Integer_Type (U_Type) 820 then 821 if P_Size <= Standard_Short_Short_Integer_Size then 822 Lib_RE := RE_W_SSU; 823 elsif P_Size <= Standard_Short_Integer_Size then 824 Lib_RE := RE_W_SU; 825 elsif P_Size <= Standard_Integer_Size then 826 Lib_RE := RE_W_U; 827 elsif P_Size <= Standard_Long_Integer_Size then 828 Lib_RE := RE_W_LU; 829 else 830 Lib_RE := RE_W_LLU; 831 end if; 832 833 else pragma Assert (Is_Access_Type (U_Type)); 834 835 if P_Size > System_Address_Size then 836 Lib_RE := RE_W_AD; 837 else 838 Lib_RE := RE_W_AS; 839 end if; 840 end if; 841 842 -- Unchecked-convert parameter to the required type (i.e. the type of 843 -- the corresponding parameter, and call the appropriate routine. 844 845 Libent := RTE (Lib_RE); 846 847 return 848 Make_Procedure_Call_Statement (Loc, 849 Name => New_Occurrence_Of (Libent, Loc), 850 Parameter_Associations => New_List ( 851 Relocate_Node (Strm), 852 Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))), 853 Relocate_Node (Item)))); 854 end Build_Elementary_Write_Call; 855 856 ----------------------------------------- 857 -- Build_Mutable_Record_Read_Procedure -- 858 ----------------------------------------- 859 860 procedure Build_Mutable_Record_Read_Procedure 861 (Loc : Source_Ptr; 862 Typ : Entity_Id; 863 Decl : out Node_Id; 864 Pnam : out Entity_Id) 865 is 866 Out_Formal : Node_Id; 867 -- Expression denoting the out formal parameter 868 869 Dcls : constant List_Id := New_List; 870 -- Declarations for the 'Read body 871 872 Stms : constant List_Id := New_List; 873 -- Statements for the 'Read body 874 875 Disc : Entity_Id; 876 -- Entity of the discriminant being processed 877 878 Tmp_For_Disc : Entity_Id; 879 -- Temporary object used to read the value of Disc 880 881 Tmps_For_Discs : constant List_Id := New_List; 882 -- List of object declarations for temporaries holding the read values 883 -- for the discriminants. 884 885 Cstr : constant List_Id := New_List; 886 -- List of constraints to be applied on temporary record 887 888 Discriminant_Checks : constant List_Id := New_List; 889 -- List of discriminant checks to be performed if the actual object 890 -- is constrained. 891 892 Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V); 893 -- Temporary record must hide formal (assignments to components of the 894 -- record are always generated with V as the identifier for the record). 895 896 Constrained_Stms : List_Id := New_List; 897 -- Statements within the block where we have the constrained temporary 898 899 begin 900 -- A mutable type cannot be a tagged type, so we generate a new name 901 -- for the stream procedure. 902 903 Pnam := 904 Make_Defining_Identifier (Loc, 905 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read)); 906 907 if Is_Unchecked_Union (Typ) then 908 909 -- If this is an unchecked union, the stream procedure is erroneous, 910 -- because there are no discriminants to read. 911 912 -- This should generate a warning ??? 913 914 Append_To (Stms, 915 Make_Raise_Program_Error (Loc, 916 Reason => PE_Unchecked_Union_Restriction)); 917 918 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => True); 919 return; 920 end if; 921 922 Disc := First_Discriminant (Typ); 923 924 Out_Formal := 925 Make_Selected_Component (Loc, 926 Prefix => New_Occurrence_Of (Pnam, Loc), 927 Selector_Name => Make_Identifier (Loc, Name_V)); 928 929 -- Generate Reads for the discriminants of the type. The discriminants 930 -- need to be read before the rest of the components, so that variants 931 -- are initialized correctly. The discriminants must be read into temp 932 -- variables so an incomplete Read (interrupted by an exception, for 933 -- example) does not alter the passed object. 934 935 while Present (Disc) loop 936 Tmp_For_Disc := Make_Defining_Identifier (Loc, 937 New_External_Name (Chars (Disc), "D")); 938 939 Append_To (Tmps_For_Discs, 940 Make_Object_Declaration (Loc, 941 Defining_Identifier => Tmp_For_Disc, 942 Object_Definition => New_Occurrence_Of (Etype (Disc), Loc))); 943 Set_No_Initialization (Last (Tmps_For_Discs)); 944 945 Append_To (Stms, 946 Make_Attribute_Reference (Loc, 947 Prefix => New_Occurrence_Of (Etype (Disc), Loc), 948 Attribute_Name => Name_Read, 949 Expressions => New_List ( 950 Make_Identifier (Loc, Name_S), 951 New_Occurrence_Of (Tmp_For_Disc, Loc)))); 952 953 Append_To (Cstr, 954 Make_Discriminant_Association (Loc, 955 Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)), 956 Expression => New_Occurrence_Of (Tmp_For_Disc, Loc))); 957 958 Append_To (Discriminant_Checks, 959 Make_Raise_Constraint_Error (Loc, 960 Condition => 961 Make_Op_Ne (Loc, 962 Left_Opnd => New_Occurrence_Of (Tmp_For_Disc, Loc), 963 Right_Opnd => 964 Make_Selected_Component (Loc, 965 Prefix => New_Copy_Tree (Out_Formal), 966 Selector_Name => New_Occurrence_Of (Disc, Loc))), 967 Reason => CE_Discriminant_Check_Failed)); 968 Next_Discriminant (Disc); 969 end loop; 970 971 -- Generate reads for the components of the record (including those 972 -- that depend on discriminants). 973 974 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); 975 976 -- Save original statement sequence for component assignments, and 977 -- replace it with Stms. 978 979 Constrained_Stms := Statements (Handled_Statement_Sequence (Decl)); 980 Set_Handled_Statement_Sequence (Decl, 981 Make_Handled_Sequence_Of_Statements (Loc, 982 Statements => Stms)); 983 984 -- If Typ has controlled components (i.e. if it is classwide or 985 -- Has_Controlled), or components constrained using the discriminants 986 -- of Typ, then we need to ensure that all component assignments are 987 -- performed on an object that has been appropriately constrained 988 -- prior to being initialized. To this effect, we wrap the component 989 -- assignments in a block where V is a constrained temporary. 990 991 Append_To (Dcls, 992 Make_Object_Declaration (Loc, 993 Defining_Identifier => Tmp, 994 Object_Definition => 995 Make_Subtype_Indication (Loc, 996 Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc), 997 Constraint => 998 Make_Index_Or_Discriminant_Constraint (Loc, 999 Constraints => Cstr)))); 1000 1001 -- AI05-023-1: Insert discriminant check prior to initialization of the 1002 -- constrained temporary. 1003 1004 Append_To (Stms, 1005 Make_Implicit_If_Statement (Pnam, 1006 Condition => 1007 Make_Attribute_Reference (Loc, 1008 Prefix => New_Copy_Tree (Out_Formal), 1009 Attribute_Name => Name_Constrained), 1010 Then_Statements => Discriminant_Checks)); 1011 1012 -- Now insert back original component assignments, wrapped in a block 1013 -- in which V is the constrained temporary. 1014 1015 Append_To (Stms, 1016 Make_Block_Statement (Loc, 1017 Declarations => Dcls, 1018 Handled_Statement_Sequence => Parent (Constrained_Stms))); 1019 1020 Append_To (Constrained_Stms, 1021 Make_Assignment_Statement (Loc, 1022 Name => Out_Formal, 1023 Expression => Make_Identifier (Loc, Name_V))); 1024 1025 Set_Declarations (Decl, Tmps_For_Discs); 1026 end Build_Mutable_Record_Read_Procedure; 1027 1028 ------------------------------------------ 1029 -- Build_Mutable_Record_Write_Procedure -- 1030 ------------------------------------------ 1031 1032 procedure Build_Mutable_Record_Write_Procedure 1033 (Loc : Source_Ptr; 1034 Typ : Entity_Id; 1035 Decl : out Node_Id; 1036 Pnam : out Entity_Id) 1037 is 1038 Stms : List_Id; 1039 Disc : Entity_Id; 1040 D_Ref : Node_Id; 1041 1042 begin 1043 Stms := New_List; 1044 Disc := First_Discriminant (Typ); 1045 1046 -- Generate Writes for the discriminants of the type 1047 -- If the type is an unchecked union, use the default values of 1048 -- the discriminants, because they are not stored. 1049 1050 while Present (Disc) loop 1051 if Is_Unchecked_Union (Typ) then 1052 D_Ref := 1053 New_Copy_Tree (Discriminant_Default_Value (Disc)); 1054 else 1055 D_Ref := 1056 Make_Selected_Component (Loc, 1057 Prefix => Make_Identifier (Loc, Name_V), 1058 Selector_Name => New_Occurrence_Of (Disc, Loc)); 1059 end if; 1060 1061 Append_To (Stms, 1062 Make_Attribute_Reference (Loc, 1063 Prefix => New_Occurrence_Of (Etype (Disc), Loc), 1064 Attribute_Name => Name_Write, 1065 Expressions => New_List ( 1066 Make_Identifier (Loc, Name_S), 1067 D_Ref))); 1068 1069 Next_Discriminant (Disc); 1070 end loop; 1071 1072 -- A mutable type cannot be a tagged type, so we generate a new name 1073 -- for the stream procedure. 1074 1075 Pnam := 1076 Make_Defining_Identifier (Loc, 1077 Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write)); 1078 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); 1079 1080 -- Write the discriminants before the rest of the components, so 1081 -- that discriminant values are properly set of variants, etc. 1082 1083 if Is_Non_Empty_List ( 1084 Statements (Handled_Statement_Sequence (Decl))) 1085 then 1086 Insert_List_Before 1087 (First (Statements (Handled_Statement_Sequence (Decl))), Stms); 1088 else 1089 Set_Statements (Handled_Statement_Sequence (Decl), Stms); 1090 end if; 1091 end Build_Mutable_Record_Write_Procedure; 1092 1093 ----------------------------------------------- 1094 -- Build_Record_Or_Elementary_Input_Function -- 1095 ----------------------------------------------- 1096 1097 -- The function we build looks like 1098 1099 -- function InputN (S : access RST) return Typ is 1100 -- C1 : constant Disc_Type_1; 1101 -- Discr_Type_1'Read (S, C1); 1102 -- C2 : constant Disc_Type_2; 1103 -- Discr_Type_2'Read (S, C2); 1104 -- ... 1105 -- Cn : constant Disc_Type_n; 1106 -- Discr_Type_n'Read (S, Cn); 1107 -- V : Typ (C1, C2, .. Cn) 1108 1109 -- begin 1110 -- Typ'Read (S, V); 1111 -- return V; 1112 -- end InputN 1113 1114 -- The discriminants are of course only present in the case of a record 1115 -- with discriminants. In the case of a record with no discriminants, or 1116 -- an elementary type, then no Cn constants are defined. 1117 1118 procedure Build_Record_Or_Elementary_Input_Function 1119 (Loc : Source_Ptr; 1120 Typ : Entity_Id; 1121 Decl : out Node_Id; 1122 Fnam : out Entity_Id; 1123 Use_Underlying : Boolean := True) 1124 is 1125 B_Typ : Entity_Id := Base_Type (Typ); 1126 Cn : Name_Id; 1127 Constr : List_Id; 1128 Decls : List_Id; 1129 Discr : Entity_Id; 1130 Discr_Elmt : Elmt_Id := No_Elmt; 1131 J : Pos; 1132 Obj_Decl : Node_Id; 1133 Odef : Node_Id; 1134 Stms : List_Id; 1135 1136 begin 1137 if Use_Underlying then 1138 B_Typ := Underlying_Type (B_Typ); 1139 end if; 1140 1141 Decls := New_List; 1142 Constr := New_List; 1143 1144 J := 1; 1145 1146 -- In the presence of multiple instantiations (as in uses of the Booch 1147 -- components) the base type may be private, and the underlying type 1148 -- already constrained, in which case there's no discriminant constraint 1149 -- to construct. 1150 1151 if Has_Discriminants (Typ) 1152 and then No (Discriminant_Default_Value (First_Discriminant (Typ))) 1153 and then not Is_Constrained (Underlying_Type (B_Typ)) 1154 then 1155 Discr := First_Discriminant (B_Typ); 1156 1157 -- If the prefix subtype is constrained, then retrieve the first 1158 -- element of its constraint. 1159 1160 if Is_Constrained (Typ) then 1161 Discr_Elmt := First_Elmt (Discriminant_Constraint (Typ)); 1162 end if; 1163 1164 while Present (Discr) loop 1165 Cn := New_External_Name ('C', J); 1166 1167 Decl := 1168 Make_Object_Declaration (Loc, 1169 Defining_Identifier => Make_Defining_Identifier (Loc, Cn), 1170 Object_Definition => 1171 New_Occurrence_Of (Etype (Discr), Loc)); 1172 1173 -- If this is an access discriminant, do not perform default 1174 -- initialization. The discriminant is about to get its value 1175 -- from Read, and if the type is null excluding we do not want 1176 -- spurious warnings on an initial null value. 1177 1178 if Is_Access_Type (Etype (Discr)) then 1179 Set_No_Initialization (Decl); 1180 end if; 1181 1182 Append_To (Decls, Decl); 1183 Append_To (Decls, 1184 Make_Attribute_Reference (Loc, 1185 Prefix => New_Occurrence_Of (Etype (Discr), Loc), 1186 Attribute_Name => Name_Read, 1187 Expressions => New_List ( 1188 Make_Identifier (Loc, Name_S), 1189 Make_Identifier (Loc, Cn)))); 1190 1191 Append_To (Constr, Make_Identifier (Loc, Cn)); 1192 1193 -- If the prefix subtype imposes a discriminant constraint, then 1194 -- check that each discriminant value equals the value read. 1195 1196 if Present (Discr_Elmt) then 1197 Append_To (Decls, 1198 Make_Raise_Constraint_Error (Loc, 1199 Condition => Make_Op_Ne (Loc, 1200 Left_Opnd => 1201 New_Occurrence_Of 1202 (Defining_Identifier (Decl), Loc), 1203 Right_Opnd => 1204 New_Copy_Tree (Node (Discr_Elmt))), 1205 Reason => CE_Discriminant_Check_Failed)); 1206 1207 Next_Elmt (Discr_Elmt); 1208 end if; 1209 1210 Next_Discriminant (Discr); 1211 J := J + 1; 1212 end loop; 1213 1214 Odef := 1215 Make_Subtype_Indication (Loc, 1216 Subtype_Mark => New_Occurrence_Of (B_Typ, Loc), 1217 Constraint => 1218 Make_Index_Or_Discriminant_Constraint (Loc, 1219 Constraints => Constr)); 1220 1221 -- If no discriminants, then just use the type with no constraint 1222 1223 else 1224 Odef := New_Occurrence_Of (B_Typ, Loc); 1225 end if; 1226 1227 -- Create an extended return statement encapsulating the result object 1228 -- and 'Read call, which is needed in general for proper handling of 1229 -- build-in-place results (such as when the result type is inherently 1230 -- limited). 1231 1232 Obj_Decl := 1233 Make_Object_Declaration (Loc, 1234 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 1235 Object_Definition => Odef); 1236 1237 -- If the type is an access type, do not perform default initialization. 1238 -- The object is about to get its value from Read, and if the type is 1239 -- null excluding we do not want spurious warnings on an initial null. 1240 1241 if Is_Access_Type (B_Typ) then 1242 Set_No_Initialization (Obj_Decl); 1243 end if; 1244 1245 Stms := New_List ( 1246 Make_Extended_Return_Statement (Loc, 1247 Return_Object_Declarations => New_List (Obj_Decl), 1248 Handled_Statement_Sequence => 1249 Make_Handled_Sequence_Of_Statements (Loc, 1250 Statements => New_List ( 1251 Make_Attribute_Reference (Loc, 1252 Prefix => New_Occurrence_Of (B_Typ, Loc), 1253 Attribute_Name => Name_Read, 1254 Expressions => New_List ( 1255 Make_Identifier (Loc, Name_S), 1256 Make_Identifier (Loc, Name_V))))))); 1257 1258 Fnam := Make_Stream_Subprogram_Name (Loc, B_Typ, TSS_Stream_Input); 1259 1260 Build_Stream_Function (Loc, B_Typ, Decl, Fnam, Decls, Stms); 1261 end Build_Record_Or_Elementary_Input_Function; 1262 1263 ------------------------------------------------- 1264 -- Build_Record_Or_Elementary_Output_Procedure -- 1265 ------------------------------------------------- 1266 1267 procedure Build_Record_Or_Elementary_Output_Procedure 1268 (Loc : Source_Ptr; 1269 Typ : Entity_Id; 1270 Decl : out Node_Id; 1271 Pnam : out Entity_Id) 1272 is 1273 Stms : List_Id; 1274 Disc : Entity_Id; 1275 Disc_Ref : Node_Id; 1276 1277 begin 1278 Stms := New_List; 1279 1280 -- Note that of course there will be no discriminants for the elementary 1281 -- type case, so Has_Discriminants will be False. Note that the language 1282 -- rules do not allow writing the discriminants in the defaulted case, 1283 -- because those are written by 'Write. 1284 1285 if Has_Discriminants (Typ) 1286 and then No (Discriminant_Default_Value (First_Discriminant (Typ))) 1287 then 1288 Disc := First_Discriminant (Typ); 1289 while Present (Disc) loop 1290 1291 -- If the type is an unchecked union, it must have default 1292 -- discriminants (this is checked earlier), and those defaults 1293 -- are written out to the stream. 1294 1295 if Is_Unchecked_Union (Typ) then 1296 Disc_Ref := New_Copy_Tree (Discriminant_Default_Value (Disc)); 1297 1298 else 1299 Disc_Ref := 1300 Make_Selected_Component (Loc, 1301 Prefix => Make_Identifier (Loc, Name_V), 1302 Selector_Name => New_Occurrence_Of (Disc, Loc)); 1303 end if; 1304 1305 Append_To (Stms, 1306 Make_Attribute_Reference (Loc, 1307 Prefix => 1308 New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc), 1309 Attribute_Name => Name_Write, 1310 Expressions => New_List ( 1311 Make_Identifier (Loc, Name_S), 1312 Disc_Ref))); 1313 1314 Next_Discriminant (Disc); 1315 end loop; 1316 end if; 1317 1318 Append_To (Stms, 1319 Make_Attribute_Reference (Loc, 1320 Prefix => New_Occurrence_Of (Typ, Loc), 1321 Attribute_Name => Name_Write, 1322 Expressions => New_List ( 1323 Make_Identifier (Loc, Name_S), 1324 Make_Identifier (Loc, Name_V)))); 1325 1326 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output); 1327 1328 Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False); 1329 end Build_Record_Or_Elementary_Output_Procedure; 1330 1331 --------------------------------- 1332 -- Build_Record_Read_Procedure -- 1333 --------------------------------- 1334 1335 procedure Build_Record_Read_Procedure 1336 (Loc : Source_Ptr; 1337 Typ : Entity_Id; 1338 Decl : out Node_Id; 1339 Pnam : out Entity_Id) 1340 is 1341 begin 1342 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read); 1343 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read); 1344 end Build_Record_Read_Procedure; 1345 1346 --------------------------------------- 1347 -- Build_Record_Read_Write_Procedure -- 1348 --------------------------------------- 1349 1350 -- The form of the record read/write procedure is as shown by the 1351 -- following example for a case with one discriminant case variant: 1352 1353 -- procedure pnam (S : access RST, V : [out] Typ) is 1354 -- begin 1355 -- Component_Type'Read/Write (S, V.component); 1356 -- Component_Type'Read/Write (S, V.component); 1357 -- ... 1358 -- Component_Type'Read/Write (S, V.component); 1359 -- 1360 -- case V.discriminant is 1361 -- when choices => 1362 -- Component_Type'Read/Write (S, V.component); 1363 -- Component_Type'Read/Write (S, V.component); 1364 -- ... 1365 -- Component_Type'Read/Write (S, V.component); 1366 -- 1367 -- when choices => 1368 -- Component_Type'Read/Write (S, V.component); 1369 -- Component_Type'Read/Write (S, V.component); 1370 -- ... 1371 -- Component_Type'Read/Write (S, V.component); 1372 -- ... 1373 -- end case; 1374 -- end pnam; 1375 1376 -- The out keyword for V is supplied in the Read case 1377 1378 procedure Build_Record_Read_Write_Procedure 1379 (Loc : Source_Ptr; 1380 Typ : Entity_Id; 1381 Decl : out Node_Id; 1382 Pnam : Entity_Id; 1383 Nam : Name_Id) 1384 is 1385 Rdef : Node_Id; 1386 Stms : List_Id; 1387 Typt : Entity_Id; 1388 1389 In_Limited_Extension : Boolean := False; 1390 -- Set to True while processing the record extension definition 1391 -- for an extension of a limited type (for which an ancestor type 1392 -- has an explicit Nam attribute definition). 1393 1394 function Make_Component_List_Attributes (CL : Node_Id) return List_Id; 1395 -- Returns a sequence of attributes to process the components that 1396 -- are referenced in the given component list. 1397 1398 function Make_Field_Attribute (C : Entity_Id) return Node_Id; 1399 -- Given C, the entity for a discriminant or component, build 1400 -- an attribute for the corresponding field values. 1401 1402 function Make_Field_Attributes (Clist : List_Id) return List_Id; 1403 -- Given Clist, a component items list, construct series of attributes 1404 -- for fieldwise processing of the corresponding components. 1405 1406 ------------------------------------ 1407 -- Make_Component_List_Attributes -- 1408 ------------------------------------ 1409 1410 function Make_Component_List_Attributes (CL : Node_Id) return List_Id is 1411 CI : constant List_Id := Component_Items (CL); 1412 VP : constant Node_Id := Variant_Part (CL); 1413 1414 Result : List_Id; 1415 Alts : List_Id; 1416 V : Node_Id; 1417 DC : Node_Id; 1418 DCH : List_Id; 1419 D_Ref : Node_Id; 1420 1421 begin 1422 Result := Make_Field_Attributes (CI); 1423 1424 if Present (VP) then 1425 Alts := New_List; 1426 1427 V := First_Non_Pragma (Variants (VP)); 1428 while Present (V) loop 1429 DCH := New_List; 1430 1431 DC := First (Discrete_Choices (V)); 1432 while Present (DC) loop 1433 Append_To (DCH, New_Copy_Tree (DC)); 1434 Next (DC); 1435 end loop; 1436 1437 Append_To (Alts, 1438 Make_Case_Statement_Alternative (Loc, 1439 Discrete_Choices => DCH, 1440 Statements => 1441 Make_Component_List_Attributes (Component_List (V)))); 1442 Next_Non_Pragma (V); 1443 end loop; 1444 1445 -- Note: in the following, we make sure that we use new occurrence 1446 -- of for the selector, since there are cases in which we make a 1447 -- reference to a hidden discriminant that is not visible. 1448 1449 -- If the enclosing record is an unchecked_union, we use the 1450 -- default expressions for the discriminant (it must exist) 1451 -- because we cannot generate a reference to it, given that 1452 -- it is not stored. 1453 1454 if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then 1455 D_Ref := 1456 New_Copy_Tree 1457 (Discriminant_Default_Value (Entity (Name (VP)))); 1458 else 1459 D_Ref := 1460 Make_Selected_Component (Loc, 1461 Prefix => Make_Identifier (Loc, Name_V), 1462 Selector_Name => 1463 New_Occurrence_Of (Entity (Name (VP)), Loc)); 1464 end if; 1465 1466 Append_To (Result, 1467 Make_Case_Statement (Loc, 1468 Expression => D_Ref, 1469 Alternatives => Alts)); 1470 end if; 1471 1472 return Result; 1473 end Make_Component_List_Attributes; 1474 1475 -------------------------- 1476 -- Make_Field_Attribute -- 1477 -------------------------- 1478 1479 function Make_Field_Attribute (C : Entity_Id) return Node_Id is 1480 Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C)); 1481 1482 TSS_Names : constant array (Name_Input .. Name_Write) of 1483 TSS_Name_Type := 1484 (Name_Read => TSS_Stream_Read, 1485 Name_Write => TSS_Stream_Write, 1486 Name_Input => TSS_Stream_Input, 1487 Name_Output => TSS_Stream_Output, 1488 others => TSS_Null); 1489 pragma Assert (TSS_Names (Nam) /= TSS_Null); 1490 1491 begin 1492 if In_Limited_Extension 1493 and then Is_Limited_Type (Field_Typ) 1494 and then No (Find_Inherited_TSS (Field_Typ, TSS_Names (Nam))) 1495 then 1496 -- The declaration is illegal per 13.13.2(9/1), and this is 1497 -- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the caller 1498 -- happy by returning a null statement. 1499 1500 return Make_Null_Statement (Loc); 1501 end if; 1502 1503 return 1504 Make_Attribute_Reference (Loc, 1505 Prefix => New_Occurrence_Of (Field_Typ, Loc), 1506 Attribute_Name => Nam, 1507 Expressions => New_List ( 1508 Make_Identifier (Loc, Name_S), 1509 Make_Selected_Component (Loc, 1510 Prefix => Make_Identifier (Loc, Name_V), 1511 Selector_Name => New_Occurrence_Of (C, Loc)))); 1512 end Make_Field_Attribute; 1513 1514 --------------------------- 1515 -- Make_Field_Attributes -- 1516 --------------------------- 1517 1518 function Make_Field_Attributes (Clist : List_Id) return List_Id is 1519 Item : Node_Id; 1520 Result : List_Id; 1521 1522 begin 1523 Result := New_List; 1524 1525 if Present (Clist) then 1526 Item := First (Clist); 1527 1528 -- Loop through components, skipping all internal components, 1529 -- which are not part of the value (e.g. _Tag), except that we 1530 -- don't skip the _Parent, since we do want to process that 1531 -- recursively. If _Parent is an interface type, being abstract 1532 -- with no components there is no need to handle it. 1533 1534 while Present (Item) loop 1535 if Nkind (Item) = N_Component_Declaration 1536 and then 1537 ((Chars (Defining_Identifier (Item)) = Name_uParent 1538 and then not Is_Interface 1539 (Etype (Defining_Identifier (Item)))) 1540 or else 1541 not Is_Internal_Name (Chars (Defining_Identifier (Item)))) 1542 then 1543 Append_To 1544 (Result, 1545 Make_Field_Attribute (Defining_Identifier (Item))); 1546 end if; 1547 1548 Next (Item); 1549 end loop; 1550 end if; 1551 1552 return Result; 1553 end Make_Field_Attributes; 1554 1555 -- Start of processing for Build_Record_Read_Write_Procedure 1556 1557 begin 1558 -- For the protected type case, use corresponding record 1559 1560 if Is_Protected_Type (Typ) then 1561 Typt := Corresponding_Record_Type (Typ); 1562 else 1563 Typt := Typ; 1564 end if; 1565 1566 -- Note that we do nothing with the discriminants, since Read and 1567 -- Write do not read or write the discriminant values. All handling 1568 -- of discriminants occurs in the Input and Output subprograms. 1569 1570 Rdef := Type_Definition 1571 (Declaration_Node (Base_Type (Underlying_Type (Typt)))); 1572 Stms := Empty_List; 1573 1574 -- In record extension case, the fields we want, including the _Parent 1575 -- field representing the parent type, are to be found in the extension. 1576 -- Note that we will naturally process the _Parent field using the type 1577 -- of the parent, and hence its stream attributes, which is appropriate. 1578 1579 if Nkind (Rdef) = N_Derived_Type_Definition then 1580 Rdef := Record_Extension_Part (Rdef); 1581 1582 if Is_Limited_Type (Typt) then 1583 In_Limited_Extension := True; 1584 end if; 1585 end if; 1586 1587 if Present (Component_List (Rdef)) then 1588 Append_List_To (Stms, 1589 Make_Component_List_Attributes (Component_List (Rdef))); 1590 end if; 1591 1592 Build_Stream_Procedure 1593 (Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read); 1594 end Build_Record_Read_Write_Procedure; 1595 1596 ---------------------------------- 1597 -- Build_Record_Write_Procedure -- 1598 ---------------------------------- 1599 1600 procedure Build_Record_Write_Procedure 1601 (Loc : Source_Ptr; 1602 Typ : Entity_Id; 1603 Decl : out Node_Id; 1604 Pnam : out Entity_Id) 1605 is 1606 begin 1607 Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write); 1608 Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write); 1609 end Build_Record_Write_Procedure; 1610 1611 ------------------------------- 1612 -- Build_Stream_Attr_Profile -- 1613 ------------------------------- 1614 1615 function Build_Stream_Attr_Profile 1616 (Loc : Source_Ptr; 1617 Typ : Entity_Id; 1618 Nam : TSS_Name_Type) return List_Id 1619 is 1620 Profile : List_Id; 1621 1622 begin 1623 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has 1624 -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005. 1625 1626 Profile := New_List ( 1627 Make_Parameter_Specification (Loc, 1628 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), 1629 Parameter_Type => 1630 Make_Access_Definition (Loc, 1631 Null_Exclusion_Present => True, 1632 Subtype_Mark => New_Occurrence_Of ( 1633 Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))); 1634 1635 if Nam /= TSS_Stream_Input then 1636 Append_To (Profile, 1637 Make_Parameter_Specification (Loc, 1638 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 1639 Out_Present => (Nam = TSS_Stream_Read), 1640 Parameter_Type => New_Occurrence_Of (Typ, Loc))); 1641 end if; 1642 1643 return Profile; 1644 end Build_Stream_Attr_Profile; 1645 1646 --------------------------- 1647 -- Build_Stream_Function -- 1648 --------------------------- 1649 1650 procedure Build_Stream_Function 1651 (Loc : Source_Ptr; 1652 Typ : Entity_Id; 1653 Decl : out Node_Id; 1654 Fnam : Entity_Id; 1655 Decls : List_Id; 1656 Stms : List_Id) 1657 is 1658 Spec : Node_Id; 1659 1660 begin 1661 -- Construct function specification 1662 1663 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has 1664 -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005. 1665 1666 Spec := 1667 Make_Function_Specification (Loc, 1668 Defining_Unit_Name => Fnam, 1669 1670 Parameter_Specifications => New_List ( 1671 Make_Parameter_Specification (Loc, 1672 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), 1673 Parameter_Type => 1674 Make_Access_Definition (Loc, 1675 Null_Exclusion_Present => True, 1676 Subtype_Mark => 1677 New_Occurrence_Of 1678 (Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))), 1679 1680 Result_Definition => New_Occurrence_Of (Typ, Loc)); 1681 1682 Decl := 1683 Make_Subprogram_Body (Loc, 1684 Specification => Spec, 1685 Declarations => Decls, 1686 Handled_Statement_Sequence => 1687 Make_Handled_Sequence_Of_Statements (Loc, 1688 Statements => Stms)); 1689 end Build_Stream_Function; 1690 1691 ---------------------------- 1692 -- Build_Stream_Procedure -- 1693 ---------------------------- 1694 1695 procedure Build_Stream_Procedure 1696 (Loc : Source_Ptr; 1697 Typ : Entity_Id; 1698 Decl : out Node_Id; 1699 Pnam : Entity_Id; 1700 Stms : List_Id; 1701 Outp : Boolean) 1702 is 1703 Spec : Node_Id; 1704 1705 begin 1706 -- Construct procedure specification 1707 1708 -- (Ada 2005: AI-441): Set the null-excluding attribute because it has 1709 -- no semantic meaning in Ada 95 but it is a requirement in Ada 2005. 1710 1711 Spec := 1712 Make_Procedure_Specification (Loc, 1713 Defining_Unit_Name => Pnam, 1714 1715 Parameter_Specifications => New_List ( 1716 Make_Parameter_Specification (Loc, 1717 Defining_Identifier => Make_Defining_Identifier (Loc, Name_S), 1718 Parameter_Type => 1719 Make_Access_Definition (Loc, 1720 Null_Exclusion_Present => True, 1721 Subtype_Mark => 1722 New_Occurrence_Of 1723 (Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))), 1724 1725 Make_Parameter_Specification (Loc, 1726 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 1727 Out_Present => Outp, 1728 Parameter_Type => New_Occurrence_Of (Typ, Loc)))); 1729 1730 Decl := 1731 Make_Subprogram_Body (Loc, 1732 Specification => Spec, 1733 Declarations => Empty_List, 1734 Handled_Statement_Sequence => 1735 Make_Handled_Sequence_Of_Statements (Loc, 1736 Statements => Stms)); 1737 end Build_Stream_Procedure; 1738 1739 ----------------------------- 1740 -- Has_Stream_Standard_Rep -- 1741 ----------------------------- 1742 1743 function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is 1744 Siz : Uint; 1745 1746 begin 1747 if Has_Non_Standard_Rep (U_Type) then 1748 return False; 1749 end if; 1750 1751 if Has_Stream_Size_Clause (U_Type) then 1752 Siz := Static_Integer (Expression (Stream_Size_Clause (U_Type))); 1753 else 1754 Siz := Esize (First_Subtype (U_Type)); 1755 end if; 1756 1757 return Siz = Esize (Root_Type (U_Type)); 1758 end Has_Stream_Standard_Rep; 1759 1760 --------------------------------- 1761 -- Make_Stream_Subprogram_Name -- 1762 --------------------------------- 1763 1764 function Make_Stream_Subprogram_Name 1765 (Loc : Source_Ptr; 1766 Typ : Entity_Id; 1767 Nam : TSS_Name_Type) return Entity_Id 1768 is 1769 Sname : Name_Id; 1770 1771 begin 1772 -- For tagged types, we are dealing with a TSS associated with the 1773 -- declaration, so we use the standard primitive function name. For 1774 -- other types, generate a local TSS name since we are generating 1775 -- the subprogram at the point of use. 1776 1777 if Is_Tagged_Type (Typ) then 1778 Sname := Make_TSS_Name (Typ, Nam); 1779 else 1780 Sname := Make_TSS_Name_Local (Typ, Nam); 1781 end if; 1782 1783 return Make_Defining_Identifier (Loc, Sname); 1784 end Make_Stream_Subprogram_Name; 1785 1786 ---------------------- 1787 -- Stream_Base_Type -- 1788 ---------------------- 1789 1790 function Stream_Base_Type (E : Entity_Id) return Entity_Id is 1791 begin 1792 if Is_Array_Type (E) 1793 and then Is_First_Subtype (E) 1794 then 1795 return E; 1796 else 1797 return Base_Type (E); 1798 end if; 1799 end Stream_Base_Type; 1800 1801end Exp_Strm; 1802