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-2004, 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    ---------------------------
  64    -- Is_Internal_File_Name --
  65    ---------------------------
  66
  67    function Is_Internal_File_Name
  68      (Fname              : File_Name_Type;
  69       Renamings_Included : Boolean := True) return Boolean
  70    is
  71    begin
  72       if Is_Predefined_File_Name (Fname, Renamings_Included) then
  73          return True;
  74
  75       --  Once Is_Predefined_File_Name has been called and returns False,
  76       --  Name_Buffer contains Fname and Name_Len is set to 8.
  77
  78       elsif Name_Buffer (1 .. 2) = "g-"
  79         or else Name_Buffer (1 .. 8) = "gnat    "
  80       then
  81          return True;
  82
  83       elsif OpenVMS
  84         and then
  85           (Name_Buffer (1 .. 4) = "dec-"
  86              or else Name_Buffer (1 .. 8) = "dec     ")
  87       then
  88          return True;
  89
  90       else
  91          return False;
  92       end if;
  93    end Is_Internal_File_Name;
  94
  95    -----------------------------
  96    -- Is_Predefined_File_Name --
  97    -----------------------------
  98
  99    --  This should really be a test of unit name, given the possibility of
 100    --  pragma Source_File_Name setting arbitrary file names for any files???
 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. This is used
 104    --  only by Is_Internal_File_Name, and is not part of the official
 105    --  external interface of this function.
 106
 107    function Is_Predefined_File_Name
 108      (Fname              : File_Name_Type;
 109       Renamings_Included : Boolean := True) return Boolean
 110    is
 111    begin
 112       Get_Name_String (Fname);
 113       return Is_Predefined_File_Name (Renamings_Included);
 114    end Is_Predefined_File_Name;
 115
 116    function Is_Predefined_File_Name
 117      (Renamings_Included : Boolean := True) return Boolean
 118    is
 119       subtype Str8 is String (1 .. 8);
 120
 121       Predef_Names : constant array (1 .. 11) of Str8 :=
 122         ("ada     ",       -- Ada
 123          "calendar",       -- Calendar
 124          "interfac",       -- Interfaces
 125          "system  ",       -- System
 126          "machcode",       -- Machine_Code
 127          "unchconv",       -- Unchecked_Conversion
 128          "unchdeal",       -- Unchecked_Deallocation
 129
 130          --  Remaining entries are only considered if Renamings_Included true
 131
 132          "directio",       -- Direct_IO
 133          "ioexcept",       -- IO_Exceptions
 134          "sequenio",       -- Sequential_IO
 135          "text_io ");      -- Text_IO
 136
 137          Num_Entries : constant Natural :=
 138                          7 + 4 * Boolean'Pos (Renamings_Included);
 139
 140    begin
 141       --  Remove extension (if present)
 142
 143       if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then
 144          Name_Len := Name_Len - 4;
 145       end if;
 146
 147       --  Definitely false if longer than 12 characters (8.3)
 148
 149       if Name_Len > 8 then
 150          return False;
 151
 152       --  Definitely predefined if prefix is a- i- or s-
 153
 154       elsif Name_Len > 2
 155         and then Name_Buffer (2) = '-'
 156         and then (Name_Buffer (1) = 'a' or else
 157                   Name_Buffer (1) = 'i' or else
 158                   Name_Buffer (1) = 's')
 159       then
 160          return True;
 161       end if;
 162
 163       --  Otherwise check against special list, first padding to 8 characters
 164
 165       while Name_Len < 8 loop
 166          Name_Len := Name_Len + 1;
 167          Name_Buffer (Name_Len) := ' ';
 168       end loop;
 169
 170       for J in 1 .. Num_Entries loop
 171          if Name_Buffer (1 .. 8) = Predef_Names (J) then
 172             return True;
 173          end if;
 174       end loop;
 175
 176       --  Note: when we return False here, the Name_Buffer contains the
 177       --  padded file name. This is not defined for clients of the package,
 178       --  but is used by Is_Internal_File_Name.
 179
 180       return False;
 181    end Is_Predefined_File_Name;
 182
 183    ---------------
 184    -- Tree_Read --
 185    ---------------
 186
 187    procedure Tree_Read is
 188    begin
 189       SFN_Table.Tree_Read;
 190    end Tree_Read;
 191
 192    ----------------
 193    -- Tree_Write --
 194    ----------------
 195
 196    procedure Tree_Write is
 197    begin
 198       SFN_Table.Tree_Write;
 199    end Tree_Write;
 200
 201 end Fname;