From b043ae011153849317d63552814f54104999eeb0 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 11:00:45 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Bob Duff * 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 * osint.adb (Find_File): Handle properly a request for a configuration file whose name is a directory. From-SVN: r247151 --- gcc/ada/ChangeLog | 20 +++++ gcc/ada/bindgen.adb | 1 + gcc/ada/errout.adb | 1 + gcc/ada/exp_prag.adb | 2 +- gcc/ada/fname-uf.adb | 7 +- gcc/ada/fname.adb | 195 ++++++++++++++++++++++++------------------- gcc/ada/fname.ads | 34 ++++---- gcc/ada/lib-load.adb | 4 + gcc/ada/make.adb | 4 +- gcc/ada/osint.adb | 29 ++++--- gcc/ada/par-prag.adb | 2 +- gcc/ada/sem_ch6.adb | 2 + gcc/ada/sem_ch8.adb | 3 +- gcc/ada/sem_prag.adb | 2 +- gcc/ada/sem_util.adb | 10 +++ gcc/ada/sem_util.ads | 5 ++ 16 files changed, 201 insertions(+), 120 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e9ef0397efa..3f938e8364c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,23 @@ +2017-04-25 Bob Duff + + * 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 + + * osint.adb (Find_File): Handle properly a request for a + configuration file whose name is a directory. + 2017-04-25 Hristian Kirtchev * sem_attr.adb, sem_ch5.adb: Minor reformatting. diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index b4d7cecc385..e87b251fa13 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -1275,6 +1275,7 @@ package body Bindgen is (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); diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 7a244fb5800..40eaf91b942 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2734,6 +2734,7 @@ package body Errout is 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); diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index e2a6753003e..b83cc38da21 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -168,7 +168,7 @@ package body Exp_Prag is -- 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; diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb index 7bf27dbe22b..cc639fb33f1 100644 --- a/gcc/ada/fname-uf.adb +++ b/gcc/ada/fname-uf.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -302,10 +302,9 @@ package body Fname.UF is -- 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 diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb index e17aa346bd5..9ee2e9a936c 100644 --- a/gcc/ada/fname.adb +++ b/gcc/ada/fname.adb @@ -57,122 +57,147 @@ package body Fname is 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; --------------- diff --git a/gcc/ada/fname.ads b/gcc/ada/fname.ads index 79c84c6cc8a..88c402aaf5d 100644 --- a/gcc/ada/fname.ads +++ b/gcc/ada/fname.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -63,27 +63,29 @@ package Fname is ----------------- 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) diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb index c66fd7264d2..f68e40e962f 100644 --- a/gcc/ada/lib-load.adb +++ b/gcc/ada/lib-load.adb @@ -582,6 +582,8 @@ package body Lib.Load is 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 @@ -785,6 +787,8 @@ package body Lib.Load is -- 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 diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index 4fd741c1be6..bfdd2163f41 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -2944,7 +2944,9 @@ package body Make is 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); diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 8c6c22b9d14..d5f63075fa8 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -1189,16 +1189,25 @@ package body Osint is 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; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 0046badb39f..85cd8998549 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -294,7 +294,7 @@ begin -- 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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index b07730a0d90..b8eb6ad4267 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6101,6 +6101,8 @@ package body Sem_Ch6 is 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 diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 2fc7322fcb1..2875579fa08 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3631,7 +3631,8 @@ package body Sem_Ch8 is -- 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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index a03582738b1..c16973763dd 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -10352,7 +10352,7 @@ package body Sem_Prag is -- Ignore pragma if Ignore_Pragma applies - if Get_Name_Table_Boolean3 (Pname) then + if Should_Ignore_Pragma (Pname) then return; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5ab9b963787..700203598ab 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -20499,6 +20499,16 @@ package body Sem_Util is 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 -- -------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index fb0bdf33a0c..06be2f87fd2 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2335,6 +2335,11 @@ package Sem_Util is 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 -- 2.30.2