| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- P P R I N T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 2008-2022, 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 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 |
| From_Source : constant Boolean := |
| Comes_From_Source (Expr) |
| and then not Opt.Debug_Generated_Code; |
| Append_Paren : Natural := 0; |
| Left : Node_Id := Original_Node (Expr); |
| Right : Node_Id := Original_Node (Expr); |
| |
| 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 |
| |
| --------------- |
| -- List_Name -- |
| --------------- |
| |
| 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; |
| -- Created for purposes of recursing on embedded lists |
| |
| ------------------------ |
| -- 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 |
| begin |
| if No (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; |
| |
| -- Continue recursing on the list - handling the first element |
| -- in a special way. |
| |
| return |
| (if First then |
| (if Add_Space and Add_Paren then " (" |
| elsif Add_Paren then "(" |
| elsif Add_Space then " " |
| else "") |
| else ", ") |
| & Expr_Name (List) |
| & Internal_List_Name |
| (List => Next (List), |
| First => False, |
| Add_Paren => Add_Paren, |
| Num => Num + 1); |
| 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 => 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 => |
| 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 |
| (List => First (Expressions (Expr)), |
| Add_Space => False); |
| |
| -- 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 |
| (List => 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 |
| (List => First (Expressions (Expr)), |
| Add_Space => False, |
| Add_Paren => False) & ")"; |
| |
| 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_Component_Association => |
| return "(" |
| & List_Name |
| (List => First (Choices (Expr)), |
| Add_Space => False, |
| Add_Paren => False) |
| & " => " & Expr_Name (Expression (Expr)) & ")"; |
| |
| 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 |
| | N_Unchecked_Expression |
| => |
| 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 => |
| |
| -- 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 (First (Expressions (Expr))); |
| else |
| return List_Name (First (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 (Parameter_Associations (Expr))) |
| & ')'; |
| else |
| return |
| Expr_Name (Name (Expr)) |
| & List_Name (First (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_Image |
| |
| 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; |
| |
| -- 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 |
| -- Consider using Sinput.Sloc_Range instead, except that it does not |
| -- work properly currently??? |
| |
| loop |
| case Nkind (Left) is |
| when N_And_Then |
| | N_Binary_Op |
| | N_Membership_Test |
| | 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_Defining_Program_Unit_Name |
| | N_Designator |
| | N_Function_Call |
| => |
| Left := Original_Node (Name (Left)); |
| |
| when N_Range => |
| Left := Original_Node (Low_Bound (Left)); |
| |
| when N_Qualified_Expression |
| | 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_And_Then |
| | N_Membership_Test |
| | N_Op |
| | N_Or_Else |
| => |
| Right := Original_Node (Right_Opnd (Right)); |
| |
| when N_Expanded_Name |
| | N_Selected_Component |
| => |
| Right := Original_Node (Selector_Name (Right)); |
| |
| when N_Qualified_Expression |
| | N_Type_Conversion |
| => |
| Right := Original_Node (Expression (Right)); |
| |
| -- If argument does not already account for a closing |
| -- parenthesis, count one here. |
| |
| if Nkind (Right) not in N_Aggregate | N_Quantified_Expression |
| then |
| Append_Paren := Append_Paren + 1; |
| end if; |
| |
| 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_Component_Association => |
| if Present (Expression (Right)) then |
| Right := Expression (Right); |
| else |
| Right := Last (Choices (Right)); |
| end if; |
| |
| when N_Indexed_Component => |
| Right := Original_Node (Last (Expressions (Right))); |
| Append_Paren := Append_Paren + 1; |
| |
| when N_Function_Call => |
| if Present (Parameter_Associations (Right)) then |
| declare |
| Rover : Node_Id; |
| Found : Boolean; |
| |
| begin |
| -- Avoid source position confusion associated with |
| -- parameters for which Comes_From_Source is False. |
| |
| Rover := First (Parameter_Associations (Right)); |
| Found := False; |
| while Present (Rover) loop |
| if Comes_From_Source (Original_Node (Rover)) then |
| Right := Original_Node (Rover); |
| Found := True; |
| end if; |
| |
| Next (Rover); |
| end loop; |
| |
| if Found then |
| Append_Paren := Append_Paren + 1; |
| end if; |
| |
| -- Quit loop if no Comes_From_Source parameters |
| |
| exit when not Found; |
| end; |
| |
| -- Quit loop if no parameters |
| |
| else |
| exit; |
| end if; |
| |
| when N_Quantified_Expression => |
| Right := Original_Node (Condition (Right)); |
| Append_Paren := Append_Paren + 1; |
| |
| when N_Aggregate => |
| declare |
| Aggr : constant Node_Id := Right; |
| Sub : Node_Id; |
| |
| begin |
| Sub := First (Expressions (Aggr)); |
| while Present (Sub) loop |
| if Sloc (Sub) > Sloc (Right) then |
| Right := Sub; |
| end if; |
| |
| Next (Sub); |
| end loop; |
| |
| Sub := First (Component_Associations (Aggr)); |
| while Present (Sub) loop |
| if Sloc (Sub) > Sloc (Right) then |
| Right := Sub; |
| end if; |
| |
| Next (Sub); |
| end loop; |
| |
| exit when Right = Aggr; |
| |
| Append_Paren := Append_Paren + 1; |
| end; |
| |
| -- For all other items, quit the loop |
| |
| when others => |
| exit; |
| end case; |
| end loop; |
| |
| declare |
| Scn : Source_Ptr := Original_Location (Sloc (Left)); |
| End_Sloc : constant Source_Ptr := |
| Original_Location (Sloc (Right)); |
| Src : constant Source_Buffer_Ptr := |
| Source_Text (Get_Source_File_Index (Scn)); |
| |
| begin |
| if Scn > End_Sloc then |
| return Default; |
| end if; |
| |
| declare |
| Threshold : constant := 256; |
| Buffer : String (1 .. Natural (End_Sloc - Scn)); |
| Index : Natural := 0; |
| Skipping_Comment : Boolean := False; |
| Underscore : Boolean := False; |
| |
| begin |
| if Right /= Expr then |
| while Scn < End_Sloc loop |
| case Src (Scn) is |
| |
| -- Give up on non ASCII characters |
| |
| when Character'Val (128) .. Character'Last => |
| Append_Paren := 0; |
| Index := 0; |
| Right := Expr; |
| 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; |
| 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; |
| |
| else |
| return |
| Buffer (1 .. Index) |
| & Expr_Name (Right, False) |
| & (1 .. Append_Paren => ')'); |
| end if; |
| end; |
| end; |
| end Expression_Image; |
| |
| end Pprint; |
