diff mbox

[Ada] Spurious error on withed Ghost unit

Message ID 20160706133902.GA78965@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet July 6, 2016, 1:39 p.m. UTC
This patch modifies the front end to prevent the generation of ALI and object
files as well as bypass the back end and suppress any errors related to code
generation when the compilation unit is ignored Ghost.

------------
-- Source --
------------

--  ignore.adc

pragma Assertion_Policy (Ghost => Ignore);

--  ghost_gen.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Ghost_Gen is
   procedure Ghost_Proc (Formal : T) is
   begin
      if Formal = Ghost_Obj then
         null;
      end if;
      Put_Line ("ERROR: Ghost_Gen");
   end Ghost_Proc;
end Ghost_Gen;

--  ghost_gen.ads

generic
   type T is private;
   Ghost_Obj : T;

package Ghost_Gen with Ghost is
   procedure Ghost_Proc (Formal : T);
end Ghost_Gen;

--  ghost_pack_spec.ads

package Ghost_Pack_Spec with Ghost is
   Ghost_Obj : constant Integer := 1;
end Ghost_Pack_Spec;

--  ghost_pack_spec_and_body.adb

with Ada.Text_IO; use Ada.Text_IO;

package body Ghost_Pack_Spec_And_Body is
   procedure Ghost_Proc (Formal : Integer) is
   begin
      if Ghost_Obj = Formal then
         null;
      end if;
      Put_Line ("ERROR: Ghost_Pack_Spec_And_Body");
   end Ghost_Proc;
end Ghost_Pack_Spec_And_Body;

--  ghost_pack_spec_and_body.ads

package Ghost_Pack_Spec_And_Body with Ghost is
   Ghost_Obj : constant Integer := 1;

   procedure Ghost_Proc (Formal : Integer);
end Ghost_Pack_Spec_And_Body;

--  ghost_subp_body.adb

with Ada.Text_IO; use Ada.Text_IO;

procedure Ghost_Subp_Body (Formal : Integer) with Ghost is
   Ghost_Obj : Integer := 1;
begin
   if Ghost_Obj = Formal then
      null;
   end if;
   Put_Line ("ERROR: Ghost_Subp_Body");
end Ghost_Subp_Body;

--  ghost_subp_spec_and_body.adb

with Ada.Text_IO; use Ada.Text_IO;

procedure Ghost_Subp_Spec_And_Body (Formal : Integer) is
begin
   Put_Line ("ERROR: Ghost_Subp_Spec_And_Body");
end Ghost_Subp_Spec_And_Body;

--  ghost_subp_spec_and_body.ads

procedure Ghost_Subp_Spec_And_Body (Formal : Integer) with Ghost;

--  living_with_1.adb

with Ghost_Gen;

procedure Living_With_1 is
   package Ghost_Inst is new Ghost_Gen (Integer, 1);
begin
   Ghost_Inst.Ghost_Proc (2);
end Living_With_1;

--  living_with_2.adb

with Ghost_Pack_Spec; use Ghost_Pack_Spec;

procedure Living_With_2 is
   Local_Ghost_Obj : constant Integer := Ghost_Obj with Ghost;
begin
   null;
end Living_With_2;

--  living_with_3.adb

with Ghost_Pack_Spec_And_Body; use Ghost_Pack_Spec_And_Body;

procedure Living_With_3 is
   Local_Ghost_Obj : constant Integer := Ghost_Obj with Ghost;
begin
   Ghost_Proc (Local_Ghost_Obj);
end Living_With_3;

--  living_with_4.adb

with Ghost_Subp_Body;

procedure Living_With_4 is
   Local_Ghost_Obj : constant Integer := 1 with Ghost;
begin
   Ghost_Subp_Body (Local_Ghost_Obj);
end Living_With_4;

--  living_with_5.adb

with Ghost_Subp_Spec_And_Body;

procedure Living_With_5 is
   Local_Ghost_Obj : constant Integer := 1 with Ghost;
begin
   Ghost_Subp_Spec_And_Body (Local_Ghost_Obj);
end Living_With_5;

----------------------------
-- Compilation and output --
----------------------------

$ echo "checked Ghost code, withs from living untis"
$ gcc -c -gnatec=check.adc ghost_gen.adb
$ gcc -c -gnatec=check.adc ghost_pack_spec.ads
$ gcc -c -gnatec=check.adc ghost_pack_spec_and_body.adb
$ gcc -c -gnatec=check.adc ghost_subp_body.adb
$ gcc -c -gnatec=check.adc ghost_subp_spec_and_body.adb
$ gcc -c -gnatec=check.adc living_with_1.adb
$ gcc -c -gnatec=check.adc living_with_2.adb
$ gcc -c -gnatec=check.adc living_with_3.adb
$ gcc -c -gnatec=check.adc living_with_4.adb
$ gcc -c -gnatec=check.adc living_with_5.adb
$ ls *.o *.ali > objects_and_ali.txt
$ grep -n "ghost" objects_and_ali.txt | wc -l
$ rm -rf *.o *.ali
$ echo "ignored Ghost code, withs from living units"
$ gcc -c -gnatec=ignore.adc ghost_gen.adb
$ gcc -c -gnatec=ignore.adc ghost_pack_spec.ads
$ gcc -c -gnatec=ignore.adc ghost_pack_spec_and_body.adb
$ gcc -c -gnatec=ignore.adc ghost_subp_body.adb
$ gcc -c -gnatec=ignore.adc ghost_subp_spec_and_body.adb
$ gcc -c -gnatec=ignore.adc living_with_1.adb
$ gcc -c -gnatec=ignore.adc living_with_2.adb
$ gcc -c -gnatec=ignore.adc living_with_3.adb
$ gcc -c -gnatec=ignore.adc living_with_4.adb
$ gcc -c -gnatec=ignore.adc living_with_5.adb
$ ls *.o *.ali > objects_and_ali.txt
$ grep "ghost" objects_and_ali.txt | wc -l
$ rm -rf *.o *.ali
$ gnatmake -f -q -gnatec=ignore.adc living_with_1.adb
$ gnatmake -f -q -gnatec=ignore.adc living_with_2.adb
$ gnatmake -f -q -gnatec=ignore.adc living_with_3.adb
$ gnatmake -f -q -gnatec=ignore.adc living_with_4.adb
$ gnatmake -f -q -gnatec=ignore.adc living_with_5.adb
$ ./living_with_1
$ ./living_with_2
$ ./living_with_3
$ ./living_with_4
$ ./living_with_5
checked Ghost code, withs from living untis
10
ignored Ghost code, withs from living units
0

Tested on x86_64-pc-linux-gnu, committed on trunk

2016-07-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* gnat1drv.adb: Code clean up. Do not emit any
	code generation errors when the unit is ignored Ghost.
diff mbox

Patch

Index: gnat1drv.adb
===================================================================
--- gnat1drv.adb	(revision 238040)
+++ gnat1drv.adb	(working copy)
@@ -89,15 +89,6 @@ 
 --------------
 
 procedure Gnat1drv is
-   Main_Unit_Node : Node_Id;
-   --  Compilation unit node for main unit
-
-   Main_Kind : Node_Kind;
-   --  Kind of main compilation unit node
-
-   Back_End_Mode : Back_End.Back_End_Mode_Type;
-   --  Record back-end mode
-
    procedure Adjust_Global_Switches;
    --  There are various interactions between front-end switch settings,
    --  including debug switch settings and target dependent parameters.
@@ -105,8 +96,9 @@ 
    --  We do it after scanning out all the switches, so that we are not
    --  depending on the order in which switches appear.
 
-   procedure Check_Bad_Body;
-   --  Called to check if the unit we are compiling has a bad body
+   procedure Check_Bad_Body (Unit_Node : Node_Id; Unit_Kind : Node_Kind);
+   --  Called to check whether a unit described by its compilation unit node
+   --  and kind has a bad body.
 
    procedure Check_Rep_Info;
    --  Called when we are not generating code, to check if -gnatR was requested
@@ -712,10 +704,8 @@ 
    -- Check_Bad_Body --
    --------------------
 
-   procedure Check_Bad_Body is
-      Sname   : Unit_Name_Type;
-      Src_Ind : Source_File_Index;
-      Fname   : File_Name_Type;
+   procedure Check_Bad_Body (Unit_Node : Node_Id; Unit_Kind : Node_Kind) is
+      Fname : File_Name_Type;
 
       procedure Bad_Body_Error (Msg : String);
       --  Issue message for bad body found
@@ -726,11 +716,16 @@ 
 
       procedure Bad_Body_Error (Msg : String) is
       begin
-         Error_Msg_N (Msg, Main_Unit_Node);
+         Error_Msg_N (Msg, Unit_Node);
          Error_Msg_File_1 := Fname;
-         Error_Msg_N ("remove incorrect body in file{!", Main_Unit_Node);
+         Error_Msg_N ("remove incorrect body in file{!", Unit_Node);
       end Bad_Body_Error;
 
+      --  Local variables
+
+      Sname   : Unit_Name_Type;
+      Src_Ind : Source_File_Index;
+
    --  Start of processing for Check_Bad_Body
 
    begin
@@ -743,13 +738,13 @@ 
 
       --  Check for body not allowed
 
-      if (Main_Kind = N_Package_Declaration
-           and then not Body_Required (Main_Unit_Node))
-        or else (Main_Kind = N_Generic_Package_Declaration
-                  and then not Body_Required (Main_Unit_Node))
-        or else Main_Kind = N_Package_Renaming_Declaration
-        or else Main_Kind = N_Subprogram_Renaming_Declaration
-        or else Nkind (Original_Node (Unit (Main_Unit_Node)))
+      if (Unit_Kind = N_Package_Declaration
+           and then not Body_Required (Unit_Node))
+        or else (Unit_Kind = N_Generic_Package_Declaration
+                  and then not Body_Required (Unit_Node))
+        or else Unit_Kind = N_Package_Renaming_Declaration
+        or else Unit_Kind = N_Subprogram_Renaming_Declaration
+        or else Nkind (Original_Node (Unit (Unit_Node)))
                          in N_Generic_Instantiation
       then
          Sname := Unit_Name (Main_Unit);
@@ -793,16 +788,16 @@ 
             --  be incorrect (we may have misinterpreted a junk spec as not
             --  needing a body when it really does).
 
-            if Main_Kind = N_Package_Declaration
+            if Unit_Kind = N_Package_Declaration
               and then Ada_Version = Ada_83
               and then Operating_Mode = Generate_Code
               and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body
               and then not Compilation_Errors
             then
                Error_Msg_N
-                 ("package $$ does not require a body??", Main_Unit_Node);
+                 ("package $$ does not require a body??", Unit_Node);
                Error_Msg_File_1 := Fname;
-               Error_Msg_N ("body in file{ will be ignored??", Main_Unit_Node);
+               Error_Msg_N ("body in file{ will be ignored??", Unit_Node);
 
                --  Ada 95 cases of a body file present when no body is
                --  permitted. This we consider to be an error.
@@ -810,15 +805,15 @@ 
             else
                --  For generic instantiations, we never allow a body
 
-               if Nkind (Original_Node (Unit (Main_Unit_Node))) in
+               if Nkind (Original_Node (Unit (Unit_Node))) in
                                                     N_Generic_Instantiation
                then
                   Bad_Body_Error
                     ("generic instantiation for $$ does not allow a body");
 
-                  --  A library unit that is a renaming never allows a body
+               --  A library unit that is a renaming never allows a body
 
-               elsif Main_Kind in N_Renaming_Declaration then
+               elsif Unit_Kind in N_Renaming_Declaration then
                   Bad_Body_Error
                     ("renaming declaration for $$ does not allow a body!");
 
@@ -829,11 +824,11 @@ 
                   --  body when in fact it does.
 
                elsif not Compilation_Errors then
-                  if Main_Kind = N_Package_Declaration then
+                  if Unit_Kind = N_Package_Declaration then
                      Bad_Body_Error
                        ("package $$ does not allow a body!");
 
-                  elsif Main_Kind = N_Generic_Package_Declaration then
+                  elsif Unit_Kind = N_Generic_Package_Declaration then
                      Bad_Body_Error
                        ("generic package $$ does not allow a body!");
                   end if;
@@ -893,9 +888,18 @@ 
       if AAMP_On_Target then
          Sem_Ch13.Validate_Independence;
       end if;
-
    end Post_Compilation_Validation_Checks;
 
+   --  Local variables
+
+   Back_End_Mode : Back_End.Back_End_Mode_Type;
+
+   Main_Unit_Kind : Node_Kind;
+   --  Kind of main compilation unit node
+
+   Main_Unit_Node : Node_Id;
+   --  Compilation unit node for main unit
+
 --  Start of processing for Gnat1drv
 
 begin
@@ -1065,9 +1069,10 @@ 
       end if;
 
       Main_Unit_Node := Cunit (Main_Unit);
-      Main_Kind := Nkind (Unit (Main_Unit_Node));
-      Check_Bad_Body;
+      Main_Unit_Kind := Nkind (Unit (Main_Unit_Node));
 
+      Check_Bad_Body (Main_Unit_Node, Main_Unit_Kind);
+
       --  In CodePeer mode we always delete old SCIL files before regenerating
       --  new ones, in case of e.g. errors, and also to remove obsolete scilx
       --  files generated by CodePeer itself.
@@ -1159,21 +1164,23 @@ 
       --  subunits. Note that we always generate code for all generic units (a
       --  change from some previous versions of GNAT).
 
-      elsif Main_Kind = N_Subprogram_Body and then not Subunits_Missing then
+      elsif Main_Unit_Kind = N_Subprogram_Body
+        and then not Subunits_Missing
+      then
          Back_End_Mode := Generate_Object;
 
       --  We can generate code for a package body unless there are subunits
       --  missing (note that we always generate code for generic units, which
       --  is a change from some earlier versions of GNAT).
 
-      elsif Main_Kind = N_Package_Body and then not Subunits_Missing then
+      elsif Main_Unit_Kind = N_Package_Body and then not Subunits_Missing then
          Back_End_Mode := Generate_Object;
 
       --  We can generate code for a package declaration or a subprogram
       --  declaration only if it does not required a body.
 
-      elsif Nkind_In (Main_Kind, N_Package_Declaration,
-                                 N_Subprogram_Declaration)
+      elsif Nkind_In (Main_Unit_Kind, N_Package_Declaration,
+                                      N_Subprogram_Declaration)
         and then
           (not Body_Required (Main_Unit_Node)
              or else Distribution_Stub_Mode = Generate_Caller_Stub_Body)
@@ -1183,8 +1190,8 @@ 
       --  We can generate code for a generic package declaration of a generic
       --  subprogram declaration only if does not require a body.
 
-      elsif Nkind_In (Main_Kind, N_Generic_Package_Declaration,
-                                 N_Generic_Subprogram_Declaration)
+      elsif Nkind_In (Main_Unit_Kind, N_Generic_Package_Declaration,
+                                      N_Generic_Subprogram_Declaration)
         and then not Body_Required (Main_Unit_Node)
       then
          Back_End_Mode := Generate_Object;
@@ -1192,15 +1199,15 @@ 
       --  Compilation units that are renamings do not require bodies, so we can
       --  generate code for them.
 
-      elsif Nkind_In (Main_Kind, N_Package_Renaming_Declaration,
-                                 N_Subprogram_Renaming_Declaration)
+      elsif Nkind_In (Main_Unit_Kind, N_Package_Renaming_Declaration,
+                                      N_Subprogram_Renaming_Declaration)
       then
          Back_End_Mode := Generate_Object;
 
       --  Compilation units that are generic renamings do not require bodies
       --  so we can generate code for them.
 
-      elsif Main_Kind in N_Generic_Renaming_Declaration then
+      elsif Main_Unit_Kind in N_Generic_Renaming_Declaration then
          Back_End_Mode := Generate_Object;
 
       --  It is not an error to analyze in CodePeer mode a spec which requires
@@ -1240,45 +1247,61 @@ 
       --  generate code).
 
       if Back_End_Mode = Skip then
-         Set_Standard_Error;
-         Write_Str ("cannot generate code for file ");
-         Write_Name (Unit_File_Name (Main_Unit));
 
-         if Subunits_Missing then
-            Write_Str (" (missing subunits)");
-            Write_Eol;
+         --  An ignored Ghost unit is rewritten into a null statement because
+         --  it must not produce an ALI or object file. Do not emit any errors
+         --  related to code generation because the unit does not exist.
 
-            --  Force generation of ALI file, for backward compatibility
+         if Main_Unit_Kind = N_Null_Statement
+           and then Is_Ignored_Ghost_Node
+                      (Original_Node (Unit (Main_Unit_Node)))
+         then
+            null;
 
-            Opt.Force_ALI_Tree_File := True;
+         --  Otherwise the unit is missing a crucial piece that prevents code
+         --  generation.
 
-         elsif Main_Kind = N_Subunit then
-            Write_Str (" (subunit)");
-            Write_Eol;
+         else
+            Set_Standard_Error;
+            Write_Str ("cannot generate code for file ");
+            Write_Name (Unit_File_Name (Main_Unit));
 
-            --  Force generation of ALI file, for backward compatibility
+            if Subunits_Missing then
+               Write_Str (" (missing subunits)");
+               Write_Eol;
 
-            Opt.Force_ALI_Tree_File := True;
+               --  Force generation of ALI file, for backward compatibility
 
-         elsif Main_Kind = N_Subprogram_Declaration then
-            Write_Str (" (subprogram spec)");
-            Write_Eol;
+               Opt.Force_ALI_Tree_File := True;
 
-         --  Generic package body in GNAT implementation mode
+            elsif Main_Unit_Kind = N_Subunit then
+               Write_Str (" (subunit)");
+               Write_Eol;
 
-         elsif Main_Kind = N_Package_Body and then GNAT_Mode then
-            Write_Str (" (predefined generic)");
-            Write_Eol;
+               --  Force generation of ALI file, for backward compatibility
 
-            --  Force generation of ALI file, for backward compatibility
+               Opt.Force_ALI_Tree_File := True;
 
-            Opt.Force_ALI_Tree_File := True;
+            elsif Main_Unit_Kind = N_Subprogram_Declaration then
+               Write_Str (" (subprogram spec)");
+               Write_Eol;
 
-         --  Only other case is a package spec
+            --  Generic package body in GNAT implementation mode
 
-         else
-            Write_Str (" (package spec)");
-            Write_Eol;
+            elsif Main_Unit_Kind = N_Package_Body and then GNAT_Mode then
+               Write_Str (" (predefined generic)");
+               Write_Eol;
+
+               --  Force generation of ALI file, for backward compatibility
+
+               Opt.Force_ALI_Tree_File := True;
+
+            --  Only other case is a package spec
+
+            else
+               Write_Str (" (package spec)");
+               Write_Eol;
+            end if;
          end if;
 
          Set_Standard_Output;
@@ -1320,7 +1343,7 @@ 
       if Back_End_Mode = Declarations_Only
         and then
           (not (Back_Annotate_Rep_Info or Generate_SCIL or GNATprove_Mode)
-            or else Main_Kind = N_Subunit
+            or else Main_Unit_Kind = N_Subunit
             or else Frontend_Layout_On_Target
             or else ASIS_GNSA_Mode)
       then
@@ -1465,11 +1488,10 @@ 
       when Program_Error =>
          Comperr.Compiler_Abort ("Program_Error");
 
+      --  Assume this is a bug. If it is real, the message will in any case
+      --  say Storage_Error, giving a strong hint.
+
       when Storage_Error =>
-
-         --  Assume this is a bug. If it is real, the message will in any case
-         --  say Storage_Error, giving a strong hint.
-
          Comperr.Compiler_Abort ("Storage_Error");
 
       when Unrecoverable_Error =>
@@ -1482,7 +1504,7 @@ 
    <<End_Of_Program>>
    null;
 
-   --  The outer exception handles an unrecoverable error
+--  The outer exception handler handles an unrecoverable error
 
 exception
    when Unrecoverable_Error =>