From patchwork Wed Sep 13 10:03:31 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 813295 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-462013-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="COTxTmYS"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3xscgs4rBQz9s9Y for ; Wed, 13 Sep 2017 20:03:53 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=CUCROylVsESshcEdrKvaEQNZNySDKs0/rDrSp6voLhr7mJ+po7 csG00RWheE/bI9pr/zL9c0UsNzWmuvM2KzCxx/qfgf7rUnXxCLm9xAWWfjgaA+8I bcI5pFIpVQdiTuk3naO0UYYZkjK4ogvuPj2gmCxebf9bUOaWAI3kjyLRg= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=ZQRrji3VWc7jhKjqNzI/iplBedQ=; b=COTxTmYS9rP7ylWnkB2k K4vWFABrUkZufDAAY67+5R4edN50D83/D25SEkRKOnMD6uSLG8rDdQMN/IxIzg4k Oi4vbFaQx2y8wIO4HxVfnEuqeUBiM+8et0yJGYGG65evdUdFxz0C1d5IDq6wf5g7 JlCROrLYPFzDXOG2xXyM96E= Received: (qmail 71422 invoked by alias); 13 Sep 2017 10:03:40 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 70451 invoked by uid 89); 13 Sep 2017 10:03:38 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=ini, ctrl X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 13 Sep 2017 10:03:33 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id CAF585624E; Wed, 13 Sep 2017 06:03:31 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id a1qgS+mNM5DR; Wed, 13 Sep 2017 06:03:31 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id AB5B85624C; Wed, 13 Sep 2017 06:03:31 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id A71D4521; Wed, 13 Sep 2017 06:03:31 -0400 (EDT) Date: Wed, 13 Sep 2017 06:03:31 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: kirtchev@adacore.com, Arnaud Charlet Subject: [Ada] Undefined symbol at link time due to Disable_Controlled Message-ID: <20170913100331.GA80823@us.adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes This patch reimplements aspect Disable_Controlled to plug the following holes in its original implementation: * The aspect may appear without an expression in which case the aspect defaults to True, however the compiler would crash due to the lack of expression. * If the expression is present, then it should be static, however the compiler would silently accept a non-static expression. * Various types that derive and/or contain a component of a type subject to the aspect are now properly handled. The patch also modifies predicate Is_Controlled to indicate whether a type is derived from [Limited_]Controlled AND NOT subject to aspect Disable_Controlled. This modification allows the semantics of the aspect to automatically perculate to derived types and/or composite types with components subject to the aspect. As a result, the finalization mechanism now properly handles such types and generates the appropriate Deep_Adjust, Deep_Initialize, and Deep_Finalize primitives. ------------ -- Source -- ------------ -- factorial.ads function Factorial (Val : Natural) return Natural; -- factorial.adb function Factorial (Val : Natural) return Natural is begin if Val > 1 then return Val * Factorial (Val - 1); end if; return 1; end Factorial; -- semantics.ads with Ada.Finalization; use Ada.Finalization; with Factorial; package Semantics is generic Flag : Boolean; Int : Integer; package Nested_Gen is type Ctrl_Rec_1 is new Controlled with null record with Disable_Controlled => Int; -- Error type Ctrl_Rec_2 is new Limited_Controlled with null record with Disable_Controlled => Factorial (3) = 6; -- N/A type Ctrl_Rec_3 is new Controlled with null record with Disable_Controlled => Flag; -- OK end Nested_Gen; subtype Small_Int is Integer range 1 .. 10 with Disable_Controlled; -- Error type Rec is null record with Disable_Controlled => False; -- Error type Ctrl_Rec_1 is new Controlled with null record with Disable_Controlled => "what?"; -- Error type Ctrl_Rec_2 is new Limited_Controlled with null record with Disable_Controlled => Factorial (3) = 6; -- Error type Ctrl_Rec_3 is new Controlled with null record with Disable_Controlled => True; -- OK Is_True : constant Boolean := True; type Ctrl_Rec_4 is new Limited_Controlled with null record with Disable_Controlled => Is_True; -- OK end Semantics; -- types.ads with Ada.Finalization; use Ada.Finalization; package Types is generic Flag : Boolean; package Gen is type Ctrl is new Controlled with record Id : Natural; end record; procedure Adjust (Obj : in out Ctrl); procedure Finalize (Obj : in out Ctrl); procedure Initialize (Obj : in out Ctrl); type Ctrl_DC is new Controlled with record Id : Natural; end record with Disable_Controlled => Flag; procedure Adjust (Obj : in out Ctrl_DC); procedure Finalize (Obj : in out Ctrl_DC); procedure Initialize (Obj : in out Ctrl_DC); type Ctrl_Ctrl_DC is new Controlled with record Id : Natural; Comp : Ctrl_DC; end record; procedure Adjust (Obj : in out Ctrl_Ctrl_DC); procedure Finalize (Obj : in out Ctrl_Ctrl_DC); procedure Initialize (Obj : in out Ctrl_Ctrl_DC); type Ctrl_DC_Ctrl is new Controlled with record Id : Natural; Comp : Ctrl; end record with Disable_Controlled => True; procedure Adjust (Obj : in out Ctrl_DC_Ctrl); procedure Finalize (Obj : in out Ctrl_DC_Ctrl); procedure Initialize (Obj : in out Ctrl_DC_Ctrl); type Ctrl_DC_Ctrl_DC is new Controlled with record Id : Natural; Comp : Ctrl_DC; end record with Disable_Controlled; procedure Adjust (Obj : in out Ctrl_DC_Ctrl_DC); procedure Finalize (Obj : in out Ctrl_DC_Ctrl_DC); procedure Initialize (Obj : in out Ctrl_DC_Ctrl_DC); type Rec_Ctrl_DC is record Comp : Ctrl_DC; end record; end Gen; generic Typ_Name : String; type Typ is private; procedure Test; type Ctrl is new Controlled with record Id : Natural; end record; procedure Adjust (Obj : in out Ctrl); procedure Finalize (Obj : in out Ctrl); procedure Initialize (Obj : in out Ctrl); type Ctrl_DC is new Controlled with record Id : Natural; end record with Disable_Controlled => True; procedure Adjust (Obj : in out Ctrl_DC); procedure Finalize (Obj : in out Ctrl_DC); procedure Initialize (Obj : in out Ctrl_DC); type Ctrl_Ctrl_DC is new Controlled with record Id : Natural; Comp : Ctrl_DC; end record; procedure Adjust (Obj : in out Ctrl_Ctrl_DC); procedure Finalize (Obj : in out Ctrl_Ctrl_DC); procedure Initialize (Obj : in out Ctrl_Ctrl_DC); type Ctrl_DC_Ctrl is new Controlled with record Id : Natural; Comp : Ctrl; end record with Disable_Controlled => True; procedure Adjust (Obj : in out Ctrl_DC_Ctrl); procedure Finalize (Obj : in out Ctrl_DC_Ctrl); procedure Initialize (Obj : in out Ctrl_DC_Ctrl); type Ctrl_DC_Ctrl_DC is new Controlled with record Id : Natural; Comp : Ctrl_DC; end record with Disable_Controlled; procedure Adjust (Obj : in out Ctrl_DC_Ctrl_DC); procedure Finalize (Obj : in out Ctrl_DC_Ctrl_DC); procedure Initialize (Obj : in out Ctrl_DC_Ctrl_DC); type Rec_Ctrl_DC is record Comp : Ctrl_DC; end record; end Types; -- types.adb with Ada.Text_IO; use Ada.Text_IO; package body Types is Id_Gen : Natural := 100; procedure Adjust_Id (Owner : String; Id : in out Natural); procedure Finalize_Id (Owner : String; Id : in out Natural); procedure Initialize_Id (Owner : String; Id : in out Natural); -------- -- Id -- -------- procedure Adjust_Id (Owner : String; Id : in out Natural) is Old_Id : constant Natural := Id; New_Id : constant Natural := Old_Id + 1; begin if Old_Id = 0 then Put_Line (" " & Owner & " adj: ERROR: already finalized"); else Put_Line (" " & Owner & " adj:" & Old_Id'Img & " =>" & New_Id'Img); Id := New_Id; end if; end Adjust_Id; procedure Finalize_Id (Owner : String; Id : in out Natural) is Old_Id : constant Natural := Id; begin if Old_Id = 0 then Put_Line (" " & Owner & " fin: ERROR: already finalized"); else Put_Line (" " & Owner & " fin:" & Old_Id'Img); Id := 0; end if; end Finalize_Id; procedure Initialize_Id (Owner : String; Id : in out Natural) is begin Id := Id_Gen; Id_Gen := Id_Gen + 1; Put_Line (" " & Owner & " ini:" & Id'Img); end Initialize_Id; package body Gen is ---------- -- Ctrl -- ---------- procedure Adjust (Obj : in out Ctrl) is begin Adjust_Id ("gen Ctrl", Obj.Id); end Adjust; procedure Finalize (Obj : in out Ctrl) is begin Finalize_Id ("gen Ctrl", Obj.Id); end Finalize; procedure Initialize (Obj : in out Ctrl) is begin Initialize_Id ("gen Ctrl", Obj.Id); end Initialize; ------------- -- Ctrl_DC -- ------------- procedure Adjust (Obj : in out Ctrl_DC) is begin Adjust_Id ("gen Ctrl_DC", Obj.Id); end Adjust; procedure Finalize (Obj : in out Ctrl_DC) is begin Finalize_Id ("gen Ctrl_DC", Obj.Id); end Finalize; procedure Initialize (Obj : in out Ctrl_DC) is begin Initialize_Id ("gen Ctrl_DC", Obj.Id); end Initialize; ------------------ -- Ctrl_Ctrl_DC -- ------------------ procedure Adjust (Obj : in out Ctrl_Ctrl_DC) is begin Adjust_Id ("gen Ctrl_Ctrl_DC", Obj.Id); end Adjust; procedure Finalize (Obj : in out Ctrl_Ctrl_DC) is begin Finalize_Id ("gen Ctrl_Ctrl_DC", Obj.Id); end Finalize; procedure Initialize (Obj : in out Ctrl_Ctrl_DC) is begin Initialize_Id ("gen Ctrl_Ctrl_DC", Obj.Id); end Initialize; ------------- -- Ctrl_DC -- ------------- procedure Adjust (Obj : in out Ctrl_DC_Ctrl) is begin Adjust_Id ("gen Ctrl_DC_Ctrl", Obj.Id); end Adjust; procedure Finalize (Obj : in out Ctrl_DC_Ctrl) is begin Finalize_Id ("gen Ctrl_DC_Ctrl", Obj.Id); end Finalize; procedure Initialize (Obj : in out Ctrl_DC_Ctrl) is begin Initialize_Id ("gen Ctrl_DC_Ctrl", Obj.Id); end Initialize; --------------------- -- Ctrl_DC_Ctrl_DC -- --------------------- procedure Adjust (Obj : in out Ctrl_DC_Ctrl_DC) is begin Adjust_Id ("gen Ctrl_DC_Ctrl_DC", Obj.Id); end Adjust; procedure Finalize (Obj : in out Ctrl_DC_Ctrl_DC) is begin Finalize_Id ("gen Ctrl_DC_Ctrl_DC", Obj.Id); end Finalize; procedure Initialize (Obj : in out Ctrl_DC_Ctrl_DC) is begin Initialize_Id ("gen Ctrl_DC_Ctrl_DC", Obj.Id); end Initialize; end Gen; procedure Test is begin Put_Line (Typ_Name & " start"); declare Obj_1 : Typ; Obj_2 : Typ; pragma Warnings (Off, Obj_2); begin Obj_1 := Obj_2; end; Put_Line (Typ_Name & " end"); end Test; ---------- -- Ctrl -- ---------- procedure Adjust (Obj : in out Ctrl) is begin Adjust_Id ("Ctrl", Obj.Id); end Adjust; procedure Finalize (Obj : in out Ctrl) is begin Finalize_Id ("Ctrl", Obj.Id); end Finalize; procedure Initialize (Obj : in out Ctrl) is begin Initialize_Id ("Ctrl", Obj.Id); end Initialize; ------------- -- Ctrl_DC -- ------------- procedure Adjust (Obj : in out Ctrl_DC) is begin Adjust_Id ("Ctrl_DC", Obj.Id); end Adjust; procedure Finalize (Obj : in out Ctrl_DC) is begin Finalize_Id ("Ctrl_DC", Obj.Id); end Finalize; procedure Initialize (Obj : in out Ctrl_DC) is begin Initialize_Id ("Ctrl_DC", Obj.Id); end Initialize; ------------------ -- Ctrl_Ctrl_DC -- ------------------ procedure Adjust (Obj : in out Ctrl_Ctrl_DC) is begin Adjust_Id ("Ctrl_Ctrl_DC", Obj.Id); end Adjust; procedure Finalize (Obj : in out Ctrl_Ctrl_DC) is begin Finalize_Id ("Ctrl_Ctrl_DC", Obj.Id); end Finalize; procedure Initialize (Obj : in out Ctrl_Ctrl_DC) is begin Initialize_Id ("Ctrl_Ctrl_DC", Obj.Id); end Initialize; ------------- -- Ctrl_DC -- ------------- procedure Adjust (Obj : in out Ctrl_DC_Ctrl) is begin Adjust_Id ("Ctrl_DC_Ctrl", Obj.Id); end Adjust; procedure Finalize (Obj : in out Ctrl_DC_Ctrl) is begin Finalize_Id ("Ctrl_DC_Ctrl", Obj.Id); end Finalize; procedure Initialize (Obj : in out Ctrl_DC_Ctrl) is begin Initialize_Id ("Ctrl_DC_Ctrl", Obj.Id); end Initialize; --------------------- -- Ctrl_DC_Ctrl_DC -- --------------------- procedure Adjust (Obj : in out Ctrl_DC_Ctrl_DC) is begin Adjust_Id ("Ctrl_DC_Ctrl_DC", Obj.Id); end Adjust; procedure Finalize (Obj : in out Ctrl_DC_Ctrl_DC) is begin Finalize_Id ("Ctrl_DC_Ctrl_DC", Obj.Id); end Finalize; procedure Initialize (Obj : in out Ctrl_DC_Ctrl_DC) is begin Initialize_Id ("Ctrl_DC_Ctrl_DC", Obj.Id); end Initialize; end Types; ---------------------------- -- Compilation and output -- ---------------------------- $ gcc -c semantics.ads $ gnatmake -q executable.adb $ ./executable semantics.ads:11:36: expected a boolean type semantics.ads:11:36: found type "Standard.Integer" semantics.ads:21:11: aspect "Disable_Controlled" requires controlled record type semantics.ads:24:11: aspect "Disable_Controlled" requires controlled record type semantics.ads:27:33: expected a boolean type semantics.ads:27:33: found a string type semantics.ads:30:11: expression of aspect "Disable_Controlled" must be static gen Ctrl start gen Ctrl ini: 100 gen Ctrl ini: 101 gen Ctrl fin: 100 gen Ctrl adj: 101 => 102 gen Ctrl fin: 101 gen Ctrl fin: 102 gen Ctrl end gen Ctrl_DC start gen Ctrl_DC end gen Ctrl_Ctrl_DC start gen Ctrl_Ctrl_DC ini: 102 gen Ctrl_Ctrl_DC ini: 103 gen Ctrl_Ctrl_DC fin: 102 gen Ctrl_Ctrl_DC adj: 103 => 104 gen Ctrl_Ctrl_DC fin: 103 gen Ctrl_Ctrl_DC fin: 104 gen Ctrl_Ctrl_DC end gen Ctrl_DC_Ctrl start gen Ctrl ini: 104 gen Ctrl ini: 105 gen Ctrl fin: 104 gen Ctrl adj: 105 => 106 gen Ctrl fin: 105 gen Ctrl fin: 106 gen Ctrl_DC_Ctrl end gen Ctrl_DC_Ctrl_DC start gen Ctrl_DC_Ctrl_DC end gen Rec_Ctrl_DC start gen Rec_Ctrl_DC end Ctrl start Ctrl ini: 106 Ctrl ini: 107 Ctrl fin: 106 Ctrl adj: 107 => 108 Ctrl fin: 107 Ctrl fin: 108 Ctrl end Ctrl_DC start Ctrl_DC end Ctrl_Ctrl_DC start Ctrl_Ctrl_DC ini: 108 Ctrl_Ctrl_DC ini: 109 Ctrl_Ctrl_DC fin: 108 Ctrl_Ctrl_DC adj: 109 => 110 Ctrl_Ctrl_DC fin: 109 Ctrl_Ctrl_DC fin: 110 Ctrl_Ctrl_DC end Ctrl_DC_Ctrl start Ctrl ini: 110 Ctrl ini: 111 Ctrl fin: 110 Ctrl adj: 111 => 112 Ctrl fin: 111 Ctrl fin: 112 Ctrl_DC_Ctrl end Ctrl_DC_Ctrl_DC start Ctrl_DC_Ctrl_DC end Rec_Ctrl_DC start Rec_Ctrl_DC end Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-13 Hristian Kirtchev * einfo.adb: Flag42 is now Is_Controlled_Active. (Is_Controlled): This attribute is now synthesized. (Is_Controlled_Active): This attribute is now an explicit flag rather than a synthesized attribute. (Set_Is_Controlled): Removed. (Set_Is_Controlled_Active): New routine. (Write_Entity_Flags): Update the output for Flag42. * einfo.ads: Update the documentation of the following attributes: Disable_Controlled, Is_Controlled, Is_Controlled_Active, Is_Controlled and Is_Controlled_Active have swapped their functionality. (Is_Controlled): Renamed to Is_Controlled_Active. (Is_Controlled_Active): Renamed to Is_Controlled. (Set_Is_Controlled): Renamed to Set_Is_Controlled_Active. * exp_ch3.adb (Expand_Freeze_Record_Type): Restore the original use of Is_Controlled. * exp_util.adb (Has_Some_Controlled_Component): Code clean up. (Needs_Finalization): Code clean up. Remove the tests for Disable_Controlled because a) they were incorrect as they would reject a type which is sublect to the aspect, but may contain controlled components, and b) they are no longer necessary. * exp_util.ads (Needs_Finalization): Update comment on documentation. * freeze.adb (Freeze_Array_Type): Restore the original use of Is_Controlled. (Freeze_Record_Type): Restore the original use of Is_Controlled. * sem_ch3.adb (Analyze_Object_Declaration): Restore the original use of Is_Controlled. (Array_Type_Declaration): Restore the original use of Is_Controlled. (Build_Derived_Private_Type): Restore the original use of Is_Controlled. (Build_Derived_Record_Type): Set the Is_Controlled_Active flag of a type derived from Ada.Finalization.[Limited_]Controlled. (Build_Derived_Type): Restore the original use of Is_Controlled. (Record_Type_Definition): Restore the original use of Is_Controlled. * sem_ch7.adb (Preserve_Full_Attributes): Restore the original use of Is_Controlled. * sem_ch13.adb (Analyze_Aspect_Disable_Controlled): New routine. (Analyze_Aspect_Specifications): Use routine Analyze_Aspect_Disable_Controlled to process aspect Disable_Controlled. Index: einfo.adb =================================================================== --- einfo.adb (revision 252062) +++ einfo.adb (working copy) @@ -334,7 +334,7 @@ -- Body_Needed_For_SAL Flag40 -- Treat_As_Volatile Flag41 - -- Is_Controlled Flag42 + -- Is_Controlled_Active Flag42 -- Has_Controlled_Component Flag43 -- Is_Pure Flag44 -- In_Private_Part Flag45 @@ -2189,10 +2189,10 @@ return Flag76 (Id); end Is_Constructor; - function Is_Controlled (Id : E) return B is + function Is_Controlled_Active (Id : E) return B is begin return Flag42 (Base_Type (Id)); - end Is_Controlled; + end Is_Controlled_Active; function Is_Controlling_Formal (Id : E) return B is begin @@ -5341,11 +5341,11 @@ Set_Flag76 (Id, V); end Set_Is_Constructor; - procedure Set_Is_Controlled (Id : E; V : B := True) is + procedure Set_Is_Controlled_Active (Id : E; V : B := True) is begin pragma Assert (Id = Base_Type (Id)); Set_Flag42 (Id, V); - end Set_Is_Controlled; + end Set_Is_Controlled_Active; procedure Set_Is_Controlling_Formal (Id : E; V : B := True) is begin @@ -7902,14 +7902,14 @@ K = E_Constant or else K = E_In_Parameter or else K = E_Loop_Parameter; end Is_Constant_Object; - -------------------------- - -- Is_Controlled_Active -- - -------------------------- + ------------------- + -- Is_Controlled -- + ------------------- - function Is_Controlled_Active (Id : E) return B is + function Is_Controlled (Id : E) return B is begin - return Is_Controlled (Id) and then not Disable_Controlled (Id); - end Is_Controlled_Active; + return Is_Controlled_Active (Id) and then not Disable_Controlled (Id); + end Is_Controlled; -------------------- -- Is_Discriminal -- @@ -9549,7 +9549,7 @@ W ("Is_Constr_Subt_For_U_Nominal", Flag80 (Id)); W ("Is_Constrained", Flag12 (Id)); W ("Is_Constructor", Flag76 (Id)); - W ("Is_Controlled", Flag42 (Id)); + W ("Is_Controlled_Active", Flag42 (Id)); W ("Is_Controlling_Formal", Flag97 (Id)); W ("Is_Descendant_Of_Address", Flag223 (Id)); W ("Is_DIC_Procedure", Flag132 (Id)); Index: einfo.ads =================================================================== --- einfo.ads (revision 252062) +++ einfo.ads (working copy) @@ -980,8 +980,9 @@ -- incomplete type. -- Disable_Controlled (Flag253) --- Present in all entities. Set for a controlled type (Is_Controlled flag --- set) if the aspect Disable_Controlled is active for the type. +-- Present in all entities. Set for a controlled type subject to aspect +-- Disable_Controlled which evaluates to True. This flag is taken into +-- account in synthesized attribute Is_Controlled. -- Discard_Names (Flag88) -- Defined in types and exception entities. Set if pragma Discard_Names @@ -2443,14 +2444,14 @@ -- Defined in function and procedure entities. Set if a pragma -- CPP_Constructor applies to the subprogram. --- Is_Controlled (Flag42) [base type only] +-- Is_Controlled_Active (Flag42) [base type only] -- Defined in all type entities. Indicates that the type is controlled, -- i.e. is either a descendant of Ada.Finalization.Controlled or of -- Ada.Finalization.Limited_Controlled. --- Is_Controlled_Active (synth) [base type only] --- Defined in all type entities. Set if Is_Controlled is set for the --- type, and Disable_Controlled is not set. +-- Is_Controlled (synth) [base type only] +-- Defined in all type entities. Set if Is_Controlled_Active is set for +-- the type, and Disable_Controlled is not set. -- Is_Controlling_Formal (Flag97) -- Defined in all Formal_Kind entities. Marks the controlling parameters @@ -5648,7 +5649,7 @@ -- Is_Atomic (Flag85) -- Is_Constr_Subt_For_U_Nominal (Flag80) -- Is_Constr_Subt_For_UN_Aliased (Flag141) - -- Is_Controlled (Flag42) (base type only) + -- Is_Controlled_Active (Flag42) (base type only) -- Is_Eliminated (Flag124) -- Is_Frozen (Flag4) -- Is_Generic_Actual_Type (Flag94) @@ -5684,7 +5685,7 @@ -- Invariant_Procedure (synth) -- Is_Access_Protected_Subprogram_Type (synth) -- Is_Atomic_Or_VFA (synth) - -- Is_Controlled_Active (synth) + -- Is_Controlled (synth) -- Partial_Invariant_Procedure (synth) -- Predicate_Function (synth) -- Predicate_Function_M (synth) @@ -6344,7 +6345,7 @@ -- Private_View (Node22) -- Stored_Constraint (Elist23) -- Has_Completion (Flag26) - -- Is_Controlled (Flag42) (base type only) + -- Is_Controlled_Active (Flag42) (base type only) -- Is_For_Access_Subtype (Flag118) (subtype only) -- (plus type attributes) @@ -6497,7 +6498,7 @@ -- Is_Class_Wide_Equivalent_Type (Flag35) -- Is_Concurrent_Record_Type (Flag20) -- Is_Constrained (Flag12) - -- Is_Controlled (Flag42) (base type only) + -- Is_Controlled_Active (Flag42) (base type only) -- Is_Interface (Flag186) -- Is_Limited_Interface (Flag197) -- No_Reordering (Flag239) (base type only) @@ -6526,7 +6527,7 @@ -- Has_Record_Rep_Clause (Flag65) (base type only) -- Is_Concurrent_Record_Type (Flag20) -- Is_Constrained (Flag12) - -- Is_Controlled (Flag42) (base type only) + -- Is_Controlled_Active (Flag42) (base type only) -- Is_Interface (Flag186) -- Is_Limited_Interface (Flag197) -- No_Reordering (Flag239) (base type only) @@ -7169,7 +7170,7 @@ function Is_Constr_Subt_For_UN_Aliased (Id : E) return B; function Is_Constrained (Id : E) return B; function Is_Constructor (Id : E) return B; - function Is_Controlled (Id : E) return B; + function Is_Controlled_Active (Id : E) return B; function Is_Controlling_Formal (Id : E) return B; function Is_CPP_Class (Id : E) return B; function Is_Descendant_Of_Address (Id : E) return B; @@ -7489,7 +7490,7 @@ function Is_Base_Type (Id : E) return B; function Is_Boolean_Type (Id : E) return B; function Is_Constant_Object (Id : E) return B; - function Is_Controlled_Active (Id : E) return B; + function Is_Controlled (Id : E) return B; function Is_Discriminal (Id : E) return B; function Is_Dynamic_Scope (Id : E) return B; function Is_External_State (Id : E) return B; @@ -7858,7 +7859,7 @@ procedure Set_Is_Constr_Subt_For_UN_Aliased (Id : E; V : B := True); procedure Set_Is_Constrained (Id : E; V : B := True); procedure Set_Is_Constructor (Id : E; V : B := True); - procedure Set_Is_Controlled (Id : E; V : B := True); + procedure Set_Is_Controlled_Active (Id : E; V : B := True); procedure Set_Is_Controlling_Formal (Id : E; V : B := True); procedure Set_Is_CPP_Class (Id : E; V : B := True); procedure Set_Is_Descendant_Of_Address (Id : E; V : B := True); @@ -8676,7 +8677,7 @@ pragma Inline (Is_Constr_Subt_For_UN_Aliased); pragma Inline (Is_Constrained); pragma Inline (Is_Constructor); - pragma Inline (Is_Controlled); + pragma Inline (Is_Controlled_Active); pragma Inline (Is_Controlling_Formal); pragma Inline (Is_CPP_Class); pragma Inline (Is_Decimal_Fixed_Point_Type); @@ -9190,7 +9191,7 @@ pragma Inline (Set_Is_Constr_Subt_For_UN_Aliased); pragma Inline (Set_Is_Constrained); pragma Inline (Set_Is_Constructor); - pragma Inline (Set_Is_Controlled); + pragma Inline (Set_Is_Controlled_Active); pragma Inline (Set_Is_Controlling_Formal); pragma Inline (Set_Is_CPP_Class); pragma Inline (Set_Is_Descendant_Of_Address); @@ -9434,7 +9435,7 @@ pragma Inline (Base_Type); pragma Inline (Is_Base_Type); - pragma Inline (Is_Controlled_Active); + pragma Inline (Is_Controlled); pragma Inline (Is_Package_Or_Generic_Package); pragma Inline (Is_Packed_Array); pragma Inline (Is_Subprogram_Or_Generic_Subprogram); Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 252062) +++ exp_ch3.adb (working copy) @@ -4951,7 +4951,7 @@ and then (Has_Controlled_Component (Comp_Typ) or else (Chars (Comp) /= Name_uParent - and then (Is_Controlled_Active (Comp_Typ)))) + and then Is_Controlled (Comp_Typ))) then Set_Has_Controlled_Component (Typ); end if; Index: exp_util.adb =================================================================== --- exp_util.adb (revision 252062) +++ exp_util.adb (working copy) @@ -10296,48 +10296,48 @@ -- Needs_Finalization -- ------------------------ - function Needs_Finalization (T : Entity_Id) return Boolean is - function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean; - -- If type is not frozen yet, check explicitly among its components, - -- because the Has_Controlled_Component flag is not necessarily set. + function Needs_Finalization (Typ : Entity_Id) return Boolean is + function Has_Some_Controlled_Component + (Input_Typ : Entity_Id) return Boolean; + -- Determine whether type Input_Typ has at least one controlled + -- component. ----------------------------------- -- Has_Some_Controlled_Component -- ----------------------------------- function Has_Some_Controlled_Component - (Rec : Entity_Id) return Boolean + (Input_Typ : Entity_Id) return Boolean is Comp : Entity_Id; begin - if Has_Controlled_Component (Rec) then + -- When a type is already frozen and has at least one controlled + -- component, or is manually decorated, it is sufficient to inspect + -- flag Has_Controlled_Component. + + if Has_Controlled_Component (Input_Typ) then return True; - elsif not Is_Frozen (Rec) then - if Is_Record_Type (Rec) then - Comp := First_Entity (Rec); + -- Otherwise inspect the internals of the type + elsif not Is_Frozen (Input_Typ) then + if Is_Array_Type (Input_Typ) then + return Needs_Finalization (Component_Type (Input_Typ)); + + elsif Is_Record_Type (Input_Typ) then + Comp := First_Component (Input_Typ); while Present (Comp) loop - if not Is_Type (Comp) - and then Needs_Finalization (Etype (Comp)) - then + if Needs_Finalization (Etype (Comp)) then return True; end if; - Next_Entity (Comp); + Next_Component (Comp); end loop; - - return False; - - else - return - Is_Array_Type (Rec) - and then Needs_Finalization (Component_Type (Rec)); end if; - else - return False; end if; + + return False; end Has_Some_Controlled_Component; -- Start of processing for Needs_Finalization @@ -10349,32 +10349,34 @@ if Restriction_Active (No_Finalization) then return False; - -- C++ types are not considered controlled. It is assumed that the - -- non-Ada side will handle their clean up. + -- C++ types are not considered controlled. It is assumed that the non- + -- Ada side will handle their clean up. - elsif Convention (T) = Convention_CPP then + elsif Convention (Typ) = Convention_CPP then return False; - -- Never needs finalization if Disable_Controlled set + -- Class-wide types are treated as controlled because derivations from + -- the root type may introduce controlled components. - elsif Disable_Controlled (T) then - return False; + elsif Is_Class_Wide_Type (Typ) then + return True; - elsif Is_Class_Wide_Type (T) and then Disable_Controlled (Etype (T)) then - return False; + -- Concurrent types are controlled as long as their corresponding record + -- is controlled. + elsif Is_Concurrent_Type (Typ) + and then Present (Corresponding_Record_Type (Typ)) + and then Needs_Finalization (Corresponding_Record_Type (Typ)) + then + return True; + + -- Otherwise the type is controlled when it is either derived from type + -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or + -- contains at least one controlled component. + else - -- Class-wide types are treated as controlled because derivations - -- from the root type can introduce controlled components. - return - Is_Class_Wide_Type (T) - or else Is_Controlled (T) - or else Has_Some_Controlled_Component (T) - or else - (Is_Concurrent_Type (T) - and then Present (Corresponding_Record_Type (T)) - and then Needs_Finalization (Corresponding_Record_Type (T))); + Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ); end if; end Needs_Finalization; @@ -10387,7 +10389,6 @@ Typ : Entity_Id) return Boolean is begin - -- If we have no initialization of any kind, then we don't need to place -- any restrictions on the address clause, because the object will be -- elaborated after the address clause is evaluated. This happens if the Index: exp_util.ads =================================================================== --- exp_util.ads (revision 252062) +++ exp_util.ads (working copy) @@ -924,11 +924,9 @@ -- consist of constants, when the object has a nontrivial initialization -- or is controlled. - function Needs_Finalization (T : Entity_Id) return Boolean; - -- True if type T is controlled, or has controlled subcomponents. Also - -- True if T is a class-wide type, because some type extension might add - -- controlled subcomponents, except that if pragma Restrictions - -- (No_Finalization) applies, this is False for class-wide types. + function Needs_Finalization (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ is controlled and this requires finalization + -- actions. function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id; -- An anonymous access type may designate a limited view. Check whether Index: freeze.adb =================================================================== --- freeze.adb (revision 252062) +++ freeze.adb (working copy) @@ -2574,7 +2574,7 @@ -- Propagate flags for component type - if Is_Controlled_Active (Component_Type (Arr)) + if Is_Controlled (Component_Type (Arr)) or else Has_Controlled_Component (Ctyp) then Set_Has_Controlled_Component (Arr); @@ -4508,7 +4508,7 @@ (Has_Controlled_Component (Etype (Comp)) or else (Chars (Comp) /= Name_uParent - and then Is_Controlled_Active (Etype (Comp))) + and then Is_Controlled (Etype (Comp))) or else (Is_Protected_Type (Etype (Comp)) and then Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 252062) +++ sem_ch13.adb (working copy) @@ -1595,6 +1595,9 @@ procedure Analyze_Aspect_Convention; -- Perform analysis of aspect Convention + procedure Analyze_Aspect_Disable_Controlled; + -- Perform analysis of aspect Disable_Controlled + procedure Analyze_Aspect_Export_Import; -- Perform analysis of aspects Export or Import @@ -1678,6 +1681,60 @@ end if; end Analyze_Aspect_Convention; + --------------------------------------- + -- Analyze_Aspect_Disable_Controlled -- + --------------------------------------- + + procedure Analyze_Aspect_Disable_Controlled is + begin + -- The aspect applies only to controlled records + + if not (Ekind (E) = E_Record_Type + and then Is_Controlled_Active (E)) + then + Error_Msg_N + ("aspect % requires controlled record type", Aspect); + return; + end if; + + -- Preanalyze the expression (if any) when the aspect resides + -- in a generic unit. + + if Inside_A_Generic then + if Present (Expr) then + Preanalyze_And_Resolve (Expr, Any_Boolean); + end if; + + -- Otherwise the aspect resides in a nongeneric context + + else + -- A controlled record type loses its controlled semantics + -- when the expression statically evaluates to True. + + if Present (Expr) then + Analyze_And_Resolve (Expr, Any_Boolean); + + if Is_OK_Static_Expression (Expr) then + if Is_True (Static_Boolean (Expr)) then + Set_Disable_Controlled (E); + end if; + + -- Otherwise the expression is not static + + else + Error_Msg_N + ("expression of aspect % must be static", Aspect); + end if; + + -- Otherwise the aspect appears without an expression and + -- defaults to True. + + else + Set_Disable_Controlled (E); + end if; + end if; + end Analyze_Aspect_Disable_Controlled; + ---------------------------------- -- Analyze_Aspect_Export_Import -- ---------------------------------- @@ -3468,34 +3525,7 @@ -- Disable_Controlled elsif A_Id = Aspect_Disable_Controlled then - if Ekind (E) /= E_Record_Type - or else not Is_Controlled (E) - then - Error_Msg_N - ("aspect % requires controlled record type", Aspect); - goto Continue; - end if; - - -- If we're in a generic template, we don't want to try - -- to disable controlled types, because typical usage is - -- "Disable_Controlled => not 'Enabled", and - -- the value of Enabled is not known until we see a - -- particular instance. In such a context, we just need - -- to preanalyze the expression for legality. - - if Expander_Active then - Analyze_And_Resolve (Expr, Standard_Boolean); - - if not Present (Expr) - or else Is_True (Static_Boolean (Expr)) - then - Set_Disable_Controlled (E); - end if; - - elsif Serious_Errors_Detected = 0 then - Preanalyze_And_Resolve (Expr, Standard_Boolean); - end if; - + Analyze_Aspect_Disable_Controlled; goto Continue; end if; @@ -10839,8 +10869,8 @@ E : constant Entity_Id := Entity (N); - Non_Generic_Case : constant Boolean := Nkind (N) = N_Freeze_Entity; - -- True in non-generic case. Some of the processing here is skipped + Nongeneric_Case : constant Boolean := Nkind (N) = N_Freeze_Entity; + -- True in nongeneric case. Some of the processing here is skipped -- for the generic case since it is not needed. Basically in the -- generic case, we only need to do stuff that might generate error -- messages or warnings. @@ -10867,7 +10897,7 @@ -- This is not needed in the generic case if Ada_Version >= Ada_2005 - and then Non_Generic_Case + and then Nongeneric_Case and then Ekind (E) = E_Record_Type and then Is_Tagged_Type (E) and then not Is_Interface (E) @@ -11003,7 +11033,7 @@ -- predefined primitives. if Is_Type (E) - and then Non_Generic_Case + and then Nongeneric_Case and then not Within_Internal_Subprogram and then Has_Predicates (E) then @@ -11019,7 +11049,7 @@ -- This is also not needed in the generic case - if Non_Generic_Case + if Nongeneric_Case and then Has_Delayed_Aspects (E) and then Scope (E) = Current_Scope then Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 252062) +++ sem_ch3.adb (working copy) @@ -4848,7 +4848,7 @@ and then not Is_Constrained (Underlying_Type (T)) and then not Is_Aliased (Id) and then not Is_Class_Wide_Type (T) - and then not Is_Controlled_Active (T) + and then not Is_Controlled (T) and then not Has_Controlled_Component (Base_Type (T)) and then Expander_Active then @@ -6157,7 +6157,7 @@ Set_Has_Controlled_Component (Implicit_Base, Has_Controlled_Component (Element_Type) - or else Is_Controlled_Active (Element_Type)); + or else Is_Controlled (Element_Type)); Set_Packed_Array_Impl_Type (Implicit_Base, Empty); @@ -6178,7 +6178,7 @@ Set_Has_Controlled_Component (T, Has_Controlled_Component (Element_Type) or else - Is_Controlled_Active (Element_Type)); + Is_Controlled (Element_Type)); Set_Finalize_Storage_Only (T, Finalize_Storage_Only (Element_Type)); Set_Default_SSO (T); @@ -7897,18 +7897,21 @@ Error_Msg_N ("cannot add discriminants to untagged type", N); end if; - Set_Stored_Constraint (Derived_Type, No_Elist); - Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); - Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); - Set_Disable_Controlled (Derived_Type, Disable_Controlled - (Parent_Type)); + Set_Stored_Constraint (Derived_Type, No_Elist); + Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type)); + + Set_Is_Controlled_Active + (Derived_Type, Is_Controlled_Active (Parent_Type)); + + Set_Disable_Controlled + (Derived_Type, Disable_Controlled (Parent_Type)); + Set_Has_Controlled_Component - (Derived_Type, Has_Controlled_Component - (Parent_Type)); + (Derived_Type, Has_Controlled_Component (Parent_Type)); -- Direct controlled types do not inherit Finalize_Storage_Only flag - if not Is_Controlled_Active (Parent_Type) then + if not Is_Controlled (Parent_Type) then Set_Finalize_Storage_Only (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); end if; @@ -9206,9 +9209,10 @@ and then Chars (Scope (Scope (Derived_Type))) = Name_Ada and then Scope (Scope (Scope (Derived_Type))) = Standard_Standard then - Set_Is_Controlled (Derived_Type); + Set_Is_Controlled_Active (Derived_Type); else - Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Base)); + Set_Is_Controlled_Active + (Derived_Type, Is_Controlled_Active (Parent_Base)); end if; -- Minor optimization: there is no need to generate the class-wide @@ -9475,20 +9479,21 @@ begin -- Set common attributes - Set_Scope (Derived_Type, Current_Scope); - + Set_Scope (Derived_Type, Current_Scope); Set_Etype (Derived_Type, Parent_Base); Set_Ekind (Derived_Type, Ekind (Parent_Base)); Propagate_Concurrent_Flags (Derived_Type, Parent_Base); - Set_Size_Info (Derived_Type, Parent_Type); - Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); - Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); + Set_Size_Info (Derived_Type, Parent_Type); + Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); + + Set_Is_Controlled_Active + (Derived_Type, Is_Controlled_Active (Parent_Type)); + Set_Disable_Controlled (Derived_Type, Disable_Controlled (Parent_Type)); + Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); + Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type)); - Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); - Set_Is_Volatile (Derived_Type, Is_Volatile (Parent_Type)); - if Is_Tagged_Type (Derived_Type) then Set_No_Tagged_Streams_Pragma (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type)); @@ -21799,7 +21804,7 @@ end; end if; - Final_Storage_Only := not Is_Controlled_Active (T); + Final_Storage_Only := not Is_Controlled (T); -- Ada 2005: Check whether an explicit Limited is present in a derived -- type declaration. @@ -21859,8 +21864,7 @@ elsif not Is_Class_Wide_Equivalent_Type (T) and then (Has_Controlled_Component (Etype (Component)) or else (Chars (Component) /= Name_uParent - and then Is_Controlled_Active - (Etype (Component)))) + and then Is_Controlled (Etype (Component)))) then Set_Has_Controlled_Component (T, True); Final_Storage_Only := Index: sem_ch7.adb =================================================================== --- sem_ch7.adb (revision 252062) +++ sem_ch7.adb (working copy) @@ -2644,7 +2644,8 @@ end if; if Priv_Is_Base_Type then - Set_Is_Controlled (Priv, Is_Controlled (Full_Base)); + Set_Is_Controlled_Active + (Priv, Is_Controlled_Active (Full_Base)); Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only (Full_Base)); Set_Has_Controlled_Component