From: Arnaud Charlet Date: Fri, 30 Jan 2015 11:20:27 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=760804f3b9b9127ea68abd96d1d96dc51c80f749;p=gcc.git [multiple changes] 2015-01-30 Yannick Moy * sem_attr.adb: Code clean up. 2015-01-30 Robert Dewar * ali.adb (Scan_ALI): Set Serious_Errors flag in Unit record. * ali.ads (Unit_Record): Add new field Serious_Errors. * lib-writ.adb (Write_Unit_Information): Set SE (serious errors) attribute in U line. * lib-writ.ads: New attribute SE (serious erors) in unit line. 2015-01-30 Hristian Kirtchev * einfo.adb Update the usage of attributes Entry_Bodies_Array, Lit_Indexes, Scale_Value, Storage_Size_Variable, String_Literal_Low_Bound along associated routines and Write_FieldX_Name. (Pending_Access_Types): New routine. (Set_Pending_Access_Types): New routine. (Write_Field15_Name): Add an entry for Pending_Access_Types. * einfo.ads Add new attribute Pending_Access_Types along with usage in nodes. Update the usage of attributes Entry_Bodies_Array, Lit_Indexes, Scale_Value, Storage_Size_Variable, String_Literal_Low_Bound. (Pending_Access_Types): New routine along with pragma Inline. (Set_Pending_Access_Types): New routine along with pragma Inline. * exp_ch3.adb (Expand_Freeze_Array_Type): Add new local variable Ins_Node. Determine the insertion node for anonynous access type that acts as a component type of an array. Update the call to Build_Finalization_Master. (Expand_Freeze_Record_Type): Update the calls to Build_Finalization_Master. (Freeze_Type): Remove local variable RACW_Seen. Factor out the code that deals with remote access-to-class-wide types. Create a finalization master when the designated type contains a private component. Fully initialize all pending access types. (Process_RACW_Types): New routine. (Process_Pending_Access_Types): New routine. * exp_ch4.adb (Expand_Allocator_Expression): Allocation no longer needs to set primitive Finalize_Address. (Expand_N_Allocator): Allocation no longer sets primitive Finalize_Address. * exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call): Update the call to Build_Finalization_Master. (Make_Build_In_Place_Call_In_Allocator): Allocation no longer needs to set primitive Finalize_Address. * exp_ch7.adb (Add_Pending_Access_Type): New routine. (Build_Finalization_Master): New parameter profile. Associate primitive Finalize_Address with the finalization master if the designated type has been frozen, otherwise treat the access type as pending. Simplify the insertion of the master and related initialization code. (Make_Finalize_Address_Body): Allow Finalize_Address for class-wide abstract types. (Make_Set_Finalize_Address_Call): Remove forlam parameter Typ. Simplify the implementation. * exp_ch7.ads (Build_Finalization_Master): New parameter profile along with comment on usage. (Make_Set_Finalize_Address_Call): Remove formal parameter Typ. Update the comment on usage. * exp_util.adb (Build_Allocate_Deallocate_Proc): Use routine Finalize_Address to retrieve the primitive. (Finalize_Address): New routine. (Find_Finalize_Address): Removed. * exp_util.ads (Finalize_Address): New routine. * freeze.adb (Freeze_All): Remove the generation of finalization masters. * sem_ch3.adb (Analyze_Full_Type_Declaration): Propagate any pending access types from the partial to the full view. From-SVN: r220279 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9fc99b8f8c1..56b0c13de15 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,75 @@ +2015-01-30 Yannick Moy + + * sem_attr.adb: Code clean up. + +2015-01-30 Robert Dewar + + * ali.adb (Scan_ALI): Set Serious_Errors flag in Unit record. + * ali.ads (Unit_Record): Add new field Serious_Errors. + * lib-writ.adb (Write_Unit_Information): Set SE (serious errors) + attribute in U line. + * lib-writ.ads: New attribute SE (serious erors) in unit line. + +2015-01-30 Hristian Kirtchev + + * einfo.adb Update the usage of attributes Entry_Bodies_Array, + Lit_Indexes, Scale_Value, Storage_Size_Variable, + String_Literal_Low_Bound along associated routines and + Write_FieldX_Name. + (Pending_Access_Types): New routine. + (Set_Pending_Access_Types): New routine. + (Write_Field15_Name): Add an entry for Pending_Access_Types. + * einfo.ads Add new attribute Pending_Access_Types along + with usage in nodes. Update the usage of attributes + Entry_Bodies_Array, Lit_Indexes, Scale_Value, + Storage_Size_Variable, String_Literal_Low_Bound. + (Pending_Access_Types): New routine along with pragma Inline. + (Set_Pending_Access_Types): New routine along with pragma Inline. + * exp_ch3.adb (Expand_Freeze_Array_Type): Add new local variable + Ins_Node. Determine the insertion node for anonynous access type + that acts as a component type of an array. Update the call to + Build_Finalization_Master. + (Expand_Freeze_Record_Type): Update + the calls to Build_Finalization_Master. + (Freeze_Type): Remove + local variable RACW_Seen. Factor out the code that deals with + remote access-to-class-wide types. Create a finalization master + when the designated type contains a private component. Fully + initialize all pending access types. + (Process_RACW_Types): New routine. + (Process_Pending_Access_Types): New routine. + * exp_ch4.adb (Expand_Allocator_Expression): Allocation no longer + needs to set primitive Finalize_Address. + (Expand_N_Allocator): Allocation no longer sets primitive + Finalize_Address. + * exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call): + Update the call to Build_Finalization_Master. + (Make_Build_In_Place_Call_In_Allocator): Allocation no longer + needs to set primitive Finalize_Address. + * exp_ch7.adb (Add_Pending_Access_Type): New routine. + (Build_Finalization_Master): New parameter profile. Associate + primitive Finalize_Address with the finalization master if the + designated type has been frozen, otherwise treat the access + type as pending. Simplify the insertion of the master and + related initialization code. + (Make_Finalize_Address_Body): Allow Finalize_Address for class-wide + abstract types. + (Make_Set_Finalize_Address_Call): Remove forlam parameter Typ. + Simplify the implementation. + * exp_ch7.ads (Build_Finalization_Master): New parameter profile + along with comment on usage. + (Make_Set_Finalize_Address_Call): Remove formal parameter Typ. Update + the comment on usage. + * exp_util.adb (Build_Allocate_Deallocate_Proc): Use routine + Finalize_Address to retrieve the primitive. + (Finalize_Address): New routine. + (Find_Finalize_Address): Removed. + * exp_util.ads (Finalize_Address): New routine. + * freeze.adb (Freeze_All): Remove the generation of finalization + masters. + * sem_ch3.adb (Analyze_Full_Type_Declaration): Propagate any + pending access types from the partial to the full view. + 2015-01-30 Robert Dewar * sem_disp.adb: Minor reformatting. diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index d46e3f97292..83bf2b99065 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -1704,6 +1704,7 @@ package body ALI is UL.Shared_Passive := False; UL.RCI := False; UL.Remote_Types := False; + UL.Serious_Errors := False; UL.Has_RACW := False; UL.Init_Scalars := False; UL.Is_Generic := False; @@ -1956,10 +1957,14 @@ package body ALI is Check_At_End_Of_Field; + -- SE/SP/SU parameters + elsif C = 'S' then C := Getc; - if C = 'P' then + if C = 'E' then + Units.Table (Units.Last).Serious_Errors := True; + elsif C = 'P' then Units.Table (Units.Last).Shared_Passive := True; elsif C = 'U' then Units.Table (Units.Last).Unit_Kind := 's'; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index c48d913d8a3..8dc87bb0fad 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -302,6 +302,10 @@ package ALI is -- Indicates presence of RT parameter for a package which has a -- pragma Remote_Types. + Serious_Errors : Boolean; + -- Indicates presence of SE parameter indicating that compilation of + -- the unit encountered as serious error. + Shared_Passive : Boolean; -- Indicates presence of SP parameter for a package which has a pragma -- Shared_Passive. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index de4e1ef540a..cfed66fe7c2 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -121,15 +121,11 @@ package body Einfo is -- Discriminant_Number Uint15 -- DT_Position Uint15 -- DT_Entry_Count Uint15 - -- Entry_Bodies_Array Node15 -- Entry_Parameters_Type Node15 -- Extra_Formal Node15 - -- Lit_Indexes Node15 + -- Pending_Access_Types Elist15 -- Related_Instance Node15 -- Status_Flag_Or_Transient_Decl Node15 - -- Scale_Value Uint15 - -- Storage_Size_Variable Node15 - -- String_Literal_Low_Bound Node15 -- Access_Disp_Table Elist16 -- Body_References Elist16 @@ -138,6 +134,7 @@ package body Einfo is -- Entry_Formal Node16 -- First_Private_Entity Node16 -- Lit_Strings Node16 + -- Scale_Value Uint16 -- String_Literal_Length Uint16 -- Unset_Reference Node16 @@ -159,14 +156,17 @@ package body Einfo is -- Delta_Value Ureal18 -- Enclosing_Scope Node18 -- Equivalent_Type Node18 + -- Lit_Indexes Node18 -- Private_Dependents Elist18 -- Renamed_Entity Node18 -- Renamed_Object Node18 + -- String_Literal_Low_Bound Node18 -- Body_Entity Node19 -- Corresponding_Discriminant Node19 -- Default_Aspect_Component_Value Node19 -- Default_Aspect_Value Node19 + -- Entry_Bodies_Array Node19 -- Extra_Accessibility_Of_Result Node19 -- Parent_Subtype Node19 -- Size_Check_Code Node19 @@ -226,10 +226,9 @@ package body Einfo is -- Dispatch_Table_Wrappers Elist26 -- Last_Assignment Node26 - -- Original_Access_Type Node26 -- Overridden_Operation Node26 -- Package_Instantiation Node26 - -- Relative_Deadline_Variable Node26 + -- Storage_Size_Variable Node26 -- Current_Use_Clause Node27 -- Related_Type Node27 @@ -238,6 +237,8 @@ package body Einfo is -- Extra_Formals Node28 -- Finalizer Node28 -- Initialization_Statements Node28 + -- Original_Access_Type Node28 + -- Relative_Deadline_Variable Node28 -- Underlying_Record_View Node28 -- BIP_Initialization_Call Node29 @@ -1093,7 +1094,7 @@ package body Einfo is function Entry_Bodies_Array (Id : E) return E is begin - return Node15 (Id); + return Node19 (Id); end Entry_Bodies_Array; function Entry_Cancel_Parameter (Id : E) return E is @@ -2505,7 +2506,7 @@ package body Einfo is function Lit_Indexes (Id : E) return E is begin pragma Assert (Is_Enumeration_Type (Id)); - return Node15 (Id); + return Node18 (Id); end Lit_Indexes; function Lit_Strings (Id : E) return E is @@ -2689,7 +2690,7 @@ package body Einfo is function Original_Access_Type (Id : E) return E is begin pragma Assert (Ekind (Id) = E_Access_Subprogram_Type); - return Node26 (Id); + return Node28 (Id); end Original_Access_Type; function Original_Array_Type (Id : E) return E is @@ -2738,6 +2739,12 @@ package body Einfo is return Elist9 (Id); end Part_Of_Constituents; + function Pending_Access_Types (Id : E) return L is + begin + pragma Assert (Is_Type (Id)); + return Elist15 (Id); + end Pending_Access_Types; + function Postcondition_Proc (Id : E) return E is begin pragma Assert (Ekind (Id) = E_Procedure); @@ -2853,7 +2860,7 @@ package body Einfo is function Relative_Deadline_Variable (Id : E) return E is begin pragma Assert (Is_Task_Type (Id)); - return Node26 (Implementation_Base_Type (Id)); + return Node28 (Implementation_Base_Type (Id)); end Relative_Deadline_Variable; function Renamed_Entity (Id : E) return N is @@ -2929,7 +2936,7 @@ package body Einfo is function Scale_Value (Id : E) return U is begin - return Uint15 (Id); + return Uint16 (Id); end Scale_Value; function Scope_Depth_Value (Id : E) return U is @@ -3063,7 +3070,7 @@ package body Einfo is function Storage_Size_Variable (Id : E) return E is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); - return Node15 (Implementation_Base_Type (Id)); + return Node26 (Implementation_Base_Type (Id)); end Storage_Size_Variable; function Static_Elaboration_Desired (Id : E) return B is @@ -3103,7 +3110,7 @@ package body Einfo is function String_Literal_Low_Bound (Id : E) return N is begin - return Node15 (Id); + return Node18 (Id); end String_Literal_Low_Bound; function Subprograms_For_Type (Id : E) return E is @@ -3920,7 +3927,7 @@ package body Einfo is procedure Set_Entry_Bodies_Array (Id : E; V : E) is begin - Set_Node15 (Id, V); + Set_Node19 (Id, V); end Set_Entry_Bodies_Array; procedure Set_Entry_Cancel_Parameter (Id : E; V : E) is @@ -5386,7 +5393,7 @@ package body Einfo is procedure Set_Lit_Indexes (Id : E; V : E) is begin pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id); - Set_Node15 (Id, V); + Set_Node18 (Id, V); end Set_Lit_Indexes; procedure Set_Lit_Strings (Id : E; V : E) is @@ -5576,7 +5583,7 @@ package body Einfo is procedure Set_Original_Access_Type (Id : E; V : E) is begin pragma Assert (Ekind (Id) = E_Access_Subprogram_Type); - Set_Node26 (Id, V); + Set_Node28 (Id, V); end Set_Original_Access_Type; procedure Set_Original_Array_Type (Id : E; V : E) is @@ -5625,6 +5632,12 @@ package body Einfo is Set_Elist9 (Id, V); end Set_Part_Of_Constituents; + procedure Set_Pending_Access_Types (Id : E; V : L) is + begin + pragma Assert (Is_Type (Id)); + Set_Elist15 (Id, V); + end Set_Pending_Access_Types; + procedure Set_Postcondition_Proc (Id : E; V : E) is begin pragma Assert (Ekind (Id) = E_Procedure); @@ -5748,7 +5761,7 @@ package body Einfo is procedure Set_Relative_Deadline_Variable (Id : E; V : E) is begin pragma Assert (Is_Task_Type (Id) and then Is_Base_Type (Id)); - Set_Node26 (Id, V); + Set_Node28 (Id, V); end Set_Relative_Deadline_Variable; procedure Set_Renamed_Entity (Id : E; V : N) is @@ -5827,7 +5840,7 @@ package body Einfo is procedure Set_Scale_Value (Id : E; V : U) is begin - Set_Uint15 (Id, V); + Set_Uint16 (Id, V); end Set_Scale_Value; procedure Set_Scope_Depth_Value (Id : E; V : U) is @@ -5972,7 +5985,7 @@ package body Einfo is begin pragma Assert (Is_Access_Type (Id) or else Is_Task_Type (Id)); pragma Assert (Id = Base_Type (Id)); - Set_Node15 (Id, V); + Set_Node26 (Id, V); end Set_Storage_Size_Variable; procedure Set_Static_Elaboration_Desired (Id : E; V : B) is @@ -6015,7 +6028,7 @@ package body Einfo is procedure Set_String_Literal_Low_Bound (Id : E; V : N) is begin pragma Assert (Ekind (Id) = E_String_Literal_Subtype); - Set_Node15 (Id, V); + Set_Node18 (Id, V); end Set_String_Literal_Low_Bound; procedure Set_Subprograms_For_Type (Id : E; V : E) is @@ -9092,36 +9105,23 @@ package body Einfo is E_Procedure => Write_Str ("DT_Position"); - when E_Protected_Type => - Write_Str ("Entry_Bodies_Array"); - when Entry_Kind => Write_Str ("Entry_Parameters_Type"); when Formal_Kind => Write_Str ("Extra_Formal"); - when Enumeration_Kind => - Write_Str ("Lit_Indexes"); + when Type_Kind => + Write_Str ("Pending_Access_Types"); when E_Package | E_Package_Body => Write_Str ("Related_Instance"); - when Decimal_Fixed_Point_Kind => - Write_Str ("Scale_Value"); - when E_Constant | E_Variable => Write_Str ("Status_Flag_Or_Transient_Decl"); - when Access_Kind | - Task_Kind => - Write_Str ("Storage_Size_Variable"); - - when E_String_Literal_Subtype => - Write_Str ("String_Literal_Low_Bound"); - when others => Write_Str ("Field15??"); end case; @@ -9160,6 +9160,9 @@ package body Einfo is when Enumeration_Kind => Write_Str ("Lit_Strings"); + when Decimal_Fixed_Point_Kind => + Write_Str ("Scale_Value"); + when E_String_Literal_Subtype => Write_Str ("String_Literal_Length"); @@ -9282,6 +9285,9 @@ package body Einfo is when Fixed_Point_Kind => Write_Str ("Delta_Value"); + when Enumeration_Kind => + Write_Str ("Lit_Indexes"); + when Incomplete_Or_Private_Kind | E_Record_Subtype => Write_Str ("Private_Dependents"); @@ -9296,6 +9302,9 @@ package body Einfo is E_Generic_Package => Write_Str ("Renamed_Entity"); + when E_String_Literal_Subtype => + Write_Str ("String_Literal_Low_Bound"); + when others => Write_Str ("Field18??"); end case; @@ -9321,6 +9330,14 @@ package body Einfo is when E_Array_Type => Write_Str ("Default_Component_Value"); + when E_Protected_Type => + Write_Str ("Entry_Bodies_Array"); + + when E_Function | + E_Operator | + E_Subprogram_Type => + Write_Str ("Extra_Accessibility_Of_Result"); + when E_Record_Type => Write_Str ("Parent_Subtype"); @@ -9335,9 +9352,6 @@ package body Einfo is when Private_Kind => Write_Str ("Underlying_Full_View"); - when E_Function | E_Operator | E_Subprogram_Type => - Write_Str ("Extra_Accessibility_Of_Result"); - when others => Write_Str ("Field19??"); end case; @@ -9648,8 +9662,9 @@ package body Einfo is E_Variable => Write_Str ("Last_Assignment"); - when E_Access_Subprogram_Type => - Write_Str ("Original_Access_Type"); + when E_Procedure | + E_Function => + Write_Str ("Overridden_Operation"); when E_Generic_Package | E_Package => @@ -9659,12 +9674,9 @@ package body Einfo is E_Constant => Write_Str ("Related_Type"); - when Task_Kind => - Write_Str ("Relative_Deadline_Variable"); - - when E_Procedure | - E_Function => - Write_Str ("Overridden_Operation"); + when Access_Kind | + Task_Kind => + Write_Str ("Storage_Size_Variable"); when others => Write_Str ("Field26??"); @@ -9719,6 +9731,12 @@ package body Einfo is E_Variable => Write_Str ("Initialization_Statements"); + when E_Access_Subprogram_Type => + Write_Str ("Original_Access_Type"); + + when Task_Kind => + Write_Str ("Relative_Deadline_Variable"); + when E_Record_Type => Write_Str ("Underlying_Record_View"); @@ -9867,6 +9885,7 @@ package body Einfo is case Ekind (Id) is when Subprogram_Kind => Write_Str ("Import_Pragma"); + when others => Write_Str ("Field35??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7d19e15f557..0c9fb61c917 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -1036,7 +1036,7 @@ package Einfo is -- at least one accept for this entry in the task body. Used to -- generate warnings for missing accepts. --- Entry_Bodies_Array (Node15) +-- Entry_Bodies_Array (Node19) -- Defined in protected types for which Has_Entries is true. -- This is the defining identifier for the array of entry body -- action procedures and barrier functions used by the runtime to @@ -3178,7 +3178,7 @@ package Einfo is -- field may be set as a result of a linker section pragma applied to the -- type of the object. --- Lit_Indexes (Node15) +-- Lit_Indexes (Node18) -- Defined in enumeration types and subtypes. Non-empty only for the -- case of an enumeration root type, where it contains the entity for -- the generated indexes entity. See unit Exp_Imgv for full details of @@ -3495,7 +3495,7 @@ package Einfo is -- Optimize_Alignment (Off) mode applies to the type/object, then neither -- of the flags Optimize_Alignment_Space/Optimize_Alignment_Time is set. --- Original_Access_Type (Node26) +-- Original_Access_Type (Node28) -- Defined in E_Access_Subprogram_Type entities. Set only if the access -- type was generated by the expander as part of processing an access -- to protected subprogram type. Points to the access to protected @@ -3578,6 +3578,14 @@ package Einfo is -- Present in abstract state entities. Contains all constituents that are -- subject to indicator Part_Of (both aspect and option variants). +-- Pending_Access_Types (Elist15) +-- Defined in all types. Set for incomplete, private, Taft-amendment +-- types, and their corresponding full views. This list contains all +-- access types, both named and anonymous, declared between the partial +-- and the full view. The list is used by the finalization machinery to +-- ensure that the finalization masters of all pending access types are +-- fully initialized when the full view is frozen. + -- Postcondition_Proc (Node8) -- Defined only in procedure entities, saves the entity of the generated -- postcondition proc if one is present, otherwise is set to Empty. Used @@ -3735,7 +3743,7 @@ package Einfo is -- associated dispatch table to point to entities containing primary or -- secondary tags. Not set in the _tag component of record types. --- Relative_Deadline_Variable (Node26) [implementation base type only] +-- Relative_Deadline_Variable (Node28) [implementation base type only] -- Defined in task type entities. This flag is set if a valid and -- effective pragma Relative_Deadline applies to the base type. Points -- to the entity for a variable that is created to hold the value given @@ -3852,7 +3860,7 @@ package Einfo is -- node (with a constraint), or a Range node, but not a simple -- subtype reference (a subtype is converted into a range). --- Scale_Value (Uint15) +-- Scale_Value (Uint16) -- Defined in decimal fixed-point types and subtypes. Contains the scale -- for the type (i.e. the value of type'Scale = the number of decimal -- digits after the decimal point). @@ -4043,7 +4051,7 @@ package Einfo is -- This attribute uses the same field as Overridden_Operation, which is -- irrelevant in init_procs. --- Storage_Size_Variable (Node15) [implementation base type only] +-- Storage_Size_Variable (Node26) [implementation base type only] -- Defined in access types and task type entities. This flag is set -- if a valid and effective pragma Storage_Size applies to the base -- type. Points to the entity for a variable that is created to @@ -4073,7 +4081,7 @@ package Einfo is -- to string literals in the program). Contains the length of the string -- literal. --- String_Literal_Low_Bound (Node15) +-- String_Literal_Low_Bound (Node18) -- Defined in string literal subtypes (which are created to correspond -- to string literals in the program). Contains an expression whose -- value represents the low bound of the literal. This is a copy of @@ -5280,6 +5288,7 @@ package Einfo is -- Esize (Uint12) -- RM_Size (Uint13) -- Alignment (Uint14) + -- Pending_Access_Types (Elist15) -- Related_Expression (Node24) -- Current_Use_Clause (Node27) -- Subprograms_For_Type (Node29) @@ -5396,17 +5405,17 @@ package Einfo is -- Directly_Designated_Type (Node20) -- Interface_Name (Node21) (JGNAT usage only) -- Needs_No_Actuals (Flag22) - -- Original_Access_Type (Node26) + -- Original_Access_Type (Node28) -- Can_Use_Internal_Rep (Flag229) -- (plus type attributes) -- E_Access_Type -- E_Access_Subtype - -- Storage_Size_Variable (Node15) (base type only) -- Master_Id (Node17) -- Directly_Designated_Type (Node20) -- Associated_Storage_Pool (Node22) (base type only) -- Finalization_Master (Node23) (base type only) + -- Storage_Size_Variable (Node26) (base type only) -- Has_Pragma_Controlled (Flag27) (base type only) -- Has_Storage_Size_Clause (Flag23) (base type only) -- Is_Access_Constant (Flag69) @@ -5426,15 +5435,15 @@ package Einfo is -- E_Anonymous_Access_Subprogram_Type -- E_Anonymous_Access_Protected_Subprogram_Type - -- Storage_Size_Variable (Node15) ??? is this needed ??? -- Directly_Designated_Type (Node20) + -- Storage_Size_Variable (Node26) ??? is this needed ??? -- Can_Use_Internal_Rep (Flag229) -- (plus type attributes) -- E_Anonymous_Access_Type - -- Storage_Size_Variable (Node15) ??? is this needed ??? -- Directly_Designated_Type (Node20) -- Finalization_Master (Node23) + -- Storage_Size_Variable (Node26) ??? is this needed ??? -- (plus type attributes) -- E_Array_Type @@ -5558,7 +5567,7 @@ package Einfo is -- E_Decimal_Fixed_Point_Type -- E_Decimal_Fixed_Subtype - -- Scale_Value (Uint15) + -- Scale_Value (Uint16) -- Digits_Value (Uint17) -- Scalar_Range (Node20) -- Delta_Value (Ureal18) @@ -5631,9 +5640,9 @@ package Einfo is -- E_Enumeration_Type -- E_Enumeration_Subtype - -- Lit_Indexes (Node15) (root type only) -- Lit_Strings (Node16) (root type only) -- First_Literal (Node17) + -- Lit_Indexes (Node18) (root type only) -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) -- Enum_Pos_To_Rep (Node23) (type only) @@ -5768,11 +5777,11 @@ package Einfo is -- Scope_Depth (synth) -- E_General_Access_Type - -- Storage_Size_Variable (Node15) (base type only) -- Master_Id (Node17) -- Directly_Designated_Type (Node20) -- Associated_Storage_Pool (Node22) (root type only) -- Finalization_Master (Node23) (root type only) + -- Storage_Size_Variable (Node26) (base type only) -- (plus type attributes) -- E_Generic_In_Parameter @@ -6072,10 +6081,10 @@ package Einfo is -- E_Protected_Type -- E_Protected_Subtype -- Direct_Primitive_Operations (Elist10) - -- Entry_Bodies_Array (Node15) -- First_Private_Entity (Node16) -- First_Entity (Node17) -- Corresponding_Record_Type (Node18) + -- Entry_Bodies_Array (Node19) -- Last_Entity (Node20) -- Discriminant_Constraint (Elist21) -- Scope_Depth_Value (Uint22) @@ -6170,9 +6179,9 @@ package Einfo is -- (plus type attributes) -- E_String_Literal_Subtype - -- String_Literal_Low_Bound (Node15) -- String_Literal_Length (Uint16) -- First_Index (Node17) (always Empty) + -- String_Literal_Low_Bound (Node18) -- Packed_Array_Impl_Type (Node23) -- (plus type attributes) @@ -6205,7 +6214,6 @@ package Einfo is -- E_Task_Type -- E_Task_Subtype -- Direct_Primitive_Operations (Elist10) - -- Storage_Size_Variable (Node15) (base type only) -- First_Private_Entity (Node16) -- First_Entity (Node17) -- Corresponding_Record_Type (Node18) @@ -6215,6 +6223,8 @@ package Einfo is -- Scope_Depth (synth) -- Stored_Constraint (Elist23) -- Task_Body_Procedure (Node25) + -- Storage_Size_Variable (Node26) (base type only) + -- Relative_Deadline_Variable (Node28) (base type only) -- Delay_Cleanups (Flag114) -- Has_Master_Entity (Flag21) -- Has_Storage_Size_Clause (Flag23) (base type only) @@ -6222,7 +6232,6 @@ package Einfo is -- Sec_Stack_Needed_For_Return (Flag167) ??? -- Has_Entries (synth) -- Number_Entries (synth) - -- Relative_Deadline_Variable (Node26) (base type only) -- (plus type attributes) -- E_Variable @@ -6868,6 +6877,7 @@ package Einfo is function Packed_Array_Impl_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; function Part_Of_Constituents (Id : E) return L; + function Pending_Access_Types (Id : E) return L; function Postcondition_Proc (Id : E) return E; function Prival (Id : E) return E; function Prival_Link (Id : E) return E; @@ -7514,6 +7524,7 @@ package Einfo is procedure Set_Packed_Array_Impl_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); procedure Set_Part_Of_Constituents (Id : E; V : L); + procedure Set_Pending_Access_Types (Id : E; V : L); procedure Set_Postcondition_Proc (Id : E; V : E); procedure Set_Prival (Id : E; V : E); procedure Set_Prival_Link (Id : E; V : E); @@ -8312,6 +8323,7 @@ package Einfo is pragma Inline (Parameter_Mode); pragma Inline (Parent_Subtype); pragma Inline (Part_Of_Constituents); + pragma Inline (Pending_Access_Types); pragma Inline (Postcondition_Proc); pragma Inline (Prival); pragma Inline (Prival_Link); @@ -8757,6 +8769,7 @@ package Einfo is pragma Inline (Set_Packed_Array_Impl_Type); pragma Inline (Set_Parent_Subtype); pragma Inline (Set_Part_Of_Constituents); + pragma Inline (Set_Pending_Access_Types); pragma Inline (Set_Postcondition_Proc); pragma Inline (Set_Prival); pragma Inline (Set_Prival_Link); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 3ee51ef8662..2a4b0875003 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -2395,16 +2395,14 @@ package body Exp_Ch3 is declare Parent_IP : constant Name_Id := Make_Init_Proc_Name (Etype (Rec_Ent)); - Stmt : Node_Id; - IP_Call : Node_Id; + Stmt : Node_Id := First (Stmts); + IP_Call : Node_Id := Empty; IP_Stmts : List_Id; begin -- Look for a call to the parent IP at the beginning -- of Stmts associated with the record extension - Stmt := First (Stmts); - IP_Call := Empty; while Present (Stmt) loop if Nkind (Stmt) = N_Procedure_Call_Statement and then Chars (Name (Stmt)) = Parent_IP @@ -6318,8 +6316,9 @@ package body Exp_Ch3 is procedure Expand_Freeze_Array_Type (N : Node_Id) is Typ : constant Entity_Id := Entity (N); - Comp_Typ : constant Entity_Id := Component_Type (Typ); Base : constant Entity_Id := Base_Type (Typ); + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Ins_Node : Node_Id; begin if not Is_Bit_Packed_Array (Typ) then @@ -6386,10 +6385,22 @@ package body Exp_Ch3 is if Ekind (Comp_Typ) = E_Anonymous_Access_Type and then Needs_Finalization (Designated_Type (Comp_Typ)) then + -- The finalization master is inserted before the declaration + -- of the array type. The only exception to this is when the + -- array type is an itype, in which case the master appears + -- before the related context. + + if Is_Itype (Typ) then + Ins_Node := Associated_Node_For_Itype (Typ); + else + Ins_Node := Parent (Typ); + end if; + Build_Finalization_Master - (Typ => Comp_Typ, - Ins_Node => Parent (Typ), - Encl_Scope => Scope (Typ)); + (Typ => Comp_Typ, + For_Anonymous => True, + Context_Scope => Scope (Typ), + Insertion_Node => Ins_Node); end if; end if; @@ -7342,9 +7353,10 @@ package body Exp_Ch3 is (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); Build_Finalization_Master - (Typ => Root_Type (Comp_Typ), - Ins_Node => Ins_Node, - Encl_Scope => Encl_Scope); + (Typ => Root_Type (Comp_Typ), + For_Anonymous => True, + Context_Scope => Encl_Scope, + Insertion_Node => Ins_Node); Fin_Mas_Id := Finalization_Master (Comp_Typ); @@ -7387,9 +7399,10 @@ package body Exp_Ch3 is else Build_Finalization_Master - (Typ => Comp_Typ, - Ins_Node => Ins_Node, - Encl_Scope => Encl_Scope); + (Typ => Comp_Typ, + For_Anonymous => True, + Context_Scope => Encl_Scope, + Insertion_Node => Ins_Node); end if; end if; @@ -7466,9 +7479,97 @@ package body Exp_Ch3 is -- Save the current Ghost mode in effect in case the type being frozen -- sets a different mode. + procedure Process_RACW_Types (Typ : Entity_Id); + -- Validate and generate stubs for all RACW types associated with type + -- Typ. + + procedure Process_Pending_Access_Types (Typ : Entity_Id); + -- Associate type Typ's Finalize_Address primitive with the finalization + -- masters of pending access-to-Typ types. + procedure Restore_Globals; -- Restore the values of all saved global variables + ------------------------ + -- Process_RACW_Types -- + ------------------------ + + procedure Process_RACW_Types (Typ : Entity_Id) is + List : constant Elist_Id := Access_Types_To_Process (N); + E : Elmt_Id; + Seen : Boolean := False; + + begin + if Present (List) then + E := First_Elmt (List); + while Present (E) loop + if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then + Validate_RACW_Primitives (Node (E)); + Seen := True; + end if; + + Next_Elmt (E); + end loop; + end if; + + -- If there are RACWs designating this type, make stubs now + + if Seen then + Remote_Types_Tagged_Full_View_Encountered (Typ); + end if; + end Process_RACW_Types; + + ---------------------------------- + -- Process_Pending_Access_Types -- + ---------------------------------- + + procedure Process_Pending_Access_Types (Typ : Entity_Id) is + E : Elmt_Id; + + begin + -- Finalize_Address is not generated in CodePeer mode because the + -- body contains address arithmetic. This processing is disabled. + + if CodePeer_Mode then + null; + + -- Certain itypes are generated for contexts that cannot allocate + -- objects and should not set primitive Finalize_Address. + + elsif Is_Itype (Typ) + and then Nkind (Associated_Node_For_Itype (Typ)) = + N_Explicit_Dereference + then + null; + + -- When an access type is declared after the incomplete view of a + -- Taft-amendment type, the access type is considered pending in + -- case the full view of the Taft-amendment type is controlled. If + -- this is indeed the case, associate the Finalize_Address routine + -- of the full view with the finalization masters of all pending + -- access types. This scenario applies to anonymous access types as + -- well. + + elsif Needs_Finalization (Typ) + and then Present (Pending_Access_Types (Typ)) + then + E := First_Elmt (Pending_Access_Types (Typ)); + while Present (E) loop + + -- Generate: + -- Set_Finalize_Address + -- (Ptr_Typ, FD'Unrestricted_Access); + + Append_Freeze_Action (Typ, + Make_Set_Finalize_Address_Call + (Loc => Sloc (N), + Ptr_Typ => Node (E))); + + Next_Elmt (E); + end loop; + end if; + end Process_Pending_Access_Types; + --------------------- -- Restore_Globals -- --------------------- @@ -7480,9 +7581,8 @@ package body Exp_Ch3 is -- Local variables - Def_Id : constant Entity_Id := Entity (N); - RACW_Seen : Boolean := False; - Result : Boolean := False; + Def_Id : constant Entity_Id := Entity (N); + Result : Boolean := False; -- Start of processing for Freeze_Type @@ -7493,29 +7593,10 @@ package body Exp_Ch3 is Set_Ghost_Mode_For_Freeze (Def_Id, N); - -- Process associated access types needing special processing - - if Present (Access_Types_To_Process (N)) then - declare - E : Elmt_Id := First_Elmt (Access_Types_To_Process (N)); - - begin - while Present (E) loop - if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then - Validate_RACW_Primitives (Node (E)); - RACW_Seen := True; - end if; - - E := Next_Elmt (E); - end loop; - end; - - -- If there are RACWs designating this type, make stubs now + -- Process any remote access-to-class-wide types designating the type + -- being frozen. - if RACW_Seen then - Remote_Types_Tagged_Full_View_Encountered (Def_Id); - end if; - end if; + Process_RACW_Types (Def_Id); -- Freeze processing for record types @@ -7760,18 +7841,26 @@ package body Exp_Ch3 is then null; - -- Assume that incomplete and private types are always completed - -- by a controlled full view. + -- Create a finalization master for an access-to-controlled type + -- or an access-to-incomplete type. It is assumed that the full + -- view will be controlled. elsif Needs_Finalization (Desig_Type) - or else - (Is_Incomplete_Or_Private_Type (Desig_Type) - and then No (Full_View (Desig_Type))) - or else - (Is_Array_Type (Desig_Type) - and then Needs_Finalization (Component_Type (Desig_Type))) + or else (Is_Incomplete_Type (Desig_Type) + and then No (Full_View (Desig_Type))) then Build_Finalization_Master (Def_Id); + + -- Create a finalization master when the designated type contains + -- a private component. It is assumed that the full view will be + -- controlled. + + elsif Has_Private_Component (Desig_Type) then + Build_Finalization_Master + (Typ => Def_Id, + For_Private => True, + Context_Scope => Scope (Def_Id), + Insertion_Node => Declaration_Node (Desig_Type)); end if; end; @@ -7810,6 +7899,11 @@ package body Exp_Ch3 is end if; + -- Complete the initialization of all pending access types' finalization + -- masters now that the designated type has been is frozen and primitive + -- Finalize_Address generated. + + Process_Pending_Access_Types (Def_Id); Freeze_Stream_Operations (N, Def_Id); Restore_Globals; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0e1b7ff9034..98b24a9a6a1 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -1278,30 +1278,6 @@ package body Exp_Ch4 is Prefix => New_Occurrence_Of (Temp, Loc))), Typ => T)); end if; - - -- Generate: - -- Set_Finalize_Address (FM, FD'Unrestricted_Access); - - -- Do not generate this call in the following cases: - - -- * .NET/JVM - these targets do not support address arithmetic - -- and unchecked conversion, key elements of Finalize_Address. - - -- * CodePeer mode - TSS primitive Finalize_Address is not - -- created in this mode. - - if VM_Target = No_VM - and then not CodePeer_Mode - and then Present (Finalization_Master (PtrT)) - and then Present (Temp_Decl) - and then Nkind (Expression (Temp_Decl)) = N_Allocator - then - Insert_Action (N, - Make_Set_Finalize_Address_Call - (Loc => Loc, - Typ => T, - Ptr_Typ => PtrT)); - end if; end if; Rewrite (N, New_Occurrence_Of (Temp, Loc)); @@ -4868,40 +4844,22 @@ package body Exp_Ch4 is (Obj_Ref => New_Copy_Tree (Init_Arg1), Typ => T)); - if Present (Finalization_Master (PtrT)) then - - -- Special processing for .NET/JVM, the allocated object - -- is attached to the finalization master. Generate: - - -- Attach (FM, Root_Controlled_Ptr (Init_Arg1)); + -- Special processing for .NET/JVM, the allocated object is + -- attached to the finalization master. Generate: - -- Types derived from [Limited_]Controlled are the only - -- ones considered since they have fields Prev and Next. - - if VM_Target /= No_VM then - if Is_Controlled (T) then - Insert_Action (N, - Make_Attach_Call - (Obj_Ref => New_Copy_Tree (Init_Arg1), - Ptr_Typ => PtrT)); - end if; + -- Attach (FM, Root_Controlled_Ptr (Init_Arg1)); - -- Default case, generate: + -- Types derived from [Limited_]Controlled are the only ones + -- considered since they have fields Prev and Next. - -- Set_Finalize_Address - -- (FM, FD'Unrestricted_Access); - - -- Do not generate this call in CodePeer mode, as TSS - -- primitive Finalize_Address is not created in this - -- mode. - - elsif not CodePeer_Mode then - Insert_Action (N, - Make_Set_Finalize_Address_Call - (Loc => Loc, - Typ => T, - Ptr_Typ => PtrT)); - end if; + if VM_Target /= No_VM + and then Is_Controlled (T) + and then Present (Finalization_Master (PtrT)) + then + Insert_Action (N, + Make_Attach_Call + (Obj_Ref => New_Copy_Tree (Init_Arg1), + Ptr_Typ => PtrT)); end if; end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 5279e85a3c1..57763704228 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -415,9 +415,10 @@ package body Exp_Ch6 is and then No (Finalization_Master (Ptr_Typ)) then Build_Finalization_Master - (Typ => Ptr_Typ, - Ins_Node => Associated_Node_For_Itype (Ptr_Typ), - Encl_Scope => Scope (Ptr_Typ)); + (Typ => Ptr_Typ, + For_Anonymous => True, + Context_Scope => Scope (Ptr_Typ), + Insertion_Node => Associated_Node_For_Itype (Ptr_Typ)); end if; -- Access-to-controlled types should always have a master @@ -8357,33 +8358,6 @@ package body Exp_Ch6 is Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Return_Obj_Actual); - -- If the build-in-place function call returns a controlled object, - -- the finalization master will require a reference to routine - -- Finalize_Address of the designated type. Setting this attribute - -- is done in the same manner to expansion of allocators. - - if Needs_Finalization (Result_Subt) then - - -- Controlled types with supressed finalization do not need to - -- associate the address of their Finalize_Address primitives with - -- a master since they do not need a master to begin with. - - if Is_Library_Level_Entity (Acc_Type) - and then Finalize_Storage_Only (Result_Subt) - then - null; - - -- Do not generate the call to Set_Finalize_Address in CodePeer mode - -- because Finalize_Address is never built. - - elsif not CodePeer_Mode then - Insert_Action (Allocator, - Make_Set_Finalize_Address_Call (Loc, - Typ => Etype (Function_Id), - Ptr_Typ => Acc_Type)); - end if; - end if; - -- Finally, replace the allocator node with a reference to the temp Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index f611fada6d4..a9a242e9b23 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -764,14 +764,42 @@ package body Exp_Ch7 is ------------------------------- procedure Build_Finalization_Master - (Typ : Entity_Id; - Ins_Node : Node_Id := Empty; - Encl_Scope : Entity_Id := Empty) + (Typ : Entity_Id; + For_Anonymous : Boolean := False; + For_Private : Boolean := False; + Context_Scope : Entity_Id := Empty; + Insertion_Node : Node_Id := Empty) is + procedure Add_Pending_Access_Type + (Typ : Entity_Id; + Ptr_Typ : Entity_Id); + -- Add access type Ptr_Typ to the pending access type list for type Typ + function In_Deallocation_Instance (E : Entity_Id) return Boolean; -- Determine whether entity E is inside a wrapper package created for -- an instance of Ada.Unchecked_Deallocation. + ----------------------------- + -- Add_Pending_Access_Type -- + ----------------------------- + + procedure Add_Pending_Access_Type + (Typ : Entity_Id; + Ptr_Typ : Entity_Id) + is + List : Elist_Id; + + begin + if Present (Pending_Access_Types (Typ)) then + List := Pending_Access_Types (Typ); + else + List := New_Elmt_List; + Set_Pending_Access_Types (Typ, List); + end if; + + Prepend_Elmt (Ptr_Typ, List); + end Add_Pending_Access_Type; + ------------------------------ -- In_Deallocation_Instance -- ------------------------------ @@ -799,7 +827,7 @@ package body Exp_Ch7 is -- Local variables - Desig_Typ : constant Entity_Id := Directly_Designated_Type (Typ); + Desig_Typ : constant Entity_Id := Designated_Type (Typ); Ptr_Typ : constant Entity_Id := Root_Type_Of_Full_View (Base_Type (Typ)); -- A finalization master created for a named access type is associated @@ -855,7 +883,7 @@ package body Exp_Ch7 is -- requires a finalization master. elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type - and then No (Ins_Node) + and then not For_Anonymous then return; @@ -874,25 +902,21 @@ package body Exp_Ch7 is elsif VM_Target /= No_VM and then not Is_Controlled (Desig_Typ) then return; - -- Do not create finalization masters in SPARK mode because they result - -- in unwanted expansion. - - -- More detail would be useful here ??? + -- Do not create finalization masters in GNATprove mode because this + -- unwanted extra expansion. A compilation in this mode keeps the tree + -- as close as possible to the original sources. elsif GNATprove_Mode then return; end if; declare + Actions : constant List_Id := New_List; Loc : constant Source_Ptr := Sloc (Ptr_Typ); - Actions : constant List_Id := New_List; Fin_Mas_Id : Entity_Id; Pool_Id : Entity_Id; begin - -- Generate: - -- Fnn : aliased Finalization_Master; - -- Source access types use fixed master names since the master is -- inserted in the same source unit only once. The only exception to -- this are instances using the same access type as generic actual. @@ -910,6 +934,11 @@ package body Exp_Ch7 is Fin_Mas_Id := Make_Temporary (Loc, 'F'); end if; + Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); + + -- Generate: + -- FM : aliased Finalization_Master; + Append_To (Actions, Make_Object_Declaration (Loc, Defining_Identifier => Fin_Mas_Id, @@ -917,19 +946,18 @@ package body Exp_Ch7 is Object_Definition => New_Occurrence_Of (RTE (RE_Finalization_Master), Loc))); - -- Storage pool selection and attribute decoration of the generated - -- master. Since .NET/JVM compilers do not support pools, this step - -- is skipped. + -- Set the associated pool and primitive Finalize_Address of the new + -- finalization master. This step is skipped on .NET/JVM because the + -- target does not support storage pools or address arithmetic. if VM_Target = No_VM then - -- If the access type has a user-defined pool, use it as the base - -- storage medium for the finalization pool. + -- The access type has a user-defined storage pool, use it if Present (Associated_Storage_Pool (Ptr_Typ)) then Pool_Id := Associated_Storage_Pool (Ptr_Typ); - -- The default choice is the global pool + -- Otherwise the default choice is the global storage pool else Pool_Id := RTE (RE_Global_Pool_Object); @@ -937,7 +965,7 @@ package body Exp_Ch7 is end if; -- Generate: - -- Set_Base_Pool (Fnn, Pool_Id'Unchecked_Access); + -- Set_Base_Pool (FM, Pool_Id'Unchecked_Access); Append_To (Actions, Make_Procedure_Call_Statement (Loc, @@ -948,67 +976,90 @@ package body Exp_Ch7 is Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Pool_Id, Loc), Attribute_Name => Name_Unrestricted_Access)))); + + -- Finalize_Address is not generated in CodePeer mode because the + -- body contains address arithmetic. Skip this step. + + if CodePeer_Mode then + null; + + -- Associate the Finalize_Address primitive of the designated type + -- with the finalization master of the access type. The designated + -- type must be forzen as Finalize_Address is generated when the + -- freeze node is expanded. + + elsif Is_Frozen (Desig_Typ) + and then Present (Finalize_Address (Desig_Typ)) + + -- The finalization master of an anonymous access type may need + -- to be inserted in a specific place in the tree. For instance: + + -- type Comp_Typ; + + -- + + -- type Rec_Typ is record + -- Comp : access Comp_Typ; + -- end record; + + -- + -- + + -- Due to this oddity, the anonymous access type is stored for + -- later processing (see below). + + and then Ekind (Ptr_Typ) /= E_Anonymous_Access_Type + then + -- Generate: + -- Set_Finalize_Address + -- (FM, FD'Unrestricted_Access); + + Append_To (Actions, + Make_Set_Finalize_Address_Call + (Loc => Loc, + Ptr_Typ => Ptr_Typ)); + + -- Otherwise the designated type is either anonymous access or a + -- Taft-amendment type and has not been frozen. Store the access + -- type for later processing (see Freeze_Type). + + else + Add_Pending_Access_Type (Desig_Typ, Ptr_Typ); + end if; end if; - Set_Finalization_Master (Ptr_Typ, Fin_Mas_Id); + -- A finalization master created for an anonymous access type or an + -- access designating a type with private components must be inserted + -- before a context-dependent node. - -- A finalization master created for an anonymous access type must be - -- inserted before a context-dependent node. + if For_Anonymous or For_Private then - if Present (Ins_Node) then - Push_Scope (Encl_Scope); + -- At this point both the scope of the context and the insertion + -- mode must be known. + + pragma Assert (Present (Context_Scope)); + pragma Assert (Present (Insertion_Node)); + + Push_Scope (Context_Scope); -- Treat use clauses as declarations and insert directly in front -- of them. - if Nkind_In (Ins_Node, N_Use_Package_Clause, - N_Use_Type_Clause) + if Nkind_In (Insertion_Node, N_Use_Package_Clause, + N_Use_Type_Clause) then - Insert_List_Before_And_Analyze (Ins_Node, Actions); + Insert_List_Before_And_Analyze (Insertion_Node, Actions); else - Insert_Actions (Ins_Node, Actions); + Insert_Actions (Insertion_Node, Actions); end if; Pop_Scope; - elsif Ekind (Desig_Typ) = E_Incomplete_Type - and then Has_Completion_In_Body (Desig_Typ) - then - Insert_Actions (Parent (Ptr_Typ), Actions); - - -- If the designated type is not yet frozen, then append the actions - -- to that type's freeze actions. The actions need to be appended to - -- whichever type is frozen later, similarly to what Freeze_Type does - -- for appending the storage pool declaration for an access type. - -- Otherwise, the call to Set_Storage_Pool_Ptr might reference the - -- pool object before it's declared. However, it's not clear that - -- this is exactly the right test to accomplish that here. ??? - - elsif Present (Freeze_Node (Desig_Typ)) - and then not Analyzed (Freeze_Node (Desig_Typ)) - then - Append_Freeze_Actions (Desig_Typ, Actions); - - elsif Present (Freeze_Node (Ptr_Typ)) - and then not Analyzed (Freeze_Node (Ptr_Typ)) - then - Append_Freeze_Actions (Ptr_Typ, Actions); - - -- If there's a pool created locally for the access type, then we - -- need to ensure that the master gets created after the pool object, - -- because otherwise we can have a forward reference, so we force the - -- master actions to be inserted and analyzed after the pool entity. - -- Note that both the access type and its designated type may have - -- already been frozen and had their freezing actions analyzed at - -- this point. (This seems a little unclean.???) - - elsif VM_Target = No_VM - and then Scope (Pool_Id) = Scope (Ptr_Typ) - then - Insert_List_After_And_Analyze (Parent (Pool_Id), Actions); + -- Otherwise the finalization master and its initialization become a + -- part of the freeze node. else - Insert_Actions (Parent (Ptr_Typ), Actions); + Append_Freeze_Actions (Ptr_Typ, Actions); end if; end; end Build_Finalization_Master; @@ -7397,7 +7448,6 @@ package body Exp_Ch7 is -- do not need the Finalize_Address primitive. elsif not Needs_Finalization (Typ) - or else Is_Abstract_Type (Typ) or else Present (TSS (Typ, TSS_Finalize_Address)) or else (Is_Class_Wide_Type (Typ) @@ -7801,85 +7851,32 @@ package body Exp_Ch7 is function Make_Set_Finalize_Address_Call (Loc : Source_Ptr; - Typ : Entity_Id; Ptr_Typ : Entity_Id) return Node_Id is - Desig_Typ : constant Entity_Id := - Available_View (Designated_Type (Ptr_Typ)); - Fin_Mas_Id : constant Entity_Id := Finalization_Master (Ptr_Typ); - Fin_Mas_Ref : Node_Id; - Utyp : Entity_Id; + Desig_Typ : constant Entity_Id := + Available_View (Designated_Type (Ptr_Typ)); + Fin_Addr : constant Entity_Id := Finalize_Address (Desig_Typ); + Fin_Mas : constant Entity_Id := Finalization_Master (Ptr_Typ); begin - -- If the context is a class-wide allocator, we use the class-wide type - -- to obtain the proper Finalize_Address routine. - - if Is_Class_Wide_Type (Desig_Typ) then - Utyp := Desig_Typ; - - else - Utyp := Typ; - - if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then - Utyp := Full_View (Utyp); - end if; - - if Is_Concurrent_Type (Utyp) then - Utyp := Corresponding_Record_Type (Utyp); - end if; - end if; - - Utyp := Underlying_Type (Base_Type (Utyp)); + -- Both the finalization master and primitive Finalize_Address must be + -- available. - -- Deal with untagged derivation of private views. If the parent is - -- now known to be protected, the finalization routine is the one - -- defined on the corresponding record of the ancestor (corresponding - -- records do not automatically inherit operations, but maybe they - -- should???) - - if Is_Untagged_Derivation (Typ) then - if Is_Protected_Type (Typ) then - Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); - else - Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); - - if Is_Protected_Type (Utyp) then - Utyp := Corresponding_Record_Type (Utyp); - end if; - end if; - end if; - - -- If the underlying_type is a subtype, we are dealing with the - -- completion of a private type. We need to access the base type and - -- generate a conversion to it. - - if Utyp /= Base_Type (Utyp) then - pragma Assert (Is_Private_Type (Typ)); - - Utyp := Base_Type (Utyp); - end if; - - Fin_Mas_Ref := New_Occurrence_Of (Fin_Mas_Id, Loc); - - -- If the call is from a build-in-place function, the Master parameter - -- is actually a pointer. Dereference it for the call. - - if Is_Access_Type (Etype (Fin_Mas_Id)) then - Fin_Mas_Ref := Make_Explicit_Dereference (Loc, Fin_Mas_Ref); - end if; + pragma Assert (Present (Fin_Addr) and Present (Fin_Mas)); -- Generate: - -- Set_Finalize_Address (FM, FD'Unrestricted_Access); + -- Set_Finalize_Address + -- (FM, FD'Unrestricted_Access); return Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (RTE (RE_Set_Finalize_Address), Loc), Parameter_Associations => New_List ( - Fin_Mas_Ref, + New_Occurrence_Of (Fin_Mas, Loc), + Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (TSS (Utyp, TSS_Finalize_Address), Loc), + Prefix => New_Occurrence_Of (Fin_Addr, Loc), Attribute_Name => Name_Unrestricted_Access))); end Make_Set_Finalize_Address_Call; diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index ee24e6d6d55..f47abe86442 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -98,17 +98,20 @@ package Exp_Ch7 is -- exception will be saved to a global location. procedure Build_Finalization_Master - (Typ : Entity_Id; - Ins_Node : Node_Id := Empty; - Encl_Scope : Entity_Id := Empty); + (Typ : Entity_Id; + For_Anonymous : Boolean := False; + For_Private : Boolean := False; + Context_Scope : Entity_Id := Empty; + Insertion_Node : Node_Id := Empty); -- Build a finalization master for an access type. The designated type may - -- not necessarely be controlled or need finalization actions. The routine - -- creates a wrapper around a user-defined storage pool or the general - -- storage pool for access types. Ins_Nod and Encl_Scope are used in - -- conjunction with anonymous access types. Ins_Node designates the - -- insertion point before which the collection should be added. Encl_Scope - -- is the scope of the context, either the enclosing record or the scope - -- of the related function. + -- not necessarely be controlled or need finalization actions depending on + -- the context. Flag For_Anonymous must be set when creating a master for + -- an anonymous access type. Flag For_Private must be set when the + -- designated type contains a private component. Parameters Context_Scope + -- and Insertion_Node must be used in conjunction with flags For_Anonymous + -- and For_Private. Context_Scope is the scope of the context where the + -- finalization master must be analyzed. Insertion_Node is the insertion + -- point before which the master is inserted. procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id); -- Build one controlling procedure when a late body overrides one of @@ -222,15 +225,13 @@ package Exp_Ch7 is function Make_Set_Finalize_Address_Call (Loc : Source_Ptr; - Typ : Entity_Id; Ptr_Typ : Entity_Id) return Node_Id; + -- Associate the Finalize_Address primitive of the designated type with the + -- finalization master of access type Ptr_Typ. The returned call is: -- Generate the following call: -- - -- Set_Finalize_Address (FM, FD'Unrestricted_Access); - -- - -- where Finalize_Address is the corresponding TSS primitive of type Typ - -- and Ptr_Typ is the access type of the related allocation. Loc is the - -- source location of the related allocator. + -- Set_Finalize_Address + -- (FM, FD'Unrestricted_Access); -------------------------------------------- -- Task and Protected Object finalization -- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index ed320cdde08..6c35fd6ad6b 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -412,9 +412,6 @@ package body Exp_Util is Proc_To_Call : Node_Id := Empty; Ptr_Typ : Entity_Id; - function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id; - -- Locate TSS primitive Finalize_Address in type Typ - function Find_Object (E : Node_Id) return Node_Id; -- Given an arbitrary expression of an allocator, try to find an object -- reference in it, otherwise return the original expression. @@ -423,82 +420,6 @@ package body Exp_Util is -- Determine whether subprogram Subp denotes a custom allocate or -- deallocate. - --------------------------- - -- Find_Finalize_Address -- - --------------------------- - - function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is - Utyp : Entity_Id := Typ; - - begin - -- Handle protected class-wide or task class-wide types - - if Is_Class_Wide_Type (Utyp) then - if Is_Concurrent_Type (Root_Type (Utyp)) then - Utyp := Root_Type (Utyp); - - elsif Is_Private_Type (Root_Type (Utyp)) - and then Present (Full_View (Root_Type (Utyp))) - and then Is_Concurrent_Type (Full_View (Root_Type (Utyp))) - then - Utyp := Full_View (Root_Type (Utyp)); - end if; - end if; - - -- Handle private types - - if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then - Utyp := Full_View (Utyp); - end if; - - -- Handle protected and task types - - if Is_Concurrent_Type (Utyp) - and then Present (Corresponding_Record_Type (Utyp)) - then - Utyp := Corresponding_Record_Type (Utyp); - end if; - - Utyp := Underlying_Type (Base_Type (Utyp)); - - -- Deal with untagged derivation of private views. If the parent is - -- now known to be protected, the finalization routine is the one - -- defined on the corresponding record of the ancestor (corresponding - -- records do not automatically inherit operations, but maybe they - -- should???) - - if Is_Untagged_Derivation (Typ) then - if Is_Protected_Type (Typ) then - Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); - else - Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); - - if Is_Protected_Type (Utyp) then - Utyp := Corresponding_Record_Type (Utyp); - end if; - end if; - end if; - - -- If the underlying_type is a subtype, we are dealing with the - -- completion of a private type. We need to access the base type and - -- generate a conversion to it. - - if Utyp /= Base_Type (Utyp) then - pragma Assert (Is_Private_Type (Typ)); - - Utyp := Base_Type (Utyp); - end if; - - -- When dealing with an internally built full view for a type with - -- unknown discriminants, use the original record type. - - if Is_Underlying_Record_View (Utyp) then - Utyp := Etype (Utyp); - end if; - - return TSS (Utyp, TSS_Finalize_Address); - end Find_Finalize_Address; - ----------------- -- Find_Object -- ----------------- @@ -764,7 +685,7 @@ package body Exp_Util is -- since it contains an Unchecked_Conversion. if Needs_Finalization (Desig_Typ) and then not CodePeer_Mode then - Fin_Addr_Id := Find_Finalize_Address (Desig_Typ); + Fin_Addr_Id := Finalize_Address (Desig_Typ); pragma Assert (Present (Fin_Addr_Id)); Append_To (Actuals, @@ -2443,6 +2364,82 @@ package body Exp_Util is end if; end Expand_Subtype_From_Expr; + ---------------------- + -- Finalize_Address -- + ---------------------- + + function Finalize_Address (Typ : Entity_Id) return Entity_Id is + Utyp : Entity_Id := Typ; + + begin + -- Handle protected class-wide or task class-wide types + + if Is_Class_Wide_Type (Utyp) then + if Is_Concurrent_Type (Root_Type (Utyp)) then + Utyp := Root_Type (Utyp); + + elsif Is_Private_Type (Root_Type (Utyp)) + and then Present (Full_View (Root_Type (Utyp))) + and then Is_Concurrent_Type (Full_View (Root_Type (Utyp))) + then + Utyp := Full_View (Root_Type (Utyp)); + end if; + end if; + + -- Handle private types + + if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then + Utyp := Full_View (Utyp); + end if; + + -- Handle protected and task types + + if Is_Concurrent_Type (Utyp) + and then Present (Corresponding_Record_Type (Utyp)) + then + Utyp := Corresponding_Record_Type (Utyp); + end if; + + Utyp := Underlying_Type (Base_Type (Utyp)); + + -- Deal with untagged derivation of private views. If the parent is + -- now known to be protected, the finalization routine is the one + -- defined on the corresponding record of the ancestor (corresponding + -- records do not automatically inherit operations, but maybe they + -- should???) + + if Is_Untagged_Derivation (Typ) then + if Is_Protected_Type (Typ) then + Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ))); + else + Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); + + if Is_Protected_Type (Utyp) then + Utyp := Corresponding_Record_Type (Utyp); + end if; + end if; + end if; + + -- If the underlying_type is a subtype, we are dealing with the + -- completion of a private type. We need to access the base type and + -- generate a conversion to it. + + if Utyp /= Base_Type (Utyp) then + pragma Assert (Is_Private_Type (Typ)); + + Utyp := Base_Type (Utyp); + end if; + + -- When dealing with an internally built full view for a type with + -- unknown discriminants, use the original record type. + + if Is_Underlying_Record_View (Utyp) then + Utyp := Etype (Utyp); + end if; + + return TSS (Utyp, TSS_Finalize_Address); + end Finalize_Address; + ------------------------ -- Find_Interface_ADT -- ------------------------ diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 99e81ec86b2..68302602a1b 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -450,6 +450,9 @@ package Exp_Util is -- declarations and/or allocations when the type is indefinite (including -- class-wide). + function Finalize_Address (Typ : Entity_Id) return Entity_Id; + -- Locate TSS primitive Finalize_Address in type Typ + function Find_Interface_ADT (T : Entity_Id; Iface : Entity_Id) return Elmt_Id; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index f14855d247e..fd06aa14623 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -1796,25 +1796,6 @@ package body Freeze is Next_Entity (Ent); end loop; end; - - -- We add finalization masters to access types whose designated types - -- require finalization. This is normally done when freezing the - -- type, but this misses recursive type definitions where the later - -- members of the recursion introduce controlled components (such as - -- can happen when incomplete types are involved), as well cases - -- where a component type is private and the controlled full type - -- occurs after the access type is frozen. Cases that don't need a - -- finalization master are generic formal types (the actual type will - -- have it) and types derived from them, and types with Java and CIL - -- conventions, since those are used for API bindings. - -- (Are there any other cases that should be excluded here???) - - elsif Is_Access_Type (E) - and then Comes_From_Source (E) - and then not Is_Generic_Type (Root_Type (E)) - and then Needs_Finalization (Designated_Type (E)) - then - Build_Finalization_Master (E); end if; Next_Entity (E); diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 0e6aec6de0c..b4667342753 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -499,6 +499,10 @@ package body Lib.Writ is Write_Info_Str (" RT"); end if; + if Serious_Errors_Detected /= 0 then + Write_Info_Str (" SE"); + end if; + if Is_Shared_Passive (Uent) then Write_Info_Str (" SP"); end if; diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index f67e33778c6..d135eac1e9a 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -598,11 +598,15 @@ package Lib.Writ is -- RT Unit has pragma Remote_Types - -- SP Unit has pragma Shared_Passive. + -- SE Compilation of unit encountered one or more serious errors. + -- Normally the generation of an ALI file is suppressed if there + -- is a serious error, but this can be overridden with -gnatQ. + + -- SP Unit has pragma Shared_Passive -- SU Unit is a subprogram, rather than a package - -- The attributes may appear in any order, separated by spaces. + -- The attributes may appear in any order, separated by spaces -- ----------------------------- -- -- W, Y and Z Withed Units -- diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 8eb85dc5e01..cf1ff9c460d 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -4595,7 +4595,8 @@ package body Sem_Attr is -- corresponding pragma. Don't issue errors when analyzing aspect. if Nkind (Prag) = N_Aspect_Specification - and then Chars (Identifier (Prag)) = Name_Post + and then Nam_In (Chars (Identifier (Prag)), Name_Post, + Name_Refined_Post) then null; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index be69b412d13..0a97caaf999 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -2792,6 +2792,14 @@ package body Sem_Ch3 is Generate_Definition (Def_Id); end if; + -- Propagate any pending access types whose finalization masters need to + -- be fully initialized from the partial to the full view. Guard against + -- an illegal full view that remains unanalyzed. + + if Is_Type (Def_Id) and then Is_Incomplete_Or_Private_Type (Prev) then + Set_Pending_Access_Types (Def_Id, Pending_Access_Types (Prev)); + end if; + if Chars (Scope (Def_Id)) = Name_System and then Chars (Def_Id) = Name_Address and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))