1--  GHDL Run Time (GRT) - Tree displayer.
2--  Copyright (C) 2002 - 2014 Tristan Gingold
3--
4--  This program is free software: you can redistribute it and/or modify
5--  it under the terms of the GNU General Public License as published by
6--  the Free Software Foundation, either version 2 of the License, or
7--  (at your option) any later version.
8--
9--  This program is distributed in the hope that it will be useful,
10--  but WITHOUT ANY WARRANTY; without even the implied warranty of
11--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12--  GNU General Public License for more details.
13--
14--  You should have received a copy of the GNU General Public License
15--  along with this program.  If not, see <gnu.org/licenses>.
16--
17--  As a special exception, if other files instantiate generics from this
18--  unit, or you link this unit with other files to produce an executable,
19--  this unit does not by itself cause the resulting executable to be
20--  covered by the GNU General Public License. This exception does not
21--  however invalidate any other reasons why the executable file might be
22--  covered by the GNU Public License.
23with System; use System;
24with Grt.Disp_Rti; use Grt.Disp_Rti;
25with Grt.Rtis; use Grt.Rtis;
26with Grt.Stdio; use Grt.Stdio;
27with Grt.Astdio; use Grt.Astdio;
28with Grt.Types; use Grt.Types;
29with Grt.Errors; use Grt.Errors;
30with Grt.Rtis_Addr; use Grt.Rtis_Addr;
31with Grt.Hooks; use Grt.Hooks;
32
33package body Grt.Disp_Tree is
34   --  Set by --disp-tree, to display the design hierarchy.
35   type Disp_Tree_Kind is
36     (
37      Disp_Tree_None,  --  Do not disp tree.
38      Disp_Tree_Inst,  --  Disp entities, arch, package, blocks, components.
39      Disp_Tree_Proc,  --  As above plus processes
40      Disp_Tree_Port   --  As above plus ports and signals.
41     );
42   Disp_Tree_Flag : Disp_Tree_Kind := Disp_Tree_None;
43
44
45   --  Get next interesting child.
46   procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc;
47                             Index : in out Ghdl_Index_Type;
48                             Child : out Ghdl_Rti_Access)
49   is
50   begin
51      --  Exit if no more children.
52      while Index < Parent.Nbr_Child loop
53         Child := Parent.Children (Index);
54         Index := Index + 1;
55         case Child.Kind is
56            when Ghdl_Rtik_Package
57              | Ghdl_Rtik_Entity
58              | Ghdl_Rtik_Architecture
59              | Ghdl_Rtik_Block
60              | Ghdl_Rtik_For_Generate
61              | Ghdl_Rtik_If_Generate
62              | Ghdl_Rtik_Case_Generate
63              | Ghdl_Rtik_Instance =>
64               return;
65            when Ghdl_Rtik_Signal
66              | Ghdl_Rtik_Port
67              | Ghdl_Rtik_Guard =>
68               if Disp_Tree_Flag >= Disp_Tree_Port then
69                  return;
70               end if;
71            when Ghdl_Rtik_Process =>
72               if Disp_Tree_Flag >= Disp_Tree_Proc then
73                  return;
74               end if;
75            when others =>
76               null;
77         end case;
78      end loop;
79      Child := null;
80   end Get_Tree_Child;
81
82   procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context)
83   is
84   begin
85      case Rti.Kind is
86         when Ghdl_Rtik_Entity
87           | Ghdl_Rtik_Process
88           | Ghdl_Rtik_Architecture
89           | Ghdl_Rtik_Block
90           | Ghdl_Rtik_If_Generate
91           | Ghdl_Rtik_Case_Generate =>
92            declare
93               Blk : constant Ghdl_Rtin_Block_Acc :=
94                 To_Ghdl_Rtin_Block_Acc (Rti);
95            begin
96               Disp_Name (Blk.Name);
97            end;
98         when Ghdl_Rtik_Package_Body
99           | Ghdl_Rtik_Package =>
100            declare
101               Blk : Ghdl_Rtin_Block_Acc;
102               Lib : Ghdl_Rtin_Type_Scalar_Acc;
103            begin
104               Blk := To_Ghdl_Rtin_Block_Acc (Rti);
105               if Rti.Kind = Ghdl_Rtik_Package_Body then
106                  Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent);
107               end if;
108               Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent);
109               Disp_Name (Lib.Name);
110               Put ('.');
111               Disp_Name (Blk.Name);
112            end;
113         when Ghdl_Rtik_For_Generate =>
114            declare
115               Gen : constant Ghdl_Rtin_Generate_Acc :=
116                 To_Ghdl_Rtin_Generate_Acc (Rti);
117               Bod : constant Ghdl_Rtin_Block_Acc :=
118                 To_Ghdl_Rtin_Block_Acc (Gen.Child);
119               Iter : constant Ghdl_Rtin_Object_Acc :=
120                 To_Ghdl_Rtin_Object_Acc (Bod.Children (0));
121               Addr, Bounds : Address;
122            begin
123               Disp_Name (Gen.Name);
124               Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt);
125               Bounds := Null_Address;
126               Put ('(');
127               Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, Bounds, False);
128               Put (')');
129            end;
130         when Ghdl_Rtik_Signal
131           | Ghdl_Rtik_Port
132           | Ghdl_Rtik_Guard
133           | Ghdl_Rtik_Iterator =>
134            Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name);
135         when Ghdl_Rtik_Instance =>
136            Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name);
137         when others =>
138            null;
139      end case;
140
141      case Rti.Kind is
142         when Ghdl_Rtik_Package
143           | Ghdl_Rtik_Package_Body =>
144            Put (" [package]");
145         when Ghdl_Rtik_Entity =>
146            Put (" [entity]");
147         when Ghdl_Rtik_Architecture =>
148            Put (" [arch]");
149         when Ghdl_Rtik_Process =>
150            Put (" [process]");
151         when Ghdl_Rtik_Block =>
152            Put (" [block]");
153         when Ghdl_Rtik_For_Generate =>
154            Put (" [for-generate]");
155         when Ghdl_Rtik_If_Generate =>
156            Put (" [if-generate ");
157            if Ctxt.Base = Null_Address then
158               Put ("false");
159            else
160               Put ("true");
161            end if;
162            Put ("]");
163         when Ghdl_Rtik_Case_Generate =>
164            Put (" [case-generate]");
165         when Ghdl_Rtik_Signal =>
166            Put (" [signal]");
167         when Ghdl_Rtik_Port =>
168            Put (" [port ");
169            case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is
170               when Ghdl_Rti_Signal_Mode_In =>
171                  Put ("in");
172               when Ghdl_Rti_Signal_Mode_Out =>
173                  Put ("out");
174               when Ghdl_Rti_Signal_Mode_Inout =>
175                  Put ("inout");
176               when Ghdl_Rti_Signal_Mode_Buffer =>
177                  Put ("buffer");
178               when Ghdl_Rti_Signal_Mode_Linkage =>
179                  Put ("linkage");
180               when others =>
181                  Put ("?");
182            end case;
183            Put ("]");
184         when Ghdl_Rtik_Guard =>
185            Put (" [guard]");
186         when Ghdl_Rtik_Iterator =>
187            Put (" [iterator]");
188         when Ghdl_Rtik_Instance =>
189            Put (" [instance]");
190         when others =>
191            null;
192      end case;
193   end Disp_Tree_Child;
194
195   procedure Disp_Tree_Block
196     (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String);
197
198   procedure Disp_Tree_Block1
199     (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
200   is
201      Child : Ghdl_Rti_Access;
202      Child2 : Ghdl_Rti_Access;
203      Index : Ghdl_Index_Type;
204
205      procedure Disp_Header (Nctxt : Rti_Context;
206                             Force_Cont : Boolean := False)
207      is
208      begin
209         Put (Pfx);
210
211         if Blk.Common.Kind /= Ghdl_Rtik_Entity
212           and Child2 = null
213           and Force_Cont = False
214         then
215            Put ("`-");
216         else
217            Put ("+-");
218         end if;
219
220         Disp_Tree_Child (Child, Nctxt);
221         New_Line;
222      end Disp_Header;
223
224      procedure Disp_Sub_Block
225        (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context)
226      is
227         Npfx : String (1 .. Pfx'Length + 2);
228      begin
229         Npfx (1 .. Pfx'Length) := Pfx;
230         Npfx (Pfx'Length + 2) := ' ';
231         if Child2 = null then
232            Npfx (Pfx'Length + 1) := ' ';
233         else
234            Npfx (Pfx'Length + 1) := '|';
235         end if;
236         Disp_Tree_Block (Sub_Blk, Nctxt, Npfx);
237      end Disp_Sub_Block;
238
239   begin
240      Index := 0;
241      Get_Tree_Child (Blk, Index, Child);
242      while Child /= null loop
243         Get_Tree_Child (Blk, Index, Child2);
244
245         case Child.Kind is
246            when Ghdl_Rtik_Process
247              | Ghdl_Rtik_Block =>
248               declare
249                  Nblk : constant Ghdl_Rtin_Block_Acc :=
250                    To_Ghdl_Rtin_Block_Acc (Child);
251                  Nctxt : Rti_Context;
252               begin
253                  Nctxt := (Base => Ctxt.Base + Nblk.Loc,
254                            Block => Child);
255                  Disp_Header (Nctxt, False);
256                  Disp_Sub_Block (Nblk, Nctxt);
257               end;
258            when Ghdl_Rtik_For_Generate =>
259               declare
260                  Gen : constant Ghdl_Rtin_Generate_Acc :=
261                    To_Ghdl_Rtin_Generate_Acc (Child);
262                  Nctxt : Rti_Context;
263                  Length : Ghdl_Index_Type;
264                  Old_Child2 : Ghdl_Rti_Access;
265               begin
266                  Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all,
267                            Block => Gen.Child);
268                  Length := Get_For_Generate_Length (Gen, Ctxt);
269                  Disp_Header (Nctxt, Length > 1);
270                  Old_Child2 := Child2;
271                  if Length > 1 then
272                     Child2 := Child;
273                  end if;
274                  for I in 1 .. Length loop
275                     Disp_Sub_Block
276                       (To_Ghdl_Rtin_Block_Acc (Gen.Child), Nctxt);
277                     if I /= Length then
278                        Nctxt.Base := Nctxt.Base + Gen.Size;
279                        if I = Length - 1 then
280                           Child2 := Old_Child2;
281                        end if;
282                        Disp_Header (Nctxt);
283                     end if;
284                  end loop;
285                  Child2 := Old_Child2;
286               end;
287            when Ghdl_Rtik_If_Generate
288              | Ghdl_Rtik_Case_Generate =>
289               declare
290                  Nctxt : constant Rti_Context :=
291                    Get_If_Case_Generate_Child (Ctxt, Child);
292               begin
293                  Disp_Header (Nctxt);
294                  if Nctxt.Base /= Null_Address then
295                     Disp_Sub_Block
296                       (To_Ghdl_Rtin_Block_Acc (Nctxt.Block), Nctxt);
297                  end if;
298               end;
299            when Ghdl_Rtik_Instance =>
300               declare
301                  Inst : Ghdl_Rtin_Instance_Acc;
302                  Sub_Ctxt : Rti_Context;
303                  Sub_Blk : Ghdl_Rtin_Block_Acc;
304                  Npfx : String (1 .. Pfx'Length + 4);
305                  Comp : Ghdl_Rtin_Component_Acc;
306                  Ch : Ghdl_Rti_Access;
307               begin
308                  Disp_Header (Ctxt);
309                  Inst := To_Ghdl_Rtin_Instance_Acc (Child);
310                  Get_Instance_Context (Inst, Ctxt, Sub_Ctxt);
311                  Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block);
312                  if Inst.Instance.Kind = Ghdl_Rtik_Component
313                    and then Disp_Tree_Flag >= Disp_Tree_Port
314                  then
315                     --  Disp generics and ports of the component.
316                     Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance);
317                     for I in 1 .. Comp.Nbr_Child loop
318                        Ch := Comp.Children (I - 1);
319                        if Ch.Kind = Ghdl_Rtik_Port then
320                           --  Disp only port (and not generics).
321                           Put (Pfx);
322                           if Child2 = null then
323                              Put ("  ");
324                           else
325                              Put ("| ");
326                           end if;
327                           if I = Comp.Nbr_Child and then Sub_Blk = null then
328                              Put ("`-");
329                           else
330                              Put ("+-");
331                           end if;
332                           Disp_Tree_Child (Ch, Sub_Ctxt);
333                           New_Line;
334                        end if;
335                     end loop;
336                  end if;
337                  if Sub_Blk /= null then
338                     Npfx (1 .. Pfx'Length) := Pfx;
339                     if Child2 = null then
340                        Npfx (Pfx'Length + 1) := ' ';
341                     else
342                        Npfx (Pfx'Length + 1) := '|';
343                     end if;
344                     Npfx (Pfx'Length + 2) := ' ';
345                     Npfx (Pfx'Length + 3) := '`';
346                     Npfx (Pfx'Length + 4) := '-';
347                     Put (Npfx);
348                     Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt);
349                     New_Line;
350                     Npfx (Pfx'Length + 3) := ' ';
351                     Npfx (Pfx'Length + 4) := ' ';
352                     Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx);
353                  end if;
354               end;
355            when others =>
356               Disp_Header (Ctxt);
357         end case;
358
359         Child := Child2;
360      end loop;
361   end Disp_Tree_Block1;
362
363   procedure Disp_Tree_Block
364     (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String)
365   is
366   begin
367      case Blk.Common.Kind is
368         when Ghdl_Rtik_Architecture =>
369            declare
370               Npfx : String (1 .. Pfx'Length + 2);
371               Nctxt : Rti_Context;
372            begin
373               --  The entity.
374               Nctxt := (Base => Ctxt.Base,
375                         Block => Blk.Parent);
376               Disp_Tree_Block1
377                 (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx);
378               --  Then the architecture.
379               Put (Pfx);
380               Put ("`-");
381               Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt);
382               New_Line;
383               Npfx (1 .. Pfx'Length) := Pfx;
384               Npfx (Pfx'Length + 1) := ' ';
385               Npfx (Pfx'Length + 2) := ' ';
386               Disp_Tree_Block1 (Blk, Ctxt, Npfx);
387            end;
388         when Ghdl_Rtik_Package_Body =>
389            Disp_Tree_Block1
390              (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx);
391         when others =>
392            Disp_Tree_Block1 (Blk, Ctxt, Pfx);
393      end case;
394   end Disp_Tree_Block;
395
396   procedure Disp_Hierarchy
397   is
398      Ctxt : Rti_Context;
399      Parent : Ghdl_Rtin_Block_Acc;
400      Child : Ghdl_Rti_Access;
401   begin
402      if Disp_Tree_Flag = Disp_Tree_None then
403         return;
404      end if;
405
406      Ctxt := Get_Top_Context;
407      Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
408
409      Disp_Tree_Child (Parent.Parent, Ctxt);
410      New_Line;
411      Disp_Tree_Block (Parent, Ctxt, "");
412
413      for I in 1 .. Ghdl_Rti_Top.Nbr_Child loop
414         Child := Ghdl_Rti_Top.Children (I - 1);
415         Ctxt := (Base => Null_Address,
416                  Block => Child);
417         Disp_Tree_Child (Child, Ctxt);
418         New_Line;
419         Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, "");
420      end loop;
421   end Disp_Hierarchy;
422
423   function Disp_Tree_Option (Option : String) return Boolean
424   is
425      Opt : constant String (1 .. Option'Length) := Option;
426   begin
427      if Opt'Length >= 11 and then Opt (1 .. 11) = "--disp-tree" then
428         if Opt'Length = 11 then
429            Disp_Tree_Flag := Disp_Tree_Port;
430         elsif Opt (12 .. Opt'Last) = "=port" then
431            Disp_Tree_Flag := Disp_Tree_Port;
432         elsif Opt (12 .. Opt'Last) = "=proc" then
433            Disp_Tree_Flag := Disp_Tree_Proc;
434         elsif Opt (12 .. Opt'Last) = "=inst" then
435            Disp_Tree_Flag := Disp_Tree_Inst;
436         elsif Opt (12 .. Opt'Last) = "=none" then
437            Disp_Tree_Flag := Disp_Tree_None;
438         else
439            Error ("bad argument for --disp-tree option, try --help");
440         end if;
441         return True;
442      else
443         return False;
444      end if;
445   end Disp_Tree_Option;
446
447   procedure Disp_Tree_Help
448   is
449      procedure P (Str : String) renames Put_Line;
450   begin
451      P (" --disp-tree[=KIND] disp the design hierarchy after elaboration");
452      P ("       KIND is inst, proc, port (default)");
453   end Disp_Tree_Help;
454
455   Disp_Tree_Hooks : aliased constant Hooks_Type :=
456     (Desc => new String'
457        ("disp-tree: display design hierarchy (--disp-tree)"),
458      Option => Disp_Tree_Option'Access,
459      Help => Disp_Tree_Help'Access,
460      Init => null,
461      Start => Disp_Hierarchy'Access,
462      Finish => null);
463
464   procedure Register is
465   begin
466      Register_Hooks (Disp_Tree_Hooks'Access);
467   end Register;
468
469end Grt.Disp_Tree;
470