diff options
Diffstat (limited to 'src/simulate/debugger.adb')
| -rw-r--r-- | src/simulate/debugger.adb | 1845 |
1 files changed, 1845 insertions, 0 deletions
diff --git a/src/simulate/debugger.adb b/src/simulate/debugger.adb new file mode 100644 index 000000000..5a43533d6 --- /dev/null +++ b/src/simulate/debugger.adb @@ -0,0 +1,1845 @@ +-- Debugger for interpreter +-- Copyright (C) 2014 Tristan Gingold +-- +-- GHDL 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, or (at your option) any later +-- version. +-- +-- GHDL 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 GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. + +with System; +with Ada.Text_IO; use Ada.Text_IO; +with GNAT.Table; +with Types; use Types; +with Iir_Values; use Iir_Values; +with Name_Table; +with Files_Map; +with Parse; +with Scanner; +with Tokens; +with Sem_Expr; +with Sem_Scopes; +with Std_Names; +with Libraries; +with Std_Package; +with Annotations; use Annotations; +with Iirs_Utils; use Iirs_Utils; +with Errorout; use Errorout; +with Disp_Vhdl; +with Execution; use Execution; +with Simulation; use Simulation; +with Iirs_Walk; use Iirs_Walk; +with Areapools; use Areapools; +with Grt.Disp; +with Grt.Readline; +with Grt.Errors; +with Grt.Disp_Signals; + +package body Debugger is + -- This exception can be raised by a debugger command to directly return + -- to the prompt. + Command_Error : exception; + + Dbg_Top_Frame : Block_Instance_Acc; + Dbg_Cur_Frame : Block_Instance_Acc; + + procedure Set_Cur_Frame (Frame : Block_Instance_Acc) is + begin + Dbg_Cur_Frame := Frame; + end Set_Cur_Frame; + + procedure Set_Top_Frame (Frame : Block_Instance_Acc) is + begin + Dbg_Top_Frame := Frame; + Set_Cur_Frame (Frame); + end Set_Top_Frame; + + type Breakpoint_Entry is record + Stmt : Iir; + end record; + + package Breakpoints is new GNAT.Table + (Table_Index_Type => Natural, + Table_Component_Type => Breakpoint_Entry, + Table_Low_Bound => 1, + Table_Initial => 16, + Table_Increment => 100); + + -- 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 statement in the same frame. + Exec_Next); + + Exec_State : Exec_State_Type := Exec_Run; + + Exec_Instance : Block_Instance_Acc; + + -- Disp a message during execution. + procedure Error_Msg_Exec (Msg: String; Loc: in Iir) is + begin + Disp_Iir_Location (Loc); + Put (Standard_Error, ' '); + Put_Line (Standard_Error, Msg); + Grt.Errors.Fatal_Error; + end Error_Msg_Exec; + + procedure Warning_Msg_Exec (Msg: String; Loc: Iir) is + begin + Disp_Iir_Location (Loc); + Put (Standard_Error, "warning: "); + Put_Line (Standard_Error, Msg); + end Warning_Msg_Exec; + + -- Disp a message for a constraint error. + procedure Error_Msg_Constraint (Expr: in Iir) is + begin + if Expr /= Null_Iir then + Disp_Iir_Location (Expr); + end if; + Put (Standard_Error, "constraint violation"); + if Expr /= Null_Iir then + case Get_Kind (Expr) is + when Iir_Kind_Addition_Operator => + Put_Line (Standard_Error, " in the ""+"" operation"); + when Iir_Kind_Substraction_Operator => + Put_Line (Standard_Error, " in the ""-"" operation"); + when Iir_Kind_Integer_Literal => + Put_Line (Standard_Error, ", literal out of range"); + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Signal_Declaration => + Put_Line (Standard_Error, " for " & Disp_Node (Expr)); + when others => + New_Line (Standard_Error); + end case; + end if; + Grt.Errors.Fatal_Error; + end Error_Msg_Constraint; + + function Get_Instance_Local_Name (Instance : Block_Instance_Acc; + Short : Boolean := False) + return String + is + Name : constant Iir := Instance.Label; + begin + if Name = Null_Iir then + return "<anon>"; + end if; + + case Get_Kind (Name) is + when Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement + | Iir_Kind_Component_Instantiation_Statement + | Iir_Kind_Procedure_Declaration + | Iir_Kinds_Process_Statement => + return Image_Identifier (Name); + when Iir_Kind_Iterator_Declaration => + return Image_Identifier (Get_Parent (Name)) & '(' + & Execute_Image_Attribute + (Instance.Objects (Get_Info (Name).Slot), Get_Type (Name)) + & ')'; + when Iir_Kind_Architecture_Body => + if Short then + return Image_Identifier (Get_Entity (Name)); + else + return Image_Identifier (Get_Entity (Name)) + & '(' & Image_Identifier (Name) & ')'; + end if; + when others => + Error_Kind ("disp_instance_local_name", Name); + end case; + end Get_Instance_Local_Name; + + -- Disp the name of an instance, without newline. + procedure Disp_Instance_Name (Instance: Block_Instance_Acc; + Short : Boolean := False) is + begin + if Instance.Parent /= null then + Disp_Instance_Name (Instance.Parent); + Put ('.'); + end if; + Put (Get_Instance_Local_Name (Instance, Short)); + end Disp_Instance_Name; + + function Get_Instance_Name (Instance: Block_Instance_Acc) return String + is + function Parent_Name return String is + begin + if Instance.Parent /= null then + return Get_Instance_Name (Instance.Parent) & '.'; + else + return ""; + end if; + end Parent_Name; + begin + return Parent_Name & Get_Instance_Local_Name (Instance); + end Get_Instance_Name; + + procedure Disp_Instances_Tree_Name (Inst : Block_Instance_Acc) is + begin + if Inst = null then + Put ("*null*"); + New_Line; + return; + end if; + Put (Get_Instance_Local_Name (Inst)); + + Put (" "); + case Get_Kind (Inst.Label) is + when Iir_Kind_Block_Statement => + Put ("[block]"); + when Iir_Kind_Generate_Statement => + Put ("[generate]"); + when Iir_Kind_Iterator_Declaration => + Put ("[iterator]"); + when Iir_Kind_Component_Instantiation_Statement => + Put ("[component]"); + when Iir_Kinds_Process_Statement => + Put ("[process]"); + when Iir_Kind_Architecture_Body => + Put ("[entity]"); + when others => + Error_Kind ("disp_instances_tree1", Inst.Label); + end case; + New_Line; + end Disp_Instances_Tree_Name; + + procedure Disp_Instances_Tree1 (Inst : Block_Instance_Acc; Pfx : String) + is + Child : Block_Instance_Acc; + begin + Child := Inst.Children; + if Child = null then + return; + end if; + + loop + if Child.Brother /= null then + Put (Pfx & "+-"); + Disp_Instances_Tree_Name (Child); + + Disp_Instances_Tree1 (Child, Pfx & "| "); + Child := Child.Brother; + else + Put (Pfx & "`-"); + Disp_Instances_Tree_Name (Child); + + Disp_Instances_Tree1 (Child, Pfx & " "); + exit; + end if; + end loop; + end Disp_Instances_Tree1; + + procedure Disp_Instances_Tree is + begin + Disp_Instances_Tree_Name (Top_Instance); + Disp_Instances_Tree1 (Top_Instance, ""); + end Disp_Instances_Tree; + + -- Disp a block instance, in a human readable way. + -- Used to debug. + procedure Disp_Block_Instance (Instance: Block_Instance_Acc) is + begin + Put_Line ("scope level:" + & Scope_Level_Type'Image (Instance.Scope_Level)); + Put_Line ("Objects:"); + for I in Instance.Objects'Range loop + Put (Object_Slot_Type'Image (I) & ": "); + Disp_Value_Tab (Instance.Objects (I), 3); + New_Line; + end loop; + end Disp_Block_Instance; + + procedure Disp_Signal (Value : Iir_Value_Literal_Acc; A_Type : Iir); + + procedure Disp_Signal_Array (Value : Iir_Value_Literal_Acc; + A_Type : Iir; + Dim : Natural) + is + begin + if Dim = Get_Nbr_Elements (Get_Index_Subtype_List (A_Type)) then + Put ("("); + for I in Value.Val_Array.V'Range loop + if I /= 1 then + Put (", "); + end if; + Disp_Signal (Value.Val_Array.V (I), Get_Element_Subtype (A_Type)); + end loop; + Put (")"); + else + Put ("("); + Disp_Signal_Array (Value, A_Type, Dim + 1); + Put (")"); + end if; + end Disp_Signal_Array; + + procedure Disp_Signal_Record (Value : Iir_Value_Literal_Acc; A_Type : Iir) + is + El : Iir_Element_Declaration; + List : Iir_List; + begin + List := Get_Elements_Declaration_List (Get_Base_Type (A_Type)); + Put ("("); + for I in Value.Val_Record.V'Range loop + El := Get_Nth_Element (List, Natural (I - 1)); + if I /= 1 then + Put (", "); + end if; + Put (Name_Table.Image (Get_Identifier (El))); + Put (" => "); + Disp_Signal (Value.Val_Record.V (I), Get_Type (El)); + end loop; + Put (")"); + end Disp_Signal_Record; + + procedure Disp_Signal (Value : Iir_Value_Literal_Acc; A_Type : Iir) is + begin + if Value = null then + Put ("!NULL!"); + return; + end if; + case Value.Kind is + when Iir_Value_I64 + | Iir_Value_F64 + | Iir_Value_E32 + | Iir_Value_B1 + | Iir_Value_Access => + Disp_Iir_Value (Value, A_Type); + when Iir_Value_Array => + Disp_Signal_Array (Value, A_Type, 1); + when Iir_Value_Record => + Disp_Signal_Record (Value, A_Type); + when Iir_Value_Range => + -- FIXME. + raise Internal_Error; + when Iir_Value_Signal => + Grt.Disp_Signals.Disp_A_Signal (Value.Sig); + when Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Disp_Signal; + + procedure Disp_Instance_Signal (Instance: Block_Instance_Acc; Decl : Iir) + is + Info : constant Sim_Info_Acc := Get_Info (Decl); + begin + Put (" "); + Put (Name_Table.Image (Get_Identifier (Decl))); + Put (" = "); + Disp_Signal (Instance.Objects (Info.Slot), Get_Type (Decl)); + end Disp_Instance_Signal; + + procedure Disp_Instance_Signals_Of_Chain (Instance: Block_Instance_Acc; + Chain : Iir) + is + El : Iir; + begin + El := Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_Declaration => + Disp_Instance_Signal (Instance, El); + when others => + null; + end case; + El := Get_Chain (El); + end loop; + end Disp_Instance_Signals_Of_Chain; + + procedure Disp_Instance_Signals (Instance: Block_Instance_Acc) + is + Blk : constant Iir := Instance.Label; + Child: Block_Instance_Acc; + begin + case Get_Kind (Blk) is + when Iir_Kind_Architecture_Body => + declare + Ent : constant Iir := Get_Entity (Blk); + begin + Disp_Instance_Name (Instance); + Put_Line (" [architecture]:"); + + Disp_Instance_Signals_Of_Chain + (Instance, Get_Port_Chain (Ent)); + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Ent)); + end; + when Iir_Kind_Block_Statement => + Disp_Instance_Name (Instance); + Put_Line (" [block]:"); + + -- FIXME: ports. + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Blk)); + when Iir_Kind_Generate_Statement => + Disp_Instance_Name (Instance); + Put_Line (" [generate]:"); + + Disp_Instance_Signals_Of_Chain + (Instance, Get_Declaration_Chain (Blk)); + when Iir_Kind_Component_Instantiation_Statement => + null; + when Iir_Kinds_Process_Statement => + null; + when Iir_Kind_Iterator_Declaration => + null; + when others => + Error_Kind ("disp_instance_signals", Instance.Label); + end case; + + Child := Instance.Children; + while Child /= null loop + Disp_Instance_Signals (Child); + Child := Child.Brother; + end loop; + end Disp_Instance_Signals; + + -- Disp all signals name and values. + procedure Disp_Signals_Value is + begin + if Disp_Time_Before_Values then + Grt.Disp.Disp_Now; + end if; + Disp_Instance_Signals (Top_Instance); + end Disp_Signals_Value; + + procedure Disp_Objects_Value is + begin + null; +-- -- Disp the results. +-- for I in 0 .. Variables.Last loop +-- Put (Get_String (Variables.Table (I).Name.all)); +-- Put (" = "); +-- Put (Get_Str_Value +-- (Get_Literal (variables.Table (I).Value.all), +-- Get_Type (variables.Table (I).Value.all))); +-- if I = variables.Last then +-- Put_Line (";"); +-- else +-- Put (", "); +-- end if; +-- end loop; + end Disp_Objects_Value; + + procedure Disp_Label (Process : Iir) + is + Label : Name_Id; + begin + Label := Get_Label (Process); + if Label = Null_Identifier then + Put ("<unlabeled>"); + else + Put (Name_Table.Image (Label)); + end if; + end Disp_Label; + + procedure Disp_Declaration_Objects + (Instance : Block_Instance_Acc; Decl_Chain : Iir) + is + El : Iir; + begin + El := Decl_Chain; + while El /= Null_Iir loop + case Get_Kind (El) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_File_Interface_Declaration + | Iir_Kind_Object_Alias_Declaration => + Put (Disp_Node (El)); + Put (" = "); + Disp_Value_Tab (Instance.Objects (Get_Info (El).Slot), 3); + when Iir_Kind_Signal_Interface_Declaration => + declare + Sig : Iir_Value_Literal_Acc; + begin + Sig := Instance.Objects (Get_Info (El).Slot); + Put (Disp_Node (El)); + Put (" = "); + Disp_Signal (Sig, Get_Type (El)); + New_Line; + end; + when Iir_Kind_Type_Declaration + | Iir_Kind_Anonymous_Type_Declaration + | Iir_Kind_Subtype_Declaration => + -- FIXME: disp ranges + null; + when Iir_Kind_Implicit_Function_Declaration => + null; + when others => + Error_Kind ("disp_declaration_objects", El); + end case; + El := Get_Chain (El); + end loop; + end Disp_Declaration_Objects; + + procedure Disp_Objects (Instance : Block_Instance_Acc) + is + Decl : constant Iir := Instance.Label; + begin + Disp_Instance_Name (Instance); + New_Line; + case Get_Kind (Decl) is + when Iir_Kind_Procedure_Declaration + | Iir_Kind_Function_Declaration => + Disp_Declaration_Objects + (Instance, Get_Interface_Declaration_Chain (Decl)); + Disp_Declaration_Objects + (Instance, + Get_Declaration_Chain (Get_Subprogram_Body (Decl))); + when Iir_Kind_Architecture_Body => + declare + Entity : constant Iir_Entity_Declaration := Get_Entity (Decl); + begin + Disp_Declaration_Objects + (Instance, Get_Generic_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Port_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Declaration_Chain (Entity)); + Disp_Declaration_Objects + (Instance, Get_Declaration_Chain (Decl)); + -- FIXME: processes. + end; + when Iir_Kind_Component_Instantiation_Statement => + null; + when others => + Error_Kind ("disp_objects", Decl); + end case; + end Disp_Objects; + pragma Unreferenced (Disp_Objects); + + procedure Disp_Process_Stats + is + Proc : Iir; + Stmt : Iir; + Nbr_User_Sensitized_Processes : Natural := 0; + Nbr_User_If_Sensitized_Processes : Natural := 0; + Nbr_Conc_Sensitized_Processes : Natural := 0; + Nbr_User_Non_Sensitized_Processes : Natural := 0; + Nbr_Conc_Non_Sensitized_Processes : Natural := 0; + begin + for I in Processes_Table.First .. Processes_Table.Last loop + Proc := Processes_Table.Table (I).Label; + case Get_Kind (Proc) is + when Iir_Kind_Sensitized_Process_Statement => + if Get_Process_Origin (Proc) = Null_Iir then + Stmt := Get_Sequential_Statement_Chain (Proc); + if Stmt /= Null_Iir + and then Get_Kind (Stmt) = Iir_Kind_If_Statement + and then Get_Chain (Stmt) = Null_Iir + then + Nbr_User_If_Sensitized_Processes := + Nbr_User_If_Sensitized_Processes + 1; + else + Nbr_User_Sensitized_Processes := + Nbr_User_Sensitized_Processes + 1; + end if; + else + Nbr_Conc_Sensitized_Processes := + Nbr_Conc_Sensitized_Processes + 1; + end if; + when Iir_Kind_Process_Statement => + if Get_Process_Origin (Proc) = Null_Iir then + Nbr_User_Non_Sensitized_Processes := + Nbr_User_Non_Sensitized_Processes + 1; + else + Nbr_Conc_Non_Sensitized_Processes := + Nbr_Conc_Non_Sensitized_Processes + 1; + end if; + when others => + raise Internal_Error; + end case; + end loop; + + Put (Natural'Image (Nbr_User_If_Sensitized_Processes)); + Put_Line (" user sensitized processes with only a if stmt"); + Put (Natural'Image (Nbr_User_Sensitized_Processes)); + Put_Line (" user sensitized processes (others)"); + Put (Natural'Image (Nbr_User_Non_Sensitized_Processes)); + Put_Line (" user non sensitized processes"); + Put (Natural'Image (Nbr_Conc_Sensitized_Processes)); + Put_Line (" sensitized concurrent statements"); + Put (Natural'Image (Nbr_Conc_Non_Sensitized_Processes)); + Put_Line (" non sensitized concurrent statements"); + Put (Process_Index_Type'Image (Processes_Table.Last)); + Put_Line (" processes (total)"); + end Disp_Process_Stats; + + procedure Disp_Signals_Stats + is + type Counters_Type is array (Signal_Type_Kind) of Natural; + Counters : Counters_Type := (others => 0); + Nbr_Signal_Elements : Natural := 0; + begin + for I in Signals_Table.First .. Signals_Table.Last loop + declare + Ent : Signal_Entry renames Signals_Table.Table (I); + begin + if Ent.Kind = User_Signal then + Nbr_Signal_Elements := Nbr_Signal_Elements + + Get_Nbr_Of_Scalars (Signals_Table.Table (I).Sig); + end if; + Counters (Ent.Kind) := Counters (Ent.Kind) + 1; + end; + end loop; + Put (Integer'Image (Counters (User_Signal))); + Put_Line (" declared user signals or ports"); + Put (Integer'Image (Nbr_Signal_Elements)); + Put_Line (" user signals sub-elements"); + Put (Integer'Image (Counters (Implicit_Quiet))); + Put_Line (" 'quiet implicit signals"); + Put (Integer'Image (Counters (Implicit_Stable))); + Put_Line (" 'stable implicit signals"); + Put (Integer'Image (Counters (Implicit_Delayed))); + Put_Line (" 'delayed implicit signals"); + Put (Integer'Image (Counters (Implicit_Transaction))); + Put_Line (" 'transaction implicit signals"); + Put (Integer'Image (Counters (Guard_Signal))); + Put_Line (" guard signals"); + end Disp_Signals_Stats; + + procedure Disp_Design_Stats is + begin + Disp_Process_Stats; + + New_Line; + + Disp_Signals_Stats; + + New_Line; + + Put (Integer'Image (Connect_Table.Last)); + Put_Line (" connections"); + end Disp_Design_Stats; + + procedure Disp_Design_Non_Sensitized + is + Instance : Block_Instance_Acc; + Proc : Iir; + begin + for I in Processes_Table.First .. Processes_Table.Last loop + Instance := Processes_Table.Table (I); + Proc := Processes_Table.Table (I).Label; + if Get_Kind (Proc) = Iir_Kind_Process_Statement then + Disp_Instance_Name (Instance); + New_Line; + Put_Line (" at " & Disp_Location (Proc)); + end if; + end loop; + end Disp_Design_Non_Sensitized; + + procedure Disp_Design_Connections is + begin + for I in Connect_Table.First .. Connect_Table.Last loop + declare + Conn : Connect_Entry renames Connect_Table.Table (I); + begin + Disp_Iir_Location (Conn.Assoc); + New_Line; + end; + end loop; + end Disp_Design_Connections; + + 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 + is + Stmt : Iir := Chain; + begin + while Stmt /= Null_Iir loop + case Get_Kind (Stmt) is + when Iir_Kind_Process_Statement => + if Walk_Decl_Chain (Get_Declaration_Chain (Stmt)) + = Walk_Abort + then + return Walk_Abort; + end if; + when others => + 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 others => + 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; + + 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_A_Frame (Instance: Block_Instance_Acc) is + begin + Put (Disp_Node (Instance.Label)); + if Instance.Stmt /= Null_Iir then + Put (" at "); + Put (Get_Location_Str (Get_Location (Instance.Stmt))); + end if; + New_Line; + end Disp_A_Frame; + + 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_Procedure is access procedure (Line : 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; + + -- Check there is a current process. + procedure Check_Current_Process is + begin + if Current_Process = null then + Put_Line ("no current process"); + raise Command_Error; + end if; + end Check_Current_Process; + + -- 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; + + procedure Help_Proc (Line : String); + + procedure Disp_Process_Loc (Proc : Process_State_Type) is + begin + Disp_Instance_Name (Proc.Top_Instance); + Put (" (" & Get_Location_Str (Get_Location (Proc.Proc)) & ")"); + New_Line; + end Disp_Process_Loc; + + -- Disp the list of processes (and its state) + procedure Ps_Proc (Line : String) is + pragma Unreferenced (Line); + Process : Iir; + begin + if Processes_State = null then + Put_Line ("no processes"); + return; + end if; + + for I in Processes_State'Range loop + Put (Process_Index_Type'Image (I) & ": "); + Process := Processes_State (I).Proc; + if Process /= Null_Iir then + Disp_Process_Loc (Processes_State (I)); + Disp_A_Frame (Processes_State (I).Instance); + else + Put_Line ("not yet elaborated"); + end if; + end loop; + end Ps_Proc; + + procedure Up_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Check_Current_Process; + if Dbg_Cur_Frame.Parent = null then + Put_Line ("top of frames reached"); + else + Set_Cur_Frame (Dbg_Cur_Frame.Parent); + end if; + end Up_Proc; + + procedure Down_Proc (Line : String) + is + pragma Unreferenced (Line); + Inst : Block_Instance_Acc; + begin + Check_Current_Process; + if Dbg_Cur_Frame = Dbg_Top_Frame then + Put_Line ("bottom of frames reached"); + else + Inst := Dbg_Top_Frame; + while Inst.Parent /= Dbg_Cur_Frame loop + Inst := Inst.Parent; + end loop; + Set_Cur_Frame (Inst); + end if; + end Down_Proc; + + procedure Set_Breakpoint (Stmt : Iir) is + begin + Put_Line + ("set breakpoint at: " & Get_Location_Str (Get_Location (Stmt))); + Breakpoints.Append (Breakpoint_Entry'(Stmt => Stmt)); + Flag_Need_Debug := True; + end Set_Breakpoint; + + procedure Next_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + Exec_State := Exec_Next; + Exec_Instance := Dbg_Top_Frame; + Flag_Need_Debug := True; + Command_Status := Status_Quit; + 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; + end Step_Proc; + + Break_Id : Name_Id; + + 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 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); + Break_Id := Name_Table.Get_Identifier (Line (P .. Line'Last)); + Status := Walk_Declarations (Cb_Set_Break'Access); + pragma Assert (Status = Walk_Continue); + end Break_Proc; + + procedure Where_Proc (Line : String) is + pragma Unreferenced (Line); + Frame : Block_Instance_Acc; + begin + Check_Current_Process; + Frame := Dbg_Top_Frame; + while Frame /= null loop + if Frame = Dbg_Cur_Frame then + Put ("* "); + else + Put (" "); + end if; + Disp_A_Frame (Frame); + Frame := Frame.Parent; + end loop; + end Where_Proc; + + procedure Info_Tree_Proc (Line : String) + is + pragma Unreferenced (Line); + begin + if Top_Instance = null then + Put_Line ("design not yet fully elaborated"); + else + Disp_Instances_Tree; + end if; + end Info_Tree_Proc; + + procedure Info_Params_Proc (Line : String) + is + pragma Unreferenced (Line); + Decl : Iir; + Params : Iir; + begin + Check_Current_Process; + Decl := Dbg_Cur_Frame.Label; + if Decl = Null_Iir + or else Get_Kind (Decl) not in Iir_Kinds_Subprogram_Declaration + then + Put_Line ("current frame is not a subprogram"); + return; + end if; + Params := Get_Interface_Declaration_Chain (Decl); + Disp_Declaration_Objects (Dbg_Cur_Frame, Params); + end Info_Params_Proc; + + procedure Info_Proc_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Check_Current_Process; + Disp_Process_Loc (Current_Process.all); + end Info_Proc_Proc; + + function Cb_Disp_Subprograms (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Put_Line (Name_Table.Image (Get_Identifier (El))); + when others => + null; + end case; + return Walk_Continue; + end Cb_Disp_Subprograms; + + procedure Info_Subprograms_Proc (Line : String) is + pragma Unreferenced (Line); + Status : Walk_Status; + begin + Status := Walk_Declarations (Cb_Disp_Subprograms'Access); + pragma Assert (Status = Walk_Continue); + end Info_Subprograms_Proc; + + function Cb_Disp_Units (El : Iir) return Walk_Status is + begin + case Get_Kind (El) is + when Iir_Kind_Package_Declaration => + Put ("package "); + Put_Line (Name_Table.Image (Get_Identifier (El))); + when Iir_Kind_Entity_Declaration => + Put ("entity "); + Put_Line (Name_Table.Image (Get_Identifier (El))); + when Iir_Kind_Architecture_Body => + Put ("architecture "); + Put (Name_Table.Image (Get_Identifier (El))); + Put (" of "); + Put_Line (Name_Table.Image (Get_Identifier (Get_Entity (El)))); + when Iir_Kind_Configuration_Declaration => + Put ("configuration "); + Put_Line (Name_Table.Image (Get_Identifier (El))); + when Iir_Kind_Package_Body => + null; + when others => + Error_Kind ("cb_disp_units", El); + end case; + return Walk_Continue; + end Cb_Disp_Units; + + procedure Info_Units_Proc (Line : String) is + pragma Unreferenced (Line); + Status : Walk_Status; + begin + Status := Walk_Units (Cb_Disp_Units'Access); + pragma Assert (Status = Walk_Continue); + end Info_Units_Proc; + + function Cb_Disp_File (El : Iir) return Walk_Status is + begin + Put_Line (Name_Table.Image (Get_Design_File_Filename (El))); + return Walk_Continue; + end Cb_Disp_File; + + procedure Info_Stats_Proc (Line : String) is + P : Natural := Line'First; + E : Natural; + begin + P := Skip_Blanks (Line (P .. Line'Last)); + if P > Line'Last then + -- No parameters. + Disp_Design_Stats; + return; + end if; + + E := Get_Word (Line (P .. Line'Last)); + if Line (P .. E) = "global" then + Disp_Design_Stats; + elsif Line (P .. E) = "non-sensitized" then + Disp_Design_Non_Sensitized; + null; + elsif Line (P .. E) = "connections" then + Disp_Design_Connections; + -- TODO: nbr of conversions + else + Put_Line ("options are: global, non-sensitized, connections"); + -- TODO: signals: nbr of scalars, nbr of non-user... + end if; + end Info_Stats_Proc; + + procedure Info_Files_Proc (Line : String) is + pragma Unreferenced (Line); + Status : Walk_Status; + begin + Status := Walk_Files (Cb_Disp_File'Access); + pragma Assert (Status = Walk_Continue); + end Info_Files_Proc; + + procedure Info_Libraries_Proc (Line : String) is + pragma Unreferenced (Line); + Lib : Iir_Library_Declaration := Libraries.Get_Libraries_Chain; + begin + while Lib /= Null_Iir loop + Put_Line (Name_Table.Image (Get_Identifier (Lib))); + Lib := Get_Chain (Lib); + end loop; + end Info_Libraries_Proc; + + procedure Disp_Declared_Signals_Chain + (Chain : Iir; Instance : Block_Instance_Acc) + is + pragma Unreferenced (Instance); + Decl : Iir; + begin + Decl := Chain; + while Decl /= Null_Iir loop + case Get_Kind (Decl) is + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Signal_Declaration => + Put_Line (" " & Name_Table.Image (Get_Identifier (Decl))); + when others => + null; + end case; + Decl := Get_Chain (Decl); + end loop; + end Disp_Declared_Signals_Chain; + + procedure Disp_Declared_Signals (Decl : Iir; Instance : Block_Instance_Acc) + is + begin + case Get_Kind (Decl) is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + Disp_Declared_Signals (Get_Parent (Decl), Instance); + when Iir_Kind_Architecture_Body => + Disp_Declared_Signals (Get_Entity (Decl), Instance); + when Iir_Kind_Entity_Declaration => + null; + when others => + Error_Kind ("disp_declared_signals", Decl); + end case; + + case Get_Kind (Decl) is + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement => + -- No signal declaration in a process (FIXME: implicit signals) + null; + when Iir_Kind_Architecture_Body => + Put_Line ("Signals of architecture " + & Name_Table.Image (Get_Identifier (Decl)) & ':'); + Disp_Declared_Signals_Chain + (Get_Declaration_Chain (Decl), Instance); + when Iir_Kind_Entity_Declaration => + Put_Line ("Ports of entity " + & Name_Table.Image (Get_Identifier (Decl)) & ':'); + Disp_Declared_Signals_Chain + (Get_Port_Chain (Decl), Instance); + when others => + Error_Kind ("disp_declared_signals (2)", Decl); + end case; + end Disp_Declared_Signals; + + procedure Info_Signals_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Check_Current_Process; + Disp_Declared_Signals + (Current_Process.Proc, Current_Process.Top_Instance); + end Info_Signals_Proc; + + type Handle_Scope_Type is access procedure (N : Iir); + + procedure Foreach_Scopes (N : Iir; Handler : Handle_Scope_Type) is + begin + case Get_Kind (N) is + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Foreach_Scopes (Get_Parent (N), Handler); + Handler.all (N); + when Iir_Kind_Architecture_Body => + Foreach_Scopes (Get_Entity (N), Handler); + Handler.all (N); + + when Iir_Kind_Entity_Declaration => + -- Top of scopes. + null; + + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Foreach_Scopes (Get_Parent (N), Handler); + Handler.all (N); + when Iir_Kind_Package_Body => + Handler.all (N); + + when Iir_Kind_Variable_Assignment_Statement + | Iir_Kind_Signal_Assignment_Statement + | Iir_Kind_Null_Statement + | Iir_Kind_Assertion_Statement + | Iir_Kind_Report_Statement + | Iir_Kind_Wait_Statement + | Iir_Kind_Return_Statement + | Iir_Kind_Next_Statement + | Iir_Kind_Exit_Statement + | Iir_Kind_Procedure_Call_Statement + | Iir_Kind_If_Statement + | Iir_Kind_While_Loop_Statement + | Iir_Kind_Case_Statement => + Foreach_Scopes (Get_Parent (N), Handler); + + when Iir_Kind_For_Loop_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Foreach_Scopes (Get_Parent (N), Handler); + Handler.all (N); + + when others => + Error_Kind ("foreach_scopes", N); + end case; + end Foreach_Scopes; + + procedure Add_Decls_For (N : Iir) + is + use Sem_Scopes; + begin + case Get_Kind (N) is + when Iir_Kind_Entity_Declaration => + declare + Unit : constant Iir := Get_Design_Unit (N); + begin + Add_Context_Clauses (Unit); + -- Add_Name (Unit, Get_Identifier (N), False); + Add_Entity_Declarations (N); + end; + when Iir_Kind_Architecture_Body => + Open_Declarative_Region; + Add_Context_Clauses (Get_Design_Unit (N)); + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + when Iir_Kind_Package_Body => + declare + Package_Decl : constant Iir := Get_Package (N); + Package_Unit : constant Iir := Get_Design_Unit (Package_Decl); + begin + Add_Name (Package_Unit); + Add_Context_Clauses (Package_Unit); + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (Package_Decl), False); + Add_Declarations (Get_Declaration_Chain (N), False); + end; + when Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body => + declare + Spec : constant Iir := Get_Subprogram_Specification (N); + begin + Open_Declarative_Region; + Add_Declarations + (Get_Interface_Declaration_Chain (Spec), False); + Add_Declarations + (Get_Declaration_Chain (N), False); + end; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement => + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (N), False); + when Iir_Kind_For_Loop_Statement => + Open_Declarative_Region; + Add_Name (Get_Parameter_Specification (N)); + when Iir_Kind_Block_Statement => + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + when Iir_Kind_Generate_Statement => + Open_Declarative_Region; + Add_Declarations (Get_Declaration_Chain (N), False); + Add_Declarations_Of_Concurrent_Statement (N); + when others => + Error_Kind ("enter_scope(2)", N); + end case; + end Add_Decls_For; + + procedure Enter_Scope (Node : Iir) + is + use Sem_Scopes; + begin + Push_Interpretations; + Open_Declarative_Region; + + -- Add STD + Add_Name (Libraries.Std_Library, Std_Names.Name_Std, False); + Use_All_Names (Std_Package.Standard_Package); + + Foreach_Scopes (Node, Add_Decls_For'Access); + end Enter_Scope; + + procedure Del_Decls_For (N : Iir) + is + use Sem_Scopes; + begin + case Get_Kind (N) is + when Iir_Kind_Entity_Declaration => + null; + when Iir_Kind_Architecture_Body => + Close_Declarative_Region; + when Iir_Kind_Process_Statement + | Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Package_Body + | Iir_Kind_Procedure_Body + | Iir_Kind_Function_Body + | Iir_Kind_For_Loop_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Generate_Statement => + Close_Declarative_Region; + when others => + Error_Kind ("Decl_Decls_For", N); + end case; + end Del_Decls_For; + + procedure Leave_Scope (Node : Iir) + is + use Sem_Scopes; + begin + Foreach_Scopes (Node, Del_Decls_For'Access); + + Close_Declarative_Region; + Pop_Interpretations; + end Leave_Scope; + + Buffer_Index : Natural := 1; + + procedure Print_Proc (Line : String) + is + use Tokens; + Index_Str : String := Natural'Image (Buffer_Index); + File : Source_File_Entry; + Expr : Iir; + Res : Iir_Value_Literal_Acc; + P : Natural; + Opt_Value : Boolean := False; + Marker : Mark_Type; + begin + -- Decode options: /v + P := Line'First; + loop + P := Skip_Blanks (Line (P .. Line'Last)); + if P + 2 < Line'Last and then Line (P .. P + 1) = "/v" then + Opt_Value := True; + P := P + 2; + else + exit; + end if; + end loop; + + Buffer_Index := Buffer_Index + 1; + Index_Str (Index_Str'First) := '*'; + File := Files_Map.Create_Source_File_From_String + (Name_Table.Get_Identifier ("*debug" & Index_Str & '*'), + Line (P .. Line'Last)); + Scanner.Set_File (File); + Scanner.Scan; + Expr := Parse.Parse_Expression; + if Scanner.Current_Token /= Tok_Eof then + Put_Line ("garbage at end of expression ignored"); + end if; + Scanner.Close_File; + if Nbr_Errors /= 0 then + Put_Line ("error while parsing expression, evaluation aborted"); + Nbr_Errors := 0; + return; + end if; + + Enter_Scope (Dbg_Cur_Frame.Stmt); + Expr := Sem_Expr.Sem_Expression_Universal (Expr); + Leave_Scope (Dbg_Cur_Frame.Stmt); + + if Expr = Null_Iir + or else Nbr_Errors /= 0 + then + Put_Line ("error while analyzing expression, evaluation aborted"); + Nbr_Errors := 0; + return; + end if; + + Disp_Vhdl.Disp_Expression (Expr); + New_Line; + + Annotate_Expand_Table; + + Mark (Marker, Expr_Pool); + + Res := Execute_Expression (Dbg_Cur_Frame, Expr); + if Opt_Value then + Disp_Value (Res); + else + Disp_Iir_Value (Res, Get_Type (Expr)); + end if; + New_Line; + + -- Free value + Release (Marker, Expr_Pool); + end Print_Proc; + + procedure Quit_Proc (Line : String) is + pragma Unreferenced (Line); + begin + Command_Status := Status_Quit; + raise Debugger_Quit; + end Quit_Proc; + + procedure Cont_Proc (Line : String) is + pragma Unreferenced (Line); + 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 Cont_Proc; + + Menu_Info_Stats : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("stats"), + Next => null, + Proc => Info_Stats_Proc'Access); + + Menu_Info_Tree : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("tree"), + Next => Menu_Info_Stats'Access, + Proc => Info_Tree_Proc'Access); + + Menu_Info_Params : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("param*eters"), + Next => Menu_Info_Tree'Access, + Proc => Info_Params_Proc'Access); + + Menu_Info_Subprograms : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("subp*rograms"), + Next => Menu_Info_Params'Access, + Proc => Info_Subprograms_Proc'Access); + + Menu_Info_Units : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("units"), + Next => Menu_Info_Subprograms'Access, + Proc => Info_Units_Proc'Access); + + Menu_Info_Files : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("files"), + Next => Menu_Info_Units'Access, + Proc => Info_Files_Proc'Access); + + Menu_Info_Libraries : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("lib*raries"), + Next => Menu_Info_Files'Access, + Proc => Info_Libraries_Proc'Access); + + Menu_Info_Signals : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("sig*nals"), + Next => Menu_Info_Libraries'Access, + Proc => Info_Signals_Proc'Access); + + Menu_Info_Proc : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("proc*esses"), + Next => Menu_Info_Signals'Access, + Proc => Info_Proc_Proc'Access); + + Menu_Down : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("down"), + Next => null, + Proc => Down_Proc'Access); + + Menu_Up : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("up"), + Next => Menu_Down'Access, + Proc => Up_Proc'Access); + + Menu_Next : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("n*ext"), + Next => Menu_Up'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_Where : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("where"), + Next => Menu_Break'Access, + Proc => Where_Proc'Access); + + Menu_Ps : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("ps"), + Next => Menu_Where'Access, + Proc => Ps_Proc'Access); + + Menu_Info : aliased Menu_Entry := + (Kind => Menu_Submenu, + Name => new String'("i*nfo"), + Next => Menu_Ps'Access, + First | Last => Menu_Info_Proc'Access); + + Menu_Print : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("pr*int"), + Next => Menu_Info'Access, + Proc => Print_Proc'Access); + + Menu_Cont : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("c*ont"), + Next => Menu_Print'Access, + Proc => Cont_Proc'Access); + + Menu_Quit : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("q*uit"), + Next => Menu_Cont'Access, + Proc => Quit_Proc'Access); + + Menu_Help1 : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("help"), + Next => Menu_Quit'Access, + Proc => Help_Proc'Access); + + Menu_Help2 : aliased Menu_Entry := + (Kind => Menu_Command, + Name => new String'("?"), + Next => 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 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 := Line_To_Position (File, Line + 1); + Put (String (Buf (Line_Pos .. Next_Line_Pos - 1))); + end Disp_Source_Line; + + function Breakpoint_Hit return Natural + is + Stmt : constant Iir := Current_Process.Instance.Stmt; + begin + for I in Breakpoints.First .. Breakpoints.Last loop + if Stmt = Breakpoints.Table (I).Stmt then + return I; + end if; + end loop; + return 0; + end Breakpoint_Hit; + + Prompt_Debug : constant String := "debug> " & ASCII.NUL; + Prompt_Crash : constant String := "crash> " & ASCII.NUL; + Prompt_Init : constant String := "init> " & ASCII.NUL; + Prompt_Elab : constant String := "elab> " & ASCII.NUL; + + procedure Debug (Reason: Debug_Reason) is + use Grt.Readline; + Raw_Line : Char_Ptr; + Prompt : System.Address; + begin + -- Unless interractive, do not use the debugger. + if Reason /= Reason_Internal_Debug then + if not Flag_Interractive then + return; + end if; + end if; + + Prompt := Prompt_Debug'Address; + + case Reason is + when Reason_Start => + Set_Top_Frame (null); + Prompt := Prompt_Init'Address; + when Reason_Elab => + Set_Top_Frame (null); + Prompt := Prompt_Elab'Address; + when Reason_Internal_Debug => + if Current_Process = null then + Set_Top_Frame (null); + else + Set_Top_Frame (Current_Process.Instance); + end if; + when Reason_Break => + case Exec_State is + when Exec_Run => + if Breakpoint_Hit /= 0 then + Put_Line ("breakpoint hit"); + else + return; + end if; + when Exec_Single_Step => + -- Default state. + Exec_State := Exec_Run; + when Exec_Next => + if Current_Process.Instance /= Exec_Instance then + return; + end if; + -- Default state. + Exec_State := Exec_Run; + end case; + Set_Top_Frame (Current_Process.Instance); + declare + Stmt : constant Iir := Dbg_Cur_Frame.Stmt; + begin + Put ("stopped at: "); + Disp_Iir_Location (Stmt); + New_Line; + Disp_Source_Line (Get_Location (Stmt)); + end; + when Reason_Assert => + Set_Top_Frame (Current_Process.Instance); + Prompt := Prompt_Crash'Address; + Put_Line ("assertion failure, enterring in debugger"); + when Reason_Error => + Set_Top_Frame (Current_Process.Instance); + Prompt := Prompt_Crash'Address; + Put_Line ("error occurred, enterring in debugger"); + end case; + + Command_Status := Status_Default; + + loop + loop + Raw_Line := Readline (Prompt); + -- Skip empty lines + exit when Raw_Line /= null and then Raw_Line (1) /= ASCII.NUL; + 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_Error is + begin + Debug (Reason_Error); + end Debug_Error; +end Debugger; |