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 --                                                                          --
  10 --          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Alloc;
  29 with Atree;   use Atree;
  30 with Debug;   use Debug;
  31 with Einfo;   use Einfo;
  32 with Namet;   use Namet;
  33 with Opt;
  34 with Osint;   use Osint;
  35 with Output;  use Output;
  36 with Scans;   use Scans;
  37 with Scn;     use Scn;
  38 with Sinfo;   use Sinfo;
  39 with System;  use System;
  40
  41 with Unchecked_Conversion;
  42
  43 package body Sinput.L is
  44
  45    --  Routines to support conversion between types Lines_Table_Ptr
  46    --  and System.Address.
  47
  48    -----------------
  49    -- Subprograms --
  50    -----------------
  51
  52    function Load_File
  53      (N    : File_Name_Type;
  54       T    : File_Type)
  55       return Source_File_Index;
  56    --  Load a source file or a configuration pragma file.
  57
  58    -------------------------------
  59    -- Adjust_Instantiation_Sloc --
  60    -------------------------------
  61
  62    procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is
  63       Loc : constant Source_Ptr := Sloc (N);
  64
  65    begin
  66       --  We only do the adjustment if the value is between the appropriate
  67       --  low and high values. It is not clear that this should ever not be
  68       --  the case, but in practice there seem to be some nodes that get
  69       --  copied twice, and this is a defence against that happening.
  70
  71       if A.Lo <= Loc and then Loc <= A.Hi then
  72          Set_Sloc (N, Loc + A.Adjust);
  73       end if;
  74    end Adjust_Instantiation_Sloc;
  75
  76    --------------------------------
  77    -- Complete_Source_File_Entry --
  78    --------------------------------
  79
  80    procedure Complete_Source_File_Entry is
  81       CSF : constant Source_File_Index := Current_Source_File;
  82
  83    begin
  84       Trim_Lines_Table (CSF);
  85       Source_File.Table (CSF).Source_Checksum := Checksum;
  86    end Complete_Source_File_Entry;
  87
  88    ---------------------------------
  89    -- Create_Instantiation_Source --
  90    ---------------------------------
  91
  92    procedure Create_Instantiation_Source
  93      (Inst_Node   : Entity_Id;
  94       Template_Id : Entity_Id;
  95       A           : out Sloc_Adjustment)
  96    is
  97       Dnod : constant Node_Id := Declaration_Node (Template_Id);
  98       Xold : Source_File_Index;
  99       Xnew : Source_File_Index;
 100
 101    begin
 102       Xold := Get_Source_File_Index (Sloc (Template_Id));
 103       A.Lo := Source_File.Table (Xold).Source_First;
 104       A.Hi := Source_File.Table (Xold).Source_Last;
 105
 106       Source_File.Increment_Last;
 107       Xnew := Source_File.Last;
 108
 109       Source_File.Table (Xnew)               := Source_File.Table (Xold);
 110       Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node);
 111       Source_File.Table (Xnew).Template      := Xold;
 112
 113       --  Now we need to compute the new values of Source_First, Source_Last
 114       --  and adjust the source file pointer to have the correct virtual
 115       --  origin for the new range of values.
 116
 117       Source_File.Table (Xnew).Source_First :=
 118         Source_File.Table (Xnew - 1).Source_Last + 1;
 119
 120       A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo;
 121       Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust;
 122
 123       Source_File.Table (Xnew).Sloc_Adjust :=
 124         Source_File.Table (Xold).Sloc_Adjust - A.Adjust;
 125
 126       if Debug_Flag_L then
 127          Write_Eol;
 128          Write_Str ("*** Create instantiation source for ");
 129
 130          if Nkind (Dnod) in N_Proper_Body
 131            and then Was_Originally_Stub (Dnod)
 132          then
 133             Write_Str ("subunit ");
 134
 135          elsif Ekind (Template_Id) = E_Generic_Package then
 136             if Nkind (Dnod) = N_Package_Body then
 137                Write_Str ("body of package ");
 138             else
 139                Write_Str ("spec of package ");
 140             end if;
 141
 142          elsif Ekind (Template_Id) = E_Function then
 143             Write_Str ("body of function ");
 144
 145          elsif Ekind (Template_Id) = E_Procedure then
 146             Write_Str ("body of procedure ");
 147
 148          elsif Ekind (Template_Id) = E_Generic_Function then
 149             Write_Str ("spec of function ");
 150
 151          elsif Ekind (Template_Id) = E_Generic_Procedure then
 152             Write_Str ("spec of procedure ");
 153
 154          elsif Ekind (Template_Id) = E_Package_Body then
 155             Write_Str ("body of package ");
 156
 157          else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
 158
 159             if Nkind (Dnod) = N_Procedure_Specification then
 160                Write_Str ("body of procedure ");
 161             else
 162                Write_Str ("body of function ");
 163             end if;
 164          end if;
 165
 166          Write_Name (Chars (Template_Id));
 167          Write_Eol;
 168
 169          Write_Str ("  new source index = ");
 170          Write_Int (Int (Xnew));
 171          Write_Eol;
 172
 173          Write_Str ("  copying from file name = ");
 174          Write_Name (File_Name (Xold));
 175          Write_Eol;
 176
 177          Write_Str ("  old source index = ");
 178          Write_Int (Int (Xold));
 179          Write_Eol;
 180
 181          Write_Str ("  old lo = ");
 182          Write_Int (Int (A.Lo));
 183          Write_Eol;
 184
 185          Write_Str ("  old hi = ");
 186          Write_Int (Int (A.Hi));
 187          Write_Eol;
 188
 189          Write_Str ("  new lo = ");
 190          Write_Int (Int (Source_File.Table (Xnew).Source_First));
 191          Write_Eol;
 192
 193          Write_Str ("  new hi = ");
 194          Write_Int (Int (Source_File.Table (Xnew).Source_Last));
 195          Write_Eol;
 196
 197          Write_Str ("  adjustment factor = ");
 198          Write_Int (Int (A.Adjust));
 199          Write_Eol;
 200
 201          Write_Str ("  instantiation location: ");
 202          Write_Location (Sloc (Inst_Node));
 203          Write_Eol;
 204       end if;
 205
 206       --  For a given character in the source, a higher subscript will be
 207       --  used to access the instantiation, which means that the virtual
 208       --  origin must have a corresponding lower value. We compute this
 209       --  new origin by taking the address of the appropriate adjusted
 210       --  element in the old array. Since this adjusted element will be
 211       --  at a negative subscript, we must suppress checks.
 212
 213       declare
 214          pragma Suppress (All_Checks);
 215
 216          function To_Source_Buffer_Ptr is new
 217            Unchecked_Conversion (Address, Source_Buffer_Ptr);
 218
 219       begin
 220          Source_File.Table (Xnew).Source_Text :=
 221            To_Source_Buffer_Ptr
 222              (Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
 223       end;
 224
 225    end Create_Instantiation_Source;
 226
 227    ----------------------
 228    -- Load_Config_File --
 229    ----------------------
 230
 231    function Load_Config_File
 232      (N    : File_Name_Type)
 233       return Source_File_Index
 234    is
 235    begin
 236       return Load_File (N, Osint.Config);
 237    end Load_Config_File;
 238
 239    ---------------
 240    -- Load_File --
 241    ---------------
 242
 243    function Load_File
 244      (N :    File_Name_Type;
 245       T :    File_Type)
 246       return Source_File_Index
 247    is
 248       Src  : Source_Buffer_Ptr;
 249       X    : Source_File_Index;
 250       Lo   : Source_Ptr;
 251       Hi   : Source_Ptr;
 252
 253    begin
 254       for J in 1 .. Source_File.Last loop
 255          if Source_File.Table (J).File_Name = N then
 256             return J;
 257          end if;
 258       end loop;
 259
 260       --  Here we must build a new entry in the file table
 261
 262       Source_File.Increment_Last;
 263       X := Source_File.Last;
 264
 265       if X = Source_File.First then
 266          Lo := First_Source_Ptr;
 267       else
 268          Lo := Source_File.Table (X - 1).Source_Last + 1;
 269       end if;
 270
 271       Read_Source_File (N, Lo, Hi, Src, T);
 272
 273       if Src = null then
 274          Source_File.Decrement_Last;
 275          return No_Source_File;
 276
 277       else
 278          if Debug_Flag_L then
 279             Write_Eol;
 280             Write_Str ("*** Build source file table entry, Index = ");
 281             Write_Int (Int (X));
 282             Write_Str (", file name = ");
 283             Write_Name (N);
 284             Write_Eol;
 285             Write_Str ("  lo = ");
 286             Write_Int (Int (Lo));
 287             Write_Eol;
 288             Write_Str ("  hi = ");
 289             Write_Int (Int (Hi));
 290             Write_Eol;
 291
 292             Write_Str ("  first 10 chars -->");
 293
 294             declare
 295                procedure Wchar (C : Character);
 296                --  Writes character or ? for control character
 297
 298                procedure Wchar (C : Character) is
 299                begin
 300                   if C < ' ' or C in ASCII.DEL .. Character'Val (16#9F#) then
 301                      Write_Char ('?');
 302                   else
 303                      Write_Char (C);
 304                   end if;
 305                end Wchar;
 306
 307             begin
 308                for J in Lo .. Lo + 9 loop
 309                   Wchar (Src (J));
 310                end loop;
 311
 312                Write_Str ("<--");
 313                Write_Eol;
 314
 315                Write_Str ("  last 10 chars  -->");
 316
 317                for J in Hi - 10 .. Hi - 1 loop
 318                   Wchar (Src (J));
 319                end loop;
 320
 321                Write_Str ("<--");
 322                Write_Eol;
 323
 324                if Src (Hi) /= EOF then
 325                   Write_Str ("  error: no EOF at end");
 326                   Write_Eol;
 327                end if;
 328             end;
 329          end if;
 330
 331          declare
 332             S : Source_File_Record renames Source_File.Table (X);
 333
 334          begin
 335             S := (Debug_Source_Name   => Full_Source_Name,
 336                   File_Name           => N,
 337                   First_Mapped_Line   => No_Line_Number,
 338                   Full_File_Name      => Full_Source_Name,
 339                   Full_Ref_Name       => Full_Source_Name,
 340                   Identifier_Casing   => Unknown,
 341                   Instantiation       => No_Location,
 342                   Keyword_Casing      => Unknown,
 343                   Last_Source_Line    => 1,
 344                   License             => Unknown,
 345                   Lines_Table         => null,
 346                   Lines_Table_Max     => 1,
 347                   Logical_Lines_Table => null,
 348                   Num_SRef_Pragmas    => 0,
 349                   Reference_Name      => N,
 350                   Sloc_Adjust         => 0,
 351                   Source_Checksum     => 0,
 352                   Source_First        => Lo,
 353                   Source_Last         => Hi,
 354                   Source_Text         => Src,
 355                   Template            => No_Source_File,
 356                   Time_Stamp          => Current_Source_File_Stamp);
 357
 358             Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
 359             S.Lines_Table (1) := Lo;
 360          end;
 361
 362          return X;
 363       end if;
 364    end Load_File;
 365
 366    ----------------------
 367    -- Load_Source_File --
 368    ----------------------
 369
 370    function Load_Source_File
 371      (N    : File_Name_Type)
 372       return Source_File_Index
 373    is
 374    begin
 375       return Load_File (N, Osint.Source);
 376    end Load_Source_File;
 377
 378    ----------------------------
 379    -- Source_File_Is_Subunit --
 380    ----------------------------
 381
 382    function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
 383    begin
 384       Initialize_Scanner (No_Unit, X);
 385
 386       --  We scan past junk to the first interesting compilation unit
 387       --  token, to see if it is SEPARATE. We ignore WITH keywords during
 388       --  this and also PRIVATE. The reason for ignoring PRIVATE is that
 389       --  it handles some error situations, and also it is possible that
 390       --  a PRIVATE WITH feature might be approved some time in the future.
 391
 392       while Token = Tok_With
 393         or else Token = Tok_Private
 394         or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
 395       loop
 396          Scan;
 397       end loop;
 398
 399       return Token = Tok_Separate;
 400    end Source_File_Is_Subunit;
 401
 402 end Sinput.L;