From patchwork Tue Apr 25 08:12:51 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 754633 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org 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 3wBwvg1lvjz9s80 for ; Tue, 25 Apr 2017 18:13:35 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="I4npNwi+"; dkim-atps=neutral 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=fLPyLPavUy9wcybcXIzBA8ZpR56qxdBnyfcgw0uXn56GKJaUXk iHMdBxcpPRdPgbxcLO7+gGzbTGsq5PaE61qLKRi1Pif++YKoVGqlCwhGfhoo8/XC 0pbqqleaeoXufaBehlC+ec3SXqOcmIMcwnCNYyRqcp9OnSmuFh+kEUrM0= 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=Pq3MFEx24aRWqzM2vEk8emNrKK8=; b=I4npNwi+QNnYqwxpg4LI jEsqhT8wZ++Pn4BeSMnhz64hMx8UQ6/0teoUoGPNEcLmL4nAd761nOY7pZ3iGVLw GKw2gXSIEEe9vpyC+KQE6gbe/y9AZbQH3m88yHY9gilCxhklFulImwjJBUp/gAo6 eMaqn5arULYNgKbaxoHH6w8= Received: (qmail 26210 invoked by alias); 25 Apr 2017 08:13:09 -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 26081 invoked by uid 89); 25 Apr 2017 08:13:08 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-9.9 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS, T_FILL_THIS_FORM_SHORT autolearn=ham version=3.3.2 spammy=climbing, Inheritance, hood, behave 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, 25 Apr 2017 08:12:51 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 1546029D9C; Tue, 25 Apr 2017 04:12:52 -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 877uDidGFckm; Tue, 25 Apr 2017 04:12:51 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id E841A2970B; Tue, 25 Apr 2017 04:12:51 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id E6B96521; Tue, 25 Apr 2017 04:12:51 -0400 (EDT) Date: Tue, 25 Apr 2017 04:12:51 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Support for discriminants in pragma Default_Initial_Condition Message-ID: <20170425081251.GA36982@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch adds support for tagged discriminants in assertion expressions such as those of pragma Default_Initial_Condition or Type_Invariant'Class. In these contexts, tagged discriminants behave as primitives and exhibit "overriding"- like properties. For instance, if a derived type constrains its parent and inherits a Default_Initial_Condition from it which checks the discriminant of the parent, the runtime check must verify the discriminant of the derived type. ------------ -- Source -- ------------ -- tester.ads package Tester is type Type_Id is (No_Type, Deriv_1_Id, Deriv_2_Id, Deriv_3_Id, Deriv_4_Id, Deriv_5_Id, Deriv_6_Id, Deriv_7_Id, Deriv_8_Id, Deriv_9_Id, Deriv_10_Id, Deriv_11_Id, Deriv_12_Id, Deriv_13_Id, Deriv_14_Id, Deriv_15_Id, Deriv_16_Id, Deriv_17_Id, Deriv_18_Id, Deriv_19_Id, Deriv_20_Id, Mid_13_Id, Mid_14_Id, Mid_19_Id, Par_1_Id, Par_2_Id, Par_3_Id, Par_4_Id, Par_5_Id, Par_6_Id, Par_7_Id, Par_8_Id, Par_9_Id, Par_10_Id, Par_11_Id, Par_12_Id, Par_13_Id, Par_14_Id, Par_15_Id, Par_16_Id, Par_17_Id, Par_18_Id, Par_19_Id, Par_20_Id); type Result is record X : Integer; Y : Integer; end record; No_Result : constant Result := (0, 0); type Results is array (Type_Id) of Result; procedure Mark (Id : Type_Id; X : Integer; Y : Integer); -- Record the result for a particular type procedure Reset_Results; -- Reset the internally kept result state procedure Test_Result (Test_Id : String; Exp : Results); -- Ensure that the internally kept result state agrees with expected -- results Exp. Emit an error if this is not the case. end Tester; -- tester.ads with Ada.Text_IO; use Ada.Text_IO; package body Tester is State : Results; ---------- -- Mark -- ---------- procedure Mark (Id : Type_Id; X : Integer; Y : Integer) is begin State (Id) := (X, Y); end Mark; ------------------- -- Reset_Results -- ------------------- procedure Reset_Results is begin State := (others => No_Result); end Reset_Results; ----------------- -- Test_Result -- ----------------- procedure Test_Result (Test_Id : String; Exp : Results) is Exp_Val : Result; Posted : Boolean := False; State_Val : Result; begin for Index in Results'Range loop Exp_Val := Exp (Index); State_Val := State (Index); if State_Val /= Exp_Val then if not Posted then Posted := True; Put_Line (Test_Id & ": ERROR"); end if; Put_Line (" Index : " & Index'Img); Put_Line (" Expected:" & Exp_Val.X'Img & ',' & Exp_Val.Y'Img); Put_Line (" Got :" & State_Val.X'Img & ',' & State_Val.Y'Img); end if; end loop; if not Posted then Put_Line (Test_Id & ": OK"); end if; end Test_Result; end Tester; -- dic_aspects.ads package DIC_Aspects is ----------------------- -- 1) No derivations -- ----------------------- type No_Deriv_1 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => No_Deriv_1.D_1 > 1 and then D_2 > 2; type No_Deriv_2 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => No_Deriv_2.D_1 > 1 and then D_2 > 2; --------------------------- -- 2) Tagged derivations -- --------------------------- -- No overriding -- No discriminants -- Visible derivation type Par_1 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => A (Par_1, Par_1.D_1, D_2); function A (Obj : Par_1; X : Integer; Y : Integer) return Boolean; type Deriv_1 is new Par_1 with private; -- DIC calls: A (Par_1, Par_1.D_1, Par_1.D_2) -- No overriding -- Unknown discriminants -- Hidden derivation type Par_2 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => B (Par_2, Par_2.D_1, D_2); function B (Obj : Par_2; X : Integer; Y : Integer) return Boolean; type Deriv_2 (<>) is tagged private; -- DIC calls: B (Par_2, Par_2.D_1, Par_2.D_2) -- No overriding -- Renaming -- Visible derivation type Par_3 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => C (Par_3, Par_3.D_1, D_2); function C (Obj : Par_3; X : Integer; Y : Integer) return Boolean; type Deriv_3 (D_2 : Integer; D_3 : Integer) is new Par_3 with private; -- D_2 renames Par_3.D_2 -- D_3 renames Par_3.D_1 -- DIC calls: C (Par_3, Deriv_3.D_3, Deriv_3.D_2) -- No overriding -- Renaming -- Hidden derivation type Par_4 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => D (Par_4, Par_4.D_1, D_2); function D (Obj : Par_4; X : Integer; Y : Integer) return Boolean; type Deriv_4 (D_1 : Integer; D_3 : Integer) is private; -- D_1 renames Par_4.D_1 -- D_3 renames Par_4.D_2 -- DIC calls: D (Par_4, Deriv_4.D_1, Deriv_4.D_3) -- No overriding -- Girder -- Visible derivation type Par_5 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => E (Par_5, Par_5.D_1, D_2); function E (Obj : Par_5; X : Integer; Y : Integer) return Boolean; type Deriv_5 (D_3 : Integer; D_4 : Integer) is new Par_5 with private; -- Par_5.D_1 constrained to 123 -- Par_5.D_2 constrained to 456 -- DIC calls: E (Par_5, 123, 456) -- No overriding -- Girder -- Hidden derivation type Par_6 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => F (Par_6, Par_6.D_1, D_2); function F (Obj : Par_6; X : Integer; Y : Integer) return Boolean; type Deriv_6 is tagged private; -- Par_6.D_1 constrained to 123 -- Par_6.D_2 constrained to 456 -- DIC calls: F (Par_6, 123, 456) -- Overriding -- No discriminants -- Visible derivation type Par_7 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => G (Par_7, Par_7.D_1, D_2); function G (Obj : Par_7; X : Integer; Y : Integer) return Boolean; type Deriv_7 is new Par_7 with private; -- DIC calls: G (Deriv_7, Par_7.D_1, Par_7.D_2) function G (Obj : Deriv_7; X : Integer; Y : Integer) return Boolean; -- Overriding -- No discriminants -- Hidden derivation type Par_8 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => H (Par_8, Par_8.D_1, D_2); function H (Obj : Par_8; X : Integer; Y : Integer) return Boolean; type Deriv_8 (<>) is tagged private; -- DIC calls: H (Deriv_8, Par_8.D_1, Par_8.D_2); function H (Obj : Deriv_8; X : Integer; Y : Integer) return Boolean; -- Overriding -- Renaming -- Visible derivation type Par_9 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => I (Par_9, Par_9.D_1, D_2); function I (Obj : Par_9; X : Integer; Y : Integer) return Boolean; type Deriv_9 (D_2 : Integer; D_1 : Integer) is new Par_9 with private; -- D_2 renames Par_9.D_1 -- D_1 renames Par_9.D_2 -- DIC calls: I (Deriv_9, Deriv_9.D_2, Deriv_9.D_1) function I (Obj : Deriv_9; X : Integer; Y : Integer) return Boolean; -- Overriding -- Renaming -- Hidden derivation type Par_10 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => J (Par_10, Par_10.D_1, D_2); function J (Obj : Par_10; X : Integer; Y : Integer) return Boolean; type Deriv_10 (D_1 : Integer; D_4 : Integer) is tagged private; -- D_1 renames Par_10.D_2 -- D_4 renames Par_10.D_1 -- DIC calls: J (Deriv_10, Deriv_10.D_4, Deriv_10.D_1) function J (Obj : Deriv_10; X : Integer; Y : Integer) return Boolean; -- Overriding -- Girder -- Visible derivation type Par_11 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => K (Par_11, Par_11.D_1, D_2); function K (Obj : Par_11; X : Integer; Y : Integer) return Boolean; type Deriv_11 (D_3 : Integer) is new Par_11 with private; -- Par_11.D_1 constained to 123 -- Par_11.D_2 constained to 456 -- DIC calls: K (Deriv_11, 123, 456) function K (Obj : Deriv_11; X : Integer; Y : Integer) return Boolean; -- Overriding -- Girder -- Hidden derivation type Par_12 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => L (Par_12, Par_12.D_1, D_2); function L (Obj : Par_12; X : Integer; Y : Integer) return Boolean; type Deriv_12 (<>) is tagged private; -- Par_12.D_1 constrained to 123 -- Par_12.D_2 constrained to 456 -- DIC calls: L (Deriv_12, 123, 456) function L (Obj : Deriv_12; X : Integer; Y : Integer) return Boolean; ------------------------------------------ -- 3) Tagged derivations, special cases -- ------------------------------------------ -- Long chain -- Overriding -- Renaming + Girder -- Mixed derivation type Par_13 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => M (Par_13, Par_13.D_1, D_2); function M (Obj : Par_13; X : Integer; Y : Integer) return Boolean; type Mid_13 (D_3 : Integer) is new Par_13 with private; -- Par_13.D_1 constrained to 123 -- D_3 renames Par_13.D_2 -- DIC calls: M (Par_13, 123, Mid_13.D_3) type Deriv_13 (D_1 : Integer) is tagged private; -- D_1 renames Mid_13.D_3 -- DIC calls : M (Deriv_13, 123, Deriv_13.D_1) function M (Obj : Deriv_13; X : Integer; Y : Integer) return Boolean; -- Long chain -- Overriding -- Renaming -- Mixed derivation type Par_14 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => N (Par_14, Par_14.D_1, D_2); function N (Obj : Par_14; X : Integer; Y : Integer) return Boolean; type Mid_14 (<>) is tagged private; -- inherits Par_14.D_1 -- inherits Par_14.D_2 -- DIC calls: N (Mid_14, Par_14.D_1, Par_14.D_2) function N (Obj : Mid_14; X : Integer; Y : Integer) return Boolean; type Deriv_14 (D_2 : Integer; D_3 : Integer) is new Mid_14 with private; -- Deriv_14.D_2 renames Mid_14.D_2 -- Deriv_14.D_3 renames Mid_14.D_1 -- DIC calls: N (Deriv_14, Deriv_14.D_3, Deriv_14.D_2) function N (Obj : Deriv_14; X : Integer; Y : Integer) return Boolean; -- Overriding -- Renaming + fewer discriminants -- Visible derivation type Par_15 (D_1 : Integer; D_2 : Integer) is tagged private with Default_Initial_Condition => O (Par_15, Par_15.D_1, D_2); function O (Obj : Par_15; X : Integer; Y : Integer) return Boolean; type Deriv_15 (D_3 : Integer) is new Par_15 with private; -- Deriv_15.D_3 constrains Par_15.D_1 and Par_15.D_2 -- DIC calls: O (Deriv_15, Deriv_15.D_3, Deriv_15.D_3) function O (Obj : Deriv_15; X : Integer; Y : Integer) return Boolean; ----------------------------- -- 4) Untagged derivations -- ----------------------------- -- Inheritance -- No discriminants type Par_16 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => P (Par_16, Par_16.D_1, D_2); function P (Obj : Par_16; X : Integer; Y : Integer) return Boolean; -- Inheritance -- Renaming type Par_17 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => Q (Par_17, Par_17.D_1, D_2); function Q (Obj : Par_17; X : Integer; Y : Integer) return Boolean; -- Inheritance -- Girder type Par_18 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => R (Par_18, Par_18.D_1, D_2); function R (Obj : Par_18; X : Integer; Y : Integer) return Boolean; -------------------------------------------- -- 5) Untagged derivations, special cases -- -------------------------------------------- -- Long chain -- Inheritance -- Renaming + Girder type Par_19 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => S (Par_19, Par_19.D_1, D_2); function S (Obj : Par_19; X : Integer; Y : Integer) return Boolean; -- Inheritance -- Renaming + fewer discriminants type Par_20 (D_1 : Integer; D_2 : Integer) is private with Default_Initial_Condition => T (Par_20, Par_20.D_1, D_2); function T (Obj : Par_20; X : Integer; Y : Integer) return Boolean; procedure Test_Deriv_2; procedure Test_Deriv_6; procedure Test_Deriv_8; procedure Test_Deriv_12; procedure Test_Deriv_16; procedure Test_Deriv_17; procedure Test_Deriv_18; procedure Test_Deriv_19; procedure Test_Deriv_20; procedure Test_DN_Deriv_14; procedure Test_Mid_14; procedure Test_Mid_19; private type No_Deriv_1 (D_1 : Integer; D_2 : Integer) is null record; type No_Deriv_2 (D_1 : Integer; D_2 : Integer) is tagged null record; type Par_1 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_1 is new Par_1 with null record; type Par_2 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_2 is new Par_2 with null record; type Par_3 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_3 (D_2 : Integer; D_3 : Integer) is new Par_3 (D_1 => D_3, D_2 => D_2) with null record; type Par_4 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_4 (D_1 : Integer; D_3 : Integer) is new Par_4 (D_1 => D_1, D_2 => D_3) with null record; type Par_5 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_5 (D_3 : Integer; D_4 : Integer) is new Par_5 (D_1 => 123, D_2 => 456) with null record; type Par_6 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_6 is new Par_6 (D_1 => 123, D_2 => 456) with null record; type Par_7 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_7 is new Par_7 with null record; type Par_8 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_8 is new Par_8 with null record; type Par_9 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_9 (D_2 : Integer; D_1 : Integer) is new Par_9 (D_1 => D_2, D_2 => D_1) with null record; type Par_10 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_10 (D_1 : Integer; D_4 : Integer) is new Par_10 (D_1 => D_4, D_2 => D_1) with null record; type Par_11 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_11 (D_3 : Integer) is new Par_11 (D_1 => 123, D_2 => 456) with null record; type Par_12 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_12 is new Par_12 (D_1 => 123, D_2 => 456) with null record; type Par_13 (D_1 : Integer; D_2 : Integer) is tagged null record; type Mid_13 (D_3 : Integer) is new Par_13 (D_1 => 123, D_2 => D_3) with null record; type Deriv_13 (D_1 : Integer) is new Mid_13 (D_3 => D_1) with null record; type Par_14 (D_1 : Integer; D_2 : Integer) is tagged null record; type Mid_14 is new Par_14 with null record; type Deriv_14 (D_2 : Integer; D_3 : Integer) is new Mid_14 (D_1 => D_3, D_2 => D_2) with null record; type Par_15 (D_1 : Integer; D_2 : Integer) is tagged null record; type Deriv_15 (D_3 : Integer) is new Par_15 (D_1 => D_3, D_2 => D_3) with null record; ----------------------------- -- 4) Untagged derivations -- ----------------------------- -- Inheritance -- No discriminants type Par_16 (D_1 : Integer; D_2 : Integer) is null record; type Deriv_16 is new Par_16; -- DIC calls: P (Par_16, Par_16.D_1, Par_16.D_2) -- Inheritance -- Renaming type Par_17 (D_1 : Integer; D_2 : Integer) is null record; type Deriv_17 (D_2 : Integer; D_3 : Integer) is new Par_17 (D_1 => D_3, D_2 => D_2); -- Deriv_17.D_2 renames Par_17.D_2 -- Deriv_17.D_3 renames Par_17.D_1 -- DIC calls: Q (Par_17, Deriv_17.D_3, Deriv_17.D_2) -- Inheritance -- Girder type Par_18 (D_1 : Integer; D_2 : Integer) is null record; type Deriv_18 is new Par_18 (D_1 => 123, D_2 => 456); -- Par_18.D_1 constrained by 123 -- Par_18.D_2 constrained by 456 -- DIC calls: R (Par_18, 123, 456) -------------------------------------------- -- 5) Untagged derivations, special cases -- -------------------------------------------- -- Long chain -- Inheritance -- Renaming + Girder type Par_19 (D_1 : Integer; D_2 : Integer) is null record; type Mid_19 (D_3 : Integer) is new Par_19 (D_1 => 123, D_2 => D_3); -- Par_19.D_1 constrained by 123 -- Mid_19.D_3 renames Par_19.D_2 -- DIC calls: R (Par_19, 123, Mid_19.D_3) type Deriv_19 (D_1 : Integer) is new Mid_19 (D_1); -- Deriv_19.D_1 renames Mid_19.D_3 -- DIC calls: R (Par_19, 123, Deriv_19.D_1) -- Inheritance -- Renaming + fewer discriminants type Par_20 (D_1 : Integer; D_2 : Integer) is null record; type Deriv_20 (D_3 : Integer) is new Par_20 (D_1 => D_3, D_2 => D_3); -- Deriv_20.D_3 constrains Par_20.D_1 and Par_20.D_2 -- DIC calls: T (Par_20, Deriv_20.D_3, Deriv_20.D_3 end DIC_Aspects; -- dic_main.adb with DIC_Aspects; with Tester; use Tester; procedure DIC_Main is package A renames DIC_Aspects; begin Reset_Results; declare Obj : A.Deriv_1 (1, 11); begin Test_Result ("Deriv_1", (Par_1_Id => (1, 11), others => No_Result)); end; Reset_Results; A.Test_Deriv_2; Test_Result ("Deriv_2", (Par_2_Id => (2, 22), others => No_Result)); Reset_Results; declare Obj : A.Deriv_3 (3, 33); begin Test_Result ("Deriv_3", (Par_3_Id => (33, 3), others => No_Result)); end; Reset_Results; declare Obj : A.Deriv_4 (4, 44); begin Test_Result ("Deriv_4", (Par_4_Id => (4, 44), others => No_Result)); end; Reset_Results; declare Obj : A.Deriv_5 (5, 55); begin Test_Result ("Deriv_5", (Par_5_Id => (123, 456), others => No_Result)); end; Reset_Results; A.Test_Deriv_6; Test_Result ("Deriv_6", (Par_6_Id => (123, 456), others => No_Result)); Reset_Results; declare Obj : A.Deriv_7 (7, 77); begin Test_Result ("Deriv_7", (Deriv_7_Id => (7, 77), others => No_Result)); end; Reset_Results; A.Test_Deriv_8; Test_Result ("Deriv_8", (Deriv_8_Id => (8, 88), others => No_Result)); Reset_Results; declare Obj : A.Deriv_9 (9, 99); begin Test_Result ("Deriv_9", (Deriv_9_Id => (9, 99), others => No_Result)); end; Reset_Results; declare Obj : A.Deriv_10 (10, 1010); begin Test_Result ("Deriv_10", (Deriv_10_Id => (1010, 10), others => No_Result)); end; Reset_Results; declare Obj : A.Deriv_11 (11); begin Test_Result ("Deriv_11", (Deriv_11_Id => (123, 456), others => No_Result)); end; Reset_Results; A.Test_Deriv_12; Test_Result ("Deriv_12", (Deriv_12_Id => (123, 456), others => No_Result)); Reset_Results; declare Obj : A.Mid_13 (13); begin Test_Result ("Mid_13", (Par_13_Id => (123, 13), others => No_Result)); end; Reset_Results; declare Obj : A.Deriv_13 (1313); begin Test_Result ("Deriv_13", (Deriv_13_Id => (123, 1313), others => No_Result)); end; Reset_Results; A.Test_Mid_14; Test_Result ("Mid_14", (Mid_14_Id => (14, 1414), others => No_Result)); Reset_Results; declare Obj : A.Deriv_14 (14, 1414); begin Test_Result ("Deriv_14", (Deriv_14_Id => (1414, 14), others => No_Result)); end; Reset_Results; A.Test_DN_Deriv_14; Test_Result ("Deriv_14_DN", (Deriv_14_Id => (1414, 14), others => No_Result)); Reset_Results; declare Obj : A.Deriv_15 (15); begin Test_Result ("Deriv_15", (Deriv_15_Id => (15, 15), others => No_Result)); end; Reset_Results; A.Test_Deriv_16; Test_Result ("Deriv_16", (Par_16_Id => (16, 1616), others => No_Result)); Reset_Results; A.Test_Deriv_17; Test_Result ("Deriv_17", (Par_17_Id => (1717, 17), others => No_Result)); Reset_Results; A.Test_Deriv_18; Test_Result ("Deriv_18", (Par_18_Id => (123, 456), others => No_Result)); Reset_Results; A.Test_Mid_19; Test_Result ("Mid_19", (Par_19_Id => (123, 19), others => No_Result)); Reset_Results; A.Test_Deriv_19; Test_Result ("Deriv_19", (Par_19_Id => (123, 1919), others => No_Result)); Reset_Results; A.Test_Deriv_20; Test_Result ("Deriv_20", (Par_20_Id => (20, 20), others => No_Result)); end DIC_Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q -gnata dic_main.adb $ ./dic_main Deriv_1: OK Deriv_2: OK Deriv_3: OK Deriv_4: OK Deriv_5: OK Deriv_6: OK Deriv_7: OK Deriv_8: OK Deriv_9: OK Deriv_10: OK Deriv_11: OK Deriv_12: OK Mid_13: OK Deriv_13: OK Mid_14: OK Deriv_14: OK Deriv_14_DN: OK Deriv_15: OK Deriv_16: OK Deriv_17: OK Deriv_18: OK Mid_19: OK Deriv_19: OK Deriv_20: OK Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-25 Hristian Kirtchev * exp_ch3.adb (Freeze_Type): Signal the DIC body is created for the purposes of freezing. * exp_util.adb Update the documentation and structure of the type map used in class-wide semantics of assertion expressions. (Add_Inherited_Tagged_DIC): There is really no need to preanalyze and resolve the triaged expression because all substitutions refer to the proper entities. Update the replacement of references. (Build_DIC_Procedure_Body): Add formal parameter For_Freeze. Add local variable Build_Body. Inherited DIC pragmas are now only processed when freezing occurs. Build a body only when one is needed. (Entity_Hash): Removed. (Map_Types): New routine. (Replace_Object_And_Primitive_References): Removed. (Replace_References): New routine. (Replace_Type_References): Moved to the library level of Exp_Util. (Type_Map_Hash): New routine. (Update_Primitives_Mapping): Update the mapping call. (Update_Primitives_Mapping_Of_Types): Removed. * exp_util.ads (Build_DIC_Procedure_Body): Add formal parameter For_Freeze and update the comment on usage. (Map_Types): New routine. (Replace_References): New routine. (Replace_Type_References): Moved to the library level of Exp_Util. (Update_Primitives_Mapping_Of_Types): Removed. * sem_ch7.adb (Preserve_Full_Attributes): Propagate the DIC properties of the private type to the full view in case the full view derives from a parent type and inherits a DIC pragma. * sem_prag.adb (Analyze_Pragma): Guard against a case where a DIC pragma is placed at the top of a declarative region. Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 247135) +++ exp_ch3.adb (working copy) @@ -7509,7 +7509,7 @@ -- verification of pragma Default_Initial_Condition's expression. if Has_DIC (Def_Id) then - Build_DIC_Procedure_Body (Def_Id); + Build_DIC_Procedure_Body (Def_Id, For_Freeze => True); end if; -- Generate the [spec and] body of the invariant procedure tasked with Index: exp_util.adb =================================================================== --- exp_util.adb (revision 247140) +++ exp_util.adb (working copy) @@ -92,17 +92,27 @@ -- operations are mapped into the overriding operations of that current -- type extension. - Primitives_Mapping_Size : constant := 511; + -- The contents of the map are as follows: - subtype Num_Primitives is Integer range 0 .. Primitives_Mapping_Size - 1; - function Entity_Hash (E : Entity_Id) return Num_Primitives; + -- Key Value - package Primitives_Mapping is new GNAT.HTable.Simple_HTable - (Header_Num => Num_Primitives, + -- Discriminant (Entity_Id) Discriminant (Entity_Id) + -- Discriminant (Entity_Id) Non-discriminant name (Entity_Id) + -- Discriminant (Entity_Id) Expression (Node_Id) + -- Primitive subprogram (Entity_Id) Primitive subprogram (Entity_Id) + -- Type (Entity_Id) Type (Entity_Id) + + Type_Map_Size : constant := 511; + + subtype Type_Map_Header is Integer range 0 .. Type_Map_Size - 1; + function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header; + + package Type_Map is new GNAT.HTable.Simple_HTable + (Header_Num => Type_Map_Header, Key => Entity_Id, - Element => Entity_Id, + Element => Node_Or_Entity_Id, No_element => Empty, - Hash => Entity_Hash, + Hash => Type_Map_Hash, Equal => "="); ----------------------- @@ -1087,7 +1097,7 @@ -- Determine whether entity has a renaming - New_E := Primitives_Mapping.Get (Entity (N)); + New_E := Type_Map.Get (Entity (N)); if Present (New_E) then Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); @@ -1173,7 +1183,7 @@ Subp_Formal := First_Formal (Subp); while Present (Par_Formal) and then Present (Subp_Formal) loop - Primitives_Mapping.Set (Par_Formal, Subp_Formal); + Type_Map.Set (Par_Formal, Subp_Formal); Next_Formal (Par_Formal); Next_Formal (Subp_Formal); end loop; @@ -1211,7 +1221,10 @@ -- replaced by gotos which jump to the end of the routine and restore the -- Ghost mode. - procedure Build_DIC_Procedure_Body (Typ : Entity_Id) is + procedure Build_DIC_Procedure_Body + (Typ : Entity_Id; + For_Freeze : Boolean := False) + is procedure Add_DIC_Check (DIC_Prag : Node_Id; DIC_Expr : Node_Id; @@ -1250,34 +1263,6 @@ -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code -- is added to list Stmts. - procedure Replace_Object_And_Primitive_References - (Expr : Node_Id; - Par_Typ : Entity_Id; - Deriv_Typ : Entity_Id; - Par_Obj : Entity_Id := Empty; - Deriv_Obj : Entity_Id := Empty); - -- Expr denotes an arbitrary expression. Par_Typ is a parent type in a - -- type hierarchy. Deriv_Typ is a type derived from Par_Typ. Par_Obj is - -- the formal parameter which emulates the current instance of Par_Typ. - -- Deriv_Obj is the formal parameter which emulates the current instance - -- of Deriv_Typ. Perform the following substitutions: - -- - -- * Replace a reference to Par_Obj with a reference to Deriv_Obj if - -- applicable. - -- - -- * Replace a call to an overridden parent primitive with a call to - -- the overriding derived type primitive. - -- - -- * Replace a call to an inherited parent primitive with a call to - -- the internally-generated inherited derived type primitive. - - procedure Replace_Type_References - (Expr : Node_Id; - Typ : Entity_Id; - Obj_Id : Entity_Id); - -- Substitute all references of the current instance of type Typ with - -- references to formal parameter Obj_Id within expression Expr. - ------------------- -- Add_DIC_Check -- ------------------- @@ -1359,7 +1344,6 @@ Deriv_Typ : Entity_Id; Stmts : in out List_Id) is - Deriv_Decl : constant Node_Id := Declaration_Node (Deriv_Typ); Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ); DIC_Args : constant List_Id := Pragma_Argument_Associations (DIC_Prag); @@ -1384,6 +1368,9 @@ -- type's DIC procedure with a reference to the _object parameter -- of the derived types' DIC procedure. + -- * Replace a reference to a discriminant of the parent type with + -- a suitable value from the point of view of the derived type. + -- * Replace a call to an overridden parent primitive with a call -- to the overriding derived type primitive. @@ -1396,19 +1383,13 @@ pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc)); - Replace_Object_And_Primitive_References + Replace_References (Expr => Expr, Par_Typ => Par_Typ, Deriv_Typ => Deriv_Typ, Par_Obj => First_Formal (Par_Proc), Deriv_Obj => First_Formal (Deriv_Proc)); - -- Preanalyze the DIC expression to detect errors and at the same - -- time capture the visibility of the proper package part. - - Set_Parent (Expr, Deriv_Decl); - Preanalyze_Assert_Expression (Expr, Any_Boolean); - -- Once the DIC assertion expression is fully processed, add a check -- to the statements of the DIC procedure. @@ -1532,200 +1513,6 @@ Stmts => Stmts); end Add_Own_DIC; - --------------------------------------------- - -- Replace_Object_And_Primitive_References -- - --------------------------------------------- - - procedure Replace_Object_And_Primitive_References - (Expr : Node_Id; - Par_Typ : Entity_Id; - Deriv_Typ : Entity_Id; - Par_Obj : Entity_Id := Empty; - Deriv_Obj : Entity_Id := Empty) - is - function Replace_Ref (Ref : Node_Id) return Traverse_Result; - -- Substitute a reference to an entity with a reference to the - -- corresponding entity stored in in table Primitives_Mapping. - - ----------------- - -- Replace_Ref -- - ----------------- - - function Replace_Ref (Ref : Node_Id) return Traverse_Result is - Context : constant Node_Id := Parent (Ref); - Loc : constant Source_Ptr := Sloc (Ref); - New_Id : Entity_Id; - New_Ref : Node_Id; - Ref_Id : Entity_Id; - Result : Traverse_Result; - - begin - Result := OK; - - -- The current node denotes a reference - - if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then - Ref_Id := Entity (Ref); - New_Id := Primitives_Mapping.Get (Ref_Id); - - -- The reference mentions a parent type primitive which has a - -- corresponding derived type primitive. - - if Present (New_Id) then - New_Ref := New_Occurrence_Of (New_Id, Loc); - - -- The reference mentions the _object parameter of the parent - -- type's DIC procedure. - - elsif Present (Par_Obj) - and then Present (Deriv_Obj) - and then Ref_Id = Par_Obj - then - New_Ref := New_Occurrence_Of (Deriv_Obj, Loc); - - -- The reference to _object acts as an actual parameter in a - -- subprogram call which may be invoking a primitive of the - -- parent type: - - -- Primitive (... _object ...); - - -- The parent type primitive may not be overridden nor - -- inherited when it is declared after the derived type - -- definition: - - -- type Parent is tagged private; - -- type Child is new Parent with private; - -- procedure Primitive (Obj : Parent); - - -- In this scenario the _object parameter is converted to - -- the parent type. - - if Nkind_In (Context, N_Function_Call, - N_Procedure_Call_Statement) - and then - No (Primitives_Mapping.Get (Entity (Name (Context)))) - then - New_Ref := Convert_To (Par_Typ, New_Ref); - - -- Do not process the generated type conversion because - -- both the parent type and the derived type are in the - -- Primitives_Mapping table. This will clobber the type - -- conversion by resetting its subtype mark. - - Result := Skip; - end if; - - -- Otherwise there is nothing to replace - - else - New_Ref := Empty; - end if; - - if Present (New_Ref) then - Rewrite (Ref, New_Ref); - - -- Update the return type when the context of the reference - -- acts as the name of a function call. Note that the update - -- should not be performed when the reference appears as an - -- actual in the call. - - if Nkind (Context) = N_Function_Call - and then Name (Context) = Ref - then - Set_Etype (Context, Etype (New_Id)); - end if; - end if; - end if; - - -- Reanalyze the reference due to potential replacements - - if Nkind (Ref) in N_Has_Etype then - Set_Analyzed (Ref, False); - end if; - - return Result; - end Replace_Ref; - - procedure Replace_Refs is new Traverse_Proc (Replace_Ref); - - -- Start of processing for Replace_Object_And_Primitive_References - - begin - -- Map each primitive operation of the parent type to the proper - -- primitive of the derived type. - - Update_Primitives_Mapping_Of_Types - (Par_Typ => Par_Typ, - Deriv_Typ => Deriv_Typ); - - -- Inspect the input expression and perform substitutions where - -- necessary. - - Replace_Refs (Expr); - end Replace_Object_And_Primitive_References; - - ----------------------------- - -- Replace_Type_References -- - ----------------------------- - - procedure Replace_Type_References - (Expr : Node_Id; - Typ : Entity_Id; - Obj_Id : Entity_Id) - is - procedure Replace_Type_Ref (N : Node_Id); - -- Substitute a single reference of the current instance of type Typ - -- with a reference to Obj_Id. - - ---------------------- - -- Replace_Type_Ref -- - ---------------------- - - procedure Replace_Type_Ref (N : Node_Id) is - Ref : Node_Id; - - begin - -- Decorate the reference to Typ even though it may be rewritten - -- further down. This is done for two reasons: - - -- 1) ASIS has all necessary semantic information in the - -- original tree. - - -- 2) Routines which examine properties of the Original_Node - -- have some semantic information. - - if Nkind (N) = N_Identifier then - Set_Entity (N, Typ); - Set_Etype (N, Typ); - - elsif Nkind (N) = N_Selected_Component then - Analyze (Prefix (N)); - Set_Entity (Selector_Name (N), Typ); - Set_Etype (Selector_Name (N), Typ); - end if; - - -- Perform the following substitution: - - -- Typ --> _object - - Ref := Make_Identifier (Sloc (N), Chars (Obj_Id)); - Set_Entity (Ref, Obj_Id); - Set_Etype (Ref, Typ); - - Rewrite (N, Ref); - - Set_Comes_From_Source (N, True); - end Replace_Type_Ref; - - procedure Replace_Type_Refs is - new Replace_Type_References_Generic (Replace_Type_Ref); - - -- Start of processing for Replace_Type_References - - begin - Replace_Type_Refs (Expr, Typ); - end Replace_Type_References; - -- Local variables Loc : constant Source_Ptr := Sloc (Typ); @@ -1741,6 +1528,9 @@ Proc_Id : Entity_Id; Stmts : List_Id := No_List; + Build_Body : Boolean := False; + -- Flag set when the type requires a DIC procedure body to be built + Work_Typ : Entity_Id; -- The working type @@ -1855,9 +1645,18 @@ DIC_Typ => DIC_Typ, Stmts => Stmts); - -- Otherwise the working type inherits a DIC pragma from a parent type + Build_Body := True; - else + -- Otherwise the working type inherits a DIC pragma from a parent type. + -- This processing is carried out when the type is frozen because the + -- state of all parent discriminants is known at that point. Note that + -- it is semantically sound to delay the creation of the DIC procedure + -- body till the freeze point. If the type has a DIC pragma of its own, + -- then the DIC procedure body would have already been constructed at + -- the end of the visible declarations and all parent DIC pragmas are + -- effectively "hidden" and irrelevant. + + elsif For_Freeze then pragma Assert (Has_Inherited_DIC (Work_Typ)); pragma Assert (DIC_Typ /= Work_Typ); @@ -1883,66 +1682,71 @@ Deriv_Typ => Work_Typ, Stmts => Stmts); end if; + + Build_Body := True; end if; End_Scope; - -- Produce an empty completing body in the following cases: - -- * Assertions are disabled - -- * The DIC Assertion_Policy is Ignore - -- * Pragma DIC appears without an argument - -- * Pragma DIC appears with argument "null" + if Build_Body then - if No (Stmts) then - Stmts := New_List (Make_Null_Statement (Loc)); - end if; + -- Produce an empty completing body in the following cases: + -- * Assertions are disabled + -- * The DIC Assertion_Policy is Ignore + -- * Pragma DIC appears without an argument + -- * Pragma DIC appears with argument "null" - -- Generate: - -- procedure DIC (_object : ) is - -- begin - -- - -- end DIC; + if No (Stmts) then + Stmts := New_List (Make_Null_Statement (Loc)); + end if; - Proc_Body := - Make_Subprogram_Body (Loc, - Specification => - Copy_Subprogram_Spec (Parent (Proc_Id)), - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts)); - Proc_Body_Id := Defining_Entity (Proc_Body); + -- Generate: + -- procedure DIC (_object : ) is + -- begin + -- + -- end DIC; - -- Perform minor decoration in case the body is not analyzed + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Subprogram_Spec (Parent (Proc_Id)), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + Proc_Body_Id := Defining_Entity (Proc_Body); - Set_Ekind (Proc_Body_Id, E_Subprogram_Body); - Set_Etype (Proc_Body_Id, Standard_Void_Type); - Set_Scope (Proc_Body_Id, Current_Scope); + -- Perform minor decoration in case the body is not analyzed - -- Link both spec and body to avoid generating duplicates + Set_Ekind (Proc_Body_Id, E_Subprogram_Body); + Set_Etype (Proc_Body_Id, Standard_Void_Type); + Set_Scope (Proc_Body_Id, Current_Scope); - Set_Corresponding_Body (Proc_Decl, Proc_Body_Id); - Set_Corresponding_Spec (Proc_Body, Proc_Id); + -- Link both spec and body to avoid generating duplicates - -- The body should not be inserted into the tree when the context is - -- ASIS or a generic unit because it is not part of the template. Note - -- that the body must still be generated in order to resolve the DIC - -- assertion expression. + Set_Corresponding_Body (Proc_Decl, Proc_Body_Id); + Set_Corresponding_Spec (Proc_Body, Proc_Id); - if ASIS_Mode or Inside_A_Generic then - null; + -- The body should not be inserted into the tree when the context + -- is ASIS or a generic unit because it is not part of the template. + -- Note that the body must still be generated in order to resolve the + -- DIC assertion expression. - -- Semi-insert the body into the tree for GNATprove by setting its - -- Parent field. This allows for proper upstream tree traversals. + if ASIS_Mode or Inside_A_Generic then + null; - elsif GNATprove_Mode then - Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ))); + -- Semi-insert the body into the tree for GNATprove by setting its + -- Parent field. This allows for proper upstream tree traversals. - -- Otherwise the body is part of the freezing actions of the working - -- type. + elsif GNATprove_Mode then + Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ))); - else - Append_Freeze_Action (Work_Typ, Proc_Body); + -- Otherwise the body is part of the freezing actions of the working + -- type. + + else + Append_Freeze_Action (Work_Typ, Proc_Body); + end if; end if; <> @@ -3389,15 +3193,6 @@ end if; end Ensure_Defined; - ----------------- - -- Entity_Hash -- - ----------------- - - function Entity_Hash (E : Entity_Id) return Num_Primitives is - begin - return Num_Primitives (E mod Primitives_Mapping_Size); - end Entity_Hash; - -------------------- -- Entry_Names_OK -- -------------------- @@ -8290,6 +8085,494 @@ Constraints => List_Constr)); end Make_Subtype_From_Expr; + --------------- + -- Map_Types -- + --------------- + + procedure Map_Types (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is + + -- Note: most of the routines in Map_Types are intentionally unnested to + -- avoid deep indentation of code. + + procedure Add_Primitive (Prim : Entity_Id); + -- Subsidiary to Map_Primitives. Find a primitive in the inheritance or + -- overriding chain starting from Prim whose dispatching type is parent + -- type Par_Typ and add a mapping between the result and primitive Prim. + + function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id; + -- Subsidiary to Map_Primitives. Return the next ancestor primitive in + -- the inheritance or overriding chain of subprogram Subp. Return Empty + -- if no such primitive is available. + + function Build_Chain return Elist_Id; + -- Subsidiary to Map_Discriminants. Recreate the derivation chain from + -- parent type Par_Typ leading down towards derived type Deriv_Typ. The + -- list has the form: + -- + -- head tail + -- v v + -- -> -> -> Deriv_Typ + -- + -- Note that Par_Typ is not part of the resulting derivation chain. + + function Find_Discriminant_Value + (Discr : Entity_Id; + Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id; + -- Subsidiary to Map_Discriminants. Find the value of discriminant Discr + -- in the derivation chain starting from parent type Par_Typ leading to + -- derived type Deriv_Typ. The returned value is one of the following: + -- + -- * An entity which is either a discriminant or a non-discriminant + -- name which renames/constraints Discr. + -- + -- * An expression which constraints Discr + -- + -- Typ_Elmt is an element of the derivation chain created by routine + -- Build_Chain and denotes the current ancestor being examined. + + procedure Map_Discriminants; + -- Map each discriminant of type Par_Typ to a meaningful constraint from + -- the point of view of type Deriv_Typ. + + procedure Map_Primitives; + -- Map each primitive of type Par_Typ to a corresponding primitive of + -- type Deriv_Typ. + + ------------------- + -- Add_Primitive -- + ------------------- + + procedure Add_Primitive (Prim : Entity_Id) is + Par_Prim : Entity_Id; + + begin + -- Inspect the inheritance chain through the Alias attribute and the + -- overriding chain through the Overridden_Operation looking for an + -- ancestor primitive with the appropriate dispatching type. + + Par_Prim := Prim; + while Present (Par_Prim) loop + exit when Find_Dispatching_Type (Par_Prim) = Par_Typ; + Par_Prim := Ancestor_Primitive (Par_Prim); + end loop; + + -- Create a mapping of the form: + + -- parent type primitive -> derived type primitive + + if Present (Par_Prim) then + Type_Map.Set (Par_Prim, Prim); + end if; + end Add_Primitive; + + ------------------------ + -- Ancestor_Primitive -- + ------------------------ + + function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is + Inher_Prim : constant Entity_Id := Alias (Subp); + Over_Prim : constant Entity_Id := Overridden_Operation (Subp); + + begin + -- The current subprogram overrides an ancestor primitive + + if Present (Over_Prim) then + return Over_Prim; + + -- The current subprogram is an internally generated alias of an + -- inherited ancestor primitive. + + elsif Present (Inher_Prim) then + return Inher_Prim; + + -- Otherwise the current subprogram is the root of the inheritance or + -- overriding chain. + + else + return Empty; + end if; + end Ancestor_Primitive; + + ----------------- + -- Build_Chain -- + ----------------- + + function Build_Chain return Elist_Id is + Anc_Typ : Entity_Id; + Chain : Elist_Id; + Curr_Typ : Entity_Id; + + begin + Chain := New_Elmt_List; + + -- Add the derived type to the derivation chain + + Prepend_Elmt (Deriv_Typ, Chain); + + -- Examine all ancestors starting from the derived type climbing + -- towards parent type Par_Typ. + + Curr_Typ := Deriv_Typ; + loop + Anc_Typ := Base_Type (Etype (Curr_Typ)); + + -- Stop the climb when either the parent type has been reached or + -- there are no more ancestors left to examine. + + exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ; + + -- Add the current ancestor to the derivation chain + + Prepend_Elmt (Anc_Typ, Chain); + Curr_Typ := Anc_Typ; + end loop; + + return Chain; + end Build_Chain; + + ----------------------------- + -- Find_Discriminant_Value -- + ----------------------------- + + function Find_Discriminant_Value + (Discr : Entity_Id; + Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id + is + Discr_Pos : constant Uint := Discriminant_Number (Discr); + Typ : constant Entity_Id := Node (Typ_Elmt); + + function Find_Constraint_Value + (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id; + -- Given constraint Constr, find what it denotes. This is either: + -- + -- * An entity which is either a discriminant or a name + -- + -- * An expression + + --------------------------- + -- Find_Constraint_Value -- + --------------------------- + + function Find_Constraint_Value + (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id + is + begin + if Nkind (Constr) in N_Entity then + + -- The constraint denotes a discriminant of the current type + -- which renames the ancestor discriminant: + + -- vv + -- type Typ (D1 : ...; DN : ...) is + -- new Anc (Discr => D1) with ... + -- ^^ + + if Ekind (Constr) = E_Discriminant then + + -- The discriminant belongs to derived type Deriv_Typ. This + -- is the final value for the ancestor discriminant as the + -- derivations chain has been fully exhausted. + + if Typ = Deriv_Typ then + return Constr; + + -- Otherwise the discriminant may be renamed or constrained + -- at a lower level. Continue looking down the derivation + -- chain. + + else + return + Find_Discriminant_Value + (Discr => Constr, + Typ_Elmt => Next_Elmt (Typ_Elmt)); + end if; + + -- Otherwise the constraint denotes a reference to some name + -- which results in a Girder discriminant: + + -- vvvv + -- Name : ...; + -- type Typ (D1 : ...; DN : ...) is + -- new Anc (Discr => Name) with ... + -- ^^^^ + + -- Return the name as this is the proper constraint of the + -- discriminant. + + else + return Constr; + end if; + + -- The constraint denotes a reference to a name + + elsif Is_Entity_Name (Constr) then + return Find_Constraint_Value (Entity (Constr)); + + -- Otherwise the current constraint is an expression which yields + -- a Girder discriminant: + + -- type Typ (D1 : ...; DN : ...) is + -- new Anc (Discr => ) with ... + -- ^^^^^^^^^^ + + -- Return the expression as this is the proper constraint of the + -- discriminant. + + else + return Constr; + end if; + end Find_Constraint_Value; + + -- Local variables + + Constrs : constant Elist_Id := Stored_Constraint (Typ); + + Constr_Elmt : Elmt_Id; + Pos : Uint; + Typ_Discr : Entity_Id; + + -- Start of processing for Find_Discriminant_Value + + begin + -- The algorithm for finding the value of a discriminant works as + -- follows. First, it recreates the derivation chain from Par_Typ + -- to Deriv_Typ as a list: + + -- Par_Typ (shown for completeness) + -- v + -- Ancestor_N <-- head of chain + -- v + -- Ancestor_1 + -- v + -- Deriv_Typ <-- tail of chain + + -- The algorithm then traces the fate of a parent discriminant down + -- the derivation chain. At each derivation level, the discriminant + -- may be either inherited or constrained. + + -- 1) Discriminant is inherited: there are two cases, depending on + -- which type is inheriting. + + -- 1.1) Deriv_Typ is inheriting: + + -- type Ancestor (D_1 : ...) is tagged ... + -- type Deriv_Typ is new Ancestor ... + + -- In this case the inherited discriminant is the final value of + -- the parent discriminant because the end of the derivation chain + -- has been reached. + + -- 1.2) Some other type is inheriting: + + -- type Ancestor_1 (D_1 : ...) is tagged ... + -- type Ancestor_2 is new Ancestor_1 ... + + -- In this case the algorithm continues to trace the fate of the + -- inherited discriminant down the derivation chain because it may + -- be further inherited or constrained. + + -- 2) Discriminant is constrained: there are three cases, depending + -- on what the constraint is. + + -- 2.1) The constraint is another discriminant (aka renaming): + + -- type Ancestor_1 (D_1 : ...) is tagged ... + -- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ... + + -- In this case the constraining discriminant becomes the one to + -- track down the derivation chain. The algorithm already knows + -- that D_2 constrains D_1, therefore if the algorithm finds the + -- value of D_2, then this would also be the value for D_1. + + -- 2.2) The constraint is a name (aka Girder): + + -- Name : ... + -- type Ancestor_1 (D_1 : ...) is tagged ... + -- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ... + + -- In this case the name is the final value of D_1 because the + -- discriminant cannot be further constrained. + + -- 2.3) The constraint is an expression (aka Girder): + + -- type Ancestor_1 (D_1 : ...) is tagged ... + -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ... + + -- Similar to 2.2, the expression is the final value of D_1 + + Pos := Uint_1; + + -- When a derived type constrains its parent type, all constaints + -- appear in the Stored_Constraint list. Examine the list looking + -- for a positional match. + + if Present (Constrs) then + Constr_Elmt := First_Elmt (Constrs); + while Present (Constr_Elmt) loop + + -- The position of the current constraint matches that of the + -- ancestor discriminant. + + if Pos = Discr_Pos then + return Find_Constraint_Value (Node (Constr_Elmt)); + end if; + + Next_Elmt (Constr_Elmt); + Pos := Pos + 1; + end loop; + + -- Otherwise the derived type does not constraint its parent type in + -- which case it inherits the parent discriminants. + + else + Typ_Discr := First_Discriminant (Typ); + while Present (Typ_Discr) loop + + -- The position of the current discriminant matches that of the + -- ancestor discriminant. + + if Pos = Discr_Pos then + return Find_Constraint_Value (Typ_Discr); + end if; + + Next_Discriminant (Typ_Discr); + Pos := Pos + 1; + end loop; + end if; + + -- A discriminant must always have a corresponding value. This is + -- either another discriminant, a name, or an expression. + + pragma Assert (False); + + return Empty; + end Find_Discriminant_Value; + + ----------------------- + -- Map_Discriminants -- + ----------------------- + + procedure Map_Discriminants is + Deriv_Chain : constant Elist_Id := Build_Chain; + + Discr : Entity_Id; + Discr_Val : Node_Or_Entity_Id; + + begin + -- Examine each discriminant of parent type Par_Typ and find a proper + -- value for it from the point of view of derived type Deriv_Typ. + + if Has_Discriminants (Par_Typ) then + Discr := First_Discriminant (Par_Typ); + while Present (Discr) loop + Discr_Val := + Find_Discriminant_Value + (Discr => Discr, + Typ_Elmt => First_Elmt (Deriv_Chain)); + + -- Create a mapping of the form: + + -- parent type discriminant -> value + + Type_Map.Set (Discr, Discr_Val); + + Next_Discriminant (Discr); + end loop; + end if; + end Map_Discriminants; + + -------------------- + -- Map_Primitives -- + -------------------- + + procedure Map_Primitives is + Deriv_Prim : Entity_Id; + Par_Prim : Entity_Id; + Par_Prims : Elist_Id; + Prim_Elmt : Elmt_Id; + + begin + -- Inspect the primitives of the derived type and determine whether + -- they relate to the primitives of the parent type. If there is a + -- meaningful relation, create a mapping of the form: + + -- parent type primitive -> derived type primitive + + if Present (Direct_Primitive_Operations (Deriv_Typ)) then + Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ)); + while Present (Prim_Elmt) loop + Deriv_Prim := Node (Prim_Elmt); + + if Is_Subprogram (Deriv_Prim) + and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ + then + Add_Primitive (Deriv_Prim); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end if; + + -- If the parent operation is an interface operation, the overriding + -- indicator is not present. Instead, we get from the interface + -- operation the primitive of the current type that implements it. + + if Is_Interface (Par_Typ) then + Par_Prims := Collect_Primitive_Operations (Par_Typ); + + if Present (Par_Prims) then + Prim_Elmt := First_Elmt (Par_Prims); + + while Present (Prim_Elmt) loop + Par_Prim := Node (Prim_Elmt); + Deriv_Prim := + Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim); + + if Present (Deriv_Prim) then + Type_Map.Set (Par_Prim, Deriv_Prim); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end if; + end if; + end Map_Primitives; + + -- Start of processing for Map_Types + + begin + -- Nothing to do if there are no types to work with + + if No (Par_Typ) or else No (Deriv_Typ) then + return; + + -- Nothing to do if the mapping already exists + + elsif Type_Map.Get (Par_Typ) = Deriv_Typ then + return; + + -- Nothing to do if both types are not tagged. Note that untagged types + -- do not have primitive operations and their discriminants are already + -- handled by gigi. + + elsif not Is_Tagged_Type (Par_Typ) + or else not Is_Tagged_Type (Deriv_Typ) + then + return; + end if; + + -- Create a mapping of the form: + + -- parent type -> derived type + + -- to prevent any subsequent attempts to produce the same relations. + + Type_Map.Set (Par_Typ, Deriv_Typ); + + Map_Discriminants; + Map_Primitives; + end Map_Types; + ---------------------------- -- Matching_Standard_Type -- ---------------------------- @@ -9522,6 +9805,280 @@ Scope_Suppress := Svg_Suppress; end Remove_Side_Effects; + ------------------------ + -- Replace_References -- + ------------------------ + + procedure Replace_References + (Expr : Node_Id; + Par_Typ : Entity_Id; + Deriv_Typ : Entity_Id; + Par_Obj : Entity_Id := Empty; + Deriv_Obj : Entity_Id := Empty) + is + function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean; + -- Determine whether node Ref denotes some component of Deriv_Obj + + function Replace_Ref (Ref : Node_Id) return Traverse_Result; + -- Substitute a reference to an entity with the corresponding value + -- stored in table Type_Map. + + ---------------------- + -- Is_Deriv_Obj_Ref -- + ---------------------- + + function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is + Par : constant Node_Id := Parent (Ref); + + begin + -- Detect the folowing selected component form: + + -- Deriv_Obj.(something) + + return + Nkind (Par) = N_Selected_Component + and then Is_Entity_Name (Prefix (Par)) + and then Entity (Prefix (Par)) = Deriv_Obj; + end Is_Deriv_Obj_Ref; + + ----------------- + -- Replace_Ref -- + ----------------- + + function Replace_Ref (Ref : Node_Id) return Traverse_Result is + Context : constant Node_Id := Parent (Ref); + Loc : constant Source_Ptr := Sloc (Ref); + Ref_Id : Entity_Id; + Result : Traverse_Result; + + New_Ref : Node_Id; + -- The new reference which is intended to substitute the old one + + Old_Ref : Node_Id; + -- The reference designated for replacement. In certain cases this + -- may be a node other than Ref. + + Val : Node_Or_Entity_Id; + -- The corresponding value of Ref from the type map + + begin + -- Assume that the input reference is to be replaced and that the + -- traversal should examine the children of the reference. + + Old_Ref := Ref; + Result := OK; + + -- The input denotes a meaningful reference + + if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then + Ref_Id := Entity (Ref); + Val := Type_Map.Get (Ref_Id); + + -- The reference has a corresponding value in the type map, a + -- substitution is possible. + + if Present (Val) then + + -- The reference denotes a discriminant + + if Ekind (Ref_Id) = E_Discriminant then + if Nkind (Val) in N_Entity then + + -- The value denotes another discriminant. Replace as + -- follows: + + -- _object.Discr -> _object.Val + + if Ekind (Val) = E_Discriminant then + New_Ref := New_Occurrence_Of (Val, Loc); + + -- Otherwise the value denotes the entity of a name which + -- constraints the discriminant. Replace as follows: + + -- _object.Discr -> Val + + else + pragma Assert (Is_Deriv_Obj_Ref (Old_Ref)); + + New_Ref := New_Occurrence_Of (Val, Loc); + Old_Ref := Parent (Old_Ref); + end if; + + -- Otherwise the value denotes an arbitrary expression which + -- constraints the discriminant. Replace as follows: + + -- _object.Discr -> Val + + else + pragma Assert (Is_Deriv_Obj_Ref (Old_Ref)); + + New_Ref := New_Copy_Tree (Val); + Old_Ref := Parent (Old_Ref); + end if; + + -- Otherwise the reference denotes a primitive. Replace as + -- follows: + + -- Primitive -> Val + + else + pragma Assert (Nkind (Val) in N_Entity); + New_Ref := New_Occurrence_Of (Val, Loc); + end if; + + -- The reference mentions the _object parameter of the parent + -- type's DIC procedure. Replace as follows: + + -- _object -> _object + + elsif Present (Par_Obj) + and then Present (Deriv_Obj) + and then Ref_Id = Par_Obj + then + New_Ref := New_Occurrence_Of (Deriv_Obj, Loc); + + -- The reference to _object acts as an actual parameter in a + -- subprogram call which may be invoking a primitive of the + -- parent type: + + -- Primitive (... _object ...); + + -- The parent type primitive may not be overridden nor + -- inherited when it is declared after the derived type + -- definition: + + -- type Parent is tagged private; + -- type Child is new Parent with private; + -- procedure Primitive (Obj : Parent); + + -- In this scenario the _object parameter is converted to the + -- parent type. + + if Nkind_In (Context, N_Function_Call, + N_Procedure_Call_Statement) + and then No (Type_Map.Get (Entity (Name (Context)))) + then + New_Ref := Convert_To (Par_Typ, New_Ref); + + -- Do not process the generated type conversion because + -- both the parent type and the derived type are in the + -- Type_Map table. This will clobber the type conversion + -- by resetting its subtype mark. + + Result := Skip; + end if; + + -- Otherwise there is nothing to replace + + else + New_Ref := Empty; + end if; + + if Present (New_Ref) then + Rewrite (Old_Ref, New_Ref); + + -- Update the return type when the context of the reference + -- acts as the name of a function call. Note that the update + -- should not be performed when the reference appears as an + -- actual in the call. + + if Nkind (Context) = N_Function_Call + and then Name (Context) = Old_Ref + then + Set_Etype (Context, Etype (Val)); + end if; + end if; + end if; + + -- Reanalyze the reference due to potential replacements + + if Nkind (Old_Ref) in N_Has_Etype then + Set_Analyzed (Old_Ref, False); + end if; + + return Result; + end Replace_Ref; + + procedure Replace_Refs is new Traverse_Proc (Replace_Ref); + + -- Start of processing for Replace_References + + begin + -- Map the attributes of the parent type to the proper corresponding + -- attributes of the derived type. + + Map_Types + (Par_Typ => Par_Typ, + Deriv_Typ => Deriv_Typ); + + -- Inspect the input expression and perform substitutions where + -- necessary. + + Replace_Refs (Expr); + end Replace_References; + + ----------------------------- + -- Replace_Type_References -- + ----------------------------- + + procedure Replace_Type_References + (Expr : Node_Id; + Typ : Entity_Id; + Obj_Id : Entity_Id) + is + procedure Replace_Type_Ref (N : Node_Id); + -- Substitute a single reference of the current instance of type Typ + -- with a reference to Obj_Id. + + ---------------------- + -- Replace_Type_Ref -- + ---------------------- + + procedure Replace_Type_Ref (N : Node_Id) is + Ref : Node_Id; + + begin + -- Decorate the reference to Typ even though it may be rewritten + -- further down. This is done for two reasons: + + -- * ASIS has all necessary semantic information in the original + -- tree. + + -- * Routines which examine properties of the Original_Node have + -- some semantic information. + + if Nkind (N) = N_Identifier then + Set_Entity (N, Typ); + Set_Etype (N, Typ); + + elsif Nkind (N) = N_Selected_Component then + Analyze (Prefix (N)); + Set_Entity (Selector_Name (N), Typ); + Set_Etype (Selector_Name (N), Typ); + end if; + + -- Perform the following substitution: + + -- Typ -> _object + + Ref := Make_Identifier (Sloc (N), Chars (Obj_Id)); + Set_Entity (Ref, Obj_Id); + Set_Etype (Ref, Typ); + + Rewrite (N, Ref); + + Set_Comes_From_Source (N, True); + end Replace_Type_Ref; + + procedure Replace_Type_Refs is + new Replace_Type_References_Generic (Replace_Type_Ref); + + -- Start of processing for Replace_Type_References + + begin + Replace_Type_Refs (Expr, Typ); + end Replace_Type_References; + --------------------------- -- Represented_As_Scalar -- --------------------------- @@ -10965,6 +11522,15 @@ and then Esize (Left_Typ) = Esize (Result_Typ); end Target_Has_Fixed_Ops; + ------------------- + -- Type_Map_Hash -- + ------------------- + + function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is + begin + return Type_Map_Header (Id mod Type_Map_Size); + end Type_Map_Hash; + ------------------------------------------ -- Type_May_Have_Bit_Aligned_Components -- ------------------------------------------ @@ -11016,163 +11582,11 @@ Subp_Id : Entity_Id) is begin - Update_Primitives_Mapping_Of_Types + Map_Types (Par_Typ => Find_Dispatching_Type (Inher_Id), Deriv_Typ => Find_Dispatching_Type (Subp_Id)); end Update_Primitives_Mapping; - ---------------------------------------- - -- Update_Primitives_Mapping_Of_Types -- - ---------------------------------------- - - procedure Update_Primitives_Mapping_Of_Types - (Par_Typ : Entity_Id; - Deriv_Typ : Entity_Id) - is - procedure Add_Primitive (Prim : Entity_Id); - -- Find a primitive in the inheritance/overriding chain starting from - -- Prim whose dispatching type is parent type Par_Typ and add a mapping - -- between the result and primitive Prim. - - ------------------- - -- Add_Primitive -- - ------------------- - - procedure Add_Primitive (Prim : Entity_Id) is - function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id; - -- Return the next ancestor primitive in the inheritance/overriding - -- chain of subprogram Subp. Return Empty if no such primitive is - -- available. - - ------------------------ - -- Ancestor_Primitive -- - ------------------------ - - function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is - Inher_Prim : constant Entity_Id := Alias (Subp); - Over_Prim : constant Entity_Id := Overridden_Operation (Subp); - - begin - -- The current subprogram overrides an ancestor primitive - - if Present (Over_Prim) then - return Over_Prim; - - -- The current subprogram is an internally generated alias of an - -- inherited ancestor primitive. - - elsif Present (Inher_Prim) then - return Inher_Prim; - - -- Otherwise the current subprogram is the root of the inheritance - -- or overriding chain. - - else - return Empty; - end if; - end Ancestor_Primitive; - - -- Local variables - - Par_Prim : Entity_Id; - - -- Start of processing for Add_Primitive - - begin - -- Inspect both the inheritance chain through the Alias attribute and - -- the overriding chain through the Overridden_Operation looking for - -- an ancestor primitive with the appropriate dispatching type. - - Par_Prim := Prim; - while Present (Par_Prim) loop - exit when Find_Dispatching_Type (Par_Prim) = Par_Typ; - Par_Prim := Ancestor_Primitive (Par_Prim); - end loop; - - -- Create a mapping of the form: - - -- Parent type primitive -> derived type primitive - - if Present (Par_Prim) then - Primitives_Mapping.Set (Par_Prim, Prim); - end if; - end Add_Primitive; - - -- Local variables - - Deriv_Prim : Entity_Id; - Par_Prim : Entity_Id; - Par_Prims : Elist_Id; - Prim_Elmt : Elmt_Id; - - -- Start of processing for Update_Primitives_Mapping_Of_Types - - begin - -- Nothing to do if there are no types to work with - - if No (Par_Typ) or else No (Deriv_Typ) then - return; - - -- Nothing to do if the mapping already exists - - elsif Primitives_Mapping.Get (Par_Typ) = Deriv_Typ then - return; - end if; - - -- Create a mapping of the form: - - -- Parent type -> Derived type - - -- to prevent any subsequent attempts to produce the same relations. - - Primitives_Mapping.Set (Par_Typ, Deriv_Typ); - - -- Inspect the primitives of the derived type and determine whether they - -- relate to the primitives of the parent type. If there is a meaningful - -- relation, create a mapping of the form: - - -- Parent type primitive -> Derived type primitive - - if Present (Direct_Primitive_Operations (Deriv_Typ)) then - Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ)); - while Present (Prim_Elmt) loop - Deriv_Prim := Node (Prim_Elmt); - - if Is_Subprogram (Deriv_Prim) - and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ - then - Add_Primitive (Deriv_Prim); - end if; - - Next_Elmt (Prim_Elmt); - end loop; - end if; - - -- If the parent operation is an interface operation, the overriding - -- indicator is not present. Instead, we get from the interface - -- operation the primitive of the current type that implements it. - - if Is_Interface (Par_Typ) then - Par_Prims := Collect_Primitive_Operations (Par_Typ); - - if Present (Par_Prims) then - Prim_Elmt := First_Elmt (Par_Prims); - - while Present (Prim_Elmt) loop - Par_Prim := Node (Prim_Elmt); - Deriv_Prim := - Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim); - - if Present (Deriv_Prim) then - Primitives_Mapping.Set (Par_Prim, Deriv_Prim); - end if; - - Next_Elmt (Prim_Elmt); - end loop; - end if; - end if; - end Update_Primitives_Mapping_Of_Types; - ---------------------------------- -- Within_Case_Or_If_Expression -- ---------------------------------- Index: exp_util.ads =================================================================== --- exp_util.ads (revision 247140) +++ exp_util.ads (working copy) @@ -278,9 +278,13 @@ -- Build a call to the DIC procedure of type Typ with Obj_Id as the actual -- parameter. - procedure Build_DIC_Procedure_Body (Typ : Entity_Id); + procedure Build_DIC_Procedure_Body + (Typ : Entity_Id; + For_Freeze : Boolean := False); -- Create the body of the procedure which verifies the assertion expression - -- of pragma Default_Initial_Condition at run time. + -- of pragma Default_Initial_Condition at run time. Flag For_Freeze should + -- be set when the body is construction as part of the freezing actions for + -- Typ. procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id); -- Create the declaration of the procedure which verifies the assertion @@ -870,6 +874,19 @@ -- wide type. Set Related_Id to request an external name for the subtype -- rather than an internal temporary. + procedure Map_Types (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id); + -- Establish the following mapping between the attributes of tagged parent + -- type Par_Type and tagged derived type Deriv_Typ. + -- + -- * Map each discriminant of type Par_Typ to the corresponding + -- discriminant of type Deriv_Typ. + + -- * Map each primitive operation of type Par_Typ to the corresponding + -- primitive of type Deriv_Typ. + -- + -- The mapping Par_Typ -> Deriv_Typ is also added to the table in order to + -- prevent subsequent attempts of the same mapping. + function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id; -- Given a scalar subtype Typ, returns a matching type in standard that -- has the same object size value. For example, a 16 bit signed type will @@ -995,6 +1012,37 @@ -- renaming cannot be elaborated without evaluating the subexpression, so -- gigi would resort to method 1) or 3) under the hood for them. + procedure Replace_References + (Expr : Node_Id; + Par_Typ : Entity_Id; + Deriv_Typ : Entity_Id; + Par_Obj : Entity_Id := Empty; + Deriv_Obj : Entity_Id := Empty); + -- Expr denotes an arbitrary expression. Par_Typ is a tagged parent type + -- in a type hierarchy. Deriv_Typ is a tagged type derived from Par_Typ + -- with optional ancestors in between. Par_Obj is a formal parameter + -- which emulates the current instance of Par_Typ. Deriv_Obj is a formal + -- parameter which emulates the current instance of Deriv_Typ. Perform the + -- following substitutions in Expr: + -- + -- * Replace a reference to Par_Obj with a reference to Deriv_Obj + -- + -- * Replace a reference to a discriminant of Par_Typ with a suitable + -- value from the point of view of Deriv_Typ. + -- + -- * Replace a call to an overridden primitive of Par_Typ with a call to + -- an overriding primitive of Deriv_Typ. + -- + -- * Replace a call to an inherited primitive of Par_Type with a call to + -- the internally-generated inherited primitive of Deriv_Typ. + + procedure Replace_Type_References + (Expr : Node_Id; + Typ : Entity_Id; + Obj_Id : Entity_Id); + -- Substitute all references of the current instance of type Typ with + -- references to formal parameter Obj_Id within expression Expr. + function Represented_As_Scalar (T : Entity_Id) return Boolean; -- Returns True iff the implementation of this type in code generation -- terms is scalar. This is true for scalars in the Ada sense, and for @@ -1103,12 +1151,6 @@ -- when elaborating a contract for a subprogram, and when freezing a type -- extension to verify legality rules on inherited conditions. - procedure Update_Primitives_Mapping_Of_Types - (Par_Typ : Entity_Id; - Deriv_Typ : Entity_Id); - -- Map the primitive operations of parent type Par_Typ to the corresponding - -- primitives of derived type Deriv_Typ. - function Within_Case_Or_If_Expression (N : Node_Id) return Boolean; -- Determine whether arbitrary node N is within a case or an if expression Index: sem_ch7.adb =================================================================== --- sem_ch7.adb (revision 247135) +++ sem_ch7.adb (working copy) @@ -2568,6 +2568,11 @@ Propagate_DIC_Attributes (Full, From_Typ => Full_Base); Propagate_DIC_Attributes (Full_Base, From_Typ => Full); + -- Propagate Default_Initial_Condition-related attributes from the + -- full view to the private view. + + Propagate_DIC_Attributes (Priv, From_Typ => Full); + -- Propagate invariant-related attributes from the base type of the -- full view to the full view and vice versa. This may seem strange, -- but is necessary depending on which type triggered the generation Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 247140) +++ sem_prag.adb (working copy) @@ -13828,6 +13828,7 @@ Check_No_Identifiers; Check_At_Most_N_Arguments (1); + Typ := Empty; Stmt := Prev (N); while Present (Stmt) loop @@ -13869,6 +13870,14 @@ Stmt := Prev (Stmt); end loop; + -- The pragma does not apply to a legal construct, issue an error + -- and stop the analysis. + + if No (Typ) then + Pragma_Misplaced; + return; + end if; + -- A pragma that applies to a Ghost entity becomes Ghost for the -- purposes of legality checks and removal of ignored Ghost code.