-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
Set_Parent_Spec (New_N, Save_Parent);
Rewrite (N, New_N);
+ -- The aspect specifications are not attached to the tree, and must
+ -- be copied and attached to the generic copy explicitly.
+
+ if Present (Aspect_Specifications (New_N)) then
+ declare
+ Aspects : constant List_Id := Aspect_Specifications (N);
+ begin
+ Set_Has_Aspects (N, False);
+ Move_Aspects (New_N, N);
+ Set_Has_Aspects (Original_Node (N), False);
+ Set_Aspect_Specifications (Original_Node (N), Aspects);
+ end;
+ end if;
+
Spec := Specification (N);
Id := Defining_Entity (Spec);
Generate_Definition (Id);
Save_Global_References (Original_Node (N));
+ -- To capture global references, analyze the expressions of aspects,
+ -- and propagate information to original tree. Note that in this case
+ -- analysis of attributes is not delayed until the freeze point.
+
+ -- It seems very hard to recreate the proper visibility of the generic
+ -- subprogram at a later point because the analysis of an aspect may
+ -- create pragmas after the generic copies have been made ???
+
+ if Has_Aspects (N) then
+ declare
+ Aspect : Node_Id;
+
+ begin
+ Aspect := First (Aspect_Specifications (N));
+ while Present (Aspect) loop
+ if Get_Aspect_Id (Chars (Identifier (Aspect)))
+ /= Aspect_Warnings
+ then
+ Analyze (Expression (Aspect));
+ end if;
+ Next (Aspect);
+ end loop;
+
+ Aspect := First (Aspect_Specifications (Original_Node (N)));
+ while Present (Aspect) loop
+ Save_Global_References (Expression (Aspect));
+ Next (Aspect);
+ end loop;
+ end;
+ end if;
+
End_Generic;
End_Scope;
Exit_Generic_Scope (Id);
Generate_Reference_To_Formals (Id);
List_Inherited_Pre_Post_Aspects (Id);
-
- if Has_Aspects (N) then
- Analyze_Aspect_Specifications (N, Id);
- end if;
end Analyze_Generic_Subprogram_Declaration;
-----------------------------------
Needs_Body : Boolean;
Inline_Now : Boolean := False;
+ Save_Style_Check : constant Boolean := Style_Check;
+ -- Save style check mode for restore on exit
+
procedure Delay_Descriptors (E : Entity_Id);
-- Delay generation of subprogram descriptors for given entity
Instantiation_Node := N;
+ -- Turn off style checking in instances. If the check is enabled on the
+ -- generic unit, a warning in an instance would just be noise. If not
+ -- enabled on the generic, then a warning in an instance is just wrong.
+
+ Style_Check := False;
+
-- Case of instantiation of a generic package
if Nkind (N) = N_Package_Instantiation then
end;
-- If we are generating calling stubs, we never need a body for an
- -- instantiation from source. However normal processing occurs for
- -- any generic instantiation appearing in generated code, since we
- -- do not generate stubs in that case.
+ -- instantiation from source in the visible part, because in that
+ -- case we'll be generating stubs for any subprogram in the instance.
+ -- However normal processing occurs for instantiations in generated
+ -- code or in the private part, since in those cases we do not
+ -- generate stubs.
if Distribution_Stub_Mode = Generate_Caller_Stub_Body
and then Comes_From_Source (N)
Set_Defining_Identifier (N, Act_Decl_Id);
end if;
+ Style_Check := Save_Style_Check;
+
<<Leave>>
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Act_Decl_Id);
if Env_Installed then
Restore_Env;
end if;
+
+ Style_Check := Save_Style_Check;
end Analyze_Package_Instantiation;
--------------------------
Parent_Installed : Boolean := False;
Renaming_List : List_Id;
+ Save_Style_Check : constant Boolean := Style_Check;
+ -- Save style check mode for restore on exit
+
procedure Analyze_Instance_And_Renamings;
-- The instance must be analyzed in a context that includes the mappings
-- of generic parameters into actuals. We create a package declaration
-- Make node global for error reporting
Instantiation_Node := N;
+
+ -- Turn off style checking in instances. If the check is enabled on the
+ -- generic unit, a warning in an instance would just be noise. If not
+ -- enabled on the generic, then a warning in an instance is just wrong.
+
+ Style_Check := False;
+
Preanalyze_Actuals (N);
Init_Env;
Make_Subprogram_Declaration (Sloc (Act_Spec),
Specification => Act_Spec);
+ -- The aspects have been copied previously, but they have to be
+ -- linked explicitly to the new subprogram declaration. Explicit
+ -- pre/postconditions on the instance are analyzed below, in a
+ -- separate step.
+
+ Move_Aspects (Act_Tree, Act_Decl);
Set_Categorization_From_Pragmas (Act_Decl);
if Parent_Installed then
Generic_Renamings_HTable.Reset;
end if;
+ Style_Check := Save_Style_Check;
+
<<Leave>>
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Act_Decl_Id);
if Env_Installed then
Restore_Env;
end if;
+
+ Style_Check := Save_Style_Check;
end Analyze_Subprogram_Instantiation;
-------------------------
-- exchange views to restore the proper visiblity in the instance.
declare
- Typ : constant Entity_Id := Base_Type (Etype (E));
+ Typ : constant Entity_Id := Base_Type (Etype (E));
-- The type of the actual
- Gen_Id : Entity_Id;
+ Gen_Id : Entity_Id;
-- The generic unit
Parent_Scope : Entity_Id;
end if;
end if;
- -- Do not copy the associated node, which points to
- -- the generic copy of the aggregate.
+ -- Do not copy the associated node, which points to the generic copy
+ -- of the aggregate.
declare
use Atree.Unchecked_Access;
Set_Field5 (New_N, Copy_Generic_Descendant (Field5 (N)));
end;
- -- Allocators do not have an identifier denoting the access type,
- -- so we must locate it through the expression to check whether
- -- the views are consistent.
+ -- Allocators do not have an identifier denoting the access type, so we
+ -- must locate it through the expression to check whether the views are
+ -- consistent.
elsif Nkind (N) = N_Allocator
and then Nkind (Expression (N)) = N_Qualified_Expression
-- Don't copy Ident or Comment pragmas, since the comment belongs to the
-- generic unit, not to the instantiating unit.
- elsif Nkind (N) = N_Pragma
- and then Instantiating
- then
+ elsif Nkind (N) = N_Pragma and then Instantiating then
declare
Prag_Id : constant Pragma_Id := Get_Pragma_Id (N);
begin
- if Prag_Id = Pragma_Ident
- or else Prag_Id = Pragma_Comment
- then
+ if Prag_Id = Pragma_Ident or else Prag_Id = Pragma_Comment then
New_N := Make_Null_Statement (Sloc (N));
+
else
Copy_Descendants;
end if;
else
Copy_Descendants;
- if Instantiating
- and then Nkind (N) = N_Subprogram_Body
- then
+ if Instantiating and then Nkind (N) = N_Subprogram_Body then
Set_Generic_Parent (Specification (New_N), N);
+
+ -- Should preserve Corresponding_Spec??? (12.3(14))
end if;
end if;
if Renamed_Object (E1) = Pack then
return True;
- elsif E1 = P
- or else Renamed_Object (E1) = P
- then
+ elsif E1 = P or else Renamed_Object (E1) = P then
return False;
elsif Is_Actual_Of_Previous_Formal (E1) then
Instance_Envs.Table
(Instance_Envs.Last).Instantiated_Parent.Act_Id;
else
- Par := Current_Instantiated_Parent.Act_Id;
+ Par := Current_Instantiated_Parent.Act_Id;
end if;
if Ekind (Scop) = E_Generic_Package
end loop;
-- At this point P1 and P2 are at the same distance from the root.
- -- We examine their parents until we find a common declarative
- -- list, at which point we can establish their relative placement
- -- by comparing their ultimate slocs. If we reach the root,
- -- N1 and N2 do not descend from the same declarative list (e.g.
- -- one is nested in the declarative part and the other is in a block
- -- in the statement part) and the earlier one is already frozen.
+ -- We examine their parents until we find a common declarative list,
+ -- at which point we can establish their relative placement by
+ -- comparing their ultimate slocs. If we reach the root, N1 and N2
+ -- do not descend from the same declarative list (e.g. one is nested
+ -- in the declarative part and the other is in a block in the
+ -- statement part) and the earlier one is already frozen.
while not Is_List_Member (P1)
or else not Is_List_Member (P2)
In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
then
-- The enclosing package may contain several instances. Rather
- -- than computing the earliest point at which to insert its
- -- freeze node, we place it at the end of the declarative part
- -- of the parent of the generic.
+ -- than computing the earliest point at which to insert its freeze
+ -- node, we place it at the end of the declarative part of the
+ -- parent of the generic.
Insert_After_Last_Decl
(Freeze_Node (Par), Package_Freeze_Node (Enc_I));
-- Freeze package that encloses instance, and place node after
-- package that encloses generic. If enclosing package is already
- -- frozen we have to assume it is at the proper place. This may be
- -- a potential ABE that requires dynamic checking. Do not add a
- -- freeze node if the package that encloses the generic is inside
- -- the body that encloses the instance, because the freeze node
- -- would be in the wrong scope. Additional contortions needed if
- -- the bodies are within a subunit.
+ -- frozen we have to assume it is at the proper place. This may be a
+ -- potential ABE that requires dynamic checking. Do not add a freeze
+ -- node if the package that encloses the generic is inside the body
+ -- that encloses the instance, because the freeze node would be in
+ -- the wrong scope. Additional contortions needed if the bodies are
+ -- within a subunit.
declare
Enclosing_Body : Node_Id;
-- investigated, and would allow this function to be significantly
-- simplified. ???
- if Present (Package_Instantiation (A)) then
- if Nkind (Package_Instantiation (A)) = N_Package_Instantiation then
- return Package_Instantiation (A);
+ Inst := Package_Instantiation (A);
- elsif Nkind (Original_Node (Package_Instantiation (A))) =
- N_Package_Instantiation
- then
- return Original_Node (Package_Instantiation (A));
+ if Present (Inst) then
+ if Nkind (Inst) = N_Package_Instantiation then
+ return Inst;
+
+ elsif Nkind (Original_Node (Inst)) = N_Package_Instantiation then
+ return Original_Node (Inst);
end if;
end if;
-- now we depend on the user not redefining Standard itself in one of
-- the parent units.
- if Is_Immediately_Visible (C)
- and then C /= Standard_Standard
- then
+ if Is_Immediately_Visible (C) and then C /= Standard_Standard then
Set_Is_Immediately_Visible (C, False);
Append_Elmt (C, Hidden_Entities);
end if;
-- might produce false positives in rare cases, but guarantees
-- that we produce all the instance bodies we will need.
- if (Is_Entity_Name (Nam)
- and then Chars (Nam) = Chars (E))
- or else (Nkind (Nam) = N_Selected_Component
- and then Chars (Selector_Name (Nam)) = Chars (E))
+ if (Is_Entity_Name (Nam) and then Chars (Nam) = Chars (E))
+ or else (Nkind (Nam) = N_Selected_Component
+ and then Chars (Selector_Name (Nam)) = Chars (E))
then
return True;
end if;
begin
- -- If the body is a subunit, the freeze point is the corresponding
- -- stub in the current compilation, not the subunit itself.
+ -- If the body is a subunit, the freeze point is the corresponding stub
+ -- in the current compilation, not the subunit itself.
if Nkind (Parent (Gen_Body)) = N_Subunit then
Orig_Body := Corresponding_Stub (Parent (Gen_Body));
end if;
end if;
- -- Perform atomic/volatile checks (RM C.6(12))
+ -- Perform atomic/volatile checks (RM C.6(12)). Note that AI05-0218-1
+ -- removes the second instance of the phrase "or allow pass by copy".
if Is_Atomic (Act_T) and then not Is_Atomic (Ancestor) then
Error_Msg_N
("cannot have atomic actual type for non-atomic formal type",
Actual);
- elsif Is_Volatile (Act_T)
- and then not Is_Volatile (Ancestor)
- and then Is_By_Reference_Type (Ancestor)
- then
+ elsif Is_Volatile (Act_T) and then not Is_Volatile (Ancestor) then
Error_Msg_N
("cannot have volatile actual type for non-volatile formal type",
Actual);
-- All other cases than aggregates
else
- -- For pragmas, we propagate the Enabled status for the
- -- relevant pragmas to the original generic tree. This was
- -- originally needed for SCO generation. It is no longer
- -- needed there (since we use the Sloc value in calls to
- -- Set_SCO_Pragma_Enabled), but it seems a generally good
- -- idea to have this flag set properly.
-
- if Nkind (N) = N_Pragma
- and then
- (Pragma_Name (N) = Name_Assert or else
- Pragma_Name (N) = Name_Check or else
- Pragma_Name (N) = Name_Precondition or else
- Pragma_Name (N) = Name_Postcondition)
- and then Present (Associated_Node (Pragma_Identifier (N)))
- then
- Set_Pragma_Enabled (N,
- Pragma_Enabled
- (Parent (Associated_Node (Pragma_Identifier (N)))));
- end if;
-
Save_Global_Descendant (Field1 (N));
Save_Global_Descendant (Field2 (N));
Save_Global_Descendant (Field3 (N));
projects / thirdparty / gcc.git / blobdiff