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-2009, 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 Hostparm; use Hostparm;
  34 with Table;
  35 with Types;    use Types;
  36
  37 package body Fname is
  38
  39    -----------------------------
  40    -- Dummy Table Definitions --
  41    -----------------------------
  42
  43    --  The following table was used in old versions of the compiler. We retain
  44    --  the declarations here for compatibility with old tree files. The new
  45    --  version of the compiler does not use this table, and will write out a
  46    --  dummy empty table for Tree_Write.
  47
  48    type SFN_Entry is record
  49       U : Unit_Name_Type;
  50       F : File_Name_Type;
  51    end record;
  52
  53    package SFN_Table is new Table.Table (
  54      Table_Component_Type => SFN_Entry,
  55      Table_Index_Type     => Int,
  56      Table_Low_Bound      => 0,
  57      Table_Initial        => Alloc.SFN_Table_Initial,
  58      Table_Increment      => Alloc.SFN_Table_Increment,
  59      Table_Name           => "Fname_Dummy_Table");
  60
  61    ---------------------------
  62    -- Is_Internal_File_Name --
  63    ---------------------------
  64
  65    function Is_Internal_File_Name
  66      (Fname              : File_Name_Type;
  67       Renamings_Included : Boolean := True) return Boolean
  68    is
  69    begin
  70       if Is_Predefined_File_Name (Fname, Renamings_Included) then
  71          return True;
  72
  73       --  Once Is_Predefined_File_Name has been called and returns False,
  74       --  Name_Buffer contains Fname and Name_Len is set to 8.
  75
  76       elsif Name_Buffer (1 .. 2) = "g-"
  77         or else Name_Buffer (1 .. 8) = "gnat    "
  78       then
  79          return True;
  80
  81       elsif OpenVMS
  82         and then
  83           (Name_Buffer (1 .. 4) = "dec-"
  84              or else Name_Buffer (1 .. 8) = "dec     ")
  85       then
  86          return True;
  87
  88       else
  89          return False;
  90       end if;
  91    end Is_Internal_File_Name;
  92
  93    -----------------------------
  94    -- Is_Predefined_File_Name --
  95    -----------------------------
  96
  97    --  This should really be a test of unit name, given the possibility of
  98    --  pragma Source_File_Name setting arbitrary file names for any files???
  99
 100    --  Once Is_Predefined_File_Name has been called and returns False,
 101    --  Name_Buffer contains Fname and Name_Len is set to 8. This is used
 102    --  only by Is_Internal_File_Name, and is not part of the official
 103    --  external interface of this function.
 104
 105    function Is_Predefined_File_Name
 106      (Fname              : File_Name_Type;
 107       Renamings_Included : Boolean := True) return Boolean
 108    is
 109    begin
 110       Get_Name_String (Fname);
 111       return Is_Predefined_File_Name (Renamings_Included);
 112    end Is_Predefined_File_Name;
 113
 114    function Is_Predefined_File_Name
 115      (Renamings_Included : Boolean := True) return Boolean
 116    is
 117       subtype Str8 is String (1 .. 8);
 118
 119       Predef_Names : constant array (1 .. 11) of Str8 :=
 120         ("ada     ",       -- Ada
 121          "interfac",       -- Interfaces
 122          "system  ",       -- System
 123
 124          --  Remaining entries are only considered if Renamings_Included true
 125
 126          "calendar",       -- Calendar
 127          "machcode",       -- Machine_Code
 128          "unchconv",       -- Unchecked_Conversion
 129          "unchdeal",       -- Unchecked_Deallocation
 130          "directio",       -- Direct_IO
 131          "ioexcept",       -- IO_Exceptions
 132          "sequenio",       -- Sequential_IO
 133          "text_io ");      -- Text_IO
 134
 135          Num_Entries : constant Natural :=
 136                          3 + 8 * Boolean'Pos (Renamings_Included);
 137
 138    begin
 139       --  Remove extension (if present)
 140
 141       if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then
 142          Name_Len := Name_Len - 4;
 143       end if;
 144
 145       --  Definitely false if longer than 12 characters (8.3)
 146
 147       if Name_Len > 8 then
 148          return False;
 149
 150       --  Definitely predefined if prefix is a- i- or s- followed by letter
 151
 152       elsif Name_Len >=  3
 153         and then Name_Buffer (2) = '-'
 154         and then (Name_Buffer (1) = 'a'
 155                     or else
 156                   Name_Buffer (1) = 'i'
 157                     or else
 158                   Name_Buffer (1) = 's')
 159         and then (Name_Buffer (3) in 'a' .. 'z'
 160                     or else
 161                   Name_Buffer (3) in 'A' .. 'Z')
 162       then
 163          return True;
 164       end if;
 165
 166       --  Otherwise check against special list, first padding to 8 characters
 167
 168       while Name_Len < 8 loop
 169          Name_Len := Name_Len + 1;
 170          Name_Buffer (Name_Len) := ' ';
 171       end loop;
 172
 173       for J in 1 .. Num_Entries loop
 174          if Name_Buffer (1 .. 8) = Predef_Names (J) then
 175             return True;
 176          end if;
 177       end loop;
 178
 179       --  Note: when we return False here, the Name_Buffer contains the
 180       --  padded file name. This is not defined for clients of the package,
 181       --  but is used by Is_Internal_File_Name.
 182
 183       return False;
 184    end Is_Predefined_File_Name;
 185
 186    ---------------
 187    -- Tree_Read --
 188    ---------------
 189
 190    procedure Tree_Read is
 191    begin
 192       SFN_Table.Tree_Read;
 193    end Tree_Read;
 194
 195    ----------------
 196    -- Tree_Write --
 197    ----------------
 198
 199    procedure Tree_Write is
 200    begin
 201       SFN_Table.Tree_Write;
 202    end Tree_Write;
 203
 204 end Fname;