1--  PSL - Printer
2--  Copyright (C) 2002-2016 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
17with Types; use Types;
18with PSL.Errors; use PSL.Errors;
19with PSL.Prints;
20with Ada.Text_IO; use Ada.Text_IO;
21with Name_Table; use Name_Table;
22
23package body PSL.Tprint is
24   procedure Disp_Expr (N : Node) is
25   begin
26      case Get_Kind (N) is
27         when N_Number =>
28            declare
29               Str : constant String := Uns32'Image (Get_Value (N));
30            begin
31               Put (Str (2 .. Str'Last));
32            end;
33         when others =>
34            Error_Kind ("disp_expr", N);
35      end case;
36   end Disp_Expr;
37
38   procedure Disp_Count (N : Node) is
39      B : Node;
40   begin
41      B := Get_Low_Bound (N);
42      if B = Null_Node then
43         return;
44      end if;
45      Disp_Expr (B);
46      B := Get_High_Bound (N);
47      if B = Null_Node then
48         return;
49      end if;
50      Put (":");
51      Disp_Expr (B);
52   end Disp_Count;
53
54   procedure Put_Node (Prefix : String; Name : String) is
55   begin
56      Put (Prefix);
57      Put ("-+ ");
58      Put (Name);
59   end Put_Node;
60
61   procedure Put_Node_Line (Prefix : String; Name : String) is
62   begin
63      Put_Node (Prefix, Name);
64      New_Line;
65   end Put_Node_Line;
66
67   function Down (Str : String) return String is
68      L : constant Natural := Str'Last;
69   begin
70      if Str (L) = '\' then
71         return Str (Str'First .. L - 1) & "  \";
72      elsif Str (L) = '/' then
73         return Str (Str'First .. L - 1) & "| \";
74      else
75         raise Program_Error;
76      end if;
77   end Down;
78
79   function Up (Str : String) return String is
80      L : constant Natural := Str'Last;
81   begin
82      if Str (L) = '/' then
83         return Str (Str'First .. L - 1) & "  /";
84      elsif Str (L) = '\' then
85         return Str (Str'First .. L - 1) & "| /";
86      else
87         raise Program_Error;
88      end if;
89   end Up;
90
91   procedure Disp_Repeat_Sequence (Prefix : String; Name : String; N : Node) is
92      S : Node;
93   begin
94      Put_Node (Prefix, Name);
95      Disp_Count (N);
96      Put_Line ("]");
97      S := Get_Sequence (N);
98      if S /= Null_Node then
99         Disp_Property (Down (Prefix), S);
100      end if;
101   end Disp_Repeat_Sequence;
102
103   procedure Disp_Binary_Sequence (Prefix : String; Name : String; N : Node) is
104   begin
105      Disp_Property (Up (Prefix), Get_Left (N));
106      Put_Node_Line (Prefix, Name);
107      Disp_Property (Down (Prefix), Get_Right (N));
108   end Disp_Binary_Sequence;
109
110   procedure Disp_Range_Property (Prefix : String; Name : String; N : Node) is
111   begin
112      Put_Node (Prefix, Name);
113      Put ("[");
114      Disp_Count (N);
115      Put_Line ("]");
116      Disp_Property (Down (Prefix), Get_Property (N));
117   end Disp_Range_Property;
118
119   procedure Disp_Boolean_Range_Property (Prefix : String;
120                                          Name : String; N : Node) is
121   begin
122      Disp_Property (Up (Prefix), Get_Boolean (N));
123      Put_Node (Prefix, Name);
124      Put ("[");
125      Disp_Count (N);
126      Put_Line ("]");
127      Disp_Property (Down (Prefix), Get_Property (N));
128   end Disp_Boolean_Range_Property;
129
130   procedure Disp_Property (Prefix : String; Prop : Node) is
131   begin
132      case Get_Kind (Prop) is
133         when N_Never =>
134            Put_Node_Line (Prefix, "never");
135            Disp_Property (Down (Prefix), Get_Property (Prop));
136         when N_Always =>
137            Put_Node_Line (Prefix, "always");
138            Disp_Property (Down (Prefix), Get_Property (Prop));
139         when N_Eventually =>
140            Put_Node_Line (Prefix, "eventually!");
141            Disp_Property (Down (Prefix), Get_Property (Prop));
142         when N_Next =>
143            Put_Node_Line (Prefix, "next");
144--              if Get_Strong_Flag (Prop) then
145--                 Put ('!');
146--              end if;
147            Disp_Property (Down (Prefix), Get_Property (Prop));
148         when N_Next_A =>
149            Disp_Range_Property (Prefix, "next_a", Prop);
150         when N_Next_E =>
151            Disp_Range_Property (Prefix, "next_e", Prop);
152         when N_Next_Event =>
153            Disp_Property (Up (Prefix), Get_Boolean (Prop));
154            Put_Node_Line (Prefix, "next_event");
155            Disp_Property (Down (Prefix), Get_Property (Prop));
156         when N_Next_Event_A =>
157            Disp_Boolean_Range_Property (Prefix, "next_event_a", Prop);
158         when N_Next_Event_E =>
159            Disp_Boolean_Range_Property (Prefix, "next_event_e", Prop);
160         when N_Braced_SERE =>
161            Put_Node_Line (Prefix, "{} (braced_SERE)");
162            Disp_Property (Down (Prefix), Get_SERE (Prop));
163         when N_Concat_SERE =>
164            Disp_Binary_Sequence (Prefix, "; (concat)", Prop);
165         when N_Fusion_SERE =>
166            Disp_Binary_Sequence (Prefix, ": (fusion)", Prop);
167         when N_Within_SERE =>
168            Disp_Binary_Sequence (Prefix, "within", Prop);
169         when N_Match_And_Seq =>
170            Disp_Binary_Sequence (Prefix, "&& (sequence matching len)", Prop);
171         when N_Or_Seq =>
172            Disp_Binary_Sequence (Prefix, "| (sequence or)", Prop);
173         when N_And_Seq =>
174            Disp_Binary_Sequence (Prefix, "& (sequence and)", Prop);
175         when N_Imp_Seq =>
176            Disp_Property (Up (Prefix), Get_Sequence (Prop));
177            Put_Node_Line (Prefix, "|=> (sequence implication)");
178            Disp_Property (Down (Prefix), Get_Property (Prop));
179         when N_Overlap_Imp_Seq =>
180            Disp_Property (Up (Prefix), Get_Sequence (Prop));
181            Put_Node_Line (Prefix, "|->");
182            Disp_Property (Down (Prefix), Get_Property (Prop));
183         when N_Or_Prop =>
184            Disp_Binary_Sequence (Prefix, "|| (property or)", Prop);
185         when N_And_Prop =>
186            Disp_Binary_Sequence (Prefix, "&& (property and)", Prop);
187         when N_Log_Imp_Prop =>
188            Disp_Binary_Sequence (Prefix, "-> (property impliciation)", Prop);
189         when N_Until =>
190            Disp_Binary_Sequence (Prefix, "until", Prop);
191         when N_Before =>
192            Disp_Binary_Sequence (Prefix, "before", Prop);
193         when N_Abort =>
194            Disp_Property (Up (Prefix), Get_Property (Prop));
195            Put_Node_Line (Prefix, "abort");
196            Disp_Property (Down (Prefix), Get_Boolean (Prop));
197         when N_Not_Bool =>
198            Put_Node_Line (Prefix, "! (boolean not)");
199            Disp_Property (Down (Prefix), Get_Boolean (Prop));
200         when N_Or_Bool =>
201            Disp_Binary_Sequence (Prefix, "|| (boolean or)", Prop);
202         when N_And_Bool =>
203            Disp_Binary_Sequence (Prefix, "&& (boolean and)", Prop);
204         when N_Name_Decl =>
205            Put_Node_Line (Prefix,
206                           "Name_Decl: " & Image (Get_Identifier (Prop)));
207         when N_Name =>
208            Put_Node_Line (Prefix, "Name: " & Image (Get_Identifier (Prop)));
209            Disp_Property (Down (Prefix), Get_Decl (Prop));
210         when N_True =>
211            Put_Node_Line (Prefix, "TRUE");
212         when N_False =>
213            Put_Node_Line (Prefix, "FALSE");
214         when N_HDL_Expr =>
215            Put_Node (Prefix, "HDL_Expr: ");
216            PSL.Prints.HDL_Expr_Printer.all (Get_HDL_Node (Prop));
217            New_Line;
218         when N_Star_Repeat_Seq =>
219            Disp_Repeat_Sequence (Prefix, "[*", Prop);
220         when N_Goto_Repeat_Seq =>
221            Disp_Repeat_Sequence (Prefix, "[->", Prop);
222         when N_Equal_Repeat_Seq =>
223            Disp_Repeat_Sequence (Prefix, "[=", Prop);
224         when N_Plus_Repeat_Seq =>
225            Put_Node_Line (Prefix, "[+]");
226            Disp_Property (Down (Prefix), Get_Sequence (Prop));
227         when others =>
228            Error_Kind ("disp_property", Prop);
229      end case;
230   end Disp_Property;
231
232   procedure Disp_Assert (N : Node) is
233      Label : constant Name_Id := Get_Label (N);
234   begin
235      Put ("  ");
236      if Label /= Null_Identifier then
237         Put (Image (Label));
238         Put (": ");
239      end if;
240      Put_Line ("assert ");
241      Disp_Property ("  \", Get_Property (N));
242   end Disp_Assert;
243
244   procedure Disp_Unit (Unit : Node) is
245      Item : Node;
246   begin
247      case Get_Kind (Unit) is
248         when N_Vunit =>
249            Put ("vunit");
250         when others =>
251            Error_Kind ("disp_unit", Unit);
252      end case;
253      Put (' ');
254      Put (Image (Get_Identifier (Unit)));
255      Put_Line (" {");
256      Item := Get_Item_Chain (Unit);
257      while Item /= Null_Node loop
258         case Get_Kind (Item) is
259            when N_Assert_Directive =>
260               Disp_Assert (Item);
261            when N_Name_Decl =>
262               null;
263            when others =>
264               Error_Kind ("disp_unit", Item);
265         end case;
266         Item := Get_Chain (Item);
267      end loop;
268      Put_Line ("}");
269   end Disp_Unit;
270end PSL.Tprint;
271