vhdl: move disp_tree and disp_vhdl as vhdl child.

1 files changed, 604 insertions, 0 deletions

diff --git a/src/vhdl/vhdl-disp_tree.adb b/src/vhdl/vhdl-disp_tree.adb
new file mode 100644
index 000000000..d214957aa
--- /dev/null
+++ b/src/vhdl/vhdl-disp_tree.adb
@@ -0,0 +1,604 @@
+--  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.Dump_Tree;
+with Nodes_Meta;
+
+--  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_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_Iir_Direction (Dir : Iir_Direction) return String is
+   begin
+      case Dir is
+         when Iir_To =>
+            return "to";
+         when Iir_Downto =>
+            return "downto";
+      end case;
+   end Image_Iir_Direction;
+
+   function Image_Token_Type (Tok : Vhdl.Tokens.Token_Type) return String
+     renames Vhdl.Tokens.Image;
+
+   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 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 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_Iir_Int64 =>
+                  Log_Line (Iir_Int64'Image (Get_Iir_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_Predefined_Functions =>
+                  Log_Line (Image_Iir_Predefined_Functions
+                              (Get_Iir_Predefined_Functions (N, F)));
+               when Type_Iir_Direction =>
+                  Log_Line (Image_Iir_Direction
+                              (Get_Iir_Direction (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_Iir_Fp64 =>
+                  Log_Line (Iir_Fp64'Image (Get_Iir_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_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;