aboutsummaryrefslogtreecommitdiffstats
path: root/src/vhdl/vhdl-formatters.adb
blob: 03c72dbaa98288a72012bce85158fb99d46e03e6 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
--  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);
      Prev_Flag_Gather_Comments : constant Boolean :=
        Flags.Flag_Gather_Comments;
   begin
      Scanner.Flag_Comment := True;
      Scanner.Flag_Newline := True;
      Flags.Flag_Gather_Comments := False;

      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;
      Flags.Flag_Gather_Comments := Prev_Flag_Gather_Comments;

      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;