-- VHDL code formatter.
-- Copyright (C) 2019 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 Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Types; use Types;
with Files_Map;
with Simple_IO;
with Utils_IO;
with Dyn_Tables;
with Flags;
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
if Tok = Current_Token then
return;
end if;
-- There are a couple of exceptions.
-- Range and Subtype are considered as identifiers when used as
-- attributes.
if Tok = Tok_Identifier
and then (Current_Token = Tok_Range
or else Current_Token = Tok_Subtype)
then
return;
end if;
-- 'default clock' are considered as identifiers.
if (Tok = Tok_Default or else Tok = Tok_Psl_Clock)
and then Current_Token = Tok_Identifier
then
return;
end if;
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 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;
First_Line : Positive := 1;
Last_Line : Positive := Positive'Last);
procedure Free (Ctxt : in out Format_Ctxt);
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 Valign (Ctxt : in out Format_Ctxt; Point : Valign_Type);
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);
package Token_Table is new Dyn_Tables
(Table_Component_Type => Uns32,
Table_Index_Type => Natural,
Table_Low_Bound => 1);
function Get_Source_File_Entry (Ctxt : Format_Ctxt)
return Source_File_Entry;
subtype Etoken_Type is Nat32 range 0 .. 2**10 - 1;
subtype Col_Type is Natural range 0 .. 2**16 - 1;
-- Entry in Token_Table for token TOK with column COL.
-- Unfortunately it is not possible to pack records with discriminant
-- with GNAT. So it is done manually.
type Etoken_Record is record
Flag_Token : Boolean;
Flag1 : Boolean;
Flag2 : Boolean;
Flag3 : Boolean;
Flag4 : Boolean;
Flag5 : Boolean;
Tok : Etoken_Type;
Col : Col_Type;
end record;
pragma Pack (Etoken_Record);
for Etoken_Record'Size use 32;
type Evalue_Record is record
Flag_Token : Boolean;
Value : Nat32;
end record;
pragma Pack (Evalue_Record);
for Evalue_Record'Size use 32;
Etok_Last : constant Etoken_Type := Token_Type'Pos (Token_Type'Last);
Etok_Start_Vbox : constant Etoken_Type := Etok_Last + 1;
Etok_Close_Vbox : constant Etoken_Type := Etok_Last + 2;
Etok_Set_Vbox : constant Etoken_Type := Etok_Last + 3;
Etok_No_Indent : constant Etoken_Type := Etok_Last + 4;
Etok_Valign : constant Etoken_Type := Etok_Last + 5;
procedure Append_Eof (Ctxt : in out Format_Ctxt);
procedure Read_Token (Ctxt : Format_Ctxt;
Idx : Natural;
Tok : out Etoken_Type;
Col : out Natural);
procedure Write_Token (Ctxt : Format_Ctxt;
Idx : Natural;
Col : Natural);
-- Token_Source_Type are followed in the stream by two values:
-- the length of the token (number of characters)
-- the position in the sources
-- With these two values, it is possible to print the tokens.
function Read_Value (Ctxt : Format_Ctxt; Idx : Natural) return Nat32;
type Printer_Ctxt is abstract tagged null record;
procedure Put (Ctxt : in out Printer_Ctxt; C : Character) is abstract;
private
type Format_Ctxt is new Disp_Ctxt with record
First_Line : Natural;
Last_Line : Natural;
Lineno : Natural;
Enable : Boolean;
Flag_Lit : Boolean;
Vnum : Natural;
Hnum : Natural;
Hfirst : Boolean;
Sfe : Source_File_Entry;
Toks : Token_Table.Instance;
end record;
end Format_Disp_Ctxt;
package body Format_Disp_Ctxt is
function To_Etoken_Record is new Ada.Unchecked_Conversion
(Uns32, Etoken_Record);
function To_Uns32 is new Ada.Unchecked_Conversion
(Etoken_Record, Uns32);
function To_Evalue_Record is new Ada.Unchecked_Conversion
(Uns32, Evalue_Record);
function To_Uns32 is new Ada.Unchecked_Conversion
(Evalue_Record, Uns32);
procedure Read_Token (Ctxt : Format_Ctxt;
Idx : Natural;
Tok : out Etoken_Type;
Col : out Natural)
is
Etok : Etoken_Record;
begin
Etok := To_Etoken_Record (Ctxt.Toks.Table (Idx));
pragma Assert (Etok.Flag_Token);
Tok := Etok.Tok;
Col := Etok.Col;
end Read_Token;
procedure Write_Token (Ctxt : Format_Ctxt;
Idx : Natural;
Col : Natural)
is
Etok : Etoken_Record;
begin
Etok := To_Etoken_Record (Ctxt.Toks.Table (Idx));
pragma Assert (Etok.Flag_Token);
Etok.Col := Col;
Ctxt.Toks.Table (Idx) := To_Uns32 (Etok);
end Write_Token;
function Read_Value (Ctxt : Format_Ctxt; Idx : Natural) return Nat32
is
V : Evalue_Record;
begin
V := To_Evalue_Record (Ctxt.Toks.Table (Idx));
pragma Assert (not V.Flag_Token);
return V.Value;
end Read_Value;
procedure Append_Token (Ctxt : in out Format_Ctxt;
Tok : Etoken_Type;
Col : Natural)
is
Etok : Etoken_Record;
begin
Etok := (Flag_Token => True,
Tok => Tok,
Col => Col,
others => False);
Token_Table.Append (Ctxt.Toks, To_Uns32 (Etok));
end Append_Token;
procedure Append_Token (Ctxt : in out Format_Ctxt; Tok : Token_Type) is
begin
Append_Token (Ctxt, Token_Type'Pos (Tok), Get_Token_Offset + 1);
end Append_Token;
procedure Append_Value (Ctxt : in out Format_Ctxt;
Val : Nat32)
is
V : Evalue_Record;
begin
V := (Flag_Token => False,
Value => Val);
Token_Table.Append (Ctxt.Toks, To_Uns32 (V));
end Append_Value;
procedure Append_Source_Token (Ctxt : in out Format_Ctxt;
Tok : Token_Type) is
begin
Append_Token (Ctxt, Token_Type'Pos (Tok), Get_Token_Offset + 1);
Append_Value (Ctxt, Get_Token_Length);
Append_Value (Ctxt, Nat32 (Get_Token_Position));
end Append_Source_Token;
procedure Append_Eof (Ctxt : in out Format_Ctxt) is
begin
Append_Token (Ctxt, Token_Type'Pos (Tok_Eof), 0);
end Append_Eof;
procedure Init (Ctxt : out Format_Ctxt;
Sfe : Source_File_Entry;
First_Line : Positive := 1;
Last_Line : Positive := Positive'Last) is
begin
Ctxt := (First_Line => First_Line,
Last_Line => Last_Line,
Lineno => 1,
Enable => First_Line = 1,
Flag_Lit => False,
Vnum => 0,
Hnum => 0,
Hfirst => True,
Sfe => Sfe,
Toks => <>);
Token_Table.Init (Ctxt.Toks, 1024);
if First_Line = 1 then
Append_Token (Ctxt, Etok_No_Indent, 0);
end if;
end Init;
procedure Free (Ctxt : in out Format_Ctxt) is
begin
Token_Table.Free (Ctxt.Toks);
end Free;
function Get_Source_File_Entry (Ctxt : Format_Ctxt)
return Source_File_Entry is
begin
return Ctxt.Sfe;
end Get_Source_File_Entry;
procedure Skip_Newline (Ctxt : in out Format_Ctxt) is
begin
Ctxt.Lineno := Ctxt.Lineno + 1;
if Ctxt.Enable then
Append_Token (Ctxt, Token_Type'Pos (Tok_Newline), 0);
if Ctxt.Last_Line < Ctxt.Lineno then
Ctxt.Enable := False;
end if;
else
if Ctxt.First_Line = Ctxt.Lineno then
Ctxt.Enable := True;
Append_Token (Ctxt, Etok_Set_Vbox, Ctxt.Vnum);
if Ctxt.Hfirst then
Append_Token (Ctxt, Etok_No_Indent, 0);
end if;
end if;
end if;
end Skip_Newline;
procedure Skip_Spaces (Ctxt : in out Format_Ctxt) is
begin
loop
case Current_Token is
when Tok_Eof =>
raise Internal_Error;
when Tok_Newline =>
Skip_Newline (Ctxt);
Scan;
when Tok_Line_Comment =>
if Ctxt.Enable then
Append_Source_Token (Ctxt, Current_Token);
end if;
Scan;
when Tok_Block_Comment_Start =>
if Ctxt.Enable then
Append_Token (Ctxt, Tok_Block_Comment_Start);
end if;
loop
Scan_Block_Comment;
case Current_Token is
when Tok_Eof =>
exit;
when Tok_Block_Comment_Text =>
if Ctxt.Enable then
Append_Source_Token (Ctxt, Current_Token);
end if;
when Tok_Block_Comment_End =>
if Ctxt.Enable then
Append_Token (Ctxt, Tok_Block_Comment_End);
end if;
exit;
when Tok_Newline =>
Skip_Newline (Ctxt);
when others =>
raise Internal_Error;
end case;
end loop;
Scan;
when others =>
exit;
end case;
end loop;
end Skip_Spaces;
procedure Valign (Ctxt : in out Format_Ctxt; Point : Valign_Type) is
begin
if Ctxt.Enable then
Append_Token (Ctxt, Etok_Valign, Valign_Type'Pos (Point));
end if;
end Valign;
procedure Start_Hbox (Ctxt : in out Format_Ctxt) is
begin
Ctxt.Hnum := Ctxt.Hnum + 1;
if Ctxt.Hnum = 1 then
Ctxt.Hfirst := True;
end if;
end Start_Hbox;
procedure Close_Hbox (Ctxt : in out Format_Ctxt) is
begin
if Ctxt.Enable and Ctxt.Hnum = 1 then
Append_Token (Ctxt, Etok_No_Indent, 0);
end if;
Ctxt.Hnum := Ctxt.Hnum - 1;
end Close_Hbox;
procedure Start_Vbox (Ctxt : in out Format_Ctxt) is
begin
pragma Assert (Ctxt.Hnum = 0);
Ctxt.Vnum := Ctxt.Vnum + 1;
if Ctxt.Enable then
Append_Token (Ctxt, Etok_Start_Vbox, Ctxt.Vnum);
end if;
end Start_Vbox;
procedure Close_Vbox (Ctxt : in out Format_Ctxt) is
begin
Skip_Spaces (Ctxt);
Ctxt.Vnum := Ctxt.Vnum - 1;
if Ctxt.Enable then
Append_Token (Ctxt, Etok_Close_Vbox, Ctxt.Vnum);
end if;
end Close_Vbox;
procedure Disp_Token (Ctxt : in out Format_Ctxt; Tok : Token_Type) is
begin
Skip_Spaces (Ctxt);
if Ctxt.Enable then
Append_Token (Ctxt, Tok);
end if;
Ctxt.Hfirst := False;
Check_Token (Tok);
Scan;
end Disp_Token;
procedure Start_Lit (Ctxt : in out Format_Ctxt; Tok : Token_Type) is
begin
pragma Assert (not Ctxt.Flag_Lit);
Ctxt.Flag_Lit := True;
Skip_Spaces (Ctxt);
-- For bit string with length (vhdl08), first store the length.
if Tok = Tok_Bit_String
and then Current_Token = Tok_Integer_Letter
then
if Ctxt.Enable then
Append_Source_Token (Ctxt, Tok_Integer_Letter);
end if;
Scan;
end if;
if Ctxt.Enable then
Append_Source_Token (Ctxt, Tok);
end if;
Ctxt.Hfirst := False;
Check_Token (Tok);
Scan;
end Start_Lit;
procedure Disp_Char (Ctxt : in out Format_Ctxt; C : Character)
is
pragma Unreferenced (C);
begin
pragma Assert (Ctxt.Flag_Lit);
null;
end Disp_Char;
procedure Close_Lit (Ctxt : in out Format_Ctxt) is
begin
pragma Assert (Ctxt.Flag_Lit);
Ctxt.Flag_Lit := False;
end Close_Lit;
end Format_Disp_Ctxt;
procedure Reindent (Ctxt : Format_Disp_Ctxt.Format_Ctxt;
Respace : Boolean := False)
is
use Format_Disp_Ctxt;
-- Number of spaces for indentation.
Indentation : constant Natural := 2;
I : Natural;
Etok : Etoken_Type;
Tok : Token_Type;
Col : Natural;
-- Previous token. This is used to decide whether a space must be
-- inserted between two tokens.
Prev_Tok : Token_Type;
Cur_Col : Natural;
Diff_Col : Integer;
Indent : Natural;
Extra_Indent : Boolean;
begin
I := Token_Table.First;
Cur_Col := 1;
Indent := 1;
Prev_Tok := Tok_Newline;
Extra_Indent := True;
Diff_Col := 0;
loop
Read_Token (Ctxt, I, Etok, Col);
if Etok <= Etok_Last then
Tok := Token_Type'Val (Etok);
case Tok is
when Tok_Eof =>
exit;
when Tok_Newline =>
Cur_Col := 1;
when Token_Source_Type
| Tok_Block_Comment_Start
| Tok_First_Delimiter .. Token_Type'Last =>
if Cur_Col = 1 then
-- First token of the line, reindent it.
Cur_Col := Indent;
if Extra_Indent then
Cur_Col := Cur_Col + Indentation;
end if;
Diff_Col := Cur_Col - Col;
else
if Respace then
-- Just adjust position.
if Need_Space (Tok, Prev_Tok) then
Cur_Col := Cur_Col + 1;
end if;
else
Cur_Col := Col + Diff_Col;
end if;
end if;
Write_Token (Ctxt, I, Cur_Col);
if Tok /= Tok_Line_Comment
and then Tok /= Tok_Block_Comment_Start
then
-- If there is a new line in the current hbox, add an
-- extra indentation.
Extra_Indent := True;
end if;
when Tok_Block_Comment_Text
| Tok_Block_Comment_End =>
null;
when Tok_Invalid =>
raise Internal_Error;
end case;
case Tok is
when Tok_Eof
| Tok_Invalid =>
raise Internal_Error;
when Tok_Newline =>
I := I + 1;
when Token_Source_Type
| Tok_Block_Comment_Text =>
if Respace then
-- Increment column by the length of the token
Cur_Col := Cur_Col + Natural (Read_Value (Ctxt, I + 1));
else
-- A token is at least one character.
Cur_Col := Cur_Col + 1;
end if;
I := I + 3;
when Tok_First_Delimiter .. Token_Type'Last
| Tok_Block_Comment_Start
| Tok_Block_Comment_End =>
if Respace then
declare
S : constant String := Image (Tok);
begin
Cur_Col := Cur_Col + S'Length;
end;
else
-- A token is at least one character.
Cur_Col := Cur_Col + 1;
end if;
I := I + 1;
end case;
else
case Etok is
when Etok_Start_Vbox
| Etok_Close_Vbox =>
Indent := Col * Indentation + 1;
Extra_Indent := False;
when Etok_Set_Vbox =>
Indent := Col * Indentation + 1;
when Etok_No_Indent =>
Extra_Indent := False;
when Etok_Valign =>
null;
when others =>
raise Internal_Error;
end case;
I := I + 1;
end if;
Prev_Tok := Tok;
end loop;
end Reindent;
-- Realign some token.
-- For objects declarations of the same region, the colon (:), the subtype
-- indication and the default value will be aligned on the same column.
procedure Realign (Ctxt : in out Format_Disp_Ctxt.Format_Ctxt;
Vbox : in out Natural)
is
use Format_Disp_Ctxt;
type Valign_Natural is array (Valign_Type) of Natural;
type Valign_Boolean is array (Valign_Type) of Boolean;
-- Maximum offset relative to previous alignment.
Vpos : Valign_Natural;
-- True when the realignment was done in the current line. Used to
-- discard same alignment marker that appears later.
Vdone : Valign_Boolean;
I : Natural;
Etok : Etoken_Type;
Tok : Token_Type;
Col : Natural;
Skip : Natural;
Valign : Valign_Type;
Diff_Col : Integer;
Cum_Col : Integer;
Prev_Col : Integer;
begin
I := Vbox;
Vpos := (others => 0);
Vdone := (others => False);
Diff_Col := 0;
Prev_Col := 0;
-- First pass: compute the positions
loop
Read_Token (Ctxt, I, Etok, Col);
if Etok <= Etok_Last then
Tok := Token_Type'Val (Etok);
case Tok is
when Tok_Eof =>
exit;
when Tok_Invalid =>
raise Internal_Error;
when Tok_Newline =>
-- Restart positions.
Vdone := (others => False);
Prev_Col := 0;
I := I + 1;
when Token_Source_Type
| Tok_Block_Comment_Text =>
I := I + 3;
when Tok_First_Delimiter .. Token_Type'Last
| Tok_Block_Comment_Start
| Tok_Block_Comment_End =>
I := I + 1;
end case;
else
case Etok is
when Etok_Start_Vbox =>
-- Nested vbox
I := I + 1;
Realign (Ctxt, I);
when Etok_Close_Vbox =>
exit;
when Etok_Set_Vbox =>
I := I + 1;
when Etok_No_Indent =>
I := I + 1;
when Etok_Valign =>
-- Ok, the serious work.
Valign := Valign_Type'Val (Col);
if not Vdone (Valign) then
-- The first presence on this line.
-- Read position of the next token.
Read_Token (Ctxt, I + 1, Etok, Col);
pragma Assert (Etok <= Etok_Last);
Vdone (Valign) := True;
Diff_Col := Col - Prev_Col;
if Vpos (Valign) < Diff_Col then
Vpos (Valign) := Diff_Col;
end if;
Prev_Col := Col;
end if;
I := I + 1;
when others =>
raise Internal_Error;
end case;
end if;
end loop;
-- Second pass: adjust the offsets
I := Vbox;
Vdone := (others => False);
Diff_Col := 0;
Skip := 0;
Cum_Col := 0;
loop
Read_Token (Ctxt, I, Etok, Col);
if Etok <= Etok_Last then
Tok := Token_Type'Val (Etok);
case Tok is
when Tok_Eof =>
Vbox := I;
exit;
when Tok_Invalid =>
raise Internal_Error;
when Tok_Newline =>
Vdone := (others => False);
Diff_Col := 0;
Cum_Col := 0;
I := I + 1;
when Token_Source_Type
| Tok_Block_Comment_Text =>
if Skip = 0 then
Write_Token (Ctxt, I, Col + Diff_Col);
end if;
I := I + 3;
when Tok_First_Delimiter .. Token_Type'Last
| Tok_Block_Comment_Start
| Tok_Block_Comment_End =>
if Skip = 0 then
Write_Token (Ctxt, I, Col + Diff_Col);
end if;
I := I + 1;
end case;
else
case Etok is
when Etok_Start_Vbox =>
-- Nested vbox
Skip := Skip + 1;
when Etok_Close_Vbox =>
if Skip = 0 then
Vbox := I + 1;
exit;
else
Skip := Skip - 1;
end if;
when Etok_Set_Vbox =>
null;
when Etok_No_Indent =>
null;
when Etok_Valign =>
-- Ok, the serious work.
if Skip = 0 then
Valign := Valign_Type'Val (Col);
if Vpos (Valign) /= 0 and then not Vdone (Valign) then
Vdone (Valign) := True;
Cum_Col := Cum_Col + Vpos (Valign);
Read_Token (Ctxt, I + 1, Etok, Col);
Diff_Col := Cum_Col - Col;
end if;
end if;
when others =>
raise Internal_Error;
end case;
I := I + 1;
end if;
end loop;
end Realign;
procedure Realign (Ctxt : in out Format_Disp_Ctxt.Format_Ctxt)
is
I : Natural;
begin
I := Format_Disp_Ctxt.Token_Table.First;
Realign (Ctxt, I);
end Realign;
type IO_Printer_Ctxt is new Format_Disp_Ctxt.Printer_Ctxt with null record;
procedure Put (Ctxt : in out IO_Printer_Ctxt; C : Character)
is
pragma Unreferenced (Ctxt);
begin
if C = ASCII.LF then
Simple_IO.New_Line;
else
Simple_IO.Put (C);
end if;
end Put;
procedure Reprint (Ctxt : Format_Disp_Ctxt.Format_Ctxt;
Prnt : in out Format_Disp_Ctxt.Printer_Ctxt'Class)
is
use Format_Disp_Ctxt;
Sfe : constant Source_File_Entry := Get_Source_File_Entry (Ctxt);
I : Natural;
Etok : Etoken_Type;
Tok : Token_Type;
Col : Natural;
Cur_Col : Natural;
begin
I := Token_Table.First;
Cur_Col := 1;
loop
Read_Token (Ctxt, I, Etok, Col);
I := I + 1;
if Flags.Verbose then
declare
use Simple_IO;
use Utils_IO;
begin
Put (' ');
if Etok <= Etok_Last then
Put (Image (Token_Type'Val (Etok)));
else
case Etok is
when Etok_Start_Vbox =>
Put ("[");
when Etok_Close_Vbox =>
Put ("]");
when Etok_Set_Vbox =>
Put ("V");
when Etok_No_Indent =>
Put ("B");
when Etok_Valign =>
Put ("A");
when others =>
raise Internal_Error;
end case;
end if;
Put (':');
Put_Int32 (Nat32 (Col));
Put ('@');
Put_Int32 (Nat32 (I - 1));
end;
end if;
while Cur_Col < Col loop
Prnt.Put (' ');
Cur_Col := Cur_Col + 1;
end loop;
if Etok <= Etok_Last then
Tok := Token_Type'Val (Etok);
case Tok is
when Tok_Eof =>
exit;
when Tok_Newline =>
Prnt.Put (ASCII.LF);
Cur_Col := 1;
when Token_Source_Type
| Tok_Block_Comment_Text =>
declare
Buf : constant File_Buffer_Acc :=
Files_Map.Get_File_Source (Sfe);
Len : Nat32;
Pos : Source_Ptr;
begin
Len := Read_Value (Ctxt, I);
Pos := Source_Ptr (Read_Value (Ctxt, I + 1));
for K in 0 .. Len - 1 loop
Prnt.Put (Buf (Pos + Source_Ptr (K)));
end loop;
Cur_Col := Cur_Col + Natural (Len);
I := I + 2;
end;
when Tok_First_Delimiter .. Token_Type'Last
| Tok_Block_Comment_Start
| Tok_Block_Comment_End =>
declare
S : constant String := Image (Tok);
begin
for I in S'Range loop
Prnt.Put (S (I));
end loop;
Cur_Col := Cur_Col + S'Length;
end;
when Tok_Invalid =>
null;
end case;
end if;
end loop;
end Reprint;
procedure Format_Init (F : Iir_Design_File;
First_Line : Positive := 1;
Last_Line : Positive := Positive'Last;
Ctxt : out Format_Disp_Ctxt.Format_Ctxt)
is
use Format_Disp_Ctxt;
Sfe : constant Source_File_Entry := Get_Design_File_Source (F);
begin
Scanner.Flag_Comment := True;
Scanner.Flag_Newline := True;
Set_File (Sfe);
Scan;
Init (Ctxt, Sfe, First_Line, Last_Line);
Prints.Disp_Vhdl (Ctxt, F);
Close_File;
Scanner.Flag_Comment := False;
Scanner.Flag_Newline := False;
Append_Eof (Ctxt);
end Format_Init;
procedure Format (F : Iir_Design_File;
Level : Format_Level;
Flag_Realign : Boolean;
First_Line : Positive := 1;
Last_Line : Positive := Positive'Last)
is
use Format_Disp_Ctxt;
Ctxt : Format_Ctxt;
Prnt : IO_Printer_Ctxt;
begin
Format_Init (F, First_Line, Last_Line, Ctxt);
if Level > Format_None then
Reindent (Ctxt, Level = Format_Space);
end if;
if Flag_Realign then
Realign (Ctxt);
end if;
Reprint (Ctxt, Prnt);
Free (Ctxt);
end Format;
procedure Dump_Fmt (Ctxt : Format_Disp_Ctxt.Format_Ctxt)
is
Prnt : IO_Printer_Ctxt;
begin
Reprint (Ctxt, Prnt);
end Dump_Fmt;
pragma Unreferenced (Dump_Fmt);
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;
type Vstring_Printer_Ctxt is new Format_Disp_Ctxt.Printer_Ctxt with record
Handle : Vstring_Acc;
end record;
procedure Put (Ctxt : in out Vstring_Printer_Ctxt; C : Character) is
begin
Grt.Vstrings.Append (Ctxt.Handle.all, C);
end Put;
procedure Indent_String (F : Iir_Design_File;
Handle : Vstring_Acc;
First_Line : Positive := 1;
Last_Line : Positive := Positive'Last)
is
use Format_Disp_Ctxt;
Ctxt : Format_Ctxt;
Prnt : Vstring_Printer_Ctxt;
begin
Format_Init (F, First_Line, Last_Line, Ctxt);
Prnt := (Format_Disp_Ctxt.Printer_Ctxt with Handle);
Reindent (Ctxt, False);
Realign (Ctxt);
Reprint (Ctxt, Prnt);
Free (Ctxt);
end Indent_String;
end Vhdl.Formatters;