-- GHDL driver - print commands.
-- 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 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.Characters.Latin_1;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Tables;
with Types; use Types;
with Flags;
with Name_Table; use Name_Table;
with Files_Map;
with Libraries;
with Errorout; use Errorout;
with Iirs_Utils; use Iirs_Utils;
with Tokens;
with Scanner;
with Parse;
with Canon;
with Version;
with Xrefs;
with Ghdlmain; use Ghdlmain;
with Ghdllocal; use Ghdllocal;
with Disp_Vhdl;
package body Ghdlprint is
type Html_Format_Type is (Html_2, Html_Css);
Html_Format : Html_Format_Type := Html_2;
procedure Put_Html (C : Character) is
begin
case C is
when '>' =>
Put (">");
when '<' =>
Put ("<");
when '&' =>
Put ("&");
when others =>
Put (C);
end case;
end Put_Html;
procedure Put_Html (S : String) is
begin
for I in S'Range loop
Put_Html (S (I));
end loop;
end Put_Html;
package Nat_IO is new Ada.Text_IO.Integer_IO (Num => Natural);
procedure Put_Nat (N : Natural) is
begin
Nat_IO.Put (N, Width => 0);
end Put_Nat;
type Filexref_Info_Type is record
Output : String_Acc;
Referenced : Boolean;
end record;
type Filexref_Info_Arr is array (Source_File_Entry range <>)
of Filexref_Info_Type;
type Filexref_Info_Arr_Acc is access Filexref_Info_Arr;
Filexref_Info : Filexref_Info_Arr_Acc := null;
-- If True, at least one xref is missing.
Missing_Xref : Boolean := False;
procedure PP_Html_File (File : Source_File_Entry)
is
use Flags;
use Scanner;
use Tokens;
use Files_Map;
use Ada.Characters.Latin_1;
Line : Natural;
Buf : File_Buffer_Acc;
Prev_Tok : Token_Type;
-- Current logical column number. Used to expand TABs.
Col : Natural;
-- Position just after the last token.
Last_Tok : Source_Ptr;
-- Position just before the current token.
Bef_Tok : Source_Ptr;
-- Position just after the current token.
Aft_Tok : Source_Ptr;
procedure Disp_Ln
is
N : Natural;
Str : String (1 .. 5);
begin
case Html_Format is
when Html_2 =>
Put ("<font size=-1>");
when Html_Css =>
Put ("<i>");
end case;
N := Line;
for I in reverse Str'Range loop
if N = 0 then
Str (I) := ' ';
else
Str (I) := Character'Val (48 + N mod 10);
N := N / 10;
end if;
end loop;
Put (Str);
case Html_Format is
when Html_2 =>
Put ("</font>");
when Html_Css =>
Put ("</i>");
end case;
Put (" ");
Col := 0;
end Disp_Ln;
procedure Disp_Spaces
is
C : Character;
P : Source_Ptr;
N_Col : Natural;
begin
P := Last_Tok;
while P < Bef_Tok loop
C := Buf (P);
if C = HT then
-- Expand TABS.
N_Col := Col + 8;
N_Col := N_Col - N_Col mod 8;
while Col < N_Col loop
Put (' ');
Col := Col + 1;
end loop;
else
Put (' ');
Col := Col + 1;
end if;
P := P + 1;
end loop;
end Disp_Spaces;
procedure Disp_Text
is
P : Source_Ptr;
begin
P := Bef_Tok;
while P < Aft_Tok loop
Put_Html (Buf (P));
Col := Col + 1;
P := P + 1;
end loop;
end Disp_Text;
procedure Disp_Reserved is
begin
Disp_Spaces;
case Html_Format is
when Html_2 =>
Put ("<font color=red>");
Disp_Text;
Put ("</font>");
when Html_Css =>
Put ("<em>");
Disp_Text;
Put ("</em>");
end case;
end Disp_Reserved;
procedure Disp_Href (Loc : Location_Type)
is
L_File : Source_File_Entry;
L_Pos : Source_Ptr;
begin
Location_To_File_Pos (Loc, L_File, L_Pos);
Put (" href=""");
if L_File /= File then
-- External reference.
if Filexref_Info (L_File).Output /= null then
Put (Filexref_Info (L_File).Output.all);
Put ("#");
Put_Nat (Natural (L_Pos));
else
-- Reference to an unused file.
Put ("index.html#f");
Put_Nat (Natural (L_File));
Filexref_Info (L_File).Referenced := True;
end if;
else
-- Local reference.
Put ("#");
Put_Nat (Natural (L_Pos));
end if;
Put ("""");
end Disp_Href;
procedure Disp_Anchor (Loc : Location_Type)
is
L_File : Source_File_Entry;
L_Pos : Source_Ptr;
begin
Put (" name=""");
Location_To_File_Pos (Loc, L_File, L_Pos);
Put_Nat (Natural (L_Pos));
Put ("""");
end Disp_Anchor;
procedure Disp_Identifier
is
use Xrefs;
Ref : Xref;
Decl : Iir;
Bod : Iir;
Loc : Location_Type;
begin
Disp_Spaces;
if Flags.Flag_Xref then
Loc := File_Pos_To_Location (File, Bef_Tok);
Ref := Find (Loc);
if Ref = Bad_Xref then
Disp_Text;
Warning_Msg_Sem (Warnid_Missing_Xref, Loc, "cannot find xref");
Missing_Xref := True;
return;
end if;
else
Disp_Text;
return;
end if;
case Get_Xref_Kind (Ref) is
when Xref_Decl =>
Put ("<a");
Disp_Anchor (Loc);
Decl := Get_Xref_Node (Ref);
case Get_Kind (Decl) is
when Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration =>
Bod := Get_Subprogram_Body (Decl);
when Iir_Kind_Package_Declaration =>
Bod := Get_Package_Body (Decl);
when Iir_Kind_Type_Declaration =>
Decl := Get_Type (Decl);
case Get_Kind (Decl) is
when Iir_Kind_Protected_Type_Declaration =>
Bod := Get_Protected_Type_Body (Decl);
when Iir_Kind_Incomplete_Type_Definition =>
Bod := Get_Type_Declarator (Decl);
when others =>
Bod := Null_Iir;
end case;
when others =>
Bod := Null_Iir;
end case;
if Bod /= Null_Iir then
Disp_Href (Get_Location (Bod));
end if;
Put (">");
Disp_Text;
Put ("</a>");
when Xref_Ref
| Xref_End =>
Decl := Get_Xref_Node (Ref);
Loc := Get_Location (Decl);
if Loc /= Location_Nil then
Put ("<a");
Disp_Href (Loc);
Put (">");
Disp_Text;
Put ("</a>");
else
-- This may happen for overload list, in use clauses.
Disp_Text;
end if;
when Xref_Body =>
Put ("<a");
Disp_Anchor (Loc);
Disp_Href (Get_Location (Get_Xref_Node (Ref)));
Put (">");
Disp_Text;
Put ("</a>");
end case;
end Disp_Identifier;
procedure Disp_Attribute
is
use Xrefs;
Ref : Xref;
Decl : Iir;
Loc : Location_Type;
begin
Disp_Spaces;
if Flags.Flag_Xref then
Loc := File_Pos_To_Location (File, Bef_Tok);
Ref := Find (Loc);
else
Ref := Bad_Xref;
end if;
if Ref = Bad_Xref then
case Html_Format is