-- 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 <gnu.org/licenses>.
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Simple_IO; use Simple_IO;
with Types; use Types;
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 ("</");
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_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;
-- 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
("<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>");
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;