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-2002, 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       subtype Str8 is String (1 .. 8);
 139
 140       Predef_Names : constant array (1 .. 11) of Str8 :=
 141         ("ada     ",       -- Ada
 142          "calendar",       -- Calendar
 143          "interfac",       -- Interfaces
 144          "system  ",       -- System
 145          "machcode",       -- Machine_Code
 146          "unchconv",       -- Unchecked_Conversion
 147          "unchdeal",       -- Unchecked_Deallocation
 148
 149          --  Remaining entries are only considered if Renamings_Included true
 150
 151          "directio",       -- Direct_IO
 152          "ioexcept",       -- IO_Exceptions
 153          "sequenio",       -- Sequential_IO
 154          "text_io ");      -- Text_IO
 155
 156          Num_Entries : constant Natural :=
 157                          7 + 4 * Boolean'Pos (Renamings_Included);
 158
 159    begin
 160       --  Get file name, removing the extension (if any)
 161
 162       Get_Name_String (Fname);
 163
 164       if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then
 165          Name_Len := Name_Len - 4;
 166       end if;
 167
 168       --  Definitely false if longer than 12 characters (8.3)
 169
 170       if Name_Len > 8 then
 171          return False;
 172
 173       --  Definitely predefined if prefix is a- i- or s-
 174
 175       elsif Name_Len > 2
 176         and then Name_Buffer (2) = '-'
 177         and then (Name_Buffer (1) = 'a' or else
 178                   Name_Buffer (1) = 'i' or else
 179                   Name_Buffer (1) = 's')
 180       then
 181          return True;
 182       end if;
 183
 184       --  Otherwise check against special list, first padding to 8 characters
 185
 186       while Name_Len < 8 loop
 187          Name_Len := Name_Len + 1;
 188          Name_Buffer (Name_Len) := ' ';
 189       end loop;
 190
 191       for J in 1 .. Num_Entries loop
 192          if Name_Buffer (1 .. 8) = Predef_Names (J) then
 193             return True;
 194          end if;
 195       end loop;
 196
 197       --  Note: when we return False here, the Name_Buffer contains the
 198       --  padded file name. This is not defined for clients of the package,
 199       --  but is used by Is_Internal_File_Name.
 200
 201       return False;
 202    end Is_Predefined_File_Name;
 203
 204    ---------------
 205    -- Tree_Read --
 206    ---------------
 207
 208    procedure Tree_Read is
 209    begin
 210       SFN_Table.Tree_Read;
 211    end Tree_Read;
 212
 213    ----------------
 214    -- Tree_Write --
 215    ----------------
 216
 217    procedure Tree_Write is
 218    begin
 219       SFN_Table.Tree_Write;
 220    end Tree_Write;
 221
 222 end Fname;