-- GHDL driver - xml commands -- Copyright (C) 2016 Tristan Gingold -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation, either version 2 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see . with GNAT.OS_Lib; use GNAT.OS_Lib; with Simple_IO; use Simple_IO; with Types; use Types; with Flags; with Name_Table; use Name_Table; with Vhdl.Nodes_Meta; use Vhdl.Nodes_Meta; with Files_Map; with Vhdl.Disp_Tree; use Vhdl.Disp_Tree; with Ghdlprint; use Ghdlprint; with Libraries; with Errorout; use Errorout; with Vhdl.Nodes; use Vhdl.Nodes; with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; with Ghdlmain; use Ghdlmain; with Ghdllocal; use Ghdllocal; package body Ghdlxml is procedure Disp_Iir (Id : String; N : Iir); -- Try to keep line length below that number. Max_Line_Len : constant Natural := 80; -- Number of space by indentation level. Indent_Size : constant Natural := 2; -- Current indentation level. Indent : Natural; -- Current column. Col : Natural; -- Low-level display routines. Consider line length, and handle -- indentation. Only use these routines to display content. -- Display indentation. procedure Put_Indent is Blanks : constant String (1 .. Indent_Size * Indent) := (others => ' '); begin pragma Assert (Col = 0); Put (Blanks); Col := Indent_Size * Indent; end Put_Indent; procedure Put_Stag (Name : String) is begin Put_Indent; Put ('<'); Put (Name); Col := Col + 1 + Name'Length; end Put_Stag; procedure Put_Stag_End is begin Put ('>'); New_Line; Col := 0; Indent := Indent + 1; end Put_Stag_End; procedure Put_Empty_Stag_End is begin Put ("/>"); New_Line; Col := 0; end Put_Empty_Stag_End; procedure Put_Etag (Name : String) is begin Indent := Indent - 1; Put_Indent; Put (""); New_Line; Col := 0; end Put_Etag; procedure Put_Attribute (Attr : String; Value : String) is -- Number of characters to be displayed. Len : constant Natural := 4 + Attr'Length + Value'Length; begin if Col + Len >= Max_Line_Len and then Indent * Indent_Size + Len < Max_Line_Len then New_Line; Col := 0; Put_Indent; end if; Put (' '); Put (Attr); Put ("="""); Put (Value); Put ('"'); Col := Col + Len; end Put_Attribute; -- Espace special characters for XML. -- -- According to: http://www.w3.org/TR/REC-xml/#NT-AttValue -- -- [10] AttValue ::= '"' ([^<&"] | Reference)* '"' -- | "'" ([^<&'] | Reference)* "'" -- [67] Reference ::= EntityRef | CharRef -- [66] CharRef ::= '&#' [0-9]+ ';' -- | '&#x' [0-9a-fA-F]+ ';' function To_XML (Str : String) return String is To_Hex : constant array (0 .. 15) of Character := "0123456789abcdef"; -- The escape sequence uses 6 characters. Res : String (1 .. 6 * Str'Length); Idx : Positive; C : Character; C_Pos : Natural; begin Idx := Res'First; for I in Str'Range loop C := Str (I); case C is when '<' | '&' | '"' | Character'Val (128) .. Character'Val (255) => Res (Idx + 0) := '&'; Res (Idx + 1) := '#'; Res (Idx + 2) := 'x'; C_Pos := Character'Pos (C); Res (Idx + 3) := To_Hex (C_Pos / 16); Res (Idx + 4) := To_Hex (C_Pos mod 16); Res (Idx + 5) := ';'; Idx := Idx + 6; when others => Res (Idx) := C; Idx := Idx + 1; end case; end loop; return Res (1 .. Idx - 1); end To_XML; function XML_Image (Id : Name_Id) return String is begin return To_XML (Image (Id)); end XML_Image; -- Strip leading blank if any. function Strip (S : String) return String is F : constant Natural := S'First; begin if F > S'Last then return ""; elsif S (F) = ' ' then return S (F + 1 .. S'Last); else return S; end if; end Strip; procedure Put_Field (F : Fields_Enum; Value : String) is begin Put_Attribute (Get_Field_Image (F), Value); end Put_Field; procedure Disp_Iir_Ref (Id : String; N : Iir) is begin if N = Null_Iir then return; end if; Put_Stag (Id); Put_Attribute ("ref", Strip (Iir'Image (N))); Put_Empty_Stag_End; end Disp_Iir_Ref; procedure Disp_Iir_List_Ref (Id : String; L : Iir_List) is begin if L = Null_Iir_List then return; end if; Put_Stag (Id); Put_Attribute ("list-ref", Strip (Iir_List'Image (L))); Put_Empty_Stag_End; end Disp_Iir_List_Ref; procedure Disp_Iir_Flist_Ref (Id : String; L : Iir_Flist) is begin if L = Null_Iir_Flist then return; end if; Put_Stag (Id); Put_Attribute ("flist-ref", Strip (Iir_Flist'Image (L))); Put_Empty_Stag_End; end Disp_Iir_Flist_Ref; procedure Disp_Iir_Chain_Elements (Chain : Iir) is El : Iir; begin El := Chain; while Is_Valid (El) loop Disp_Iir ("el", El); El := Get_Chain (El); end loop; end Disp_Iir_Chain_Elements; procedure Disp_Iir_Chain (Id : String; N : Iir) is begin if N = Null_Iir then return; end if; Put_Stag (Id); Put_Stag_End; Disp_Iir_Chain_Elements (N); Put_Etag (Id); end Disp_Iir_Chain; procedure Disp_Iir_List (Id : String; L : Iir_List; Ref : Boolean) is El : Iir; It : List_Iterator; begin case L is when Null_Iir_List => null; when Iir_List_All => Put_Stag (Id); Put_Attribute ("list-id", "all"); Put_Empty_Stag_End; when others => Put_Stag (Id); Put_Attribute ("list-id", Strip (Iir_List'Image (L))); Put_Stag_End; It := List_Iterate (L); while Is_Valid (It) loop El := Get_Element (It); if Ref then Disp_Iir_Ref ("el", El); else Disp_Iir ("el", El); end if; Next (It); end loop; Put_Etag (Id); end case; end Disp_Iir_List; procedure Disp_Iir_Flist (Id : String; L : Iir_Flist; Ref : Boolean) is El : Iir; begin if L = Null_Iir_Flist then return; end if; Put_Stag (Id); case L is when Iir_Flist_All => Put_Attribute ("flist-id", "all"); Put_Empty_Stag_End; return; when Iir_Flist_Others => Put_Attribute ("flist-id", "others"); Put_Empty_Stag_End; return; when others => Put_Attribute ("flist-id", Strip (Iir_Flist'Image (L))); Put_Stag_End; end case; for I in Flist_First .. Flist_Last (L) loop El := Get_Nth_Element (L, I); if Ref then Disp_Iir_Ref ("el", El); else Disp_Iir ("el", El); end if; end loop; Put_Etag (Id); end Disp_Iir_Flist; procedure Disp_Iir (Id : String; N : Iir) is begin if N = Null_Iir then return; end if; Put_Stag (Id); Put_Attribute ("id", Strip (Iir'Image (N))); Put_Attribute ("kind", Get_Iir_Image (Get_Kind (N))); declare Loc : constant Location_Type := Get_Location (N); File : Name_Id; Line : Natural; Col : Natural; begin if Loc /= No_Location then Files_Map.Location_To_Position (Loc, File, Line, Col); Put_Attribute ("file", Image (File)); Put_Attribute ("line", Strip (Natural'Image (Line))); Put_Attribute ("col", Strip (Natural'Image (Col))); end if; end; declare Fields : constant Fields_Array := Get_Fields (Get_Kind (N)); F : Fields_Enum; begin -- First attributes for I in Fields'Range loop F := Fields (I); case Get_Field_Type (F) is when Type_Iir => null; when Type_Iir_List => null; when Type_Iir_Flist => null; when Type_String8_Id => null; when Type_PSL_NFA => Put_Field (F, "PSL-NFA"); -- Disp_PSL_NFA (Get_PSL_NFA (N, F), Sub_Indent); when Type_PSL_Node => Put_Field (F, "PSL-NODE"); when Type_Source_Ptr => null; when Type_Date_Type => Put_Field (F, Strip (Date_Type'Image (Get_Date_Type (N, F)))); when Type_Number_Base_Type => Put_Field (F, Number_Base_Type'Image (Get_Number_Base_Type (N, F))); when Type_Iir_Constraint => Put_Field (F, Image_Iir_Constraint (Get_Iir_Constraint (N, F))); when Type_Iir_Mode => Put_Field (F, Image_Iir_Mode (Get_Iir_Mode (N, F))); when Type_Iir_Force_Mode => Put_Field (F, Image_Iir_Force_Mode (Get_Iir_Force_Mode (N, F))); when Type_Iir_Index32 => Put_Field (F, Iir_Index32'Image (Get_Iir_Index32 (N, F))); when Type_Int64 => Put_Field (F, Int64'Image (Get_Int64 (N, F))); when Type_Boolean => Put_Field (F, Image_Boolean (Get_Boolean (N, F))); when Type_Iir_Staticness => Put_Field (F, Image_Iir_Staticness (Get_Iir_Staticness (N, F))); when Type_Scalar_Size => Put_Field (F, Image_Scalar_Size (Get_Scalar_Size (N, F))); when Type_Date_State_Type => Put_Field (F, Image_Date_State_Type (Get_Date_State_Type (N, F))); when Type_Iir_All_Sensitized => Put_Field (F, Image_Iir_All_Sensitized (Get_Iir_All_Sensitized (N, F))); when Type_Iir_Signal_Kind => Put_Field (F, Image_Iir_Signal_Kind (Get_Iir_Signal_Kind (N, F))); when Type_Tri_State_Type => Put_Field (F, Image_Tri_State_Type (Get_Tri_State_Type (N, F))); when Type_Iir_Pure_State => Put_Field (F, Image_Iir_Pure_State (Get_Iir_Pure_State (N, F))); when Type_Iir_Delay_Mechanism => Put_Field (F, Image_Iir_Delay_Mechanism (Get_Iir_Delay_Mechanism (N, F))); when Type_Iir_Predefined_Functions => Put_Field (F, Image_Iir_Predefined_Functions (Get_Iir_Predefined_Functions (N, F))); when Type_Direction_Type => Put_Field (F, Image_Direction_Type (Get_Direction_Type (N, F))); when Type_Iir_Int32 => Put_Field (F, Strip (Iir_Int32'Image (Get_Iir_Int32 (N, F)))); when Type_Int32 => Put_Field (F, Strip (Int32'Image (Get_Int32 (N, F)))); when Type_Fp64 => Put_Field (F, Fp64'Image (Get_Fp64 (N, F))); when Type_Time_Stamp_Id => Put_Field (F, Image_Time_Stamp_Id (Get_Time_Stamp_Id (N, F))); when Type_File_Checksum_Id => Put_Field (F, Image_File_Checksum_Id (Get_File_Checksum_Id (N, F))); when Type_Token_Type => Put_Field (F, Image_Token_Type (Get_Token_Type (N, F))); when Type_Name_Id => Put_Field (F, XML_Image (Get_Name_Id (N, F))); when Type_Source_File_Entry => null; end case; end loop; Put_Stag_End; for I in Fields'Range loop F := Fields (I); case Get_Field_Type (F) is when Type_Iir => declare V : constant Iir := Get_Iir (N, F); Img : constant String := Get_Field_Image (F); begin case Get_Field_Attribute (F) is when Attr_None => Disp_Iir (Img, V); when Attr_Ref | Attr_Forward_Ref | Attr_Maybe_Forward_Ref => Disp_Iir_Ref (Img, V); when Attr_Maybe_Ref => if Get_Is_Ref (N) then Disp_Iir_Ref (Img, V); else Disp_Iir (Img, V); end if; when Attr_Chain => Disp_Iir_Chain (Img, V); when Attr_Chain_Next => null; when Attr_Of_Ref | Attr_Of_Maybe_Ref => raise Internal_Error; end case; end; when Type_Iir_List => declare L : constant Iir_List := Get_Iir_List (N, F); Img : constant String := Get_Field_Image (F); begin case Get_Field_Attribute (F) is when Attr_None => Disp_Iir_List (Img, L, False); when Attr_Of_Ref => Disp_Iir_List (Img, L, True); when Attr_Of_Maybe_Ref => Disp_Iir_List (Img, L, Get_Is_Ref (N)); when Attr_Ref => Disp_Iir_List_Ref (Img, L); when others => raise Internal_Error; end case; end; when Type_Iir_Flist => declare L : constant Iir_Flist := Get_Iir_Flist (N, F); Img : constant String := Get_Field_Image (F); begin case Get_Field_Attribute (F) is when Attr_None => Disp_Iir_Flist (Img, L, False); when Attr_Of_Ref => Disp_Iir_Flist (Img, L, True); when Attr_Of_Maybe_Ref => Disp_Iir_Flist (Img, L, Get_Is_Ref (N)); when Attr_Ref => Disp_Iir_Flist_Ref (Img, L); when others => raise Internal_Error; end case; end; when Type_String8_Id => -- Special handling for strings declare Len : constant Int32 := Get_String_Length (N); begin Put_Stag (Get_Field_Image (F)); Put_Attribute ("length", Strip (Int32'Image (Len))); Put_Attribute ("content", To_XML (Image_String8 (N))); Put_Empty_Stag_End; end; when others => null; end case; end loop; end; Put_Etag (Id); end Disp_Iir; -- Command --file-to-xml type Command_File_To_Xml is new Command_Lib with null record; function Decode_Command (Cmd : Command_File_To_Xml; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_File_To_Xml) return String; procedure Perform_Action (Cmd : in out Command_File_To_Xml; Files_Name : Argument_List); function Decode_Command (Cmd : Command_File_To_Xml; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "file-to-xml" or else Name = "--file-to-xml"; end Decode_Command; function Get_Short_Help (Cmd : Command_File_To_Xml) return String is pragma Unreferenced (Cmd); begin return "file-to-xml FILEs" & ASCII.LF & " Dump AST in XML" & ASCII.LF & " alias: --file-to-xml"; end Get_Short_Help; procedure Perform_Action (Cmd : in out Command_File_To_Xml; Files_Name : Argument_List) is pragma Unreferenced (Cmd); use Files_Map; Id : Name_Id; File : Source_File_Entry; type File_Data is record Fe : Source_File_Entry; Design_File : Iir; end record; type File_Data_Array is array (Files_Name'Range) of File_Data; Files : File_Data_Array; begin -- Load work library. if not Setup_Libraries (True) then return; end if; Flags.Flag_Elaborate_With_Outdated := True; -- Parse all files. for I in Files'Range loop Id := Get_Identifier (Files_Name (I).all); File := Read_Source_File (Libraries.Local_Directory, Id); if File = No_Source_File_Entry then Error ("cannot open " & Image (Id)); return; end if; Files (I).Fe := File; Files (I).Design_File := Load_File (File); if Files (I).Design_File = Null_Iir then return; end if; -- Put units in library. -- Note: design_units stay while design_file get empty. Libraries.Add_Design_File_Into_Library (Files (I).Design_File); end loop; -- Analyze all files. for I in Files'Range loop Analyze_Design_File_Units (Files (I).Design_File); end loop; Indent := 0; Col := 0; Put_Line (""); Put_Stag ("root"); Put_Attribute ("version", "0.13"); Put_Stag_End; Disp_Iir_Chain_Elements (Libraries.Get_Libraries_Chain); Put_Etag ("root"); exception when Compilation_Error => Error ("xml dump failed due to compilation error"); end Perform_Action; procedure Register_Commands is begin Register_Command (new Command_File_To_Xml); end Register_Commands; end Ghdlxml;