From 19a9154fb3fadd0a33a6826e525091a9a75687e4 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Sat, 4 May 2019 22:12:13 +0200 Subject: vhdl: move disp_tree and disp_vhdl as vhdl child. --- src/vhdl/vhdl-disp_tree.adb | 604 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 604 insertions(+) create mode 100644 src/vhdl/vhdl-disp_tree.adb (limited to 'src/vhdl/vhdl-disp_tree.adb') 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 ""; + 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 (""); + 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; -- cgit v1.2.3