1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
34 with Types; use Types;
38 -----------------------------
39 -- Dummy Table Definitions --
40 -----------------------------
42 -- The following table was used in old versions of the compiler. We retain
43 -- the declarations here for compatibility with old tree files. The new
44 -- version of the compiler does not use this table, and will write out a
45 -- dummy empty table for Tree_Write.
47 type SFN_Entry is record
52 package SFN_Table is new Table.Table (
53 Table_Component_Type => SFN_Entry,
54 Table_Index_Type => Int,
56 Table_Initial => Alloc.SFN_Table_Initial,
57 Table_Increment => Alloc.SFN_Table_Increment,
58 Table_Name => "Fname_Dummy_Table");
60 function Has_Internal_Extension (Fname : String) return Boolean;
61 pragma Inline (Has_Internal_Extension);
62 -- True if the extension is appropriate for an internal/predefined unit.
63 -- That means ".ads" or ".adb" for source files, and ".ali" for ALI files.
65 function Has_Prefix (X, Prefix : String) return Boolean;
66 pragma Inline (Has_Prefix);
67 -- True if Prefix is at the beginning of X. For example,
68 -- Has_Prefix ("a-filename.ads", Prefix => "a-") is True.
70 ----------------------------
71 -- Has_Internal_Extension --
72 ----------------------------
74 function Has_Internal_Extension (Fname : String) return Boolean is
76 if Fname'Length >= 4 then
78 S : String renames Fname (Fname'Last - 3 .. Fname'Last);
80 return S = ".ads" or else S = ".adb" or else S = ".ali";
84 end Has_Internal_Extension;
90 function Has_Prefix (X, Prefix : String) return Boolean is
92 if X'Length >= Prefix'Length then
94 S : String renames X (X'First .. X'First + Prefix'Length - 1);
102 -----------------------
103 -- Is_GNAT_File_Name --
104 -----------------------
106 function Is_GNAT_File_Name (Fname : String) return Boolean is
108 -- Check for internal extensions before checking prefixes, so we don't
109 -- think (e.g.) "gnat.adc" is internal.
111 if not Has_Internal_Extension (Fname) then
115 -- Definitely internal if prefix is g-
117 if Has_Prefix (Fname, "g-") then
121 -- See the note in Is_Predefined_File_Name for the rationale
123 return Fname'Length = 8 and then Has_Prefix (Fname, "gnat");
124 end Is_GNAT_File_Name;
126 function Is_GNAT_File_Name (Fname : File_Name_Type) return Boolean is
127 Result : constant Boolean :=
128 Is_GNAT_File_Name (Get_Name_String (Fname));
131 end Is_GNAT_File_Name;
133 ---------------------------
134 -- Is_Internal_File_Name --
135 ---------------------------
137 function Is_Internal_File_Name
139 Renamings_Included : Boolean := True) return Boolean
142 if Is_Predefined_File_Name (Fname, Renamings_Included) then
146 return Is_GNAT_File_Name (Fname);
147 end Is_Internal_File_Name;
149 function Is_Internal_File_Name
150 (Fname : File_Name_Type;
151 Renamings_Included : Boolean := True) return Boolean
153 Result : constant Boolean :=
154 Is_Internal_File_Name
155 (Get_Name_String (Fname), Renamings_Included);
158 end Is_Internal_File_Name;
160 -----------------------------
161 -- Is_Predefined_File_Name --
162 -----------------------------
164 function Is_Predefined_File_Name
166 Renamings_Included : Boolean := True) return Boolean
169 -- Definitely false if longer than 12 characters (8.3)
170 -- except for the Interfaces packages
173 and then Fname (Fname'First .. Fname'First + 1) /= "i-"
178 if not Has_Internal_Extension (Fname) then
182 -- Definitely predefined if prefix is a- i- or s-
184 if Fname'Length >= 2 then
186 S : String renames Fname (Fname'First .. Fname'First + 1);
188 if S = "a-" or else S = "i-" or else S = "s-" then
194 -- We include the "." in the prefixes below, so we don't match (e.g.)
195 -- adamant.ads. So the first line matches "ada.ads", "ada.adb", and
196 -- "ada.ali". But that's not necessary if they have 8 characters.
198 if Has_Prefix (Fname, "ada.") -- Ada
199 or else Has_Prefix (Fname, "interfac") -- Interfaces
200 or else Has_Prefix (Fname, "system.a") -- System
205 -- If instructed and the name has 8+ characters, check for renamings
207 if Renamings_Included
208 and then Is_Predefined_Renaming_File_Name (Fname)
214 end Is_Predefined_File_Name;
216 function Is_Predefined_File_Name
217 (Fname : File_Name_Type;
218 Renamings_Included : Boolean := True) return Boolean
220 Result : constant Boolean :=
221 Is_Predefined_File_Name
222 (Get_Name_String (Fname), Renamings_Included);
225 end Is_Predefined_File_Name;
227 --------------------------------------
228 -- Is_Predefined_Renaming_File_Name --
229 --------------------------------------
231 function Is_Predefined_Renaming_File_Name
232 (Fname : String) return Boolean
234 subtype Str8 is String (1 .. 8);
236 Renaming_Names : constant array (1 .. 8) of Str8 :=
237 ("calendar", -- Calendar
238 "machcode", -- Machine_Code
239 "unchconv", -- Unchecked_Conversion
240 "unchdeal", -- Unchecked_Deallocation
241 "directio", -- Direct_IO
242 "ioexcept", -- IO_Exceptions
243 "sequenio", -- Sequential_IO
244 "text_io."); -- Text_IO
246 -- Definitely false if longer than 12 characters (8.3)
248 if Fname'Length in 8 .. 12 then
250 S : String renames Fname (Fname'First .. Fname'First + 7);
252 for J in Renaming_Names'Range loop
253 if S = Renaming_Names (J) then
261 end Is_Predefined_Renaming_File_Name;
263 function Is_Predefined_Renaming_File_Name
264 (Fname : File_Name_Type) return Boolean is
265 Result : constant Boolean :=
266 Is_Predefined_Renaming_File_Name (Get_Name_String (Fname));
269 end Is_Predefined_Renaming_File_Name;
275 procedure Tree_Read is
284 procedure Tree_Write is
286 SFN_Table.Tree_Write;