ghdlprint.adb

vhdl集成电路设计软件.需要用gcc-4.0.2版本编译.

--  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 Types; use Types;
with Flags;
with Name_Table; use Name_Table;
with Files_Map;
with Libraries;
with Errorout; use Errorout;
with Iirs; use Iirs;
with Tokens;
with Scan;
with Version;
with Xrefs;
with Ghdlmain; use Ghdlmain;
with Ghdllocal; use Ghdllocal;

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 ("&lt;");
         when '&' =>
            Put ("&amp;");
         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;

   procedure PP_Html_File (File : Source_File_Entry)
   is
      use Scan;
      use Tokens;
      use Files_Map;
      use Ada.Characters.Latin_1;

      Line : Natural;
      Buf : File_Buffer_Acc;
      Prev_Tok : Token_Type;

      --  True if tokens are between 'end' and ';'
      In_End : Boolean := False;

      --  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 ("cannot find xref", Loc);
               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
               when Html_2 =>
                  Put ("<font color=orange>");
                  Disp_Text;
                  Put ("</font>");
               when Html_Css =>
                  Put ("<var>");
                  Disp_Text;
                  Put ("</var>");
            end case;
         else
            Decl := Get_Xref_Node (Ref);
            Loc := Get_Location (Decl);
            Put ("<a");
            Disp_Href (Loc);
            Put (">");
            Disp_Text;
            Put ("</a>");
         end if;
      end Disp_Attribute;
   begin
      Scan.Flag_Comment := True;
      Scan.Flag_Newline := True;

      Set_File (File);
      Buf := Get_File_Source (File);

      Put_Line ("<pre>");
      Line := 1;
      Disp_Ln;
      Last_Tok := Source_Ptr_Org;
      Prev_Tok := Tok_Invalid;
      loop
         Scan.Scan;
         Bef_Tok := Get_Token_Position;
         Aft_Tok := Get_Position;
         case Current_Token is
            when Tok_Eof =>
               exit;
            when Tok_Newline =>
               New_Line;
               Line := Line + 1;
               Disp_Ln;
            when Tok_Comment =>
               Disp_Spaces;
               case Html_Format is
                  when Html_2 =>
                     Put ("<font color=green>");
                     Disp_Text;
                     Put ("</font>");
                  when Html_Css =>
                     Put ("<tt>");
                     Disp_Text;
                     Put ("</tt>");
               end case;
            when Tok_Access .. Tok_Elsif
              | Tok_Entity .. Tok_With
              | Tok_Mod .. Tok_Rem
              | Tok_And .. Tok_Not =>
               Disp_Reserved;
            when Tok_End =>
               Disp_Reserved;
               In_End := True;
            when Tok_Semi_Colon =>
               In_End := False;
               Disp_Spaces;
               Disp_Text;
            when Tok_Xnor .. Tok_Ror =>
               if Flags.Vhdl_Std > Vhdl_87 then
                  Disp_Reserved;
               else
                  Disp_Identifier;
               end if;
            when Tok_Protected =>
               if Flags.Vhdl_Std >= Vhdl_00 then
                  Disp_Reserved;
               else
                  Disp_Identifier;
               end if;