gcc/gcc/ada/fname.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                F N A M E                                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Alloc;
with Table;
with Types; use Types;

package body Fname is

   -----------------------------
   -- Dummy Table Definitions --
   -----------------------------

   --  The following table was used in old versions of the compiler. We retain
   --  the declarations here for compatibility with old tree files. The new
   --  version of the compiler does not use this table, and will write out a
   --  dummy empty table for Tree_Write.

   type SFN_Entry is record
      U : Unit_Name_Type;
      F : File_Name_Type;
   end record;

   package SFN_Table is new Table.Table (
     Table_Component_Type => SFN_Entry,
     Table_Index_Type     => Int,
     Table_Low_Bound      => 0,
     Table_Initial        => Alloc.SFN_Table_Initial,
     Table_Increment      => Alloc.SFN_Table_Increment,
     Table_Name           => "Fname_Dummy_Table");

   function Has_Internal_Extension (Fname : String) return Boolean;
   pragma Inline (Has_Internal_Extension);
   --  True if the extension is appropriate for an internal/predefined unit.
   --  That means ".ads" or ".adb" for source files, and ".ali" for ALI files.

   function Has_Prefix (X, Prefix : String) return Boolean;
   pragma Inline (Has_Prefix);
   --  True if Prefix is at the beginning of X. For example,
   --  Has_Prefix ("a-filename.ads", Prefix => "a-") is True.

   ----------------------------
   -- Has_Internal_Extension --
   ----------------------------

   function Has_Internal_Extension (Fname : String) return Boolean is
   begin
      if Fname'Length >= 4 then
         declare
            S : String renames Fname (Fname'Last - 3 .. Fname'Last);
         begin
            return S = ".ads" or else S = ".adb" or else S = ".ali";
         end;
      end if;
      return False;
   end Has_Internal_Extension;

   ----------------
   -- Has_Prefix --
   ----------------

   function Has_Prefix (X, Prefix : String) return Boolean is
   begin
      if X'Length >= Prefix'Length then
         declare
            S : String renames X (X'First .. X'First + Prefix'Length - 1);
         begin
            return S = Prefix;
         end;
      end if;
      return False;
   end Has_Prefix;

   ---------------------------
   -- Is_Internal_File_Name --
   ---------------------------

   function Is_Internal_File_Name
     (Fname              : String;
      Renamings_Included : Boolean := True) return Boolean
   is
   begin
      if Is_Predefined_File_Name (Fname, Renamings_Included) then
         return True;
      end if;

      --  Check for internal extensions first, so we don't think (e.g.)
      --  "gnat.adc" is internal.

      if not Has_Internal_Extension (Fname) then
         return False;
      end if;

      --  Definitely internal if prefix is g-

      if Has_Prefix (Fname, "g-") then
         return True;
      end if;

      --  See the note in Is_Predefined_File_Name for the rationale

      return Fname'Length = 8 and then Has_Prefix (Fname, "gnat");
   end Is_Internal_File_Name;

   function Is_Internal_File_Name
     (Fname              : File_Name_Type;
      Renamings_Included : Boolean := True) return Boolean
   is
      Result : constant Boolean :=
                 Is_Internal_File_Name
                   (Get_Name_String (Fname), Renamings_Included);
   begin
      return Result;
   end Is_Internal_File_Name;

   -----------------------------
   -- Is_Predefined_File_Name --
   -----------------------------

   function Is_Predefined_File_Name
     (Fname              : String;
      Renamings_Included : Boolean := True) return Boolean
   is
      subtype Str8 is String (1 .. 8);

      Renaming_Names : constant array (1 .. 8) of Str8 :=
        ("calendar",   --  Calendar
         "machcode",   --  Machine_Code
         "unchconv",   --  Unchecked_Conversion
         "unchdeal",   --  Unchecked_Deallocation
         "directio",   --  Direct_IO
         "ioexcept",   --  IO_Exceptions
         "sequenio",   --  Sequential_IO
         "text_io.");  --  Text_IO

      --  Note: the implementation is optimized to perform uniform comparisons
      --  on string slices whose length is known at compile time and is a small
      --  power of 2 (at most 8 characters); the remaining calls to Has_Prefix
      --  must be inlined to expose the compile-time known length. There must
      --  be no calls to the fallback string comparison routine (e.g. memcmp)
      --  left in the object code for the function; this can save up to 10% of
      --  the entire compilation time spent in the front end.

   begin
      if not Has_Internal_Extension (Fname) then
         return False;
      end if;

      --  Definitely predefined if prefix is a- i- or s-

      if Fname'Length >= 2 then
         declare
            S : String renames Fname (Fname'First .. Fname'First + 1);
         begin
            if S = "a-" or else S = "i-" or else S = "s-" then
               return True;
            end if;
         end;
      end if;

      --  Definitely false if longer than 12 characters (8.3)

      if Fname'Length > 12 then
         return False;
      end if;

      --  We include the "." in the prefixes below, so we don't match (e.g.)
      --  adamant.ads. So the first line matches "ada.ads", "ada.adb", and
      --  "ada.ali". But that's not necessary if they have 8 characters.

      if Has_Prefix (Fname, "ada.")             --  Ada
        or else Has_Prefix (Fname, "interfac")  --  Interfaces
        or else Has_Prefix (Fname, "system.a")  --  System
      then
         return True;
      end if;

      --  If instructed and the name has 8+ characters, check for renamings

      if Renamings_Included and then Fname'Length >= 8 then
         declare
            S : String renames Fname (Fname'First .. Fname'First + 7);
         begin
            for J in Renaming_Names'Range loop
               if S = Renaming_Names (J) then
                  return True;
               end if;
            end loop;
         end;
      end if;

      return False;
   end Is_Predefined_File_Name;

   function Is_Predefined_File_Name
     (Fname              : File_Name_Type;
      Renamings_Included : Boolean := True) return Boolean
   is
      Result : constant Boolean :=
                 Is_Predefined_File_Name
                   (Get_Name_String (Fname), Renamings_Included);
   begin
      return Result;
   end Is_Predefined_File_Name;

   ---------------
   -- Tree_Read --
   ---------------

   procedure Tree_Read is
   begin
      SFN_Table.Tree_Read;
   end Tree_Read;

   ----------------
   -- Tree_Write --
   ----------------

   procedure Tree_Write is
   begin
      SFN_Table.Tree_Write;
   end Tree_Write;

end Fname;