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