diff options
Diffstat (limited to 'src/ghdldrv/ghdlxml.adb')
-rw-r--r-- | src/ghdldrv/ghdlxml.adb | 526 |
1 files changed, 526 insertions, 0 deletions
diff --git a/src/ghdldrv/ghdlxml.adb b/src/ghdldrv/ghdlxml.adb new file mode 100644 index 000000000..329af4658 --- /dev/null +++ b/src/ghdldrv/ghdlxml.adb @@ -0,0 +1,526 @@ +-- GHDL driver - xml commands +-- Copyright (C) 2016 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 GCC; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Text_IO; use Ada.Text_IO; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with Types; use Types; +with Name_Table; use Name_Table; +with Nodes_Meta; use Nodes_Meta; +with Str_Table; +with Files_Map; +with Disp_Tree; use Disp_Tree; +with Ghdlprint; use Ghdlprint; +with Libraries; +with Errorout; use Errorout; +with Iirs; use Iirs; +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 ("</"); + Put (Name); + 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_Chain (Id : String; N : Iir) + is + El : Iir; + begin + if N = Null_Iir then + return; + end if; + + Put_Stag (Id); + Put_Stag_End; + + El := N; + while Is_Valid (El) loop + Disp_Iir ("el", El); + El := Get_Chain (El); + end loop; + + Put_Etag (Id); + end Disp_Iir_Chain; + + procedure Disp_Iir_List (Id : String; L : Iir_List; Ref : Boolean) + is + El : Iir; + begin + if L = Null_Iir_List then + return; + end if; + + Put_Stag (Id); + case L is + when Iir_List_All => + Put_Attribute ("list-id", "all"); + Put_Empty_Stag_End; + return; + when Iir_List_Others => + Put_Attribute ("list-id", "others"); + Put_Empty_Stag_End; + return; + when others => + Put_Attribute ("list-id", Strip (Iir_List'Image (L))); + Put_Stag_End; + end case; + + for I in Natural loop + El := Get_Nth_Element (L, I); + exit when El = Null_Iir; + if Ref then + Disp_Iir_Ref ("el", El); + else + Disp_Iir ("el", El); + end if; + end loop; + + Put_Etag (Id); + end Disp_Iir_List; + + 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_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_Index32 => + Put_Field (F, Iir_Index32'Image (Get_Iir_Index32 (N, F))); + when Type_Iir_Int64 => + Put_Field (F, Iir_Int64'Image (Get_Iir_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_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_Iir_Direction => + Put_Field (F, Image_Iir_Direction + (Get_Iir_Direction (N, F))); + when Type_Location_Type => + declare + Loc : constant Location_Type := Get_Location_Type (N, F); + begin + if Loc /= No_Location then + Put_Field (F, Image_Location_Type (Loc)); + end if; + end; + 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_Iir_Fp64 => + Put_Field (F, Iir_Fp64'Image (Get_Iir_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))); + 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 => + 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_Ref => + Disp_Iir_List_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 (Str_Table.String_String8 + (Get_String8_Id (N), Len))); + 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"; + end Decode_Command; + + function Get_Short_Help (Cmd : Command_File_To_Xml) return String + is + pragma Unreferenced (Cmd); + begin + return "--file-to-xml FILEs Dump AST in 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. + Setup_Libraries (True); + + -- Parse all files. + for I in Files'Range loop + Id := Get_Identifier (Files_Name (I).all); + File := Load_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 := Libraries.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 + ("<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>"); + Disp_Iir_Chain ("root", Libraries.Get_Libraries_Chain); + 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; |