gcc/ada/fname.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                F N A M E                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2017, 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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Alloc;
  33 with Table;
  34 with Types; use Types;
  35
  36 package body Fname is
  37
  38    -----------------------------
  39    -- Dummy Table Definitions --
  40    -----------------------------
  41
  42    --  The following table was used in old versions of the compiler. We retain
  43    --  the declarations here for compatibility with old tree files. The new
  44    --  version of the compiler does not use this table, and will write out a
  45    --  dummy empty table for Tree_Write.
  46
  47    type SFN_Entry is record
  48       U : Unit_Name_Type;
  49       F : File_Name_Type;
  50    end record;
  51
  52    package SFN_Table is new Table.Table (
  53      Table_Component_Type => SFN_Entry,
  54      Table_Index_Type     => Int,
  55      Table_Low_Bound      => 0,
  56      Table_Initial        => Alloc.SFN_Table_Initial,
  57      Table_Increment      => Alloc.SFN_Table_Increment,
  58      Table_Name           => "Fname_Dummy_Table");
  59
  60    function Has_Internal_Extension (Fname : String) return Boolean;
  61    pragma Inline (Has_Internal_Extension);
  62    --  True if the extension is appropriate for an internal/predefined unit.
  63    --  That means ".ads" or ".adb" for source files, and ".ali" for ALI files.
  64
  65    function Has_Prefix (X, Prefix : String) return Boolean;
  66    pragma Inline (Has_Prefix);
  67    --  True if Prefix is at the beginning of X. For example,
  68    --  Has_Prefix ("a-filename.ads", Prefix => "a-") is True.
  69
  70    ----------------------------
  71    -- Has_Internal_Extension --
  72    ----------------------------
  73
  74    function Has_Internal_Extension (Fname : String) return Boolean is
  75    begin
  76       if Fname'Length >= 4 then
  77          declare
  78             S : String renames Fname (Fname'Last - 3 .. Fname'Last);
  79          begin
  80             return S = ".ads" or else S = ".adb" or else S = ".ali";
  81          end;
  82       end if;
  83       return False;
  84    end Has_Internal_Extension;
  85
  86    ----------------
  87    -- Has_Prefix --
  88    ----------------
  89
  90    function Has_Prefix (X, Prefix : String) return Boolean is
  91    begin
  92       if X'Length >= Prefix'Length then
  93          declare
  94             S : String renames X (X'First .. X'First + Prefix'Length - 1);
  95          begin
  96             return S = Prefix;
  97          end;
  98       end if;
  99       return False;
 100    end Has_Prefix;
 101
 102    -----------------------
 103    -- Is_GNAT_File_Name --
 104    -----------------------
 105
 106    function Is_GNAT_File_Name (Fname : String) return Boolean is
 107    begin
 108       --  Check for internal extensions before checking prefixes, so we don't
 109       --  think (e.g.) "gnat.adc" is internal.
 110
 111       if not Has_Internal_Extension (Fname) then
 112          return False;
 113       end if;
 114
 115       --  Definitely internal if prefix is g-
 116
 117       if Has_Prefix (Fname, "g-") then
 118          return True;
 119       end if;
 120
 121       --  See the note in Is_Predefined_File_Name for the rationale
 122
 123       return Fname'Length = 8 and then Has_Prefix (Fname, "gnat");
 124    end Is_GNAT_File_Name;
 125
 126    function Is_GNAT_File_Name (Fname : File_Name_Type) return Boolean is
 127       Result : constant Boolean :=
 128                  Is_GNAT_File_Name (Get_Name_String (Fname));
 129    begin
 130       return Result;
 131    end Is_GNAT_File_Name;
 132
 133    ---------------------------
 134    -- Is_Internal_File_Name --
 135    ---------------------------
 136
 137    function Is_Internal_File_Name
 138      (Fname              : String;
 139       Renamings_Included : Boolean := True) return Boolean
 140    is
 141    begin
 142       if Is_Predefined_File_Name (Fname, Renamings_Included) then
 143          return True;
 144       end if;
 145
 146       return Is_GNAT_File_Name (Fname);
 147    end Is_Internal_File_Name;
 148
 149    function Is_Internal_File_Name
 150      (Fname              : File_Name_Type;
 151       Renamings_Included : Boolean := True) return Boolean
 152    is
 153       Result : constant Boolean :=
 154                  Is_Internal_File_Name
 155                    (Get_Name_String (Fname), Renamings_Included);
 156    begin
 157       return Result;
 158    end Is_Internal_File_Name;
 159
 160    -----------------------------
 161    -- Is_Predefined_File_Name --
 162    -----------------------------
 163
 164    function Is_Predefined_File_Name
 165      (Fname              : String;
 166       Renamings_Included : Boolean := True) return Boolean
 167    is
 168    begin
 169       --  Definitely false if longer than 12 characters (8.3)
 170       --  except for the Interfaces packages
 171
 172       if Fname'Length > 12
 173         and then Fname (Fname'First .. Fname'First + 1) /= "i-"
 174       then
 175          return False;
 176       end if;
 177
 178       if not Has_Internal_Extension (Fname) then
 179          return False;
 180       end if;
 181
 182       --  Definitely predefined if prefix is a- i- or s-
 183
 184       if Fname'Length >= 2 then
 185          declare
 186             S : String renames Fname (Fname'First .. Fname'First + 1);
 187          begin
 188             if S = "a-" or else S = "i-" or else S = "s-" then
 189                return True;
 190             end if;
 191          end;
 192       end if;
 193
 194       --  We include the "." in the prefixes below, so we don't match (e.g.)
 195       --  adamant.ads. So the first line matches "ada.ads", "ada.adb", and
 196       --  "ada.ali". But that's not necessary if they have 8 characters.
 197
 198       if Has_Prefix (Fname, "ada.")             --  Ada
 199         or else Has_Prefix (Fname, "interfac")  --  Interfaces
 200         or else Has_Prefix (Fname, "system.a")  --  System
 201       then
 202          return True;
 203       end if;
 204
 205       --  If instructed and the name has 8+ characters, check for renamings
 206
 207       if Renamings_Included
 208         and then Is_Predefined_Renaming_File_Name (Fname)
 209       then
 210          return True;
 211       end if;
 212
 213       return False;
 214    end Is_Predefined_File_Name;
 215
 216    function Is_Predefined_File_Name
 217      (Fname              : File_Name_Type;
 218       Renamings_Included : Boolean := True) return Boolean
 219    is
 220       Result : constant Boolean :=
 221                  Is_Predefined_File_Name
 222                    (Get_Name_String (Fname), Renamings_Included);
 223    begin
 224       return Result;
 225    end Is_Predefined_File_Name;
 226
 227    --------------------------------------
 228    -- Is_Predefined_Renaming_File_Name --
 229    --------------------------------------
 230
 231    function Is_Predefined_Renaming_File_Name
 232      (Fname : String) return Boolean
 233    is
 234       subtype Str8 is String (1 .. 8);
 235
 236       Renaming_Names : constant array (1 .. 8) of Str8 :=
 237         ("calendar",   --  Calendar
 238          "machcode",   --  Machine_Code
 239          "unchconv",   --  Unchecked_Conversion
 240          "unchdeal",   --  Unchecked_Deallocation
 241          "directio",   --  Direct_IO
 242          "ioexcept",   --  IO_Exceptions
 243          "sequenio",   --  Sequential_IO
 244          "text_io.");  --  Text_IO
 245    begin
 246       --  Definitely false if longer than 12 characters (8.3)
 247
 248       if Fname'Length in 8 .. 12 then
 249          declare
 250             S : String renames Fname (Fname'First .. Fname'First + 7);
 251          begin
 252             for J in Renaming_Names'Range loop
 253                if S = Renaming_Names (J) then
 254                   return True;
 255                end if;
 256             end loop;
 257          end;
 258       end if;
 259
 260       return False;
 261    end Is_Predefined_Renaming_File_Name;
 262
 263    function Is_Predefined_Renaming_File_Name
 264      (Fname : File_Name_Type) return Boolean is
 265       Result : constant Boolean :=
 266                  Is_Predefined_Renaming_File_Name (Get_Name_String (Fname));
 267    begin
 268       return Result;
 269    end Is_Predefined_Renaming_File_Name;
 270
 271    ---------------
 272    -- Tree_Read --
 273    ---------------
 274
 275    procedure Tree_Read is
 276    begin
 277       SFN_Table.Tree_Read;
 278    end Tree_Read;
 279
 280    ----------------
 281    -- Tree_Write --
 282    ----------------
 283
 284    procedure Tree_Write is
 285    begin
 286       SFN_Table.Tree_Write;
 287    end Tree_Write;
 288
 289 end Fname;