If Source_File_Name pragmas with patterns were used to specify a non- standard naming scheme, then the compiler would fail to diagnose an attempt to compile a spec which did not need a body when in fact a body file was present.
Given a gnat.adc file containing: 1. pragma Source_File_Name_Project 2. (Spec_File_Name => "*.1.ada", 3. Casing => lowercase, 4. Dot_Replacement => "-"); 5. pragma Source_File_Name_Project 6. (Body_File_Name => "*.2.ada", 7. Casing => lowercase, 8. Dot_Replacement => "-"); where pkg.1.ada contains 1. package Pkg is end; and pkg.2.ada contains 1. package body Pkg is end; the compiling the spec using gcc -c -x ada pkg.1.ada generates 1. package Pkg is end; | >>> package "Pkg" does not allow a body >>> remove incorrect body in file "pkg.2.ada" Previously this message was not given in this case Tested on x86_64-pc-linux-gnu, committed on trunk 2014-05-21 Robert Dewar <de...@adacore.com> * gnat1drv.adb (Check_Bad_Body): Use Source_File_Is_Body to simplify the needed test, and also deal with failure to catch situations with non-standard names. * sinput-l.ads, sinput-l.adb (Source_File_Is_No_Body): New function (Source_File_Is_Subunit): Removed, no longer used.
Index: gnat1drv.adb =================================================================== --- gnat1drv.adb (revision 210687) +++ gnat1drv.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -633,7 +633,6 @@ Sname := Unit_Name (Main_Unit); -- If we do not already have a body name, then get the body name - -- (but how can we have a body name here???) if not Is_Body_Name (Sname) then Sname := Get_Body_Name (Sname); @@ -651,19 +650,15 @@ -- to include both in a partition, this is diagnosed at bind time. In -- Ada 83 mode this is not a warning case. - -- Note: if weird file names are being used, we can have a situation - -- where the file name that supposedly contains body in fact contains - -- a spec, or we can't tell what it contains. Skip the error message - -- in these cases. + -- Note that in general we do not give the message if the file in + -- question does not look like a body. This includes weird cases, + -- but in particular means that if the file is just a No_Body pragma, + -- then we won't give the message (that's the whole point of this + -- pragma, to be used this way and to cause the body file to be + -- ignored in this context). - -- Also ignore body that is nothing but pragma No_Body; (that's the - -- whole point of this pragma, to be used this way and to cause the - -- body file to be ignored in this context). - if Src_Ind /= No_Source_File - and then Get_Expected_Unit_Type (Fname) = Expect_Body - and then not Source_File_Is_Subunit (Src_Ind) - and then not Source_File_Is_No_Body (Src_Ind) + and then Source_File_Is_Body (Src_Ind) then Errout.Finalize (Last_Call => False); @@ -693,8 +688,8 @@ else -- For generic instantiations, we never allow a body - if Nkind (Original_Node (Unit (Main_Unit_Node))) - in N_Generic_Instantiation + if Nkind (Original_Node (Unit (Main_Unit_Node))) in + N_Generic_Instantiation then Bad_Body_Error ("generic instantiation for $$ does not allow a body"); Index: sinput-l.adb =================================================================== --- sinput-l.adb (revision 210687) +++ sinput-l.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -795,10 +795,107 @@ Prep_Buffer (Prep_Buffer_Last) := C; end Put_Char_In_Prep_Buffer; - ----------------------------------- - -- Source_File_Is_Pragma_No_Body -- - ----------------------------------- + ------------------------- + -- Source_File_Is_Body -- + ------------------------- + function Source_File_Is_Body (X : Source_File_Index) return Boolean is + Pcount : Natural; + + begin + Initialize_Scanner (No_Unit, X); + + -- Loop to look for subprogram or package body + + loop + case Token is + + -- PRAGMA, WITH, USE (which can appear before a body) + + when Tok_Pragma | Tok_With | Tok_Use => + + -- We just want to skip any of these, do it by skipping to a + -- semicolon, but check for EOF, in case we have bad syntax. + + loop + if Token = Tok_Semicolon then + Scan; + exit; + elsif Token = Tok_EOF then + return False; + else + Scan; + end if; + end loop; + + -- PACKAGE + + when Tok_Package => + Scan; -- Past PACKAGE + + -- We have a body if and only if BODY follows + + return Token = Tok_Body; + + -- FUNCTION or PROCEDURE + + when Tok_Procedure | Tok_Function => + Pcount := 0; + + -- Loop through tokens following PROCEDURE or FUNCTION + + loop + Scan; + + case Token is + + -- For parens, count paren level (note that paren level + -- can get greater than 1 if we have default parameters). + + when Tok_Left_Paren => + Pcount := Pcount + 1; + + when Tok_Right_Paren => + Pcount := Pcount - 1; + + -- EOF means something weird, probably no body + + when Tok_EOF => + return False; + + -- BEGIN or IS or END definitely means body is present + + when Tok_Begin | Tok_Is | Tok_End => + return True; + + -- Semicolon means no body present if at outside any + -- parens. If within parens, ignore, since it could be + -- a parameter separator. + + when Tok_Semicolon => + if Pcount = 0 then + return False; + end if; + + -- Skip anything else + + when others => + null; + end case; + end loop; + + -- Anything else in main scan means we don't have a body + + when others => + return False; + end case; + end loop; + end Source_File_Is_Body; + + ---------------------------- + -- Source_File_Is_No_Body -- + ---------------------------- + function Source_File_Is_No_Body (X : Source_File_Index) return Boolean is begin Initialize_Scanner (No_Unit, X); @@ -826,27 +923,4 @@ return Token = Tok_EOF; end Source_File_Is_No_Body; - ---------------------------- - -- Source_File_Is_Subunit -- - ---------------------------- - - function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is - begin - Initialize_Scanner (No_Unit, X); - - -- We scan past junk to the first interesting compilation unit token, to - -- see if it is SEPARATE. We ignore WITH keywords during this and also - -- PRIVATE. The reason for ignoring PRIVATE is that it handles some - -- error situations, and also to handle PRIVATE WITH in Ada 2005 mode. - - while Token = Tok_With - or else Token = Tok_Private - or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF) - loop - Scan; - end loop; - - return Token = Tok_Separate; - end Source_File_Is_Subunit; - end Sinput.L; Index: sinput-l.ads =================================================================== --- sinput-l.ads (revision 210687) +++ sinput-l.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -64,19 +64,16 @@ -- Called on completing the parsing of a source file. This call completes -- the source file table entry for the current source file. + function Source_File_Is_Body (X : Source_File_Index) return Boolean; + -- Returns true if the designated source file contains a subprogram body + -- or a package body. This is a limited scan just to determine the answer + -- to this question.. + function Source_File_Is_No_Body (X : Source_File_Index) return Boolean; -- Returns true if the designated source file contains pragma No_Body; -- and no other tokens. If the source file contains anything other than -- this sequence of three tokens, then False is returned. - function Source_File_Is_Subunit (X : Source_File_Index) return Boolean; - -- This function determines if a source file represents a subunit. It - -- works by scanning for the first compilation unit token, and returning - -- True if it is the token SEPARATE. It will return False otherwise, - -- meaning that the file cannot possibly be a legal subunit. This - -- function does NOT do a complete parse of the file, or build a - -- tree. It is used in the main driver in the check for bad bodies. - ------------------------------------------------- -- Subprograms for Dealing With Instantiations -- -------------------------------------------------