1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2008-2020, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Csets
; use Csets
;
28 with Einfo
; use Einfo
;
29 with Namet
; use Namet
;
30 with Nlists
; use Nlists
;
32 with Sinfo
; use Sinfo
;
33 with Sinput
; use Sinput
;
34 with Snames
; use Snames
;
35 with Uintp
; use Uintp
;
37 package body Pprint
is
39 List_Name_Count
: Integer := 0;
40 -- Counter used to prevent infinite recursion while computing name of
41 -- complex expressions.
43 ----------------------
44 -- Expression_Image --
45 ----------------------
47 function Expression_Image
49 Default
: String) return String
51 From_Source
: constant Boolean :=
52 Comes_From_Source
(Expr
)
53 and then not Opt
.Debug_Generated_Code
;
54 Append_Paren
: Natural := 0;
55 Left
: Node_Id
:= Original_Node
(Expr
);
56 Right
: Node_Id
:= Original_Node
(Expr
);
60 Take_Prefix
: Boolean := True;
61 Expand_Type
: Boolean := True) return String;
62 -- Return string corresponding to Expr. If no string can be extracted,
63 -- return "...". If Take_Prefix is True, go back to prefix when needed,
64 -- otherwise only consider the right-hand side of an expression. If
65 -- Expand_Type is True and Expr is a type, try to expand Expr (an
66 -- internally generated type) into a user understandable name.
68 Max_List
: constant := 3;
69 -- Limit number of list elements to dump
71 Max_Expr_Elements
: constant := 24;
72 -- Limit number of elements in an expression for use by Expr_Name
74 Num_Elements
: Natural := 0;
75 -- Current number of elements processed by Expr_Name
79 Add_Space
: Boolean := True;
80 Add_Paren
: Boolean := True) return String;
81 -- Return a string corresponding to List
89 Add_Space
: Boolean := True;
90 Add_Paren
: Boolean := True) return String
92 function Internal_List_Name
94 First
: Boolean := True;
95 Add_Space
: Boolean := True;
96 Add_Paren
: Boolean := True;
97 Num
: Natural := 1) return String;
98 -- ??? what does this do
100 ------------------------
101 -- Internal_List_Name --
102 ------------------------
104 function Internal_List_Name
106 First
: Boolean := True;
107 Add_Space
: Boolean := True;
108 Add_Paren
: Boolean := True;
109 Num
: Natural := 1) return String
111 function Prepend
(S
: String) return String;
112 -- ??? what does this do
118 function Prepend
(S
: String) return String is
133 -- Start of processing for Internal_List_Name
136 if not Present
(List
) then
137 if First
or else not Add_Paren
then
142 elsif Num
> Max_List
then
150 -- ??? the Internal_List_Name calls can be factored out
153 return Prepend
(Expr_Name
(List
)
155 (List
=> Next
(List
),
157 Add_Paren
=> Add_Paren
,
160 return ", " & Expr_Name
(List
)
162 (List
=> Next
(List
),
164 Add_Paren
=> Add_Paren
,
167 end Internal_List_Name
;
169 -- Start of processing for List_Name
172 -- Prevent infinite recursion by limiting depth to 3
174 if List_Name_Count
> 3 then
178 List_Name_Count
:= List_Name_Count
+ 1;
181 Result
: constant String :=
184 Add_Space
=> Add_Space
,
185 Add_Paren
=> Add_Paren
);
187 List_Name_Count
:= List_Name_Count
- 1;
198 Take_Prefix
: Boolean := True;
199 Expand_Type
: Boolean := True) return String
202 Num_Elements
:= Num_Elements
+ 1;
204 if Num_Elements
> Max_Expr_Elements
then
209 when N_Defining_Identifier
212 return Ident_Image
(Expr
, Expression_Image
.Expr
, Expand_Type
);
214 when N_Character_Literal
=>
216 Char
: constant Int
:= UI_To_Int
(Char_Literal_Value
(Expr
));
218 if Char
in 32 .. 127 then
219 return "'" & Character'Val (Char
) & "'";
221 UI_Image
(Char_Literal_Value
(Expr
));
223 "'\" & UI_Image_Buffer (1 .. UI_Image_Length) & "'";
227 when N_Integer_Literal =>
228 UI_Image (Intval (Expr));
229 return UI_Image_Buffer (1 .. UI_Image_Length);
231 when N_Real_Literal =>
232 return Real_Image (Realval (Expr));
234 when N_String_Literal =>
235 return String_Image (Strval (Expr));
238 return "new " & Expr_Name (Expression (Expr));
241 if Present (Sinfo.Expressions (Expr)) then
244 (List => First (Sinfo.Expressions (Expr)),
247 -- Do not return empty string for (others => <>) aggregate
248 -- of a componentless record type. At least one caller (the
249 -- recursive call below in the N_Qualified_Expression case)
250 -- is not prepared to deal with a zero-length result.
252 elsif Null_Record_Present (Expr)
253 or else not Present (First (Component_Associations (Expr)))
255 return ("(null record)");
260 (List => First (Component_Associations (Expr)),
265 when N_Extension_Aggregate =>
266 return "(" & Expr_Name (Ancestor_Part (Expr)) & " with "
268 (List => First (Sinfo.Expressions (Expr)),
270 Add_Paren => False) & ")";
272 when N_Attribute_Reference =>
275 function To_Mixed_Case (S : String) return String;
276 -- Transform given string into the corresponding one in
283 function To_Mixed_Case (S : String) return String is
284 Result : String (S'Range);
285 Ucase : Boolean := True;
288 for J in S'Range loop
290 Result (J) := Fold_Upper (S (J));
292 Result (J) := Fold_Lower (S (J));
295 Ucase := (S (J) = '_
');
301 Id : constant Attribute_Id :=
302 Get_Attribute_Id (Attribute_Name (Expr));
304 -- Always use mixed case for attributes
306 Str : constant String :=
307 Expr_Name (Prefix (Expr))
310 (Get_Name_String (Attribute_Name (Expr)));
316 if (Id = Attribute_First or else Id = Attribute_Last)
317 and then Str (Str'First) = '$'
319 N := Associated_Node_For_Itype (Etype (Prefix (Expr)));
322 if Nkind (N) = N_Full_Type_Declaration then
323 N := Type_Definition (N);
326 if Nkind (N) = N_Subtype_Declaration then
329 (Constraint (Subtype_Indication (N)));
331 if List_Length (Ranges) = 1
332 and then Nkind (First (Ranges)) in
334 N_Real_Range_Specification |
335 N_Signed_Integer_Type_Definition
337 if Id = Attribute_First then
340 (Low_Bound (First (Ranges)), Str);
344 (High_Bound (First (Ranges)), Str);
354 return "'" & Get_Name_String (Attribute_Name (Expr));
357 when N_Explicit_Dereference =>
358 Explicit_Dereference : declare
359 function Deref_Suffix return String;
360 -- Usually returns ".all", but will return "" if
361 -- Hide_Temp_Derefs is true and the prefix is a use of a
362 -- not-from-source object declared as
363 -- X : constant Some_Access_Type := Some_Expr'Reference;
364 -- (as is sometimes done in Exp_Util.Remove_Side_Effects).
370 function Deref_Suffix return String is
375 and then Nkind (Prefix (Expr)) = N_Identifier
376 and then Nkind (Entity (Prefix (Expr))) =
377 N_Defining_Identifier
379 Decl := Parent (Entity (Prefix (Expr)));
382 and then Nkind (Decl) = N_Object_Declaration
383 and then not Comes_From_Source (Decl)
384 and then Constant_Present (Decl)
385 and then Present (Sinfo.Expression (Decl))
386 and then Nkind (Sinfo.Expression (Decl)) =
398 -- Start of processing for Explicit_Dereference
401 if Hide_Parameter_Blocks
402 and then Nkind (Prefix (Expr)) = N_Selected_Component
403 and then Present (Etype (Prefix (Expr)))
404 and then Is_Access_Type (Etype (Prefix (Expr)))
405 and then Is_Param_Block_Component_Type
406 (Etype (Prefix (Expr)))
408 -- Return "Foo" instead of "Parameter_Block.Foo.all"
410 return Expr_Name (Selector_Name (Prefix (Expr)));
412 elsif Take_Prefix then
413 return Expr_Name (Prefix (Expr)) & Deref_Suffix;
417 end Explicit_Dereference;
420 | N_Selected_Component
424 Expr_Name (Prefix (Expr)) & "." &
425 Expr_Name (Selector_Name (Expr));
427 return "." & Expr_Name (Selector_Name (Expr));
430 when N_Component_Association =>
433 (List => First (Choices (Expr)),
436 & " => " & Expr_Name (Expression (Expr)) & ")";
438 when N_If_Expression =>
440 N : constant Node_Id := First (Sinfo.Expressions (Expr));
443 "if " & Expr_Name (N) & " then "
444 & Expr_Name (Next (N)) & " else "
445 & Expr_Name (Next (Next (N)));
448 when N_Qualified_Expression =>
450 Mark : constant String :=
452 (Subtype_Mark (Expr), Expand_Type => False);
453 Str : constant String := Expr_Name (Expression (Expr));
455 if Str (Str'First) = '(' and then Str (Str'Last) = ')' then
456 return Mark & "'" & Str;
458 return Mark & "'(" & Str & ")";
462 when N_Expression_With_Actions
463 | N_Unchecked_Expression
465 return Expr_Name (Expression (Expr));
467 when N_Raise_Constraint_Error =>
468 if Present (Condition (Expr)) then
470 "[constraint_error when "
471 & Expr_Name (Condition (Expr)) & "]";
473 return "[constraint_error]";
476 when N_Raise_Program_Error =>
477 if Present (Condition (Expr)) then
479 "[program_error when "
480 & Expr_Name (Condition (Expr)) & "]";
482 return "[program_error]";
487 Expr_Name (Low_Bound (Expr)) & ".." &
488 Expr_Name (High_Bound (Expr));
492 Expr_Name (Prefix (Expr)) & " (" &
493 Expr_Name (Discrete_Range (Expr)) & ")";
497 Expr_Name (Left_Opnd (Expr)) & " and then " &
498 Expr_Name (Right_Opnd (Expr));
502 Expr_Name (Left_Opnd (Expr)) & " in " &
503 Expr_Name (Right_Opnd (Expr));
507 Expr_Name (Left_Opnd (Expr)) & " not in " &
508 Expr_Name (Right_Opnd (Expr));
512 Expr_Name (Left_Opnd (Expr)) & " or else " &
513 Expr_Name (Right_Opnd (Expr));
517 Expr_Name (Left_Opnd (Expr)) & " and " &
518 Expr_Name (Right_Opnd (Expr));
522 Expr_Name (Left_Opnd (Expr)) & " or " &
523 Expr_Name (Right_Opnd (Expr));
527 Expr_Name (Left_Opnd (Expr)) & " xor " &
528 Expr_Name (Right_Opnd (Expr));
532 Expr_Name (Left_Opnd (Expr)) & " = " &
533 Expr_Name (Right_Opnd (Expr));
537 Expr_Name (Left_Opnd (Expr)) & " /= " &
538 Expr_Name (Right_Opnd (Expr));
542 Expr_Name (Left_Opnd (Expr)) & " < " &
543 Expr_Name (Right_Opnd (Expr));
547 Expr_Name (Left_Opnd (Expr)) & " <= " &
548 Expr_Name (Right_Opnd (Expr));
552 Expr_Name (Left_Opnd (Expr)) & " > " &
553 Expr_Name (Right_Opnd (Expr));
557 Expr_Name (Left_Opnd (Expr)) & " >= " &
558 Expr_Name (Right_Opnd (Expr));
562 Expr_Name (Left_Opnd (Expr)) & " + " &
563 Expr_Name (Right_Opnd (Expr));
565 when N_Op_Subtract =>
567 Expr_Name (Left_Opnd (Expr)) & " - " &
568 Expr_Name (Right_Opnd (Expr));
570 when N_Op_Multiply =>
572 Expr_Name (Left_Opnd (Expr)) & " * " &
573 Expr_Name (Right_Opnd (Expr));
577 Expr_Name (Left_Opnd (Expr)) & " / " &
578 Expr_Name (Right_Opnd (Expr));
582 Expr_Name (Left_Opnd (Expr)) & " mod " &
583 Expr_Name (Right_Opnd (Expr));
587 Expr_Name (Left_Opnd (Expr)) & " rem " &
588 Expr_Name (Right_Opnd (Expr));
592 Expr_Name (Left_Opnd (Expr)) & " ** " &
593 Expr_Name (Right_Opnd (Expr));
595 when N_Op_Shift_Left =>
597 Expr_Name (Left_Opnd (Expr)) & " << " &
598 Expr_Name (Right_Opnd (Expr));
600 when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic =>
602 Expr_Name (Left_Opnd (Expr)) & " >> " &
603 Expr_Name (Right_Opnd (Expr));
607 Expr_Name (Left_Opnd (Expr)) & " & " &
608 Expr_Name (Right_Opnd (Expr));
611 return "+" & Expr_Name (Right_Opnd (Expr));
614 return "-" & Expr_Name (Right_Opnd (Expr));
617 return "abs " & Expr_Name (Right_Opnd (Expr));
620 return "not (" & Expr_Name (Right_Opnd (Expr)) & ")";
622 when N_Parameter_Association =>
623 return Expr_Name (Explicit_Actual_Parameter (Expr));
625 when N_Type_Conversion =>
627 -- Most conversions are not very interesting (used inside
628 -- expanded checks to convert to larger ranges), so skip them.
630 return Expr_Name (Expression (Expr));
632 when N_Unchecked_Type_Conversion =>
634 -- Only keep the type conversion in complex cases
636 if not Is_Scalar_Type (Etype (Expr))
637 or else not Is_Scalar_Type (Etype (Expression (Expr)))
638 or else Is_Modular_Integer_Type (Etype (Expr)) /=
639 Is_Modular_Integer_Type (Etype (Expression (Expr)))
641 return Expr_Name (Subtype_Mark (Expr)) &
642 "(" & Expr_Name (Expression (Expr)) & ")";
644 return Expr_Name (Expression (Expr));
647 when N_Indexed_Component =>
650 Expr_Name (Prefix (Expr))
651 & List_Name (First (Sinfo.Expressions (Expr)));
653 return List_Name (First (Sinfo.Expressions (Expr)));
656 when N_Function_Call =>
658 -- If Default = "", it means we're expanding the name of
659 -- a gnat temporary (and not really a function call), so add
660 -- parentheses around function call to mark it specially.
664 & Expr_Name (Name (Expr))
665 & List_Name (First (Sinfo.Parameter_Associations (Expr)))
669 Expr_Name (Name (Expr))
671 (First (Sinfo.Parameter_Associations (Expr)));
677 when N_Others_Choice =>
685 -- Start of processing for Expression_Name
688 if not From_Source then
690 S : constant String := Expr_Name (Expr);
700 -- Compute left (start) and right (end) slocs for the expression
701 -- Consider using Sinput.Sloc_Range instead, except that it does not
702 -- work properly currently???
711 Left := Original_Node (Left_Opnd (Left));
713 when N_Attribute_Reference
715 | N_Explicit_Dereference
716 | N_Indexed_Component
718 | N_Selected_Component
721 Left := Original_Node (Prefix (Left));
723 when N_Defining_Program_Unit_Name
727 Left := Original_Node (Name (Left));
730 Left := Original_Node (Low_Bound (Left));
732 when N_Qualified_Expression
735 Left := Original_Node (Subtype_Mark (Left));
737 -- For any other item, quit loop
745 case Nkind (Right) is
751 Right := Original_Node (Right_Opnd (Right));
754 | N_Selected_Component
756 Right := Original_Node (Selector_Name (Right));
758 when N_Qualified_Expression
761 Right := Original_Node (Expression (Right));
763 -- If argument does not already account for a closing
764 -- parenthesis, count one here.
766 if Nkind (Right) not in N_Aggregate | N_Quantified_Expression
768 Append_Paren := Append_Paren + 1;
772 Right := Original_Node (Identifier (Right));
774 when N_Defining_Program_Unit_Name =>
775 Right := Original_Node (Defining_Identifier (Right));
778 Right := Original_Node (High_Bound (Right));
780 when N_Parameter_Association =>
781 Right := Original_Node (Explicit_Actual_Parameter (Right));
783 when N_Component_Association =>
784 if Present (Expression (Right)) then
785 Right := Expression (Right);
787 Right := Last (Choices (Right));
790 when N_Indexed_Component =>
791 Right := Original_Node (Last (Sinfo.Expressions (Right)));
792 Append_Paren := Append_Paren + 1;
794 when N_Function_Call =>
795 if Present (Sinfo.Parameter_Associations (Right)) then
801 -- Avoid source position confusion associated with
802 -- parameters for which Comes_From_Source is False.
804 Rover := First (Sinfo.Parameter_Associations (Right));
806 while Present (Rover) loop
807 if Comes_From_Source (Original_Node (Rover)) then
808 Right := Original_Node (Rover);
816 Append_Paren := Append_Paren + 1;
819 -- Quit loop if no Comes_From_Source parameters
824 -- Quit loop if no parameters
830 when N_Quantified_Expression =>
831 Right := Original_Node (Condition (Right));
832 Append_Paren := Append_Paren + 1;
836 Aggr : constant Node_Id := Right;
840 Sub := First (Expressions (Aggr));
841 while Present (Sub) loop
842 if Sloc (Sub) > Sloc (Right) then
849 Sub := First (Component_Associations (Aggr));
850 while Present (Sub) loop
851 if Sloc (Sub) > Sloc (Right) then
858 exit when Right = Aggr;
860 Append_Paren := Append_Paren + 1;
863 -- For all other items, quit the loop
871 Scn : Source_Ptr := Original_Location (Sloc (Left));
872 End_Sloc : constant Source_Ptr :=
873 Original_Location (Sloc (Right));
874 Src : constant Source_Buffer_Ptr :=
875 Source_Text (Get_Source_File_Index (Scn));
878 if Scn > End_Sloc then
883 Threshold : constant := 256;
884 Buffer : String (1 .. Natural (End_Sloc - Scn));
885 Index : Natural := 0;
886 Skipping_Comment : Boolean := False;
887 Underscore : Boolean := False;
890 if Right /= Expr then
891 while Scn < End_Sloc loop
894 -- Give up on non ASCII characters
896 when Character'Val (128) .. Character'Last =>
905 if not Skipping_Comment and then not Underscore then
908 Buffer (Index) := ' ';
911 -- CR/LF/FF is the end of any comment
917 Skipping_Comment := False;
922 if not Skipping_Comment then
926 if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
927 Skipping_Comment := True;
931 Buffer (Index) := Src (Scn);
936 -- Give up on too long strings
938 if Index >= Threshold then
939 return Buffer (1 .. Index) & "...";
948 S : constant String := Expr_Name (Right);
960 & Expr_Name (Right, False)
961 & (1 .. Append_Paren => ')');
965 end Expression_Image;