-- GHDL driver - print commands. -- Copyright (C) 2002, 2003, 2004, 2005 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 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 Options; use Options; with Errorout; use Errorout; with Version; with Vhdl.Errors; use Vhdl.Errors; with Vhdl.Utils; use Vhdl.Utils; with Vhdl.Tokens; with Vhdl.Scanner; with Vhdl.Parse; with Vhdl.Canon; with Vhdl.Xrefs; with Vhdl.Sem_Lib; use Vhdl.Sem_Lib; with Vhdl.Prints; with Vhdl.Formatters; use Vhdl.Formatters; with Vhdl.Elocations; 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 ("<"); 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 Vhdl.Scanner; use Vhdl.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 (""); when Html_Css => Put (""); 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 (""); when Html_Css => Put (""); 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 + Tab_Stop; N_Col := N_Col - N_Col mod Tab_Stop; 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 (""); Disp_Text; Put (""); when Html_Css => Put (""); Disp_Text; Put (""); 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 Vhdl.Xrefs; Ref : Xref; Decl : Iir; Bod : Iir; Loc : Location_Type; begin if Flags.Flag_Xref then Loc := File_Pos_To_Location (File, Bef_Tok); Ref := Find (Loc); if Ref = Bad_Xref then Disp_Spaces; Disp_Text; Warning_Msg_Sem (Warnid_Missing_Xref, Loc, "cannot find xref"); Missing_Xref := True; return; end if; else Disp_Spaces; Disp_Text; return; end if; case Get_Xref_Kind (Ref) is when Xref_Keyword => Disp_Reserved; when Xref_Decl => Disp_Spaces; Put (" 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 (""); when Xref_Ref | Xref_End => Disp_Spaces; Decl := Get_Xref_Node (Ref); Loc := Get_Location (Decl); if Loc /= Location_Nil then Put (""); Disp_Text; Put (""); else -- This may happen for overload list, in use clauses. Disp_Text; end if; when Xref_Body => Disp_Spaces; Put (""); Disp_Text; Put (""); end case; end Disp_Identifier; procedure Disp_Attribute is use Vhdl.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 (""); Disp_Text; Put (""); when Html_Css => Put (""); Disp_Text; Put (""); end case; else Decl := Get_Xref_Node (Ref); Loc := Get_Location (Decl); Put (""); Disp_Text; Put (""); end if; end Disp_Attribute; begin Vhdl.Scanner.Flag_Comment := True; Vhdl.Scanner.Flag_Newline := True; Set_File (File); Buf := Get_File_Source (File); Put_Line ("
");
      Line := 1;
      Disp_Ln;
      Last_Tok := Source_Ptr_Org;
      Prev_Tok := Tok_Invalid;
      loop
         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_Line_Comment
              | Tok_Block_Comment_Start =>
               Disp_Spaces;
               case Html_Format is
                  when Html_2 =>
                     Put ("");
                  when Html_Css =>
                     Put ("");
               end case;
               Disp_Text;
               if Current_Token = Tok_Block_Comment_Start then
                  loop
                     Scan_Block_Comment;
                     Bef_Tok := Get_Token_Position;
                     Aft_Tok := Get_Position;
                     case Current_Token is
                        when Tok_Newline =>
                           New_Line;
                           Line := Line + 1;
                           Disp_Ln;
                        when Tok_Eof =>
                           exit;
                        when Tok_Block_Comment_Text =>
                           Disp_Text;
                        when Tok_Block_Comment_End =>
                           Disp_Text;
                           exit;
                        when others =>
                           raise Internal_Error;
                     end case;
                  end loop;
               end if;
               case Html_Format is
                  when Html_2 =>
                     Put ("");
                  when Html_Css =>
                     Put ("");
               end case;
            when Tok_Mod .. Tok_Vunit =>
               Disp_Reserved;
            when Tok_Semi_Colon =>
               Disp_Spaces;
               Disp_Text;
            when Tok_Across .. Tok_Tolerance =>
               Disp_Reserved;
            when Tok_Psl_Clock
               | Tok_Psl_Endpoint
               | Tok_Psl_Boolean
               | Tok_Psl_Const
               | Tok_Inf
               | Tok_Within
               | Tok_Abort
               | Tok_Async_Abort
               | Tok_Sync_Abort
               | Tok_Before
               | Tok_Before_Em
               | Tok_Before_Un
               | Tok_Before_Em_Un
               | Tok_Until_Em
               | Tok_Until_Un
               | Tok_Until_Em_Un
               | Tok_Always
               | Tok_Never
               | Tok_Eventually_Em
               | Tok_Next_Em
               | Tok_Next_A
               | Tok_Next_A_Em
               | Tok_Next_E
               | Tok_Next_E_Em
               | Tok_Next_Event
               | Tok_Next_Event_Em
               | Tok_Next_Event_A
               | Tok_Next_Event_A_Em
               | Tok_Next_Event_E_Em
               | Tok_Next_Event_E
               | Tok_Prev
               | Tok_Stable
               | Tok_Rose
               | Tok_Fell
               | Tok_Onehot
               | Tok_Onehot0 =>
               Disp_Spaces;
               Disp_Text;
            when Tok_String
               | Tok_Bit_String
               | Tok_Character =>
               Disp_Spaces;
               case Html_Format is
                  when Html_2 =>
                     Put ("");
                     Disp_Text;
                     Put ("");
                  when Html_Css =>
                     Put ("");
                     Disp_Text;
                     Put ("");
               end case;
            when Tok_Identifier =>
               if Prev_Tok = Tok_Tick then
                  Disp_Attribute;
               else
                  Disp_Identifier;
               end if;
            when Tok_Left_Paren .. Tok_Colon
              | Tok_Comma .. Tok_Dot
              | Tok_Equal_Equal
              | Tok_Integer
              | Tok_Integer_Letter
              | Tok_Real
              | Tok_Equal .. Tok_Slash =>
               Disp_Spaces;
               Disp_Text;
            when Tok_Invalid
              | Tok_Block_Comment_Text
              | Tok_Block_Comment_End =>
               raise Internal_Error;
         end case;
         Last_Tok := Aft_Tok;
         Prev_Tok := Current_Token;
      end loop;
      Close_File;
      New_Line;
      Put_Line ("
"); Put_Line ("
"); end PP_Html_File; procedure Put_Html_Header is begin Put (""); Put_Line (" "); case Html_Format is when Html_2 => null; when Html_Css => Put_Line (" "); end case; --Put_Line (""); --Put_Line(""); --Put_Line (""); --Put_Line (""); end Put_Html_Header; procedure Put_Css is begin Put_Line ("/* EM is used for reserved words */"); Put_Line ("EM { color : red; font-style: normal }"); New_Line; Put_Line ("/* TT is used for comments */"); Put_Line ("TT { color : green; font-style: normal }"); New_Line; Put_Line ("/* KBD is used for literals and strings */"); Put_Line ("KBD { color : blue; font-style: normal }"); New_Line; Put_Line ("/* I is used for line numbers */"); Put_Line ("I { color : gray; font-size: 50% }"); New_Line; Put_Line ("/* VAR is used for attributes name */"); Put_Line ("VAR { color : orange; font-style: normal }"); New_Line; Put_Line ("/* A is used for identifiers. */"); Put_Line ("A { color: blue; font-style: normal;"); Put_Line (" text-decoration: none }"); end Put_Css; procedure Put_Html_Foot is begin Put_Line ("

"); Put ("This page was generated using "); Put ("GHDL "); Put (Version.Ghdl_Ver); Put (' '); Put (Version.Ghdl_Release); Put (", a program written by"); Put (" Tristan Gingold"); New_Line; Put_Line ("

"); Put_Line (""); Put_Line (""); end Put_Html_Foot; function Create_Output_Filename (Name : String; Num : Natural) return String_Acc is -- Position of the extension. 0 if none. Ext_Pos : Natural; Num_Str : String := Natural'Image (Num); begin -- Search for the extension. Ext_Pos := 0; for I in reverse Name'Range loop exit when Name (I) = Directory_Separator; if Name (I) = '.' then Ext_Pos := I - 1; exit; end if; end loop; if Ext_Pos = 0 then Ext_Pos := Name'Last; end if; Num_Str (1) := '.'; return new String'(Name (Name'First .. Ext_Pos) & Num_Str & ".html"); end Create_Output_Filename; -- Command --chop. type Command_Chop is new Command_Lib with null record; function Decode_Command (Cmd : Command_Chop; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Chop) return String; procedure Perform_Action (Cmd : in out Command_Chop; Args : Argument_List); function Decode_Command (Cmd : Command_Chop; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "chop" or else Name = "--chop"; end Decode_Command; function Get_Short_Help (Cmd : Command_Chop) return String is pragma Unreferenced (Cmd); begin return "chop [OPTS] FILEs" & ASCII.LF & " Chop FILEs" & ASCII.LF & " alias: --chop"; end Get_Short_Help; procedure Perform_Action (Cmd : in out Command_Chop; Args : Argument_List) is pragma Unreferenced (Cmd); use Ada.Characters.Latin_1; Files : Iir_Array (Args'Range); function Build_File_Name_Length (Lib : Iir) return Natural is Id : constant Name_Id := Get_Identifier (Lib); Len : Natural; Id1 : Name_Id; begin Len := Get_Name_Length (Id); case Get_Kind (Lib) is when Iir_Kind_Configuration_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration | Iir_Kind_Package_Instantiation_Declaration => null; when Iir_Kind_Package_Body => Len := Len + 1 + 4; -- add -body when Iir_Kind_Architecture_Body => Id1 := Get_Entity_Identifier_Of_Architecture (Lib); Len := Len + 1 + Get_Name_Length (Id1); when others => Error_Kind ("build_file_name", Lib); end case; Len := Len + 1 + 4; -- add .vhdl return Len; end Build_File_Name_Length; procedure Build_File_Name (Lib : Iir; Res : out String) is Id : constant Name_Id := Get_Identifier (Lib); P : Natural; procedure Append (Str : String) is begin Res (P + 1 .. P + Str'Length) := Str; P := P + Str'Length; end Append; begin P := Res'First - 1; case Get_Kind (Lib) is when Iir_Kind_Configuration_Declaration | Iir_Kind_Entity_Declaration | Iir_Kind_Package_Declaration | Iir_Kind_Package_Instantiation_Declaration => Append (Image (Id)); when Iir_Kind_Package_Body => Append (Image (Id)); Append ("-body"); when Iir_Kind_Architecture_Body => Append (Image (Get_Entity_Identifier_Of_Architecture (Lib))); Append ("-"); Append (Image (Id)); when others => raise Internal_Error; end case; Append (".vhdl"); end Build_File_Name; -- Scan source file BUF+START until end of line. -- Return line kind to KIND and position of next line to NEXT. type Line_Type is (Line_Blank, Line_Comment, Line_Text); procedure Find_Eol (Buf : File_Buffer_Acc; Start : Source_Ptr; Next : out Source_Ptr; Kind : out Line_Type) is P : Source_Ptr; begin P := Start; Kind := Line_Blank; -- Skip blanks. while Buf (P) = ' ' or Buf (P) = HT loop P := P + 1; end loop; -- Skip comment if any. if Buf (P) = '-' and Buf (P + 1) = '-' then Kind := Line_Comment; P := P + 2; elsif Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT then Kind := Line_Text; end if; -- Skip until end of line. while Buf (P) /= CR and Buf (P) /= LF and Buf (P) /= EOT loop P := P + 1; end loop; if Buf (P) = CR then P := P + 1; if Buf (P) = LF then P := P + 1; end if; elsif Buf (P) = LF then P := P + 1; if Buf (P) = CR then P := P + 1; end if; end if; Next := P; end Find_Eol; Id : Name_Id; Design_File : Iir_Design_File; Unit : Iir; Lib : Iir; Len : Natural; begin Flags.Bootstrap := True; Flags.Flag_Elocations := True; -- Load word library. if not Libraries.Load_Std_Library then raise Option_Error; end if; Libraries.Load_Work_Library; -- First loop: parse source file, check destination file does not -- exist. for I in Args'Range loop Id := Get_Identifier (Args (I).all); Design_File := Load_File_Name (Id); if Design_File = Null_Iir then raise Compile_Error; end if; Files (I) := Design_File; Unit := Get_First_Design_Unit (Design_File); while Unit /= Null_Iir loop Lib := Get_Library_Unit (Unit); Len := Build_File_Name_Length (Lib); declare Filename : String (1 .. Len + 1); begin Build_File_Name (Lib, Filename); Filename (Len + 1) := Ghdllocal.Nul; if Is_Regular_File (Filename) then Error ("file '" & Filename (1 .. Len) & "' already exists"); raise Compile_Error; end if; Put (Filename (1 .. Len)); Put (" (for "); Disp_Library_Unit (Lib); Put (")"); New_Line; end; Unit := Get_Chain (Unit); end loop; end loop; -- Second loop: do the real work. for I in Args'Range loop Design_File := Files (I); Unit := Get_First_Design_Unit (Design_File); declare use Files_Map; File_Entry : Source_File_Entry; Buffer : File_Buffer_Acc; Start : Source_Ptr; Lend : Source_Ptr; First : Source_Ptr; Next : Source_Ptr; Kind : Line_Type; begin -- A design_file must have at least one design unit. if Unit = Null_Iir then raise Compile_Error; end if; Location_To_File_Pos (Get_Location (Unit), File_Entry, Start); Buffer := Get_File_Source (File_Entry); First := Source_Ptr_Org; if Get_Chain (Unit) /= Null_Iir then -- If there is only one unit, then the whole file is written. -- First last blank line. Next := Source_Ptr_Org; loop Start := Next; Find_Eol (Buffer, Start, Next, Kind); exit when Kind = Line_Text; if Kind = Line_Blank then First := Next; end if; end loop; -- FIXME: write header. end if; while Unit /= Null_Iir loop Lib := Get_Library_Unit (Unit); Location_To_File_Pos (Vhdl.Elocations.Get_End_Location (Lib), File_Entry, Lend); if Lend < First then raise Internal_Error; end if; -- Find the ';'. while Buffer (Lend) /= ';' loop Lend := Lend + 1; end loop; Lend := Lend + 1; -- Find end of line. Find_Eol (Buffer, Lend, Next, Kind); if Kind = Line_Text then -- There is another unit on the same line. Next := Lend; -- Skip blanks. while Buffer (Next) = ' ' or Buffer (Next) = HT loop Next := Next + 1; end loop; else -- Find first blank line. loop Start := Next; Find_Eol (Buffer, Start, Next, Kind); exit when Kind /= Line_Comment; end loop; if Kind = Line_Text then -- There is not blank lines. -- All the comments are supposed to belong to the next -- unit. Find_Eol (Buffer, Lend, Next, Kind); Lend := Next; else Lend := Start; end if; end if; if Get_Chain (Unit) = Null_Iir then -- Last unit. -- Put the end of the file in it. Lend := Get_File_Length (File_Entry); end if; -- FIXME: file with only one unit. -- FIXME: set extension. Len := Build_File_Name_Length (Lib); declare Filename : String (1 .. Len + 1); Fd : File_Descriptor; Wlen : Integer; begin Build_File_Name (Lib, Filename); Filename (Len + 1) := Character'Val (0); Fd := Create_File (Filename, Binary); if Fd = Invalid_FD then Error ("cannot create file '" & Filename (1 .. Len) & "'"); raise Compile_Error; end if; Wlen := Integer (Lend - First); if Write (Fd, Buffer (First)'Address, Wlen) /= Wlen then Error ("cannot write to '" & Filename (1 .. Len) & "'"); raise Compile_Error; end if; Close (Fd); end; First := Next; Unit := Get_Chain (Unit); end loop; end; end loop; end Perform_Action; -- Command --lines. type Command_Lines is new Command_Lib with null record; function Decode_Command (Cmd : Command_Lines; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Lines) return String; procedure Perform_Action (Cmd : in out Command_Lines; Args : Argument_List); function Decode_Command (Cmd : Command_Lines; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "lines" or else Name = "--lines"; end Decode_Command; function Get_Short_Help (Cmd : Command_Lines) return String is pragma Unreferenced (Cmd); begin return "lines FILEs" & ASCII.LF & " Precede line with its number" & ASCII.LF & " alias: --lines"; end Get_Short_Help; procedure Perform_Action (Cmd : in out Command_Lines; Args : Argument_List) is pragma Unreferenced (Cmd); use Vhdl.Scanner; use Vhdl.Tokens; use Files_Map; use Ada.Characters.Latin_1; Id : Name_Id; Fe : Source_File_Entry; Local_Id : Name_Id; Line : Natural; File : Source_File_Entry; Buf : File_Buffer_Acc; Ptr : Source_Ptr; Eptr : Source_Ptr; C : Character; N : Natural; Log : Natural; Str : String (1 .. 10); begin Local_Id := Get_Identifier (""); for I in Args'Range loop -- Load the file. Id := Get_Identifier (Args (I).all); Fe := Files_Map.Read_Source_File (Local_Id, Id); if Fe = No_Source_File_Entry then Error ("cannot open file " & Args (I).all); raise Compile_Error; end if; Set_File (Fe); -- Scan the content, to compute the number of lines. loop Scan; exit when Current_Token = Tok_Eof; end loop; File := Get_Current_Source_File; Line := Get_Current_Line; Close_File; -- Compute log10 of line. N := Line; Log := 0; loop N := N / 10; Log := Log + 1; exit when N = 0; end loop; -- Disp file name. Put (Args (I).all); Put (':'); New_Line; Buf := Get_File_Source (File); for J in 1 .. Line loop Ptr := File_Line_To_Position (File, J); exit when Ptr = Source_Ptr_Bad; exit when Buf (Ptr) = Files_Map.EOT; -- Disp line number. N := J; for K in reverse 1 .. Log loop if N = 0 then Str (K) := ' '; else Str (K) := Character'Val (48 + N mod 10); N := N / 10; end if; end loop; Put (Str (1 .. Log)); Put (": "); -- Search for end of line (or end of file). Eptr := Ptr; loop C := Buf (Eptr); exit when C = Files_Map.EOT or C = LF or C = CR; Eptr := Eptr + 1; end loop; -- Disp line. if Eptr > Ptr then -- Avoid constraint error on conversion of nul array. declare subtype Conv_Subtype is String (1 .. Natural (Eptr - Ptr)); begin Put (Conv_Subtype (Buf (Ptr .. Eptr - 1))); end; end if; New_Line; end loop; end loop; end Perform_Action; -- Command Reprint. type Command_Reprint is new Command_Lib with record Flag_Sem : Boolean := True; Flag_Format : Boolean := False; Level : Format_Level := Format_Indent; Flag_Realign : Boolean := False; Flag_Force : Boolean := False; First_Line : Positive := 1; Last_Line : Positive := Positive'Last; end record; function Decode_Command (Cmd : Command_Reprint; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Reprint) return String; procedure Decode_Option (Cmd : in out Command_Reprint; Option : String; Arg : String; Res : out Option_State); procedure Perform_Action (Cmd : in out Command_Reprint; Args : Argument_List); function Decode_Command (Cmd : Command_Reprint; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "reprint" or else Name = "--reprint"; end Decode_Command; function Get_Short_Help (Cmd : Command_Reprint) return String is pragma Unreferenced (Cmd); begin return "reprint [OPTS] FILEs" & ASCII.LF & " Redisplay FILEs" & ASCII.LF & " alias: --reprint"; end Get_Short_Help; procedure Decode_Option (Cmd : in out Command_Reprint; Option : String; Arg : String; Res : out Option_State) is pragma Assert (Option'First = 1); begin if Option = "--no-sem" then Cmd.Flag_Sem := False; Res := Option_Ok; elsif Option = "--force" then Cmd.Flag_Force := True; Res := Option_Ok; elsif Option = "--realign" then Cmd.Flag_Realign := True; Res := Option_Ok; elsif Option'Length > 8 and then Option (1 .. 8) = "--range=" then declare F : constant Natural := 9; L : constant Natural := Option'Last; Colon : constant Natural := Index (Option (F .. L), ':'); begin if Colon = 0 then Cmd.First_Line := Positive'Value (Option (F .. L)); Cmd.Last_Line := Cmd.First_Line; else if Colon > 9 then Cmd.First_Line := Positive'Value (Option (F .. Colon - 1)); end if; if Colon < Option'Last then Cmd.Last_Line := Positive'Value (Option (Colon + 1 .. L)); end if; end if; Res := Option_Ok; exception when Constraint_Error => Res := Option_Err; end; else Decode_Option (Command_Lib (Cmd), Option, Arg, Res); end if; end Decode_Option; procedure Perform_Action (Cmd : in out Command_Reprint; Args : Argument_List) is Design_File : Iir_Design_File; Unit : Iir; Next_Unit : Iir; Id : Name_Id; begin if Cmd.Flag_Sem then -- Libraries are required for semantic analysis. if not Setup_Libraries (True) then return; end if; end if; -- Keep parenthesis during parse. Vhdl.Parse.Flag_Parse_Parenthesis := True; Vhdl.Canon.Canon_Flag_Concurrent_Stmts := False; Vhdl.Canon.Canon_Flag_Configurations := False; Vhdl.Canon.Canon_Flag_Specification_Lists := False; Vhdl.Canon.Canon_Flag_Associations := False; -- Parse all files. for I in Args'Range loop Id := Name_Table.Get_Identifier (Args (I).all); Design_File := Load_File_Name (Id); if Design_File = Null_Iir or else (Errorout.Nbr_Errors > 0 and not Cmd.Flag_Force) then raise Errorout.Compilation_Error; end if; Unit := Get_First_Design_Unit (Design_File); if Cmd.Flag_Sem then Design_File := Null_Iir; end if; while Unit /= Null_Iir loop if Cmd.Flag_Sem then -- Analyze the design unit. Vhdl.Sem_Lib.Finish_Compilation (Unit, True); if Cmd.Flag_Sem and then Design_File = Null_Iir then Design_File := Get_Design_File (Unit); end if; end if; Next_Unit := Get_Chain (Unit); if not Cmd.Flag_Format and then (Errorout.Nbr_Errors = 0 or Cmd.Flag_Force) then Vhdl.Prints.Disp_Vhdl (Unit); end if; if Errorout.Nbr_Errors = 0 then if Cmd.Flag_Sem then Set_Chain (Unit, Null_Iir); Libraries.Add_Design_Unit_Into_Library (Unit); end if; end if; Unit := Next_Unit; end loop; if Errorout.Nbr_Errors > 0 then raise Errorout.Compilation_Error; end if; if Cmd.Flag_Format then Vhdl.Formatters.Format (Design_File, Cmd.Level, Cmd.Flag_Realign, Cmd.First_Line, Cmd.Last_Line); end if; end loop; end Perform_Action; -- Command Format type Command_Format is new Command_Reprint with null record; function Decode_Command (Cmd : Command_Format; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Format) return String; procedure Decode_Option (Cmd : in out Command_Format; Option : String; Arg : String; Res : out Option_State); procedure Perform_Action (Cmd : in out Command_Format; Args : Argument_List); function Decode_Command (Cmd : Command_Format; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "fmt" or else Name = "--format"; end Decode_Command; function Get_Short_Help (Cmd : Command_Format) return String is pragma Unreferenced (Cmd); begin return "fmt [OPTS] FILEs" & ASCII.LF & " Format FILEs" & ASCII.LF & " alias: --format"; end Get_Short_Help; procedure Decode_Option (Cmd : in out Command_Format; Option : String; Arg : String; Res : out Option_State) is pragma Assert (Option'First = 1); begin if Option = "--level=indent" then Cmd.Level := Format_Indent; Res := Option_Ok; elsif Option = "--level=none" then Cmd.Level := Format_None; Res := Option_Ok; elsif Option = "--level=space" then Cmd.Level := Format_Space; Res := Option_Ok; else Decode_Option (Command_Reprint (Cmd), Option, Arg, Res); end if; end Decode_Option; procedure Perform_Action (Cmd : in out Command_Format; Args : Argument_List) is begin Cmd.Flag_Format := True; Perform_Action (Command_Reprint (Cmd), Args); end Perform_Action; -- Command compare tokens. type Command_Compare_Tokens is new Command_Lib with null record; function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Compare_Tokens) return String; procedure Perform_Action (Cmd : in out Command_Compare_Tokens; Args : Argument_List); function Decode_Command (Cmd : Command_Compare_Tokens; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "compare-tokens" or else Name = "--compare-tokens"; end Decode_Command; function Get_Short_Help (Cmd : Command_Compare_Tokens) return String is pragma Unreferenced (Cmd); begin return "compare-tokens [OPTS] REF FILEs" & ASCII.LF & " Compare FILEs with REF" & ASCII.LF & " alias: --compare-tokens"; end Get_Short_Help; procedure Perform_Action (Cmd : in out Command_Compare_Tokens; Args : Argument_List) is pragma Unreferenced (Cmd); use Vhdl.Tokens; use Vhdl.Scanner; package Ref_Tokens is new Tables (Table_Component_Type => Token_Type, Table_Index_Type => Integer, Table_Low_Bound => 0, Table_Initial => 1024); Id : Name_Id; Fe : Source_File_Entry; Local_Id : Name_Id; Tok_Idx : Natural; begin if Args'Length < 1 then Error ("missing ref file"); raise Compile_Error; end if; Local_Id := Get_Identifier (""); for I in Args'Range loop -- Load the file. Id := Get_Identifier (Args (I).all); Fe := Files_Map.Read_Source_File (Local_Id, Id); if Fe = No_Source_File_Entry then Error ("cannot open file " & Args (I).all); raise Compile_Error; end if; Set_File (Fe); if I = Args'First then -- Scan ref file loop Scan; Ref_Tokens.Append (Current_Token); exit when Current_Token = Tok_Eof; end loop; else -- Scan file Tok_Idx := Ref_Tokens.First; loop Scan; if Ref_Tokens.Table (Tok_Idx) /= Current_Token then Report_Msg (Msgid_Error, Errorout.Parse, Get_Token_Coord, "token mismatch"); exit; end if; case Current_Token is when Tok_Eof => exit; when others => null; end case; Tok_Idx := Tok_Idx + 1; end loop; end if; Close_File; end loop; Ref_Tokens.Free; if Nbr_Errors /= 0 then raise Compilation_Error; end if; end Perform_Action; -- Command html. type Command_Html is abstract new Command_Lib with null record; procedure Decode_Option (Cmd : in out Command_Html; Option : String; Arg : String; Res : out Option_State); procedure Disp_Long_Help (Cmd : Command_Html); procedure Decode_Option (Cmd : in out Command_Html; Option : String; Arg : String; Res : out Option_State) is begin if Option = "--format=css" then Html_Format := Html_Css; Res := Option_Ok; elsif Option = "--format=html2" then Html_Format := Html_2; Res := Option_Ok; else Decode_Option (Command_Lib (Cmd), Option, Arg, Res); end if; end Decode_Option; procedure Disp_Long_Help (Cmd : Command_Html) is begin Disp_Long_Help (Command_Lib (Cmd)); Put_Line ("--format=html2 Use FONT attributes"); Put_Line ("--format=css Use ghdl.css file"); end Disp_Long_Help; -- Command --pp-html. type Command_PP_Html is new Command_Html with null record; function Decode_Command (Cmd : Command_PP_Html; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_PP_Html) return String; procedure Perform_Action (Cmd : in out Command_PP_Html; Files : Argument_List); function Decode_Command (Cmd : Command_PP_Html; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "pp-html" or else Name = "--pp-html"; end Decode_Command; function Get_Short_Help (Cmd : Command_PP_Html) return String is pragma Unreferenced (Cmd); begin return "pp-html FILEs" & ASCII.LF & " Pretty-print FILEs in HTML" & ASCII.LF & " alias: --pp-html"; end Get_Short_Help; procedure Perform_Action (Cmd : in out Command_PP_Html; Files : Argument_List) is pragma Unreferenced (Cmd); Id : Name_Id; Fe : Source_File_Entry; Local_Id : Name_Id; begin Local_Id := Get_Identifier (""); Put_Html_Header; Put_Line (" "); for I in Files'Range loop Put (" "); Put_Line (Files (I).all); end loop; Put_Line (" "); Put_Line (""); New_Line; Put_Line (""); for I in Files'Range loop Id := Get_Identifier (Files (I).all); Fe := Files_Map.Read_Source_File (Local_Id, Id); if Fe = No_Source_File_Entry then Error ("cannot open file " & Files (I).all); raise Compile_Error; end if; Put ("

"); Put (Files (I).all); Put ("

"); New_Line; PP_Html_File (Fe); end loop; Put_Html_Foot; end Perform_Action; -- Command --xref-html. type Command_Xref_Html is new Command_Html with record Output_Dir : String_Access := null; Check_Missing : Boolean := False; end record; function Decode_Command (Cmd : Command_Xref_Html; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Xref_Html) return String; procedure Decode_Option (Cmd : in out Command_Xref_Html; Option : String; Arg : String; Res : out Option_State); procedure Disp_Long_Help (Cmd : Command_Xref_Html); procedure Perform_Action (Cmd : in out Command_Xref_Html; Files_Name : Argument_List); function Decode_Command (Cmd : Command_Xref_Html; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "xref-html" or else Name = "--xref-html"; end Decode_Command; function Get_Short_Help (Cmd : Command_Xref_Html) return String is pragma Unreferenced (Cmd); begin return "xref-html FILEs" & ASCII.LF & " Display FILEs in HTML with xrefs" & ASCII.LF & " alias: --xref-html"; end Get_Short_Help; procedure Decode_Option (Cmd : in out Command_Xref_Html; Option : String; Arg : String; Res : out Option_State) is begin if Option = "-o" then if Arg = "" then Res := Option_Arg_Req; else Cmd.Output_Dir := new String'(Arg); Res := Option_Arg; end if; elsif Option = "--check-missing" then Cmd.Check_Missing := True; Enable_Warning (Warnid_Missing_Xref, True); Res := Option_Ok; else Decode_Option (Command_Html (Cmd), Option, Arg, Res); end if; end Decode_Option; procedure Disp_Long_Help (Cmd : Command_Xref_Html) is begin Disp_Long_Help (Command_Html (Cmd)); Put_Line ("-o DIR Put generated files into DIR (def: html/)"); Put_Line ("--check-missing Fail if a reference is missing"); New_Line; Put_Line ("When format is css, the CSS file 'ghdl.css' " & "is never overwritten."); end Disp_Long_Help; procedure Analyze_Design_File_Units (File : Iir_Design_File) is Unit : Iir_Design_Unit; begin Unit := Get_First_Design_Unit (File); while Unit /= Null_Iir loop case Get_Date_State (Unit) is when Date_Extern | Date_Disk => raise Internal_Error; when Date_Parse => Vhdl.Sem_Lib.Load_Design_Unit (Unit, Get_Location (Unit)); if Errorout.Nbr_Errors /= 0 then raise Compilation_Error; end if; when Date_Analyze => null; end case; Unit := Get_Chain (Unit); end loop; end Analyze_Design_File_Units; procedure Perform_Action (Cmd : in out Command_Xref_Html; Files_Name : Argument_List) is use GNAT.Directory_Operations; Id : Name_Id; File : Source_File_Entry; type File_Data is record Fe : Source_File_Entry; Design_File : Iir; Output : String_Acc; end record; type File_Data_Array is array (Files_Name'Range) of File_Data; Output_Dir : String_Access; Files : File_Data_Array; Output : File_Type; begin Vhdl.Xrefs.Init; Flags.Flag_Xref := True; -- Load work library. if not Setup_Libraries (True) then return; end if; Output_Dir := Cmd.Output_Dir; if Output_Dir = null then Output_Dir := new String'("html"); elsif Output_Dir.all = "-" then Output_Dir := null; end if; -- Try to create the directory. if Output_Dir /= null and then not Is_Directory (Output_Dir.all) then begin Make_Dir (Output_Dir.all); exception when Directory_Error => Error ("cannot create directory " & Output_Dir.all); return; end; end if; -- Parse all files. for I in Files'Range loop Id := Get_Identifier (Files_Name (I).all); File := Files_Map.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; Files (I).Output := Create_Output_Filename (Base_Name (Files_Name (I).all), I); if Is_Regular_File (Files (I).Output.all) then -- Prevent overwrite. null; end if; -- Put units in library. 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; Vhdl.Xrefs.Sort_By_Location; if False then -- Dump locations for I in 1 .. Vhdl.Xrefs.Get_Last_Xref loop declare use Vhdl.Xrefs; procedure Put_Loc (L : Location_Type) is use Files_Map; L_File : Source_File_Entry; L_Pos : Source_Ptr; begin Files_Map.Location_To_File_Pos (L, L_File, L_Pos); Put_Nat (Natural (L_File)); --Image (Get_File_Name (L_File)); --Put (Name_Buffer (1 .. Name_Length)); Put (":"); Put_Nat (Natural (L_Pos)); end Put_Loc; begin Put_Loc (Get_Xref_Location (I)); case Get_Xref_Kind (I) is when Xref_Decl => Put (" decl "); Put (Image (Get_Identifier (Get_Xref_Node (I)))); when Xref_Ref => Put (" use "); Put_Loc (Get_Location (Get_Xref_Node (I))); when Xref_End => Put (" end "); when Xref_Body => Put (" body "); when Xref_Keyword => Put (" keyword "); end case; New_Line; end; end loop; end if; -- Create filexref_info. Filexref_Info := new Filexref_Info_Arr (No_Source_File_Entry .. Files_Map.Get_Last_Source_File_Entry); Filexref_Info.all := (others => (Output => null, Referenced => False)); for I in Files'Range loop Filexref_Info (Files (I).Fe).Output := Files (I).Output; end loop; for I in Files'Range loop if Output_Dir /= null then Create (Output, Out_File, Output_Dir.all & Directory_Separator & Files (I).Output.all); Set_Output (Output); end if; Put_Html_Header; Put_Line (" "); Put_Html (Files_Name (I).all); Put (""); Put_Line (""); New_Line; Put_Line (""); Put ("

"); Put_Html (Files_Name (I).all); Put ("

"); New_Line; PP_Html_File (Files (I).Fe); Put_Html_Foot; if Output_Dir /= null then Close (Output); end if; end loop; -- Create indexes. if Output_Dir /= null then Create (Output, Out_File, Output_Dir.all & Directory_Separator & "index.html"); Set_Output (Output); Put_Html_Header; Put_Line (" Xrefs indexes"); Put_Line (""); New_Line; Put_Line (""); Put_Line ("

list of files:"); Put_Line ("

"); Put_Line ("
"); -- TODO: list of design units. Put_Line ("

list of files referenced but not available:"); Put_Line ("


"); Put_Html_Foot; Close (Output); end if; if Html_Format = Html_Css and then Output_Dir /= null then declare Css_Filename : constant String := Output_Dir.all & Directory_Separator & "ghdl.css"; begin if not Is_Regular_File (Css_Filename & Nul) then Create (Output, Out_File, Css_Filename); Set_Output (Output); Put_Css; Close (Output); end if; end; end if; if Missing_Xref and Cmd.Check_Missing then Error ("missing xrefs"); raise Compile_Error; end if; exception when Compilation_Error => Error ("xrefs has failed due to compilation error"); end Perform_Action; -- Command --xref type Command_Xref is new Command_Lib with null record; function Decode_Command (Cmd : Command_Xref; Name : String) return Boolean; function Get_Short_Help (Cmd : Command_Xref) return String; procedure Perform_Action (Cmd : in out Command_Xref; Files_Name : Argument_List); function Decode_Command (Cmd : Command_Xref; Name : String) return Boolean is pragma Unreferenced (Cmd); begin return Name = "xref" or else Name = "--xref"; end Decode_Command; function Get_Short_Help (Cmd : Command_Xref) return String is pragma Unreferenced (Cmd); begin return "xref FILEs" & ASCII.LF & " Generate xrefs" & ASCII.LF & " alias: --xref"; end Get_Short_Help; procedure Perform_Action (Cmd : in out Command_Xref; 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; Vhdl.Xrefs.Init; Flags.Flag_Xref := 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; Vhdl.Xrefs.Fix_End_Xrefs; Vhdl.Xrefs.Sort_By_Node_Location; for F in Files'Range loop Put ("GHDL-XREF V0"); declare use Vhdl.Xrefs; Cur_Decl : Iir; Cur_File : Source_File_Entry; procedure Emit_Loc (Loc : Location_Type; C : Character) is L_File : Source_File_Entry; L_Pos : Source_Ptr; L_Line : Natural; L_Off : Natural; begin Location_To_Coord (Loc, L_File, L_Pos, L_Line, L_Off); --Put_Nat (Natural (L_File)); --Put (':'); Put_Nat (L_Line); Put (C); Put_Nat (L_Off); end Emit_Loc; procedure Emit_Decl (N : Iir) is Loc : Location_Type; Loc_File : Source_File_Entry; Loc_Pos : Source_Ptr; C : Character; Dir : Name_Id; begin New_Line; Cur_Decl := N; Loc := Get_Location (N); Location_To_File_Pos (Loc, Loc_File, Loc_Pos); if Loc_File /= Cur_File then Cur_File := Loc_File; Put ("XFILE: "); Dir := Get_Directory_Name (Cur_File); if Dir /= Null_Identifier then Put (Image (Dir)); end if; Put (Image (Get_File_Name (Cur_File))); New_Line; end if; -- Unused letters: -- b d fgh jk no qr uvwxyz -- D H JK MNO QR U WXYZ case Get_Kind (N) is when Iir_Kind_Type_Declaration => C := 'T'; when Iir_Kind_Subtype_Declaration => C := 't'; when Iir_Kind_Entity_Declaration => C := 'E'; when Iir_Kind_Architecture_Body => C := 'A'; when Iir_Kind_Library_Declaration => C := 'L'; when Iir_Kind_Package_Declaration => C := 'P'; when Iir_Kind_Package_Body => C := 'B'; when Iir_Kind_Function_Declaration => C := 'F'; when Iir_Kind_Procedure_Declaration => C := 'p'; when Iir_Kind_Interface_Signal_Declaration => C := 's'; when Iir_Kind_Signal_Declaration => C := 'S'; when Iir_Kind_Interface_Constant_Declaration => C := 'c'; when Iir_Kind_Constant_Declaration => C := 'C'; when Iir_Kind_Variable_Declaration => C := 'V'; when Iir_Kind_Element_Declaration => C := 'e'; when Iir_Kind_Iterator_Declaration => C := 'i'; when Iir_Kind_Attribute_Declaration => C := 'a'; when Iir_Kind_Enumeration_Literal => C := 'l'; when Iir_Kind_Component_Declaration => C := 'm'; when Iir_Kind_Component_Instantiation_Statement => C := 'I'; when Iir_Kind_If_Generate_Statement | Iir_Kind_For_Generate_Statement => C := 'G'; when others => C := '?'; end case; Emit_Loc (Loc, C); --Disp_Tree.Disp_Iir_Address (N); Put (' '); case Get_Kind (N) is when Iir_Kind_Function_Body | Iir_Kind_Procedure_Body => null; when others => Put (Image (Get_Identifier (N))); end case; end Emit_Decl; procedure Emit_Ref (R : Xref; T : Character) is N : Iir; begin N := Get_Xref_Node (R); if N /= Cur_Decl then Emit_Decl (N); end if; Put (' '); Emit_Loc (Get_Xref_Location (R), T); end Emit_Ref; Loc : Location_Type; Loc_File : Source_File_Entry; Loc_Pos : Source_Ptr; begin Cur_Decl := Null_Iir; Cur_File := No_Source_File_Entry; for I in First_Xref .. Get_Last_Xref loop Loc := Get_Xref_Location (I); Location_To_File_Pos (Loc, Loc_File, Loc_Pos); if Loc_File = Files (F).Fe then -- This is a local location. case Get_Xref_Kind (I) is when Xref_Decl => Emit_Decl (Get_Xref_Node (I)); when Xref_End => Emit_Ref (I, 'e'); when Xref_Ref => Emit_Ref (I, 'r'); when Xref_Body => Emit_Ref (I, 'b'); when Xref_Keyword => -- Keywords location are not written. null; end case; end if; end loop; New_Line; end; end loop; exception when Compilation_Error => Error ("xrefs has failed due to compilation error"); end Perform_Action; procedure Register_Commands is begin Register_Command (new Command_Chop); Register_Command (new Command_Lines); Register_Command (new Command_Reprint); Register_Command (new Command_Format); Register_Command (new Command_Compare_Tokens); Register_Command (new Command_PP_Html); Register_Command (new Command_Xref_Html); Register_Command (new Command_Xref); end Register_Commands; end Ghdlprint;