From patchwork Fri Jul 9 12:38:21 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1503105 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (2048-bit key; unprotected) header.d=adacore-com.20150623.gappssmtp.com header.i=@adacore-com.20150623.gappssmtp.com header.a=rsa-sha256 header.s=20150623 header.b=bbQ5ZHmm; dkim-atps=neutral Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4GLtGS0Hczz9sRN for ; Fri, 9 Jul 2021 22:47:12 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 78653398703B for ; Fri, 9 Jul 2021 12:47:09 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-lj1-x22f.google.com (mail-lj1-x22f.google.com [IPv6:2a00:1450:4864:20::22f]) by sourceware.org (Postfix) with ESMTPS id 2424C3987018 for ; Fri, 9 Jul 2021 12:38:24 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 2424C3987018 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-lj1-x22f.google.com with SMTP id q4so7779158ljp.13 for ; Fri, 09 Jul 2021 05:38:24 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore-com.20150623.gappssmtp.com; s=20150623; h=date:from:to:cc:subject:message-id:mime-version:content-disposition; bh=LULQhbBnapaS+OOfC2PO5Pyaj4pd87kcTFNInr+bUdk=; b=bbQ5ZHmmpMn2he8rnskKMOWuziPNdXzXFeWhI7Rka+Y+c0VXbhQT754MIU6iT9hjO6 PjZUpw/McbdBRStQHDHVk2+Auj74viBbeJVlaz0wP/OBAYX0gulzjbuhVBS7DaaWpy6k UeLJuHWe8194qKtNLyv1rRhDSUymFNaWxmDFyMoLaJomV6wWeJPl2wcYjGp6uI23n7V3 hNkBue17TOc1f3kFVpK+DuNaIi4aFjpH7cULcKbA1jqkAwOu9ScsiOe9vu5h03XFfay+ gDBlmnrhVfhLjwAFxn6WRyqzL/jNa+ym6CftCn8eMHDce7WkH4qrOmlkaFifLuPlLRBq m2vA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:date:from:to:cc:subject:message-id:mime-version :content-disposition; bh=LULQhbBnapaS+OOfC2PO5Pyaj4pd87kcTFNInr+bUdk=; b=olLWreUxo8xF+1MXgpuD1Fv5k6Qu8R2LkVta6Xjs+uuzouk9W9mvD06RumqATaIXY5 3jNIMsp50nNyF5m5+BCfjmsRjH0e/K2itK8cVUawAjeGr0rIYLFioazvLCtCmE6iqc+t E6yqMU57swFbBsm6+eZIoIxGBeeF7IQIQ2ru9FCTW6Y3sTY8AaPeMfFkdhf85NNj8g+p 0bGsxtVoRaQ7BW38rTqXnNwueR+CGYKh/6JTZo5I0Jl+K7aiI+AqviG0nGxAZVFnEK1j kHZG1bFnhsxcjNB/rfRbSMbhl9vXYX2W3pCxH7PY0UmejOyIfFu6NckyWsAq0ssM9Fc8 qzkA== X-Gm-Message-State: AOAM533GFxgBrQl0tILjf9vANniQmbNUfvK0YjDoyaR9iXhv/+jdThaS +CF6GDqLLFi2/RCIcJlTlCmavXSdi7OR0Q== X-Google-Smtp-Source: ABdhPJxu4wYTwsoVBgckC0dFGWcD2ybD1ko/i0Nn8yzXJ+kldvrAlm6ZONZWWgzxFY0u3sECb9OUCg== X-Received: by 2002:a2e:9f10:: with SMTP id u16mr17469026ljk.139.1625834302981; Fri, 09 Jul 2021 05:38:22 -0700 (PDT) Received: from adacore.com ([2a02:2ab8:224:2ce:72b5:e8ff:feef:ee60]) by smtp.gmail.com with ESMTPSA id c21sm455950lfv.199.2021.07.09.05.38.21 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Fri, 09 Jul 2021 05:38:22 -0700 (PDT) Date: Fri, 9 Jul 2021 12:38:21 +0000 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] Fix invalid JSON for derived variant record with -gnatRj Message-ID: <20210709123821.GA3875762@adacore.com> MIME-Version: 1.0 Content-Disposition: inline X-Spam-Status: No, score=-13.0 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, WEIRD_QUOTING autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: Eric Botcazou Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" This prevents the output of -gnatRj from containing several "variant" fields for an extension with a variant part of a tagged type with a variant part. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * repinfo.ads (JSON output format): Document adjusted key name. * repinfo.adb (List_Record_Layout): Use Original_Record_Component if the normalized position of the component is not known. (List_Structural_Record_Layout): Rename Outer_Ent parameter into Ext_End and add Ext_Level parameter. In an extension, if the parent subtype has static discriminants, call List_Record_Layout on it. Output "parent_" prefixes before "variant" according to Ext_Level. Adjust recursive calls throughout the procedure. diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -963,10 +963,15 @@ package body Repinfo is procedure List_Structural_Record_Layout (Ent : Entity_Id; - Outer_Ent : Entity_Id; + Ext_Ent : Entity_Id; + Ext_Level : Nat := 0; Variant : Node_Id := Empty; Indent : Natural := 0); - -- Internal recursive procedure to display the structural layout + -- Internal recursive procedure to display the structural layout. + -- If Ext_Ent is not equal to Ent, it is an extension of Ent and + -- Ext_Level is the number of successive extensions between them. + -- If Variant is present, it's for a variant in the variant part + -- instead of the common part of Ent. Indent is the indentation. Incomplete_Layout : exception; -- Exception raised if the layout is incomplete in -gnatc mode @@ -1319,7 +1324,12 @@ package body Repinfo is end if; end if; - List_Component_Layout (Comp, + -- The Parent_Subtype in an extension is not back-annotated + + List_Component_Layout ( + (if Known_Normalized_Position (Comp) + then Comp + else Original_Record_Component (Comp)), Starting_Position, Starting_First_Bit, Prefix); end; @@ -1334,15 +1344,16 @@ package body Repinfo is procedure List_Structural_Record_Layout (Ent : Entity_Id; - Outer_Ent : Entity_Id; + Ext_Ent : Entity_Id; + Ext_Level : Nat := 0; Variant : Node_Id := Empty; Indent : Natural := 0) is function Derived_Discriminant (Disc : Entity_Id) return Entity_Id; - -- This function assumes that Outer_Ent is an extension of Ent. + -- This function assumes that Ext_Ent is an extension of Ent. -- Disc is a discriminant of Ent that does not itself constrain a -- discriminant of the parent type of Ent. Return the discriminant - -- of Outer_Ent that ultimately constrains Disc, if any. + -- of Ext_Ent that ultimately constrains Disc, if any. ---------------------------- -- Derived_Discriminant -- @@ -1353,7 +1364,7 @@ package body Repinfo is Derived_Disc : Entity_Id; begin - Derived_Disc := First_Discriminant (Outer_Ent); + Derived_Disc := First_Discriminant (Ext_Ent); -- Loop over the discriminants of the extension @@ -1380,7 +1391,7 @@ package body Repinfo is Next_Discriminant (Derived_Disc); end loop; - -- Disc is not constrained by a discriminant of Outer_Ent + -- Disc is not constrained by a discriminant of Ext_Ent return Empty; end Derived_Discriminant; @@ -1432,12 +1443,21 @@ package body Repinfo is pragma Assert (Present (Parent_Type)); end if; - Parent_Type := Base_Type (Parent_Type); - if not In_Extended_Main_Source_Unit (Parent_Type) then - raise Not_In_Extended_Main; + -- Do not list variants if one of them has been selected + + if Has_Static_Discriminants (Parent_Type) then + List_Record_Layout (Parent_Type); + + else + Parent_Type := Base_Type (Parent_Type); + if not In_Extended_Main_Source_Unit (Parent_Type) then + raise Not_In_Extended_Main; + end if; + + List_Structural_Record_Layout + (Parent_Type, Ext_Ent, Ext_Level + 1); end if; - List_Structural_Record_Layout (Parent_Type, Outer_Ent); First := False; if Present (Record_Extension_Part (Definition)) then @@ -1467,7 +1487,7 @@ package body Repinfo is -- If this is the parent type of an extension, retrieve -- the derived discriminant from the extension, if any. - if Ent /= Outer_Ent then + if Ent /= Ext_Ent then Listed_Disc := Derived_Discriminant (Disc); if No (Listed_Disc) then @@ -1544,7 +1564,11 @@ package body Repinfo is Spaces (Indent); Write_Line (" ],"); Spaces (Indent); - Write_Str (" ""variant"" : ["); + Write_Str (" """); + for J in 1 .. Ext_Level loop + Write_Str ("parent_"); + end loop; + Write_Str ("variant"" : ["); -- Otherwise we recurse on each variant @@ -1567,7 +1591,8 @@ package body Repinfo is Spaces (Indent); Write_Str (" ""record"": ["); - List_Structural_Record_Layout (Ent, Outer_Ent, Var, Indent + 4); + List_Structural_Record_Layout + (Ent, Ext_Ent, Ext_Level, Var, Indent + 4); Write_Eol; Spaces (Indent); diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -189,7 +189,7 @@ package Repinfo is -- "name" : string -- "location" : string -- "record" : array of components - -- "variant" : array of variants + -- "[parent_]*variant" : array of variants -- "formal" : array of formal parameters -- "mechanism" : string -- "Size" : numerical expression @@ -209,8 +209,9 @@ package Repinfo is -- fully qualified Ada name. The value of "location" is the expanded -- chain of instantiation locations that contains the entity. -- "record" is present for every record type and its value is the list of - -- components. "variant" is present only if the record type has a variant - -- part and its value is the list of variants. + -- components. "[parent_]*variant" is present only if the record type, or + -- one of its ancestors (parent, grand-parent, etc) if it's an extension, + -- has a variant part and its value is the list of variants. -- "formal" is present for every subprogram and entry, and its value is -- the list of formal parameters. "mechanism" is present for functions -- only and its value is the return mechanim.