Add ghdl --find-top command.

7 files changed, 345 insertions, 0 deletions

diff --git a/src/ghdldrv/ghdllocal.adb b/src/ghdldrv/ghdllocal.adb
index 81c3adb05..75ececd4f 100644
--- a/src/ghdldrv/ghdllocal.adb
+++ b/src/ghdldrv/ghdllocal.adb
@@ -1065,6 +1065,62 @@ package body Ghdllocal is
       Disp_Vhdl.Disp_Vhdl (Std_Package.Std_Standard_Unit);
    end Perform_Action;
 
+   --  Command --find-top.
+   type Command_Find_Top is new Command_Lib with null record;
+   function Decode_Command (Cmd : Command_Find_Top; Name : String)
+                           return Boolean;
+   function Get_Short_Help (Cmd : Command_Find_Top) return String;
+   procedure Perform_Action (Cmd : in out Command_Find_Top;
+                             Args : Argument_List);
+
+   function Decode_Command (Cmd : Command_Find_Top; Name : String)
+                           return Boolean
+   is
+      pragma Unreferenced (Cmd);
+   begin
+      return Name = "--find-top";
+   end Decode_Command;
+
+   function Get_Short_Help (Cmd : Command_Find_Top) return String
+   is
+      pragma Unreferenced (Cmd);
+   begin
+      return "--find-top         Disp possible top entity in work library";
+   end Get_Short_Help;
+
+   procedure Perform_Action (Cmd : in out Command_Find_Top;
+                             Args : Argument_List)
+   is
+      use Libraries;
+      pragma Unreferenced (Cmd);
+      From : Iir;
+      Top : Iir;
+   begin
+      Setup_Libraries (True);
+
+      if Args'Length = 0 then
+         From := Work_Library;
+      elsif Args'Length = 1 then
+         From := Find_Design_File
+           (Work_Library, Name_Table.Get_Identifier (Args (Args'First).all));
+         if not Is_Valid (From) then
+            Error ("cannot find '" & Args (Args'First).all & "' in library");
+            raise Option_Error;
+         end if;
+      else
+         Error ("command '--find-top' accepts at most one argument");
+         raise Option_Error;
+      end if;
+
+      Top := Configuration.Find_Top_Entity (From);
+
+      if Top = Null_Iir then
+         Error ("no top entity found");
+      else
+         Put_Line (Name_Table.Image (Get_Identifier (Top)));
+      end if;
+   end Perform_Action;
+
    --  Command --bug-box.
    type Command_Bug_Box is new Command_Type with null record;
    function Decode_Command (Cmd : Command_Bug_Box; Name : String)
@@ -1539,6 +1595,7 @@ package body Ghdllocal is
       Register_Command (new Command_Remove);
       Register_Command (new Command_Copy);
       Register_Command (new Command_Disp_Standard);
+      Register_Command (new Command_Find_Top);
       Register_Command (new Command_Bug_Box);
    end Register_Commands;
 end Ghdllocal;
diff --git a/src/libraries.adb b/src/libraries.adb
index 01bf46faf..864543b36 100644
--- a/src/libraries.adb
+++ b/src/libraries.adb
@@ -1482,6 +1482,21 @@ package body Libraries is
       end case;
    end Find_Design_Unit;
 
+   function Find_Design_File (Lib : Iir_Library_Declaration; Name : Name_Id)
+                             return Iir
+   is
+      File : Iir;
+   begin
+      File := Get_Design_File_Chain (Lib);
+      while Is_Valid (File) loop
+         if Get_Design_File_Filename (File) = Name then
+            return File;
+         end if;
+         File := Get_Chain (File);
+      end loop;
+      return Null_Iir;
+   end Find_Design_File;
+
    function Is_Obsolete (Design_Unit : Iir_Design_Unit; Loc : Iir)
      return Boolean
    is
diff --git a/src/libraries.ads b/src/libraries.ads
index 2d1483833..edaf74292 100644
--- a/src/libraries.ads
+++ b/src/libraries.ads
@@ -187,6 +187,12 @@ package Libraries is
    --  Return null_iir if the design unit is not found.
    function Find_Design_Unit (Unit : Iir) return Iir_Design_Unit;
 
+   --  Search design file NAME in library LIB.  This is not very efficient as
+   --  this is a simple linear search.  NAME must correspond exactely to the
+   --  design file name.
+   function Find_Design_File (Lib : Iir_Library_Declaration; Name : Name_Id)
+                             return Iir;
+
    --  Find an entity whose name is NAME in any library.
    --  If there is no such entity, return NULL_IIR.
    --  If there are severals entities, return NULL_IIR;
diff --git a/src/vhdl/configuration.adb b/src/vhdl/configuration.adb
index 2c0e2dd38..a0fc0bb7a 100644
--- a/src/vhdl/configuration.adb
+++ b/src/vhdl/configuration.adb
@@ -15,12 +15,15 @@
 --  along with GHDL; see the file COPYING.  If not, write to the Free
 --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 --  02111-1307, USA.
+
 with Libraries;
 with Errorout; use Errorout;
 with Std_Package;
 with Name_Table; use Name_Table;
 with Flags;
 with Iirs_Utils; use Iirs_Utils;
+with Iirs_Walk;
+with Sem_Scopes;
 with Canon;
 
 package body Configuration is
@@ -755,4 +758,199 @@ package body Configuration is
          El := Get_Chain (El);
       end loop;
    end Check_Entity_Declaration_Top;
+
+   package Top is
+      procedure Mark_Instantiated_Units (Lib : Iir_Library_Declaration);
+
+      Nbr_Top_Entities : Natural;
+      First_Top_Entity : Iir;
+
+      procedure Find_First_Top_Entity (Lib : Iir_Library_Declaration);
+   end Top;
+
+   package body Top is
+      use Iirs_Walk;
+
+      function Add_Entity_Cb (Design : Iir) return Walk_Status
+      is
+         Kind : constant Iir_Kind := Get_Kind (Get_Library_Unit (Design));
+      begin
+         if Get_Date (Design) < Date_Analyzed then
+            return Walk_Continue;
+         end if;
+
+         case Iir_Kinds_Library_Unit_Declaration (Kind) is
+            when Iir_Kind_Architecture_Body
+              | Iir_Kind_Configuration_Declaration =>
+               Libraries.Load_Design_Unit (Design, Null_Iir);
+            when Iir_Kind_Entity_Declaration =>
+               Libraries.Load_Design_Unit (Design, Null_Iir);
+               Sem_Scopes.Add_Name (Get_Library_Unit (Design));
+            when Iir_Kind_Package_Declaration
+              | Iir_Kind_Package_Instantiation_Declaration
+              | Iir_Kind_Package_Body
+              | Iir_Kind_Context_Declaration =>
+               null;
+         end case;
+         return Walk_Continue;
+      end Add_Entity_Cb;
+
+      procedure Mark_Aspect (Aspect : Iir)
+      is
+         Unit : Iir;
+      begin
+         case Iir_Kinds_Entity_Aspect (Get_Kind (Aspect)) is
+            when Iir_Kind_Entity_Aspect_Entity =>
+               Unit := Get_Entity (Aspect);
+               Set_Elab_Flag (Get_Parent (Unit), True);
+            when Iir_Kind_Entity_Aspect_Configuration
+              | Iir_Kind_Entity_Aspect_Open =>
+               null;
+         end case;
+      end Mark_Aspect;
+
+      function Mark_Instantiation_Cb (Stmt : Iir) return Walk_Status
+      is
+         Inst : Iir;
+      begin
+         if Get_Kind (Stmt) /= Iir_Kind_Component_Instantiation_Statement then
+            return Walk_Continue;
+         end if;
+
+         Inst := Get_Instantiated_Unit (Stmt);
+         case Get_Kind (Inst) is
+            when Iir_Kinds_Denoting_Name =>
+               --  TODO: look at default_binding_indication
+               --        or configuration_specification ?
+               declare
+                  Config : constant Iir :=
+                    Get_Configuration_Specification (Stmt);
+               begin
+                  if Is_Valid (Config) then
+                     Mark_Aspect
+                       (Get_Entity_Aspect (Get_Binding_Indication (Config)));
+                     return Walk_Continue;
+                  end if;
+               end;
+               declare
+                  use Sem_Scopes;
+                  Comp : constant Iir := Get_Named_Entity (Inst);
+                  Interp : constant Name_Interpretation_Type :=
+                    Get_Interpretation (Get_Identifier (Comp));
+                  Decl : Iir;
+               begin
+                  if Valid_Interpretation (Interp) then
+                     Decl := Get_Declaration (Interp);
+                     pragma Assert
+                       (Get_Kind (Decl) = Iir_Kind_Entity_Declaration);
+                     Set_Elab_Flag (Get_Design_Unit (Decl), True);
+                  else
+                     --  If there is no corresponding entity name for the
+                     --  component name, assume it belongs to a different
+                     --  library (or will be set by a configuration unit).
+                     null;
+                  end if;
+               end;
+            when Iir_Kinds_Entity_Aspect =>
+               Mark_Aspect (Inst);
+            when others =>
+               Error_Kind ("mark_instantiation_cb", Stmt);
+         end case;
+
+         return Walk_Continue;
+      end Mark_Instantiation_Cb;
+
+      function Mark_Units_Cb (Design : Iir) return Walk_Status
+      is
+         Unit : constant Iir := Get_Library_Unit (Design);
+         Status : Walk_Status;
+      begin
+         if Get_Date (Design) < Date_Analyzed then
+            return Walk_Continue;
+         end if;
+
+         case Iir_Kinds_Library_Unit_Declaration (Get_Kind (Unit)) is
+            when Iir_Kind_Architecture_Body =>
+               Status := Walk_Concurrent_Statements_Chain
+                 (Get_Concurrent_Statement_Chain (Unit),
+                  Mark_Instantiation_Cb'Access);
+               pragma Assert (Status = Walk_Continue);
+            when Iir_Kind_Configuration_Declaration =>
+               --  TODO
+               raise Program_Error;
+               --  Mark_Units_Of_Block_Configuration
+               --   (Get_Block_Configuration (Unit));
+            when Iir_Kind_Package_Declaration
+              | Iir_Kind_Package_Instantiation_Declaration
+              | Iir_Kind_Package_Body
+              | Iir_Kind_Entity_Declaration
+              | Iir_Kind_Context_Declaration =>
+               null;
+         end case;
+         return Walk_Continue;
+      end Mark_Units_Cb;
+
+      procedure Mark_Instantiated_Units (Lib : Iir_Library_Declaration)
+      is
+         Status : Walk_Status;
+      begin
+         --  Name table is used to map names to entities.
+         Sem_Scopes.Push_Interpretations;
+         Sem_Scopes.Open_Declarative_Region;
+
+         --  1. Add all design entities in the name table.
+         Status := Walk_Design_Units (Lib, Add_Entity_Cb'Access);
+         pragma Assert (Status = Walk_Continue);
+
+         --  2. Walk architecture and configurations, and mark instantiated
+         --     entities.
+         Status := Walk_Design_Units (Lib, Mark_Units_Cb'Access);
+         pragma Assert (Status = Walk_Continue);
+
+         Sem_Scopes.Close_Declarative_Region;
+         Sem_Scopes.Pop_Interpretations;
+      end Mark_Instantiated_Units;
+
+      function Extract_Entity_Cb (Design : Iir) return Walk_Status
+      is
+         Unit : constant Iir := Get_Library_Unit (Design);
+      begin
+         if Get_Kind (Unit) = Iir_Kind_Entity_Declaration then
+            if Get_Elab_Flag (Design) then
+               Set_Elab_Flag (Design, False);
+            else
+               Nbr_Top_Entities := Nbr_Top_Entities + 1;
+               if Nbr_Top_Entities = 1 then
+                  First_Top_Entity := Unit;
+               end if;
+            end if;
+         end if;
+         return Walk_Continue;
+      end Extract_Entity_Cb;
+
+      procedure Find_First_Top_Entity (Lib : Iir_Library_Declaration)
+      is
+         Status : Walk_Status;
+      begin
+         Nbr_Top_Entities := 0;
+         First_Top_Entity := Null_Iir;
+
+         Status := Walk_Design_Units (Lib, Extract_Entity_Cb'Access);
+         pragma Assert (Status = Walk_Continue);
+      end Find_First_Top_Entity;
+
+   end Top;
+
+   function Find_Top_Entity (From : Iir) return Iir is
+   begin
+      Top.Mark_Instantiated_Units (From);
+      Top.Find_First_Top_Entity (From);
+
+      if Top.Nbr_Top_Entities = 1 then
+         return Top.First_Top_Entity;
+      else
+         return Null_Iir;
+      end if;
+   end Find_Top_Entity;
+
 end Configuration;
diff --git a/src/vhdl/configuration.ads b/src/vhdl/configuration.ads
index ddd6206d4..6ec910f00 100644
--- a/src/vhdl/configuration.ads
+++ b/src/vhdl/configuration.ads
@@ -55,4 +55,9 @@ package Configuration is
    --  ENTITY has no ports or all ports type are constrained.
    --  If not, emit a elab error message.
    procedure Check_Entity_Declaration_Top (Entity : Iir_Entity_Declaration);
+
+   --  Use heuritics to find the top entity in FROM (either a library or
+   --  a design file): mark all instantiated units and return the unmarked
+   --  one if there is only one.
+   function Find_Top_Entity (From : Iir) return Iir;
 end Configuration;
diff --git a/src/vhdl/iirs_walk.adb b/src/vhdl/iirs_walk.adb
index 80f825f68..3bc4ecf07 100644
--- a/src/vhdl/iirs_walk.adb
+++ b/src/vhdl/iirs_walk.adb
@@ -17,6 +17,7 @@
 --  02111-1307, USA.
 
 with Iirs_Utils; use Iirs_Utils;
+with Errorout; use Errorout;
 
 package body Iirs_Walk is
    function Walk_Chain (Chain : Iir; Cb : Walk_Cb) return Walk_Status
@@ -118,4 +119,59 @@ package body Iirs_Walk is
       end case;
       return Status;
    end Walk_Assignment_Target;
+
+   function Walk_Design_Units (Parent : Iir; Cb : Walk_Cb) return Walk_Status
+   is
+      El : Iir;
+      Status : Walk_Status := Walk_Continue;
+   begin
+      case Get_Kind (Parent) is
+         when Iir_Kind_Library_Declaration =>
+            El := Get_Design_File_Chain (Parent);
+            while Is_Valid (El) loop
+               Status := Walk_Design_Units (El, Cb);
+               exit when Status /= Walk_Continue;
+               El := Get_Chain (El);
+            end loop;
+            return Status;
+         when Iir_Kind_Design_File =>
+            El := Get_First_Design_Unit (Parent);
+            while Is_Valid (El) loop
+               Status := Cb.all (El);
+               exit when Status /= Walk_Continue;
+               El := Get_Chain (El);
+            end loop;
+            return Status;
+         when others =>
+            Error_Kind ("walk_library_units", Parent);
+      end case;
+   end Walk_Design_Units;
+
+   function Walk_Concurrent_Statements_Chain (Chain : Iir; Cb : Walk_Cb)
+                                       return Walk_Status
+   is
+      Status : Walk_Status;
+      El : Iir;
+   begin
+      El := Chain;
+      while Is_Valid (El) loop
+         case Iir_Kinds_Concurrent_Statement (Get_Kind (El)) is
+            when Iir_Kinds_Simple_Concurrent_Statement
+              | Iir_Kind_Component_Instantiation_Statement =>
+               return Cb.all (El);
+            when Iir_Kind_Block_Statement =>
+               Status := Cb.all (El);
+               if Status /= Walk_Continue then
+                  return Status;
+               end if;
+               return Walk_Concurrent_Statements_Chain
+                 (Get_Concurrent_Statement_Chain (El), Cb);
+            when others =>
+               Error_Kind ("walk_concurrent_statements_chain", El);
+         end case;
+         El := Get_Chain (El);
+      end loop;
+
+      return Walk_Continue;
+   end Walk_Concurrent_Statements_Chain;
 end Iirs_Walk;
diff --git a/src/vhdl/iirs_walk.ads b/src/vhdl/iirs_walk.ads
index 4c098f7d5..c00aa955d 100644
--- a/src/vhdl/iirs_walk.ads
+++ b/src/vhdl/iirs_walk.ads
@@ -42,4 +42,12 @@ package Iirs_Walk is
    --  Walk on all stmts and sub-stmts of CHAIN.
    function Walk_Sequential_Stmt_Chain (Chain : Iir; Cb : Walk_Cb)
                                        return Walk_Status;
+
+   --  Walk on all design units of library or design file PARENT.
+   function Walk_Design_Units (Parent : Iir; Cb : Walk_Cb) return Walk_Status;
+
+   --  Walk on all concurrent statements (and sub statements) of CHAIN.
+   function Walk_Concurrent_Statements_Chain (Chain : Iir; Cb : Walk_Cb)
+                                       return Walk_Status;
+
 end Iirs_Walk;