[Ada] Fix error of not diagnosing bad body with non-standard file names
Arnaud Charlet
charlet@adacore.com
Wed May 21 12:40:00 GMT 2014
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 <dewar@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.
-------------- next part --------------
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 --
-------------------------------------------------
More information about the Gcc-patches
mailing list