File : pprint.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- P P R I N T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2008-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Namet; use Namet;
29 with Nlists; use Nlists;
30 with Opt; use Opt;
31 with Sinfo; use Sinfo;
32 with Sinput; use Sinput;
33 with Snames; use Snames;
34 with Uintp; use Uintp;
35
36 package body Pprint is
37
38 List_Name_Count : Integer := 0;
39 -- Counter used to prevent infinite recursion while computing name of
40 -- complex expressions.
41
42 ----------------------
43 -- Expression_Image --
44 ----------------------
45
46 function Expression_Image
47 (Expr : Node_Id;
48 Default : String) return String
49 is
50 From_Source : constant Boolean :=
51 Comes_From_Source (Expr)
52 and then not Opt.Debug_Generated_Code;
53 Append_Paren : Boolean := False;
54 Left : Node_Id := Original_Node (Expr);
55 Right : Node_Id := Original_Node (Expr);
56
57 function Expr_Name
58 (Expr : Node_Id;
59 Take_Prefix : Boolean := True;
60 Expand_Type : Boolean := True) return String;
61 -- Return string corresponding to Expr. If no string can be extracted,
62 -- return "...". If Take_Prefix is True, go back to prefix when needed,
63 -- otherwise only consider the right-hand side of an expression. If
64 -- Expand_Type is True and Expr is a type, try to expand Expr (an
65 -- internally generated type) into a user understandable name.
66
67 Max_List : constant := 3;
68 -- Limit number of list elements to dump
69
70 Max_Expr_Elements : constant := 24;
71 -- Limit number of elements in an expression for use by Expr_Name
72
73 Num_Elements : Natural := 0;
74 -- Current number of elements processed by Expr_Name
75
76 function List_Name
77 (List : Node_Id;
78 Add_Space : Boolean := True;
79 Add_Paren : Boolean := True) return String;
80 -- Return a string corresponding to List
81
82 ---------------
83 -- List_Name --
84 ---------------
85
86 function List_Name
87 (List : Node_Id;
88 Add_Space : Boolean := True;
89 Add_Paren : Boolean := True) return String
90 is
91 function Internal_List_Name
92 (List : Node_Id;
93 First : Boolean := True;
94 Add_Space : Boolean := True;
95 Add_Paren : Boolean := True;
96 Num : Natural := 1) return String;
97 -- ??? what does this do
98
99 ------------------------
100 -- Internal_List_Name --
101 ------------------------
102
103 function Internal_List_Name
104 (List : Node_Id;
105 First : Boolean := True;
106 Add_Space : Boolean := True;
107 Add_Paren : Boolean := True;
108 Num : Natural := 1) return String
109 is
110 function Prepend (S : String) return String;
111 -- ??? what does this do
112
113 -------------
114 -- Prepend --
115 -------------
116
117 function Prepend (S : String) return String is
118 begin
119 if Add_Space then
120 if Add_Paren then
121 return " (" & S;
122 else
123 return ' ' & S;
124 end if;
125 elsif Add_Paren then
126 return '(' & S;
127 else
128 return S;
129 end if;
130 end Prepend;
131
132 -- Start of processing for Internal_List_Name
133
134 begin
135 if not Present (List) then
136 if First or else not Add_Paren then
137 return "";
138 else
139 return ")";
140 end if;
141 elsif Num > Max_List then
142 if Add_Paren then
143 return ", ...)";
144 else
145 return ", ...";
146 end if;
147 end if;
148
149 -- ??? the Internal_List_Name calls can be factored out
150
151 if First then
152 return Prepend (Expr_Name (List)
153 & Internal_List_Name
154 (List => Next (List),
155 First => False,
156 Add_Paren => Add_Paren,
157 Num => Num + 1));
158 else
159 return ", " & Expr_Name (List)
160 & Internal_List_Name
161 (List => Next (List),
162 First => False,
163 Add_Paren => Add_Paren,
164 Num => Num + 1);
165 end if;
166 end Internal_List_Name;
167
168 -- Start of processing for List_Name
169
170 begin
171 -- Prevent infinite recursion by limiting depth to 3
172
173 if List_Name_Count > 3 then
174 return "...";
175 end if;
176
177 List_Name_Count := List_Name_Count + 1;
178
179 declare
180 Result : constant String :=
181 Internal_List_Name
182 (List => List,
183 Add_Space => Add_Space,
184 Add_Paren => Add_Paren);
185 begin
186 List_Name_Count := List_Name_Count - 1;
187 return Result;
188 end;
189 end List_Name;
190
191 ---------------
192 -- Expr_Name --
193 ---------------
194
195 function Expr_Name
196 (Expr : Node_Id;
197 Take_Prefix : Boolean := True;
198 Expand_Type : Boolean := True) return String
199 is
200 begin
201 Num_Elements := Num_Elements + 1;
202
203 if Num_Elements > Max_Expr_Elements then
204 return "...";
205 end if;
206
207 case Nkind (Expr) is
208 when N_Defining_Identifier | N_Identifier =>
209 return Ident_Image (Expr, Expression_Image.Expr, Expand_Type);
210
211 when N_Character_Literal =>
212 declare
213 Char : constant Int :=
214 UI_To_Int (Char_Literal_Value (Expr));
215 begin
216 if Char in 32 .. 127 then
217 return "'" & Character'Val (Char) & "'";
218 else
219 UI_Image (Char_Literal_Value (Expr));
220 return
221 "'\" & UI_Image_Buffer (1 .. UI_Image_Length) & "'";
222 end if;
223 end;
224
225 when N_Integer_Literal =>
226 UI_Image (Intval (Expr));
227 return UI_Image_Buffer (1 .. UI_Image_Length);
228
229 when N_Real_Literal =>
230 return Real_Image (Realval (Expr));
231
232 when N_String_Literal =>
233 return String_Image (Strval (Expr));
234
235 when N_Allocator =>
236 return "new " & Expr_Name (Expression (Expr));
237
238 when N_Aggregate =>
239 if Present (Sinfo.Expressions (Expr)) then
240 return
241 List_Name
242 (List => First (Sinfo.Expressions (Expr)),
243 Add_Space => False);
244
245 -- Do not return empty string for (others => <>) aggregate
246 -- of a componentless record type. At least one caller (the
247 -- recursive call below in the N_Qualified_Expression case)
248 -- is not prepared to deal with a zero-length result.
249
250 elsif Null_Record_Present (Expr)
251 or else not Present (First (Component_Associations (Expr)))
252 then
253 return ("(null record)");
254
255 else
256 return
257 List_Name
258 (List => First (Component_Associations (Expr)),
259 Add_Space => False,
260 Add_Paren => False);
261 end if;
262
263 when N_Extension_Aggregate =>
264 return "(" & Expr_Name (Ancestor_Part (Expr)) & " with "
265 & List_Name
266 (List => First (Sinfo.Expressions (Expr)),
267 Add_Space => False,
268 Add_Paren => False) & ")";
269
270 when N_Attribute_Reference =>
271 if Take_Prefix then
272 declare
273 Id : constant Attribute_Id :=
274 Get_Attribute_Id (Attribute_Name (Expr));
275 Str : constant String :=
276 Expr_Name (Prefix (Expr)) & "'"
277 & Get_Name_String (Attribute_Name (Expr));
278 N : Node_Id;
279 Ranges : List_Id;
280
281 begin
282 if (Id = Attribute_First or else Id = Attribute_Last)
283 and then Str (Str'First) = '$'
284 then
285 N := Associated_Node_For_Itype (Etype (Prefix (Expr)));
286
287 if Present (N) then
288 if Nkind (N) = N_Full_Type_Declaration then
289 N := Type_Definition (N);
290 end if;
291
292 if Nkind (N) = N_Subtype_Declaration then
293 Ranges :=
294 Constraints
295 (Constraint (Subtype_Indication (N)));
296
297 if List_Length (Ranges) = 1
298 and then
299 Nkind_In
300 (First (Ranges),
301 N_Range,
302 N_Real_Range_Specification,
303 N_Signed_Integer_Type_Definition)
304 then
305 if Id = Attribute_First then
306 return
307 Expression_Image
308 (Low_Bound (First (Ranges)), Str);
309 else
310 return
311 Expression_Image
312 (High_Bound (First (Ranges)), Str);
313 end if;
314 end if;
315 end if;
316 end if;
317 end if;
318
319 return Str;
320 end;
321 else
322 return "'" & Get_Name_String (Attribute_Name (Expr));
323 end if;
324
325 when N_Explicit_Dereference =>
326
327 -- Return "Foo" instead of "Parameter_Block.Foo.all"
328
329 if Hide_Parameter_Blocks
330 and then Nkind (Prefix (Expr)) = N_Selected_Component
331 and then Present (Etype (Prefix (Expr)))
332 and then Is_Access_Type (Etype (Prefix (Expr)))
333 and then Is_Param_Block_Component_Type (Etype (Prefix (Expr)))
334 then
335 return Expr_Name (Selector_Name (Prefix (Expr)));
336
337 elsif Take_Prefix then
338 return Expr_Name (Prefix (Expr)) & ".all";
339 else
340 return ".all";
341 end if;
342
343 when N_Expanded_Name | N_Selected_Component =>
344 if Take_Prefix then
345 return
346 Expr_Name (Prefix (Expr)) & "." &
347 Expr_Name (Selector_Name (Expr));
348 else
349 return "." & Expr_Name (Selector_Name (Expr));
350 end if;
351
352 when N_Component_Association =>
353 return "("
354 & List_Name
355 (List => First (Choices (Expr)),
356 Add_Space => False,
357 Add_Paren => False)
358 & " => " & Expr_Name (Expression (Expr)) & ")";
359
360 when N_If_Expression =>
361 declare
362 N : constant Node_Id := First (Sinfo.Expressions (Expr));
363 begin
364 return
365 "if " & Expr_Name (N) & " then "
366 & Expr_Name (Next (N)) & " else "
367 & Expr_Name (Next (Next (N)));
368 end;
369
370 when N_Qualified_Expression =>
371 declare
372 Mark : constant String :=
373 Expr_Name
374 (Subtype_Mark (Expr), Expand_Type => False);
375 Str : constant String := Expr_Name (Expression (Expr));
376 begin
377 if Str (Str'First) = '(' and then Str (Str'Last) = ')' then
378 return Mark & "'" & Str;
379 else
380 return Mark & "'(" & Str & ")";
381 end if;
382 end;
383
384 when N_Unchecked_Expression | N_Expression_With_Actions =>
385 return Expr_Name (Expression (Expr));
386
387 when N_Raise_Constraint_Error =>
388 if Present (Condition (Expr)) then
389 return
390 "[constraint_error when "
391 & Expr_Name (Condition (Expr)) & "]";
392 else
393 return "[constraint_error]";
394 end if;
395
396 when N_Raise_Program_Error =>
397 if Present (Condition (Expr)) then
398 return
399 "[program_error when "
400 & Expr_Name (Condition (Expr)) & "]";
401 else
402 return "[program_error]";
403 end if;
404
405 when N_Range =>
406 return
407 Expr_Name (Low_Bound (Expr)) & ".." &
408 Expr_Name (High_Bound (Expr));
409
410 when N_Slice =>
411 return
412 Expr_Name (Prefix (Expr)) & " (" &
413 Expr_Name (Discrete_Range (Expr)) & ")";
414
415 when N_And_Then =>
416 return
417 Expr_Name (Left_Opnd (Expr)) & " and then " &
418 Expr_Name (Right_Opnd (Expr));
419
420 when N_In =>
421 return
422 Expr_Name (Left_Opnd (Expr)) & " in " &
423 Expr_Name (Right_Opnd (Expr));
424
425 when N_Not_In =>
426 return
427 Expr_Name (Left_Opnd (Expr)) & " not in " &
428 Expr_Name (Right_Opnd (Expr));
429
430 when N_Or_Else =>
431 return
432 Expr_Name (Left_Opnd (Expr)) & " or else " &
433 Expr_Name (Right_Opnd (Expr));
434
435 when N_Op_And =>
436 return
437 Expr_Name (Left_Opnd (Expr)) & " and " &
438 Expr_Name (Right_Opnd (Expr));
439
440 when N_Op_Or =>
441 return
442 Expr_Name (Left_Opnd (Expr)) & " or " &
443 Expr_Name (Right_Opnd (Expr));
444
445 when N_Op_Xor =>
446 return
447 Expr_Name (Left_Opnd (Expr)) & " xor " &
448 Expr_Name (Right_Opnd (Expr));
449
450 when N_Op_Eq =>
451 return
452 Expr_Name (Left_Opnd (Expr)) & " = " &
453 Expr_Name (Right_Opnd (Expr));
454
455 when N_Op_Ne =>
456 return
457 Expr_Name (Left_Opnd (Expr)) & " /= " &
458 Expr_Name (Right_Opnd (Expr));
459
460 when N_Op_Lt =>
461 return
462 Expr_Name (Left_Opnd (Expr)) & " < " &
463 Expr_Name (Right_Opnd (Expr));
464
465 when N_Op_Le =>
466 return
467 Expr_Name (Left_Opnd (Expr)) & " <= " &
468 Expr_Name (Right_Opnd (Expr));
469
470 when N_Op_Gt =>
471 return
472 Expr_Name (Left_Opnd (Expr)) & " > " &
473 Expr_Name (Right_Opnd (Expr));
474
475 when N_Op_Ge =>
476 return
477 Expr_Name (Left_Opnd (Expr)) & " >= " &
478 Expr_Name (Right_Opnd (Expr));
479
480 when N_Op_Add =>
481 return
482 Expr_Name (Left_Opnd (Expr)) & " + " &
483 Expr_Name (Right_Opnd (Expr));
484
485 when N_Op_Subtract =>
486 return
487 Expr_Name (Left_Opnd (Expr)) & " - " &
488 Expr_Name (Right_Opnd (Expr));
489
490 when N_Op_Multiply =>
491 return
492 Expr_Name (Left_Opnd (Expr)) & " * " &
493 Expr_Name (Right_Opnd (Expr));
494
495 when N_Op_Divide =>
496 return
497 Expr_Name (Left_Opnd (Expr)) & " / " &
498 Expr_Name (Right_Opnd (Expr));
499
500 when N_Op_Mod =>
501 return
502 Expr_Name (Left_Opnd (Expr)) & " mod " &
503 Expr_Name (Right_Opnd (Expr));
504
505 when N_Op_Rem =>
506 return
507 Expr_Name (Left_Opnd (Expr)) & " rem " &
508 Expr_Name (Right_Opnd (Expr));
509
510 when N_Op_Expon =>
511 return
512 Expr_Name (Left_Opnd (Expr)) & " ** " &
513 Expr_Name (Right_Opnd (Expr));
514
515 when N_Op_Shift_Left =>
516 return
517 Expr_Name (Left_Opnd (Expr)) & " << " &
518 Expr_Name (Right_Opnd (Expr));
519
520 when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic =>
521 return
522 Expr_Name (Left_Opnd (Expr)) & " >> " &
523 Expr_Name (Right_Opnd (Expr));
524
525 when N_Op_Concat =>
526 return
527 Expr_Name (Left_Opnd (Expr)) & " & " &
528 Expr_Name (Right_Opnd (Expr));
529
530 when N_Op_Plus =>
531 return "+" & Expr_Name (Right_Opnd (Expr));
532
533 when N_Op_Minus =>
534 return "-" & Expr_Name (Right_Opnd (Expr));
535
536 when N_Op_Abs =>
537 return "abs " & Expr_Name (Right_Opnd (Expr));
538
539 when N_Op_Not =>
540 return "not (" & Expr_Name (Right_Opnd (Expr)) & ")";
541
542 when N_Parameter_Association =>
543 return Expr_Name (Explicit_Actual_Parameter (Expr));
544
545 when N_Type_Conversion =>
546
547 -- Most conversions are not very interesting (used inside
548 -- expanded checks to convert to larger ranges), so skip them.
549
550 return Expr_Name (Expression (Expr));
551
552 when N_Unchecked_Type_Conversion =>
553
554 -- Only keep the type conversion in complex cases
555
556 if not Is_Scalar_Type (Etype (Expr))
557 or else not Is_Scalar_Type (Etype (Expression (Expr)))
558 or else Is_Modular_Integer_Type (Etype (Expr)) /=
559 Is_Modular_Integer_Type (Etype (Expression (Expr)))
560 then
561 return Expr_Name (Subtype_Mark (Expr)) &
562 "(" & Expr_Name (Expression (Expr)) & ")";
563 else
564 return Expr_Name (Expression (Expr));
565 end if;
566
567 when N_Indexed_Component =>
568 if Take_Prefix then
569 return
570 Expr_Name (Prefix (Expr))
571 & List_Name (First (Sinfo.Expressions (Expr)));
572 else
573 return List_Name (First (Sinfo.Expressions (Expr)));
574 end if;
575
576 when N_Function_Call =>
577
578 -- If Default = "", it means we're expanding the name of
579 -- a gnat temporary (and not really a function call), so add
580 -- parentheses around function call to mark it specially.
581
582 if Default = "" then
583 return '('
584 & Expr_Name (Name (Expr))
585 & List_Name (First (Sinfo.Parameter_Associations (Expr)))
586 & ')';
587 else
588 return
589 Expr_Name (Name (Expr))
590 & List_Name
591 (First (Sinfo.Parameter_Associations (Expr)));
592 end if;
593
594 when N_Null =>
595 return "null";
596
597 when N_Others_Choice =>
598 return "others";
599
600 when others =>
601 return "...";
602 end case;
603 end Expr_Name;
604
605 -- Start of processing for Expression_Name
606
607 begin
608 if not From_Source then
609 declare
610 S : constant String := Expr_Name (Expr);
611 begin
612 if S = "..." then
613 return Default;
614 else
615 return S;
616 end if;
617 end;
618 end if;
619
620 -- Compute left (start) and right (end) slocs for the expression
621 -- Consider using Sinput.Sloc_Range instead, except that it does not
622 -- work properly currently???
623
624 loop
625 case Nkind (Left) is
626 when N_And_Then |
627 N_Binary_Op |
628 N_Membership_Test |
629 N_Or_Else =>
630 Left := Original_Node (Left_Opnd (Left));
631
632 when N_Attribute_Reference |
633 N_Expanded_Name |
634 N_Explicit_Dereference |
635 N_Indexed_Component |
636 N_Reference |
637 N_Selected_Component |
638 N_Slice =>
639 Left := Original_Node (Prefix (Left));
640
641 when N_Defining_Program_Unit_Name |
642 N_Designator |
643 N_Function_Call =>
644 Left := Original_Node (Name (Left));
645
646 when N_Range =>
647 Left := Original_Node (Low_Bound (Left));
648
649 when N_Type_Conversion =>
650 Left := Original_Node (Subtype_Mark (Left));
651
652 -- For any other item, quit loop
653
654 when others =>
655 exit;
656 end case;
657 end loop;
658
659 loop
660 case Nkind (Right) is
661 when N_And_Then |
662 N_Membership_Test |
663 N_Op |
664 N_Or_Else =>
665 Right := Original_Node (Right_Opnd (Right));
666
667 when N_Expanded_Name |
668 N_Selected_Component =>
669 Right := Original_Node (Selector_Name (Right));
670
671 when N_Designator =>
672 Right := Original_Node (Identifier (Right));
673
674 when N_Defining_Program_Unit_Name =>
675 Right := Original_Node (Defining_Identifier (Right));
676
677 when N_Range =>
678 Right := Original_Node (High_Bound (Right));
679
680 when N_Parameter_Association =>
681 Right := Original_Node (Explicit_Actual_Parameter (Right));
682
683 when N_Indexed_Component =>
684 Right := Original_Node (Last (Sinfo.Expressions (Right)));
685 Append_Paren := True;
686
687 when N_Function_Call =>
688 if Present (Sinfo.Parameter_Associations (Right)) then
689 declare
690 Rover : Node_Id;
691 Found : Boolean;
692
693 begin
694 -- Avoid source position confusion associated with
695 -- parameters for which Comes_From_Source is False.
696
697 Rover := First (Sinfo.Parameter_Associations (Right));
698 Found := False;
699 while Present (Rover) loop
700 if Comes_From_Source (Original_Node (Rover)) then
701 Right := Original_Node (Rover);
702 Append_Paren := True;
703 Found := True;
704 end if;
705
706 Next (Rover);
707 end loop;
708
709 -- Quit loop if no Comes_From_Source parameters
710
711 exit when not Found;
712 end;
713
714 -- Quit loop if no parameters
715
716 else
717 exit;
718 end if;
719
720 when N_Quantified_Expression =>
721 Right := Original_Node (Condition (Right));
722
723 -- For all other items, quit the loop
724
725 when others =>
726 exit;
727 end case;
728 end loop;
729
730 declare
731 Scn : Source_Ptr := Original_Location (Sloc (Left));
732 End_Sloc : constant Source_Ptr :=
733 Original_Location (Sloc (Right));
734 Src : constant Source_Buffer_Ptr :=
735 Source_Text (Get_Source_File_Index (Scn));
736
737 begin
738 if Scn > End_Sloc then
739 return Default;
740 end if;
741
742 declare
743 Buffer : String (1 .. Natural (End_Sloc - Scn));
744 Index : Natural := 0;
745 Skipping_Comment : Boolean := False;
746 Underscore : Boolean := False;
747
748 begin
749 if Right /= Expr then
750 while Scn < End_Sloc loop
751 case Src (Scn) is
752 when ' ' | ASCII.HT =>
753 if not Skipping_Comment and then not Underscore then
754 Underscore := True;
755 Index := Index + 1;
756 Buffer (Index) := ' ';
757 end if;
758
759 -- CR/LF/FF is the end of any comment
760
761 when ASCII.LF | ASCII.CR | ASCII.FF =>
762 Skipping_Comment := False;
763
764 when others =>
765 Underscore := False;
766
767 if not Skipping_Comment then
768
769 -- Ignore comment
770
771 if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
772 Skipping_Comment := True;
773
774 else
775 Index := Index + 1;
776 Buffer (Index) := Src (Scn);
777 end if;
778 end if;
779 end case;
780
781 Scn := Scn + 1;
782 end loop;
783 end if;
784
785 if Index < 1 then
786 declare
787 S : constant String := Expr_Name (Right);
788 begin
789 if S = "..." then
790 return Default;
791 else
792 return S;
793 end if;
794 end;
795
796 elsif Append_Paren then
797 return Buffer (1 .. Index) & Expr_Name (Right, False) & ')';
798
799 else
800 return Buffer (1 .. Index) & Expr_Name (Right, False);
801 end if;
802 end;
803 end;
804 end Expression_Image;
805
806 end Pprint;