1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2008-2015, 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 Namet
; use Namet
;
29 with Nlists
; use Nlists
;
31 with Sinfo
; use Sinfo
;
32 with Sinput
; use Sinput
;
33 with Snames
; use Snames
;
34 with Uintp
; use Uintp
;
36 package body Pprint
is
38 List_Name_Count
: Integer := 0;
39 -- Counter used to prevent infinite recursion while computing name of
40 -- complex expressions.
42 ----------------------
43 -- Expression_Image --
44 ----------------------
46 function Expression_Image
48 Default
: String) return String
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
);
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 Max_List
: constant := 3;
68 -- Limit number of list elements to dump
70 Max_Expr_Elements
: constant := 24;
71 -- Limit number of elements in an expression for use by Expr_Name
73 Num_Elements
: Natural := 0;
74 -- Current number of elements processed by Expr_Name
78 Add_Space
: Boolean := True;
79 Add_Paren
: Boolean := True) return String;
80 -- Return a string corresponding to List
88 Add_Space
: Boolean := True;
89 Add_Paren
: Boolean := True) return String
91 function Internal_List_Name
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
99 ------------------------
100 -- Internal_List_Name --
101 ------------------------
103 function Internal_List_Name
105 First
: Boolean := True;
106 Add_Space
: Boolean := True;
107 Add_Paren
: Boolean := True;
108 Num
: Natural := 1) return String
110 function Prepend
(S
: String) return String;
111 -- ??? what does this do
117 function Prepend
(S
: String) return String is
132 -- Start of processing for Internal_List_Name
135 if not Present
(List
) then
136 if First
or else not Add_Paren
then
141 elsif Num
> Max_List
then
149 -- ??? the Internal_List_Name calls can be factored out
152 return Prepend
(Expr_Name
(List
)
154 (List
=> Next
(List
),
156 Add_Paren
=> Add_Paren
,
159 return ", " & Expr_Name
(List
)
161 (List
=> Next
(List
),
163 Add_Paren
=> Add_Paren
,
166 end Internal_List_Name
;
168 -- Start of processing for List_Name
171 -- Prevent infinite recursion by limiting depth to 3
173 if List_Name_Count
> 3 then
177 List_Name_Count
:= List_Name_Count
+ 1;
180 Result
: constant String :=
183 Add_Space
=> Add_Space
,
184 Add_Paren
=> Add_Paren
);
186 List_Name_Count
:= List_Name_Count
- 1;
197 Take_Prefix
: Boolean := True;
198 Expand_Type
: Boolean := True) return String
201 Num_Elements
:= Num_Elements
+ 1;
203 if Num_Elements
> Max_Expr_Elements
then
208 when N_Defining_Identifier | N_Identifier
=>
209 return Ident_Image
(Expr
, Expression_Image
.Expr
, Expand_Type
);
211 when N_Character_Literal
=>
213 Char
: constant Int
:=
214 UI_To_Int
(Char_Literal_Value
(Expr
));
216 if Char
in 32 .. 127 then
217 return "'" & Character'Val (Char
) & "'";
219 UI_Image
(Char_Literal_Value
(Expr
));
221 "'\" & UI_Image_Buffer (1 .. UI_Image_Length) & "'";
225 when N_Integer_Literal =>
226 UI_Image (Intval (Expr));
227 return UI_Image_Buffer (1 .. UI_Image_Length);
229 when N_Real_Literal =>
230 return Real_Image (Realval (Expr));
232 when N_String_Literal =>
233 return String_Image (Strval (Expr));
236 return "new " & Expr_Name (Expression (Expr));
239 if Present (Sinfo.Expressions (Expr)) then
242 (List => First (Sinfo.Expressions (Expr)),
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.
250 elsif Null_Record_Present (Expr)
251 or else not Present (First (Component_Associations (Expr)))
253 return ("(null record)");
258 (List => First (Component_Associations (Expr)),
263 when N_Extension_Aggregate =>
264 return "(" & Expr_Name (Ancestor_Part (Expr)) & " with "
266 (List => First (Sinfo.Expressions (Expr)),
268 Add_Paren => False) & ")";
270 when N_Attribute_Reference =>
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));
282 if (Id = Attribute_First or else Id = Attribute_Last)
283 and then Str (Str'First) = '$'
285 N := Associated_Node_For_Itype (Etype (Prefix (Expr)));
288 if Nkind (N) = N_Full_Type_Declaration then
289 N := Type_Definition (N);
292 if Nkind (N) = N_Subtype_Declaration then
295 (Constraint (Subtype_Indication (N)));
297 if List_Length (Ranges) = 1
302 N_Real_Range_Specification,
303 N_Signed_Integer_Type_Definition)
305 if Id = Attribute_First then
308 (Low_Bound (First (Ranges)), Str);
312 (High_Bound (First (Ranges)), Str);
322 return "'" & Get_Name_String (Attribute_Name (Expr));
325 when N_Explicit_Dereference =>
327 -- Return "Foo" instead of "Parameter_Block.Foo.all"
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)))
335 return Expr_Name (Selector_Name (Prefix (Expr)));
337 elsif Take_Prefix then
338 return Expr_Name (Prefix (Expr)) & ".all";
343 when N_Expanded_Name | N_Selected_Component =>
346 Expr_Name (Prefix (Expr)) & "." &
347 Expr_Name (Selector_Name (Expr));
349 return "." & Expr_Name (Selector_Name (Expr));
352 when N_Component_Association =>
355 (List => First (Choices (Expr)),
358 & " => " & Expr_Name (Expression (Expr)) & ")";
360 when N_If_Expression =>
362 N : constant Node_Id := First (Sinfo.Expressions (Expr));
365 "if " & Expr_Name (N) & " then "
366 & Expr_Name (Next (N)) & " else "
367 & Expr_Name (Next (Next (N)));
370 when N_Qualified_Expression =>
372 Mark : constant String :=
374 (Subtype_Mark (Expr), Expand_Type => False);
375 Str : constant String := Expr_Name (Expression (Expr));
377 if Str (Str'First) = '(' and then Str (Str'Last) = ')' then
378 return Mark & "'" & Str;
380 return Mark & "'(" & Str & ")";
384 when N_Unchecked_Expression | N_Expression_With_Actions =>
385 return Expr_Name (Expression (Expr));
387 when N_Raise_Constraint_Error =>
388 if Present (Condition (Expr)) then
390 "[constraint_error when "
391 & Expr_Name (Condition (Expr)) & "]";
393 return "[constraint_error]";
396 when N_Raise_Program_Error =>
397 if Present (Condition (Expr)) then
399 "[program_error when "
400 & Expr_Name (Condition (Expr)) & "]";
402 return "[program_error]";
407 Expr_Name (Low_Bound (Expr)) & ".." &
408 Expr_Name (High_Bound (Expr));
412 Expr_Name (Prefix (Expr)) & " (" &
413 Expr_Name (Discrete_Range (Expr)) & ")";
417 Expr_Name (Left_Opnd (Expr)) & " and then " &
418 Expr_Name (Right_Opnd (Expr));
422 Expr_Name (Left_Opnd (Expr)) & " in " &
423 Expr_Name (Right_Opnd (Expr));
427 Expr_Name (Left_Opnd (Expr)) & " not in " &
428 Expr_Name (Right_Opnd (Expr));
432 Expr_Name (Left_Opnd (Expr)) & " or else " &
433 Expr_Name (Right_Opnd (Expr));
437 Expr_Name (Left_Opnd (Expr)) & " and " &
438 Expr_Name (Right_Opnd (Expr));
442 Expr_Name (Left_Opnd (Expr)) & " or " &
443 Expr_Name (Right_Opnd (Expr));
447 Expr_Name (Left_Opnd (Expr)) & " xor " &
448 Expr_Name (Right_Opnd (Expr));
452 Expr_Name (Left_Opnd (Expr)) & " = " &
453 Expr_Name (Right_Opnd (Expr));
457 Expr_Name (Left_Opnd (Expr)) & " /= " &
458 Expr_Name (Right_Opnd (Expr));
462 Expr_Name (Left_Opnd (Expr)) & " < " &
463 Expr_Name (Right_Opnd (Expr));
467 Expr_Name (Left_Opnd (Expr)) & " <= " &
468 Expr_Name (Right_Opnd (Expr));
472 Expr_Name (Left_Opnd (Expr)) & " > " &
473 Expr_Name (Right_Opnd (Expr));
477 Expr_Name (Left_Opnd (Expr)) & " >= " &
478 Expr_Name (Right_Opnd (Expr));
482 Expr_Name (Left_Opnd (Expr)) & " + " &
483 Expr_Name (Right_Opnd (Expr));
485 when N_Op_Subtract =>
487 Expr_Name (Left_Opnd (Expr)) & " - " &
488 Expr_Name (Right_Opnd (Expr));
490 when N_Op_Multiply =>
492 Expr_Name (Left_Opnd (Expr)) & " * " &
493 Expr_Name (Right_Opnd (Expr));
497 Expr_Name (Left_Opnd (Expr)) & " / " &
498 Expr_Name (Right_Opnd (Expr));
502 Expr_Name (Left_Opnd (Expr)) & " mod " &
503 Expr_Name (Right_Opnd (Expr));
507 Expr_Name (Left_Opnd (Expr)) & " rem " &
508 Expr_Name (Right_Opnd (Expr));
512 Expr_Name (Left_Opnd (Expr)) & " ** " &
513 Expr_Name (Right_Opnd (Expr));
515 when N_Op_Shift_Left =>
517 Expr_Name (Left_Opnd (Expr)) & " << " &
518 Expr_Name (Right_Opnd (Expr));
520 when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic =>
522 Expr_Name (Left_Opnd (Expr)) & " >> " &
523 Expr_Name (Right_Opnd (Expr));
527 Expr_Name (Left_Opnd (Expr)) & " & " &
528 Expr_Name (Right_Opnd (Expr));
531 return "+" & Expr_Name (Right_Opnd (Expr));
534 return "-" & Expr_Name (Right_Opnd (Expr));
537 return "abs " & Expr_Name (Right_Opnd (Expr));
540 return "not (" & Expr_Name (Right_Opnd (Expr)) & ")";
542 when N_Parameter_Association =>
543 return Expr_Name (Explicit_Actual_Parameter (Expr));
545 when N_Type_Conversion | N_Unchecked_Type_Conversion =>
547 -- Most conversions are not very interesting (used inside
548 -- expanded checks to convert to larger ranges), so skip them.
550 return Expr_Name (Expression (Expr));
552 when N_Indexed_Component =>
555 Expr_Name (Prefix (Expr))
556 & List_Name (First (Sinfo.Expressions (Expr)));
558 return List_Name (First (Sinfo.Expressions (Expr)));
561 when N_Function_Call =>
563 -- If Default = "", it means we're expanding the name of
564 -- a gnat temporary (and not really a function call), so add
565 -- parentheses around function call to mark it specially.
569 & Expr_Name (Name (Expr))
570 & List_Name (First (Sinfo.Parameter_Associations (Expr)))
574 Expr_Name (Name (Expr))
576 (First (Sinfo.Parameter_Associations (Expr)));
582 when N_Others_Choice =>
590 -- Start of processing for Expression_Name
593 if not From_Source then
595 S : constant String := Expr_Name (Expr);
605 -- Compute left (start) and right (end) slocs for the expression
606 -- Consider using Sinput.Sloc_Range instead, except that it does not
607 -- work properly currently???
615 Left := Original_Node (Left_Opnd (Left));
617 when N_Attribute_Reference |
619 N_Explicit_Dereference |
620 N_Indexed_Component |
622 N_Selected_Component |
624 Left := Original_Node (Prefix (Left));
626 when N_Defining_Program_Unit_Name |
629 Left := Original_Node (Name (Left));
632 Left := Original_Node (Low_Bound (Left));
634 when N_Type_Conversion =>
635 Left := Original_Node (Subtype_Mark (Left));
637 -- For any other item, quit loop
645 case Nkind (Right) is
650 Right := Original_Node (Right_Opnd (Right));
652 when N_Expanded_Name |
653 N_Selected_Component =>
654 Right := Original_Node (Selector_Name (Right));
657 Right := Original_Node (Identifier (Right));
659 when N_Defining_Program_Unit_Name =>
660 Right := Original_Node (Defining_Identifier (Right));
663 Right := Original_Node (High_Bound (Right));
665 when N_Parameter_Association =>
666 Right := Original_Node (Explicit_Actual_Parameter (Right));
668 when N_Indexed_Component =>
669 Right := Original_Node (Last (Sinfo.Expressions (Right)));
670 Append_Paren := True;
672 when N_Function_Call =>
673 if Present (Sinfo.Parameter_Associations (Right)) then
679 -- Avoid source position confusion associated with
680 -- parameters for which Comes_From_Source is False.
682 Rover := First (Sinfo.Parameter_Associations (Right));
684 while Present (Rover) loop
685 if Comes_From_Source (Original_Node (Rover)) then
686 Right := Original_Node (Rover);
687 Append_Paren := True;
694 -- Quit loop if no Comes_From_Source parameters
699 -- Quit loop if no parameters
705 when N_Quantified_Expression =>
706 Right := Original_Node (Condition (Right));
708 -- For all other items, quit the loop
716 Scn : Source_Ptr := Original_Location (Sloc (Left));
717 End_Sloc : constant Source_Ptr :=
718 Original_Location (Sloc (Right));
719 Src : constant Source_Buffer_Ptr :=
720 Source_Text (Get_Source_File_Index (Scn));
723 if Scn > End_Sloc then
728 Buffer : String (1 .. Natural (End_Sloc - Scn));
729 Index : Natural := 0;
730 Skipping_Comment : Boolean := False;
731 Underscore : Boolean := False;
734 if Right /= Expr then
735 while Scn < End_Sloc loop
737 when ' ' | ASCII.HT =>
738 if not Skipping_Comment and then not Underscore then
741 Buffer (Index) := ' ';
744 -- CR/LF/FF is the end of any comment
746 when ASCII.LF | ASCII.CR | ASCII.FF =>
747 Skipping_Comment := False;
752 if not Skipping_Comment then
756 if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
757 Skipping_Comment := True;
761 Buffer (Index) := Src (Scn);
772 S : constant String := Expr_Name (Right);
781 elsif Append_Paren then
782 return Buffer (1 .. Index) & Expr_Name (Right, False) & ')';
785 return Buffer (1 .. Index) & Expr_Name (Right, False);
789 end Expression_Image;