From patchwork Tue Dec 11 11:37:09 2018 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: 1011071 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-492109-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="ekjVsTnP"; 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 43DdGq6Pp0z9s47 for ; Tue, 11 Dec 2018 22:37:54 +1100 (AEDT) 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=N78UHrqqvi9mIeB+hBDRfv+fzkZV0Da1suc6Al+6QRU9NYuhl8 OGv6sQQZXA4KrBxGzCFVhn+pxNFSZJmlXNkz85ufjFQgXspq1HbyPO9UtxagTxIi Wq/PVqnW8AjL9uVe1NbkTcClBVxaVIOVq0PKEHno3q2HBU2PkXAw7ocXU= 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=K/6LcPVDtlb67taEbRYsPP4SwJ4=; b=ekjVsTnPflRd15Z77lOd 0bTUWwlizQmuyvSNpiYx/hLr/wvd7NPITa4/sPYxTkWhCf1oJSQS3BmcpEsYnv26 9PWrjawnudJnAoxGy+qq/hnR5Uzhb6aZRHmQgpOjwOp8/L15DnLZxQWgHGUXsTRZ u26hCGlZTVQDsmy5SDh6ilU= Received: (qmail 105321 invoked by alias); 11 Dec 2018 11:37:17 -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 105178 invoked by uid 89); 11 Dec 2018 11:37:16 -0000 Authentication-Results: sourceware.org; auth=none 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=ERROR, complement 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; Tue, 11 Dec 2018 11:37:10 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 7781B56089; Tue, 11 Dec 2018 06:37:09 -0500 (EST) 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 Eqbwq5Wxcwg1; Tue, 11 Dec 2018 06:37:09 -0500 (EST) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 641EB56088; Tue, 11 Dec 2018 06:37:09 -0500 (EST) Received: by tron.gnat.com (Postfix, from userid 4862) id 617133573; Tue, 11 Dec 2018 06:37:09 -0500 (EST) Date: Tue, 11 Dec 2018 06:37:09 -0500 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Spurious error with pragma Thread_Local_Storage Message-ID: <20181211113709.GA106101@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-IsSubscribed: yes The following patch modifies the checks related to pragma Thread_Local_Storage to correct a confusion in semantics which led to spurious errors. ------------ -- Source -- ------------ -- pack.ads package Pack is type Arr is array (1 .. 5) of Boolean; type Arr_With_Default is array (1 .. 5) of Boolean with Default_Component_Value => False; type Int is new Integer range 1 .. 5; type Int_With_Default is new Integer range 1 .. 5 with Default_Value => 1; protected type Prot_Typ is entry E; end Prot_Typ; type Rec_1 is record Comp : Integer; end record; type Rec_2 is record Comp : Int; end record; type Rec_3 is record Comp : Int_With_Default; end record; task type Task_Typ is entry E; end Task_Typ; end Pack; -- pack.adb package body Pack is function F (Val : Int) return Int is begin if Val <= 1 then return 1; else return F (Val - 1) * Val; end if; end F; function F (Val : Int_With_Default) return Int_With_Default is begin if Val <= 1 then return 1; else return F (Val - 1) * Val; end if; end F; function F (Val : Integer) return Integer is begin if Val <= 1 then return 1; else return F (Val - 1) * Val; end if; end F; protected body Prot_Typ is entry E when True is begin null; end E; end Prot_Typ; task body Task_Typ is begin accept E; end Task_Typ; Obj_1 : Arr; -- OK pragma Thread_Local_Storage (Obj_1); Obj_2 : Arr := (others => True); -- OK pragma Thread_Local_Storage (Obj_2); Obj_3 : Arr := (others => F (2) = Integer (3)); -- ERROR pragma Thread_Local_Storage (Obj_3); Obj_4 : Arr_With_Default; -- ERROR pragma Thread_Local_Storage (Obj_4); Obj_5 : Arr_With_Default := (others => True); -- OK pragma Thread_Local_Storage (Obj_5); Obj_6 : Arr_With_Default := (others => F (2) = Integer (3)); -- ERROR pragma Thread_Local_Storage (Obj_6); Obj_7 : Integer; -- OK pragma Thread_Local_Storage (Obj_7); Obj_8 : Integer := 1; -- OK pragma Thread_Local_Storage (Obj_8); Obj_9 : Integer := F (2); -- ERROR pragma Thread_Local_Storage (Obj_9); Obj_10 : Int; -- OK pragma Thread_Local_Storage (Obj_10); Obj_11 : Int := 1; -- OK pragma Thread_Local_Storage (Obj_11); Obj_12 : Int := F (2); -- ERROR pragma Thread_Local_Storage (Obj_12); Obj_13 : Int_With_Default; -- ERROR pragma Thread_Local_Storage (Obj_13); Obj_14 : Int_With_Default := 1; -- OK pragma Thread_Local_Storage (Obj_14); Obj_15 : Int_With_Default := F (2); -- ERROR pragma Thread_Local_Storage (Obj_15); Obj_16 : Prot_Typ; -- ERROR pragma Thread_Local_Storage (Obj_16); Obj_17 : Rec_1; -- OK pragma Thread_Local_Storage (Obj_17); Obj_18 : Rec_1 := (others => 1); -- OK pragma Thread_Local_Storage (Obj_18); Obj_19 : Rec_1 := (others => F (2)); -- ERROR pragma Thread_Local_Storage (Obj_19); Obj_20 : Rec_2; -- OK pragma Thread_Local_Storage (Obj_20); Obj_21 : Rec_2 := (others => 1); -- OK pragma Thread_Local_Storage (Obj_21); Obj_22 : Rec_2 := (others => F (2)); -- ERROR pragma Thread_Local_Storage (Obj_22); Obj_23 : Rec_3; -- ERROR pragma Thread_Local_Storage (Obj_23); Obj_24 : Rec_3 := (others => 1); -- OK pragma Thread_Local_Storage (Obj_24); Obj_25 : Rec_3 := (others => F (2)); -- ERROR pragma Thread_Local_Storage (Obj_25); Obj_26 : Task_Typ; -- ERROR pragma Thread_Local_Storage (Obj_26); end Pack; ---------------------------- -- Compilation and output -- ---------------------------- $ gcc -c pack.adb pack.adb:47:04: Thread_Local_Storage variable "Obj_4" is improperly initialized pack.adb:47:04: only allowed initialization is explicit "null", static expression or static aggregate pack.adb:62:04: Thread_Local_Storage variable "Obj_9" is improperly initialized pack.adb:62:04: only allowed initialization is explicit "null", static expression or static aggregate pack.adb:71:04: Thread_Local_Storage variable "Obj_12" is improperly initialized pack.adb:71:04: only allowed initialization is explicit "null", static expression or static aggregate pack.adb:74:04: Thread_Local_Storage variable "Obj_13" is improperly initialized pack.adb:74:04: only allowed initialization is explicit "null", static expression or static aggregate pack.adb:80:04: Thread_Local_Storage variable "Obj_15" is improperly initialized pack.adb:80:04: only allowed initialization is explicit "null", static expression or static aggregate pack.adb:83:04: Thread_Local_Storage variable "Obj_16" is improperly initialized pack.adb:83:04: only allowed initialization is explicit "null", static expression or static aggregate pack.adb:92:04: Thread_Local_Storage variable "Obj_19" is improperly initialized pack.adb:92:04: only allowed initialization is explicit "null", static expression or static aggregate pack.adb:101:04: Thread_Local_Storage variable "Obj_22" is improperly initialized pack.adb:101:04: only allowed initialization is explicit "null", static expression or static aggregate pack.adb:104:04: Thread_Local_Storage variable "Obj_23" is improperly initialized pack.adb:104:04: only allowed initialization is explicit "null", static expression or static aggregate pack.adb:110:04: Thread_Local_Storage variable "Obj_25" is improperly initialized pack.adb:110:04: only allowed initialization is explicit "null", static expression or static aggregate pack.adb:113:04: Thread_Local_Storage variable "Obj_26" is improperly initialized pack.adb:113:04: only allowed initialization is explicit "null", static expression or static aggregate Tested on x86_64-pc-linux-gnu, committed on trunk 2018-12-11 Hristian Kirtchev gcc/ada/ * freeze.adb (Check_Pragma_Thread_Local_Storage): Use the violating set to diagnose detect an illegal initialization, rather than the complement of the OK set. (Freeze_Object_Declaration): Factorize code in Has_Default_Initialization. (Has_Default_Initialization, Has_Incompatible_Initialization): New routines. --- gcc/ada/freeze.adb +++ gcc/ada/freeze.adb @@ -3187,8 +3187,13 @@ package body Freeze is -- length of the array, or its corresponding attribute. procedure Check_Pragma_Thread_Local_Storage (Var_Id : Entity_Id); - -- Ensure that the initialization state of variable Var_Id subject to - -- pragma Thread_Local_Storage satisfies the semantics of the pragma. + -- Ensure that the initialization state of variable Var_Id subject + -- to pragma Thread_Local_Storage agrees with the semantics of the + -- pragma. + + function Has_Default_Initialization + (Obj_Id : Entity_Id) return Boolean; + -- Determine whether object Obj_Id default initialized ------------------------------- -- Check_Large_Modular_Array -- @@ -3274,53 +3279,117 @@ package body Freeze is --------------------------------------- procedure Check_Pragma_Thread_Local_Storage (Var_Id : Entity_Id) is - Decl : constant Node_Id := Declaration_Node (Var_Id); - Expr : constant Node_Id := Expression (Decl); + function Has_Incompatible_Initialization + (Var_Decl : Node_Id) return Boolean; + -- Determine whether variable Var_Id with declaration Var_Decl is + -- initialized with a value that violates the semantics of pragma + -- Thread_Local_Storage. - begin - -- A variable whose initialization is suppressed lacks default - -- initialization. + ------------------------------------- + -- Has_Incompatible_Initialization -- + ------------------------------------- - if Suppress_Initialization (Var_Id) then - null; + function Has_Incompatible_Initialization + (Var_Decl : Node_Id) return Boolean + is + Init_Expr : constant Node_Id := Expression (Var_Decl); - -- The variable has some form of initialization. Check whether it - -- is compatible with the semantics of the pragma. + begin + -- The variable is default-initialized. This directly violates + -- the semantics of the pragma. - elsif Has_Init_Expression (Decl) - and then Present (Expr) - and then + if Has_Default_Initialization (Var_Id) then + return True; - -- The variable is initialized with "null" + -- The variable has explicit initialization. In this case only + -- a handful of values satisfy the semantics of the pragma. - (Nkind (Expr) = N_Null - or else + elsif Has_Init_Expression (Var_Decl) + and then Present (Init_Expr) + then + -- "null" is a legal form of initialization + + if Nkind (Init_Expr) = N_Null then + return False; - -- The variable is initialized with a static constant + -- A static expression is a legal form of initialization - Is_OK_Static_Expression (Expr) - or else + elsif Is_Static_Expression (Init_Expr) then + return False; - -- The variable is initialized with a static aggregate + -- A static aggregate is a legal form of initialization - (Nkind (Expr) = N_Aggregate - and then Compile_Time_Known_Aggregate (Expr))) - then + elsif Nkind (Init_Expr) = N_Aggregate + and then Compile_Time_Known_Aggregate (Init_Expr) + then + return False; + + -- All other initialization expressions violate the semantic + -- of the pragma. + + else + return True; + end if; + + -- The variable lacks any kind of initialization, which agrees + -- with the semantics of the pragma. + + else + return False; + end if; + end Has_Incompatible_Initialization; + + -- Local declarations + + Var_Decl : constant Node_Id := Declaration_Node (Var_Id); + + -- Start of processing for Check_Pragma_Thread_Local_Storage + + begin + -- A variable whose initialization is suppressed lacks any kind of + -- initialization. + + if Suppress_Initialization (Var_Id) then null; - -- Otherwise the initialization of the variable violates the - -- semantics of pragma Thread_Local_Storage. + -- The variable has default initialization, or is explicitly + -- initialized to a value other than null, static expression, + -- or a static aggregate. - else + elsif Has_Incompatible_Initialization (Var_Decl) then Error_Msg_NE ("Thread_Local_Storage variable& is improperly initialized", - Decl, Var_Id); + Var_Decl, Var_Id); Error_Msg_NE ("\only allowed initialization is explicit NULL, static " - & "expression or static aggregate", Decl, Var_Id); + & "expression or static aggregate", Var_Decl, Var_Id); end if; end Check_Pragma_Thread_Local_Storage; + -------------------------------- + -- Has_Default_Initialization -- + -------------------------------- + + function Has_Default_Initialization + (Obj_Id : Entity_Id) return Boolean + is + Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id); + Obj_Typ : constant Entity_Id := Etype (Obj_Id); + + begin + return + Comes_From_Source (Obj_Id) + and then not Is_Imported (Obj_Id) + and then not Has_Init_Expression (Obj_Decl) + and then + ((Has_Non_Null_Base_Init_Proc (Obj_Typ) + and then not No_Initialization (Obj_Decl) + and then not Initialization_Suppressed (Obj_Typ)) + or else + (Needs_Simple_Initialization (Obj_Typ) + and then not Is_Internal (Obj_Id))); + end Has_Default_Initialization; + -- Local variables Typ : constant Entity_Id := Etype (E); @@ -3438,17 +3507,7 @@ package body Freeze is if Ekind (E) = E_Constant and then Present (Full_View (E)) then null; - elsif Comes_From_Source (E) - and then not Is_Imported (E) - and then not Has_Init_Expression (Declaration_Node (E)) - and then - ((Has_Non_Null_Base_Init_Proc (Typ) - and then not No_Initialization (Declaration_Node (E)) - and then not Initialization_Suppressed (Typ)) - or else - (Needs_Simple_Initialization (Typ) - and then not Is_Internal (E))) - then + elsif Has_Default_Initialization (E) then Check_Restriction (No_Default_Initialization, Declaration_Node (E)); end if;