-- VHDL code formatter.
-- Copyright (C) 2019 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 GHDL; see the file COPYING. If not, write to the Free
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
with Ada.Unchecked_Deallocation;
with Types; use Types;
with Files_Map;
with Simple_IO;
with Vhdl.Tokens; use Vhdl.Tokens;
with Vhdl.Scanner; use Vhdl.Scanner;
with Vhdl.Prints; use Vhdl.Prints;
package body Vhdl.Formatters is
-- Check token TOK with the one from the scanner. Deal with irregular
-- cases.
procedure Check_Token (Tok : Token_Type) is
begin
-- There are a couple of exceptions due to attributes or
-- PSL.
if Tok = Tok_Identifier
and then (Current_Token = Tok_Range
or else Current_Token = Tok_Subtype)
then
null;
elsif (Tok = Tok_Psl_Default
or else Tok = Tok_Psl_Clock)
and then Current_Token = Tok_Identifier
then
null;
elsif Tok /= Current_Token then
declare
use Simple_IO;
begin
Put_Line_Err ("error: token mismatch. ");
Put_Err (" need to print: ");
Put_Err (Image (Tok));
Put_Err (", but read ");
Put_Err (Image (Current_Token));
Put_Err (" from file.");
New_Line_Err;
end;
raise Internal_Error;
end if;
end Check_Token;
package Format_Disp_Ctxt is
type Format_Ctxt is new Disp_Ctxt with private;
procedure Init (Ctxt : out Format_Ctxt; Sfe : Source_File_Entry);
procedure Start_Hbox (Ctxt : in out Format_Ctxt);
procedure Close_Hbox (Ctxt : in out Format_Ctxt);
procedure Start_Vbox (Ctxt : in out Format_Ctxt);
procedure Close_Vbox (Ctxt : in out Format_Ctxt);
procedure Disp_Token (Ctxt : in out Format_Ctxt; Tok : Token_Type);
procedure Start_Lit (Ctxt : in out Format_Ctxt; Tok : Token_Type);
procedure Disp_Char (Ctxt : in out Format_Ctxt; C : Character);
procedure Close_Lit (Ctxt : in out Format_Ctxt);
private
type Format_Ctxt is new Disp_Ctxt with record
Vnum : Natural;
Hnum : Natural;
Prev_Tok : Token_Type;
Sfe : Source_File_Entry;
Source : File_Buffer_Acc;
end record;
procedure Disp_Newline (Ctxt : in out Format_Ctxt);
procedure Disp_Indent (Ctxt : in out Format_Ctxt);
procedure Put (Ctxt : in out Format_Ctxt; C : Character);
procedure Sync (Ctxt : in out Format_Ctxt; Tok : Token_Type);
end Format_Disp_Ctxt;
package body Format_Disp_Ctxt is
procedure Init (Ctxt : out Format_Ctxt; Sfe : Source_File_Entry) is
begin
Ctxt := (Vnum => 0,
Hnum => 0,
Prev_Tok => Tok_Newline,
Sfe => Sfe,
Source => Files_Map.Get_File_Source (Sfe));
end Init;
procedure Put (Ctxt : in out Format_Ctxt; C : Character)
is
pragma Unreferenced (Ctxt);
begin
Simple_IO.Put (C);
end Put;
procedure Start_Hbox (Ctxt : in out Format_Ctxt) is
begin
Ctxt.Hnum := Ctxt.Hnum + 1;
end Start_Hbox;
procedure Disp_Newline (Ctxt : in out Format_Ctxt) is
begin
Put (Ctxt, ASCII.LF);
Ctxt.Prev_Tok := Tok_Newline;
end Disp_Newline;
procedure Close_Hbox (Ctxt : in out Format_Ctxt) is
begin
Ctxt.Hnum := Ctxt.Hnum - 1;
if Ctxt.Hnum = 0 then
Disp_Newline (Ctxt);
end if;
end Close_Hbox;
procedure Start_Vbox (Ctxt : in out Format_Ctxt) is
begin
pragma Assert (Ctxt.Hnum = 0);
Ctxt.Vnum := Ctxt.Vnum + 1;
end Start_Vbox;
procedure Close_Vbox (Ctxt : in out Format_Ctxt) is
begin
Ctxt.Vnum := Ctxt.Vnum - 1;
end Close_Vbox;
procedure Disp_Indent (Ctxt : in out Format_Ctxt) is
begin
for I in 1 .. Ctxt.Vnum loop
Put (Ctxt, ' ');
Put (Ctxt, ' ');
end loop;
end Disp_Indent;
procedure Disp_Space (Ctxt : in out Format_Ctxt; Tok : Token_Type)
is
Prev_Tok : constant Token_Type := Ctxt.Prev_Tok;
begin
if Prev_Tok = Tok_Newline
and then Ctxt.Hnum = 1
then
Disp_Indent (Ctxt);
elsif Need_Space (Tok, Prev_Tok) then
Put (Ctxt, ' ');
end if;
Ctxt.Prev_Tok := Tok;
end Disp_Space;
procedure Disp_Token (Ctxt : in out Format_Ctxt; Tok : Token_Type) is
begin
Sync (Ctxt, Tok);
Disp_Space (Ctxt, Tok);
Disp_Str (Ctxt, Image (Tok));
end Disp_Token;
procedure Start_Lit (Ctxt : in out Format_Ctxt; Tok : Token_Type) is
begin
Sync (Ctxt, Tok);
Disp_Space (Ctxt, Tok);
end Start_Lit;
procedure Disp_Char (Ctxt : in out Format_Ctxt; C : Character) is
begin
Put (Ctxt, C);
end Disp_Char;
procedure Close_Lit (Ctxt : in out Format_Ctxt) is
begin
null;
end Close_Lit;
procedure Sync (Ctxt : in out Format_Ctxt; Tok : Token_Type) is
begin
-- The easy case.
loop
case Current_Token is
when Tok_Eof =>
raise Internal_Error;
when Tok_Newline =>
-- Ignored
Scan;
-- But empty lines are kept.
while Current_Token = Tok_Newline loop
Disp_Newline (Ctxt);
Scan;
end loop;
when Tok_Line_Comment
| Tok_Block_Comment =>
-- Display the comment as it is.
declare
P : Source_Ptr;
begin
-- Re-indent the comment unless this is an end-of-line
-- comment or a comment at line 0.
if Ctxt.Prev_Tok = Tok_Newline then
-- Compute the offset. Not trivial for block
-- comment as this is a multi-line token and
-- Get_Token_Offset is not valid in that case.
declare
Off : Natural;
Line_Pos : Source_Ptr;
Line : Positive;
begin
if Current_Token = Tok_Block_Comment then
Files_Map.File_Pos_To_Coord
(Ctxt.Sfe, Get_Token_Position,
Line_Pos, Line, Off);
else
Off := Get_Token_Offset;
end if;
if Off /= 0 then
Disp_Indent (Ctxt);
end if;
end;
end if;
P := Get_Token_Position;
for I in 1 .. Get_Token_Length loop
Disp_Char (Ctxt, Ctxt.Source (P));
P := P + 1;
end loop;
end;
Scan;
while Current_Token = Tok_Newline loop
Disp_Newline (Ctxt);
Scan;
end loop;
when others =>
if Current_Token = Tok_Integer_Letter
and then Tok = Tok_Bit_String
then
Scan;
end if;
Check_Token (Tok);
Scan;
return;
end case;
end loop;
end Sync;
end Format_Disp_Ctxt;
procedure Format (F : Iir_Design_File)
is
use Format_Disp_Ctxt;
Sfe : constant Source_File_Entry := Get_Design_File_Source (F);
Ctxt : Format_Ctxt;
begin
Scanner.Flag_Comment := True;
Scanner.Flag_Newline := True;
Set_File (Sfe);
Scan;
Init (Ctxt, Sfe);
Prints.Disp_Vhdl (Ctxt, F);
Close_File;
Scanner.Flag_Comment := False;
Scanner.Flag_Newline := False;
end Format;
package Indent_Disp_Ctxt is
type Indent_Ctxt is new Disp_Ctxt with record
Vnum : Natural;
Hnum : Natural;
Hfirst : Boolean; -- First token in the hbox.
Last_Tok : Source_Ptr;
Col : Natural;
Line : Positive;
First_Line : Positive;
Last_Line : Positive;
Discard_Output : Boolean;
Sfe : Source_File_Entry;
Source : File_Buffer_Acc;
end record;
procedure Init (Ctxt : out Indent_Ctxt;
Sfe : Source_File_Entry;
First_Line : Positive;
Last_Line : Positive);
procedure Start_Hbox (Ctxt : in out Indent_Ctxt);
procedure Close_Hbox (Ctxt : in out Indent_Ctxt);
procedure Start_Vbox (Ctxt : in out Indent_Ctxt);
procedure Close_Vbox (Ctxt : in out Indent_Ctxt);
procedure Disp_Token (Ctxt : in out Indent_Ctxt; Tok : Token_Type);
procedure Start_Lit (Ctxt : in out Indent_Ctxt; Tok : Token_Type);
procedure Disp_Char (Ctxt : in out Indent_Ctxt; C : Character) is null;
procedure Close_Lit (Ctxt : in out Indent_Ctxt) is null;
procedure Put (Ctxt : in out Indent_Ctxt; C : Character);
private
procedure Sync (Ctxt : in out Indent_Ctxt; Tok : Token_Type);
end Indent_Disp_Ctxt;
package body Indent_Disp_Ctxt is
procedure Init (Ctxt : out Indent_Ctxt;
Sfe : Source_File_Entry;
First_Line : Positive;
Last_Line : Positive) is
begin
Ctxt := (Vnum => 0,
Hnum => 0,
Hfirst => False,
Last_Tok => Source_Ptr_Org,
Col => 0,
Line => 1,
First_Line => First_Line,
Last_Line => Last_Line,
Discard_Output => First_Line > 1,
Sfe => Sfe,
Source => Files_Map.Get_File_Source (Sfe));
Scanner.Flag_Comment := True;
Scanner.Flag_Newline := True;
Set_File (Sfe);
Scan;
end Init;
procedure Put (Ctxt : in out Indent_Ctxt; C : Character)
is
pragma Unreferenced (Ctxt);
begin
Simple_IO.Put (C);
end Put;
procedure Disp_Spaces (Ctxt : in out Indent_Ctxt)
is
use Files_Map;
C : Character;
P : Source_Ptr;
N_Col : Natural;
Bef_Tok : Source_Ptr;
Indent : Natural;
begin
if Ctxt.Discard_Output then
return;
end if;
if Ctxt.Col = 0 then
-- Reindent.
Indent := Ctxt.Vnum;
if Ctxt.Hnum > 0 and not Ctxt.Hfirst then
Indent := Indent + 1;
end if;
for I in 1 .. 2 * Indent loop
Put (Indent_Ctxt'Class (Ctxt), ' ');
end loop;
Ctxt.Col := 2 * Indent;
else
P := Ctxt.Last_Tok;
Bef_Tok := Get_Token_Position;
while P < Bef_Tok loop
C := Ctxt.Source (P);
if C = ASCII.HT then
-- Expand TABS.
N_Col := Ctxt.Col + Tab_Stop;
N_Col := N_Col - N_Col mod Tab_Stop;
while Ctxt.Col < N_Col loop
Put (Indent_Ctxt'Class (Ctxt), ' ');
Ctxt.Col := Ctxt.Col + 1;
end loop;
else
Put (Indent_Ctxt'Class (Ctxt), ' ');
Ctxt.Col := Ctxt.Col + 1;
end if;
P := P + 1;
end loop;
end if;
end Disp_Spaces;
-- Disp text for sources for the current token.
procedure Disp_Text (Ctxt : in out Indent_Ctxt)
is
Aft_Tok : constant Source_Ptr := Get_Position;
P : Source_Ptr;
begin
if Ctxt.Discard_Output then
return;
end if;
P := Get_Token_Position;
while P < Aft_Tok loop
Put (Indent_Ctxt'Class (Ctxt), Ctxt.Source (P));
Ctxt.Col := Ctxt.Col + 1;
P := P + 1;
end loop;
end Disp_Text;
procedure Disp_Comments (Ctxt : in out Indent_Ctxt) is
begin
loop
case Current_Token is
when Tok_Eof =>
raise Internal_Error;
when Tok_Newline =>
if not Ctxt.Discard_Output then
Put (Indent_Ctxt'Class (Ctxt), ASCII.LF);
end if;
Ctxt.Col := 0;
Ctxt.Line := Ctxt.Line + 1;
Ctxt.Discard_Output :=
Ctxt.Line < Ctxt.First_Line
or Ctxt.Line > Ctxt.Last_Line;
when Tok_Line_Comment
| Tok_Block_Comment =>
Disp_Spaces (Ctxt);
Disp_Text (Ctxt);
when others =>
exit;
end case;
Ctxt.Last_Tok := Get_Position;
Scan;
end loop;
end Disp_Comments;
procedure Start_Hbox (Ctxt : in out Indent_Ctxt) is
begin
Disp_Comments (Ctxt);
Ctxt.Hnum := Ctxt.Hnum + 1;
Ctxt.Hfirst := True;
end Start_Hbox;
procedure Close_Hbox (Ctxt : in out Indent_Ctxt) is
begin
-- An hbox cannot be empty.
pragma Assert (Ctxt.Hfirst = False);
Ctxt.Hnum := Ctxt.Hnum - 1;
end Close_Hbox;
procedure Start_Vbox (Ctxt : in out Indent_Ctxt) is
begin
pragma Assert (Ctxt.Hnum = 0);
Ctxt.Vnum := Ctxt.Vnum + 1;
end Start_Vbox;
procedure Close_Vbox (Ctxt : in out Indent_Ctxt) is
begin
Ctxt.Vnum := Ctxt.Vnum - 1;
end Close_Vbox;
procedure Sync (Ctxt : in out Indent_Ctxt; Tok : Token_Type) is
begin
Disp_Comments (Ctxt);
Disp_Spaces (Ctxt);
Disp_Text (Ctxt);
if Current_Token = Tok_Integer_Letter
and then Tok = Tok_Bit_String
then
Scan;
Disp_Text (Ctxt);
end if;
Check_Token (Tok);
Ctxt.Last_Tok := Get_Position;
Ctxt.Hfirst := False;
Scan;
end Sync;
procedure Disp_Token (Ctxt : in out Indent_Ctxt; Tok : Token_Type) is
begin
Sync (Ctxt, Tok);
end Disp_Token;
procedure Start_Lit (Ctxt : in out Indent_Ctxt; Tok : Token_Type) is
begin
Sync (Ctxt, Tok);
end Start_Lit;
end Indent_Disp_Ctxt;
package Indent_Vstrings_Ctxt is
use Grt.Vstrings;
type Vstring_Ctxt is new Indent_Disp_Ctxt.Indent_Ctxt with private;
procedure Init (Ctxt : out Vstring_Ctxt;
Handle : Vstring_Acc;
Sfe : Source_File_Entry;
First_Line : Positive;
Last_Line : Positive);
procedure Put (Ctxt : in out Vstring_Ctxt; C : Character);
private
type Vstring_Ctxt is new Indent_Disp_Ctxt.Indent_Ctxt with record
Hand : Vstring_Acc;
end record;
end Indent_Vstrings_Ctxt;
package body Indent_Vstrings_Ctxt is
procedure Init (Ctxt : out Vstring_Ctxt;
Handle : Vstring_Acc;
Sfe : Source_File_Entry;
First_Line : Positive;
Last_Line : Positive) is
begin
Indent_Disp_Ctxt.Init (Indent_Disp_Ctxt.Indent_Ctxt (Ctxt), Sfe,
First_Line, Last_Line);
Ctxt.Hand := Handle;
end Init;
procedure Put (Ctxt : in out Vstring_Ctxt; C : Character) is
begin
Append (Ctxt.Hand.all, C);
end Put;
end Indent_Vstrings_Ctxt;
function Allocate_Handle return Vstring_Acc is
begin
return new Grt.Vstrings.Vstring;
end Allocate_Handle;
function Get_Length (Handle : Vstring_Acc) return Natural is
begin
return Grt.Vstrings.Length (Handle.all);
end Get_Length;
function Get_C_String (Handle : Vstring_Acc)
return Grt.Types.Ghdl_C_String is
begin
return Grt.Vstrings.Get_C_String (Handle.all);
end Get_C_String;
procedure Free_Handle (Handle : Vstring_Acc)
is
procedure Deallocate is new Ada.Unchecked_Deallocation
(Grt.Vstrings.Vstring, Vstring_Acc);
Handle1 : Vstring_Acc;
begin
Grt.Vstrings.Free (Handle.all);
Handle1 := Handle;
Deallocate (Handle1);
end Free_Handle;
procedure Indent_String (F : Iir_Design_File;
Handle : Vstring_Acc;
First_Line : Positive := 1;
Last_Line : Positive := Positive'Last)
is
use Indent_Vstrings_Ctxt;
Sfe : constant Source_File_Entry := Get_Design_File_Source (F);
Ctxt : Vstring_Ctxt;
begin
Init (Ctxt, Handle, Sfe, First_Line, Last_Line);
Prints.Disp_Vhdl (Ctxt, F);
Close_File;
Scanner.Flag_Comment := False;
Scanner.Flag_Newline := False;
end Indent_String;
procedure Indent (F : Iir_Design_File;
First_Line : Positive := 1;
Last_Line : Positive := Positive'Last) is
begin
if False then
-- Display character per character. Slow but useful for debugging.
declare
use Indent_Disp_Ctxt;
Sfe : constant Source_File_Entry := Get_Design_File_Source (F);
Ctxt : Indent_Ctxt;
begin
Init (Ctxt, Sfe, First_Line, Last_Line);
Prints.Disp_Vhdl (Ctxt, F);
end;
else
declare
use Grt.Types;
Handle : Vstring_Acc;
Res : Ghdl_C_String;
Len : Natural;
begin
Handle := Allocate_Handle;
Indent_String (F, Handle, First_Line, Last_Line);
Res := Get_C_String (Handle);
Len := Get_Length (Handle);
Simple_IO.Put (Res (1 .. Len));
Free_Handle (Handle);
end;
end if;
end Indent;
end Vhdl.Formatters;