gcc/ada/sinput-l.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S I N P U T . L                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2003 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Alloc;
  28 with Atree;    use Atree;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Namet;    use Namet;
  33 with Opt;
  34 with Osint;    use Osint;
  35 with Output;   use Output;
  36 with Prep;     use Prep;
  37 with Prepcomp; use Prepcomp;
  38 with Scans;    use Scans;
  39 with Scn;      use Scn;
  40 with Sinfo;    use Sinfo;
  41 with System;   use System;
  42
  43 with Unchecked_Conversion;
  44
  45 package body Sinput.L is
  46
  47    Prep_Buffer : Text_Buffer_Ptr := null;
  48    --  A buffer to temporarily stored the result of preprocessing a source.
  49    --  It is only allocated if there is at least one source to preprocess.
  50
  51    Prep_Buffer_Last : Text_Ptr := 0;
  52    --  Index of the last significant character in Prep_Buffer
  53
  54    Initial_Size_Of_Prep_Buffer : constant := 10_000;
  55    --  Size of Prep_Buffer when it is first allocated
  56
  57    --  When a file is to be preprocessed and the options to list symbols
  58    --  has been selected (switch -s), Prep.List_Symbols is called with a
  59    --  "foreword", a single line indicationg what source the symbols apply to.
  60    --  The following two constant String are the start and the end of this
  61    --  foreword.
  62
  63    Foreword_Start : constant String :=
  64                       "Preprocessing Symbols for source """;
  65
  66    Foreword_End : constant String := """";
  67
  68    -----------------
  69    -- Subprograms --
  70    -----------------
  71
  72    procedure Put_Char_In_Prep_Buffer (C : Character);
  73    --  Add one character in Prep_Buffer, extending Prep_Buffer if need be.
  74    --  Used to initialize the preprocessor.
  75
  76    procedure New_EOL_In_Prep_Buffer;
  77    --  Add an LF to Prep_Buffer.
  78    --  Used to initialize the preprocessor.
  79
  80    function Load_File
  81      (N    : File_Name_Type;
  82       T    : Osint.File_Type)
  83       return Source_File_Index;
  84    --  Load a source file, a configuration pragmas file or a definition file
  85    --  Coding also allows preprocessing file, but not a library file ???
  86
  87    -------------------------------
  88    -- Adjust_Instantiation_Sloc --
  89    -------------------------------
  90
  91    procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is
  92       Loc : constant Source_Ptr := Sloc (N);
  93
  94    begin
  95       --  We only do the adjustment if the value is between the appropriate
  96       --  low and high values. It is not clear that this should ever not be
  97       --  the case, but in practice there seem to be some nodes that get
  98       --  copied twice, and this is a defence against that happening.
  99
 100       if A.Lo <= Loc and then Loc <= A.Hi then
 101          Set_Sloc (N, Loc + A.Adjust);
 102       end if;
 103    end Adjust_Instantiation_Sloc;
 104
 105    --------------------------------
 106    -- Complete_Source_File_Entry --
 107    --------------------------------
 108
 109    procedure Complete_Source_File_Entry is
 110       CSF : constant Source_File_Index := Current_Source_File;
 111
 112    begin
 113       Trim_Lines_Table (CSF);
 114       Source_File.Table (CSF).Source_Checksum := Checksum;
 115    end Complete_Source_File_Entry;
 116
 117    ---------------------------------
 118    -- Create_Instantiation_Source --
 119    ---------------------------------
 120
 121    procedure Create_Instantiation_Source
 122      (Inst_Node    : Entity_Id;
 123       Template_Id  : Entity_Id;
 124       Inlined_Body : Boolean;
 125       A            : out Sloc_Adjustment)
 126    is
 127       Dnod : constant Node_Id := Declaration_Node (Template_Id);
 128       Xold : Source_File_Index;
 129       Xnew : Source_File_Index;
 130
 131    begin
 132       Xold := Get_Source_File_Index (Sloc (Template_Id));
 133       A.Lo := Source_File.Table (Xold).Source_First;
 134       A.Hi := Source_File.Table (Xold).Source_Last;
 135
 136       Source_File.Increment_Last;
 137       Xnew := Source_File.Last;
 138
 139       Source_File.Table (Xnew)               := Source_File.Table (Xold);
 140       Source_File.Table (Xnew).Inlined_Body  := Inlined_Body;
 141       Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node);
 142       Source_File.Table (Xnew).Template      := Xold;
 143
 144       --  Now we need to compute the new values of Source_First, Source_Last
 145       --  and adjust the source file pointer to have the correct virtual
 146       --  origin for the new range of values.
 147
 148       Source_File.Table (Xnew).Source_First :=
 149         Source_File.Table (Xnew - 1).Source_Last + 1;
 150       A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo;
 151       Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust;
 152       Set_Source_File_Index_Table (Xnew);
 153
 154       Source_File.Table (Xnew).Sloc_Adjust :=
 155         Source_File.Table (Xold).Sloc_Adjust - A.Adjust;
 156
 157       if Debug_Flag_L then
 158          Write_Eol;
 159          Write_Str ("*** Create instantiation source for ");
 160
 161          if Nkind (Dnod) in N_Proper_Body
 162            and then Was_Originally_Stub (Dnod)
 163          then
 164             Write_Str ("subunit ");
 165
 166          elsif Ekind (Template_Id) = E_Generic_Package then
 167             if Nkind (Dnod) = N_Package_Body then
 168                Write_Str ("body of package ");
 169             else
 170                Write_Str ("spec of package ");
 171             end if;
 172
 173          elsif Ekind (Template_Id) = E_Function then
 174             Write_Str ("body of function ");
 175
 176          elsif Ekind (Template_Id) = E_Procedure then
 177             Write_Str ("body of procedure ");
 178
 179          elsif Ekind (Template_Id) = E_Generic_Function then
 180             Write_Str ("spec of function ");
 181
 182          elsif Ekind (Template_Id) = E_Generic_Procedure then
 183             Write_Str ("spec of procedure ");
 184
 185          elsif Ekind (Template_Id) = E_Package_Body then
 186             Write_Str ("body of package ");
 187
 188          else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
 189
 190             if Nkind (Dnod) = N_Procedure_Specification then
 191                Write_Str ("body of procedure ");
 192             else
 193                Write_Str ("body of function ");
 194             end if;
 195          end if;
 196
 197          Write_Name (Chars (Template_Id));
 198          Write_Eol;
 199
 200          Write_Str ("  new source index = ");
 201          Write_Int (Int (Xnew));
 202          Write_Eol;
 203
 204          Write_Str ("  copying from file name = ");
 205          Write_Name (File_Name (Xold));
 206          Write_Eol;
 207
 208          Write_Str ("  old source index = ");
 209          Write_Int (Int (Xold));
 210          Write_Eol;
 211
 212          Write_Str ("  old lo = ");
 213          Write_Int (Int (A.Lo));
 214          Write_Eol;
 215
 216          Write_Str ("  old hi = ");
 217          Write_Int (Int (A.Hi));
 218          Write_Eol;
 219
 220          Write_Str ("  new lo = ");
 221          Write_Int (Int (Source_File.Table (Xnew).Source_First));
 222          Write_Eol;
 223
 224          Write_Str ("  new hi = ");
 225          Write_Int (Int (Source_File.Table (Xnew).Source_Last));
 226          Write_Eol;
 227
 228          Write_Str ("  adjustment factor = ");
 229          Write_Int (Int (A.Adjust));
 230          Write_Eol;
 231
 232          Write_Str ("  instantiation location: ");
 233          Write_Location (Sloc (Inst_Node));
 234          Write_Eol;
 235       end if;
 236
 237       --  For a given character in the source, a higher subscript will be
 238       --  used to access the instantiation, which means that the virtual
 239       --  origin must have a corresponding lower value. We compute this
 240       --  new origin by taking the address of the appropriate adjusted
 241       --  element in the old array. Since this adjusted element will be
 242       --  at a negative subscript, we must suppress checks.
 243
 244       declare
 245          pragma Suppress (All_Checks);
 246
 247          function To_Source_Buffer_Ptr is new
 248            Unchecked_Conversion (Address, Source_Buffer_Ptr);
 249
 250       begin
 251          Source_File.Table (Xnew).Source_Text :=
 252            To_Source_Buffer_Ptr
 253              (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
 254       end;
 255    end Create_Instantiation_Source;
 256
 257    ----------------------
 258    -- Load_Config_File --
 259    ----------------------
 260
 261    function Load_Config_File
 262      (N    : File_Name_Type)
 263       return Source_File_Index
 264    is
 265    begin
 266       return Load_File (N, Osint.Config);
 267    end Load_Config_File;
 268
 269    --------------------------
 270    -- Load_Definition_File --
 271    --------------------------
 272
 273    function Load_Definition_File
 274      (N    : File_Name_Type)
 275       return Source_File_Index
 276    is
 277    begin
 278       return Load_File (N, Osint.Definition);
 279    end Load_Definition_File;
 280
 281    ---------------
 282    -- Load_File --
 283    ---------------
 284
 285    function Load_File
 286      (N :    File_Name_Type;
 287       T :    Osint.File_Type)
 288       return Source_File_Index
 289    is
 290       Src : Source_Buffer_Ptr;
 291       X   : Source_File_Index;
 292       Lo  : Source_Ptr;
 293       Hi  : Source_Ptr;
 294
 295       Preprocessing_Needed : Boolean := False;
 296
 297    begin
 298       for J in 1 .. Source_File.Last loop
 299          if Source_File.Table (J).File_Name = N then
 300             return J;
 301          end if;
 302       end loop;
 303
 304       --  Here we must build a new entry in the file table
 305
 306       --  But first, we must check if a source needs to be preprocessed,
 307       --  because we may have to load and parse a definition file, and we want
 308       --  to do that before we load the source, so that the buffer of the
 309       --  source will be the last created, and we will be able to replace it
 310       --  and modify Hi without stepping on another buffer.
 311
 312       if T = Osint.Source then
 313          Prepare_To_Preprocess
 314            (Source => N, Preprocessing_Needed => Preprocessing_Needed);
 315       end if;
 316
 317       Source_File.Increment_Last;
 318       X := Source_File.Last;
 319
 320       if X = Source_File.First then
 321          Lo := First_Source_Ptr;
 322       else
 323          Lo := Source_File.Table (X - 1).Source_Last + 1;
 324       end if;
 325
 326       Osint.Read_Source_File (N, Lo, Hi, Src, T);
 327
 328       if Src = null then
 329          Source_File.Decrement_Last;
 330          return No_Source_File;
 331
 332       else
 333          if Debug_Flag_L then
 334             Write_Eol;
 335             Write_Str ("*** Build source file table entry, Index = ");
 336             Write_Int (Int (X));
 337             Write_Str (", file name = ");
 338             Write_Name (N);
 339             Write_Eol;
 340             Write_Str ("  lo = ");
 341             Write_Int (Int (Lo));
 342             Write_Eol;
 343             Write_Str ("  hi = ");
 344             Write_Int (Int (Hi));
 345             Write_Eol;
 346
 347             Write_Str ("  first 10 chars -->");
 348
 349             declare
 350                procedure Wchar (C : Character);
 351                --  Writes character or ? for control character
 352
 353                procedure Wchar (C : Character) is
 354                begin
 355                   if C < ' ' or C in ASCII.DEL .. Character'Val (16#9F#) then
 356                      Write_Char ('?');
 357                   else
 358                      Write_Char (C);
 359                   end if;
 360                end Wchar;
 361
 362             begin
 363                for J in Lo .. Lo + 9 loop
 364                   Wchar (Src (J));
 365                end loop;
 366
 367                Write_Str ("<--");
 368                Write_Eol;
 369
 370                Write_Str ("  last 10 chars  -->");
 371
 372                for J in Hi - 10 .. Hi - 1 loop
 373                   Wchar (Src (J));
 374                end loop;
 375
 376                Write_Str ("<--");
 377                Write_Eol;
 378
 379                if Src (Hi) /= EOF then
 380                   Write_Str ("  error: no EOF at end");
 381                   Write_Eol;
 382                end if;
 383             end;
 384          end if;
 385
 386          declare
 387             S         : Source_File_Record renames Source_File.Table (X);
 388             File_Type : Type_Of_File;
 389
 390          begin
 391             case T is
 392                when Osint.Source =>
 393                   File_Type := Sinput.Src;
 394
 395                when Osint.Library =>
 396                   raise Program_Error;
 397
 398                when Osint.Config =>
 399                   File_Type := Sinput.Config;
 400
 401                when Osint.Definition =>
 402                   File_Type := Def;
 403
 404                when Osint.Preprocessing_Data =>
 405                   File_Type := Preproc;
 406             end case;
 407
 408             S := (Debug_Source_Name   => N,
 409                   File_Name           => N,
 410                   File_Type           => File_Type,
 411                   First_Mapped_Line   => No_Line_Number,
 412                   Full_Debug_Name     => Osint.Full_Source_Name,
 413                   Full_File_Name      => Osint.Full_Source_Name,
 414                   Full_Ref_Name       => Osint.Full_Source_Name,
 415                   Identifier_Casing   => Unknown,
 416                   Inlined_Body        => False,
 417                   Instantiation       => No_Location,
 418                   Keyword_Casing      => Unknown,
 419                   Last_Source_Line    => 1,
 420                   License             => Unknown,
 421                   Lines_Table         => null,
 422                   Lines_Table_Max     => 1,
 423                   Logical_Lines_Table => null,
 424                   Num_SRef_Pragmas    => 0,
 425                   Reference_Name      => N,
 426                   Sloc_Adjust         => 0,
 427                   Source_Checksum     => 0,
 428                   Source_First        => Lo,
 429                   Source_Last         => Hi,
 430                   Source_Text         => Src,
 431                   Template            => No_Source_File,
 432                   Time_Stamp          => Osint.Current_Source_File_Stamp);
 433
 434             Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
 435             S.Lines_Table (1) := Lo;
 436          end;
 437
 438          --  Preprocess the source if it needs to be preprocessed
 439
 440          if Preprocessing_Needed then
 441             if Opt.List_Preprocessing_Symbols then
 442                Get_Name_String (N);
 443
 444                declare
 445                   Foreword : String (1 .. Foreword_Start'Length +
 446                                           Name_Len + Foreword_End'Length);
 447
 448                begin
 449                   Foreword (1 .. Foreword_Start'Length) := Foreword_Start;
 450                   Foreword (Foreword_Start'Length + 1 ..
 451                               Foreword_Start'Length + Name_Len) :=
 452                     Name_Buffer (1 .. Name_Len);
 453                   Foreword (Foreword'Last - Foreword_End'Length + 1 ..
 454                               Foreword'Last) := Foreword_End;
 455                   Prep.List_Symbols (Foreword);
 456                end;
 457             end if;
 458
 459             declare
 460                T : constant Nat := Total_Errors_Detected;
 461                --  Used to check if there were errors during preprocessing
 462
 463             begin
 464                --  If this is the first time we preprocess a source, allocate
 465                --  the preprocessing buffer.
 466
 467                if Prep_Buffer = null then
 468                   Prep_Buffer :=
 469                     new Text_Buffer (1 .. Initial_Size_Of_Prep_Buffer);
 470                end if;
 471
 472                --  Make sure the preprocessing buffer is empty
 473
 474                Prep_Buffer_Last := 0;
 475
 476                --  Initialize the preprocessor
 477
 478                Prep.Initialize
 479                  (Error_Msg         => Errout.Error_Msg'Access,
 480                   Scan              => Scn.Scanner.Scan'Access,
 481                   Set_Ignore_Errors => Errout.Set_Ignore_Errors'Access,
 482                   Put_Char          => Put_Char_In_Prep_Buffer'Access,
 483                   New_EOL           => New_EOL_In_Prep_Buffer'Access);
 484
 485                --  Initialize the scanner and set its behavior for
 486                --  preprocessing, then preprocess.
 487
 488                Scn.Scanner.Initialize_Scanner (No_Unit, X);
 489
 490                Scn.Scanner.Set_Special_Character ('#');
 491                Scn.Scanner.Set_Special_Character ('$');
 492                Scn.Scanner.Set_End_Of_Line_As_Token (True);
 493
 494                Preprocess;
 495
 496                --  Reset the scanner to its standard behavior
 497
 498                Scn.Scanner.Reset_Special_Characters;
 499                Scn.Scanner.Set_End_Of_Line_As_Token (False);
 500
 501                --  If there were errors during preprocessing, record an
 502                --  error at the start of the file, and do not change the
 503                --  source buffer.
 504
 505                if T /= Total_Errors_Detected then
 506                   Errout.Error_Msg
 507                     ("file could not be successfully preprocessed", Lo);
 508                   return No_Source_File;
 509
 510                else
 511                   --  Set the new value of Hi
 512
 513                   Hi := Lo + Source_Ptr (Prep_Buffer_Last);
 514
 515                   --  Create the new source buffer
 516
 517                   declare
 518                      subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
 519                      --  Physical buffer allocated
 520
 521                      type Actual_Source_Ptr is access Actual_Source_Buffer;
 522                      --  This is the pointer type for the physical buffer
 523                      --  allocated.
 524
 525                      Actual_Ptr : constant Actual_Source_Ptr :=
 526                                     new Actual_Source_Buffer;
 527                      --  And this is the actual physical buffer
 528
 529                   begin
 530                      Actual_Ptr (Lo .. Hi - 1) :=
 531                        Prep_Buffer (1 .. Prep_Buffer_Last);
 532                      Actual_Ptr (Hi) := EOF;
 533
 534                      --  Now we need to work out the proper virtual origin
 535                      --  pointer to return. This is exactly
 536                      --  Actual_Ptr (0)'Address, but we have to be careful to
 537                      --  suppress checks to compute this address.
 538
 539                      declare
 540                         pragma Suppress (All_Checks);
 541
 542                         function To_Source_Buffer_Ptr is new
 543                           Unchecked_Conversion (Address, Source_Buffer_Ptr);
 544
 545                      begin
 546                         Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
 547
 548                         --  Record in the table the new source buffer and the
 549                         --  new value of Hi.
 550
 551                         Source_File.Table (X).Source_Text := Src;
 552                         Source_File.Table (X).Source_Last := Hi;
 553
 554                         --  Reset Last_Line to 1, because the lines do not
 555                         --  have neccessarily the same starts and lengths.
 556
 557                         Source_File.Table (X).Last_Source_Line := 1;
 558                      end;
 559                   end;
 560                end if;
 561             end;
 562          end if;
 563
 564          Set_Source_File_Index_Table (X);
 565          return X;
 566       end if;
 567    end Load_File;
 568
 569    ----------------------------------
 570    -- Load_Preprocessing_Data_File --
 571    ----------------------------------
 572
 573    function Load_Preprocessing_Data_File
 574      (N    : File_Name_Type)
 575       return Source_File_Index
 576    is
 577    begin
 578       return Load_File (N, Osint.Preprocessing_Data);
 579    end Load_Preprocessing_Data_File;
 580
 581    ----------------------
 582    -- Load_Source_File --
 583    ----------------------
 584
 585    function Load_Source_File
 586      (N    : File_Name_Type)
 587       return Source_File_Index
 588    is
 589    begin
 590       return Load_File (N, Osint.Source);
 591    end Load_Source_File;
 592
 593    ----------------------------
 594    -- New_EOL_In_Prep_Buffer --
 595    ----------------------------
 596
 597    procedure New_EOL_In_Prep_Buffer is
 598    begin
 599       Put_Char_In_Prep_Buffer (ASCII.LF);
 600    end New_EOL_In_Prep_Buffer;
 601
 602    -----------------------------
 603    -- Put_Char_In_Prep_Buffer --
 604    -----------------------------
 605
 606    procedure Put_Char_In_Prep_Buffer (C : Character) is
 607    begin
 608       --  If preprocessing buffer is not large enough, double it
 609
 610       if Prep_Buffer_Last = Prep_Buffer'Last then
 611          declare
 612             New_Prep_Buffer : constant Text_Buffer_Ptr :=
 613               new Text_Buffer (1 .. 2 * Prep_Buffer_Last);
 614
 615          begin
 616             New_Prep_Buffer (Prep_Buffer'Range) := Prep_Buffer.all;
 617             Free (Prep_Buffer);
 618             Prep_Buffer := New_Prep_Buffer;
 619          end;
 620       end if;
 621
 622       Prep_Buffer_Last := Prep_Buffer_Last + 1;
 623       Prep_Buffer (Prep_Buffer_Last) := C;
 624    end Put_Char_In_Prep_Buffer;
 625
 626    ----------------------------
 627    -- Source_File_Is_Subunit --
 628    ----------------------------
 629
 630    function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
 631    begin
 632       Initialize_Scanner (No_Unit, X);
 633
 634       --  We scan past junk to the first interesting compilation unit
 635       --  token, to see if it is SEPARATE. We ignore WITH keywords during
 636       --  this and also PRIVATE. The reason for ignoring PRIVATE is that
 637       --  it handles some error situations, and also it is possible that
 638       --  a PRIVATE WITH feature might be approved some time in the future.
 639
 640       while Token = Tok_With
 641         or else Token = Tok_Private
 642         or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
 643       loop
 644          Scan;
 645       end loop;
 646
 647       return Token = Tok_Separate;
 648    end Source_File_Is_Subunit;
 649
 650 end Sinput.L;