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-2016, 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    ---------------------------
  61    -- Is_Internal_File_Name --
  62    ---------------------------
  63
  64    function Is_Internal_File_Name
  65      (Fname              : File_Name_Type;
  66       Renamings_Included : Boolean := True) return Boolean
  67    is
  68    begin
  69       if Is_Predefined_File_Name (Fname, Renamings_Included) then
  70          return True;
  71
  72       --  Once Is_Predefined_File_Name has been called and returns False,
  73       --  Name_Buffer contains Fname and Name_Len is set to 8.
  74
  75       elsif Name_Buffer (1 .. 2) = "g-"
  76         or else Name_Buffer (1 .. 8) = "gnat    "
  77       then
  78          return True;
  79
  80       else
  81          return False;
  82       end if;
  83    end Is_Internal_File_Name;
  84
  85    -----------------------------
  86    -- Is_Predefined_File_Name --
  87    -----------------------------
  88
  89    --  This should really be a test of unit name, given the possibility of
  90    --  pragma Source_File_Name setting arbitrary file names for any files???
  91
  92    --  Once Is_Predefined_File_Name has been called and returns False,
  93    --  Name_Buffer contains Fname and Name_Len is set to 8. This is used
  94    --  only by Is_Internal_File_Name, and is not part of the official
  95    --  external interface of this function.
  96
  97    function Is_Predefined_File_Name
  98      (Fname              : File_Name_Type;
  99       Renamings_Included : Boolean := True) return Boolean
 100    is
 101    begin
 102       Get_Name_String (Fname);
 103       return Is_Predefined_File_Name (Renamings_Included);
 104    end Is_Predefined_File_Name;
 105
 106    function Is_Predefined_File_Name
 107      (Renamings_Included : Boolean := True) return Boolean
 108    is
 109       subtype Str8 is String (1 .. 8);
 110
 111       Predef_Names : constant array (1 .. 11) of Str8 :=
 112         ("ada     ",       -- Ada
 113          "interfac",       -- Interfaces
 114          "system  ",       -- System
 115
 116          --  Remaining entries are only considered if Renamings_Included true
 117
 118          "calendar",       -- Calendar
 119          "machcode",       -- Machine_Code
 120          "unchconv",       -- Unchecked_Conversion
 121          "unchdeal",       -- Unchecked_Deallocation
 122          "directio",       -- Direct_IO
 123          "ioexcept",       -- IO_Exceptions
 124          "sequenio",       -- Sequential_IO
 125          "text_io ");      -- Text_IO
 126
 127          Num_Entries : constant Natural :=
 128                          3 + 8 * Boolean'Pos (Renamings_Included);
 129
 130    begin
 131       --  Remove extension (if present)
 132
 133       if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then
 134          Name_Len := Name_Len - 4;
 135       end if;
 136
 137       --  Definitely predefined if prefix is a- i- or s- followed by letter
 138
 139       if Name_Len >=  3
 140         and then Name_Buffer (2) = '-'
 141         and then (Name_Buffer (1) = 'a'
 142                     or else
 143                   Name_Buffer (1) = 'i'
 144                     or else
 145                   Name_Buffer (1) = 's')
 146         and then (Name_Buffer (3) in 'a' .. 'z'
 147                     or else
 148                   Name_Buffer (3) in 'A' .. 'Z')
 149       then
 150          return True;
 151
 152       --  Definitely false if longer than 12 characters (8.3)
 153
 154       elsif Name_Len > 8 then
 155          return False;
 156       end if;
 157
 158       --  Otherwise check against special list, first padding to 8 characters
 159
 160       while Name_Len < 8 loop
 161          Name_Len := Name_Len + 1;
 162          Name_Buffer (Name_Len) := ' ';
 163       end loop;
 164
 165       for J in 1 .. Num_Entries loop
 166          if Name_Buffer (1 .. 8) = Predef_Names (J) then
 167             return True;
 168          end if;
 169       end loop;
 170
 171       --  Note: when we return False here, the Name_Buffer contains the
 172       --  padded file name. This is not defined for clients of the package,
 173       --  but is used by Is_Internal_File_Name.
 174
 175       return False;
 176    end Is_Predefined_File_Name;
 177
 178    ---------------
 179    -- Tree_Read --
 180    ---------------
 181
 182    procedure Tree_Read is
 183    begin
 184       SFN_Table.Tree_Read;
 185    end Tree_Read;
 186
 187    ----------------
 188    -- Tree_Write --
 189    ----------------
 190
 191    procedure Tree_Write is
 192    begin
 193       SFN_Table.Tree_Write;
 194    end Tree_Write;
 195
 196 end Fname;