1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- C S T A N D -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2015, 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 Csets; use Csets; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Layout; use Layout; 32with Namet; use Namet; 33with Nlists; use Nlists; 34with Nmake; use Nmake; 35with Opt; use Opt; 36with Output; use Output; 37with Set_Targ; use Set_Targ; 38with Targparm; use Targparm; 39with Tbuild; use Tbuild; 40with Ttypes; use Ttypes; 41with Scn; 42with Sem_Mech; use Sem_Mech; 43with Sem_Util; use Sem_Util; 44with Sinfo; use Sinfo; 45with Snames; use Snames; 46with Stand; use Stand; 47with Uintp; use Uintp; 48with Urealp; use Urealp; 49 50package body CStand is 51 52 Stloc : constant Source_Ptr := Standard_Location; 53 Staloc : constant Source_Ptr := Standard_ASCII_Location; 54 -- Standard abbreviations used throughout this package 55 56 Back_End_Float_Types : Elist_Id := No_Elist; 57 -- List used for any floating point supported by the back end. This needs 58 -- to be at the library level, because the call back procedures retrieving 59 -- this information are at that level. 60 61 ----------------------- 62 -- Local Subprograms -- 63 ----------------------- 64 65 procedure Build_Float_Type 66 (E : Entity_Id; 67 Siz : Int; 68 Rep : Float_Rep_Kind; 69 Digs : Int); 70 -- Procedure to build standard predefined float base type. The first 71 -- parameter is the entity for the type, and the second parameter is the 72 -- size in bits. The third parameter indicates the kind of representation 73 -- to be used. The fourth parameter is the digits value. Each type 74 -- is added to the list of predefined floating point types. 75 76 procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Nat); 77 -- Procedure to build standard predefined signed integer subtype. The 78 -- first parameter is the entity for the subtype. The second parameter 79 -- is the size in bits. The corresponding base type is not built by 80 -- this routine but instead must be built by the caller where needed. 81 82 procedure Build_Unsigned_Integer_Type 83 (Uns : Entity_Id; 84 Siz : Nat; 85 Nam : String); 86 -- Procedure to build standard predefined unsigned integer subtype. These 87 -- subtypes are not user visible, but they are used internally. The first 88 -- parameter is the entity for the subtype. The second parameter is the 89 -- size in bits. The third parameter is an identifying name. 90 91 procedure Copy_Float_Type (To : Entity_Id; From : Entity_Id); 92 -- Build a floating point type, copying representation details from From. 93 -- This is used to create predefined floating point types based on 94 -- available types in the back end. 95 96 procedure Create_Operators; 97 -- Make entries for each of the predefined operators in Standard 98 99 procedure Create_Unconstrained_Base_Type 100 (E : Entity_Id; 101 K : Entity_Kind); 102 -- The predefined signed integer types are constrained subtypes which 103 -- must have a corresponding unconstrained base type. This type is almost 104 -- useless. The only place it has semantics is Subtypes_Statically_Match. 105 -- Consequently, we arrange for it to be identical apart from the setting 106 -- of the constrained bit. This routine takes an entity E for the Type, 107 -- copies it to estabish the base type, then resets the Ekind of the 108 -- original entity to K (the Ekind for the subtype). The Etype field of 109 -- E is set by the call (to point to the created base type entity), and 110 -- also the Is_Constrained flag of E is set. 111 -- 112 -- To understand the exact requirement for this, see RM 3.5.4(11) which 113 -- makes it clear that Integer, for example, is constrained, with the 114 -- constraint bounds matching the bounds of the (unconstrained) base 115 -- type. The point is that Integer and Integer'Base have identical 116 -- bounds, but do not statically match, since a subtype with constraints 117 -- never matches a subtype with no constraints. 118 119 function Find_Back_End_Float_Type (Name : String) return Entity_Id; 120 -- Return the first float type in Back_End_Float_Types with the given name. 121 -- Names of entities in back end types, are either type names of C 122 -- predefined types (all lower case), or mode names (upper case). 123 -- These are not generally valid identifier names. 124 125 function Identifier_For (S : Standard_Entity_Type) return Node_Id; 126 -- Returns an identifier node with the same name as the defining 127 -- identifier corresponding to the given Standard_Entity_Type value 128 129 procedure Make_Component 130 (Rec : Entity_Id; 131 Typ : Entity_Id; 132 Nam : String); 133 -- Build a record component with the given type and name, and append to 134 -- the list of components of Rec. 135 136 function Make_Formal 137 (Typ : Entity_Id; 138 Formal_Name : String) return Entity_Id; 139 -- Construct entity for subprogram formal with given name and type 140 141 function Make_Integer (V : Uint) return Node_Id; 142 -- Builds integer literal with given value 143 144 procedure Make_Name (Id : Entity_Id; Nam : String); 145 -- Make an entry in the names table for Nam, and set as Chars field of Id 146 147 function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id; 148 -- Build entity for standard operator with given name and type 149 150 function New_Standard_Entity 151 (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id; 152 -- Builds a new entity for Standard 153 154 function New_Standard_Entity (S : String) return Entity_Id; 155 -- Builds a new entity for Standard with Nkind = N_Defining_Identifier, 156 -- and Chars of this defining identifier set to the given string S. 157 158 procedure Print_Standard; 159 -- Print representation of package Standard if switch set 160 161 procedure Register_Float_Type 162 (Name : String; 163 Digs : Positive; 164 Float_Rep : Float_Rep_Kind; 165 Precision : Positive; 166 Size : Positive; 167 Alignment : Natural); 168 -- Registers a single back end floating-point type (from FPT_Mode_Table in 169 -- Set_Targ). This will create a predefined floating-point base type for 170 -- one of the floating point types reported by the back end, and add it 171 -- to the list of predefined float types. Name is the name of the type 172 -- as a normal format (non-null-terminated) string. Digs is the number of 173 -- digits, which is always non-zero, since non-floating-point types were 174 -- filtered out earlier. Float_Rep indicates the kind of floating-point 175 -- type, and Precision, Size and Alignment are the precision, size and 176 -- alignment in bits. 177 178 procedure Set_Integer_Bounds 179 (Id : Entity_Id; 180 Typ : Entity_Id; 181 Lb : Uint; 182 Hb : Uint); 183 -- Procedure to set bounds for integer type or subtype. Id is the entity 184 -- whose bounds and type are to be set. The Typ parameter is the Etype 185 -- value for the entity (which will be the same as Id for all predefined 186 -- integer base types. The third and fourth parameters are the bounds. 187 188 ---------------------- 189 -- Build_Float_Type -- 190 ---------------------- 191 192 procedure Build_Float_Type 193 (E : Entity_Id; 194 Siz : Int; 195 Rep : Float_Rep_Kind; 196 Digs : Int) 197 is 198 begin 199 Set_Type_Definition (Parent (E), 200 Make_Floating_Point_Definition (Stloc, 201 Digits_Expression => Make_Integer (UI_From_Int (Digs)))); 202 203 Set_Ekind (E, E_Floating_Point_Type); 204 Set_Etype (E, E); 205 Set_Float_Rep (E, Rep); 206 Init_Size (E, Siz); 207 Set_Elem_Alignment (E); 208 Init_Digits_Value (E, Digs); 209 Set_Float_Bounds (E); 210 Set_Is_Frozen (E); 211 Set_Is_Public (E); 212 Set_Size_Known_At_Compile_Time (E); 213 end Build_Float_Type; 214 215 ------------------------------ 216 -- Find_Back_End_Float_Type -- 217 ------------------------------ 218 219 function Find_Back_End_Float_Type (Name : String) return Entity_Id is 220 N : Elmt_Id; 221 222 begin 223 N := First_Elmt (Back_End_Float_Types); 224 while Present (N) and then Get_Name_String (Chars (Node (N))) /= Name 225 loop 226 Next_Elmt (N); 227 end loop; 228 229 return Node (N); 230 end Find_Back_End_Float_Type; 231 232 ------------------------------- 233 -- Build_Signed_Integer_Type -- 234 ------------------------------- 235 236 procedure Build_Signed_Integer_Type (E : Entity_Id; Siz : Nat) is 237 U2Siz1 : constant Uint := 2 ** (Siz - 1); 238 Lbound : constant Uint := -U2Siz1; 239 Ubound : constant Uint := U2Siz1 - 1; 240 241 begin 242 Set_Type_Definition (Parent (E), 243 Make_Signed_Integer_Type_Definition (Stloc, 244 Low_Bound => Make_Integer (Lbound), 245 High_Bound => Make_Integer (Ubound))); 246 247 Set_Ekind (E, E_Signed_Integer_Type); 248 Set_Etype (E, E); 249 Init_Size (E, Siz); 250 Set_Elem_Alignment (E); 251 Set_Integer_Bounds (E, E, Lbound, Ubound); 252 Set_Is_Frozen (E); 253 Set_Is_Public (E); 254 Set_Is_Known_Valid (E); 255 Set_Size_Known_At_Compile_Time (E); 256 end Build_Signed_Integer_Type; 257 258 --------------------------------- 259 -- Build_Unsigned_Integer_Type -- 260 --------------------------------- 261 262 procedure Build_Unsigned_Integer_Type 263 (Uns : Entity_Id; 264 Siz : Nat; 265 Nam : String) 266 is 267 Decl : Node_Id; 268 R_Node : Node_Id; 269 270 begin 271 Decl := New_Node (N_Full_Type_Declaration, Stloc); 272 Set_Defining_Identifier (Decl, Uns); 273 Make_Name (Uns, Nam); 274 275 Set_Ekind (Uns, E_Modular_Integer_Type); 276 Set_Scope (Uns, Standard_Standard); 277 Set_Etype (Uns, Uns); 278 Init_Size (Uns, Siz); 279 Set_Elem_Alignment (Uns); 280 Set_Modulus (Uns, Uint_2 ** Siz); 281 Set_Is_Unsigned_Type (Uns); 282 Set_Size_Known_At_Compile_Time (Uns); 283 Set_Is_Known_Valid (Uns, True); 284 285 R_Node := New_Node (N_Range, Stloc); 286 Set_Low_Bound (R_Node, Make_Integer (Uint_0)); 287 Set_High_Bound (R_Node, Make_Integer (Modulus (Uns) - 1)); 288 Set_Etype (Low_Bound (R_Node), Uns); 289 Set_Etype (High_Bound (R_Node), Uns); 290 Set_Scalar_Range (Uns, R_Node); 291 end Build_Unsigned_Integer_Type; 292 293 --------------------- 294 -- Copy_Float_Type -- 295 --------------------- 296 297 procedure Copy_Float_Type (To : Entity_Id; From : Entity_Id) is 298 begin 299 Build_Float_Type (To, UI_To_Int (Esize (From)), Float_Rep (From), 300 UI_To_Int (Digits_Value (From))); 301 end Copy_Float_Type; 302 303 ---------------------- 304 -- Create_Operators -- 305 ---------------------- 306 307 -- Each operator has an abbreviated signature. The formals have the names 308 -- LEFT and RIGHT. Their types are not actually used for resolution. 309 310 procedure Create_Operators is 311 Op_Node : Entity_Id; 312 313 -- The following tables define the binary and unary operators and their 314 -- corresponding result type. 315 316 Binary_Ops : constant array (S_Binary_Ops) of Name_Id := 317 318 -- There is one entry here for each binary operator, except for the 319 -- case of concatenation, where there are three entries, one for a 320 -- String result, one for Wide_String, and one for Wide_Wide_String. 321 322 (Name_Op_Add, 323 Name_Op_And, 324 Name_Op_Concat, 325 Name_Op_Concat, 326 Name_Op_Concat, 327 Name_Op_Divide, 328 Name_Op_Eq, 329 Name_Op_Expon, 330 Name_Op_Ge, 331 Name_Op_Gt, 332 Name_Op_Le, 333 Name_Op_Lt, 334 Name_Op_Mod, 335 Name_Op_Multiply, 336 Name_Op_Ne, 337 Name_Op_Or, 338 Name_Op_Rem, 339 Name_Op_Subtract, 340 Name_Op_Xor); 341 342 Bin_Op_Types : constant array (S_Binary_Ops) of Entity_Id := 343 344 -- This table has the corresponding result types. The entries are 345 -- ordered so they correspond to the Binary_Ops array above. 346 347 (Universal_Integer, -- Add 348 Standard_Boolean, -- And 349 Standard_String, -- Concat (String) 350 Standard_Wide_String, -- Concat (Wide_String) 351 Standard_Wide_Wide_String, -- Concat (Wide_Wide_String) 352 Universal_Integer, -- Divide 353 Standard_Boolean, -- Eq 354 Universal_Integer, -- Expon 355 Standard_Boolean, -- Ge 356 Standard_Boolean, -- Gt 357 Standard_Boolean, -- Le 358 Standard_Boolean, -- Lt 359 Universal_Integer, -- Mod 360 Universal_Integer, -- Multiply 361 Standard_Boolean, -- Ne 362 Standard_Boolean, -- Or 363 Universal_Integer, -- Rem 364 Universal_Integer, -- Subtract 365 Standard_Boolean); -- Xor 366 367 Unary_Ops : constant array (S_Unary_Ops) of Name_Id := 368 369 -- There is one entry here for each unary operator 370 371 (Name_Op_Abs, 372 Name_Op_Subtract, 373 Name_Op_Not, 374 Name_Op_Add); 375 376 Unary_Op_Types : constant array (S_Unary_Ops) of Entity_Id := 377 378 -- This table has the corresponding result types. The entries are 379 -- ordered so they correspond to the Unary_Ops array above. 380 381 (Universal_Integer, -- Abs 382 Universal_Integer, -- Subtract 383 Standard_Boolean, -- Not 384 Universal_Integer); -- Add 385 386 begin 387 for J in S_Binary_Ops loop 388 Op_Node := New_Operator (Binary_Ops (J), Bin_Op_Types (J)); 389 SE (J) := Op_Node; 390 Append_Entity (Make_Formal (Any_Type, "LEFT"), Op_Node); 391 Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node); 392 end loop; 393 394 for J in S_Unary_Ops loop 395 Op_Node := New_Operator (Unary_Ops (J), Unary_Op_Types (J)); 396 SE (J) := Op_Node; 397 Append_Entity (Make_Formal (Any_Type, "RIGHT"), Op_Node); 398 end loop; 399 400 -- For concatenation, we create a separate operator for each 401 -- array type. This simplifies the resolution of the component- 402 -- component concatenation operation. In Standard, we set the types 403 -- of the formals for string, wide [wide]_string, concatenations. 404 405 Set_Etype (First_Entity (Standard_Op_Concat), Standard_String); 406 Set_Etype (Last_Entity (Standard_Op_Concat), Standard_String); 407 408 Set_Etype (First_Entity (Standard_Op_Concatw), Standard_Wide_String); 409 Set_Etype (Last_Entity (Standard_Op_Concatw), Standard_Wide_String); 410 411 Set_Etype (First_Entity (Standard_Op_Concatww), 412 Standard_Wide_Wide_String); 413 414 Set_Etype (Last_Entity (Standard_Op_Concatww), 415 Standard_Wide_Wide_String); 416 end Create_Operators; 417 418 --------------------- 419 -- Create_Standard -- 420 --------------------- 421 422 -- The tree for the package Standard is prefixed to all compilations. 423 -- Several entities required by semantic analysis are denoted by global 424 -- variables that are initialized to point to the corresponding occurrences 425 -- in Standard. The visible entities of Standard are created here. Special 426 -- entities maybe created here as well or may be created from the semantics 427 -- module. By not adding them to the Decls list of Standard they will not 428 -- be visible to Ada programs. 429 430 procedure Create_Standard is 431 Decl_S : constant List_Id := New_List; 432 -- List of declarations in Standard 433 434 Decl_A : constant List_Id := New_List; 435 -- List of declarations in ASCII 436 437 Decl : Node_Id; 438 Pspec : Node_Id; 439 Tdef_Node : Node_Id; 440 Ident_Node : Node_Id; 441 Ccode : Char_Code; 442 E_Id : Entity_Id; 443 R_Node : Node_Id; 444 B_Node : Node_Id; 445 446 procedure Build_Exception (S : Standard_Entity_Type); 447 -- Procedure to declare given entity as an exception 448 449 procedure Create_Back_End_Float_Types; 450 -- Initialize the Back_End_Float_Types list by having the back end 451 -- enumerate all available types and building type entities for them. 452 453 procedure Create_Float_Types; 454 -- Creates entities for all predefined floating point types, and 455 -- adds these to the Predefined_Float_Types list in package Standard. 456 457 procedure Make_Dummy_Index (E : Entity_Id); 458 -- Called to provide a dummy index field value for Any_Array/Any_String 459 460 procedure Pack_String_Type (String_Type : Entity_Id); 461 -- Generate proper tree for pragma Pack that applies to given type, and 462 -- mark type as having the pragma. 463 464 --------------------- 465 -- Build_Exception -- 466 --------------------- 467 468 procedure Build_Exception (S : Standard_Entity_Type) is 469 begin 470 Set_Ekind (Standard_Entity (S), E_Exception); 471 Set_Etype (Standard_Entity (S), Standard_Exception_Type); 472 Set_Is_Public (Standard_Entity (S), True); 473 474 Decl := 475 Make_Exception_Declaration (Stloc, 476 Defining_Identifier => Standard_Entity (S)); 477 Append (Decl, Decl_S); 478 end Build_Exception; 479 480 --------------------------------- 481 -- Create_Back_End_Float_Types -- 482 --------------------------------- 483 484 procedure Create_Back_End_Float_Types is 485 begin 486 for J in 1 .. Num_FPT_Modes loop 487 declare 488 E : FPT_Mode_Entry renames FPT_Mode_Table (J); 489 begin 490 Register_Float_Type 491 (E.NAME.all, E.DIGS, E.FLOAT_REP, E.PRECISION, E.SIZE, 492 E.ALIGNMENT); 493 end; 494 end loop; 495 end Create_Back_End_Float_Types; 496 497 ------------------------ 498 -- Create_Float_Types -- 499 ------------------------ 500 501 procedure Create_Float_Types is 502 begin 503 -- Create type definition nodes for predefined float types 504 505 Copy_Float_Type 506 (Standard_Short_Float, 507 Find_Back_End_Float_Type (C_Type_For (S_Short_Float))); 508 Set_Is_Implementation_Defined (Standard_Short_Float); 509 510 Copy_Float_Type (Standard_Float, Standard_Short_Float); 511 512 Copy_Float_Type 513 (Standard_Long_Float, 514 Find_Back_End_Float_Type (C_Type_For (S_Long_Float))); 515 516 Copy_Float_Type 517 (Standard_Long_Long_Float, 518 Find_Back_End_Float_Type (C_Type_For (S_Long_Long_Float))); 519 Set_Is_Implementation_Defined (Standard_Long_Long_Float); 520 521 Predefined_Float_Types := New_Elmt_List; 522 523 Append_Elmt (Standard_Short_Float, Predefined_Float_Types); 524 Append_Elmt (Standard_Float, Predefined_Float_Types); 525 Append_Elmt (Standard_Long_Float, Predefined_Float_Types); 526 Append_Elmt (Standard_Long_Long_Float, Predefined_Float_Types); 527 528 -- Any other back end types are appended at the end of the list of 529 -- predefined float types, and will only be selected if the none of 530 -- the types in Standard is suitable, or if a specific named type is 531 -- requested through a pragma Import. 532 533 while not Is_Empty_Elmt_List (Back_End_Float_Types) loop 534 declare 535 E : constant Elmt_Id := First_Elmt (Back_End_Float_Types); 536 begin 537 Append_Elmt (Node (E), To => Predefined_Float_Types); 538 Remove_Elmt (Back_End_Float_Types, E); 539 end; 540 end loop; 541 end Create_Float_Types; 542 543 ---------------------- 544 -- Make_Dummy_Index -- 545 ---------------------- 546 547 procedure Make_Dummy_Index (E : Entity_Id) is 548 Index : Node_Id; 549 Dummy : List_Id; 550 551 begin 552 Index := 553 Make_Range (Sloc (E), 554 Low_Bound => Make_Integer (Uint_0), 555 High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size)); 556 Set_Etype (Index, Standard_Integer); 557 Set_First_Index (E, Index); 558 559 -- Make sure Index is a list as required, so Next_Index is Empty 560 561 Dummy := New_List (Index); 562 end Make_Dummy_Index; 563 564 ---------------------- 565 -- Pack_String_Type -- 566 ---------------------- 567 568 procedure Pack_String_Type (String_Type : Entity_Id) is 569 Prag : constant Node_Id := 570 Make_Pragma (Stloc, 571 Chars => Name_Pack, 572 Pragma_Argument_Associations => 573 New_List ( 574 Make_Pragma_Argument_Association (Stloc, 575 Expression => New_Occurrence_Of (String_Type, Stloc)))); 576 begin 577 Append (Prag, Decl_S); 578 Record_Rep_Item (String_Type, Prag); 579 Set_Has_Pragma_Pack (String_Type, True); 580 end Pack_String_Type; 581 582 -- Start of processing for Create_Standard 583 584 begin 585 -- Initialize scanner for internal scans of literals 586 587 Scn.Initialize_Scanner (No_Unit, Internal_Source_File); 588 589 -- First step is to create defining identifiers for each entity 590 591 for S in Standard_Entity_Type loop 592 declare 593 S_Name : constant String := Standard_Entity_Type'Image (S); 594 -- Name of entity (note we skip S_ at the start) 595 596 Ident_Node : Node_Id; 597 -- Defining identifier node 598 599 begin 600 Ident_Node := New_Standard_Entity; 601 Make_Name (Ident_Node, S_Name (3 .. S_Name'Length)); 602 Standard_Entity (S) := Ident_Node; 603 end; 604 end loop; 605 606 -- Create package declaration node for package Standard 607 608 Standard_Package_Node := New_Node (N_Package_Declaration, Stloc); 609 610 Pspec := New_Node (N_Package_Specification, Stloc); 611 Set_Specification (Standard_Package_Node, Pspec); 612 613 Set_Defining_Unit_Name (Pspec, Standard_Standard); 614 Set_Visible_Declarations (Pspec, Decl_S); 615 616 Set_Ekind (Standard_Standard, E_Package); 617 Set_Is_Pure (Standard_Standard); 618 Set_Is_Compilation_Unit (Standard_Standard); 619 620 -- Create type/subtype declaration nodes for standard types 621 622 for S in S_Types loop 623 624 -- Subtype declaration case 625 626 if S = S_Natural or else S = S_Positive then 627 Decl := New_Node (N_Subtype_Declaration, Stloc); 628 Set_Subtype_Indication (Decl, 629 New_Occurrence_Of (Standard_Integer, Stloc)); 630 631 -- Full type declaration case 632 633 else 634 Decl := New_Node (N_Full_Type_Declaration, Stloc); 635 end if; 636 637 Set_Is_Frozen (Standard_Entity (S)); 638 Set_Is_Public (Standard_Entity (S)); 639 Set_Defining_Identifier (Decl, Standard_Entity (S)); 640 Append (Decl, Decl_S); 641 end loop; 642 643 Create_Back_End_Float_Types; 644 645 -- Create type definition node for type Boolean. The Size is set to 646 -- 1 as required by Ada 95 and current ARG interpretations for Ada/83. 647 648 -- Note: Object_Size of Boolean is 8. This means that we do NOT in 649 -- general know that Boolean variables have valid values, so we do 650 -- not set the Is_Known_Valid flag. 651 652 Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); 653 Set_Literals (Tdef_Node, New_List); 654 Append (Standard_False, Literals (Tdef_Node)); 655 Append (Standard_True, Literals (Tdef_Node)); 656 Set_Type_Definition (Parent (Standard_Boolean), Tdef_Node); 657 658 Set_Ekind (Standard_Boolean, E_Enumeration_Type); 659 Set_First_Literal (Standard_Boolean, Standard_False); 660 Set_Etype (Standard_Boolean, Standard_Boolean); 661 Init_Esize (Standard_Boolean, Standard_Character_Size); 662 Init_RM_Size (Standard_Boolean, 1); 663 Set_Elem_Alignment (Standard_Boolean); 664 665 Set_Is_Unsigned_Type (Standard_Boolean); 666 Set_Size_Known_At_Compile_Time (Standard_Boolean); 667 Set_Has_Pragma_Ordered (Standard_Boolean); 668 669 Set_Ekind (Standard_True, E_Enumeration_Literal); 670 Set_Etype (Standard_True, Standard_Boolean); 671 Set_Enumeration_Pos (Standard_True, Uint_1); 672 Set_Enumeration_Rep (Standard_True, Uint_1); 673 Set_Is_Known_Valid (Standard_True, True); 674 675 Set_Ekind (Standard_False, E_Enumeration_Literal); 676 Set_Etype (Standard_False, Standard_Boolean); 677 Set_Enumeration_Pos (Standard_False, Uint_0); 678 Set_Enumeration_Rep (Standard_False, Uint_0); 679 Set_Is_Known_Valid (Standard_False, True); 680 681 -- For the bounds of Boolean, we create a range node corresponding to 682 683 -- range False .. True 684 685 -- where the occurrences of the literals must point to the 686 -- corresponding definition. 687 688 R_Node := New_Node (N_Range, Stloc); 689 B_Node := New_Node (N_Identifier, Stloc); 690 Set_Chars (B_Node, Chars (Standard_False)); 691 Set_Entity (B_Node, Standard_False); 692 Set_Etype (B_Node, Standard_Boolean); 693 Set_Is_Static_Expression (B_Node); 694 Set_Low_Bound (R_Node, B_Node); 695 696 B_Node := New_Node (N_Identifier, Stloc); 697 Set_Chars (B_Node, Chars (Standard_True)); 698 Set_Entity (B_Node, Standard_True); 699 Set_Etype (B_Node, Standard_Boolean); 700 Set_Is_Static_Expression (B_Node); 701 Set_High_Bound (R_Node, B_Node); 702 703 Set_Scalar_Range (Standard_Boolean, R_Node); 704 Set_Etype (R_Node, Standard_Boolean); 705 Set_Parent (R_Node, Standard_Boolean); 706 707 -- Record entity identifiers for boolean literals in the 708 -- Boolean_Literals array, for easy reference during expansion. 709 710 Boolean_Literals := (False => Standard_False, True => Standard_True); 711 712 -- Create type definition nodes for predefined integer types 713 714 Build_Signed_Integer_Type 715 (Standard_Short_Short_Integer, Standard_Short_Short_Integer_Size); 716 717 Build_Signed_Integer_Type 718 (Standard_Short_Integer, Standard_Short_Integer_Size); 719 Set_Is_Implementation_Defined (Standard_Short_Integer); 720 721 Build_Signed_Integer_Type 722 (Standard_Integer, Standard_Integer_Size); 723 724 Build_Signed_Integer_Type 725 (Standard_Long_Integer, Standard_Long_Integer_Size); 726 727 Build_Signed_Integer_Type 728 (Standard_Long_Long_Integer, Standard_Long_Long_Integer_Size); 729 Set_Is_Implementation_Defined (Standard_Long_Long_Integer); 730 731 Create_Unconstrained_Base_Type 732 (Standard_Short_Short_Integer, E_Signed_Integer_Subtype); 733 Set_Is_Implementation_Defined (Standard_Short_Short_Integer); 734 735 Create_Unconstrained_Base_Type 736 (Standard_Short_Integer, E_Signed_Integer_Subtype); 737 738 Create_Unconstrained_Base_Type 739 (Standard_Integer, E_Signed_Integer_Subtype); 740 741 Create_Unconstrained_Base_Type 742 (Standard_Long_Integer, E_Signed_Integer_Subtype); 743 744 Create_Unconstrained_Base_Type 745 (Standard_Long_Long_Integer, E_Signed_Integer_Subtype); 746 Set_Is_Implementation_Defined (Standard_Short_Short_Integer); 747 748 Create_Float_Types; 749 750 -- Create type definition node for type Character. Note that we do not 751 -- set the Literals field, since type Character is handled with special 752 -- routine that do not need a literal list. 753 754 Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); 755 Set_Type_Definition (Parent (Standard_Character), Tdef_Node); 756 757 Set_Ekind (Standard_Character, E_Enumeration_Type); 758 Set_Etype (Standard_Character, Standard_Character); 759 Init_Esize (Standard_Character, Standard_Character_Size); 760 Init_RM_Size (Standard_Character, 8); 761 Set_Elem_Alignment (Standard_Character); 762 763 Set_Has_Pragma_Ordered (Standard_Character); 764 Set_Is_Unsigned_Type (Standard_Character); 765 Set_Is_Character_Type (Standard_Character); 766 Set_Is_Known_Valid (Standard_Character); 767 Set_Size_Known_At_Compile_Time (Standard_Character); 768 769 -- Create the bounds for type Character 770 771 R_Node := New_Node (N_Range, Stloc); 772 773 -- Low bound for type Character (Standard.Nul) 774 775 B_Node := New_Node (N_Character_Literal, Stloc); 776 Set_Is_Static_Expression (B_Node); 777 Set_Chars (B_Node, No_Name); 778 Set_Char_Literal_Value (B_Node, Uint_0); 779 Set_Entity (B_Node, Empty); 780 Set_Etype (B_Node, Standard_Character); 781 Set_Low_Bound (R_Node, B_Node); 782 783 -- High bound for type Character 784 785 B_Node := New_Node (N_Character_Literal, Stloc); 786 Set_Is_Static_Expression (B_Node); 787 Set_Chars (B_Node, No_Name); 788 Set_Char_Literal_Value (B_Node, UI_From_Int (16#FF#)); 789 Set_Entity (B_Node, Empty); 790 Set_Etype (B_Node, Standard_Character); 791 Set_High_Bound (R_Node, B_Node); 792 793 Set_Scalar_Range (Standard_Character, R_Node); 794 Set_Etype (R_Node, Standard_Character); 795 Set_Parent (R_Node, Standard_Character); 796 797 -- Create type definition for type Wide_Character. Note that we do not 798 -- set the Literals field, since type Wide_Character is handled with 799 -- special routines that do not need a literal list. 800 801 Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); 802 Set_Type_Definition (Parent (Standard_Wide_Character), Tdef_Node); 803 804 Set_Ekind (Standard_Wide_Character, E_Enumeration_Type); 805 Set_Etype (Standard_Wide_Character, Standard_Wide_Character); 806 Init_Size (Standard_Wide_Character, Standard_Wide_Character_Size); 807 808 Set_Elem_Alignment (Standard_Wide_Character); 809 Set_Has_Pragma_Ordered (Standard_Wide_Character); 810 Set_Is_Unsigned_Type (Standard_Wide_Character); 811 Set_Is_Character_Type (Standard_Wide_Character); 812 Set_Is_Known_Valid (Standard_Wide_Character); 813 Set_Size_Known_At_Compile_Time (Standard_Wide_Character); 814 815 -- Create the bounds for type Wide_Character 816 817 R_Node := New_Node (N_Range, Stloc); 818 819 -- Low bound for type Wide_Character 820 821 B_Node := New_Node (N_Character_Literal, Stloc); 822 Set_Is_Static_Expression (B_Node); 823 Set_Chars (B_Node, No_Name); -- ??? 824 Set_Char_Literal_Value (B_Node, Uint_0); 825 Set_Entity (B_Node, Empty); 826 Set_Etype (B_Node, Standard_Wide_Character); 827 Set_Low_Bound (R_Node, B_Node); 828 829 -- High bound for type Wide_Character 830 831 B_Node := New_Node (N_Character_Literal, Stloc); 832 Set_Is_Static_Expression (B_Node); 833 Set_Chars (B_Node, No_Name); -- ??? 834 Set_Char_Literal_Value (B_Node, UI_From_Int (16#FFFF#)); 835 Set_Entity (B_Node, Empty); 836 Set_Etype (B_Node, Standard_Wide_Character); 837 Set_High_Bound (R_Node, B_Node); 838 839 Set_Scalar_Range (Standard_Wide_Character, R_Node); 840 Set_Etype (R_Node, Standard_Wide_Character); 841 Set_Parent (R_Node, Standard_Wide_Character); 842 843 -- Create type definition for type Wide_Wide_Character. Note that we 844 -- do not set the Literals field, since type Wide_Wide_Character is 845 -- handled with special routines that do not need a literal list. 846 847 Tdef_Node := New_Node (N_Enumeration_Type_Definition, Stloc); 848 Set_Type_Definition (Parent (Standard_Wide_Wide_Character), Tdef_Node); 849 850 Set_Ekind (Standard_Wide_Wide_Character, E_Enumeration_Type); 851 Set_Etype (Standard_Wide_Wide_Character, 852 Standard_Wide_Wide_Character); 853 Init_Size (Standard_Wide_Wide_Character, 854 Standard_Wide_Wide_Character_Size); 855 856 Set_Elem_Alignment (Standard_Wide_Wide_Character); 857 Set_Has_Pragma_Ordered (Standard_Wide_Wide_Character); 858 Set_Is_Unsigned_Type (Standard_Wide_Wide_Character); 859 Set_Is_Character_Type (Standard_Wide_Wide_Character); 860 Set_Is_Known_Valid (Standard_Wide_Wide_Character); 861 Set_Size_Known_At_Compile_Time (Standard_Wide_Wide_Character); 862 Set_Is_Ada_2005_Only (Standard_Wide_Wide_Character); 863 864 -- Create the bounds for type Wide_Wide_Character 865 866 R_Node := New_Node (N_Range, Stloc); 867 868 -- Low bound for type Wide_Wide_Character 869 870 B_Node := New_Node (N_Character_Literal, Stloc); 871 Set_Is_Static_Expression (B_Node); 872 Set_Chars (B_Node, No_Name); -- ??? 873 Set_Char_Literal_Value (B_Node, Uint_0); 874 Set_Entity (B_Node, Empty); 875 Set_Etype (B_Node, Standard_Wide_Wide_Character); 876 Set_Low_Bound (R_Node, B_Node); 877 878 -- High bound for type Wide_Wide_Character 879 880 B_Node := New_Node (N_Character_Literal, Stloc); 881 Set_Is_Static_Expression (B_Node); 882 Set_Chars (B_Node, No_Name); -- ??? 883 Set_Char_Literal_Value (B_Node, UI_From_Int (16#7FFF_FFFF#)); 884 Set_Entity (B_Node, Empty); 885 Set_Etype (B_Node, Standard_Wide_Wide_Character); 886 Set_High_Bound (R_Node, B_Node); 887 888 Set_Scalar_Range (Standard_Wide_Wide_Character, R_Node); 889 Set_Etype (R_Node, Standard_Wide_Wide_Character); 890 Set_Parent (R_Node, Standard_Wide_Wide_Character); 891 892 -- Create type definition node for type String 893 894 Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc); 895 896 declare 897 CompDef_Node : Node_Id; 898 begin 899 CompDef_Node := New_Node (N_Component_Definition, Stloc); 900 Set_Aliased_Present (CompDef_Node, False); 901 Set_Access_Definition (CompDef_Node, Empty); 902 Set_Subtype_Indication (CompDef_Node, Identifier_For (S_Character)); 903 Set_Component_Definition (Tdef_Node, CompDef_Node); 904 end; 905 906 Set_Subtype_Marks (Tdef_Node, New_List); 907 Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); 908 Set_Type_Definition (Parent (Standard_String), Tdef_Node); 909 910 Set_Ekind (Standard_String, E_Array_Type); 911 Set_Etype (Standard_String, Standard_String); 912 Set_Component_Type (Standard_String, Standard_Character); 913 Set_Component_Size (Standard_String, Uint_8); 914 Init_Size_Align (Standard_String); 915 Set_Alignment (Standard_String, Uint_1); 916 Pack_String_Type (Standard_String); 917 918 -- On targets where a storage unit is larger than a byte (such as AAMP), 919 -- pragma Pack has a real effect on the representation of type String, 920 -- and the type must be marked as having a nonstandard representation. 921 922 if System_Storage_Unit > Uint_8 then 923 Set_Has_Non_Standard_Rep (Standard_String); 924 Set_Has_Pragma_Pack (Standard_String); 925 end if; 926 927 -- Set index type of String 928 929 E_Id := 930 First (Subtype_Marks (Type_Definition (Parent (Standard_String)))); 931 Set_First_Index (Standard_String, E_Id); 932 Set_Entity (E_Id, Standard_Positive); 933 Set_Etype (E_Id, Standard_Positive); 934 935 -- Create type definition node for type Wide_String 936 937 Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc); 938 939 declare 940 CompDef_Node : Node_Id; 941 begin 942 CompDef_Node := New_Node (N_Component_Definition, Stloc); 943 Set_Aliased_Present (CompDef_Node, False); 944 Set_Access_Definition (CompDef_Node, Empty); 945 Set_Subtype_Indication (CompDef_Node, 946 Identifier_For (S_Wide_Character)); 947 Set_Component_Definition (Tdef_Node, CompDef_Node); 948 end; 949 950 Set_Subtype_Marks (Tdef_Node, New_List); 951 Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); 952 Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node); 953 954 Set_Ekind (Standard_Wide_String, E_Array_Type); 955 Set_Etype (Standard_Wide_String, Standard_Wide_String); 956 Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); 957 Set_Component_Size (Standard_Wide_String, Uint_16); 958 Init_Size_Align (Standard_Wide_String); 959 Pack_String_Type (Standard_Wide_String); 960 961 -- Set index type of Wide_String 962 963 E_Id := 964 First 965 (Subtype_Marks (Type_Definition (Parent (Standard_Wide_String)))); 966 Set_First_Index (Standard_Wide_String, E_Id); 967 Set_Entity (E_Id, Standard_Positive); 968 Set_Etype (E_Id, Standard_Positive); 969 970 -- Create type definition node for type Wide_Wide_String 971 972 Tdef_Node := New_Node (N_Unconstrained_Array_Definition, Stloc); 973 974 declare 975 CompDef_Node : Node_Id; 976 begin 977 CompDef_Node := New_Node (N_Component_Definition, Stloc); 978 Set_Aliased_Present (CompDef_Node, False); 979 Set_Access_Definition (CompDef_Node, Empty); 980 Set_Subtype_Indication (CompDef_Node, 981 Identifier_For (S_Wide_Wide_Character)); 982 Set_Component_Definition (Tdef_Node, CompDef_Node); 983 end; 984 985 Set_Subtype_Marks (Tdef_Node, New_List); 986 Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); 987 Set_Type_Definition (Parent (Standard_Wide_Wide_String), Tdef_Node); 988 989 Set_Ekind (Standard_Wide_Wide_String, E_Array_Type); 990 Set_Etype (Standard_Wide_Wide_String, 991 Standard_Wide_Wide_String); 992 Set_Component_Type (Standard_Wide_Wide_String, 993 Standard_Wide_Wide_Character); 994 Set_Component_Size (Standard_Wide_Wide_String, Uint_32); 995 Init_Size_Align (Standard_Wide_Wide_String); 996 Set_Is_Ada_2005_Only (Standard_Wide_Wide_String); 997 Pack_String_Type (Standard_Wide_Wide_String); 998 999 -- Set index type of Wide_Wide_String 1000 1001 E_Id := 1002 First 1003 (Subtype_Marks 1004 (Type_Definition (Parent (Standard_Wide_Wide_String)))); 1005 Set_First_Index (Standard_Wide_Wide_String, E_Id); 1006 Set_Entity (E_Id, Standard_Positive); 1007 Set_Etype (E_Id, Standard_Positive); 1008 1009 -- Setup entity for Natural 1010 1011 Set_Ekind (Standard_Natural, E_Signed_Integer_Subtype); 1012 Set_Etype (Standard_Natural, Base_Type (Standard_Integer)); 1013 Init_Esize (Standard_Natural, Standard_Integer_Size); 1014 Init_RM_Size (Standard_Natural, Standard_Integer_Size - 1); 1015 Set_Elem_Alignment (Standard_Natural); 1016 Set_Size_Known_At_Compile_Time 1017 (Standard_Natural); 1018 Set_Integer_Bounds (Standard_Natural, 1019 Typ => Base_Type (Standard_Integer), 1020 Lb => Uint_0, 1021 Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); 1022 Set_Is_Constrained (Standard_Natural); 1023 1024 -- Setup entity for Positive 1025 1026 Set_Ekind (Standard_Positive, E_Signed_Integer_Subtype); 1027 Set_Etype (Standard_Positive, Base_Type (Standard_Integer)); 1028 Init_Esize (Standard_Positive, Standard_Integer_Size); 1029 Init_RM_Size (Standard_Positive, Standard_Integer_Size - 1); 1030 Set_Elem_Alignment (Standard_Positive); 1031 1032 Set_Size_Known_At_Compile_Time (Standard_Positive); 1033 1034 Set_Integer_Bounds (Standard_Positive, 1035 Typ => Base_Type (Standard_Integer), 1036 Lb => Uint_1, 1037 Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); 1038 Set_Is_Constrained (Standard_Positive); 1039 1040 -- Create declaration for package ASCII 1041 1042 Decl := New_Node (N_Package_Declaration, Stloc); 1043 Append (Decl, Decl_S); 1044 1045 Pspec := New_Node (N_Package_Specification, Stloc); 1046 Set_Specification (Decl, Pspec); 1047 1048 Set_Defining_Unit_Name (Pspec, Standard_Entity (S_ASCII)); 1049 Set_Ekind (Standard_Entity (S_ASCII), E_Package); 1050 Set_Visible_Declarations (Pspec, Decl_A); 1051 1052 -- Create control character definitions in package ASCII. Note that 1053 -- the character literal entries created here correspond to literal 1054 -- values that are impossible in the source, but can be represented 1055 -- internally with no difficulties. 1056 1057 Ccode := 16#00#; 1058 1059 for S in S_ASCII_Names loop 1060 Decl := New_Node (N_Object_Declaration, Staloc); 1061 Set_Constant_Present (Decl, True); 1062 1063 declare 1064 A_Char : constant Entity_Id := Standard_Entity (S); 1065 Expr_Decl : Node_Id; 1066 1067 begin 1068 Set_Sloc (A_Char, Staloc); 1069 Set_Ekind (A_Char, E_Constant); 1070 Set_Never_Set_In_Source (A_Char, True); 1071 Set_Is_True_Constant (A_Char, True); 1072 Set_Etype (A_Char, Standard_Character); 1073 Set_Scope (A_Char, Standard_Entity (S_ASCII)); 1074 Set_Is_Immediately_Visible (A_Char, False); 1075 Set_Is_Public (A_Char, True); 1076 Set_Is_Known_Valid (A_Char, True); 1077 1078 Append_Entity (A_Char, Standard_Entity (S_ASCII)); 1079 Set_Defining_Identifier (Decl, A_Char); 1080 1081 Set_Object_Definition (Decl, Identifier_For (S_Character)); 1082 Expr_Decl := New_Node (N_Character_Literal, Staloc); 1083 Set_Expression (Decl, Expr_Decl); 1084 1085 Set_Is_Static_Expression (Expr_Decl); 1086 Set_Chars (Expr_Decl, No_Name); 1087 Set_Etype (Expr_Decl, Standard_Character); 1088 Set_Char_Literal_Value (Expr_Decl, UI_From_Int (Int (Ccode))); 1089 end; 1090 1091 Append (Decl, Decl_A); 1092 1093 -- Increment character code, dealing with non-contiguities 1094 1095 Ccode := Ccode + 1; 1096 1097 if Ccode = 16#20# then 1098 Ccode := 16#21#; 1099 elsif Ccode = 16#27# then 1100 Ccode := 16#3A#; 1101 elsif Ccode = 16#3C# then 1102 Ccode := 16#3F#; 1103 elsif Ccode = 16#41# then 1104 Ccode := 16#5B#; 1105 end if; 1106 end loop; 1107 1108 -- Create semantic phase entities 1109 1110 Standard_Void_Type := New_Standard_Entity; 1111 Set_Ekind (Standard_Void_Type, E_Void); 1112 Set_Etype (Standard_Void_Type, Standard_Void_Type); 1113 Set_Scope (Standard_Void_Type, Standard_Standard); 1114 Make_Name (Standard_Void_Type, "_void_type"); 1115 1116 -- The type field of packages is set to void 1117 1118 Set_Etype (Standard_Standard, Standard_Void_Type); 1119 Set_Etype (Standard_ASCII, Standard_Void_Type); 1120 1121 -- Standard_A_String is actually used in generated code, so it has a 1122 -- type name that is reasonable, but does not overlap any Ada name. 1123 1124 Standard_A_String := New_Standard_Entity; 1125 Set_Ekind (Standard_A_String, E_Access_Type); 1126 Set_Scope (Standard_A_String, Standard_Standard); 1127 Set_Etype (Standard_A_String, Standard_A_String); 1128 1129 if Debug_Flag_6 then 1130 Init_Size (Standard_A_String, System_Address_Size); 1131 else 1132 Init_Size (Standard_A_String, System_Address_Size * 2); 1133 end if; 1134 1135 Init_Alignment (Standard_A_String); 1136 1137 Set_Directly_Designated_Type 1138 (Standard_A_String, Standard_String); 1139 Make_Name (Standard_A_String, "access_string"); 1140 1141 Standard_A_Char := New_Standard_Entity; 1142 Set_Ekind (Standard_A_Char, E_Access_Type); 1143 Set_Scope (Standard_A_Char, Standard_Standard); 1144 Set_Etype (Standard_A_Char, Standard_A_String); 1145 Init_Size (Standard_A_Char, System_Address_Size); 1146 Set_Elem_Alignment (Standard_A_Char); 1147 1148 Set_Directly_Designated_Type (Standard_A_Char, Standard_Character); 1149 Make_Name (Standard_A_Char, "access_character"); 1150 1151 -- Standard_Debug_Renaming_Type is used for the special objects created 1152 -- to encode the names occurring in renaming declarations for use by the 1153 -- debugger (see exp_dbug.adb). The type is a zero-sized subtype of 1154 -- Standard.Integer. 1155 1156 Standard_Debug_Renaming_Type := New_Standard_Entity; 1157 1158 Set_Ekind (Standard_Debug_Renaming_Type, E_Signed_Integer_Subtype); 1159 Set_Scope (Standard_Debug_Renaming_Type, Standard_Standard); 1160 Set_Etype (Standard_Debug_Renaming_Type, Base_Type (Standard_Integer)); 1161 Init_Esize (Standard_Debug_Renaming_Type, 0); 1162 Init_RM_Size (Standard_Debug_Renaming_Type, 0); 1163 Set_Size_Known_At_Compile_Time (Standard_Debug_Renaming_Type); 1164 Set_Integer_Bounds (Standard_Debug_Renaming_Type, 1165 Typ => Base_Type (Standard_Debug_Renaming_Type), 1166 Lb => Uint_1, 1167 Hb => Uint_0); 1168 Set_Is_Constrained (Standard_Debug_Renaming_Type); 1169 Set_Has_Size_Clause (Standard_Debug_Renaming_Type); 1170 1171 Make_Name (Standard_Debug_Renaming_Type, "_renaming_type"); 1172 1173 -- Note on type names. The type names for the following special types 1174 -- are constructed so that they will look reasonable should they ever 1175 -- appear in error messages etc, although in practice the use of the 1176 -- special insertion character } for types results in special handling 1177 -- of these type names in any case. The blanks in these names would 1178 -- trouble in Gigi, but that's OK here, since none of these types 1179 -- should ever get through to Gigi. Attributes of these types are 1180 -- filled out to minimize problems with cascaded errors (for example, 1181 -- Any_Integer is given reasonable and consistent type and size values) 1182 1183 Any_Type := New_Standard_Entity ("any type"); 1184 Decl := New_Node (N_Full_Type_Declaration, Stloc); 1185 Set_Defining_Identifier (Decl, Any_Type); 1186 Set_Scope (Any_Type, Standard_Standard); 1187 Build_Signed_Integer_Type (Any_Type, Standard_Integer_Size); 1188 1189 Any_Id := New_Standard_Entity ("any id"); 1190 Set_Ekind (Any_Id, E_Variable); 1191 Set_Scope (Any_Id, Standard_Standard); 1192 Set_Etype (Any_Id, Any_Type); 1193 Init_Esize (Any_Id); 1194 Init_Alignment (Any_Id); 1195 1196 Any_Access := New_Standard_Entity ("an access type"); 1197 Set_Ekind (Any_Access, E_Access_Type); 1198 Set_Scope (Any_Access, Standard_Standard); 1199 Set_Etype (Any_Access, Any_Access); 1200 Init_Size (Any_Access, System_Address_Size); 1201 Set_Elem_Alignment (Any_Access); 1202 1203 Any_Character := New_Standard_Entity ("a character type"); 1204 Set_Ekind (Any_Character, E_Enumeration_Type); 1205 Set_Scope (Any_Character, Standard_Standard); 1206 Set_Etype (Any_Character, Any_Character); 1207 Set_Is_Unsigned_Type (Any_Character); 1208 Set_Is_Character_Type (Any_Character); 1209 Init_Esize (Any_Character, Standard_Character_Size); 1210 Init_RM_Size (Any_Character, 8); 1211 Set_Elem_Alignment (Any_Character); 1212 Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character)); 1213 1214 Any_Array := New_Standard_Entity ("an array type"); 1215 Set_Ekind (Any_Array, E_Array_Type); 1216 Set_Scope (Any_Array, Standard_Standard); 1217 Set_Etype (Any_Array, Any_Array); 1218 Set_Component_Type (Any_Array, Any_Character); 1219 Init_Size_Align (Any_Array); 1220 Make_Dummy_Index (Any_Array); 1221 1222 Any_Boolean := New_Standard_Entity ("a boolean type"); 1223 Set_Ekind (Any_Boolean, E_Enumeration_Type); 1224 Set_Scope (Any_Boolean, Standard_Standard); 1225 Set_Etype (Any_Boolean, Standard_Boolean); 1226 Init_Esize (Any_Boolean, Standard_Character_Size); 1227 Init_RM_Size (Any_Boolean, 1); 1228 Set_Elem_Alignment (Any_Boolean); 1229 Set_Is_Unsigned_Type (Any_Boolean); 1230 Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean)); 1231 1232 Any_Composite := New_Standard_Entity ("a composite type"); 1233 Set_Ekind (Any_Composite, E_Array_Type); 1234 Set_Scope (Any_Composite, Standard_Standard); 1235 Set_Etype (Any_Composite, Any_Composite); 1236 Set_Component_Size (Any_Composite, Uint_0); 1237 Set_Component_Type (Any_Composite, Standard_Integer); 1238 Init_Size_Align (Any_Composite); 1239 1240 Any_Discrete := New_Standard_Entity ("a discrete type"); 1241 Set_Ekind (Any_Discrete, E_Signed_Integer_Type); 1242 Set_Scope (Any_Discrete, Standard_Standard); 1243 Set_Etype (Any_Discrete, Any_Discrete); 1244 Init_Size (Any_Discrete, Standard_Integer_Size); 1245 Set_Elem_Alignment (Any_Discrete); 1246 1247 Any_Fixed := New_Standard_Entity ("a fixed-point type"); 1248 Set_Ekind (Any_Fixed, E_Ordinary_Fixed_Point_Type); 1249 Set_Scope (Any_Fixed, Standard_Standard); 1250 Set_Etype (Any_Fixed, Any_Fixed); 1251 Init_Size (Any_Fixed, Standard_Integer_Size); 1252 Set_Elem_Alignment (Any_Fixed); 1253 1254 Any_Integer := New_Standard_Entity ("an integer type"); 1255 Set_Ekind (Any_Integer, E_Signed_Integer_Type); 1256 Set_Scope (Any_Integer, Standard_Standard); 1257 Set_Etype (Any_Integer, Standard_Long_Long_Integer); 1258 Init_Size (Any_Integer, Standard_Long_Long_Integer_Size); 1259 Set_Elem_Alignment (Any_Integer); 1260 1261 Set_Integer_Bounds 1262 (Any_Integer, 1263 Typ => Base_Type (Standard_Integer), 1264 Lb => Uint_0, 1265 Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); 1266 1267 Any_Modular := New_Standard_Entity ("a modular type"); 1268 Set_Ekind (Any_Modular, E_Modular_Integer_Type); 1269 Set_Scope (Any_Modular, Standard_Standard); 1270 Set_Etype (Any_Modular, Standard_Long_Long_Integer); 1271 Init_Size (Any_Modular, Standard_Long_Long_Integer_Size); 1272 Set_Elem_Alignment (Any_Modular); 1273 Set_Is_Unsigned_Type (Any_Modular); 1274 1275 Any_Numeric := New_Standard_Entity ("a numeric type"); 1276 Set_Ekind (Any_Numeric, E_Signed_Integer_Type); 1277 Set_Scope (Any_Numeric, Standard_Standard); 1278 Set_Etype (Any_Numeric, Standard_Long_Long_Integer); 1279 Init_Size (Any_Numeric, Standard_Long_Long_Integer_Size); 1280 Set_Elem_Alignment (Any_Numeric); 1281 1282 Any_Real := New_Standard_Entity ("a real type"); 1283 Set_Ekind (Any_Real, E_Floating_Point_Type); 1284 Set_Scope (Any_Real, Standard_Standard); 1285 Set_Etype (Any_Real, Standard_Long_Long_Float); 1286 Init_Size (Any_Real, 1287 UI_To_Int (Esize (Standard_Long_Long_Float))); 1288 Set_Elem_Alignment (Any_Real); 1289 1290 Any_Scalar := New_Standard_Entity ("a scalar type"); 1291 Set_Ekind (Any_Scalar, E_Signed_Integer_Type); 1292 Set_Scope (Any_Scalar, Standard_Standard); 1293 Set_Etype (Any_Scalar, Any_Scalar); 1294 Init_Size (Any_Scalar, Standard_Integer_Size); 1295 Set_Elem_Alignment (Any_Scalar); 1296 1297 Any_String := New_Standard_Entity ("a string type"); 1298 Set_Ekind (Any_String, E_Array_Type); 1299 Set_Scope (Any_String, Standard_Standard); 1300 Set_Etype (Any_String, Any_String); 1301 Set_Component_Type (Any_String, Any_Character); 1302 Init_Size_Align (Any_String); 1303 Make_Dummy_Index (Any_String); 1304 1305 Raise_Type := New_Standard_Entity ("raise type"); 1306 Decl := New_Node (N_Full_Type_Declaration, Stloc); 1307 Set_Defining_Identifier (Decl, Raise_Type); 1308 Set_Scope (Raise_Type, Standard_Standard); 1309 Build_Signed_Integer_Type (Raise_Type, Standard_Integer_Size); 1310 1311 Standard_Integer_8 := New_Standard_Entity ("integer_8"); 1312 Decl := New_Node (N_Full_Type_Declaration, Stloc); 1313 Set_Defining_Identifier (Decl, Standard_Integer_8); 1314 Set_Scope (Standard_Integer_8, Standard_Standard); 1315 Build_Signed_Integer_Type (Standard_Integer_8, 8); 1316 1317 Standard_Integer_16 := New_Standard_Entity ("integer_16"); 1318 Decl := New_Node (N_Full_Type_Declaration, Stloc); 1319 Set_Defining_Identifier (Decl, Standard_Integer_16); 1320 Set_Scope (Standard_Integer_16, Standard_Standard); 1321 Build_Signed_Integer_Type (Standard_Integer_16, 16); 1322 1323 Standard_Integer_32 := New_Standard_Entity ("integer_32"); 1324 Decl := New_Node (N_Full_Type_Declaration, Stloc); 1325 Set_Defining_Identifier (Decl, Standard_Integer_32); 1326 Set_Scope (Standard_Integer_32, Standard_Standard); 1327 Build_Signed_Integer_Type (Standard_Integer_32, 32); 1328 1329 Standard_Integer_64 := New_Standard_Entity ("integer_64"); 1330 Decl := New_Node (N_Full_Type_Declaration, Stloc); 1331 Set_Defining_Identifier (Decl, Standard_Integer_64); 1332 Set_Scope (Standard_Integer_64, Standard_Standard); 1333 Build_Signed_Integer_Type (Standard_Integer_64, 64); 1334 1335 -- Standard_*_Unsigned subtypes are not user visible, but they are 1336 -- used internally. They are unsigned types with the same length as 1337 -- the correspondingly named signed integer types. 1338 1339 Standard_Short_Short_Unsigned := New_Standard_Entity; 1340 Build_Unsigned_Integer_Type 1341 (Standard_Short_Short_Unsigned, 1342 Standard_Short_Short_Integer_Size, 1343 "short_short_unsigned"); 1344 1345 Standard_Short_Unsigned := New_Standard_Entity; 1346 Build_Unsigned_Integer_Type 1347 (Standard_Short_Unsigned, 1348 Standard_Short_Integer_Size, 1349 "short_unsigned"); 1350 1351 Standard_Unsigned := New_Standard_Entity; 1352 Build_Unsigned_Integer_Type 1353 (Standard_Unsigned, 1354 Standard_Integer_Size, 1355 "unsigned"); 1356 1357 Standard_Long_Unsigned := New_Standard_Entity; 1358 Build_Unsigned_Integer_Type 1359 (Standard_Long_Unsigned, 1360 Standard_Long_Integer_Size, 1361 "long_unsigned"); 1362 1363 Standard_Long_Long_Unsigned := New_Standard_Entity; 1364 Build_Unsigned_Integer_Type 1365 (Standard_Long_Long_Unsigned, 1366 Standard_Long_Long_Integer_Size, 1367 "long_long_unsigned"); 1368 1369 -- Standard_Unsigned_64 is not user visible, but is used internally. It 1370 -- is an unsigned type mod 2**64, 64-bits unsigned, size is 64. 1371 1372 Standard_Unsigned_64 := New_Standard_Entity; 1373 Build_Unsigned_Integer_Type (Standard_Unsigned_64, 64, "unsigned_64"); 1374 1375 -- Note: universal integer and universal real are constructed as fully 1376 -- formed signed numeric types, with parameters corresponding to the 1377 -- longest runtime types (Long_Long_Integer and Long_Long_Float). This 1378 -- allows Gigi to properly process references to universal types that 1379 -- are not folded at compile time. 1380 1381 Universal_Integer := New_Standard_Entity; 1382 Decl := New_Node (N_Full_Type_Declaration, Stloc); 1383 Set_Defining_Identifier (Decl, Universal_Integer); 1384 Make_Name (Universal_Integer, "universal_integer"); 1385 Set_Scope (Universal_Integer, Standard_Standard); 1386 Build_Signed_Integer_Type 1387 (Universal_Integer, Standard_Long_Long_Integer_Size); 1388 1389 Universal_Real := New_Standard_Entity; 1390 Decl := New_Node (N_Full_Type_Declaration, Stloc); 1391 Set_Defining_Identifier (Decl, Universal_Real); 1392 Make_Name (Universal_Real, "universal_real"); 1393 Set_Scope (Universal_Real, Standard_Standard); 1394 Copy_Float_Type (Universal_Real, Standard_Long_Long_Float); 1395 1396 -- Note: universal fixed, unlike universal integer and universal real, 1397 -- is never used at runtime, so it does not need to have bounds set. 1398 1399 Universal_Fixed := New_Standard_Entity; 1400 Decl := New_Node (N_Full_Type_Declaration, Stloc); 1401 Set_Defining_Identifier (Decl, Universal_Fixed); 1402 Make_Name (Universal_Fixed, "universal_fixed"); 1403 Set_Ekind (Universal_Fixed, E_Ordinary_Fixed_Point_Type); 1404 Set_Etype (Universal_Fixed, Universal_Fixed); 1405 Set_Scope (Universal_Fixed, Standard_Standard); 1406 Init_Size (Universal_Fixed, Standard_Long_Long_Integer_Size); 1407 Set_Elem_Alignment (Universal_Fixed); 1408 Set_Size_Known_At_Compile_Time 1409 (Universal_Fixed); 1410 1411 -- Create type declaration for Duration, using a 64-bit size. The 1412 -- delta and size values depend on the mode set in system.ads. 1413 1414 Build_Duration : declare 1415 Dlo : Uint; 1416 Dhi : Uint; 1417 Delta_Val : Ureal; 1418 1419 begin 1420 -- In 32 bit mode, the size is 32 bits, and the delta and 1421 -- small values are set to 20 milliseconds (20.0*(10.0**(-3)). 1422 1423 if Duration_32_Bits_On_Target then 1424 Dlo := Intval (Type_Low_Bound (Standard_Integer_32)); 1425 Dhi := Intval (Type_High_Bound (Standard_Integer_32)); 1426 Delta_Val := UR_From_Components (UI_From_Int (20), Uint_3, 10); 1427 1428 -- In 64-bit mode, the size is 64-bits and the delta and 1429 -- small values are set to nanoseconds (1.0*(10.0**(-9)). 1430 1431 else 1432 Dlo := Intval (Type_Low_Bound (Standard_Integer_64)); 1433 Dhi := Intval (Type_High_Bound (Standard_Integer_64)); 1434 Delta_Val := UR_From_Components (Uint_1, Uint_9, 10); 1435 end if; 1436 1437 Tdef_Node := Make_Ordinary_Fixed_Point_Definition (Stloc, 1438 Delta_Expression => Make_Real_Literal (Stloc, Delta_Val), 1439 Real_Range_Specification => 1440 Make_Real_Range_Specification (Stloc, 1441 Low_Bound => Make_Real_Literal (Stloc, 1442 Realval => Dlo * Delta_Val), 1443 High_Bound => Make_Real_Literal (Stloc, 1444 Realval => Dhi * Delta_Val))); 1445 1446 Set_Type_Definition (Parent (Standard_Duration), Tdef_Node); 1447 1448 Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type); 1449 Set_Etype (Standard_Duration, Standard_Duration); 1450 1451 if Duration_32_Bits_On_Target then 1452 Init_Size (Standard_Duration, 32); 1453 else 1454 Init_Size (Standard_Duration, 64); 1455 end if; 1456 1457 Set_Elem_Alignment (Standard_Duration); 1458 Set_Delta_Value (Standard_Duration, Delta_Val); 1459 Set_Small_Value (Standard_Duration, Delta_Val); 1460 Set_Scalar_Range (Standard_Duration, 1461 Real_Range_Specification 1462 (Type_Definition (Parent (Standard_Duration)))); 1463 1464 -- Normally it does not matter that nodes in package Standard are 1465 -- not marked as analyzed. The Scalar_Range of the fixed-point type 1466 -- Standard_Duration is an exception, because of the special test 1467 -- made in Freeze.Freeze_Fixed_Point_Type. 1468 1469 Set_Analyzed (Scalar_Range (Standard_Duration)); 1470 1471 Set_Etype (Type_High_Bound (Standard_Duration), Standard_Duration); 1472 Set_Etype (Type_Low_Bound (Standard_Duration), Standard_Duration); 1473 1474 Set_Is_Static_Expression (Type_High_Bound (Standard_Duration)); 1475 Set_Is_Static_Expression (Type_Low_Bound (Standard_Duration)); 1476 1477 Set_Corresponding_Integer_Value 1478 (Type_High_Bound (Standard_Duration), Dhi); 1479 1480 Set_Corresponding_Integer_Value 1481 (Type_Low_Bound (Standard_Duration), Dlo); 1482 1483 Set_Size_Known_At_Compile_Time (Standard_Duration); 1484 end Build_Duration; 1485 1486 -- Build standard exception type. Note that the type name here is 1487 -- actually used in the generated code, so it must be set correctly. 1488 -- The type Standard_Exception_Type must be consistent with the type 1489 -- System.Standard_Library.Exception_Data, as the latter is what is 1490 -- known by the run-time. Components of the record are documented in 1491 -- the declaration in System.Standard_Library. 1492 1493 Standard_Exception_Type := New_Standard_Entity; 1494 Set_Ekind (Standard_Exception_Type, E_Record_Type); 1495 Set_Etype (Standard_Exception_Type, Standard_Exception_Type); 1496 Set_Scope (Standard_Exception_Type, Standard_Standard); 1497 Set_Stored_Constraint 1498 (Standard_Exception_Type, No_Elist); 1499 Init_Size_Align (Standard_Exception_Type); 1500 Set_Size_Known_At_Compile_Time 1501 (Standard_Exception_Type, True); 1502 Make_Name (Standard_Exception_Type, "exception"); 1503 1504 Make_Component 1505 (Standard_Exception_Type, Standard_Boolean, "Not_Handled_By_Others"); 1506 Make_Component 1507 (Standard_Exception_Type, Standard_Character, "Lang"); 1508 Make_Component 1509 (Standard_Exception_Type, Standard_Natural, "Name_Length"); 1510 Make_Component 1511 (Standard_Exception_Type, Standard_A_Char, "Full_Name"); 1512 Make_Component 1513 (Standard_Exception_Type, Standard_A_Char, "HTable_Ptr"); 1514 Make_Component 1515 (Standard_Exception_Type, Standard_A_Char, "Foreign_Data"); 1516 Make_Component 1517 (Standard_Exception_Type, Standard_A_Char, "Raise_Hook"); 1518 1519 -- Build tree for record declaration, for use by the back-end 1520 1521 declare 1522 Comp_List : List_Id; 1523 Comp : Entity_Id; 1524 1525 begin 1526 Comp := First_Entity (Standard_Exception_Type); 1527 Comp_List := New_List; 1528 while Present (Comp) loop 1529 Append ( 1530 Make_Component_Declaration (Stloc, 1531 Defining_Identifier => Comp, 1532 Component_Definition => 1533 Make_Component_Definition (Stloc, 1534 Aliased_Present => False, 1535 Subtype_Indication => New_Occurrence_Of (Etype (Comp), 1536 Stloc))), 1537 Comp_List); 1538 1539 Next_Entity (Comp); 1540 end loop; 1541 1542 Decl := Make_Full_Type_Declaration (Stloc, 1543 Defining_Identifier => Standard_Exception_Type, 1544 Type_Definition => 1545 Make_Record_Definition (Stloc, 1546 End_Label => Empty, 1547 Component_List => 1548 Make_Component_List (Stloc, 1549 Component_Items => Comp_List))); 1550 end; 1551 1552 Append (Decl, Decl_S); 1553 1554 Layout_Type (Standard_Exception_Type); 1555 1556 -- Create declarations of standard exceptions 1557 1558 Build_Exception (S_Constraint_Error); 1559 Build_Exception (S_Program_Error); 1560 Build_Exception (S_Storage_Error); 1561 Build_Exception (S_Tasking_Error); 1562 1563 -- Numeric_Error is a normal exception in Ada 83, but in Ada 95 1564 -- it is a renaming of Constraint_Error. Is this test too early??? 1565 1566 if Ada_Version = Ada_83 then 1567 Build_Exception (S_Numeric_Error); 1568 1569 else 1570 Decl := New_Node (N_Exception_Renaming_Declaration, Stloc); 1571 E_Id := Standard_Entity (S_Numeric_Error); 1572 1573 Set_Ekind (E_Id, E_Exception); 1574 Set_Etype (E_Id, Standard_Exception_Type); 1575 Set_Is_Public (E_Id); 1576 Set_Renamed_Entity (E_Id, Standard_Entity (S_Constraint_Error)); 1577 1578 Set_Defining_Identifier (Decl, E_Id); 1579 Append (Decl, Decl_S); 1580 1581 Ident_Node := New_Node (N_Identifier, Stloc); 1582 Set_Chars (Ident_Node, Chars (Standard_Entity (S_Constraint_Error))); 1583 Set_Entity (Ident_Node, Standard_Entity (S_Constraint_Error)); 1584 Set_Name (Decl, Ident_Node); 1585 end if; 1586 1587 -- Abort_Signal is an entity that does not get made visible 1588 1589 Abort_Signal := New_Standard_Entity; 1590 Set_Chars (Abort_Signal, Name_uAbort_Signal); 1591 Set_Ekind (Abort_Signal, E_Exception); 1592 Set_Etype (Abort_Signal, Standard_Exception_Type); 1593 Set_Scope (Abort_Signal, Standard_Standard); 1594 Set_Is_Public (Abort_Signal, True); 1595 Decl := 1596 Make_Exception_Declaration (Stloc, 1597 Defining_Identifier => Abort_Signal); 1598 1599 -- Create defining identifiers for shift operator entities. Note 1600 -- that these entities are used only for marking shift operators 1601 -- generated internally, and hence need no structure, just a name 1602 -- and a unique identity. 1603 1604 Standard_Op_Rotate_Left := New_Standard_Entity; 1605 Set_Chars (Standard_Op_Rotate_Left, Name_Rotate_Left); 1606 Set_Ekind (Standard_Op_Rotate_Left, E_Operator); 1607 1608 Standard_Op_Rotate_Right := New_Standard_Entity; 1609 Set_Chars (Standard_Op_Rotate_Right, Name_Rotate_Right); 1610 Set_Ekind (Standard_Op_Rotate_Right, E_Operator); 1611 1612 Standard_Op_Shift_Left := New_Standard_Entity; 1613 Set_Chars (Standard_Op_Shift_Left, Name_Shift_Left); 1614 Set_Ekind (Standard_Op_Shift_Left, E_Operator); 1615 1616 Standard_Op_Shift_Right := New_Standard_Entity; 1617 Set_Chars (Standard_Op_Shift_Right, Name_Shift_Right); 1618 Set_Ekind (Standard_Op_Shift_Right, E_Operator); 1619 1620 Standard_Op_Shift_Right_Arithmetic := New_Standard_Entity; 1621 Set_Chars (Standard_Op_Shift_Right_Arithmetic, 1622 Name_Shift_Right_Arithmetic); 1623 Set_Ekind (Standard_Op_Shift_Right_Arithmetic, 1624 E_Operator); 1625 1626 -- Create standard operator declarations 1627 1628 Create_Operators; 1629 1630 -- Initialize visibility table with entities in Standard 1631 1632 for E in Standard_Entity_Type loop 1633 if Ekind (Standard_Entity (E)) /= E_Operator then 1634 Set_Name_Entity_Id 1635 (Chars (Standard_Entity (E)), Standard_Entity (E)); 1636 Set_Homonym (Standard_Entity (E), Empty); 1637 end if; 1638 1639 if E not in S_ASCII_Names then 1640 Set_Scope (Standard_Entity (E), Standard_Standard); 1641 Set_Is_Immediately_Visible (Standard_Entity (E)); 1642 end if; 1643 end loop; 1644 1645 -- The predefined package Standard itself does not have a scope; 1646 -- it is the only entity in the system not to have one, and this 1647 -- is what identifies the package to Gigi. 1648 1649 Set_Scope (Standard_Standard, Empty); 1650 1651 -- Set global variables indicating last Id values and version 1652 1653 Last_Standard_Node_Id := Last_Node_Id; 1654 Last_Standard_List_Id := Last_List_Id; 1655 1656 -- The Error node has an Etype of Any_Type to help error recovery 1657 1658 Set_Etype (Error, Any_Type); 1659 1660 -- Print representation of standard if switch set 1661 1662 if Opt.Print_Standard then 1663 Print_Standard; 1664 end if; 1665 end Create_Standard; 1666 1667 ------------------------------------ 1668 -- Create_Unconstrained_Base_Type -- 1669 ------------------------------------ 1670 1671 procedure Create_Unconstrained_Base_Type 1672 (E : Entity_Id; 1673 K : Entity_Kind) 1674 is 1675 New_Ent : constant Entity_Id := New_Copy (E); 1676 1677 begin 1678 Set_Ekind (E, K); 1679 Set_Is_Constrained (E, True); 1680 Set_Is_First_Subtype (E, True); 1681 Set_Etype (E, New_Ent); 1682 1683 Append_Entity (New_Ent, Standard_Standard); 1684 Set_Is_Constrained (New_Ent, False); 1685 Set_Etype (New_Ent, New_Ent); 1686 Set_Is_Known_Valid (New_Ent, True); 1687 1688 if K = E_Signed_Integer_Subtype then 1689 Set_Etype (Low_Bound (Scalar_Range (E)), New_Ent); 1690 Set_Etype (High_Bound (Scalar_Range (E)), New_Ent); 1691 end if; 1692 1693 end Create_Unconstrained_Base_Type; 1694 1695 -------------------- 1696 -- Identifier_For -- 1697 -------------------- 1698 1699 function Identifier_For (S : Standard_Entity_Type) return Node_Id is 1700 Ident_Node : Node_Id; 1701 begin 1702 Ident_Node := New_Node (N_Identifier, Stloc); 1703 Set_Chars (Ident_Node, Chars (Standard_Entity (S))); 1704 Set_Entity (Ident_Node, Standard_Entity (S)); 1705 return Ident_Node; 1706 end Identifier_For; 1707 1708 -------------------- 1709 -- Make_Component -- 1710 -------------------- 1711 1712 procedure Make_Component 1713 (Rec : Entity_Id; 1714 Typ : Entity_Id; 1715 Nam : String) 1716 is 1717 Id : constant Entity_Id := New_Standard_Entity; 1718 1719 begin 1720 Set_Ekind (Id, E_Component); 1721 Set_Etype (Id, Typ); 1722 Set_Scope (Id, Rec); 1723 Init_Component_Location (Id); 1724 1725 Set_Original_Record_Component (Id, Id); 1726 Make_Name (Id, Nam); 1727 Append_Entity (Id, Rec); 1728 end Make_Component; 1729 1730 ----------------- 1731 -- Make_Formal -- 1732 ----------------- 1733 1734 function Make_Formal 1735 (Typ : Entity_Id; 1736 Formal_Name : String) return Entity_Id 1737 is 1738 Formal : Entity_Id; 1739 1740 begin 1741 Formal := New_Standard_Entity; 1742 1743 Set_Ekind (Formal, E_In_Parameter); 1744 Set_Mechanism (Formal, Default_Mechanism); 1745 Set_Scope (Formal, Standard_Standard); 1746 Set_Etype (Formal, Typ); 1747 Make_Name (Formal, Formal_Name); 1748 1749 return Formal; 1750 end Make_Formal; 1751 1752 ------------------ 1753 -- Make_Integer -- 1754 ------------------ 1755 1756 function Make_Integer (V : Uint) return Node_Id is 1757 N : constant Node_Id := Make_Integer_Literal (Stloc, V); 1758 begin 1759 Set_Is_Static_Expression (N); 1760 return N; 1761 end Make_Integer; 1762 1763 --------------- 1764 -- Make_Name -- 1765 --------------- 1766 1767 procedure Make_Name (Id : Entity_Id; Nam : String) is 1768 begin 1769 for J in 1 .. Nam'Length loop 1770 Name_Buffer (J) := Fold_Lower (Nam (Nam'First + (J - 1))); 1771 end loop; 1772 1773 Name_Len := Nam'Length; 1774 Set_Chars (Id, Name_Find); 1775 end Make_Name; 1776 1777 ------------------ 1778 -- New_Operator -- 1779 ------------------ 1780 1781 function New_Operator (Op : Name_Id; Typ : Entity_Id) return Entity_Id is 1782 Ident_Node : Entity_Id; 1783 1784 begin 1785 Ident_Node := Make_Defining_Identifier (Stloc, Op); 1786 1787 Set_Is_Pure (Ident_Node, True); 1788 Set_Ekind (Ident_Node, E_Operator); 1789 Set_Etype (Ident_Node, Typ); 1790 Set_Scope (Ident_Node, Standard_Standard); 1791 Set_Homonym (Ident_Node, Get_Name_Entity_Id (Op)); 1792 Set_Convention (Ident_Node, Convention_Intrinsic); 1793 1794 Set_Is_Immediately_Visible (Ident_Node, True); 1795 Set_Is_Intrinsic_Subprogram (Ident_Node, True); 1796 1797 Set_Name_Entity_Id (Op, Ident_Node); 1798 Append_Entity (Ident_Node, Standard_Standard); 1799 return Ident_Node; 1800 end New_Operator; 1801 1802 ------------------------- 1803 -- New_Standard_Entity -- 1804 ------------------------- 1805 1806 function New_Standard_Entity 1807 (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id 1808 is 1809 E : constant Entity_Id := New_Entity (New_Node_Kind, Stloc); 1810 1811 begin 1812 -- All standard entities are Pure and Public 1813 1814 Set_Is_Pure (E); 1815 Set_Is_Public (E); 1816 1817 -- All standard entity names are analyzed manually, and are thus 1818 -- frozen as soon as they are created. 1819 1820 Set_Is_Frozen (E); 1821 1822 -- Set debug information required for all standard types 1823 1824 Set_Needs_Debug_Info (E); 1825 1826 -- All standard entities are built with fully qualified names, so 1827 -- set the flag to prevent an abortive attempt at requalification. 1828 1829 Set_Has_Qualified_Name (E); 1830 1831 -- Return newly created entity to be completed by caller 1832 1833 return E; 1834 end New_Standard_Entity; 1835 1836 function New_Standard_Entity (S : String) return Entity_Id is 1837 Ent : constant Entity_Id := New_Standard_Entity; 1838 begin 1839 Make_Name (Ent, S); 1840 return Ent; 1841 end New_Standard_Entity; 1842 1843 -------------------- 1844 -- Print_Standard -- 1845 -------------------- 1846 1847 procedure Print_Standard is 1848 1849 procedure P (Item : String) renames Output.Write_Line; 1850 -- Short-hand, since we do a lot of line writes here 1851 1852 procedure P_Int_Range (Size : Pos); 1853 -- Prints the range of an integer based on its Size 1854 1855 procedure P_Float_Range (Id : Entity_Id); 1856 -- Prints the bounds range for the given float type entity 1857 1858 procedure P_Float_Type (Id : Entity_Id); 1859 -- Prints the type declaration of the given float type entity 1860 1861 procedure P_Mixed_Name (Id : Name_Id); 1862 -- Prints Id in mixed case 1863 1864 ------------------- 1865 -- P_Float_Range -- 1866 ------------------- 1867 1868 procedure P_Float_Range (Id : Entity_Id) is 1869 begin 1870 Write_Str (" range "); 1871 UR_Write (Realval (Type_Low_Bound (Id))); 1872 Write_Str (" .. "); 1873 UR_Write (Realval (Type_High_Bound (Id))); 1874 Write_Str (";"); 1875 Write_Eol; 1876 end P_Float_Range; 1877 1878 ------------------ 1879 -- P_Float_Type -- 1880 ------------------ 1881 1882 procedure P_Float_Type (Id : Entity_Id) is 1883 begin 1884 Write_Str (" type "); 1885 P_Mixed_Name (Chars (Id)); 1886 Write_Str (" is digits "); 1887 Write_Int (UI_To_Int (Digits_Value (Id))); 1888 Write_Eol; 1889 P_Float_Range (Id); 1890 Write_Str (" for "); 1891 P_Mixed_Name (Chars (Id)); 1892 Write_Str ("'Size use "); 1893 Write_Int (UI_To_Int (RM_Size (Id))); 1894 Write_Line (";"); 1895 Write_Eol; 1896 end P_Float_Type; 1897 1898 ----------------- 1899 -- P_Int_Range -- 1900 ----------------- 1901 1902 procedure P_Int_Range (Size : Pos) is 1903 begin 1904 Write_Str (" is range -(2 **"); 1905 Write_Int (Size - 1); 1906 Write_Str (")"); 1907 Write_Str (" .. +(2 **"); 1908 Write_Int (Size - 1); 1909 Write_Str (" - 1);"); 1910 Write_Eol; 1911 end P_Int_Range; 1912 1913 ------------------ 1914 -- P_Mixed_Name -- 1915 ------------------ 1916 1917 procedure P_Mixed_Name (Id : Name_Id) is 1918 begin 1919 Get_Name_String (Id); 1920 1921 for J in 1 .. Name_Len loop 1922 if J = 1 or else Name_Buffer (J - 1) = '_' then 1923 Name_Buffer (J) := Fold_Upper (Name_Buffer (J)); 1924 end if; 1925 end loop; 1926 1927 Write_Str (Name_Buffer (1 .. Name_Len)); 1928 end P_Mixed_Name; 1929 1930 -- Start of processing for Print_Standard 1931 1932 begin 1933 P ("-- Representation of package Standard"); 1934 Write_Eol; 1935 P ("-- This is not accurate Ada, since new base types cannot be "); 1936 P ("-- created, but the listing shows the target dependent"); 1937 P ("-- characteristics of the Standard types for this compiler"); 1938 Write_Eol; 1939 1940 P ("package Standard is"); 1941 P ("pragma Pure (Standard);"); 1942 Write_Eol; 1943 1944 P (" type Boolean is (False, True);"); 1945 P (" for Boolean'Size use 1;"); 1946 P (" for Boolean use (False => 0, True => 1);"); 1947 Write_Eol; 1948 1949 -- Integer types 1950 1951 Write_Str (" type Integer"); 1952 P_Int_Range (Standard_Integer_Size); 1953 Write_Str (" for Integer'Size use "); 1954 Write_Int (Standard_Integer_Size); 1955 P (";"); 1956 Write_Eol; 1957 1958 P (" subtype Natural is Integer range 0 .. Integer'Last;"); 1959 P (" subtype Positive is Integer range 1 .. Integer'Last;"); 1960 Write_Eol; 1961 1962 Write_Str (" type Short_Short_Integer"); 1963 P_Int_Range (Standard_Short_Short_Integer_Size); 1964 Write_Str (" for Short_Short_Integer'Size use "); 1965 Write_Int (Standard_Short_Short_Integer_Size); 1966 P (";"); 1967 Write_Eol; 1968 1969 Write_Str (" type Short_Integer"); 1970 P_Int_Range (Standard_Short_Integer_Size); 1971 Write_Str (" for Short_Integer'Size use "); 1972 Write_Int (Standard_Short_Integer_Size); 1973 P (";"); 1974 Write_Eol; 1975 1976 Write_Str (" type Long_Integer"); 1977 P_Int_Range (Standard_Long_Integer_Size); 1978 Write_Str (" for Long_Integer'Size use "); 1979 Write_Int (Standard_Long_Integer_Size); 1980 P (";"); 1981 Write_Eol; 1982 1983 Write_Str (" type Long_Long_Integer"); 1984 P_Int_Range (Standard_Long_Long_Integer_Size); 1985 Write_Str (" for Long_Long_Integer'Size use "); 1986 Write_Int (Standard_Long_Long_Integer_Size); 1987 P (";"); 1988 Write_Eol; 1989 1990 -- Floating point types 1991 1992 P_Float_Type (Standard_Short_Float); 1993 P_Float_Type (Standard_Float); 1994 P_Float_Type (Standard_Long_Float); 1995 P_Float_Type (Standard_Long_Long_Float); 1996 1997 P (" type Character is (...)"); 1998 Write_Str (" for Character'Size use "); 1999 Write_Int (Standard_Character_Size); 2000 P (";"); 2001 P (" -- See RM A.1(35) for details of this type"); 2002 Write_Eol; 2003 2004 P (" type Wide_Character is (...)"); 2005 Write_Str (" for Wide_Character'Size use "); 2006 Write_Int (Standard_Wide_Character_Size); 2007 P (";"); 2008 P (" -- See RM A.1(36) for details of this type"); 2009 Write_Eol; 2010 2011 P (" type Wide_Wide_Character is (...)"); 2012 Write_Str (" for Wide_Wide_Character'Size use "); 2013 Write_Int (Standard_Wide_Wide_Character_Size); 2014 P (";"); 2015 P (" -- See RM A.1(36) for details of this type"); 2016 2017 P (" type String is array (Positive range <>) of Character;"); 2018 P (" pragma Pack (String);"); 2019 Write_Eol; 2020 2021 P (" type Wide_String is array (Positive range <>)" & 2022 " of Wide_Character;"); 2023 P (" pragma Pack (Wide_String);"); 2024 Write_Eol; 2025 2026 P (" type Wide_Wide_String is array (Positive range <>)" & 2027 " of Wide_Wide_Character;"); 2028 P (" pragma Pack (Wide_Wide_String);"); 2029 Write_Eol; 2030 2031 -- We only have one representation each for 32-bit and 64-bit sizes, 2032 -- so select the right one based on Duration_32_Bits_On_Target. 2033 2034 if Duration_32_Bits_On_Target then 2035 P (" type Duration is delta 0.020"); 2036 P (" range -((2 ** 31) * 0.020) .."); 2037 P (" +((2 ** 31 - 1) * 0.020);"); 2038 P (" for Duration'Small use 0.020;"); 2039 2040 else 2041 P (" type Duration is delta 0.000000001"); 2042 P (" range -((2 ** 63) * 0.000000001) .."); 2043 P (" +((2 ** 63 - 1) * 0.000000001);"); 2044 P (" for Duration'Small use 0.000000001;"); 2045 end if; 2046 2047 Write_Eol; 2048 2049 P (" Constraint_Error : exception;"); 2050 P (" Program_Error : exception;"); 2051 P (" Storage_Error : exception;"); 2052 P (" Tasking_Error : exception;"); 2053 P (" Numeric_Error : exception renames Constraint_Error;"); 2054 Write_Eol; 2055 2056 P ("end Standard;"); 2057 end Print_Standard; 2058 2059 ------------------------- 2060 -- Register_Float_Type -- 2061 ------------------------- 2062 2063 procedure Register_Float_Type 2064 (Name : String; 2065 Digs : Positive; 2066 Float_Rep : Float_Rep_Kind; 2067 Precision : Positive; 2068 Size : Positive; 2069 Alignment : Natural) 2070 is 2071 Ent : constant Entity_Id := New_Standard_Entity; 2072 2073 begin 2074 Set_Defining_Identifier (New_Node (N_Full_Type_Declaration, Stloc), Ent); 2075 Make_Name (Ent, Name); 2076 Set_Scope (Ent, Standard_Standard); 2077 Build_Float_Type (Ent, Int (Size), Float_Rep, Pos (Digs)); 2078 Set_RM_Size (Ent, UI_From_Int (Int (Precision))); 2079 Set_Alignment (Ent, UI_From_Int (Int (Alignment / 8))); 2080 2081 if No (Back_End_Float_Types) then 2082 Back_End_Float_Types := New_Elmt_List; 2083 end if; 2084 2085 Append_Elmt (Ent, Back_End_Float_Types); 2086 end Register_Float_Type; 2087 2088 ---------------------- 2089 -- Set_Float_Bounds -- 2090 ---------------------- 2091 2092 procedure Set_Float_Bounds (Id : Entity_Id) is 2093 L : Node_Id; 2094 H : Node_Id; 2095 -- Low and high bounds of literal value 2096 2097 R : Node_Id; 2098 -- Range specification 2099 2100 Radix : constant Uint := Machine_Radix_Value (Id); 2101 Mantissa : constant Uint := Machine_Mantissa_Value (Id); 2102 Emax : constant Uint := Machine_Emax_Value (Id); 2103 Significand : constant Uint := Radix ** Mantissa - 1; 2104 Exponent : constant Uint := Emax - Mantissa; 2105 2106 begin 2107 H := Make_Float_Literal (Stloc, Radix, Significand, Exponent); 2108 L := Make_Float_Literal (Stloc, Radix, -Significand, Exponent); 2109 2110 Set_Etype (L, Id); 2111 Set_Is_Static_Expression (L); 2112 2113 Set_Etype (H, Id); 2114 Set_Is_Static_Expression (H); 2115 2116 R := New_Node (N_Range, Stloc); 2117 Set_Low_Bound (R, L); 2118 Set_High_Bound (R, H); 2119 Set_Includes_Infinities (R, True); 2120 Set_Scalar_Range (Id, R); 2121 Set_Etype (R, Id); 2122 Set_Parent (R, Id); 2123 end Set_Float_Bounds; 2124 2125 ------------------------ 2126 -- Set_Integer_Bounds -- 2127 ------------------------ 2128 2129 procedure Set_Integer_Bounds 2130 (Id : Entity_Id; 2131 Typ : Entity_Id; 2132 Lb : Uint; 2133 Hb : Uint) 2134 is 2135 L : Node_Id; 2136 H : Node_Id; 2137 -- Low and high bounds of literal value 2138 2139 R : Node_Id; 2140 -- Range specification 2141 2142 begin 2143 L := Make_Integer (Lb); 2144 H := Make_Integer (Hb); 2145 2146 Set_Etype (L, Typ); 2147 Set_Etype (H, Typ); 2148 2149 R := New_Node (N_Range, Stloc); 2150 Set_Low_Bound (R, L); 2151 Set_High_Bound (R, H); 2152 Set_Scalar_Range (Id, R); 2153 Set_Etype (R, Typ); 2154 Set_Parent (R, Id); 2155 Set_Is_Unsigned_Type (Id, Lb >= 0); 2156 end Set_Integer_Bounds; 2157 2158end CStand; 2159