-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
-- Local Subprograms --
-----------------------
+ procedure Analyze_Package_Body_Helper (N : Node_Id);
+ -- Does all the real work of Analyze_Package_Body
+
procedure Check_Anonymous_Access_Types
(Spec_Id : Entity_Id;
P_Body : Node_Id);
--------------------------
procedure Analyze_Package_Body (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ if Debug_Flag_C then
+ Write_Str ("==> package body ");
+ Write_Name (Chars (Defining_Entity (N)));
+ Write_Str (" from ");
+ Write_Location (Loc);
+ Write_Eol;
+ Indent;
+ end if;
+
+ -- The real work is split out into the helper, so it can do "return;"
+ -- without skipping the debug output.
+
+ Analyze_Package_Body_Helper (N);
+
+ if Debug_Flag_C then
+ Outdent;
+ Write_Str ("<== package body ");
+ Write_Name (Chars (Defining_Entity (N)));
+ Write_Str (" from ");
+ Write_Location (Loc);
+ Write_Eol;
+ end if;
+ end Analyze_Package_Body;
+
+ ---------------------------------
+ -- Analyze_Package_Body_Helper --
+ ---------------------------------
+
+ procedure Analyze_Package_Body_Helper (N : Node_Id) is
HSS : Node_Id;
Body_Id : Entity_Id;
Spec_Id : Entity_Id;
end loop;
end Install_Composite_Operations;
- -- Start of processing for Analyze_Package_Body
+ -- Start of processing for Analyze_Package_Body_Helper
begin
-- Find corresponding package specification, and establish the current
-- the later is never used for name resolution. In this fashion there
-- is only one visible entity that denotes the package.
- if Debug_Flag_C then
- Write_Str ("==== Compiling package body ");
- Write_Name (Chars (Defining_Entity (N)));
- Write_Str (" from ");
- Write_Location (Loc);
- Write_Eol;
- end if;
-
-- Set Body_Id. Note that this Will be reset to point to the generic
-- copy later on in the generic case.
Qualify_Entity_Names (N);
end if;
end if;
- end Analyze_Package_Body;
+ end Analyze_Package_Body_Helper;
---------------------------------
-- Analyze_Package_Declaration --
return;
end if;
+ if Debug_Flag_C then
+ Write_Str ("==> package spec ");
+ Write_Name (Chars (Id));
+ Write_Str (" from ");
+ Write_Location (Sloc (N));
+ Write_Eol;
+ Indent;
+ end if;
+
Generate_Definition (Id);
Enter_Name (Id);
Set_Ekind (Id, E_Package);
Set_Categorization_From_Pragmas (N);
- if Debug_Flag_C then
- Write_Str ("==== Compiling package spec ");
- Write_Name (Chars (Id));
- Write_Str (" from ");
- Write_Location (Sloc (N));
- Write_Eol;
- end if;
-
Analyze (Specification (N));
Validate_Categorization_Dependency (N, Id);
if Comp_Unit then
Validate_RT_RAT_Component (N);
end if;
+
+ if Debug_Flag_C then
+ Outdent;
+ Write_Str ("<== package spec ");
+ Write_Name (Chars (Id));
+ Write_Str (" from ");
+ Write_Location (Sloc (N));
+ Write_Eol;
+ end if;
end Analyze_Package_Declaration;
-----------------------------------
Next_Elmt (Op_Elmt_2);
end loop;
- -- Case 2: We have not found any explicit overriding and
- -- hence we need to declare the operation (i.e., make it
- -- visible).
+ -- Case 2: We have not found any explicit overriding and
+ -- hence we need to declare the operation (i.e., make it
+ -- visible).
Derive_Subprogram (New_Op, Alias (Prim_Op), E, Etype (E));
end if;
else
- -- Non-tagged type, scan forward to locate inherited hidden
- -- operations.
+ -- Non-tagged type, scan forward to locate inherited hidden
+ -- operations.
Prim_Op := Next_Entity (E);
while Present (Prim_Op) loop
if Tagged_Present (Def) then
Set_Ekind (Id, E_Record_Type_With_Private);
- Make_Class_Wide_Type (Id);
Set_Primitive_Operations (Id, New_Elmt_List);
Set_Is_Abstract_Type (Id, Abstract_Present (Def));
Set_Is_Limited_Record (Id, Limited_Present (Def));
Set_Has_Delayed_Freeze (Id, True);
+ -- Create a class-wide type with the same attributes
+
+ Make_Class_Wide_Type (Id);
+
elsif Abstract_Present (Def) then
Error_Msg_N ("only a tagged type can be abstract", N);
end if;
("missing full declaration for private extension", Id);
end if;
+ -- Case of constant, check for deferred constant declaration with
+ -- no full view. Likely just a matter of a missing expression, or
+ -- accidental use of the keyword constant.
+
elsif Ekind (Id) = E_Constant
+
+ -- OK if constant value present
+
and then No (Constant_Value (Id))
+
+ -- OK if full view present
+
and then No (Full_View (Id))
+
+ -- OK if imported, since that provides the completion
+
and then not Is_Imported (Id)
- and then (Nkind (Parent (Id)) /= N_Object_Declaration
- or else not No_Initialization (Parent (Id)))
+
+ -- OK if object declaration replaced by renaming declaration as
+ -- a result of OK_To_Rename processing (e.g. for concatenation)
+
+ and then Nkind (Parent (Id)) /= N_Object_Renaming_Declaration
+
+ -- OK if object declaration with the No_Initialization flag set
+
+ and then not (Nkind (Parent (Id)) = N_Object_Declaration
+ and then No_Initialization (Parent (Id)))
then
+ -- If no private declaration is present, we assume the user did
+ -- not intend a deferred constant declaration and the problem
+ -- is simply that the initializing expression is missing.
+
if not Has_Private_Declaration (Etype (Id)) then
- -- We assume that the user did not intend a deferred
- -- constant declaration, and the expression is just missing.
+ -- We assume that the user did not intend a deferred constant
+ -- declaration, and the expression is just missing.
Error_Msg_N
("constant declaration requires initialization expression",
Parent (Id));
end if;
+ -- Otherwise if a private declaration is present, then we are
+ -- missing the full declaration for the deferred constant.
+
else
Error_Msg_N
("missing full declaration for deferred constant (RM 7.4)",
and then No (Full_View (Id))
then
-- Mark Taft amendment types. Verify that there are no primitive
- -- operations declared for the type (3.10.1 (9)).
+ -- operations declared for the type (3.10.1(9)).
Set_Has_Completion_In_Body (Id);
OSDN Git Service
