From patchwork Tue Nov 7 09:20:27 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 162350 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:aa0b:0:b0:403:3b70:6f57 with SMTP id k11csp114393vqo; Tue, 7 Nov 2023 01:28:16 -0800 (PST) X-Google-Smtp-Source: AGHT+IFYbRJ43AzYcOn6A3/Z9cNBdEM/XsBQx+U7CQphQSFMVf32vkdBMFC6Y/Q/BG+R8CdnqWxT X-Received: by 2002:a05:620a:45a1:b0:76e:f5c5:1bac with SMTP id bp33-20020a05620a45a100b0076ef5c51bacmr33765077qkb.48.1699349296217; Tue, 07 Nov 2023 01:28:16 -0800 (PST) ARC-Seal: i=2; a=rsa-sha256; t=1699349296; cv=pass; d=google.com; s=arc-20160816; b=inuvwI/FpCUQY0zDlAwKcnDIa2OcLVdiepH15S5kBAcVMIfDI4B2zvZV2ahG3IvvOk 2BMYBy6900hI44pMCcFUTA8T1+obZXH4MAes61Q0mFqkbI7OFZft6iam4jvIe/2IN0CC WcjA2PpkBmwcHJf3bWjMiyIVH1WEwgSAhslL8DwmBkr9ohV1CFUYcAXnc5pChc09yMrr D7tBoI4TWPwDrcoQdOe3k2uxx0MuHtVZqRIDjmW4Fz6NZw2eqgM4TEGMdKUE9KmT0MbL GLGb2UTX9frgkBtelICwqmbYA0tT7QUbJMbD8iU3gIwPyao9gJDIkLU/LzIvL5t8rjl1 kNXA== ARC-Message-Signature: i=2; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=errors-to:list-subscribe:list-help:list-post:list-archive :list-unsubscribe:list-id:precedence:content-transfer-encoding :mime-version:message-id:date:subject:cc:to:from:dkim-signature :arc-filter:dmarc-filter:delivered-to; bh=rF2ShpJE3kJXaQ5OVtS+PnaFStYeSaU1YwYVEyBmjpg=; fh=xkXw4ZjwHxuTwIHh5BpbVWFYGO+bP8cUYTTqcq/2BVI=; b=vedGPwsMfzlCovQhuV0bMFImMR+gE07FNIxRRRFStM6Vrb7LoipF/nGYP7iw5dMq/P ATX9lVIejF3IYhGDo2RwdENwGNUFsf0sCEqmiXJzrlFfUjpL01L/4eAPfBUKhQzCIjrK aGu1kIM0TVucx2hT7rz6sJKq+tgqAFEgipDQK9D98lLMrTP5o7wP0Ok3RKjYeQlRubQk Gbq+vHq4C1CZ/518Lypct021Jy9OtvLW2cOqcChfE5AtVTu4trc/G6SIDs1JiNwNg653 uPh139NfB4q8wEwJL8m7sEHPcK24MGBgABoLwJmD8UrxXBhoee14IauhC3m17C4OGP8y 5wpg== ARC-Authentication-Results: i=2; mx.google.com; dkim=pass header.i=@adacore.com header.s=google header.b=dKMV7Wm9; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=adacore.com Received: from server2.sourceware.org (server2.sourceware.org. [2620:52:3:1:0:246e:9693:128c]) by mx.google.com with ESMTPS id v2-20020a05620a0f0200b00765aafce58csi6807285qkl.120.2023.11.07.01.28.16 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 07 Nov 2023 01:28:16 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) client-ip=2620:52:3:1:0:246e:9693:128c; Authentication-Results: mx.google.com; dkim=pass header.i=@adacore.com header.s=google header.b=dKMV7Wm9; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=adacore.com Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 01C6A3858428 for ; Tue, 7 Nov 2023 09:28:16 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x329.google.com (mail-wm1-x329.google.com [IPv6:2a00:1450:4864:20::329]) by sourceware.org (Postfix) with ESMTPS id 98F9D3857341 for ; Tue, 7 Nov 2023 09:20:32 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 98F9D3857341 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 98F9D3857341 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::329 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1699348837; cv=none; b=cydybkKDh2J4sd6DKrZDC3VJ6U8YJCr6USVsotyqmx0nGUwlON4+AcxvaqMiIhLARC/gimE9w9MARCwHwT6++tyBIZK5tEuMBL6hGlmG53VjeuiU6hGZZNNOp9MNkcvSyecVZZNfKv+EvMD13IiiAHctbkt9kqpYmP3/y05mt2M= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1699348837; c=relaxed/simple; bh=vKVLZkmxfwb8KKCMncDmTHf2+vrMORqGp3T2e6JFAIQ=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=NMpbvXIMQp2N5vpK6JHqBNYywtFMD6QrCYhWo94yGen1RHLRExrrAnH7TTHfKN0M8TV7iG79NX0jznzcVwPoiCMrjKhGYb84o9m6DmQ8dYxMq/tScz1L4HAZywNUpun6D8bxXG07AdEiijf9jsZc1lQE6LAgTV6cVRDbo/OUB84= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x329.google.com with SMTP id 5b1f17b1804b1-408382da7f0so40101145e9.0 for ; Tue, 07 Nov 2023 01:20:32 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1699348831; x=1699953631; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:from:to:cc:subject:date:message-id:reply-to; bh=rF2ShpJE3kJXaQ5OVtS+PnaFStYeSaU1YwYVEyBmjpg=; b=dKMV7Wm9tslCYEshUvPLYr6ft+1xb75vDqX5PwldLXL+PUSSIViXD7X7YOsRgZRhmi j6M8lvWt+efhOgSvcupN1uuALXxc5iVZB47rh4PoKdn+BrnqbNBn5oJScI7ZdyDj5FHE zBAjEcthwvq7DPX7LfFbm7nGoMffw62rUioGkvOoPingdExN/kBBPzE4xyE+WTZtCK7d HBm05EpqrwQkdRettvERPX5+T6TCDcOSh8FcvLPcVylKbHV1Dd/5iwFz7YfRIC8iH5Qd hvUhJgjg0ZK2gvUOsOks0mmpVtEpMT1UVorC0vVQaSjWHGAmIrfQ78AIijgJARVhyMAT tC1A== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1699348831; x=1699953631; h=content-transfer-encoding:mime-version:message-id:date:subject:cc :to:from:x-gm-message-state:from:to:cc:subject:date:message-id :reply-to; bh=rF2ShpJE3kJXaQ5OVtS+PnaFStYeSaU1YwYVEyBmjpg=; b=fP886OfDgGCABhOcqtAqlmWJEIXpEQfV3uupP1cW82X0S9Xfk70YGItMh4rllvYbPs NweSl4AcWqFpV/oZEEJGYI/xUxzE+h6gOeRnw4KgixqdwzWN9oj1Cw3zUwkcLO8J6UC5 uVfcOkjnQedkm4jdKHdW5Wu2WVwV8NTtwtiar0OAKkUpUL37W1p2XaE8maWYg1hbEke/ ERzP6Ec/liPCJBXjqi+i9sxijrzTaevRj4C5bfz1sAyMoO3BZPKp01LL68ba1LuiWkCi W5QXhLHUi9umbg+ryYzgezw1bWC0hYIEN7C1UyZCCupEvjXQdBZ/y4iM+S/N+R/aOcjN UB+Q== X-Gm-Message-State: AOJu0YxzWh93xPQsoke2avIdqbgY4mJAX77H+lTgI02yQ1+UeW9vAuzh AzFMFJdSbNOGAYJkBNqCZtBkkHqLgWSqg0L/yoL4Bw== X-Received: by 2002:a5d:5348:0:b0:32d:a495:a9b7 with SMTP id t8-20020a5d5348000000b0032da495a9b7mr22875105wrv.61.1699348830971; Tue, 07 Nov 2023 01:20:30 -0800 (PST) Received: from localhost.localdomain ([2001:861:3382:1a90:dbc1:a1d1:2e58:4040]) by smtp.gmail.com with ESMTPSA id o9-20020a5d62c9000000b0032f7f4d008dsm1800927wrv.20.2023.11.07.01.20.30 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 07 Nov 2023 01:20:30 -0800 (PST) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Yannick Moy Subject: [COMMITTED] ada: Rename Is_Limited_View to reflect actual query Date: Tue, 7 Nov 2023 10:20:27 +0100 Message-ID: <20231107092027.3906542-1-poulhies@adacore.com> X-Mailer: git-send-email 2.42.0 MIME-Version: 1.0 X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1781896887717314140 X-GMAIL-MSGID: 1781896887717314140 From: Yannick Moy Function Sem_Aux.Is_Limited_View returns whether the type is "inherently limited" in a slightly different way from the "immutably limited" definition in Ada 2012. Rename for clarity. gcc/ada/ * exp_aggr.adb: Apply the renaming. * exp_ch3.adb: Same. * exp_ch4.adb: Same. * exp_ch6.adb: Same. * exp_ch7.adb: Same. * exp_util.adb: Same. * freeze.adb: Same. * sem_aggr.adb: Same. * sem_attr.adb: Same. * sem_aux.adb: Alphabetize Is_Limited_Type. Rename. * sem_aux.ads: Same. * sem_ch3.adb: Apply the renaming. * sem_ch6.adb: Same. * sem_ch8.adb: Same. * sem_prag.adb: Same. * sem_res.adb: Same. * sem_util.adb: Same. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 10 ++-- gcc/ada/exp_ch3.adb | 6 +-- gcc/ada/exp_ch4.adb | 2 +- gcc/ada/exp_ch6.adb | 4 +- gcc/ada/exp_ch7.adb | 4 +- gcc/ada/exp_util.adb | 4 +- gcc/ada/freeze.adb | 5 +- gcc/ada/sem_aggr.adb | 2 +- gcc/ada/sem_attr.adb | 4 +- gcc/ada/sem_aux.adb | 116 +++++++++++++++++++++---------------------- gcc/ada/sem_aux.ads | 16 +++--- gcc/ada/sem_ch3.adb | 2 +- gcc/ada/sem_ch6.adb | 6 +-- gcc/ada/sem_ch8.adb | 2 +- gcc/ada/sem_prag.adb | 2 +- gcc/ada/sem_res.adb | 4 +- gcc/ada/sem_util.adb | 10 ++-- 17 files changed, 101 insertions(+), 98 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 340c8c68465..319254dfd63 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -945,7 +945,7 @@ package body Exp_Aggr is -- If component is limited, aggregate must be expanded because each -- component assignment must be built in place. - if Is_Limited_View (Component_Type (Typ)) then + if Is_Inherently_Limited_Type (Component_Type (Typ)) then return False; end if; @@ -3026,7 +3026,7 @@ package body Exp_Aggr is -- call will be generated by Make_Tag_Ctrl_Assignment). if Needs_Finalization (Init_Typ) - and then not Is_Limited_View (Init_Typ) + and then not Is_Inherently_Limited_Type (Init_Typ) then Set_No_Finalize_Actions (First (Assign)); else @@ -8166,7 +8166,9 @@ package body Exp_Aggr is -- Extension aggregates, aggregates in extended return statements, and -- aggregates for C++ imported types must be expanded. - elsif Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then + elsif Ada_Version >= Ada_2005 + and then Is_Inherently_Limited_Type (Typ) + then if Nkind (Parent (N)) not in N_Component_Association | N_Object_Declaration then @@ -8400,7 +8402,7 @@ package body Exp_Aggr is -- of their individual elements will receive an adjustment of its own. if Finalization_OK - and then not Is_Limited_View (Comp_Typ) + and then not Is_Inherently_Limited_Type (Comp_Typ) and then not (Is_Array_Type (Etype (N)) and then Is_Array_Type (Comp_Typ) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 0217f8d7eb0..511d4c09b22 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7255,7 +7255,7 @@ package body Exp_Ch3 is else pragma Assert (Is_Definite_Subtype (Typ) or else (Has_Unknown_Discriminants (Typ) - and then Is_Limited_View (Typ))); + and then Is_Inherently_Limited_Type (Typ))); Alloc_Typ := Typ; end if; @@ -7692,7 +7692,7 @@ package body Exp_Ch3 is -- and attached to the finalization list. if Needs_Finalization (Typ) - and then not Is_Limited_View (Typ) + and then not Is_Inherently_Limited_Type (Typ) then Adj_Call := Make_Adjust_Call ( @@ -8137,7 +8137,7 @@ package body Exp_Ch3 is -- the object declaration into a renaming declaration. if Needs_Finalization (Typ) - and then not Is_Limited_View (Typ) + and then not Is_Inherently_Limited_Type (Typ) and then Nkind (Expr_Q) /= N_Function_Call and then not Rewrite_As_Renaming then diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index ec95d8b830b..f04ac615be9 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -941,7 +941,7 @@ package body Exp_Ch4 is if Needs_Finalization (DesigT) and then Needs_Finalization (T) - and then not Is_Limited_View (T) + and then not Is_Inherently_Limited_Type (T) and then not Aggr_In_Place and then Nkind (Exp) /= N_Function_Call and then not For_Special_Return_Object (N) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 1a2a027265c..d4802402670 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6913,7 +6913,7 @@ package body Exp_Ch6 is Set_Enclosing_Sec_Stack_Return (N); end if; - elsif Is_Limited_View (R_Type) then + elsif Is_Inherently_Limited_Type (R_Type) then null; -- No copy needed for thunks returning interface type objects since @@ -8219,7 +8219,7 @@ package body Exp_Ch6 is -- of a function with a limited interface result, where the function -- may return objects of nonlimited descendants. - return Is_Limited_View (Typ) + return Is_Inherently_Limited_Type (Typ) and then Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L; end Is_Build_In_Place_Result_Type; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 00b7692c964..369f0b07999 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -788,7 +788,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Array_Body (Initialize_Case, Typ))); - if not Is_Limited_View (Typ) then + if not Is_Inherently_Limited_Type (Typ) then Set_TSS (Typ, Make_Deep_Proc (Prim => Adjust_Case, @@ -3814,7 +3814,7 @@ package body Exp_Ch7 is Typ => Typ, Stmts => Make_Deep_Record_Body (Initialize_Case, Typ))); - if not Is_Limited_View (Typ) then + if not Is_Inherently_Limited_Type (Typ) then Set_TSS (Typ, Make_Deep_Proc (Prim => Adjust_Case, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 1aff5a062ce..3e8d5997949 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -5927,7 +5927,7 @@ package body Exp_Util is -- function being called is build-in-place. This will have to be revised -- when build-in-place functions are generalized to other types. - elsif Is_Limited_View (Exp_Typ) + elsif Is_Inherently_Limited_Type (Exp_Typ) and then (Is_Class_Wide_Type (Exp_Typ) or else Is_Interface (Exp_Typ) @@ -12363,7 +12363,7 @@ package body Exp_Util is if Ada_Version >= Ada_2005 and then Nkind (Exp) = N_Function_Call - and then Is_Limited_View (Etype (Exp)) + and then Is_Inherently_Limited_Type (Etype (Exp)) and then Nkind (Parent (Exp)) /= N_Object_Declaration then declare diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index efd95d757c4..61099138814 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -798,7 +798,7 @@ package body Freeze is -- limited objects. if Present (Init) - and then not Is_Limited_View (Typ) + and then not Is_Inherently_Limited_Type (Typ) then -- Capture initialization value at point of declaration, and make -- explicit assignment legal, because object may be a constant. @@ -7446,7 +7446,8 @@ package body Freeze is -- be an array type, or a nonlimited record type). if Has_Private_Declaration (E) then - if (not Is_Record_Type (E) or else not Is_Limited_View (E)) + if (not Is_Record_Type (E) + or else not Is_Inherently_Limited_Type (E)) and then not Is_Private_Type (E) then Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 597c3ce2dd1..36db7987d91 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -4305,7 +4305,7 @@ package body Sem_Aggr is -- extensions, and maybe for nondiscriminated types. -- This is wrong for limited, but those were wrong already. - if not Is_Limited_View (A_Type) + if not Is_Inherently_Limited_Type (A_Type) and then Is_Build_In_Place_Function_Call (A) then Transform_BIP_Assignment (A_Type); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 3eba3a29362..531bc112c91 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -4981,7 +4981,7 @@ package body Sem_Attr is -- Loop_Entry must create a constant initialized by the evaluated -- prefix. - if Is_Limited_View (Etype (P)) then + if Is_Inherently_Limited_Type (Etype (P)) then Error_Attr_P ("prefix of attribute % cannot be limited"); end if; @@ -7357,7 +7357,7 @@ package body Sem_Attr is then Error_Attr_P ("prefix of attribute % must be a record or array"); - elsif Is_Limited_View (P_Type) then + elsif Is_Inherently_Limited_Type (P_Type) then Error_Attr ("prefix of attribute % cannot be limited", N); elsif Nkind (E1) /= N_Aggregate then diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index e7e096fa1cf..c8fbdb0b117 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -1017,55 +1017,6 @@ package body Sem_Aux is end if; end Is_Generic_Formal; - ------------------------------- - -- Is_Immutably_Limited_Type -- - ------------------------------- - - function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is - Btype : constant Entity_Id := Available_View (Base_Type (Ent)); - - begin - if Is_Limited_Record (Btype) then - return True; - - elsif Ekind (Btype) = E_Limited_Private_Type - and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration - then - return not In_Package_Body (Scope ((Btype))); - - elsif Is_Private_Type (Btype) then - - -- AI05-0063: A type derived from a limited private formal type is - -- not immutably limited in a generic body. - - if Is_Derived_Type (Btype) - and then Is_Generic_Type (Etype (Btype)) - then - if not Is_Limited_Type (Etype (Btype)) then - return False; - - -- A descendant of a limited formal type is not immutably limited - -- in the generic body, or in the body of a generic child. - - elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then - return not In_Package_Body (Scope (Btype)); - - else - return False; - end if; - - else - return False; - end if; - - elsif Is_Concurrent_Type (Btype) then - return True; - - else - return False; - end if; - end Is_Immutably_Limited_Type; - --------------------- -- Is_Limited_Type -- --------------------- @@ -1148,11 +1099,60 @@ package body Sem_Aux is end if; end Is_Limited_Type; - --------------------- - -- Is_Limited_View -- - --------------------- + ------------------------------- + -- Is_Immutably_Limited_Type -- + ------------------------------- + + function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is + Btype : constant Entity_Id := Available_View (Base_Type (Ent)); + + begin + if Is_Limited_Record (Btype) then + return True; + + elsif Ekind (Btype) = E_Limited_Private_Type + and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration + then + return not In_Package_Body (Scope ((Btype))); + + elsif Is_Private_Type (Btype) then + + -- AI05-0063: A type derived from a limited private formal type is + -- not immutably limited in a generic body. + + if Is_Derived_Type (Btype) + and then Is_Generic_Type (Etype (Btype)) + then + if not Is_Limited_Type (Etype (Btype)) then + return False; + + -- A descendant of a limited formal type is not immutably limited + -- in the generic body, or in the body of a generic child. + + elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then + return not In_Package_Body (Scope (Btype)); + + else + return False; + end if; + + else + return False; + end if; + + elsif Is_Concurrent_Type (Btype) then + return True; + + else + return False; + end if; + end Is_Immutably_Limited_Type; + + -------------------------------- + -- Is_Inherently_Limited_Type -- + -------------------------------- - function Is_Limited_View (Ent : Entity_Id) return Boolean is + function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is Btype : constant Entity_Id := Available_View (Base_Type (Ent)); begin @@ -1192,7 +1192,7 @@ package body Sem_Aux is if No (Utyp) then return False; else - return Is_Limited_View (Utyp); + return Is_Inherently_Limited_Type (Utyp); end if; end; end if; @@ -1210,7 +1210,7 @@ package body Sem_Aux is -- of a type that is not inherently limited. if Is_Class_Wide_Type (Btype) then - return Is_Limited_View (Root_Type (Btype)); + return Is_Inherently_Limited_Type (Root_Type (Btype)); else declare @@ -1227,7 +1227,7 @@ package body Sem_Aux is -- limited interfaces. if not Is_Interface (Etype (C)) - and then Is_Limited_View (Etype (C)) + and then Is_Inherently_Limited_Type (Etype (C)) then return True; end if; @@ -1240,12 +1240,12 @@ package body Sem_Aux is end if; elsif Is_Array_Type (Btype) then - return Is_Limited_View (Component_Type (Btype)); + return Is_Inherently_Limited_Type (Component_Type (Btype)); else return False; end if; - end Is_Limited_View; + end Is_Inherently_Limited_Type; ---------------------- -- Nearest_Ancestor -- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index a490fd3edd1..5447fa8d0d3 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -311,13 +311,20 @@ package Sem_Aux is -- used to set the visibility of generic formals of a generic package -- declared with a box or with partial parameterization. + function Is_Limited_Type (Ent : Entity_Id) return Boolean; + -- Ent is any entity. Returns true if Ent is a limited type (limited + -- private type, limited interface type, task type, protected type, + -- composite containing a limited component, or a subtype of any of + -- these types). This older routine overlaps with the next ones, this + -- should be cleaned up??? + function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean; -- Implements definition in Ada 2012 RM-7.5 (8.1/3). This differs from the -- following predicate in that an untagged record with immutably limited -- components is NOT by itself immutably limited. This matters, e.g. when -- checking the legality of an access to the current instance. - function Is_Limited_View (Ent : Entity_Id) return Boolean; + function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean; -- Ent is any entity. True for a type that is "inherently" limited (i.e. -- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with -- a part that is of a task, protected, or explicitly limited record type". @@ -327,13 +334,6 @@ package Sem_Aux is -- for other types, too. This is also used for identifying pure procedures -- whose calls should not be eliminated (RM 10.2.1(18/2)). - function Is_Limited_Type (Ent : Entity_Id) return Boolean; - -- Ent is any entity. Returns true if Ent is a limited type (limited - -- private type, limited interface type, task type, protected type, - -- composite containing a limited component, or a subtype of any of - -- these types). This older routine overlaps with the previous one, this - -- should be cleaned up??? - function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id; -- Given a subtype Typ, this function finds out the nearest ancestor from -- which constraints and predicates are inherited. There is no simple link diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a38275133f4..ca60850a2b3 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -11636,7 +11636,7 @@ package body Sem_Ch3 is -- or else be a partial view. if Nkind (Discriminant_Type (D)) = N_Access_Definition then - if Is_Limited_View (Current_Scope) + if Is_Inherently_Limited_Type (Current_Scope) or else (Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration and then Limited_Present (Parent (Current_Scope))) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 3dd265901dd..4f2521a1dfb 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1065,7 +1065,7 @@ package body Sem_Ch6 is -- get generated elsewhere. if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L) - and then Is_Limited_View (Etype (Scope_Id)) + and then Is_Inherently_Limited_Type (Etype (Scope_Id)) and then Static_Accessibility_Level (Expr, Zero_On_Dynamic_Level) > Subprogram_Access_Level (Scope_Id) then @@ -6662,7 +6662,7 @@ package body Sem_Ch6 is ("(Ada 2005) cannot copy object of a limited type " & "(RM-2005 6.5(5.5/2))", Expr); - if Is_Limited_View (R_Type) then + if Is_Inherently_Limited_Type (R_Type) then Error_Msg_N ("\return by reference not permitted in Ada 2005", Expr); end if; @@ -6682,7 +6682,7 @@ package body Sem_Ch6 is ("return of limited object not permitted in Ada 2005 " & "(RM-2005 6.5(5.5/2))?y?", Expr); - elsif Is_Limited_View (R_Type) then + elsif Is_Inherently_Limited_Type (R_Type) then Error_Msg_N ("return by reference not permitted in Ada 2005 " & "(RM-2005 6.5(5.5/2))?y?", Expr); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 7f6accd7768..88be8aeaff2 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1143,7 +1143,7 @@ package body Sem_Ch8 is -- there is no copy involved and no performance hit. if Nkind (Nam) = N_Function_Call - and then Is_Limited_View (Etype (Nam)) + and then Is_Inherently_Limited_Type (Etype (Nam)) and then not Is_Constrained (Etype (Nam)) and then Comes_From_Source (N) then diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index b9172cd9719..c49cb278c59 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -24027,7 +24027,7 @@ package body Sem_Prag is -- in Freeze_Entity). if Is_Record_Type (Typ) - and then not Is_Limited_View (Typ) + and then not Is_Inherently_Limited_Type (Typ) then Error_Pragma ("pragma% can only apply to explicitly limited record type"); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index e7b0b8ba7e1..fa1365c2641 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5451,7 +5451,7 @@ package body Sem_Res is -- of the current b-i-p implementation to unify the handling for -- multiple kinds of storage pools). ??? - if Is_Limited_View (Desig_T) + if Is_Inherently_Limited_Type (Desig_T) and then Nkind (Expression (E)) = N_Function_Call then declare @@ -5716,7 +5716,7 @@ package body Sem_Res is if Ada_Version >= Ada_2012 and then Is_Limited_Type (Desig_T) - and then not Is_Limited_View (Scope (Discr)) + and then not Is_Inherently_Limited_Type (Scope (Discr)) then Error_Msg_N ("only immutably limited types can have anonymous " diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index afe69da6a84..3d870b1049c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1879,7 +1879,7 @@ package body Sem_Util is return False; end if; - return Is_Definite_Subtype (T) and then Is_Limited_View (T); + return Is_Definite_Subtype (T) and then Is_Inherently_Limited_Type (T); end Build_Default_Subtype_OK; -------------------------------------------- @@ -6190,7 +6190,7 @@ package body Sem_Util is -- In Ada 95, limited types are returned by reference, but not if the -- convention is other than Ada. - elsif Is_Limited_View (Typ) + elsif Is_Inherently_Limited_Type (Typ) and then not Has_Foreign_Convention (Func) then Set_Returns_By_Ref (Func); @@ -15325,7 +15325,7 @@ package body Sem_Util is -- statement is aliased if its type is immutably limited. or else (Is_Return_Object (E) - and then Is_Limited_View (Etype (E))) + and then Is_Inherently_Limited_Type (Etype (E))) -- The current instance of a limited type is aliased, so -- we want to allow uses of T'Access in the init proc for @@ -15334,7 +15334,7 @@ package body Sem_Util is or else (Is_Formal (E) and then Chars (E) = Name_uInit - and then Is_Limited_View (Etype (E))); + and then Is_Inherently_Limited_Type (Etype (E))); elsif Nkind (Obj) = N_Selected_Component then return Is_Aliased (Entity (Selector_Name (Obj))); @@ -22592,7 +22592,7 @@ package body Sem_Util is begin if Is_Record_Type (Typ) - and then not Is_Limited_View (Typ) + and then not Is_Inherently_Limited_Type (Typ) and then Has_Defaulted_Discriminants (Typ) then -- Loop through the components, looking for an array whose upper