-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, 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- --
-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- that is currently being written. Note that Debug_Node is always empty
-- if a debug source file is not being written.
+ procedure Sprint_And_List (List : List_Id);
+ -- Print the given list with items separated by vertical "and"
+
procedure Sprint_Bar_List (List : List_Id);
-- Print the given list with items separated by vertical bars
end Source_Dump;
---------------------
+ -- Sprint_And_List --
+ ---------------------
+
+ procedure Sprint_And_List (List : List_Id) is
+ Node : Node_Id;
+ begin
+ if Is_Non_Empty_List (List) then
+ Node := First (List);
+ loop
+ Sprint_Node (Node);
+ Next (Node);
+ exit when Node = Empty;
+ Write_Str (" and ");
+ end loop;
+ end if;
+ end Sprint_And_List;
+
+ ---------------------
-- Sprint_Bar_List --
---------------------
procedure Sprint_Bar_List (List : List_Id) is
Node : Node_Id;
-
begin
if Is_Non_Empty_List (List) then
Node := First (List);
-
loop
Sprint_Node (Node);
Next (Node);
begin
if Is_Non_Empty_List (List) then
Node := First (List);
-
loop
Sprint_Node (Node);
Next (Node);
then
Write_Str (", ");
end if;
-
end loop;
end if;
end Sprint_Comma_List;
Write_Str_With_Col_Check ("function");
Write_Param_Specs (Node);
Write_Str_With_Col_Check (" return ");
- Sprint_Node (Subtype_Mark (Node));
+ Sprint_Node (Result_Definition (Node));
when N_Access_Procedure_Definition =>
end if;
Write_Char_Sloc (''');
- Write_Char_Code (Char_Literal_Value (Node));
+ Write_Char_Code (UI_To_CC (Char_Literal_Value (Node)));
Write_Char (''');
when N_Code_Statement =>
Sprint_Node (Subtype_Indication (Node));
- if Present (Record_Extension_Part (Node)) then
+ if Present (Interface_List (Node)) then
+ Sprint_And_List (Interface_List (Node));
Write_Str_With_Col_Check (" with ");
+ end if;
+
+ if Present (Record_Extension_Part (Node)) then
+ if No (Interface_List (Node)) then
+ Write_Str_With_Col_Check (" with ");
+ end if;
+
Sprint_Node (Record_Extension_Part (Node));
end if;
Write_Str_With_Col_Check (" with private");
end if;
+ when N_Formal_Abstract_Subprogram_Declaration =>
+ Write_Indent_Str_Sloc ("with ");
+ Sprint_Node (Specification (Node));
+
+ Write_Str_With_Col_Check (" is abstract");
+
+ if Box_Present (Node) then
+ Write_Str_With_Col_Check (" <>");
+ elsif Present (Default_Name (Node)) then
+ Write_Str_With_Col_Check (" ");
+ Sprint_Node (Default_Name (Node));
+ end if;
+
+ Write_Char (';');
+
+ when N_Formal_Concrete_Subprogram_Declaration =>
+ Write_Indent_Str_Sloc ("with ");
+ Sprint_Node (Specification (Node));
+
+ if Box_Present (Node) then
+ Write_Str_With_Col_Check (" is <>");
+ elsif Present (Default_Name (Node)) then
+ Write_Str_With_Col_Check (" is ");
+ Sprint_Node (Default_Name (Node));
+ end if;
+
+ Write_Char (';');
+
when N_Formal_Discrete_Type_Definition =>
Write_Str_With_Col_Check_Sloc ("<>");
when N_Formal_Signed_Integer_Type_Definition =>
Write_Str_With_Col_Check_Sloc ("range <>");
- when N_Formal_Subprogram_Declaration =>
- Write_Indent_Str_Sloc ("with ");
- Sprint_Node (Specification (Node));
-
- if Box_Present (Node) then
- Write_Str_With_Col_Check (" is <>");
- elsif Present (Default_Name (Node)) then
- Write_Str_With_Col_Check (" is ");
- Sprint_Node (Default_Name (Node));
- end if;
-
- Write_Char (';');
-
when N_Formal_Type_Declaration =>
Write_Indent_Str_Sloc ("type ");
Write_Id (Defining_Identifier (Node));
Sprint_Node (Defining_Unit_Name (Node));
Write_Param_Specs (Node);
Write_Str_With_Col_Check (" return ");
- Sprint_Node (Subtype_Mark (Node));
+
+ -- Ada 2005 (AI-231)
+
+ if Nkind (Result_Definition (Node)) /= N_Access_Definition
+ and then Null_Exclusion_Present (Node)
+ then
+ Write_Str (" not null ");
+ end if;
+
+ Sprint_Node (Result_Definition (Node));
when N_Generic_Association =>
Set_Debug_Sloc;
Write_Indent_Str_Sloc ("protected type ");
Write_Id (Defining_Identifier (Node));
Write_Discr_Specs (Node);
- Write_Str (" is");
+
+ if Present (Interface_List (Node)) then
+ Write_Str (" is new ");
+ Sprint_And_List (Interface_List (Node));
+ Write_Str (" with ");
+ else
+ Write_Str (" is");
+ end if;
+
Sprint_Node (Protected_Definition (Node));
Write_Id (Defining_Identifier (Node));
Write_Char (';');
when N_Subprogram_Declaration =>
Write_Indent;
Sprint_Node_Sloc (Specification (Node));
+
+ if Nkind (Specification (Node)) = N_Procedure_Specification
+ and then Null_Present (Specification (Node))
+ then
+ Write_Str_With_Col_Check (" is null");
+ end if;
+
Write_Char (';');
when N_Subprogram_Info =>
Write_Id (Defining_Identifier (Node));
Write_Discr_Specs (Node);
+ if Present (Interface_List (Node)) then
+ Write_Str (" is new ");
+ Sprint_And_List (Interface_List (Node));
+ end if;
+
if Present (Task_Definition (Node)) then
- Write_Str (" is");
+ if No (Interface_List (Node)) then
+ Write_Str (" is");
+ else
+ Write_Str (" with ");
+ end if;
+
Sprint_Node (Task_Definition (Node));
Write_Id (Defining_Identifier (Node));
end if;
Write_Str ("""]");
end Write_Condition_And_Reason;
- ------------------------
- -- Write_Discr_Specs --
- ------------------------
+ -----------------------
+ -- Write_Discr_Specs --
+ -----------------------
procedure Write_Discr_Specs (N : Node_Id) is
- Specs : List_Id;
- Spec : Node_Id;
+ Specs : List_Id;
+ Spec : Node_Id;
begin
Specs := Discriminant_Specifications (N);
OSDN Git Service
