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