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