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