[Ada] Ignore_Pragma causes errors in the run-time system

Message ID	20170425090101.GA63523@adacore.com
State	New
Headers	show Return-Path: <gcc-patches-return-452022-incoming=patchwork.ozlabs.org@gcc.gnu.org> DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=kEm+Wr6Ou603ytuiNZcQEpooSgwN8B76Pr6ynHaHPty0/ktUpz 7i0mS+fPgu6nUlqihIyoLu9OxLd0A+9zNhGtNMMJ4sgpyigik1mvyjr25To62CgV GFGe+BoCAaY3YbRI3W4kBOxWXEpKGFSMkEFsG3Qdu8hKHVvZ9xMER0his= Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk Sender: gcc-patches-owner@gcc.gnu.org Date: Tue, 25 Apr 2017 05:01:01 -0400 From: Arnaud Charlet <charlet@adacore.com> To: gcc-patches@gcc.gnu.org Cc: Bob Duff <duff@adacore.com> Subject: [Ada] Ignore_Pragma causes errors in the run-time system Message-ID: <20170425090101.GA63523@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="45Z9DzgjV8m4Oswq" Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12)

Index: exp_prag.adb =================================================================== --- exp_prag.adb (revision 247135) +++ exp_prag.adb (working copy) @@ -168,7 +168,7 @@ -- 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; Index: make.adb =================================================================== --- make.adb (revision 247135) +++ make.adb (working copy) @@ -2944,7 +2944,9 @@ 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); Index: bindgen.adb =================================================================== --- bindgen.adb (revision 247135) +++ bindgen.adb (working copy) @@ -1275,6 +1275,7 @@ (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); Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 247150) +++ sem_prag.adb (working copy) @@ -10352,7 +10352,7 @@ -- Ignore pragma if Ignore_Pragma applies - if Get_Name_Table_Boolean3 (Pname) then + if Should_Ignore_Pragma (Pname) then return; end if; Index: fname-uf.adb =================================================================== --- fname-uf.adb (revision 247135) +++ fname-uf.adb (working copy) @@ -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 @@ -- 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 Index: sem_util.adb =================================================================== --- sem_util.adb (revision 247142) +++ sem_util.adb (working copy) @@ -20499,6 +20499,16 @@ 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 -- -------------------- Index: sem_util.ads =================================================================== --- sem_util.ads (revision 247140) +++ sem_util.ads (working copy) @@ -2335,6 +2335,11 @@ 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 Index: errout.adb =================================================================== --- errout.adb (revision 247135) +++ errout.adb (working copy) @@ -2734,6 +2734,7 @@ 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); Index: lib-load.adb =================================================================== --- lib-load.adb (revision 247135) +++ lib-load.adb (working copy) @@ -582,6 +582,8 @@ 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 @@ -- 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 Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 247138) +++ sem_ch6.adb (working copy) @@ -6101,6 +6101,8 @@ 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 Index: par-prag.adb =================================================================== --- par-prag.adb (revision 247135) +++ par-prag.adb (working copy) @@ -294,7 +294,7 @@ -- 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; Index: sem_ch8.adb =================================================================== --- sem_ch8.adb (revision 247150) +++ sem_ch8.adb (working copy) @@ -3631,7 +3631,8 @@ -- 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 Index: fname.adb =================================================================== --- fname.adb (revision 247135) +++ fname.adb (working copy) @@ -57,122 +57,147 @@ 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; + -- Check for internal extensions first, so we don't think (e.g.) + -- "gnat.adc" is internal. - -- Once Is_Predefined_File_Name has been called and returns False, - -- Name_Buffer contains Fname and Name_Len is set to 8. - - 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; + + 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; - ----------------------------- - -- 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. - - 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; + return Is_Internal_File_Name + (Get_Name_String (Fname), Renamings_Included); + end Is_Internal_File_Name; + ----------------------------- + -- 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 - - Num_Entries : constant Natural := - 3 + 8 * Boolean'Pos (Renamings_Included); - + (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 + 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; - while Name_Len < 8 loop - Name_Len := Name_Len + 1; - Name_Buffer (Name_Len) := ' '; - end loop; + if not Renamings_Included then + return False; + end if; - for J in 1 .. Num_Entries loop - if Name_Buffer (1 .. 8) = Predef_Names (J) then - return True; - end if; - end loop; + -- The following are the predefined renamings - -- 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. + 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; --------------- Index: fname.ads =================================================================== --- fname.ads (revision 247135) +++ fname.ads (working copy) @@ -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 @@ ----------------- function Is_Predefined_File_Name + (Fname : String; + Renamings_Included : Boolean := True) return Boolean; + function Is_Predefined_File_Name (Fname : File_Name_Type; 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. + -- 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_Predefined_File_Name - (Renamings_Included : Boolean := True) return Boolean; - -- This version is called with the file name already in Name_Buffer - 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)

[Ada] Ignore_Pragma causes errors in the run-time system

Commit Message

Patch