------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- P P R I N T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008-2024, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; with Errout; use Errout; with Namet; use Namet; with Nlists; use Nlists; with Opt; use Opt; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; with Sinput; use Sinput; with Snames; use Snames; with Uintp; use Uintp; with System.Case_Util; package body Pprint is List_Name_Count : Natural := 0; -- Counter used to prevent infinite recursion while computing name of -- complex expressions. ---------------------- -- Expression_Image -- ---------------------- function Expression_Image (Expr : Node_Id; Default : String) return String is function Expr_Name (Expr : Node_Id; Take_Prefix : Boolean := True; Expand_Type : Boolean := True) return String; -- Return string corresponding to Expr. If no string can be extracted, -- return "...". If Take_Prefix is True, go back to prefix when needed, -- otherwise only consider the right-hand side of an expression. If -- Expand_Type is True and Expr is a type, try to expand Expr (an -- internally generated type) into a user understandable name. function Count_Parentheses (S : String; C : Character) return Natural with Pre => C in '(' | ')'; -- Returns the number of times parenthesis character C should be added -- to string S for getting a correctly parenthesized result. For C = '(' -- this means prepending the character, for C = ')' this means appending -- the character. function Fix_Parentheses (S : String) return String; -- Counts the number of required opening and closing parentheses in S to -- respectively prepend and append for getting correct parentheses. Then -- returns S with opening parentheses prepended and closing parentheses -- appended so that the result is correctly parenthesized. Max_List_Depth : constant := 3; -- Limit number of nested lists to print Max_List_Length : constant := 3; -- Limit number of list elements to print Max_Expr_Elements : constant := 24; -- Limit number of elements in an expression for use by Expr_Name Num_Elements : Natural := 0; -- Current number of elements processed by Expr_Name function List_Name (List : List_Id) return String; -- Return a string corresponding to List --------------- -- List_Name -- --------------- function List_Name (List : List_Id) return String is Buf : Bounded_String; Elmt : Node_Id; Printed_Elmts : Natural := 0; begin -- Give up if the printed list is too deep if List_Name_Count > Max_List_Depth then return "..."; end if; List_Name_Count := List_Name_Count + 1; Elmt := First (List); while Present (Elmt) loop -- Print component_association as "x | y | z => 12345" if Nkind (Elmt) = N_Component_Association then declare Choice : Node_Id := First (Choices (Elmt)); begin while Present (Choice) loop Append (Buf, Expr_Name (Choice)); Next (Choice); if Present (Choice) then Append (Buf, " | "); end if; end loop; end; Append (Buf, " => "); if Box_Present (Elmt) then Append (Buf, "<>"); else Append (Buf, Expr_Name (Expression (Elmt))); end if; -- Print parameter_association as "x => 12345" elsif Nkind (Elmt) = N_Parameter_Association then Append (Buf, Expr_Name (Selector_Name (Elmt))); Append (Buf, " => "); Append (Buf, Expr_Name (Explicit_Actual_Parameter (Elmt))); -- Print expression itself as "12345" else Append (Buf, Expr_Name (Elmt)); end if; Next (Elmt); Printed_Elmts := Printed_Elmts + 1; -- Separate next element with a comma, if necessary if Present (Elmt) then Append (Buf, ", "); -- Abbreviate remaining elements as "...", if limit exceeded if Printed_Elmts = Max_List_Length then Append (Buf, "..."); exit; end if; end if; end loop; List_Name_Count := List_Name_Count - 1; return To_String (Buf); end List_Name; --------------- -- Expr_Name -- --------------- function Expr_Name (Expr : Node_Id; Take_Prefix : Boolean := True; Expand_Type : Boolean := True) return String is begin Num_Elements := Num_Elements + 1; if Num_Elements > Max_Expr_Elements then return "..."; end if; -- Just print pieces of aggregate nodes, even though they are not -- expressions. It is too much trouble to handle them any better. if Nkind (Expr) = N_Component_Association then pragma Assert (Box_Present (Expr)); declare Buf : Bounded_String; Choice : Node_Id := First (Choices (Expr)); begin while Present (Choice) loop Append (Buf, Expr_Name (Choice)); Next (Choice); if Present (Choice) then Append (Buf, " | "); end if; end loop; Append (Buf, " => <>"); return To_String (Buf); end; elsif Nkind (Expr) = N_Others_Choice then return "others"; end if; case N_Subexpr'(Nkind (Expr)) is when N_Identifier => return Ident_Image (Expr, Expression_Image.Expr, Expand_Type); when N_Character_Literal => declare Char : constant Int := UI_To_Int (Char_Literal_Value (Expr)); begin if Char in 32 .. 126 then return "'" & Character'Val (Char) & "'"; else UI_Image (Char_Literal_Value (Expr)); return "'\" & UI_Image_Buffer (1 .. UI_Image_Length) & "'"; end if; end; when N_Integer_Literal => return UI_Image (Intval (Expr)); when N_Real_Literal => return Real_Image (Realval (Expr)); when N_String_Literal => return String_Image (Strval (Expr)); when N_Allocator => return "new " & Expr_Name (Expression (Expr)); when N_Aggregate => if Present (Expressions (Expr)) then return '(' & List_Name (Expressions (Expr)) & ')'; -- Do not return empty string for (others => <>) aggregate -- of a componentless record type. At least one caller (the -- recursive call below in the N_Qualified_Expression case) -- is not prepared to deal with a zero-length result. elsif Null_Record_Present (Expr) or else No (First (Component_Associations (Expr))) then return ("(null record)"); else return '(' & List_Name (Component_Associations (Expr)) & ')'; end if; when N_Extension_Aggregate => return '(' & Expr_Name (Ancestor_Part (Expr)) & " with (" & List_Name (Expressions (Expr)) & ')'; when N_Attribute_Reference => if Take_Prefix then declare Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (Expr)); -- Always use mixed case for attributes Str : constant String := Expr_Name (Prefix (Expr)) & "'" & System.Case_Util.To_Mixed (Get_Name_String (Attribute_Name (Expr))); N : Node_Id; Ranges : List_Id; begin if (Id = Attribute_First or else Id = Attribute_Last) and then Str (Str'First) = '$' then N := Associated_Node_For_Itype (Etype (Prefix (Expr))); if Present (N) then if Nkind (N) = N_Full_Type_Declaration then N := Type_Definition (N); end if; if Nkind (N) = N_Subtype_Declaration then Ranges := Constraints (Constraint (Subtype_Indication (N))); if List_Length (Ranges) = 1 and then Nkind (First (Ranges)) in N_Range | N_Real_Range_Specification | N_Signed_Integer_Type_Definition then if Id = Attribute_First then return Expression_Image (Low_Bound (First (Ranges)), Str); else return Expression_Image (High_Bound (First (Ranges)), Str); end if; end if; end if; end if; end if; return Str; end; else return ''' & Get_Name_String (Attribute_Name (Expr)); end if; when N_Explicit_Dereference => Explicit_Dereference : declare function Deref_Suffix return String; -- Usually returns ".all", but will return "" if -- Hide_Temp_Derefs is true and the prefix is a use of a -- not-from-source object declared as -- X : constant Some_Access_Type := Some_Expr'Reference; -- (as is sometimes done in Exp_Util.Remove_Side_Effects). ------------------ -- Deref_Suffix -- ------------------ function Deref_Suffix return String is Decl : Node_Id; begin if Hide_Temp_Derefs and then Nkind (Prefix (Expr)) = N_Identifier and then Nkind (Entity (Prefix (Expr))) = N_Defining_Identifier then Decl := Parent (Entity (Prefix (Expr))); if Present (Decl) and then Nkind (Decl) = N_Object_Declaration and then not Comes_From_Source (Decl) and then Constant_Present (Decl) and then Present (Expression (Decl)) and then Nkind (Expression (Decl)) = N_Reference then return ""; end if; end if; -- The default case return ".all"; end Deref_Suffix; -- Start of processing for Explicit_Dereference begin if Hide_Parameter_Blocks and then Nkind (Prefix (Expr)) = N_Selected_Component and then Present (Etype (Prefix (Expr))) and then Is_Access_Type (Etype (Prefix (Expr))) and then Is_Param_Block_Component_Type (Etype (Prefix (Expr))) then -- Return "Foo" instead of "Parameter_Block.Foo.all" return Expr_Name (Selector_Name (Prefix (Expr))); elsif Take_Prefix then return Expr_Name (Prefix (Expr)) & Deref_Suffix; else return Deref_Suffix; end if; end Explicit_Dereference; when N_Expanded_Name | N_Selected_Component => if Take_Prefix then return Expr_Name (Prefix (Expr)) & "." & Expr_Name (Selector_Name (Expr)); else return "." & Expr_Name (Selector_Name (Expr)); end if; when N_If_Expression => declare Cond_Expr : constant Node_Id := First (Expressions (Expr)); Then_Expr : constant Node_Id := Next (Cond_Expr); Else_Expr : constant Node_Id := Next (Then_Expr); begin return "if " & Expr_Name (Cond_Expr) & " then " & Expr_Name (Then_Expr) & " else " & Expr_Name (Else_Expr); end; when N_Qualified_Expression => declare Mark : constant String := Expr_Name (Subtype_Mark (Expr), Expand_Type => False); Str : constant String := Expr_Name (Expression (Expr)); begin if Str (Str'First) = '(' and then Str (Str'Last) = ')' then return Mark & "'" & Str; else return Mark & "'(" & Str & ")"; end if; end; when N_Expression_With_Actions => return Expr_Name (Expression (Expr)); when N_Raise_Constraint_Error => if Present (Condition (Expr)) then return "[constraint_error when " & Expr_Name (Condition (Expr)) & "]"; else return "[constraint_error]"; end if; when N_Raise_Program_Error => if Present (Condition (Expr)) then return "[program_error when " & Expr_Name (Condition (Expr)) & "]"; else return "[program_error]"; end if; when N_Raise_Storage_Error => if Present (Condition (Expr)) then return "[storage_error when " & Expr_Name (Condition (Expr)) & "]"; else return "[storage_error]"; end if; when N_Range => return Expr_Name (Low_Bound (Expr)) & ".." & Expr_Name (High_Bound (Expr)); when N_Slice => return Expr_Name (Prefix (Expr)) & " (" & Expr_Name (Discrete_Range (Expr)) & ")"; when N_And_Then => return Expr_Name (Left_Opnd (Expr)) & " and then " & Expr_Name (Right_Opnd (Expr)); when N_In => return Expr_Name (Left_Opnd (Expr)) & " in " & Expr_Name (Right_Opnd (Expr)); when N_Not_In => return Expr_Name (Left_Opnd (Expr)) & " not in " & Expr_Name (Right_Opnd (Expr)); when N_Or_Else => return Expr_Name (Left_Opnd (Expr)) & " or else " & Expr_Name (Right_Opnd (Expr)); when N_Op_And => return Expr_Name (Left_Opnd (Expr)) & " and " & Expr_Name (Right_Opnd (Expr)); when N_Op_Or => return Expr_Name (Left_Opnd (Expr)) & " or " & Expr_Name (Right_Opnd (Expr)); when N_Op_Xor => return Expr_Name (Left_Opnd (Expr)) & " xor " & Expr_Name (Right_Opnd (Expr)); when N_Op_Eq => return Expr_Name (Left_Opnd (Expr)) & " = " & Expr_Name (Right_Opnd (Expr)); when N_Op_Ne => return Expr_Name (Left_Opnd (Expr)) & " /= " & Expr_Name (Right_Opnd (Expr)); when N_Op_Lt => return Expr_Name (Left_Opnd (Expr)) & " < " & Expr_Name (Right_Opnd (Expr)); when N_Op_Le => return Expr_Name (Left_Opnd (Expr)) & " <= " & Expr_Name (Right_Opnd (Expr)); when N_Op_Gt => return Expr_Name (Left_Opnd (Expr)) & " > " & Expr_Name (Right_Opnd (Expr)); when N_Op_Ge => return Expr_Name (Left_Opnd (Expr)) & " >= " & Expr_Name (Right_Opnd (Expr)); when N_Op_Add => return Expr_Name (Left_Opnd (Expr)) & " + " & Expr_Name (Right_Opnd (Expr)); when N_Op_Subtract => return Expr_Name (Left_Opnd (Expr)) & " - " & Expr_Name (Right_Opnd (Expr)); when N_Op_Multiply => return Expr_Name (Left_Opnd (Expr)) & " * " & Expr_Name (Right_Opnd (Expr)); when N_Op_Divide => return Expr_Name (Left_Opnd (Expr)) & " / " & Expr_Name (Right_Opnd (Expr)); when N_Op_Mod => return Expr_Name (Left_Opnd (Expr)) & " mod " & Expr_Name (Right_Opnd (Expr)); when N_Op_Rem => return Expr_Name (Left_Opnd (Expr)) & " rem " & Expr_Name (Right_Opnd (Expr)); when N_Op_Expon => return Expr_Name (Left_Opnd (Expr)) & " ** " & Expr_Name (Right_Opnd (Expr)); when N_Op_Shift_Left => return Expr_Name (Left_Opnd (Expr)) & " << " & Expr_Name (Right_Opnd (Expr)); when N_Op_Shift_Right | N_Op_Shift_Right_Arithmetic => return Expr_Name (Left_Opnd (Expr)) & " >> " & Expr_Name (Right_Opnd (Expr)); when N_Op_Concat => return Expr_Name (Left_Opnd (Expr)) & " & " & Expr_Name (Right_Opnd (Expr)); when N_Op_Plus => return "+" & Expr_Name (Right_Opnd (Expr)); when N_Op_Minus => return "-" & Expr_Name (Right_Opnd (Expr)); when N_Op_Abs => return "abs " & Expr_Name (Right_Opnd (Expr)); when N_Op_Not => return "not (" & Expr_Name (Right_Opnd (Expr)) & ")"; when N_Type_Conversion => -- Most conversions are not very interesting (used inside -- expanded checks to convert to larger ranges), so skip them. return Expr_Name (Expression (Expr)); when N_Unchecked_Type_Conversion => -- Only keep the type conversion in complex cases if not Is_Scalar_Type (Etype (Expr)) or else not Is_Scalar_Type (Etype (Expression (Expr))) or else Is_Modular_Integer_Type (Etype (Expr)) /= Is_Modular_Integer_Type (Etype (Expression (Expr))) then return Expr_Name (Subtype_Mark (Expr)) & "(" & Expr_Name (Expression (Expr)) & ")"; else return Expr_Name (Expression (Expr)); end if; when N_Indexed_Component => if Take_Prefix then return Expr_Name (Prefix (Expr)) & " (" & List_Name (Expressions (Expr)) & ')'; else return List_Name (Expressions (Expr)); end if; when N_Function_Call => -- If Default = "", it means we're expanding the name of -- a gnat temporary (and not really a function call), so add -- parentheses around function call to mark it specially. if Default = "" then if Present (Parameter_Associations (Expr)) then return '(' & Expr_Name (Name (Expr)) & " (" & List_Name (Parameter_Associations (Expr)) & "))"; else return '(' & Expr_Name (Name (Expr)) & ')'; end if; elsif Present (Parameter_Associations (Expr)) then return Expr_Name (Name (Expr)) & " (" & List_Name (Parameter_Associations (Expr)) & ')'; else return Expr_Name (Name (Expr)); end if; when N_Null => return "null"; when N_Case_Expression | N_Delta_Aggregate | N_External_Initializer | N_Interpolated_String_Literal | N_Op_Rotate_Left | N_Op_Rotate_Right | N_Operator_Symbol | N_Procedure_Call_Statement | N_Quantified_Expression | N_Raise_Expression | N_Reference | N_Target_Name => return "..."; end case; end Expr_Name; ----------------------- -- Count_Parentheses -- ----------------------- function Count_Parentheses (S : String; C : Character) return Natural is procedure Next_Char (Count : in out Natural; C, D, Ch : Character); -- Process next character Ch and update the number Count of C -- characters to add for correct parenthesizing, where D is the -- opposite parenthesis. --------------- -- Next_Char -- --------------- procedure Next_Char (Count : in out Natural; C, D, Ch : Character) is begin if Ch = D then Count := Count + 1; elsif Ch = C and then Count > 0 then Count := Count - 1; end if; end Next_Char; -- Local variables Count : Natural := 0; -- Start of processing for Count_Parentheses begin if C = '(' then for Ch of reverse S loop Next_Char (Count, C, ')', Ch); end loop; else for Ch of S loop Next_Char (Count, C, '(', Ch); end loop; end if; return Count; end Count_Parentheses; --------------------- -- Fix_Parentheses -- --------------------- function Fix_Parentheses (S : String) return String is Count_Open : constant Natural := Count_Parentheses (S, '('); Count_Close : constant Natural := Count_Parentheses (S, ')'); begin return (1 .. Count_Open => '(') & S & (1 .. Count_Close => ')'); end Fix_Parentheses; -- Local variables Left, Right : Source_Ptr; -- Start of processing for Expression_Image begin -- Since this is an expression pretty-printer, it should not be called -- for anything but an expression. However, currently CodePeer calls -- it for defining identifiers. This should be fixed in the CodePeer -- itself, but for now simply return the default (if present) or print -- name of the defining identifier. if Nkind (Expr) = N_Defining_Identifier then pragma Assert (CodePeer_Mode); if Comes_From_Source (Expr) or else Opt.Debug_Generated_Code then if Default = "" then declare Nam : constant Name_Id := Chars (Expr); Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Nam))); begin Adjust_Name_Case (Buf, Sloc (Expr)); Append (Buf, Nam); return To_String (Buf); end; else return Default; end if; else declare S : constant String := Ident_Image (Expr => Expr, Orig_Expr => Expr, Expand_Type => True); begin if S = "..." then return Default; else return S; end if; end; end if; else pragma Assert (Nkind (Expr) in N_Subexpr); end if; -- ??? The following should be primarily needed for CodePeer if not Comes_From_Source (Expr) or else Opt.Debug_Generated_Code then declare S : constant String := Expr_Name (Expr); begin if S = "..." then return Default; else return S; end if; end; end if; -- Reach to the underlying expression for an expression-with-actions if Nkind (Expr) = N_Expression_With_Actions then return Expression_Image (Expression (Expr), Default); end if; -- Compute left (start) and right (end) slocs for the expression Left := First_Sloc (Expr); Right := Last_Sloc (Expr); if Left > Right then return Default; end if; declare Scn : Source_Ptr := Left; Src : constant not null Source_Buffer_Ptr := Source_Text (Get_Source_File_Index (Scn)); Threshold : constant := 256; Buffer : String (1 .. Natural (Right - Left + 1)); Index : Natural := 0; Skipping_Comment : Boolean := False; Underscore : Boolean := False; begin while Scn <= Right loop case Src (Scn) is -- Give up on non ASCII characters when Character'Val (128) .. Character'Last => Index := 0; exit; when ' ' | ASCII.HT => if not Skipping_Comment and then not Underscore then Underscore := True; Index := Index + 1; Buffer (Index) := ' '; end if; -- CR/LF/FF is the end of any comment when ASCII.CR | ASCII.FF | ASCII.LF => Skipping_Comment := False; when others => Underscore := False; if not Skipping_Comment then -- Ignore comment if Src (Scn) = '-' and then Src (Scn + 1) = '-' then Skipping_Comment := True; else Index := Index + 1; Buffer (Index) := Src (Scn); end if; end if; end case; -- Give up on too long strings if Index >= Threshold then return Buffer (1 .. Index) & "..."; end if; Scn := Scn + 1; end loop; return Fix_Parentheses (Buffer (1 .. Index)); end; end Expression_Image; end Pprint;