===================================================================
@@ -601,30 +601,35 @@
Build_Access_Subprogram_Type (P);
- -- For unrestricted access, kill current values, since this
- -- attribute allows a reference to a local subprogram that
- -- could modify local variables to be passed out of scope
+ -- For P'Access or P'Unrestricted_Access, where P is a nested
+ -- subprogram, we might be passing P to another subprogram (but we
+ -- don't check that here), which might call P. P could modify
+ -- local variables, so we need to kill current values. It is
+ -- important not to do this for library-level subprograms, because
+ -- Kill_Current_Values is very inefficient in the case of library
+ -- level packages with lots of tagged types.
- if Aname = Name_Unrestricted_Access then
+ if Is_Library_Level_Entity (Entity (Prefix (N))) then
+ null;
- -- Do not kill values on nodes initializing dispatch tables
- -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
- -- is currently generated by the expander only for this
- -- purpose. Done to keep the quality of warnings currently
- -- generated by the compiler (otherwise any declaration of
- -- a tagged type cleans constant indications from its scope).
+ -- Do not kill values on nodes initializing dispatch tables
+ -- slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
+ -- is currently generated by the expander only for this
+ -- purpose. Done to keep the quality of warnings currently
+ -- generated by the compiler (otherwise any declaration of
+ -- a tagged type cleans constant indications from its scope).
- if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
- and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr)
- or else
- Etype (Parent (N)) = RTE (RE_Size_Ptr))
- and then Is_Dispatching_Operation
- (Directly_Designated_Type (Etype (N)))
- then
- null;
- else
- Kill_Current_Values;
- end if;
+ elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion
+ and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr)
+ or else
+ Etype (Parent (N)) = RTE (RE_Size_Ptr))
+ and then Is_Dispatching_Operation
+ (Directly_Designated_Type (Etype (N)))
+ then
+ null;
+
+ else
+ Kill_Current_Values;
end if;
return;