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-2023, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 package body Fname is
  27
  28    function Has_Internal_Extension (Fname : String) return Boolean;
  29    pragma Inline (Has_Internal_Extension);
  30    --  True if the extension is appropriate for an internal/predefined unit.
  31    --  That means ".ads" or ".adb" for source files, and ".ali" for ALI files.
  32
  33    function Has_Prefix (X, Prefix : String) return Boolean;
  34    pragma Inline (Has_Prefix);
  35    --  True if Prefix is at the beginning of X. For example,
  36    --  Has_Prefix ("a-filename.ads", Prefix => "a-") is True.
  37
  38    ----------------------------
  39    -- Has_Internal_Extension --
  40    ----------------------------
  41
  42    function Has_Internal_Extension (Fname : String) return Boolean is
  43    begin
  44       if Fname'Length >= 4 then
  45          declare
  46             S : String renames Fname (Fname'Last - 3 .. Fname'Last);
  47          begin
  48             return S = ".ads" or else S = ".adb" or else S = ".ali";
  49          end;
  50       end if;
  51       return False;
  52    end Has_Internal_Extension;
  53
  54    ----------------
  55    -- Has_Prefix --
  56    ----------------
  57
  58    function Has_Prefix (X, Prefix : String) return Boolean is
  59    begin
  60       if X'Length >= Prefix'Length then
  61          declare
  62             S : String renames X (X'First .. X'First + Prefix'Length - 1);
  63          begin
  64             return S = Prefix;
  65          end;
  66       end if;
  67       return False;
  68    end Has_Prefix;
  69
  70    -----------------------
  71    -- Is_GNAT_File_Name --
  72    -----------------------
  73
  74    function Is_GNAT_File_Name (Fname : String) return Boolean is
  75    begin
  76       --  Check for internal extensions before checking prefixes, so we don't
  77       --  think (e.g.) "gnat.adc" is internal.
  78
  79       if not Has_Internal_Extension (Fname) then
  80          return False;
  81       end if;
  82
  83       --  Definitely internal if prefix is g-
  84
  85       if Has_Prefix (Fname, "g-") then
  86          return True;
  87       end if;
  88
  89       --  See the note in Is_Predefined_File_Name for the rationale
  90
  91       return Fname'Length = 8 and then Has_Prefix (Fname, "gnat");
  92    end Is_GNAT_File_Name;
  93
  94    function Is_GNAT_File_Name (Fname : File_Name_Type) return Boolean is
  95       Result : constant Boolean :=
  96                  Is_GNAT_File_Name (Get_Name_String (Fname));
  97    begin
  98       return Result;
  99    end Is_GNAT_File_Name;
 100
 101    ---------------------------
 102    -- Is_Internal_File_Name --
 103    ---------------------------
 104
 105    function Is_Internal_File_Name
 106      (Fname              : String;
 107       Renamings_Included : Boolean := True) return Boolean
 108    is
 109    begin
 110       if Is_Predefined_File_Name (Fname, Renamings_Included) then
 111          return True;
 112       end if;
 113
 114       return Is_GNAT_File_Name (Fname);
 115    end Is_Internal_File_Name;
 116
 117    function Is_Internal_File_Name
 118      (Fname              : File_Name_Type;
 119       Renamings_Included : Boolean := True) return Boolean
 120    is
 121       Result : constant Boolean :=
 122                  Is_Internal_File_Name
 123                    (Get_Name_String (Fname), Renamings_Included);
 124    begin
 125       return Result;
 126    end Is_Internal_File_Name;
 127
 128    -----------------------------
 129    -- Is_Predefined_File_Name --
 130    -----------------------------
 131
 132    function Is_Predefined_File_Name
 133      (Fname              : String;
 134       Renamings_Included : Boolean := True) return Boolean
 135    is
 136    begin
 137       --  Definitely false if longer than 12 characters (8.3), except for the
 138       --  Interfaces packages and also the implementation units of the 128-bit
 139       --  types under System.
 140
 141       if Fname'Length > 12
 142         and then Fname (Fname'First .. Fname'First + 1) /= "i-"
 143         and then Fname (Fname'First .. Fname'First + 1) /= "s-"
 144       then
 145          return False;
 146       end if;
 147
 148       if not Has_Internal_Extension (Fname) then
 149          return False;
 150       end if;
 151
 152       --  Definitely predefined if prefix is a- i- or s-
 153
 154       if Fname'Length >= 2 then
 155          declare
 156             S : String renames Fname (Fname'First .. Fname'First + 1);
 157          begin
 158             if S = "a-" or else S = "i-" or else S = "s-" then
 159                return True;
 160             end if;
 161          end;
 162       end if;
 163
 164       --  We include the "." in the prefixes below, so we don't match (e.g.)
 165       --  adamant.ads. So the first line matches "ada.ads", "ada.adb", and
 166       --  "ada.ali". But that's not necessary if they have 8 characters.
 167
 168       if Has_Prefix (Fname, "ada.")             --  Ada
 169         or else Has_Prefix (Fname, "interfac")  --  Interfaces
 170         or else Has_Prefix (Fname, "system.a")  --  System
 171       then
 172          return True;
 173       end if;
 174
 175       --  If instructed and the name has 8+ characters, check for renamings
 176
 177       if Renamings_Included
 178         and then Is_Predefined_Renaming_File_Name (Fname)
 179       then
 180          return True;
 181       end if;
 182
 183       return False;
 184    end Is_Predefined_File_Name;
 185
 186    function Is_Predefined_File_Name
 187      (Fname              : File_Name_Type;
 188       Renamings_Included : Boolean := True) return Boolean
 189    is
 190       Result : constant Boolean :=
 191                  Is_Predefined_File_Name
 192                    (Get_Name_String (Fname), Renamings_Included);
 193    begin
 194       return Result;
 195    end Is_Predefined_File_Name;
 196
 197    --------------------------------------
 198    -- Is_Predefined_Renaming_File_Name --
 199    --------------------------------------
 200
 201    function Is_Predefined_Renaming_File_Name
 202      (Fname : String) return Boolean
 203    is
 204       subtype Str8 is String (1 .. 8);
 205
 206       Renaming_Names : constant array (1 .. 8) of Str8 :=
 207         ("calendar",   --  Calendar
 208          "machcode",   --  Machine_Code
 209          "unchconv",   --  Unchecked_Conversion
 210          "unchdeal",   --  Unchecked_Deallocation
 211          "directio",   --  Direct_IO
 212          "ioexcept",   --  IO_Exceptions
 213          "sequenio",   --  Sequential_IO
 214          "text_io.");  --  Text_IO
 215    begin
 216       --  Definitely false if longer than 12 characters (8.3)
 217
 218       if Fname'Length in 8 .. 12 then
 219          declare
 220             S : String renames Fname (Fname'First .. Fname'First + 7);
 221          begin
 222             for J in Renaming_Names'Range loop
 223                if S = Renaming_Names (J) then
 224                   return True;
 225                end if;
 226             end loop;
 227          end;
 228       end if;
 229
 230       return False;
 231    end Is_Predefined_Renaming_File_Name;
 232
 233    function Is_Predefined_Renaming_File_Name
 234      (Fname : File_Name_Type) return Boolean is
 235       Result : constant Boolean :=
 236                  Is_Predefined_Renaming_File_Name (Get_Name_String (Fname));
 237    begin
 238       return Result;
 239    end Is_Predefined_Renaming_File_Name;
 240
 241 end Fname;