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-2003, 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 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Alloc;
  35 with Hostparm; use Hostparm;
  36 with Namet;    use Namet;
  37 with Table;
  38
  39 package body Fname is
  40
  41    -----------------------------
  42    -- Dummy Table Definitions --
  43    -----------------------------
  44
  45    --  The following table was used in old versions of the compiler. We retain
  46    --  the declarations here for compatibility with old tree files. The new
  47    --  version of the compiler does not use this table, and will write out a
  48    --  dummy empty table for Tree_Write.
  49
  50    type SFN_Entry is record
  51       U : Unit_Name_Type;
  52       F : File_Name_Type;
  53    end record;
  54
  55    package SFN_Table is new Table.Table (
  56      Table_Component_Type => SFN_Entry,
  57      Table_Index_Type     => Int,
  58      Table_Low_Bound      => 0,
  59      Table_Initial        => Alloc.SFN_Table_Initial,
  60      Table_Increment      => Alloc.SFN_Table_Increment,
  61      Table_Name           => "Fname_Dummy_Table");
  62    ----------------------------
  63    -- Get_Expected_Unit_Type --
  64    ----------------------------
  65
  66    --  We assume that a file name whose last character is a lower case b is
  67    --  a body and a file name whose last character is a lower case s is a
  68    --  spec. If any other character is found (e.g. when we are in syntax
  69    --  checking only mode, where the file name conventions are not set),
  70    --  then we return Unknown.
  71
  72    function Get_Expected_Unit_Type
  73      (Fname : File_Name_Type)
  74       return  Expected_Unit_Type
  75    is
  76    begin
  77       Get_Name_String (Fname);
  78
  79       if Name_Buffer (Name_Len) = 'b' then
  80          return Expect_Body;
  81       elsif Name_Buffer (Name_Len) = 's' then
  82          return Expect_Spec;
  83       else
  84          return Unknown;
  85       end if;
  86    end Get_Expected_Unit_Type;
  87
  88    ---------------------------
  89    -- Is_Internal_File_Name --
  90    ---------------------------
  91
  92    function Is_Internal_File_Name
  93      (Fname              : File_Name_Type;
  94       Renamings_Included : Boolean := True)
  95       return               Boolean
  96    is
  97    begin
  98       if Is_Predefined_File_Name (Fname, Renamings_Included) then
  99          return True;
 100
 101       --  Once Is_Predefined_File_Name has been called and returns False,
 102       --  Name_Buffer contains Fname and Name_Len is set to 8.
 103
 104       elsif Name_Buffer (1 .. 2) = "g-"
 105         or else Name_Buffer (1 .. 8) = "gnat    "
 106       then
 107          return True;
 108
 109       elsif OpenVMS
 110         and then
 111           (Name_Buffer (1 .. 4) = "dec-"
 112              or else Name_Buffer (1 .. 8) = "dec     ")
 113       then
 114          return True;
 115
 116       else
 117          return False;
 118       end if;
 119    end Is_Internal_File_Name;
 120
 121    -----------------------------
 122    -- Is_Predefined_File_Name --
 123    -----------------------------
 124
 125    --  This should really be a test of unit name, given the possibility of
 126    --  pragma Source_File_Name setting arbitrary file names for any files???
 127
 128    --  Once Is_Predefined_File_Name has been called and returns False,
 129    --  Name_Buffer contains Fname and Name_Len is set to 8. This is used
 130    --  only by Is_Internal_File_Name, and is not part of the official
 131    --  external interface of this function.
 132
 133    function Is_Predefined_File_Name
 134      (Fname              : File_Name_Type;
 135       Renamings_Included : Boolean := True)
 136       return               Boolean
 137    is
 138    begin
 139       Get_Name_String (Fname);
 140       return Is_Predefined_File_Name (Renamings_Included);
 141    end Is_Predefined_File_Name;
 142
 143    function Is_Predefined_File_Name
 144      (Renamings_Included : Boolean := True)
 145       return               Boolean
 146    is
 147       subtype Str8 is String (1 .. 8);
 148
 149       Predef_Names : constant array (1 .. 11) of Str8 :=
 150         ("ada     ",       -- Ada
 151          "calendar",       -- Calendar
 152          "interfac",       -- Interfaces
 153          "system  ",       -- System
 154          "machcode",       -- Machine_Code
 155          "unchconv",       -- Unchecked_Conversion
 156          "unchdeal",       -- Unchecked_Deallocation
 157
 158          --  Remaining entries are only considered if Renamings_Included true
 159
 160          "directio",       -- Direct_IO
 161          "ioexcept",       -- IO_Exceptions
 162          "sequenio",       -- Sequential_IO
 163          "text_io ");      -- Text_IO
 164
 165          Num_Entries : constant Natural :=
 166                          7 + 4 * Boolean'Pos (Renamings_Included);
 167
 168    begin
 169       --  Remove extension (if present)
 170
 171       if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then
 172          Name_Len := Name_Len - 4;
 173       end if;
 174
 175       --  Definitely false if longer than 12 characters (8.3)
 176
 177       if Name_Len > 8 then
 178          return False;
 179
 180       --  Definitely predefined if prefix is a- i- or s-
 181
 182       elsif Name_Len > 2
 183         and then Name_Buffer (2) = '-'
 184         and then (Name_Buffer (1) = 'a' or else
 185                   Name_Buffer (1) = 'i' or else
 186                   Name_Buffer (1) = 's')
 187       then
 188          return True;
 189       end if;
 190
 191       --  Otherwise check against special list, first padding to 8 characters
 192
 193       while Name_Len < 8 loop
 194          Name_Len := Name_Len + 1;
 195          Name_Buffer (Name_Len) := ' ';
 196       end loop;
 197
 198       for J in 1 .. Num_Entries loop
 199          if Name_Buffer (1 .. 8) = Predef_Names (J) then
 200             return True;
 201          end if;
 202       end loop;
 203
 204       --  Note: when we return False here, the Name_Buffer contains the
 205       --  padded file name. This is not defined for clients of the package,
 206       --  but is used by Is_Internal_File_Name.
 207
 208       return False;
 209    end Is_Predefined_File_Name;
 210
 211    ---------------
 212    -- Tree_Read --
 213    ---------------
 214
 215    procedure Tree_Read is
 216    begin
 217       SFN_Table.Tree_Read;
 218    end Tree_Read;
 219
 220    ----------------
 221    -- Tree_Write --
 222    ----------------
 223
 224    procedure Tree_Write is
 225    begin
 226       SFN_Table.Tree_Write;
 227    end Tree_Write;
 228
 229 end Fname;