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