1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2008-2024, 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 Einfo
; use Einfo
;
28 with Einfo
.Entities
; use Einfo
.Entities
;
29 with Einfo
.Utils
; use Einfo
.Utils
;
30 with Errout
; use Errout
;
31 with Namet
; use Namet
;
32 with Nlists
; use Nlists
;
34 with Sinfo
; use Sinfo
;
35 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
36 with Sinfo
.Utils
; use Sinfo
.Utils
;
37 with Sinput
; use Sinput
;
38 with Snames
; use Snames
;
39 with Uintp
; use Uintp
;
41 with System
.Case_Util
;
43 package body Pprint
is
45 List_Name_Count
: Natural := 0;
46 -- Counter used to prevent infinite recursion while computing name of
47 -- complex expressions.
49 ----------------------
50 -- Expression_Image --
51 ----------------------
53 function Expression_Image
55 Default
: String) return String
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.
67 function Count_Parentheses
(S
: String; C
: Character) return Natural
68 with Pre
=> C
in '(' |
')';
69 -- Returns the number of times parenthesis character C should be added
70 -- to string S for getting a correctly parenthesized result. For C = '('
71 -- this means prepending the character, for C = ')' this means appending
74 function Fix_Parentheses
(S
: String) return String;
75 -- Counts the number of required opening and closing parentheses in S to
76 -- respectively prepend and append for getting correct parentheses. Then
77 -- returns S with opening parentheses prepended and closing parentheses
78 -- appended so that the result is correctly parenthesized.
80 Max_List_Depth
: constant := 3;
81 -- Limit number of nested lists to print
83 Max_List_Length
: constant := 3;
84 -- Limit number of list elements to print
86 Max_Expr_Elements
: constant := 24;
87 -- Limit number of elements in an expression for use by Expr_Name
89 Num_Elements
: Natural := 0;
90 -- Current number of elements processed by Expr_Name
92 function List_Name
(List
: List_Id
) return String;
93 -- Return a string corresponding to List
99 function List_Name
(List
: List_Id
) return String is
100 Buf
: Bounded_String
;
103 Printed_Elmts
: Natural := 0;
106 -- Give up if the printed list is too deep
108 if List_Name_Count
> Max_List_Depth
then
112 List_Name_Count
:= List_Name_Count
+ 1;
114 Elmt
:= First
(List
);
115 while Present
(Elmt
) loop
117 -- Print component_association as "x | y | z => 12345"
119 if Nkind
(Elmt
) = N_Component_Association
then
121 Choice
: Node_Id
:= First
(Choices
(Elmt
));
123 while Present
(Choice
) loop
124 Append
(Buf
, Expr_Name
(Choice
));
127 if Present
(Choice
) then
132 Append
(Buf
, " => ");
133 if Box_Present
(Elmt
) then
136 Append
(Buf
, Expr_Name
(Expression
(Elmt
)));
139 -- Print parameter_association as "x => 12345"
141 elsif Nkind
(Elmt
) = N_Parameter_Association
then
142 Append
(Buf
, Expr_Name
(Selector_Name
(Elmt
)));
143 Append
(Buf
, " => ");
144 Append
(Buf
, Expr_Name
(Explicit_Actual_Parameter
(Elmt
)));
146 -- Print expression itself as "12345"
149 Append
(Buf
, Expr_Name
(Elmt
));
153 Printed_Elmts
:= Printed_Elmts
+ 1;
155 -- Separate next element with a comma, if necessary
157 if Present
(Elmt
) then
160 -- Abbreviate remaining elements as "...", if limit exceeded
162 if Printed_Elmts
= Max_List_Length
then
169 List_Name_Count
:= List_Name_Count
- 1;
171 return To_String
(Buf
);
180 Take_Prefix
: Boolean := True;
181 Expand_Type
: Boolean := True) return String
184 Num_Elements
:= Num_Elements
+ 1;
186 if Num_Elements
> Max_Expr_Elements
then
190 -- Just print pieces of aggregate nodes, even though they are not
191 -- expressions. It is too much trouble to handle them any better.
193 if Nkind
(Expr
) = N_Component_Association
then
195 pragma Assert
(Box_Present
(Expr
));
198 Buf
: Bounded_String
;
199 Choice
: Node_Id
:= First
(Choices
(Expr
));
201 while Present
(Choice
) loop
202 Append
(Buf
, Expr_Name
(Choice
));
205 if Present
(Choice
) then
210 Append
(Buf
, " => <>");
212 return To_String
(Buf
);
215 elsif Nkind
(Expr
) = N_Others_Choice
then
219 case N_Subexpr
'(Nkind (Expr)) is
221 return Ident_Image (Expr, Expression_Image.Expr, Expand_Type);
223 when N_Character_Literal =>
225 Char : constant Int := UI_To_Int (Char_Literal_Value (Expr));
227 if Char in 32 .. 126 then
228 return "'" & Character'Val (Char) & "'";
230 UI_Image (Char_Literal_Value (Expr));
232 "'\" & UI_Image_Buffer
(1 .. UI_Image_Length
) & "'";
236 when N_Integer_Literal
=>
237 return UI_Image
(Intval
(Expr
));
239 when N_Real_Literal
=>
240 return Real_Image
(Realval
(Expr
));
242 when N_String_Literal
=>
243 return String_Image
(Strval
(Expr
));
246 return "new " & Expr_Name
(Expression
(Expr
));
249 if Present
(Expressions
(Expr
)) then
250 return '(' & List_Name
(Expressions
(Expr
)) & ')';
252 -- Do not return empty string for (others => <>) aggregate
253 -- of a componentless record type. At least one caller (the
254 -- recursive call below in the N_Qualified_Expression case)
255 -- is not prepared to deal with a zero-length result.
257 elsif Null_Record_Present
(Expr
)
258 or else No
(First
(Component_Associations
(Expr
)))
260 return ("(null record)");
263 return '(' & List_Name
(Component_Associations
(Expr
)) & ')';
266 when N_Extension_Aggregate
=>
267 return '(' & Expr_Name
(Ancestor_Part
(Expr
))
268 & " with (" & List_Name
(Expressions
(Expr
)) & ')';
270 when N_Attribute_Reference
=>
273 Id
: constant Attribute_Id
:=
274 Get_Attribute_Id
(Attribute_Name
(Expr
));
276 -- Always use mixed case for attributes
278 Str
: constant String :=
279 Expr_Name
(Prefix
(Expr
))
281 & System
.Case_Util
.To_Mixed
282 (Get_Name_String
(Attribute_Name
(Expr
)));
288 if (Id
= Attribute_First
or else Id
= Attribute_Last
)
289 and then Str
(Str
'First) = '$'
291 N
:= Associated_Node_For_Itype
(Etype
(Prefix
(Expr
)));
294 if Nkind
(N
) = N_Full_Type_Declaration
then
295 N
:= Type_Definition
(N
);
298 if Nkind
(N
) = N_Subtype_Declaration
then
301 (Constraint
(Subtype_Indication
(N
)));
303 if List_Length
(Ranges
) = 1
304 and then Nkind
(First
(Ranges
)) in
306 N_Real_Range_Specification |
307 N_Signed_Integer_Type_Definition
309 if Id
= Attribute_First
then
312 (Low_Bound
(First
(Ranges
)), Str
);
316 (High_Bound
(First
(Ranges
)), Str
);
326 return ''' & Get_Name_String
(Attribute_Name
(Expr
));
329 when N_Explicit_Dereference
=>
330 Explicit_Dereference
: declare
331 function Deref_Suffix
return String;
332 -- Usually returns ".all", but will return "" if
333 -- Hide_Temp_Derefs is true and the prefix is a use of a
334 -- not-from-source object declared as
335 -- X : constant Some_Access_Type := Some_Expr'Reference;
336 -- (as is sometimes done in Exp_Util.Remove_Side_Effects).
342 function Deref_Suffix
return String is
347 and then Nkind
(Prefix
(Expr
)) = N_Identifier
348 and then Nkind
(Entity
(Prefix
(Expr
))) =
349 N_Defining_Identifier
351 Decl
:= Parent
(Entity
(Prefix
(Expr
)));
354 and then Nkind
(Decl
) = N_Object_Declaration
355 and then not Comes_From_Source
(Decl
)
356 and then Constant_Present
(Decl
)
357 and then Present
(Expression
(Decl
))
358 and then Nkind
(Expression
(Decl
)) = N_Reference
369 -- Start of processing for Explicit_Dereference
372 if Hide_Parameter_Blocks
373 and then Nkind
(Prefix
(Expr
)) = N_Selected_Component
374 and then Present
(Etype
(Prefix
(Expr
)))
375 and then Is_Access_Type
(Etype
(Prefix
(Expr
)))
376 and then Is_Param_Block_Component_Type
377 (Etype
(Prefix
(Expr
)))
379 -- Return "Foo" instead of "Parameter_Block.Foo.all"
381 return Expr_Name
(Selector_Name
(Prefix
(Expr
)));
383 elsif Take_Prefix
then
384 return Expr_Name
(Prefix
(Expr
)) & Deref_Suffix
;
388 end Explicit_Dereference
;
391 | N_Selected_Component
395 Expr_Name
(Prefix
(Expr
)) & "." &
396 Expr_Name
(Selector_Name
(Expr
));
398 return "." & Expr_Name
(Selector_Name
(Expr
));
401 when N_If_Expression
=>
403 Cond_Expr
: constant Node_Id
:= First
(Expressions
(Expr
));
404 Then_Expr
: constant Node_Id
:= Next
(Cond_Expr
);
405 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
408 "if " & Expr_Name
(Cond_Expr
) & " then "
409 & Expr_Name
(Then_Expr
) & " else "
410 & Expr_Name
(Else_Expr
);
413 when N_Qualified_Expression
=>
415 Mark
: constant String :=
417 (Subtype_Mark
(Expr
), Expand_Type
=> False);
418 Str
: constant String := Expr_Name
(Expression
(Expr
));
420 if Str
(Str
'First) = '(' and then Str
(Str
'Last) = ')' then
421 return Mark
& "'" & Str
;
423 return Mark
& "'(" & Str
& ")";
427 when N_Expression_With_Actions
428 | N_Unchecked_Expression
430 return Expr_Name
(Expression
(Expr
));
432 when N_Raise_Constraint_Error
=>
433 if Present
(Condition
(Expr
)) then
435 "[constraint_error when "
436 & Expr_Name
(Condition
(Expr
)) & "]";
438 return "[constraint_error]";
441 when N_Raise_Program_Error
=>
442 if Present
(Condition
(Expr
)) then
444 "[program_error when "
445 & Expr_Name
(Condition
(Expr
)) & "]";
447 return "[program_error]";
450 when N_Raise_Storage_Error
=>
451 if Present
(Condition
(Expr
)) then
453 "[storage_error when "
454 & Expr_Name
(Condition
(Expr
)) & "]";
456 return "[storage_error]";
461 Expr_Name
(Low_Bound
(Expr
)) & ".." &
462 Expr_Name
(High_Bound
(Expr
));
466 Expr_Name
(Prefix
(Expr
)) & " (" &
467 Expr_Name
(Discrete_Range
(Expr
)) & ")";
471 Expr_Name
(Left_Opnd
(Expr
)) & " and then " &
472 Expr_Name
(Right_Opnd
(Expr
));
476 Expr_Name
(Left_Opnd
(Expr
)) & " in " &
477 Expr_Name
(Right_Opnd
(Expr
));
481 Expr_Name
(Left_Opnd
(Expr
)) & " not in " &
482 Expr_Name
(Right_Opnd
(Expr
));
486 Expr_Name
(Left_Opnd
(Expr
)) & " or else " &
487 Expr_Name
(Right_Opnd
(Expr
));
491 Expr_Name
(Left_Opnd
(Expr
)) & " and " &
492 Expr_Name
(Right_Opnd
(Expr
));
496 Expr_Name
(Left_Opnd
(Expr
)) & " or " &
497 Expr_Name
(Right_Opnd
(Expr
));
501 Expr_Name
(Left_Opnd
(Expr
)) & " xor " &
502 Expr_Name
(Right_Opnd
(Expr
));
506 Expr_Name
(Left_Opnd
(Expr
)) & " = " &
507 Expr_Name
(Right_Opnd
(Expr
));
511 Expr_Name
(Left_Opnd
(Expr
)) & " /= " &
512 Expr_Name
(Right_Opnd
(Expr
));
516 Expr_Name
(Left_Opnd
(Expr
)) & " < " &
517 Expr_Name
(Right_Opnd
(Expr
));
521 Expr_Name
(Left_Opnd
(Expr
)) & " <= " &
522 Expr_Name
(Right_Opnd
(Expr
));
526 Expr_Name
(Left_Opnd
(Expr
)) & " > " &
527 Expr_Name
(Right_Opnd
(Expr
));
531 Expr_Name
(Left_Opnd
(Expr
)) & " >= " &
532 Expr_Name
(Right_Opnd
(Expr
));
536 Expr_Name
(Left_Opnd
(Expr
)) & " + " &
537 Expr_Name
(Right_Opnd
(Expr
));
539 when N_Op_Subtract
=>
541 Expr_Name
(Left_Opnd
(Expr
)) & " - " &
542 Expr_Name
(Right_Opnd
(Expr
));
544 when N_Op_Multiply
=>
546 Expr_Name
(Left_Opnd
(Expr
)) & " * " &
547 Expr_Name
(Right_Opnd
(Expr
));
551 Expr_Name
(Left_Opnd
(Expr
)) & " / " &
552 Expr_Name
(Right_Opnd
(Expr
));
556 Expr_Name
(Left_Opnd
(Expr
)) & " mod " &
557 Expr_Name
(Right_Opnd
(Expr
));
561 Expr_Name
(Left_Opnd
(Expr
)) & " rem " &
562 Expr_Name
(Right_Opnd
(Expr
));
566 Expr_Name
(Left_Opnd
(Expr
)) & " ** " &
567 Expr_Name
(Right_Opnd
(Expr
));
569 when N_Op_Shift_Left
=>
571 Expr_Name
(Left_Opnd
(Expr
)) & " << " &
572 Expr_Name
(Right_Opnd
(Expr
));
574 when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic
=>
576 Expr_Name
(Left_Opnd
(Expr
)) & " >> " &
577 Expr_Name
(Right_Opnd
(Expr
));
581 Expr_Name
(Left_Opnd
(Expr
)) & " & " &
582 Expr_Name
(Right_Opnd
(Expr
));
585 return "+" & Expr_Name
(Right_Opnd
(Expr
));
588 return "-" & Expr_Name
(Right_Opnd
(Expr
));
591 return "abs " & Expr_Name
(Right_Opnd
(Expr
));
594 return "not (" & Expr_Name
(Right_Opnd
(Expr
)) & ")";
596 when N_Type_Conversion
=>
598 -- Most conversions are not very interesting (used inside
599 -- expanded checks to convert to larger ranges), so skip them.
601 return Expr_Name
(Expression
(Expr
));
603 when N_Unchecked_Type_Conversion
=>
605 -- Only keep the type conversion in complex cases
607 if not Is_Scalar_Type
(Etype
(Expr
))
608 or else not Is_Scalar_Type
(Etype
(Expression
(Expr
)))
609 or else Is_Modular_Integer_Type
(Etype
(Expr
)) /=
610 Is_Modular_Integer_Type
(Etype
(Expression
(Expr
)))
612 return Expr_Name
(Subtype_Mark
(Expr
)) &
613 "(" & Expr_Name
(Expression
(Expr
)) & ")";
615 return Expr_Name
(Expression
(Expr
));
618 when N_Indexed_Component
=>
621 Expr_Name
(Prefix
(Expr
))
622 & " (" & List_Name
(Expressions
(Expr
)) & ')';
624 return List_Name
(Expressions
(Expr
));
627 when N_Function_Call
=>
629 -- If Default = "", it means we're expanding the name of
630 -- a gnat temporary (and not really a function call), so add
631 -- parentheses around function call to mark it specially.
634 if Present
(Parameter_Associations
(Expr
)) then
636 & Expr_Name
(Name
(Expr
))
638 & List_Name
(Parameter_Associations
(Expr
))
641 return '(' & Expr_Name
(Name
(Expr
)) & ')';
643 elsif Present
(Parameter_Associations
(Expr
)) then
645 Expr_Name
(Name
(Expr
))
646 & " (" & List_Name
(Parameter_Associations
(Expr
)) & ')';
648 return Expr_Name
(Name
(Expr
));
654 when N_Case_Expression
656 | N_Interpolated_String_Literal
660 | N_Procedure_Call_Statement
661 | N_Quantified_Expression
670 -----------------------
671 -- Count_Parentheses --
672 -----------------------
674 function Count_Parentheses
(S
: String; C
: Character) return Natural is
676 procedure Next_Char
(Count
: in out Natural; C
, D
, Ch
: Character);
677 -- Process next character Ch and update the number Count of C
678 -- characters to add for correct parenthesizing, where D is the
679 -- opposite parenthesis.
685 procedure Next_Char
(Count
: in out Natural; C
, D
, Ch
: Character) is
689 elsif Ch
= C
and then Count
> 0 then
696 Count
: Natural := 0;
698 -- Start of processing for Count_Parentheses
702 for Ch
of reverse S
loop
703 Next_Char
(Count
, C
, ')', Ch
);
707 Next_Char
(Count
, C
, '(', Ch
);
712 end Count_Parentheses
;
714 ---------------------
715 -- Fix_Parentheses --
716 ---------------------
718 function Fix_Parentheses
(S
: String) return String is
719 Count_Open
: constant Natural := Count_Parentheses
(S
, '(');
720 Count_Close
: constant Natural := Count_Parentheses
(S
, ')');
722 return (1 .. Count_Open
=> '(') & S
& (1 .. Count_Close
=> ')');
727 Left
, Right
: Source_Ptr
;
729 -- Start of processing for Expression_Image
732 -- Since this is an expression pretty-printer, it should not be called
733 -- for anything but an expression. However, currently CodePeer calls
734 -- it for defining identifiers. This should be fixed in the CodePeer
735 -- itself, but for now simply return the default (if present) or print
736 -- name of the defining identifier.
738 if Nkind
(Expr
) = N_Defining_Identifier
then
739 pragma Assert
(CodePeer_Mode
);
740 if Comes_From_Source
(Expr
)
741 or else Opt
.Debug_Generated_Code
745 Nam
: constant Name_Id
:= Chars
(Expr
);
747 (Max_Length
=> Natural (Length_Of_Name
(Nam
)));
749 Adjust_Name_Case
(Buf
, Sloc
(Expr
));
751 return To_String
(Buf
);
758 S
: constant String :=
760 (Expr
=> Expr
, Orig_Expr
=> Expr
, Expand_Type
=> True);
770 pragma Assert
(Nkind
(Expr
) in N_Subexpr
);
773 -- ??? The following should be primarily needed for CodePeer
775 if not Comes_From_Source
(Expr
)
776 or else Opt
.Debug_Generated_Code
779 S
: constant String := Expr_Name
(Expr
);
789 -- Reach to the underlying expression for an expression-with-actions
791 if Nkind
(Expr
) = N_Expression_With_Actions
then
792 return Expression_Image
(Expression
(Expr
), Default
);
795 -- Compute left (start) and right (end) slocs for the expression
797 Left
:= First_Sloc
(Expr
);
798 Right
:= Last_Sloc
(Expr
);
805 Scn
: Source_Ptr
:= Left
;
806 Src
: constant not null Source_Buffer_Ptr
:=
807 Source_Text
(Get_Source_File_Index
(Scn
));
809 Threshold
: constant := 256;
810 Buffer
: String (1 .. Natural (Right
- Left
+ 1));
811 Index
: Natural := 0;
812 Skipping_Comment
: Boolean := False;
813 Underscore
: Boolean := False;
815 while Scn
<= Right
loop
818 -- Give up on non ASCII characters
820 when Character'Val (128) .. Character'Last =>
827 if not Skipping_Comment
and then not Underscore
then
830 Buffer
(Index
) := ' ';
833 -- CR/LF/FF is the end of any comment
839 Skipping_Comment
:= False;
844 if not Skipping_Comment
then
848 if Src
(Scn
) = '-' and then Src
(Scn
+ 1) = '-' then
849 Skipping_Comment
:= True;
852 Buffer
(Index
) := Src
(Scn
);
857 -- Give up on too long strings
859 if Index
>= Threshold
then
860 return Buffer
(1 .. Index
) & "...";
866 return Fix_Parentheses
(Buffer
(1 .. Index
));
868 end Expression_Image
;