path: root/src/synth/elab-debugger__on.adb

--  Debugging during synthesis.
--  Copyright (C) 2019 Tristan Gingold
--
--  This file is part of GHDL.
--
--  This program is free software: you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation, either version 2 of the License, or
--  (at your option) any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program.  If not, see <gnu.org/licenses>.

with System;

with Types; use Types;
with Files_Map;
with Tables;
with Simple_IO; use Simple_IO;
with Utils_IO; use Utils_IO;
with Name_Table;
with Str_Table;
with Libraries;

with Grt.Readline;

with Vhdl.Errors;
with Vhdl.Nodes_Walk; use Vhdl.Nodes_Walk;
with Vhdl.Parse;
with Vhdl.Utils; use Vhdl.Utils;

with Elab.Vhdl_Objtypes; use Elab.Vhdl_Objtypes;
with Elab.Memtype; use Elab.Memtype;
with Elab.Vhdl_Values; use Elab.Vhdl_Values;
with Elab.Vhdl_Context.Debug; use Elab.Vhdl_Context.Debug;

package body Elab.Debugger is
   Flag_Enabled : Boolean := False;

   Current_Instance : Synth_Instance_Acc;
   Current_Loc : Node;

   type Debug_Reason is
     (
      Reason_Init,
      Reason_Break,
      Reason_Error
     );

   package Breakpoints is new Tables
     (Table_Index_Type => Natural,
      Table_Component_Type => Node,
      Table_Low_Bound => 1,
      Table_Initial => 16);

   function Is_Breakpoint_Hit return Boolean is
   begin
      for I in Breakpoints.First .. Breakpoints.Last loop
         if Breakpoints.Table (I) = Current_Loc then
            return True;
         end if;
      end loop;
      return False;
   end Is_Breakpoint_Hit;

   --  Current execution state, or reason to stop execution (set by the
   --  last debugger command).
   type Exec_State_Type is
     (--  Execution should continue until a breakpoint is reached or assertion
      --  failure.
      Exec_Run,

      --  Execution will stop at the next statement.
      Exec_Single_Step,

      --  Execution will stop at the next simple statement in the same frame.
      Exec_Next,

      --  Execution will stop at the next statement in the same frame.  In
      --  case of compound statement, stop after the compound statement.
      Exec_Next_Stmt);

   Exec_State : Exec_State_Type := Exec_Run;

   --  Current frame for next.
   Exec_Instance : Synth_Instance_Acc;

   --  Current statement for next_stmt.
   Exec_Statement : Node;

   function Is_Within_Statement (Stmt : Node; Cur : Node) return Boolean
   is
      Parent : Node;
   begin
      Parent := Cur;
      loop
         if Parent = Stmt then
            return True;
         end if;
         case Get_Kind (Parent) is
            when Iir_Kinds_Sequential_Statement =>
               Parent := Get_Parent (Parent);
            when others =>
               return False;
         end case;
      end loop;
   end Is_Within_Statement;

   Prompt_Debug : constant String := "debug> " & ASCII.NUL;
   Prompt_Error : constant String := "error> " & ASCII.NUL;
   Prompt_Init  : constant String := "init> " & ASCII.NUL;
   --  Prompt_Elab  : constant String := "elab> " & ASCII.NUL;

   procedure Disp_Iir_Location (N : Node) is
   begin
      if N = Null_Iir then
         Put_Err ("??:??:??");
      else
         Put_Err (Vhdl.Errors.Disp_Location (N));
      end if;
      Put_Err (": ");
   end Disp_Iir_Location;

   --  For the list command: current file and current line.
   List_Current_File : Source_File_Entry := No_Source_File_Entry;
   List_Current_Line : Natural := 0;
   List_Current_Line_Pos : Source_Ptr := 0;

   --  Set List_Current_* from a location.  To be called after program break
   --  to indicate current location.
   procedure Set_List_Current (Loc : Location_Type)
   is
      Offset : Natural;
   begin
      Files_Map.Location_To_Coord
        (Loc, List_Current_File, List_Current_Line_Pos,
         List_Current_Line, Offset);
   end Set_List_Current;

   procedure Disp_Current_Lines
   is
      use Files_Map;
      --  Number of lines to display before and after the current line.
      Radius : constant := 5;

      Buf : File_Buffer_Acc;

      Pos : Source_Ptr;
      Line : Natural;
      Len : Source_Ptr;
      C : Character;
   begin
      if List_Current_Line > Radius then
         Line := List_Current_Line - Radius;
      else
         Line := 1;
      end if;

      Pos := File_Line_To_Position (List_Current_File, Line);
      Buf := Get_File_Source (List_Current_File);

      while Line < List_Current_Line + Radius loop
         --  Compute line length.
         Len := 0;
         loop
            C := Buf (Pos + Len);
            exit when C = ASCII.CR or C = ASCII.LF or C = ASCII.EOT;
            Len := Len + 1;
         end loop;

         --  Disp line number.
         declare
            Str : constant String := Natural'Image (Line);
         begin
            if Line = List_Current_Line then
               Put ('*');
            else
               Put (' ');
            end if;
            Put ((Str'Length .. 5 => ' '));
            Put (Str (Str'First + 1 .. Str'Last));
            Put (' ');
         end;

         --  Disp line.
         Put_Line (String (Buf (Pos .. Pos + Len - 1)));

         --  Skip EOL.
         exit when C = ASCII.EOT;
         Pos := Pos + Len + 1;
         if C = ASCII.CR then
            if Buf (Pos) = ASCII.LF then
               Pos := Pos + 1;
            end if;
         else
            pragma Assert (C = ASCII.LF);
            if Buf (Pos) = ASCII.CR then
               Pos := Pos + 1;
            end if;
         end if;

         Line := Line + 1;
      end loop;
   end Disp_Current_Lines;

   procedure Disp_Source_Line (Loc : Location_Type)
   is
      use Files_Map;

      File : Source_File_Entry;
      Line_Pos : Source_Ptr;
      Line : Natural;
      Offset : Natural;
      Buf : File_Buffer_Acc;
      Next_Line_Pos : Source_Ptr;
   begin
      Location_To_Coord (Loc, File, Line_Pos, Line, Offset);
      Buf := Get_File_Source (File);
      Next_Line_Pos := File_Line_To_Position (File, Line + 1);
      Put (String (Buf (Line_Pos .. Next_Line_Pos - 1)));
   end Disp_Source_Line;

   --  The status of the debugger.  This status can be modified by a command
   --  as a side effect to resume or quit the debugger.
   type Command_Status_Type is (Status_Default, Status_Quit);
   Command_Status : Command_Status_Type;

   --  This exception can be raised by a debugger command to directly return
   --  to the prompt.
   Command_Error : exception;

   type Menu_Procedure is access procedure (Line : String);

   --  If set (by commands), call this procedure on empty line to repeat
   --  last command.
   Cmd_Repeat : Menu_Procedure;

   type Menu_Kind is (Menu_Command, Menu_Submenu);
   type Menu_Entry (Kind : Menu_Kind);
   type Menu_Entry_Acc is access all Menu_Entry;

   type Cst_String_Acc is access constant String;

   type Menu_Entry (Kind : Menu_Kind) is record
      Name : Cst_String_Acc;
      Next : Menu_Entry_Acc;

      case Kind is
         when Menu_Command =>
            Proc : Menu_Procedure;
         when Menu_Submenu =>
            First, Last : Menu_Entry_Acc := null;
      end case;
   end record;

   function Is_Blank (C : Character) return Boolean is
   begin
      return C = ' ' or else C = ASCII.HT;
   end Is_Blank;

   function Skip_Blanks (S : String) return Positive
   is
      P : Positive := S'First;
   begin
      while P <= S'Last and then Is_Blank (S (P)) loop
         P := P + 1;
      end loop;
      return P;
   end Skip_Blanks;

   --  Return the position of the last character of the word (the last
   --  non-blank character).
   function Get_Word (S : String) return Positive
   is
      P : Positive := S'First;
   begin
      while P <= S'Last and then not Is_Blank (S (P)) loop
         P := P + 1;
      end loop;
      return P - 1;
   end Get_Word;

   procedure Disp_Memtyp (M : Memtyp; Vtype : Node);

   procedure Disp_Discrete_Value (Val : Int64; Btype : Node) is
   begin
      case Get_Kind (Btype) is
         when Iir_Kind_Integer_Type_Definition =>
            Put_Int64 (Val);
         when Iir_Kind_Enumeration_Type_Definition =>
            declare
               Pos : constant Natural := Natural (Val);
               Enums : constant Node_Flist :=
                 Get_Enumeration_Literal_List (Btype);
               Id : constant Name_Id :=
                 Get_Identifier (Get_Nth_Element (Enums, Pos));
            begin
               Put (Name_Table.Image (Id));
            end;
         when others =>
            Vhdl.Errors.Error_Kind ("disp_discrete_value", Btype);
      end case;
   end Disp_Discrete_Value;

   procedure Disp_Value_Vector (Mem : Memtyp; A_Type: Node; Bound : Bound_Type)
   is
      El_Type : constant Node := Get_Base_Type (Get_Element_Subtype (A_Type));
      El_Typ : constant Type_Acc := Get_Array_Element (Mem.Typ);
      type Last_Enum_Type is (None, Char, Identifier);
      Last_Enum : Last_Enum_Type;
      Enum_List : Node_Flist;
      El_Id : Name_Id;
      El_Pos : Natural;
   begin
      --  Pretty print vectors of enumerated types
      if Get_Kind (El_Type) = Iir_Kind_Enumeration_Type_Definition then
         Last_Enum := None;
         Enum_List := Get_Enumeration_Literal_List (El_Type);
         for I in 1 .. Bound.Len loop
            El_Pos := Natural
              (Read_Discrete
                 (Memtyp'(El_Typ, Mem.Mem + Size_Type (I - 1) * El_Typ.Sz)));
            El_Id := Get_Identifier (Get_Nth_Element (Enum_List, El_Pos));
            if Name_Table.Is_Character (El_Id) then
               case Last_Enum is
                  when None =>
                     Put ("""");
                  when Identifier =>
                     Put (" & """);
                  when Char =>
                     null;
               end case;
               Put (Name_Table.Get_Character (El_Id));
               Last_Enum := Char;
            else
               case Last_Enum is
                  when None =>
                     null;
                  when Identifier =>
                     Put (" & ");
                  when Char =>
                     Put (""" & ");
               end case;
               Put (Name_Table.Image (El_Id));
               Last_Enum := Identifier;
            end if;
         end loop;
         case Last_Enum is
            when None =>
               Put ("""""");  --  Simply ""
            when Identifier =>
               null;
            when Char =>
               Put ("""");
         end case;
      else
         Put ("(");
         for I in 1 .. Bound.Len loop
            if I /= 1 then
               Put (", ");
            end if;
            Disp_Memtyp ((El_Typ, Mem.Mem + Size_Type (I - 1) * Mem.Typ.Sz),
                         El_Type);
         end loop;
         Put (")");
      end if;
   end Disp_Value_Vector;

   procedure Disp_Value_Array (Mem : Memtyp; A_Type: Node; Dim: Dim_Type)
   is
      Stride : Size_Type;
   begin
      if Dim = Mem.Typ.Abounds.Ndim then
         --  Last dimension
         Disp_Value_Vector (Mem, A_Type, Mem.Typ.Abounds.D (Dim));
      else
         Stride := Mem.Typ.Arr_El.Sz;
         for I in Dim + 1 .. Mem.Typ.Abounds.Ndim loop
            Stride := Stride * Size_Type (Mem.Typ.Abounds.D (I).Len);
         end loop;

         Put ("(");
         for I in 1 .. Mem.Typ.Abounds.D (Dim).Len loop
            if I /= 1 then
               Put (", ");
            end if;
            Disp_Value_Array ((Mem.Typ, Mem.Mem + Stride), A_Type, Dim + 1);
         end loop;
         Put (")");
      end if;
   end Disp_Value_Array;

   procedure Disp_Memtyp (M : Memtyp; Vtype : Node) is
   begin
      if M.Mem = null then
         Put ("*NULL*");
         return;
      end if;

      case M.Typ.Kind is
         when Type_Discrete
           | Type_Bit
           | Type_Logic =>
            Disp_Discrete_Value (Read_Discrete (M), Get_Base_Type (Vtype));
         when Type_Vector =>
            Disp_Value_Vector (M, Vtype, M.Typ.Vbound);
         when Type_Array =>
            Disp_Value_Array (M, Vtype, 1);
         when Type_Float =>
            Put ("*float*");
         when Type_Slice =>
            Put ("*slice*");
         when Type_File =>
            Put ("*file*");
         when Type_Record =>
            Put ("*record*");
         when Type_Access =>
            Put ("*access*");
         when Type_Protected =>
            Put ("*protected*");
         when Type_Unbounded_Array
            | Type_Unbounded_Record
            | Type_Unbounded_Vector =>
            Put ("*unbounded*");
      end case;
   end Disp_Memtyp;

   procedure Disp_Value (Vt : Valtyp; Vtype : Node) is
   begin
      if Vt.Val = null then
         Put ("*NULL*");
         return;
      end if;

      case Vt.Val.Kind is
         when Value_Net =>
            Put ("net");
         when Value_Wire =>
            Put ("wire");
         when Value_Signal =>
            Put ("signal");
         when Value_File =>
            Put ("file");
         when Value_Const =>
            Put ("const: ");
            Disp_Memtyp (Get_Memtyp (Vt), Vtype);
         when Value_Alias =>
            Put ("alias");
            Disp_Memtyp (Get_Memtyp (Vt), Vtype);
         when Value_Memory =>
            Disp_Memtyp (Get_Memtyp (Vt), Vtype);
      end case;
   end Disp_Value;

   procedure Disp_Bound_Type (Bound : Bound_Type) is
   begin
      Put_Int32 (Bound.Left);
      Put (' ');
      case Bound.Dir is
         when Dir_To =>
            Put ("to");
         when Dir_Downto =>
            Put ("downto");
      end case;
      Put (' ');
      Put_Int32 (Bound.Right);
   end Disp_Bound_Type;

   procedure Disp_Type (Typ : Type_Acc; Vtype : Node)
   is
      pragma Unreferenced (Vtype);
   begin
      case Typ.Kind is
         when Type_Bit =>
            Put ("bit");
         when Type_Logic =>
            Put ("logic");
         when Type_Discrete =>
            Put ("discrete");
         when Type_Float =>
            Put ("float");
         when Type_Vector =>
            Put ("vector (");
            Disp_Bound_Type (Typ.Vbound);
            Put (')');
         when Type_Unbounded_Vector =>
            Put ("unbounded_vector");
         when Type_Array =>
            Put ("array");
         when Type_Unbounded_Array =>
            Put ("unbounded_array");
         when Type_Unbounded_Record =>
            Put ("unbounded_record");
         when Type_Record =>
            Put ("record");
         when Type_Slice =>
            Put ("slice");
         when Type_Access =>
            Put ("access");
         when Type_File =>
            Put ("file");
         when Type_Protected =>
            Put ("protected");
      end case;
   end Disp_Type;

   procedure Disp_Declaration_Object
     (Instance : Synth_Instance_Acc; Decl : Iir) is
   begin
      case Get_Kind (Decl) is
         when Iir_Kind_Constant_Declaration
           | Iir_Kind_Variable_Declaration
           | Iir_Kind_Interface_Variable_Declaration
           | Iir_Kind_Interface_Constant_Declaration
           | Iir_Kind_Interface_File_Declaration
           | Iir_Kind_Object_Alias_Declaration
           | Iir_Kind_Interface_Signal_Declaration
           | Iir_Kind_Signal_Declaration
           | Iir_Kind_File_Declaration =>
            declare
               Val : constant Valtyp := Get_Value (Instance, Decl);
               Dtype : constant Node := Get_Type (Decl);
            begin
               Put (Vhdl.Errors.Disp_Node (Decl));
               Put (": ");
               Disp_Type (Val.Typ, Dtype);
               Put (" = ");
               Disp_Value (Val, Dtype);
               New_Line;
            end;
         when Iir_Kinds_Signal_Attribute =>
            --  FIXME: todo ?
            null;
         when Iir_Kind_Type_Declaration
           | Iir_Kind_Anonymous_Type_Declaration
           | Iir_Kind_Subtype_Declaration =>
            --  FIXME: disp ranges
            null;
         when Iir_Kind_Function_Declaration
           | Iir_Kind_Function_Body
           | Iir_Kind_Procedure_Declaration
           | Iir_Kind_Procedure_Body =>
            null;
         when others =>
            Vhdl.Errors.Error_Kind ("disp_declaration_object", Decl);
      end case;
   end Disp_Declaration_Object;

   procedure Disp_Declaration_Objects
     (Instance : Synth_Instance_Acc; Decl_Chain : Iir)
   is
      El : Iir;
   begin
      El := Decl_Chain;
      while El /= Null_Iir loop
         Disp_Declaration_Object (Instance, El);
         El := Get_Chain (El);
      end loop;
   end Disp_Declaration_Objects;

   procedure Info_Params_Proc (Line : String)
   is
      pragma Unreferenced (Line);
      Decl : Iir;
      Params : Iir;
   begin
      Decl := Get_Source_Scope (Current_Instance);
      loop
         case Get_Kind (Decl) is
            when Iir_Kind_Procedure_Body
              | Iir_Kind_Function_Body =>
               Decl := Get_Subprogram_Specification (Decl);
               exit;
            when Iir_Kind_Process_Statement
              | Iir_Kind_Sensitized_Process_Statement =>
               Put_Line ("processes have no parameters");
               return;
            when Iir_Kind_While_Loop_Statement
              | Iir_Kind_If_Statement
              | Iir_Kind_For_Loop_Statement
              | Iir_Kind_Case_Statement =>
               Decl := Get_Parent (Decl);
            when others =>
               Vhdl.Errors.Error_Kind ("info_params_proc", Decl);
         end case;
      end loop;
      Params := Get_Interface_Declaration_Chain (Decl);
      Disp_Declaration_Objects (Current_Instance, Params);
   end Info_Params_Proc;

   procedure Info_Locals_Proc (Line : String)
   is
      pragma Unreferenced (Line);
      Decl : Iir;
      Decls : Iir;
   begin
      --  From statement to declaration.
      Decl := Get_Source_Scope (Current_Instance);
      loop
         case Get_Kind (Decl) is
            when Iir_Kind_Procedure_Body
               | Iir_Kind_Function_Body
               | Iir_Kind_Process_Statement
               | Iir_Kind_Sensitized_Process_Statement
               | Iir_Kind_Generate_Statement_Body =>
               Decls := Get_Declaration_Chain (Decl);
               exit;
            when Iir_Kind_While_Loop_Statement
              | Iir_Kind_If_Statement
              | Iir_Kind_For_Loop_Statement
              | Iir_Kind_Case_Statement =>
               Decl := Get_Parent (Decl);
            when others =>
               Vhdl.Errors.Error_Kind ("info_params_proc", Decl);
         end case;
      end loop;
      Disp_Declaration_Objects (Current_Instance, Decls);
   end Info_Locals_Proc;

   procedure Info_Instance_Proc (Line : String)
   is
      pragma Unreferenced (Line);
   begin
      Debug_Synth_Instance (Current_Instance);
   end Info_Instance_Proc;

   function Walk_Files (Cb : Walk_Cb) return Walk_Status
   is
      Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain;
      File : Iir_Design_File;
   begin
      while Lib /= Null_Iir loop
         File := Get_Design_File_Chain (Lib);
         while File /= Null_Iir loop
            case Cb.all (File) is
               when Walk_Continue =>
                  null;
               when Walk_Up =>
                  exit;
               when Walk_Abort =>
                  return Walk_Abort;
            end case;
            File := Get_Chain (File);
         end loop;
         Lib := Get_Chain (Lib);
      end loop;
      return Walk_Continue;
   end Walk_Files;

   Walk_Units_Cb : Walk_Cb;

   function Cb_Walk_Units (Design_File : Iir) return Walk_Status
   is
      Unit : Iir_Design_Unit;
   begin
      Unit := Get_First_Design_Unit (Design_File);
      while Unit /= Null_Iir loop
         case Walk_Units_Cb.all (Get_Library_Unit (Unit)) is
            when Walk_Continue =>
               null;
            when Walk_Abort =>
               return Walk_Abort;
            when Walk_Up =>
               exit;
         end case;
         Unit := Get_Chain (Unit);
      end loop;
      return Walk_Continue;
   end Cb_Walk_Units;

   function Walk_Units (Cb : Walk_Cb) return Walk_Status is
   begin
      Walk_Units_Cb := Cb;
      return Walk_Files (Cb_Walk_Units'Access);
   end Walk_Units;

   Walk_Declarations_Cb : Walk_Cb;

   function Cb_Walk_Declarations (Unit : Iir) return Walk_Status
   is
      function Walk_Decl_Chain (Chain : Iir) return Walk_Status
      is
         Decl : Iir;
      begin
         Decl := Chain;
         while Decl /= Null_Iir loop
            case Walk_Declarations_Cb.all (Decl) is
               when Walk_Abort =>
                  return Walk_Abort;
               when Walk_Up =>
                  return Walk_Continue;
               when Walk_Continue =>
                  null;
            end case;
            Decl := Get_Chain (Decl);
         end loop;
         return Walk_Continue;
      end Walk_Decl_Chain;

      function Walk_Conc_Chain (Chain : Iir) return Walk_Status;

      function Walk_Generate_Statement_Body (Bod : Iir) return Walk_Status is
      begin
         if Walk_Decl_Chain (Get_Declaration_Chain (Bod)) = Walk_Abort then
            return Walk_Abort;
         end if;
         if Walk_Conc_Chain (Get_Concurrent_Statement_Chain (Bod)) = Walk_Abort
         then
            return Walk_Abort;
         end if;
         return Walk_Continue;
      end Walk_Generate_Statement_Body;

      function Walk_Conc_Chain (Chain : Iir) return Walk_Status
      is
         Stmt : Iir := Chain;
      begin
         while Stmt /= Null_Iir loop
            case Get_Kind (Stmt) is
               when Iir_Kinds_Process_Statement =>
                  if Walk_Decl_Chain (Get_Declaration_Chain (Stmt))
                    = Walk_Abort
                  then
                     return Walk_Abort;
                  end if;
               when Iir_Kind_For_Generate_Statement =>
                  if Walk_Declarations_Cb.all
                    (Get_Parameter_Specification (Stmt)) = Walk_Abort
                    or else Walk_Generate_Statement_Body
                    (Get_Generate_Statement_Body (Stmt)) = Walk_Abort
                  then
                     return Walk_Abort;
                  end if;
               when Iir_Kind_If_Generate_Statement =>
                  declare
                     Stmt1 : Iir;
                  begin
                     Stmt1 := Stmt;
                     while Stmt1 /= Null_Iir loop
                        if Walk_Generate_Statement_Body
                          (Get_Generate_Statement_Body (Stmt)) = Walk_Abort
                        then
                           return Walk_Abort;
                        end if;
                        Stmt1 := Get_Generate_Else_Clause (Stmt1);
                     end loop;
                  end;
               when Iir_Kind_Component_Instantiation_Statement
                 | Iir_Kind_Concurrent_Simple_Signal_Assignment =>
                  null;
               when Iir_Kind_Block_Statement =>
                  --  FIXME: header
                  if (Walk_Decl_Chain
                        (Get_Declaration_Chain (Stmt)) = Walk_Abort)
                    or else
                    (Walk_Conc_Chain
                       (Get_Concurrent_Statement_Chain (Stmt)) = Walk_Abort)
                  then
                     return Walk_Abort;
                  end if;
               when others =>
                  Vhdl.Errors.Error_Kind ("walk_conc_chain", Stmt);
            end case;
            Stmt := Get_Chain (Stmt);
         end loop;
         return Walk_Continue;
      end Walk_Conc_Chain;
   begin
      case Get_Kind (Unit) is
         when Iir_Kind_Entity_Declaration =>
            if Walk_Decl_Chain (Get_Generic_Chain (Unit)) = Walk_Abort
              or else Walk_Decl_Chain (Get_Port_Chain (Unit)) = Walk_Abort
              or else (Walk_Decl_Chain
                         (Get_Declaration_Chain (Unit)) = Walk_Abort)
              or else (Walk_Conc_Chain
                         (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort)
            then
               return Walk_Abort;
            end if;
         when Iir_Kind_Architecture_Body =>
            if (Walk_Decl_Chain
                  (Get_Declaration_Chain (Unit)) = Walk_Abort)
              or else (Walk_Conc_Chain
                         (Get_Concurrent_Statement_Chain (Unit)) = Walk_Abort)
            then
               return Walk_Abort;
            end if;
         when Iir_Kind_Package_Declaration
           | Iir_Kind_Package_Body =>
            if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort
            then
               return Walk_Abort;
            end if;
         when Iir_Kind_Configuration_Declaration =>
            if Walk_Decl_Chain (Get_Declaration_Chain (Unit)) = Walk_Abort
            then
               return Walk_Abort;
            end if;
            --  FIXME: block configuration ?
         when Iir_Kind_Context_Declaration =>
            null;
         when others =>
            Vhdl.Errors.Error_Kind ("Cb_Walk_Declarations", Unit);
      end case;
      return Walk_Continue;
   end Cb_Walk_Declarations;

   function Walk_Declarations (Cb : Walk_Cb) return Walk_Status is
   begin
      Walk_Declarations_Cb := Cb;
      return Walk_Units (Cb_Walk_Declarations'Access);
   end Walk_Declarations;

   --  Next statement in the same frame, but handle compound statements as
   --  one statement.
   procedure Next_Stmt_Proc (Line : String)
   is
      pragma Unreferenced (Line);
   begin
      Exec_State := Exec_Next_Stmt;
      Exec_Instance := Current_Instance;
      Exec_Statement := Current_Loc;
      Flag_Need_Debug := True;
      Command_Status := Status_Quit;
   end Next_Stmt_Proc;

   --  Finish parent statement.
   procedure Finish_Stmt_Proc (Line : String)
   is
      pragma Unreferenced (Line);
   begin
      Exec_State := Exec_Next_Stmt;
      Exec_Instance := Current_Instance;
      Exec_Statement := Get_Parent (Current_Loc);
      Flag_Need_Debug := True;
      Command_Status := Status_Quit;
   end Finish_Stmt_Proc;

   procedure Next_Proc (Line : String)
   is
      pragma Unreferenced (Line);
   begin
      Exec_State := Exec_Next;
      Exec_Instance := Current_Instance;
      Flag_Need_Debug := True;
      Command_Status := Status_Quit;
      Cmd_Repeat := Next_Proc'Access;
   end Next_Proc;

   procedure Step_Proc (Line : String)
   is
      pragma Unreferenced (Line);
   begin
      Exec_State := Exec_Single_Step;
      Flag_Need_Debug := True;
      Command_Status := Status_Quit;
      Cmd_Repeat := Step_Proc'Access;
   end Step_Proc;

   Break_Id : Name_Id;

   procedure Set_Breakpoint (Stmt : Iir) is
   begin
      Put_Line ("set breakpoint at: " & Files_Map.Image (Get_Location (Stmt)));
      Breakpoints.Append (Stmt);
      Flag_Need_Debug := True;
   end Set_Breakpoint;

   function Cb_Set_Break (El : Iir) return Walk_Status is
   begin
      case Get_Kind (El) is
         when Iir_Kind_Function_Declaration
           | Iir_Kind_Procedure_Declaration =>
            if Get_Identifier (El) = Break_Id
              and then
              Get_Implicit_Definition (El) not in Iir_Predefined_Implicit
            then
               Set_Breakpoint
                 (Get_Sequential_Statement_Chain (Get_Subprogram_Body (El)));
            end if;
         when others =>
            null;
      end case;
      return Walk_Continue;
   end Cb_Set_Break;

   procedure Break_Proc (Line : String)
   is
      Status : Walk_Status;
      P : Natural;
   begin
      P := Skip_Blanks (Line);
      if Line (P) = '"' then
         --  An operator name.
         declare
            use Str_Table;
            Str : String8_Id;
            Len : Nat32;
         begin
            Str := Create_String8;
            Len := 0;
            P := P + 1;
            while Line (P) /= '"' loop
               Append_String8_Char (Line (P));
               Len := Len + 1;
               P := P + 1;
            end loop;
            Break_Id := Vhdl.Parse.Str_To_Operator_Name
              (Str, Len, No_Location);
            --  FIXME: free string.
            --  FIXME: catch error.
         end;
      else
         Break_Id := Name_Table.Get_Identifier (Line (P .. Line'Last));
      end if;
      Status := Walk_Declarations (Cb_Set_Break'Access);
      pragma Assert (Status = Walk_Continue);
   end Break_Proc;

   procedure Help_Proc (Line : String);

   procedure Prepare_Continue is
   begin
      Command_Status := Status_Quit;

      --  Set Flag_Need_Debug only if there is at least one enabled breakpoint.
      Flag_Need_Debug := False;
      for I in Breakpoints.First .. Breakpoints.Last loop
         Flag_Need_Debug := True;
         exit;
      end loop;
   end Prepare_Continue;

   procedure Cont_Proc (Line : String) is
      pragma Unreferenced (Line);
   begin
      Prepare_Continue;
   end Cont_Proc;

   procedure List_Proc (Line : String)
   is
      pragma Unreferenced (Line);
   begin
      Disp_Current_Lines;
   end List_Proc;

   Menu_Info_Instance : aliased Menu_Entry :=
     (Kind => Menu_Command,
      Name => new String'("inst*ance"),
      Next => null, -- Menu_Info_Tree'Access,
      Proc => Info_Instance_Proc'Access);

   Menu_Info_Locals : aliased Menu_Entry :=
     (Kind => Menu_Command,
      Name => new String'("locals"),
      Next => Menu_Info_Instance'Access,
      Proc => Info_Locals_Proc'Access);

   Menu_Info_Params : aliased Menu_Entry :=
     (Kind => Menu_Command,
      Name => new String'("param*eters"),
      Next => Menu_Info_Locals'Access, -- Menu_Info_Tree'Access,
      Proc => Info_Params_Proc'Access);

   Menu_Info : aliased Menu_Entry :=
     (Kind => Menu_Submenu,
      Name => new String'("i*nfo"),
      Next => null, -- Menu_Ps'Access,
      First | Last => Menu_Info_Params'Access); --  Menu_Info_Proc'Access);

   Menu_List : aliased Menu_Entry :=
     (Kind => Menu_Command,
      Name => new String'("l*list"),
      Next => Menu_Info'Access, -- null,
      Proc => List_Proc'Access);

   Menu_Cont : aliased Menu_Entry :=
     (Kind => Menu_Command,
      Name => new String'("c*ont"),
      Next => Menu_List'Access, --Menu_Print'Access,
      Proc => Cont_Proc'Access);

   Menu_Nstmt : aliased Menu_Entry :=
     (Kind => Menu_Command,
      Name => new String'("ns*tmt"),
      Next => Menu_Cont'Access, -- Menu_Up'Access,
      Proc => Next_Stmt_Proc'Access);

   Menu_Fstmt : aliased Menu_Entry :=
     (Kind => Menu_Command,
      Name => new String'("fs*tmt"),
      Next => Menu_Nstmt'Access,
      Proc => Finish_Stmt_Proc'Access);

   Menu_Next : aliased Menu_Entry :=
     (Kind => Menu_Command,
      Name => new String'("n*ext"),
      Next => Menu_Fstmt'Access,
      Proc => Next_Proc'Access);

   Menu_Step : aliased Menu_Entry :=
     (Kind => Menu_Command,
      Name => new String'("s*tep"),
      Next => Menu_Next'Access,
      Proc => Step_Proc'Access);

   Menu_Break : aliased Menu_Entry :=
     (Kind => Menu_Command,
      Name => new String'("b*reak"),
      Next => Menu_Step'Access,
      Proc => Break_Proc'Access);

   Menu_Help2 : aliased Menu_Entry :=
     (Kind => Menu_Command,
      Name => new String'("?"),
      Next => Menu_Break'Access, --  Menu_Help1'Access,
      Proc => Help_Proc'Access);

   Menu_Top : aliased Menu_Entry :=
     (Kind => Menu_Submenu,
      Name => null,
      Next => null,
      First | Last => Menu_Help2'Access);


   function Find_Menu (Menu : Menu_Entry_Acc; Cmd : String)
                      return Menu_Entry_Acc
   is
      function Is_Cmd (Cmd_Name : String; Str : String) return Boolean
      is
         -- Number of characters that were compared.
         P : Natural;
      begin
         P := 0;
         --  Prefix (before the '*').
         loop
            if P = Cmd_Name'Length then
               --  Full match.
               return P = Str'Length;
            end if;
            exit when Cmd_Name (Cmd_Name'First + P) = '*';
            if P = Str'Length then
               --  Command is too short
               return False;
            end if;
            if Cmd_Name (Cmd_Name'First + P) /= Str (Str'First + P) then
               return False;
            end if;
            P := P + 1;
         end loop;
         --  Suffix (after the '*')
         loop
            if P = Str'Length then
               return True;
            end if;
            if P + 1 = Cmd_Name'Length then
               --  String is too long
               return False;
            end if;
            if Cmd_Name (Cmd_Name'First + P + 1) /= Str (Str'First + P) then
               return False;
            end if;
            P := P + 1;
         end loop;
      end Is_Cmd;
      Ent : Menu_Entry_Acc;
   begin
      Ent := Menu.First;
      while Ent /= null loop
         if Is_Cmd (Ent.Name.all, Cmd) then
            return Ent;
         end if;
         Ent := Ent.Next;
      end loop;
      return null;
   end Find_Menu;

   procedure Parse_Command (Line : String;
                            P : in out Natural;
                            Menu : out Menu_Entry_Acc)
   is
      E : Natural;
   begin
      P := Skip_Blanks (Line (P .. Line'Last));
      if P > Line'Last then
         return;
      end if;
      E := Get_Word (Line (P .. Line'Last));
      Menu := Find_Menu (Menu, Line (P .. E));
      if Menu = null then
         Put_Line ("command '" & Line (P .. E) & "' not found");
      end if;
      P := E + 1;
   end Parse_Command;

   procedure Help_Proc (Line : String)
   is
      P : Natural;
      Root : Menu_Entry_Acc := Menu_Top'access;
   begin
      Put_Line ("This is the help command");
      P := Line'First;
      while P < Line'Last loop
         Parse_Command (Line, P, Root);
         if Root = null then
            return;
         elsif Root.Kind /= Menu_Submenu then
            Put_Line ("Menu entry " & Root.Name.all & " is not a submenu");
            return;
         end if;
      end loop;

      Root := Root.First;
      while Root /= null loop
         Put (Root.Name.all);
         if Root.Kind = Menu_Submenu then
            Put (" (menu)");
         end if;
         New_Line;
         Root := Root.Next;
      end loop;
   end Help_Proc;

   procedure Debug (Reason: Debug_Reason)
   is
      use Grt.Readline;
      Raw_Line : Char_Ptr;
      Prompt : System.Address;
   begin
      Prompt := Prompt_Debug'Address;

      case Reason is
         when Reason_Init =>
            Prompt := Prompt_Init'Address;
         when Reason_Error =>
            Prompt := Prompt_Error'Address;
         when Reason_Break =>
            case Exec_State is
               when Exec_Run =>
                  if not Is_Breakpoint_Hit then
                     return;
                  end if;
                  Put_Line ("breakpoint hit");
               when Exec_Single_Step =>
                  null;
               when Exec_Next =>
                  if Current_Instance /= Exec_Instance then
                     return;
                  end if;
               when Exec_Next_Stmt =>
                  if Current_Instance /= Exec_Instance
                    or else Is_Within_Statement (Exec_Statement, Current_Loc)
                  then
                     return;
                  end if;
            end case;
            --  Default state.
            Exec_State := Exec_Run;

      end case;

      case Reason is
         when Reason_Error
           | Reason_Break =>
            Put ("stopped at: ");
            Disp_Iir_Location (Current_Loc);
            New_Line;
            Disp_Source_Line (Get_Location (Current_Loc));
         when others =>
            null;
      end case;

      if Current_Loc /= Null_Node then
         Set_List_Current (Get_Location (Current_Loc));
      end if;

      Command_Status := Status_Default;

      loop
         loop
            Raw_Line := Readline (Prompt);
            --  Skip empty lines
            if Raw_Line = null or else Raw_Line (1) = ASCII.NUL then
               if Cmd_Repeat /= null then
                  Cmd_Repeat.all ("");
                  case Command_Status is
                     when Status_Default =>
                        null;
                     when Status_Quit =>
                        return;
                  end case;
               end if;
            else
               Cmd_Repeat := null;
               exit;
            end if;
         end loop;
         declare
            Line_Last : constant Natural := Strlen (Raw_Line);
            Line : String renames Raw_Line (1 .. Line_Last);
            P, E : Positive;
            Cmd : Menu_Entry_Acc := Menu_Top'Access;
         begin
            --  Find command
            P := 1;
            loop
               E := P;
               Parse_Command (Line, E, Cmd);
               exit when Cmd = null;
               case Cmd.Kind is
                  when Menu_Submenu =>
                     if E > Line_Last then
                        Put_Line ("missing command for submenu "
                                    & Line (P .. E - 1));
                        Cmd := null;
                        exit;
                     end if;
                     P := E;
                  when Menu_Command =>
                     exit;
               end case;
            end loop;

            if Cmd /= null then
               Cmd.Proc.all (Line (E .. Line_Last));

               case Command_Status is
                  when Status_Default =>
                     null;
                  when Status_Quit =>
                     exit;
               end case;
            end if;
         exception
            when Command_Error =>
               null;
         end;
      end loop;
      --  Put ("resuming");
   end Debug;

   procedure Debug_Init (Top : Node) is
   begin
      Flag_Enabled := True;

      Current_Instance := null;
      Current_Loc := Top;

      --  To avoid warnings.
      Exec_Statement := Null_Node;
      Exec_Instance := null;

      Debug (Reason_Init);
   end Debug_Init;

   procedure Debug_Break (Inst : Synth_Instance_Acc; Stmt : Node) is
   begin
      Current_Instance := Inst;
      Current_Loc := Stmt;

      Debug (Reason_Break);
   end Debug_Break;

   procedure Debug_Leave (Inst : Synth_Instance_Acc) is
   begin
      if Exec_Instance = Inst then
         --  Will be destroyed.
         Exec_Instance := null;

         case Exec_State is
            when Exec_Run =>
               null;
            when Exec_Single_Step =>
               null;
            when Exec_Next
              | Exec_Next_Stmt =>
               --  Leave the frame, will stop just after.
               Exec_State := Exec_Single_Step;
         end case;
      end if;
   end Debug_Leave;

   procedure Debug_Error (Inst : Synth_Instance_Acc; Expr : Node) is
   begin
      if Flag_Enabled then
         Current_Instance := Inst;
         Current_Loc := Expr;
         Debug (Reason_Error);
      end if;
   end Debug_Error;

   procedure Disp_A_Frame (Inst: Synth_Instance_Acc) is
   begin
      if Inst = Root_Instance then
         Put_Line ("root instance");
         return;
      end if;

      Put (Vhdl.Errors.Disp_Node (Get_Source_Scope (Inst)));
--      if Inst.Stmt /= Null_Iir then
--         Put (" at ");
--         Put (Files_Map.Image (Get_Location (Inst.Stmt)));
--      end if;
      New_Line;
   end Disp_A_Frame;

   procedure Debug_Bt (Instance : Synth_Instance_Acc)
   is
      Inst : Synth_Instance_Acc;
   begin
      Inst := Instance;
      while Inst /= null loop
         Disp_A_Frame (Inst);
         Inst := Get_Caller_Instance (Inst);
      end loop;
   end Debug_Bt;
   pragma Unreferenced (Debug_Bt);

end Elab.Debugger;