1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2008-2016, 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 =>
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_Unchecked_Type_Conversion =>
554 -- Only keep the type conversion in complex cases
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)))
561 return Expr_Name (Subtype_Mark (Expr)) &
562 "(" & Expr_Name (Expression (Expr)) & ")";
564 return Expr_Name (Expression (Expr));
567 when N_Indexed_Component =>
570 Expr_Name (Prefix (Expr))
571 & List_Name (First (Sinfo.Expressions (Expr)));
573 return List_Name (First (Sinfo.Expressions (Expr)));
576 when N_Function_Call =>
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.
584 & Expr_Name (Name (Expr))
585 & List_Name (First (Sinfo.Parameter_Associations (Expr)))
589 Expr_Name (Name (Expr))
591 (First (Sinfo.Parameter_Associations (Expr)));
597 when N_Others_Choice =>
605 -- Start of processing for Expression_Name
608 if not From_Source then
610 S : constant String := Expr_Name (Expr);
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???
630 Left := Original_Node (Left_Opnd (Left));
632 when N_Attribute_Reference |
634 N_Explicit_Dereference |
635 N_Indexed_Component |
637 N_Selected_Component |
639 Left := Original_Node (Prefix (Left));
641 when N_Defining_Program_Unit_Name |
644 Left := Original_Node (Name (Left));
647 Left := Original_Node (Low_Bound (Left));
649 when N_Type_Conversion =>
650 Left := Original_Node (Subtype_Mark (Left));
652 -- For any other item, quit loop
660 case Nkind (Right) is
665 Right := Original_Node (Right_Opnd (Right));
667 when N_Expanded_Name |
668 N_Selected_Component =>
669 Right := Original_Node (Selector_Name (Right));
672 Right := Original_Node (Identifier (Right));
674 when N_Defining_Program_Unit_Name =>
675 Right := Original_Node (Defining_Identifier (Right));
678 Right := Original_Node (High_Bound (Right));
680 when N_Parameter_Association =>
681 Right := Original_Node (Explicit_Actual_Parameter (Right));
683 when N_Indexed_Component =>
684 Right := Original_Node (Last (Sinfo.Expressions (Right)));
685 Append_Paren := True;
687 when N_Function_Call =>
688 if Present (Sinfo.Parameter_Associations (Right)) then
694 -- Avoid source position confusion associated with
695 -- parameters for which Comes_From_Source is False.
697 Rover := First (Sinfo.Parameter_Associations (Right));
699 while Present (Rover) loop
700 if Comes_From_Source (Original_Node (Rover)) then
701 Right := Original_Node (Rover);
702 Append_Paren := True;
709 -- Quit loop if no Comes_From_Source parameters
714 -- Quit loop if no parameters
720 when N_Quantified_Expression =>
721 Right := Original_Node (Condition (Right));
723 -- For all other items, quit the loop
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));
738 if Scn > End_Sloc then
743 Buffer : String (1 .. Natural (End_Sloc - Scn));
744 Index : Natural := 0;
745 Skipping_Comment : Boolean := False;
746 Underscore : Boolean := False;
749 if Right /= Expr then
750 while Scn < End_Sloc loop
752 when ' ' | ASCII.HT =>
753 if not Skipping_Comment and then not Underscore then
756 Buffer (Index) := ' ';
759 -- CR/LF/FF is the end of any comment
761 when ASCII.LF | ASCII.CR | ASCII.FF =>
762 Skipping_Comment := False;
767 if not Skipping_Comment then
771 if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
772 Skipping_Comment := True;
776 Buffer (Index) := Src (Scn);
787 S : constant String := Expr_Name (Right);
796 elsif Append_Paren then
797 return Buffer (1 .. Index) & Expr_Name (Right, False) & ')';
800 return Buffer (1 .. Index) & Expr_Name (Right, False);
804 end Expression_Image;