path: root/src/vhdl/vhdl-disp_tree.adb

--  Node displaying (for debugging).
--  Copyright (C) 2002, 2003, 2004, 2005 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.

--  Display trees in raw form.  Mainly used for debugging.

with Logging; use Logging;
with Name_Table;
with Str_Table;
with Files_Map;
with PSL.Types; use PSL.Types;
with PSL.Dump_Tree;
with Vhdl.Nodes_Meta;
with Vhdl.Utils; use Vhdl.Utils;

--  Do not add a use clause for iirs_utils, as it may crash for ill-formed
--  trees, which is annoying while debugging.

package body Vhdl.Disp_Tree is
   --  Max depth for Disp_Iir.  Can be modified from a debugger.
   pragma Warnings (Off);
   Max_Depth : Natural := 10;
   pragma Warnings (On);

   procedure Disp_Header (N : Iir);

   procedure Disp_Tree_List_Flat (Tree_List: Iir_List; Tab: Natural);
   pragma Unreferenced (Disp_Tree_List_Flat);

   procedure Put_Indent (Tab: Natural) is
      Blanks : constant String (1 .. 2 * Tab) := (others => ' ');
   begin
      Log (Blanks);
   end Put_Indent;

   procedure Disp_Int32 (Num : Int32)
   is
      Res : String (1 .. 10) := "         ]";
      N : Int32;
   begin
      N := Num;
      for I in reverse 2 .. 9 loop
         Res (I) := Character'Val (Character'Pos ('0') + (N mod 10));
         N := N / 10;
         if N = 0 then
            Res (I - 1) := '[';
            Log (Res (I - 1 .. Res'Last));
            return;
         end if;
      end loop;
      Log (Res);
   end Disp_Int32;

   procedure Disp_Iir_Number (Node: Iir) is
   begin
      Disp_Int32 (Int32 (Node));
   end Disp_Iir_Number;

   -- For iir.

   procedure Disp_Iir_List
     (Tree_List : Iir_List; Tab : Natural; Depth : Natural)
   is
      It : List_Iterator;
   begin
      case Tree_List is
         when Null_Iir_List =>
            Log_Line ("null-list");
         when Iir_List_All =>
            Log_Line ("list-all");
         when others =>
            Log_Line;
            It := List_Iterate (Tree_List);
            while Is_Valid (It) loop
               Put_Indent (Tab);
               Disp_Iir (Get_Element (It), Tab + 1, Depth);
               Next (It);
            end loop;
      end case;
   end Disp_Iir_List;

   procedure Disp_Iir_Flist
     (Tree_Flist : Iir_Flist; Tab : Natural; Depth : Natural)
   is
      El: Iir;
   begin
      if Tree_Flist = Null_Iir_Flist then
         Log_Line ("null-flist");
      elsif Tree_Flist = Iir_Flist_All then
         Log_Line ("flist-all");
      elsif Tree_Flist = Iir_Flist_Others then
         Log_Line ("flist-others");
      else
         Log_Line;
         for I in Flist_First .. Flist_Last (Tree_Flist) loop
            El := Get_Nth_Element (Tree_Flist, I);
            Put_Indent (Tab);
            Disp_Iir (El, Tab + 1, Depth);
         end loop;
      end if;
   end Disp_Iir_Flist;

   procedure Disp_Chain (Tree_Chain: Iir; Indent: Natural; Depth : Natural)
   is
      El: Iir;
   begin
      Log_Line;
      El := Tree_Chain;
      while El /= Null_Iir loop
         Put_Indent (Indent);
         Disp_Iir (El, Indent + 1, Depth);
         El := Get_Chain (El);
      end loop;
   end Disp_Chain;

   procedure Disp_Tree_Flat_Chain (Tree_Chain: Iir; Tab: Natural)
   is
      El: Iir;
   begin
      El := Tree_Chain;
      while El /= Null_Iir loop
         Disp_Iir (El, Tab, 0);
         El := Get_Chain (El);
      end loop;
   end Disp_Tree_Flat_Chain;
   pragma Unreferenced (Disp_Tree_Flat_Chain);

   procedure Disp_Tree_List_Flat (Tree_List : Iir_List; Tab : Natural)
   is
      It : List_Iterator;
   begin
      case Tree_List is
         when Null_Iir_List =>
            Put_Indent (Tab);
            Log_Line (" null-list");
         when Iir_List_All =>
            Put_Indent (Tab);
            Log_Line (" list-all");
         when others =>
            It := List_Iterate (Tree_List);
            while Is_Valid (It) loop
               Disp_Iir (Get_Element (It), Tab, 0);
               Next (It);
            end loop;
      end case;
   end Disp_Tree_List_Flat;

   function Image_Name_Id (Ident: Name_Id) return String
   is
      use Name_Table;
   begin
      if Ident = Null_Identifier then
         return "<anonymous>";
      elsif Is_Character (Ident) then
         return Image (Ident);
      else
         return '"' & Image (Ident) & '"';
      end if;
   end Image_Name_Id;

   function Image_Iir_Staticness (Static: Iir_Staticness) return String is
   begin
      case Static is
         when Unknown =>
            return "???";
         when None =>
            return "none";
         when Globally =>
            return "global";
         when Locally =>
            return "local";
      end case;
   end Image_Iir_Staticness;

   function Image_Boolean (Bool : Boolean) return String is
   begin
      if Bool then
         return "true";
      else
         return "false";
      end if;
   end Image_Boolean;

   function Image_Iir_Delay_Mechanism (Mech : Iir_Delay_Mechanism)
                                      return String is
   begin
      case Mech is
         when Iir_Inertial_Delay =>
            return "inertial";
         when Iir_Transport_Delay =>
            return "transport";
      end case;
   end Image_Iir_Delay_Mechanism;

   function Image_Iir_Force_Mode (Mode : Iir_Force_Mode) return String is
   begin
      case Mode is
         when Iir_Force_In =>
            return "in";
         when Iir_Force_Out =>
            return "out";
      end case;
   end Image_Iir_Force_Mode;

   function Image_Iir_Mode (Mode : Iir_Mode) return String is
   begin
      case Mode is
         when Iir_Unknown_Mode =>
            return "???";
         when Iir_Linkage_Mode =>
            return "linkage";
         when Iir_Buffer_Mode =>
            return "buffer";
         when Iir_Out_Mode =>
            return "out";
         when Iir_Inout_Mode =>
            return "inout";
         when Iir_In_Mode =>
            return "in";
      end case;
   end Image_Iir_Mode;

   function Image_Iir_Signal_Kind (Kind : Iir_Signal_Kind) return String is
   begin
      case Kind is
         when Iir_Register_Kind =>
            return "register";
         when Iir_Bus_Kind =>
            return "bus";
      end case;
   end Image_Iir_Signal_Kind;

   function Image_Iir_Pure_State (State : Iir_Pure_State) return String is
   begin
      case State is
         when Pure =>
            return "pure";
         when Impure =>
            return "impure";
         when Maybe_Impure =>
            return "maybe_impure";
         when Unknown =>
            return "unknown";
      end case;
   end Image_Iir_Pure_State;

   function Image_Iir_All_Sensitized (Sig : Iir_All_Sensitized)
                                     return String is
   begin
      case Sig is
         when Unknown =>
            return "???";
         when No_Signal =>
            return "no_signal";
         when Read_Signal =>
            return "read_signal";
         when Invalid_Signal =>
            return "invalid_signal";
      end case;
   end Image_Iir_All_Sensitized;

   function Image_Iir_Constraint (Const : Iir_Constraint) return String is
   begin
      case Const is
         when Unconstrained =>
            return "unconstrained";
         when Partially_Constrained =>
            return "partially constrained";
         when Fully_Constrained =>
            return "fully constrained";
      end case;
   end Image_Iir_Constraint;

   function Image_Date_State_Type (State : Date_State_Type) return String is
   begin
      case State is
         when Date_Extern =>
            return "extern";
         when Date_Disk =>
            return "disk";
         when Date_Parse =>
            return "parse";
         when Date_Analyze =>
            return "analyze";
      end case;
   end Image_Date_State_Type;

   function Image_Tri_State_Type (State : Tri_State_Type) return String is
   begin
      case State is
         when True =>
            return "true";
         when False =>
            return "false";
         when Unknown =>
            return "unknown";
      end case;
   end Image_Tri_State_Type;

   function Image_Time_Stamp_Id (Id : Time_Stamp_Id) return String
     renames Files_Map.Get_Time_Stamp_String;

   function Image_File_Checksum_Id (Id : File_Checksum_Id) return String
     renames Files_Map.Get_File_Checksum_String;

   function Image_Iir_Predefined_Functions (F : Iir_Predefined_Functions)
                                           return String is
   begin
      return Iir_Predefined_Functions'Image (F);
   end Image_Iir_Predefined_Functions;

   procedure Disp_PSL_NFA (N : PSL_NFA; Indent : Natural)
   is
      pragma Unreferenced (Indent);
   begin
      if N = 0 then
         Log_Line ("*null*");
      else
         Log_Line ("*??*");
      end if;
   end Disp_PSL_NFA;

   function Image_Location_Type (Loc : Location_Type) return String is
   begin
      return Files_Map.Image (Loc);
   end Image_Location_Type;

   function Image_Direction_Type (Dir : Direction_Type) return String is
   begin
      case Dir is
         when Dir_To =>
            return "to";
         when Dir_Downto =>
            return "downto";
      end case;
   end Image_Direction_Type;

   function Image_Token_Type (Tok : Vhdl.Tokens.Token_Type) return String
     renames Vhdl.Tokens.Image;

   function Image_Scalar_Size (Sz : Scalar_Size) return String is
   begin
      case Sz is
         when Scalar_8 =>
            return "8";
         when Scalar_16 =>
            return "16";
         when Scalar_32 =>
            return "32";
         when Scalar_64 =>
            return "64";
      end case;
   end Image_Scalar_Size;

   function Image_String8 (N : Iir) return String
   is
      use Str_Table;
      T : constant Iir := Get_Type (N);
      Str : constant String8_Id := Get_String8_Id (N);
      Len : constant Int32 := Get_String_Length (N);
   begin
      if Is_Null (T) then
         --  Not yet analyzed, the string is the ASCII image.
         return Str_Table.String_String8 (Str, Len);
      else
         declare
            El : constant Iir := Get_Base_Type (Get_Element_Subtype (T));
            Lits : constant Iir_Flist := Get_Enumeration_Literal_List (El);
            Res : String (1 .. Natural (Len));
            C : Natural;
         begin
            for I in 1 .. Len loop
               C := Natural (Element_String8 (Str, I));
               Res (Natural (I)) := Name_Table.Get_Character
                 (Get_Identifier (Get_Nth_Element (Lits, C)));
            end loop;
            return Res;
         end;
      end if;
   end Image_String8;

   procedure Header (Str : String; Indent : Natural) is
   begin
      Put_Indent (Indent);
      Log (Str);
      Log (": ");
   end Header;

   procedure Disp_Header (N : Iir)
   is
      use Vhdl.Nodes_Meta;
      K : Iir_Kind;
   begin
      if N = Null_Iir then
         Log_Line ("*null*");
         return;
      end if;

      K := Get_Kind (N);
      Log (Get_Iir_Image (K));
      if Has_Identifier (K) then
         Log (" ");
         Log (Image_Name_Id (Get_Identifier (N)));
      end if;

      Log (" ");
      Disp_Iir_Number (N);

      --  Be nice: print type name for a type definition.
      if K in Iir_Kinds_Type_And_Subtype_Definition
        or K = Iir_Kind_Wildcard_Type_Definition
      then
         declare
            Decl : constant Iir := Get_Type_Declarator (N);
         begin
            if Decl /= Null_Iir
              and then Get_Identifier (Decl) /= Null_Identifier
            then
               Log (" ");
               Log (Image_Name_Id (Get_Identifier (Decl)));
            end if;
         end;
      end if;

      Log_Line;
   end Disp_Header;

   procedure Disp_Iir (N : Iir; Indent : Natural; Depth : Natural)
   is
      Sub_Indent : constant Natural := Indent + 1;
      Ndepth : Natural;
   begin
      Disp_Header (N);

      if Depth = 0 or else N = Null_Iir then
         return;
      end if;

      Header ("location", Indent);
      declare
         L : Location_Type;
      begin
         L := Get_Location (N);
         loop
            Log (Image_Location_Type (L));
            L := Files_Map.Location_Instance_To_Location (L);
            exit when L = No_Location;
            Log (" instantiated at ");
         end loop;
         Log_Line;
      end;

      declare
         use Vhdl.Nodes_Meta;
         Fields : constant Fields_Array := Get_Fields (Get_Kind (N));
         F : Fields_Enum;
      begin
         for I in Fields'Range loop
            F := Fields (I);
            Header (Get_Field_Image (F), Indent);
            case Get_Field_Type (F) is
               when Type_Iir =>
                  case Get_Field_Attribute (F) is
                     when Attr_None =>
                        Disp_Iir (Get_Iir (N, F), Sub_Indent, Depth - 1);
                     when Attr_Ref
                       | Attr_Forward_Ref
                       | Attr_Maybe_Forward_Ref =>
                        Disp_Iir (Get_Iir (N, F), Sub_Indent, 0);
                     when Attr_Maybe_Ref =>
                        if Get_Is_Ref (N) then
                           Ndepth := 0;
                        else
                           Ndepth := Depth - 1;
                        end if;
                        Disp_Iir (Get_Iir (N, F), Sub_Indent, Ndepth);
                     when Attr_Chain =>
                        Disp_Chain (Get_Iir (N, F), Sub_Indent, Depth - 1);
                     when Attr_Chain_Next =>
                        Disp_Iir_Number (Get_Iir (N, F));
                        Log_Line;
                     when Attr_Of_Ref | Attr_Of_Maybe_Ref =>
                        raise Internal_Error;
                  end case;
               when Type_Iir_List =>
                  case Get_Field_Attribute (F) is
                     when Attr_None =>
                        Ndepth := Depth - 1;
                     when Attr_Of_Ref =>
                        Ndepth := 0;
                     when Attr_Ref =>
                        Ndepth := 0;
                     when Attr_Of_Maybe_Ref =>
                        if Get_Is_Ref (N) then
                           Ndepth := 0;
                        else
                           Ndepth := Depth - 1;
                        end if;
                     when others =>
                        raise Internal_Error;
                  end case;
                  Disp_Iir_List (Get_Iir_List (N, F), Sub_Indent, Ndepth);
               when Type_Iir_Flist =>
                  case Get_Field_Attribute (F) is
                     when Attr_None =>
                        Ndepth := Depth - 1;
                     when Attr_Of_Ref =>
                        Ndepth := 0;
                     when Attr_Ref =>
                        Ndepth := 0;
                     when Attr_Of_Maybe_Ref =>
                        if Get_Is_Ref (N) then
                           Ndepth := 0;
                        else
                           Ndepth := Depth - 1;
                        end if;
                     when others =>
                        raise Internal_Error;
                  end case;
                  Disp_Iir_Flist (Get_Iir_Flist (N, F), Sub_Indent, Ndepth);
               when Type_PSL_NFA =>
                  Disp_PSL_NFA (Get_PSL_NFA (N, F), Sub_Indent);
               when Type_String8_Id =>
                  Log_Line ("<string8>");
               when Type_PSL_Node =>
                  PSL.Dump_Tree.Disp_Tree
                    (Get_PSL_Node (N, F), Sub_Indent, Depth - 1);
               when Type_Source_Ptr =>
                  Log_Line (Source_Ptr'Image (Get_Source_Ptr (N, F)));
               when Type_Source_File_Entry =>
                  Log_Line (Source_File_Entry'Image
                              (Get_Source_File_Entry (N, F)));
               when Type_Date_Type =>
                  Log_Line (Date_Type'Image (Get_Date_Type (N, F)));
               when Type_Number_Base_Type =>
                  Log_Line (Number_Base_Type'Image
                              (Get_Number_Base_Type (N, F)));
               when Type_Iir_Constraint =>
                  Log_Line (Image_Iir_Constraint
                              (Get_Iir_Constraint (N, F)));
               when Type_Iir_Mode =>
                  Log_Line (Image_Iir_Mode (Get_Iir_Mode (N, F)));
               when Type_Iir_Index32 =>
                  Log_Line (Iir_Index32'Image (Get_Iir_Index32 (N, F)));
               when Type_Int64 =>
                  Log_Line (Int64'Image (Get_Int64 (N, F)));
               when Type_Boolean =>
                  Log_Line (Image_Boolean
                              (Get_Boolean (N, F)));
               when Type_Iir_Staticness =>
                  Log_Line (Image_Iir_Staticness
                              (Get_Iir_Staticness (N, F)));
               when Type_Date_State_Type =>
                  Log_Line (Image_Date_State_Type
                              (Get_Date_State_Type (N, F)));
               when Type_Iir_All_Sensitized =>
                  Log_Line (Image_Iir_All_Sensitized
                              (Get_Iir_All_Sensitized (N, F)));
               when Type_Iir_Signal_Kind =>
                  Log_Line (Image_Iir_Signal_Kind
                              (Get_Iir_Signal_Kind (N, F)));
               when Type_Tri_State_Type =>
                  Log_Line (Image_Tri_State_Type
                              (Get_Tri_State_Type (N, F)));
               when Type_Iir_Pure_State =>
                  Log_Line (Image_Iir_Pure_State
                              (Get_Iir_Pure_State (N, F)));
               when Type_Iir_Delay_Mechanism =>
                  Log_Line (Image_Iir_Delay_Mechanism
                              (Get_Iir_Delay_Mechanism (N, F)));
               when Type_Iir_Force_Mode =>
                  Log_Line (Image_Iir_Force_Mode (Get_Iir_Force_Mode (N, F)));
               when Type_Iir_Predefined_Functions =>
                  Log_Line (Image_Iir_Predefined_Functions
                              (Get_Iir_Predefined_Functions (N, F)));
               when Type_Direction_Type =>
                  Log_Line (Image_Direction_Type
                              (Get_Direction_Type (N, F)));
               when Type_Iir_Int32 =>
                  Log_Line (Iir_Int32'Image (Get_Iir_Int32 (N, F)));
               when Type_Int32 =>
                  Log_Line (Int32'Image (Get_Int32 (N, F)));
               when Type_Fp64 =>
                  Log_Line (Fp64'Image (Get_Fp64 (N, F)));
               when Type_Time_Stamp_Id =>
                  Log_Line (Image_Time_Stamp_Id
                              (Get_Time_Stamp_Id (N, F)));
               when Type_File_Checksum_Id =>
                  Log_Line (Image_File_Checksum_Id
                              (Get_File_Checksum_Id (N, F)));
               when Type_Token_Type =>
                  Log_Line (Image_Token_Type (Get_Token_Type (N, F)));
               when Type_Scalar_Size =>
                  Log_Line (Image_Scalar_Size (Get_Scalar_Size (N, F)));
               when Type_Name_Id =>
                  Log (Image_Name_Id (Get_Name_Id (N, F)));
                  Log (" ");
                  Disp_Int32 (Int32 (Get_Name_Id (N, F)));
                  Log_Line;
            end case;
         end loop;
      end;
   end Disp_Iir;

   procedure Disp_Tree_For_Psl
     (N : Int32; Indent : Natural; Depth : Natural) is
   begin
      Disp_Iir (Iir (N), Indent, Depth);
   end Disp_Tree_For_Psl;

   procedure Disp_Tree (Tree : Iir;
                        Flat : Boolean := false) is
   begin
      if Flat then
         Disp_Iir (Tree, 1, 0);
      else
         Disp_Iir (Tree, 1, Max_Depth);
      end if;
   end Disp_Tree;
end Vhdl.Disp_Tree;