+2017-04-25 Bob Duff <duff@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Should_Ignore_Pragma): New function
+ that returns True when appropriate.
+ * par-prag.adb, exp_prag.adb, sem_prag.adb: Do not ignore pragmas
+ when compiling predefined files.
+ * fname.ads, fname.adb (Is_Predefined_File_Name): Fix bug:
+ "gnat.adc" should not be considered a predefined file name.
+ That required (or at least encouraged) a lot of cleanup of global
+ variable usage. We shouldn't be communicating information via
+ the global name buffer.
+ * bindgen.adb, errout.adb, fname-uf.adb, lib-load.adb, make.adb,
+ * restrict.adb, sem_ch10.adb, sem_ch6.adb, sem_ch8.adb: Changes
+ required by the above-mentioned cleanup.
+
+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * osint.adb (Find_File): Handle properly a request for a
+ configuration file whose name is a directory.
+
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* sem_attr.adb, sem_ch5.adb: Minor reformatting.
(No_Run_Time_Mode
and then Is_Predefined_File_Name (U.Sfile))
then
+ Get_Name_String (U.Sfile);
Set_String (" ");
Set_String ("E");
Set_Unit_Number (Unum);
not Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1)))
then
+ Get_Name_String (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1)));
Set_Msg_Str (" defined");
Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag);
-- the back end or the expander here does not get overenthusiastic and
-- start processing such a pragma!
- if Get_Name_Table_Boolean3 (Pname) then
+ if Should_Ignore_Pragma (Pname) then
Rewrite (N, Make_Null_Statement (Sloc (N)));
return;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Determine if we have a predefined file name
- Name_Len := Uname'Length;
- Name_Buffer (1 .. Name_Len) := Uname;
Is_Predef :=
- Is_Predefined_File_Name (Renamings_Included => True);
+ Is_Predefined_File_Name
+ (Uname, Renamings_Included => True);
-- Found a match, execute the pattern
Table_Increment => Alloc.SFN_Table_Increment,
Table_Name => "Fname_Dummy_Table");
+ function Has_Prefix (X, Prefix : String) return Boolean;
+ -- True if Prefix is at the beginning of X. For example,
+ -- Has_Prefix("a-filename.ads", Prefix => "a-") is True.
+
+ function Has_Suffix (X, Suffix : String) return Boolean;
+ -- True if Suffix is at the end of X
+
+ function Has_Internal_Extension (Fname : String) return Boolean;
+ -- True if the extension is ".ads" or ".adb", as is always the case for
+ -- internal/predefined units.
+
+ ----------------------------
+ -- Has_Internal_Extension --
+ ----------------------------
+
+ function Has_Internal_Extension (Fname : String) return Boolean is
+ begin
+ return Has_Suffix (Fname, Suffix => ".ads")
+ or else Has_Suffix (Fname, Suffix => ".adb");
+ end Has_Internal_Extension;
+
+ ----------------
+ -- Has_Prefix --
+ ----------------
+
+ function Has_Prefix (X, Prefix : String) return Boolean is
+ begin
+ if X'Length >= Prefix'Length then
+ declare
+ Slice : String renames
+ X (X'First .. X'First + Prefix'Length - 1);
+ begin
+ return Slice = Prefix;
+ end;
+ end if;
+ return False;
+ end Has_Prefix;
+
+ ----------------
+ -- Has_Suffix --
+ ----------------
+
+ function Has_Suffix (X, Suffix : String) return Boolean is
+ begin
+ if X'Length >= Suffix'Length then
+ declare
+ Slice : String renames
+ X (X'Last - Suffix'Length + 1 .. X'Last);
+ begin
+ return Slice = Suffix;
+ end;
+ end if;
+ return False;
+ end Has_Suffix;
+
---------------------------
-- Is_Internal_File_Name --
---------------------------
function Is_Internal_File_Name
- (Fname : File_Name_Type;
- Renamings_Included : Boolean := True) return Boolean
- is
+ (Fname : String;
+ Renamings_Included : Boolean := True) return Boolean is
begin
- if Is_Predefined_File_Name (Fname, Renamings_Included) then
- return True;
-
- -- Once Is_Predefined_File_Name has been called and returns False,
- -- Name_Buffer contains Fname and Name_Len is set to 8.
+ -- Check for internal extensions first, so we don't think (e.g.)
+ -- "gnat.adc" is internal.
- elsif Name_Buffer (1 .. 2) = "g-"
- or else Name_Buffer (1 .. 8) = "gnat "
- then
- return True;
-
- else
+ if not Has_Internal_Extension (Fname) then
return False;
end if;
- end Is_Internal_File_Name;
-
- -----------------------------
- -- Is_Predefined_File_Name --
- -----------------------------
- -- This should really be a test of unit name, given the possibility of
- -- pragma Source_File_Name setting arbitrary file names for any files???
-
- -- Once Is_Predefined_File_Name has been called and returns False,
- -- Name_Buffer contains Fname and Name_Len is set to 8. This is used
- -- only by Is_Internal_File_Name, and is not part of the official
- -- external interface of this function.
+ return Is_Predefined_File_Name (Fname, Renamings_Included)
+ or else Has_Prefix (Fname, Prefix => "g-")
+ or else Has_Prefix (Fname, Prefix => "gnat.ad");
+ end Is_Internal_File_Name;
- function Is_Predefined_File_Name
+ function Is_Internal_File_Name
(Fname : File_Name_Type;
Renamings_Included : Boolean := True) return Boolean
is
begin
- Get_Name_String (Fname);
- return Is_Predefined_File_Name (Renamings_Included);
- end Is_Predefined_File_Name;
-
- function Is_Predefined_File_Name
- (Renamings_Included : Boolean := True) return Boolean
- is
- subtype Str8 is String (1 .. 8);
-
- Predef_Names : constant array (1 .. 11) of Str8 :=
- ("ada ", -- Ada
- "interfac", -- Interfaces
- "system ", -- System
-
- -- Remaining entries are only considered if Renamings_Included true
-
- "calendar", -- Calendar
- "machcode", -- Machine_Code
- "unchconv", -- Unchecked_Conversion
- "unchdeal", -- Unchecked_Deallocation
- "directio", -- Direct_IO
- "ioexcept", -- IO_Exceptions
- "sequenio", -- Sequential_IO
- "text_io "); -- Text_IO
+ return Is_Internal_File_Name
+ (Get_Name_String (Fname), Renamings_Included);
+ end Is_Internal_File_Name;
- Num_Entries : constant Natural :=
- 3 + 8 * Boolean'Pos (Renamings_Included);
+ -----------------------------
+ -- Is_Predefined_File_Name --
+ -----------------------------
+ function Is_Predefined_File_Name
+ (Fname : String;
+ Renamings_Included : Boolean := True) return Boolean is
begin
- -- Remove extension (if present)
-
- if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then
- Name_Len := Name_Len - 4;
+ if not Has_Internal_Extension (Fname) then
+ return False;
end if;
- -- Definitely predefined if prefix is a- i- or s- followed by letter
-
- if Name_Len >= 3
- and then Name_Buffer (2) = '-'
- and then (Name_Buffer (1) = 'a'
- or else
- Name_Buffer (1) = 'i'
- or else
- Name_Buffer (1) = 's')
- and then (Name_Buffer (3) in 'a' .. 'z'
- or else
- Name_Buffer (3) in 'A' .. 'Z')
+ if Has_Prefix (Fname, "a-")
+ or else Has_Prefix (Fname, "i-")
+ or else Has_Prefix (Fname, "s-")
then
return True;
+ end if;
-- Definitely false if longer than 12 characters (8.3)
- elsif Name_Len > 8 then
+ if Fname'Length > 12 then
return False;
end if;
- -- Otherwise check against special list, first padding to 8 characters
-
- while Name_Len < 8 loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := ' ';
- end loop;
+ if Has_Prefix (Fname, Prefix => "ada.ad") -- Ada
+ or else Has_Prefix (Fname, Prefix => "interfac.ad") -- Interfaces
+ or else Has_Prefix (Fname, Prefix => "system.ad") -- System
+ then
+ return True;
+ end if;
- for J in 1 .. Num_Entries loop
- if Name_Buffer (1 .. 8) = Predef_Names (J) then
- return True;
- end if;
- end loop;
+ if not Renamings_Included then
+ return False;
+ end if;
- -- Note: when we return False here, the Name_Buffer contains the
- -- padded file name. This is not defined for clients of the package,
- -- but is used by Is_Internal_File_Name.
+ -- The following are the predefined renamings
+
+ return Has_Prefix (Fname, Prefix => "calendar.ad") -- Calendar
+ or else Has_Prefix (Fname, Prefix => "machcode.ad") -- Machine_Code
+ or else Has_Prefix (Fname, Prefix => "unchconv.ad")
+ -- Unchecked_Conversion
+ or else Has_Prefix (Fname, Prefix => "unchdeal.ad")
+ -- Unchecked_Deallocation
+ or else Has_Prefix (Fname, Prefix => "directio.ad") -- Direct_IO
+ or else Has_Prefix (Fname, Prefix => "ioexcept.ad") -- IO_Exceptions
+ or else Has_Prefix (Fname, Prefix => "sequenio.ad") -- Sequential_IO
+ or else Has_Prefix (Fname, Prefix => "text_io.ad"); -- Text_IO
+ end Is_Predefined_File_Name;
- return False;
+ function Is_Predefined_File_Name
+ (Fname : File_Name_Type;
+ Renamings_Included : Boolean := True) return Boolean
+ is
+ begin
+ return Is_Predefined_File_Name
+ (Get_Name_String (Fname), Renamings_Included);
end Is_Predefined_File_Name;
---------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-----------------
function Is_Predefined_File_Name
- (Fname : File_Name_Type;
+ (Fname : String;
Renamings_Included : Boolean := True) return Boolean;
- -- This function determines if the given file name (which must be a simple
- -- file name with no directory information) is the file name for one of the
- -- predefined library units (i.e. part of the Ada, System, or Interface
- -- hierarchies). Note that units in the GNAT hierarchy are not considered
- -- predefined (see Is_Internal_File_Name below). On return, Name_Buffer
- -- contains the file name. The Renamings_Included parameter indicates
- -- whether annex J renamings such as Text_IO are to be considered as
- -- predefined. If Renamings_Included is True, then Text_IO will return
- -- True, otherwise only children of Ada, Interfaces and System return True.
-
function Is_Predefined_File_Name
- (Renamings_Included : Boolean := True) return Boolean;
- -- This version is called with the file name already in Name_Buffer
+ (Fname : File_Name_Type;
+ Renamings_Included : Boolean := True) return Boolean;
+ -- These functions determine if the given file name (which must be a
+ -- simple file name with no directory information) is the file name for
+ -- one of the predefined library units (i.e. part of the Ada, System, or
+ -- Interface hierarchies). Note that units in the GNAT hierarchy are not
+ -- considered predefined (see Is_Internal_File_Name below). The
+ -- Renamings_Included parameter indicates whether annex J renamings such as
+ -- Text_IO are to be considered as predefined. If Renamings_Included is
+ -- True, then Text_IO will return True, otherwise only children of Ada,
+ -- Interfaces and System return True.
+ function Is_Internal_File_Name
+ (Fname : String;
+ Renamings_Included : Boolean := True) return Boolean;
function Is_Internal_File_Name
(Fname : File_Name_Type;
Renamings_Included : Boolean := True) return Boolean;
- -- Similar to Is_Predefined_File_Name. The internal file set is a superset
- -- of the predefined file set including children of GNAT.
+ -- Same as Is_Predefined_File_Name, except units in the GNAT hierarchy are
+ -- included.
procedure Tree_Read;
-- Dummy procedure (reads dummy table values from tree file)
end if;
if Present (Error_Node) then
+ Get_Name_String (Fname);
+
if Is_Predefined_File_Name (Fname) then
Error_Msg_Unit_1 := Uname_Actual;
Error_Msg
-- Generate message if unit required
if Required then
+ Get_Name_String (Fname);
+
if Is_Predefined_File_Name (Fname) then
-- This is a predefined library unit which is not present
Fname : constant File_Name_Type := Strip_Directory (S);
begin
- if Is_Predefined_File_Name (Fname, False) then
+ if Is_Predefined_File_Name
+ (Fname, Renamings_Included => False)
+ then
if Check_Readonly_Files or else Must_Compile then
Comp_Args (Comp_Args'First + 2 .. Comp_Last + 1) :=
Comp_Args (Comp_Args'First + 1 .. Comp_Last);
Found := N;
Attr.all := Unknown_Attributes;
- if T = Config and then Full_Name then
- declare
- Full_Path : constant String :=
- Normalize_Pathname (Get_Name_String (N));
- Full_Size : constant Natural := Full_Path'Length;
- begin
- Name_Buffer (1 .. Full_Size) := Full_Path;
- Name_Len := Full_Size;
- Found := Name_Find;
- end;
+ if T = Config then
+ if Full_Name then
+ declare
+ Full_Path : constant String :=
+ Normalize_Pathname (Get_Name_String (N));
+ Full_Size : constant Natural := Full_Path'Length;
+
+ begin
+ Name_Buffer (1 .. Full_Size) := Full_Path;
+ Name_Len := Full_Size;
+ Found := Name_Find;
+ end;
+ end if;
+
+ -- Check that it is a file, not a directory
+
+ if not Is_Regular_File (Get_Name_String (Found)) then
+ Found := No_File;
+ end if;
end if;
return;
-- Ignore pragma previously flagged by Ignore_Pragma
- if Get_Name_Table_Boolean3 (Prag_Name) then
+ if Should_Ignore_Pragma (Prag_Name) then
return Pragma_Node;
end if;
Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Alias (Overridden_Subp))))
then
+ Get_Name_String
+ (Unit_File_Name (Get_Source_Unit (Alias (Overridden_Subp))));
Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
elsif Is_Subprogram (Subp) then
-- children of Ada.Numerics, which are never loaded by Rtsfind).
if Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
- and then Name_Buffer (1 .. 3) /= "a-n"
+ and then Get_Name_String
+ (Unit_File_Name (Current_Sem_Unit)) (1 .. 3) /= "a-n"
and then
Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration
then
-- Ignore pragma if Ignore_Pragma applies
- if Get_Name_Table_Boolean3 (Pname) then
+ if Should_Ignore_Pragma (Pname) then
return;
end if;
Set_Alignment (T1, Alignment (T2));
end Set_Size_Info;
+ --------------------------
+ -- Should_Ignore_Pragma --
+ --------------------------
+
+ function Should_Ignore_Pragma (Prag_Name : Name_Id) return Boolean is
+ begin
+ return not Is_Internal_File_Name (File_Name (Current_Source_File))
+ and then Get_Name_Table_Boolean3 (Prag_Name);
+ end Should_Ignore_Pragma;
+
--------------------
-- Static_Boolean --
--------------------
function Scope_Is_Transient return Boolean;
-- True if the current scope is transient
+ function Should_Ignore_Pragma (Prag_Name : Name_Id) return Boolean;
+ -- True if we should ignore pragmas with the specified name. In particular,
+ -- this returns True if pragma Ignore_Pragma applies, and we are not in a
+ -- predefined unit.
+
function Static_Boolean (N : Node_Id) return Uint;
-- This function analyzes the given expression node and then resolves it
-- as Standard.Boolean. If the result is static, then Uint_1 or Uint_0 is
projects / gcc.git / commitdiff