| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P P R I N T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2008-2012, 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 Namet; use Namet; |
| with Nlists; use Nlists; |
| with Opt; use Opt; |
| with Sinfo; use Sinfo; |
| with Sinput; use Sinput; |
| with Snames; use Snames; |
| with Uintp; use Uintp; |
| |
| package body Pprint is |
| |
| List_Name_Count : Integer := 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 |
| Left : Node_Id := Original_Node (Expr); |
| Right : Node_Id := Original_Node (Expr); |
| From_Source : constant Boolean := |
| Comes_From_Source (Expr) and then not Opt.Debug_Generated_Code; |
| Append_Paren : Boolean := False; |
| |
| 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. |
| |
| Max_List : constant := 3; |
| -- Limit number of list elements to dump |
| |
| 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 : Node_Id; |
| Add_Space : Boolean := True; |
| Add_Paren : Boolean := True) return String; |
| -- Return a string corresponding to List |
| |
| function List_Name |
| (List : Node_Id; |
| Add_Space : Boolean := True; |
| Add_Paren : Boolean := True) return String |
| is |
| function Internal_List_Name |
| (List : Node_Id; |
| First : Boolean := True; |
| Add_Space : Boolean := True; |
| Add_Paren : Boolean := True; |
| Num : Natural := 1) return String; |
| |
| ------------------------ |
| -- Internal_List_Name -- |
| ------------------------ |
| |
| function Internal_List_Name |
| (List : Node_Id; |
| First : Boolean := True; |
| Add_Space : Boolean := True; |
| Add_Paren : Boolean := True; |
| Num : Natural := 1) return String |
| is |
| function Prepend (S : String) return String; |
| |
| ------------- |
| -- Prepend -- |
| ------------- |
| |
| function Prepend (S : String) return String is |
| begin |
| if Add_Space then |
| if Add_Paren then |
| return " (" & S; |
| else |
| return ' ' & S; |
| end if; |
| elsif Add_Paren then |
| return '(' & S; |
| else |
| return S; |
| end if; |
| end Prepend; |
| |
| -- Start of processing for Internal_List_Name |
| |
| begin |
| if not Present (List) then |
| if First or else not Add_Paren then |
| return ""; |
| else |
| return ")"; |
| end if; |
| elsif Num > Max_List then |
| if Add_Paren then |
| return ", ...)"; |
| else |
| return ", ..."; |
| end if; |
| end if; |
| |
| if First then |
| return Prepend |
| (Expr_Name (List) |
| & Internal_List_Name (Next (List), |
| First => False, |
| Add_Paren => Add_Paren, |
| Num => Num + 1)); |
| else |
| return ", " & Expr_Name (List) & |
| Internal_List_Name |
| (Next (List), |
| First => False, |
| Add_Paren => Add_Paren, |
| Num => Num + 1); |
| end if; |
| end Internal_List_Name; |
| |
| -- Start of processing for List_Name |
| |
| begin |
| -- Prevent infinite recursion by limiting depth to 3 |
| |
| if List_Name_Count > 3 then |
| return "..."; |
| end if; |
| |
| List_Name_Count := List_Name_Count + 1; |
| declare |
| Result : constant String := |
| Internal_List_Name |
| (List, Add_Space => Add_Space, Add_Paren => Add_Paren); |
| begin |
| List_Name_Count := List_Name_Count - 1; |
| return Result; |
| end; |
| 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; |
| |
| case Nkind (Expr) is |
| when N_Defining_Identifier | 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 .. 127 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 => |
| UI_Image (Intval (Expr)); |
| return UI_Image_Buffer (1 .. UI_Image_Length); |
| |
| 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 (Sinfo.Expressions (Expr)) then |
| return List_Name |
| (First (Sinfo.Expressions (Expr)), Add_Space => False); |
| |
| elsif Null_Record_Present (Expr) then |
| return ("(null record)"); |
| |
| else |
| return List_Name |
| (First (Component_Associations (Expr)), |
| Add_Space => False, Add_Paren => False); |
| end if; |
| |
| when N_Extension_Aggregate => |
| return "(" & Expr_Name (Ancestor_Part (Expr)) & |
| " with " & |
| List_Name (First (Sinfo.Expressions (Expr)), |
| Add_Space => False, Add_Paren => False) & |
| ")"; |
| |
| when N_Attribute_Reference => |
| if Take_Prefix then |
| declare |
| Str : constant String := Expr_Name (Prefix (Expr)) |
| & "'" & Get_Name_String (Attribute_Name (Expr)); |
| Id : constant Attribute_Id := |
| Get_Attribute_Id (Attribute_Name (Expr)); |
| Ranges : List_Id; |
| N : Node_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_In |
| (First (Ranges), |
| 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 => |
| if Take_Prefix then |
| return Expr_Name (Prefix (Expr)) & ".all"; |
| else |
| return ".all"; |
| end if; |
| |
| 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_Component_Association => |
| return "(" |
| & List_Name (First (Choices (Expr)), |
| Add_Space => False, Add_Paren => False) |
| & " => " & Expr_Name (Expression (Expr)) & ")"; |
| |
| when N_If_Expression => |
| declare |
| N : constant Node_Id := First (Sinfo.Expressions (Expr)); |
| begin |
| return "if " & Expr_Name (N) & " then " & |
| Expr_Name (Next (N)) & " else " & |
| Expr_Name (Next (Next (N))); |
| 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_Unchecked_Expression | 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_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_Parameter_Association => |
| return Expr_Name (Explicit_Actual_Parameter (Expr)); |
| |
| when N_Type_Conversion | N_Unchecked_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_Indexed_Component => |
| if Take_Prefix then |
| return Expr_Name (Prefix (Expr)) & |
| List_Name (First (Sinfo.Expressions (Expr))); |
| else |
| return List_Name (First (Sinfo.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 |
| return '(' & Expr_Name (Name (Expr)) & |
| List_Name (First (Sinfo.Parameter_Associations (Expr))) & |
| ')'; |
| else |
| return Expr_Name (Name (Expr)) & |
| List_Name (First (Sinfo.Parameter_Associations (Expr))); |
| end if; |
| |
| when N_Null => |
| return "null"; |
| |
| when N_Others_Choice => |
| return "others"; |
| |
| when others => |
| return "..."; |
| end case; |
| end Expr_Name; |
| |
| -- Start of processing for Expression_Name |
| |
| begin |
| if not From_Source then |
| declare |
| S : constant String := Expr_Name (Expr); |
| begin |
| if S = "..." then |
| return Default; |
| else |
| return S; |
| end if; |
| end; |
| end if; |
| |
| -- Compute left (start) and right (end) slocs for the expression |
| -- Consider using Sinput.Sloc_Range instead, except that it does not |
| -- work properly currently??? |
| |
| loop |
| case Nkind (Left) is |
| when N_Binary_Op | N_Membership_Test | |
| N_And_Then | N_Or_Else => |
| Left := Original_Node (Left_Opnd (Left)); |
| |
| when N_Attribute_Reference | N_Expanded_Name | |
| N_Explicit_Dereference | N_Indexed_Component | |
| N_Reference | N_Selected_Component | |
| N_Slice => |
| Left := Original_Node (Prefix (Left)); |
| |
| when N_Designator | N_Defining_Program_Unit_Name | |
| N_Function_Call => |
| Left := Original_Node (Name (Left)); |
| |
| when N_Range => |
| Left := Original_Node (Low_Bound (Left)); |
| |
| when N_Type_Conversion => |
| Left := Original_Node (Subtype_Mark (Left)); |
| |
| -- For any other item, quit loop |
| |
| when others => |
| exit; |
| end case; |
| end loop; |
| |
| loop |
| case Nkind (Right) is |
| when N_Op | N_Membership_Test | |
| N_And_Then | N_Or_Else => |
| Right := Original_Node (Right_Opnd (Right)); |
| |
| when N_Selected_Component | N_Expanded_Name => |
| Right := Original_Node (Selector_Name (Right)); |
| |
| when N_Designator => |
| Right := Original_Node (Identifier (Right)); |
| |
| when N_Defining_Program_Unit_Name => |
| Right := Original_Node (Defining_Identifier (Right)); |
| |
| when N_Range => |
| Right := Original_Node (High_Bound (Right)); |
| |
| when N_Parameter_Association => |
| Right := Original_Node (Explicit_Actual_Parameter (Right)); |
| |
| when N_Indexed_Component => |
| Right := Original_Node (Last (Sinfo.Expressions (Right))); |
| Append_Paren := True; |
| |
| when N_Function_Call => |
| if Present (Sinfo.Parameter_Associations (Right)) then |
| Right := |
| Original_Node |
| (Last (Sinfo.Parameter_Associations (Right))); |
| Append_Paren := True; |
| |
| -- Quit loop if no named associations |
| |
| else |
| exit; |
| end if; |
| |
| -- For all other items, quit the loop |
| |
| when others => |
| exit; |
| end case; |
| end loop; |
| |
| declare |
| Scn : Source_Ptr := Original_Location (Sloc (Left)); |
| Src : constant Source_Buffer_Ptr := |
| Source_Text (Get_Source_File_Index (Scn)); |
| End_Sloc : constant Source_Ptr := |
| Original_Location (Sloc (Right)); |
| |
| begin |
| if Scn > End_Sloc then |
| return Default; |
| end if; |
| |
| declare |
| Buffer : String (1 .. Natural (End_Sloc - Scn)); |
| Skipping_Comment : Boolean := False; |
| Underscore : Boolean := False; |
| Index : Natural := 0; |
| |
| begin |
| if Right /= Expr then |
| while Scn < End_Sloc loop |
| case Src (Scn) is |
| 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.LF | ASCII.CR | ASCII.FF => |
| 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; |
| |
| Scn := Scn + 1; |
| end loop; |
| end if; |
| |
| if Index < 1 then |
| declare |
| S : constant String := Expr_Name (Right); |
| begin |
| if S = "..." then |
| return Default; |
| else |
| return S; |
| end if; |
| end; |
| |
| elsif Append_Paren then |
| return Buffer (1 .. Index) & Expr_Name (Right, False) & ')'; |
| |
| else |
| return Buffer (1 .. Index) & Expr_Name (Right, False); |
| end if; |
| end; |
| end; |
| end Expression_Image; |
| |
| end Pprint; |
