gcc/ada/butil.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                B U T I L                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2023, 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
  26 with Ada.Unchecked_Deallocation;
  27 with Opt;    use Opt;
  28 with Output; use Output;
  29
  30 with GNAT; use GNAT;
  31
  32 with System.OS_Lib; use System.OS_Lib;
  33
  34 package body Butil is
  35
  36    -----------------------
  37    -- Local subprograms --
  38    -----------------------
  39
  40    procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator);
  41    --  Parse the name of the next available unit accessible through iterator
  42    --  Iter and save it in the iterator.
  43
  44    function Read_Forced_Elab_Order_File return String_Ptr;
  45    --  Read the contents of the forced-elaboration-order file supplied to the
  46    --  binder via switch -f and return them as a string. Return null if the
  47    --  file is not available.
  48
  49    --------------
  50    -- Has_Next --
  51    --------------
  52
  53    function Has_Next (Iter : Forced_Units_Iterator) return Boolean is
  54    begin
  55       return Present (Iter.Unit_Name);
  56    end Has_Next;
  57
  58    ----------------------
  59    -- Is_Internal_Unit --
  60    ----------------------
  61
  62    --  Note: the reason we do not use the Fname package for this function
  63    --  is that it would drag too much junk into the binder.
  64
  65    function Is_Internal_Unit return Boolean is
  66    begin
  67       return Is_Predefined_Unit
  68         or else (Name_Len > 4 and then (Name_Buffer (1 .. 5) = "gnat%"
  69                                           or else
  70                                         Name_Buffer (1 .. 5) = "gnat."));
  71    end Is_Internal_Unit;
  72
  73    ------------------------
  74    -- Is_Predefined_Unit --
  75    ------------------------
  76
  77    --  Note: the reason we do not use the Fname package for this function
  78    --  is that it would drag too much junk into the binder.
  79
  80    function Is_Predefined_Unit return Boolean is
  81       L : Natural renames Name_Len;
  82       B : String  renames Name_Buffer;
  83    begin
  84       return    (L >  3 and then B (1 ..  4) = "ada.")
  85         or else (L >  6 and then B (1 ..  7) = "system.")
  86         or else (L > 10 and then B (1 .. 11) = "interfaces.")
  87         or else (L >  3 and then B (1 ..  4) = "ada%")
  88         or else (L >  8 and then B (1 ..  9) = "calendar%")
  89         or else (L >  9 and then B (1 .. 10) = "direct_io%")
  90         or else (L > 10 and then B (1 .. 11) = "interfaces%")
  91         or else (L > 13 and then B (1 .. 14) = "io_exceptions%")
  92         or else (L > 12 and then B (1 .. 13) = "machine_code%")
  93         or else (L > 13 and then B (1 .. 14) = "sequential_io%")
  94         or else (L >  6 and then B (1 ..  7) = "system%")
  95         or else (L >  7 and then B (1 ..  8) = "text_io%")
  96         or else (L > 20 and then B (1 .. 21) = "unchecked_conversion%")
  97         or else (L > 22 and then B (1 .. 23) = "unchecked_deallocation%")
  98         or else (L >  4 and then B (1 ..  5) = "gnat%")
  99         or else (L >  4 and then B (1 ..  5) = "gnat.");
 100    end Is_Predefined_Unit;
 101
 102    --------------------------
 103    -- Iterate_Forced_Units --
 104    --------------------------
 105
 106    function Iterate_Forced_Units return Forced_Units_Iterator is
 107       Iter : Forced_Units_Iterator;
 108
 109    begin
 110       Iter.Order := Read_Forced_Elab_Order_File;
 111       Parse_Next_Unit_Name (Iter);
 112
 113       return Iter;
 114    end Iterate_Forced_Units;
 115
 116    ----------
 117    -- Next --
 118    ----------
 119
 120    procedure Next
 121      (Iter      : in out Forced_Units_Iterator;
 122       Unit_Name : out Unit_Name_Type;
 123       Unit_Line : out Logical_Line_Number)
 124    is
 125    begin
 126       if not Has_Next (Iter) then
 127          raise Iterator_Exhausted;
 128       end if;
 129
 130       Unit_Line := Iter.Unit_Line;
 131       Unit_Name := Iter.Unit_Name;
 132       pragma Assert (Present (Unit_Name));
 133
 134       Parse_Next_Unit_Name (Iter);
 135    end Next;
 136
 137    --------------------------
 138    -- Parse_Next_Unit_Name --
 139    --------------------------
 140
 141    procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator) is
 142       Body_Suffix : constant String   := " (body)";
 143       Body_Type   : constant String   := "%b";
 144       Body_Length : constant Positive := Body_Suffix'Length;
 145       Body_Offset : constant Natural  := Body_Length - 1;
 146
 147       Comment_Header : constant String  := "--";
 148       Comment_Offset : constant Natural := Comment_Header'Length - 1;
 149
 150       Spec_Suffix : constant String   := " (spec)";
 151       Spec_Type   : constant String   := "%s";
 152       Spec_Length : constant Positive := Spec_Suffix'Length;
 153       Spec_Offset : constant Natural  := Spec_Length - 1;
 154
 155       Index : Positive            renames Iter.Order_Index;
 156       Line  : Logical_Line_Number renames Iter.Order_Line;
 157       Order : String_Ptr          renames Iter.Order;
 158
 159       function At_Comment return Boolean;
 160       pragma Inline (At_Comment);
 161       --  Determine whether iterator Iter is positioned over the start of a
 162       --  comment.
 163
 164       function At_Terminator return Boolean;
 165       pragma Inline (At_Terminator);
 166       --  Determine whether iterator Iter is positioned over a line terminator
 167       --  character.
 168
 169       function At_Whitespace return Boolean;
 170       pragma Inline (At_Whitespace);
 171       --  Determine whether iterator Iter is positioned over a whitespace
 172       --  character.
 173
 174       function Is_Terminator (C : Character) return Boolean;
 175       pragma Inline (Is_Terminator);
 176       --  Determine whether character C denotes a line terminator
 177
 178       function Is_Whitespace (C : Character) return Boolean;
 179       pragma Inline (Is_Whitespace);
 180       --  Determine whether character C denotes a whitespace
 181
 182       procedure Parse_Unit_Name;
 183       pragma Inline (Parse_Unit_Name);
 184       --  Find and parse the first available unit name
 185
 186       procedure Skip_Comment;
 187       pragma Inline (Skip_Comment);
 188       --  Skip a comment by reaching a line terminator
 189
 190       procedure Skip_Terminator;
 191       pragma Inline (Skip_Terminator);
 192       --  Skip a line terminator and deal with the logical line numbering
 193
 194       procedure Skip_Whitespace;
 195       pragma Inline (Skip_Whitespace);
 196       --  Skip whitespace
 197
 198       function Within_Order
 199         (Low_Offset  : Natural := 0;
 200          High_Offset : Natural := 0) return Boolean;
 201       pragma Inline (Within_Order);
 202       --  Determine whether index of iterator Iter is still within the range of
 203       --  the order string. Low_Offset may be used to inspect the area that is
 204       --  less than the index. High_Offset may be used to inspect the area that
 205       --  is greater than the index.
 206
 207       ----------------
 208       -- At_Comment --
 209       ----------------
 210
 211       function At_Comment return Boolean is
 212       begin
 213          --  The interator is over a comment when the index is positioned over
 214          --  the start of a comment header.
 215          --
 216          --    unit (spec)  --  comment
 217          --                 ^
 218          --                 Index
 219
 220          return
 221            Within_Order (High_Offset => Comment_Offset)
 222              and then Order (Index .. Index + Comment_Offset) = Comment_Header;
 223       end At_Comment;
 224
 225       -------------------
 226       -- At_Terminator --
 227       -------------------
 228
 229       function At_Terminator return Boolean is
 230       begin
 231          return Within_Order and then Is_Terminator (Order (Index));
 232       end At_Terminator;
 233
 234       -------------------
 235       -- At_Whitespace --
 236       -------------------
 237
 238       function At_Whitespace return Boolean is
 239       begin
 240          return Within_Order and then Is_Whitespace (Order (Index));
 241       end At_Whitespace;
 242
 243       -------------------
 244       -- Is_Terminator --
 245       -------------------
 246
 247       function Is_Terminator (C : Character) return Boolean is
 248       begin
 249          --  Carriage return is treated intentionally as whitespace since it
 250          --  appears only on certain targets, while line feed is consistent on
 251          --  all of them.
 252
 253          return C = ASCII.LF;
 254       end Is_Terminator;
 255
 256       -------------------
 257       -- Is_Whitespace --
 258       -------------------
 259
 260       function Is_Whitespace (C : Character) return Boolean is
 261       begin
 262          return
 263            C = ' '
 264              or else C = ASCII.CR   --  carriage return
 265              or else C = ASCII.FF   --  form feed
 266              or else C = ASCII.HT   --  horizontal tab
 267              or else C = ASCII.VT;  --  vertical tab
 268       end Is_Whitespace;
 269
 270       ---------------------
 271       -- Parse_Unit_Name --
 272       ---------------------
 273
 274       procedure Parse_Unit_Name is
 275          pragma Assert (not At_Comment);
 276          pragma Assert (not At_Terminator);
 277          pragma Assert (not At_Whitespace);
 278          pragma Assert (Within_Order);
 279
 280          procedure Find_End_Index_Of_Unit_Name;
 281          pragma Inline (Find_End_Index_Of_Unit_Name);
 282          --  Position the index of iterator Iter at the last character of the
 283          --  first available unit name.
 284
 285          ---------------------------------
 286          -- Find_End_Index_Of_Unit_Name --
 287          ---------------------------------
 288
 289          procedure Find_End_Index_Of_Unit_Name is
 290          begin
 291             --  At this point the index points at the start of a unit name. The
 292             --  unit name may be legal, in which case it appears as:
 293             --
 294             --    unit (body)
 295             --
 296             --  However, it may also be illegal:
 297             --
 298             --    unit without suffix
 299             --    unit with multiple prefixes (spec)
 300             --
 301             --  In order to handle both forms, find the construct following the
 302             --  unit name. This is either a comment, a terminator, or the end
 303             --  of the order:
 304             --
 305             --    unit (body)    --  comment
 306             --    unit without suffix    <terminator>
 307             --    unit with multiple prefixes (spec)<end of order>
 308             --
 309             --  Once the construct is found, truncate the unit name by skipping
 310             --  all white space between the construct and the end of the unit
 311             --  name.
 312
 313             --  Find the construct that follows the unit name
 314
 315             while Within_Order loop
 316                if At_Comment then
 317                   exit;
 318
 319                elsif At_Terminator then
 320                   exit;
 321                end if;
 322
 323                Index := Index + 1;
 324             end loop;
 325
 326             --  Position the index prior to the construct that follows the unit
 327             --  name.
 328
 329             Index := Index - 1;
 330
 331             --  Truncate towards the end of the unit name
 332
 333             while Within_Order loop
 334                if At_Whitespace then
 335                   Index := Index - 1;
 336                else
 337                   exit;
 338                end if;
 339             end loop;
 340          end Find_End_Index_Of_Unit_Name;
 341
 342          --  Local variables
 343
 344          Start_Index : constant Positive := Index;
 345
 346          End_Index : Positive;
 347          Is_Body   : Boolean := False;
 348          Is_Spec   : Boolean := False;
 349
 350       --  Start of processing for Parse_Unit_Name
 351
 352       begin
 353          Find_End_Index_Of_Unit_Name;
 354          End_Index := Index;
 355
 356          pragma Assert (Start_Index <= End_Index);
 357
 358          --  At this point the indices are positioned as follows:
 359          --
 360          --              End_Index
 361          --              Index
 362          --              v
 363          --    unit (spec)     --  comment
 364          --    ^
 365          --    Start_Index
 366
 367          --  Rewind the index, skipping over the legal suffixes
 368          --
 369          --    Index     End_Index
 370          --        v     v
 371          --    unit (spec)     --  comment
 372          --    ^
 373          --    Start_Index
 374
 375          if Within_Order (Low_Offset => Body_Offset)
 376            and then Order (Index - Body_Offset .. Index) = Body_Suffix
 377          then
 378             Is_Body := True;
 379             Index   := Index - Body_Length;
 380
 381          elsif Within_Order (Low_Offset => Spec_Offset)
 382            and then Order (Index - Spec_Offset .. Index) = Spec_Suffix
 383          then
 384             Is_Spec := True;
 385             Index   := Index - Spec_Length;
 386          end if;
 387
 388          --  Capture the line where the unit name is defined
 389
 390          Iter.Unit_Line := Line;
 391
 392          --  Transform the unit name to match the format recognized by the
 393          --  name table.
 394
 395          if Is_Body then
 396             Iter.Unit_Name :=
 397               Name_Find (Order (Start_Index .. Index) & Body_Type);
 398
 399          elsif Is_Spec then
 400             Iter.Unit_Name :=
 401               Name_Find (Order (Start_Index .. Index) & Spec_Type);
 402
 403          --  Otherwise the unit name is illegal, so leave it as is
 404
 405          else
 406             Iter.Unit_Name := Name_Find (Order (Start_Index .. Index));
 407          end if;
 408
 409          --  Advance the index past the unit name
 410          --
 411          --      End_IndexIndex
 412          --              vv
 413          --    unit (spec)     --  comment
 414          --    ^
 415          --    Start_Index
 416
 417          Index := End_Index + 1;
 418       end Parse_Unit_Name;
 419
 420       ------------------
 421       -- Skip_Comment --
 422       ------------------
 423
 424       procedure Skip_Comment is
 425       begin
 426          pragma Assert (At_Comment);
 427
 428          while Within_Order loop
 429             if At_Terminator then
 430                exit;
 431             end if;
 432
 433             Index := Index + 1;
 434          end loop;
 435       end Skip_Comment;
 436
 437       ---------------------
 438       -- Skip_Terminator --
 439       ---------------------
 440
 441       procedure Skip_Terminator is
 442       begin
 443          pragma Assert (At_Terminator);
 444
 445          Index := Index + 1;
 446          Line  := Line  + 1;
 447       end Skip_Terminator;
 448
 449       ---------------------
 450       -- Skip_Whitespace --
 451       ---------------------
 452
 453       procedure Skip_Whitespace is
 454       begin
 455          while Within_Order loop
 456             if At_Whitespace then
 457                Index := Index + 1;
 458             else
 459                exit;
 460             end if;
 461          end loop;
 462       end Skip_Whitespace;
 463
 464       ------------------
 465       -- Within_Order --
 466       ------------------
 467
 468       function Within_Order
 469         (Low_Offset  : Natural := 0;
 470          High_Offset : Natural := 0) return Boolean
 471       is
 472       begin
 473          return
 474            Order /= null
 475              and then Index - Low_Offset  >= Order'First
 476              and then Index + High_Offset <= Order'Last;
 477       end Within_Order;
 478
 479    --  Start of processing for Parse_Next_Unit_Name
 480
 481    begin
 482       --  A line in the forced-elaboration-order file has the following
 483       --  grammar:
 484       --
 485       --    LINE ::=
 486       --      [WHITESPACE] UNIT_NAME [WHITESPACE] [COMMENT] TERMINATOR
 487       --
 488       --    WHITESPACE ::=
 489       --      <any whitespace character>
 490       --    | <carriage return>
 491       --
 492       --    UNIT_NAME ::=
 493       --      UNIT_PREFIX [WHITESPACE] UNIT_SUFFIX
 494       --
 495       --    UNIT_PREFIX ::=
 496       --      <any string>
 497       --
 498       --    UNIT_SUFFIX ::=
 499       --      (body)
 500       --    | (spec)
 501       --
 502       --    COMMENT ::=
 503       --      --  <any string>
 504       --
 505       --    TERMINATOR ::=
 506       --      <line feed>
 507       --      <end of file>
 508       --
 509       --  Items in <> brackets are semantic notions
 510
 511       --  Assume that the order has no remaining units
 512
 513       Iter.Unit_Line := No_Line_Number;
 514       Iter.Unit_Name := No_Unit_Name;
 515
 516       --  Try to find the first available unit name from the current position
 517       --  of iteration.
 518
 519       while Within_Order loop
 520          Skip_Whitespace;
 521
 522          if At_Comment then
 523             Skip_Comment;
 524
 525          elsif not Within_Order then
 526             exit;
 527
 528          elsif At_Terminator then
 529             Skip_Terminator;
 530
 531          else
 532             Parse_Unit_Name;
 533             exit;
 534          end if;
 535       end loop;
 536    end Parse_Next_Unit_Name;
 537
 538    ---------------------------------
 539    -- Read_Forced_Elab_Order_File --
 540    ---------------------------------
 541
 542    function Read_Forced_Elab_Order_File return String_Ptr is
 543       procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr);
 544
 545       Descr    : File_Descriptor;
 546       Len      : Natural;
 547       Len_Read : Natural;
 548       Result   : String_Ptr;
 549       Success  : Boolean;
 550
 551    begin
 552       if Force_Elab_Order_File = null then
 553          return null;
 554       end if;
 555
 556       --  Obtain and sanitize a descriptor to the elaboration-order file
 557
 558       Descr := Open_Read (Force_Elab_Order_File.all, Binary);
 559
 560       if Descr = Invalid_FD then
 561          return null;
 562       end if;
 563
 564       --  Determine the size of the file, allocate a result large enough to
 565       --  house its contents, and read it.
 566
 567       Len := Natural (File_Length (Descr));
 568
 569       if Len = 0 then
 570          return null;
 571       end if;
 572
 573       Result   := new String (1 .. Len);
 574       Len_Read := Read (Descr, Result (1)'Address, Len);
 575
 576       --  The read failed to acquire the whole content of the file
 577
 578       if Len_Read /= Len then
 579          Free (Result);
 580          return null;
 581       end if;
 582
 583       Close (Descr, Success);
 584
 585       --  The file failed to close
 586
 587       if not Success then
 588          Free (Result);
 589          return null;
 590       end if;
 591
 592       return Result;
 593    end Read_Forced_Elab_Order_File;
 594
 595    ----------------
 596    -- Uname_Less --
 597    ----------------
 598
 599    function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is
 600    begin
 601       Get_Name_String (U1);
 602
 603       declare
 604          U1_Name : constant String (1 .. Name_Len) :=
 605                      Name_Buffer (1 .. Name_Len);
 606          Min_Length : Natural;
 607
 608       begin
 609          Get_Name_String (U2);
 610
 611          if Name_Len < U1_Name'Last then
 612             Min_Length := Name_Len;
 613          else
 614             Min_Length := U1_Name'Last;
 615          end if;
 616
 617          for J in 1 .. Min_Length loop
 618             if U1_Name (J) > Name_Buffer (J) then
 619                return False;
 620             elsif U1_Name (J) < Name_Buffer (J) then
 621                return True;
 622             end if;
 623          end loop;
 624
 625          return U1_Name'Last < Name_Len;
 626       end;
 627    end Uname_Less;
 628
 629    ---------------------
 630    -- Write_Unit_Name --
 631    ---------------------
 632
 633    procedure Write_Unit_Name (U : Unit_Name_Type) is
 634    begin
 635       Get_Name_String (U);
 636       Write_Str (Name_Buffer (1 .. Name_Len - 2));
 637
 638       if Name_Buffer (Name_Len) = 's' then
 639          Write_Str (" (spec)");
 640       else
 641          Write_Str (" (body)");
 642       end if;
 643
 644       Name_Len := Name_Len + 5;
 645    end Write_Unit_Name;
 646
 647 end Butil;