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 --                            $Revision: 1.40 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Alloc;
  30 with Atree;  use Atree;
  31 with Debug;  use Debug;
  32 with Einfo;  use Einfo;
  33 with Namet;  use Namet;
  34 with Opt;
  35 with Osint;  use Osint;
  36 with Output; use Output;
  37 with Scans;  use Scans;
  38 with Scn;    use Scn;
  39 with Sinfo;  use Sinfo;
  40 with System; use System;
  41
  42 with Unchecked_Conversion;
  43
  44 package body Sinput.L is
  45
  46    Dfile : Source_File_Index;
  47    --  Index of currently active debug source file
  48
  49    -----------------
  50    -- Subprograms --
  51    -----------------
  52
  53    procedure Trim_Lines_Table (S : Source_File_Index);
  54    --  Set lines table size for entry S in the source file table to
  55    --  correspond to the current value of Num_Source_Lines, releasing
  56    --  any unused storage.
  57
  58    function Load_File
  59      (N    : File_Name_Type;
  60       T    : File_Type)
  61       return Source_File_Index;
  62    --  Load a source file or a configuration pragma file.
  63
  64    -------------------------------
  65    -- Adjust_Instantiation_Sloc --
  66    -------------------------------
  67
  68    procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is
  69       Loc : constant Source_Ptr := Sloc (N);
  70
  71    begin
  72       --  We only do the adjustment if the value is between the appropriate
  73       --  low and high values. It is not clear that this should ever not be
  74       --  the case, but in practice there seem to be some nodes that get
  75       --  copied twice, and this is a defence against that happening.
  76
  77       if A.Lo <= Loc and then Loc <= A.Hi then
  78          Set_Sloc (N, Loc + A.Adjust);
  79       end if;
  80    end Adjust_Instantiation_Sloc;
  81
  82    ------------------------
  83    -- Close_Debug_Source --
  84    ------------------------
  85
  86    procedure Close_Debug_Source is
  87       S    : Source_File_Record renames Source_File.Table (Dfile);
  88       Src  : Source_Buffer_Ptr;
  89
  90    begin
  91       Trim_Lines_Table (Dfile);
  92       Close_Debug_File;
  93
  94       --  Now we need to read the file that we wrote and store it
  95       --  in memory for subsequent access.
  96
  97       Read_Source_File
  98         (S.Debug_Source_Name, S.Source_First, S.Source_Last, Src);
  99       S.Source_Text := Src;
 100    end Close_Debug_Source;
 101
 102    --------------------------------
 103    -- Complete_Source_File_Entry --
 104    --------------------------------
 105
 106    procedure Complete_Source_File_Entry is
 107       CSF : constant Source_File_Index := Current_Source_File;
 108
 109    begin
 110       Trim_Lines_Table (CSF);
 111       Source_File.Table (CSF).Source_Checksum := Checksum;
 112    end Complete_Source_File_Entry;
 113
 114    -------------------------
 115    -- Create_Debug_Source --
 116    -------------------------
 117
 118    procedure Create_Debug_Source
 119      (Source : Source_File_Index;
 120       Loc    : out Source_Ptr)
 121    is
 122    begin
 123       Loc := Source_File.Table (Source_File.Last).Source_Last + 1;
 124       Source_File.Increment_Last;
 125       Dfile := Source_File.Last;
 126
 127       declare
 128          S : Source_File_Record renames Source_File.Table (Dfile);
 129
 130       begin
 131          S := Source_File.Table (Source);
 132          S.Debug_Source_Name := Create_Debug_File (S.File_Name);
 133          S.Source_First      := Loc;
 134          S.Source_Last       := Loc;
 135          S.Lines_Table       := null;
 136          S.Last_Source_Line  := 1;
 137
 138          --  Allocate lines table, guess that it needs to be three times
 139          --  bigger than the original source (in number of lines).
 140
 141          Alloc_Line_Tables
 142            (S, Int (Source_File.Table (Source).Last_Source_Line * 3));
 143          S.Lines_Table (1) := Loc;
 144       end;
 145
 146       if Debug_Flag_GG then
 147          Write_Str ("---> Create_Debug_Source (Source => ");
 148          Write_Int (Int (Source));
 149          Write_Str (", Loc => ");
 150          Write_Int (Int (Loc));
 151          Write_Str (");");
 152          Write_Eol;
 153       end if;
 154
 155    end Create_Debug_Source;
 156
 157    ---------------------------------
 158    -- Create_Instantiation_Source --
 159    ---------------------------------
 160
 161    procedure Create_Instantiation_Source
 162      (Inst_Node   : Entity_Id;
 163       Template_Id : Entity_Id;
 164       A           : out Sloc_Adjustment)
 165    is
 166       Dnod : constant Node_Id := Declaration_Node (Template_Id);
 167       Xold : Source_File_Index;
 168       Xnew : Source_File_Index;
 169
 170    begin
 171       Xold := Get_Source_File_Index (Sloc (Template_Id));
 172       A.Lo := Source_File.Table (Xold).Source_First;
 173       A.Hi := Source_File.Table (Xold).Source_Last;
 174
 175       Source_File.Increment_Last;
 176       Xnew := Source_File.Last;
 177
 178       Source_File.Table (Xnew)               := Source_File.Table (Xold);
 179       Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node);
 180       Source_File.Table (Xnew).Template      := Xold;
 181
 182       --  Now we need to compute the new values of Source_First, Source_Last
 183       --  and adjust the source file pointer to have the correct virtual
 184       --  origin for the new range of values.
 185
 186       Source_File.Table (Xnew).Source_First :=
 187         Source_File.Table (Xnew - 1).Source_Last + 1;
 188
 189       A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo;
 190       Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust;
 191
 192       Source_File.Table (Xnew).Sloc_Adjust :=
 193         Source_File.Table (Xold).Sloc_Adjust - A.Adjust;
 194
 195       if Debug_Flag_L then
 196          Write_Eol;
 197          Write_Str ("*** Create instantiation source for ");
 198
 199          if Nkind (Dnod) in N_Proper_Body
 200            and then Was_Originally_Stub (Dnod)
 201          then
 202             Write_Str ("subunit ");
 203
 204          elsif Ekind (Template_Id) = E_Generic_Package then
 205             if Nkind (Dnod) = N_Package_Body then
 206                Write_Str ("body of package ");
 207             else
 208                Write_Str ("spec of package ");
 209             end if;
 210
 211          elsif Ekind (Template_Id) = E_Function then
 212             Write_Str ("body of function ");
 213
 214          elsif Ekind (Template_Id) = E_Procedure then
 215             Write_Str ("body of procedure ");
 216
 217          elsif Ekind (Template_Id) = E_Generic_Function then
 218             Write_Str ("spec of function ");
 219
 220          elsif Ekind (Template_Id) = E_Generic_Procedure then
 221             Write_Str ("spec of procedure ");
 222
 223          elsif Ekind (Template_Id) = E_Package_Body then
 224             Write_Str ("body of package ");
 225
 226          else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
 227
 228             if Nkind (Dnod) = N_Procedure_Specification then
 229                Write_Str ("body of procedure ");
 230             else
 231                Write_Str ("body of function ");
 232             end if;
 233          end if;
 234
 235          Write_Name (Chars (Template_Id));
 236          Write_Eol;
 237
 238          Write_Str ("  new source index = ");
 239          Write_Int (Int (Xnew));
 240          Write_Eol;
 241
 242          Write_Str ("  copying from file name = ");
 243          Write_Name (File_Name (Xold));
 244          Write_Eol;
 245
 246          Write_Str ("  old source index = ");
 247          Write_Int (Int (Xold));
 248          Write_Eol;
 249
 250          Write_Str ("  old lo = ");
 251          Write_Int (Int (A.Lo));
 252          Write_Eol;
 253
 254          Write_Str ("  old hi = ");
 255          Write_Int (Int (A.Hi));
 256          Write_Eol;
 257
 258          Write_Str ("  new lo = ");
 259          Write_Int (Int (Source_File.Table (Xnew).Source_First));
 260          Write_Eol;
 261
 262          Write_Str ("  new hi = ");
 263          Write_Int (Int (Source_File.Table (Xnew).Source_Last));
 264          Write_Eol;
 265
 266          Write_Str ("  adjustment factor = ");
 267          Write_Int (Int (A.Adjust));
 268          Write_Eol;
 269
 270          Write_Str ("  instantiation location: ");
 271          Write_Location (Sloc (Inst_Node));
 272          Write_Eol;
 273       end if;
 274
 275       --  For a given character in the source, a higher subscript will be
 276       --  used to access the instantiation, which means that the virtual
 277       --  origin must have a corresponding lower value. We compute this
 278       --  new origin by taking the address of the appropriate adjusted
 279       --  element in the old array. Since this adjusted element will be
 280       --  at a negative subscript, we must suppress checks.
 281
 282       declare
 283          pragma Suppress (All_Checks);
 284
 285          function To_Source_Buffer_Ptr is new
 286            Unchecked_Conversion (Address, Source_Buffer_Ptr);
 287
 288       begin
 289          Source_File.Table (Xnew).Source_Text :=
 290            To_Source_Buffer_Ptr
 291              (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
 292       end;
 293
 294    end Create_Instantiation_Source;
 295
 296    ----------------------
 297    -- Load_Config_File --
 298    ----------------------
 299
 300    function Load_Config_File
 301      (N    : File_Name_Type)
 302       return Source_File_Index
 303    is
 304    begin
 305       return Load_File (N, Osint.Config);
 306    end Load_Config_File;
 307
 308    ---------------
 309    -- Load_File --
 310    ---------------
 311
 312    function Load_File
 313      (N :    File_Name_Type;
 314       T :    File_Type)
 315       return Source_File_Index
 316    is
 317       Src  : Source_Buffer_Ptr;
 318       X    : Source_File_Index;
 319       Lo   : Source_Ptr;
 320       Hi   : Source_Ptr;
 321
 322    begin
 323       for J in 1 .. Source_File.Last loop
 324          if Source_File.Table (J).File_Name = N then
 325             return J;
 326          end if;
 327       end loop;
 328
 329       --  Here we must build a new entry in the file table
 330
 331       Source_File.Increment_Last;
 332       X := Source_File.Last;
 333
 334       if X = Source_File.First then
 335          Lo := First_Source_Ptr;
 336       else
 337          Lo := Source_File.Table (X - 1).Source_Last + 1;
 338       end if;
 339
 340       Read_Source_File (N, Lo, Hi, Src, T);
 341
 342       if Src = null then
 343          Source_File.Decrement_Last;
 344          return No_Source_File;
 345
 346       else
 347          if Debug_Flag_L then
 348             Write_Eol;
 349             Write_Str ("*** Build source file table entry, Index = ");
 350             Write_Int (Int (X));
 351             Write_Str (", file name = ");
 352             Write_Name (N);
 353             Write_Eol;
 354             Write_Str ("  lo = ");
 355             Write_Int (Int (Lo));
 356             Write_Eol;
 357             Write_Str ("  hi = ");
 358             Write_Int (Int (Hi));
 359             Write_Eol;
 360
 361             Write_Str ("  first 10 chars -->");
 362
 363             declare
 364                procedure Wchar (C : Character);
 365                --  Writes character or ? for control character
 366
 367                procedure Wchar (C : Character) is
 368                begin
 369                   if C < ' ' or C in ASCII.DEL .. Character'Val (16#9F#) then
 370                      Write_Char ('?');
 371                   else
 372                      Write_Char (C);
 373                   end if;
 374                end Wchar;
 375
 376             begin
 377                for J in Lo .. Lo + 9 loop
 378                   Wchar (Src (J));
 379                end loop;
 380
 381                Write_Str ("<--");
 382                Write_Eol;
 383
 384                Write_Str ("  last 10 chars  -->");
 385
 386                for J in Hi - 10 .. Hi - 1 loop
 387                   Wchar (Src (J));
 388                end loop;
 389
 390                Write_Str ("<--");
 391                Write_Eol;
 392
 393                if Src (Hi) /= EOF then
 394                   Write_Str ("  error: no EOF at end");
 395                   Write_Eol;
 396                end if;
 397             end;
 398          end if;
 399
 400          declare
 401             S : Source_File_Record renames Source_File.Table (X);
 402
 403          begin
 404             S := (Debug_Source_Name   => Full_Source_Name,
 405                   File_Name           => N,
 406                   First_Mapped_Line   => No_Line_Number,
 407                   Full_File_Name      => Full_Source_Name,
 408                   Full_Ref_Name       => Full_Source_Name,
 409                   Identifier_Casing   => Unknown,
 410                   Instantiation       => No_Location,
 411                   Keyword_Casing      => Unknown,
 412                   Last_Source_Line    => 1,
 413                   License             => Unknown,
 414                   Lines_Table         => null,
 415                   Lines_Table_Max     => 1,
 416                   Logical_Lines_Table => null,
 417                   Num_SRef_Pragmas    => 0,
 418                   Reference_Name      => N,
 419                   Sloc_Adjust         => 0,
 420                   Source_Checksum     => 0,
 421                   Source_First        => Lo,
 422                   Source_Last         => Hi,
 423                   Source_Text         => Src,
 424                   Template            => No_Source_File,
 425                   Time_Stamp          => Current_Source_File_Stamp);
 426
 427             Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
 428             S.Lines_Table (1) := Lo;
 429          end;
 430
 431          return X;
 432       end if;
 433    end Load_File;
 434
 435    ----------------------
 436    -- Load_Source_File --
 437    ----------------------
 438
 439    function Load_Source_File
 440      (N    : File_Name_Type)
 441       return Source_File_Index
 442    is
 443    begin
 444       return Load_File (N, Osint.Source);
 445    end Load_Source_File;
 446
 447    ----------------------------
 448    -- Source_File_Is_Subunit --
 449    ----------------------------
 450
 451    function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
 452    begin
 453       Initialize_Scanner (No_Unit, X);
 454
 455       --  We scan past junk to the first interesting compilation unit
 456       --  token, to see if it is SEPARATE. We ignore WITH keywords during
 457       --  this and also PRIVATE. The reason for ignoring PRIVATE is that
 458       --  it handles some error situations, and also it is possible that
 459       --  a PRIVATE WITH feature might be approved some time in the future.
 460
 461       while Token = Tok_With
 462         or else Token = Tok_Private
 463         or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
 464       loop
 465          Scan;
 466       end loop;
 467
 468       return Token = Tok_Separate;
 469    end Source_File_Is_Subunit;
 470
 471    ----------------------
 472    -- Trim_Lines_Table --
 473    ----------------------
 474
 475    procedure Trim_Lines_Table (S : Source_File_Index) is
 476
 477       function realloc
 478         (P        : Lines_Table_Ptr;
 479          New_Size : Int)
 480          return     Lines_Table_Ptr;
 481       pragma Import (C, realloc);
 482
 483       Max : constant Nat := Nat (Source_File.Table (S).Last_Source_Line);
 484
 485    begin
 486       --  Release allocated storage that is no longer needed
 487
 488       Source_File.Table (S).Lines_Table :=
 489         realloc
 490           (Source_File.Table (S).Lines_Table,
 491            Max * (Lines_Table_Type'Component_Size / System.Storage_Unit));
 492       Source_File.Table (S).Lines_Table_Max := Physical_Line_Number (Max);
 493    end Trim_Lines_Table;
 494
 495    ----------------------
 496    -- Write_Debug_Line --
 497    ----------------------
 498
 499    procedure Write_Debug_Line (Str : String; Loc : in out Source_Ptr) is
 500       S : Source_File_Record renames Source_File.Table (Dfile);
 501
 502    begin
 503       --  Ignore write request if null line at start of file
 504
 505       if Str'Length = 0 and then Loc = S.Source_First then
 506          return;
 507
 508       --  Here we write the line, and update the source record entry
 509
 510       else
 511          Write_Debug_Info (Str);
 512          Add_Line_Tables_Entry (S, Loc);
 513          Loc := Loc + Source_Ptr (Str'Length + Debug_File_Eol_Length);
 514          S.Source_Last := Loc;
 515
 516          if Debug_Flag_GG then
 517             declare
 518                Lin : constant String := Str;
 519
 520             begin
 521                Column := 1;
 522                Write_Str ("---> Write_Debug_Line (Str => """);
 523                Write_Str (Lin);
 524                Write_Str (""", Loc => ");
 525                Write_Int (Int (Loc));
 526                Write_Str (");");
 527                Write_Eol;
 528             end;
 529          end if;
 530       end if;
 531    end Write_Debug_Line;
 532
 533 end Sinput.L;