From patchwork Mon May 15 09:42:44 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: 94030 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:b0ea:0:b0:3b6:4342:cba0 with SMTP id b10csp6791413vqo; Mon, 15 May 2023 02:46:21 -0700 (PDT) X-Google-Smtp-Source: ACHHUZ5XVYQl5K1XESuztpgcGHGSzJ2jmcdoMeRv9C3ktgzidxEricLd/s9lUiQaCSUaNfWcom3G X-Received: by 2002:aa7:d549:0:b0:504:8905:5218 with SMTP id u9-20020aa7d549000000b0050489055218mr28506811edr.1.1684143981416; Mon, 15 May 2023 02:46:21 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1684143981; cv=none; d=google.com; s=arc-20160816; b=rvsAX7sLlVbVBRzP3s+pg3Qbc2QguCfBCk601+ZLaYaKNdM7faW7Jh5XAxmS+Z1CLr 2SGRvDaqD9WOP0Mu2n1E9ohp30JjBMuQvRo9E3pUIgU9BD4X13nc8bbNSGD/L/BMISA8 iYXU7GW2KrgGlmG+10wkhizWRl+sn7zryPcLLwkAA1izuH9wyRjpTFhWoUCf9bfm9C0G fipBAUnKqrFcMZbvwS9tzqdLKPJxcK2+wQuvHf844/yo/5Jp9aSqgN+GTKeH6ISvdk8W gSHqYbyoRcfeGDV/6flBKrCeejhMpwismAa9+stTheQg6NnvYkkCC58oc+rxjydcwqXg ywVw== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:reply-to:from:list-subscribe:list-help:list-post :list-archive:list-unsubscribe:list-id:precedence :content-transfer-encoding:mime-version:message-id:date:subject:cc :to:dmarc-filter:delivered-to:dkim-signature:dkim-filter; bh=IwLDbiSLFV+8f0471qNa7nZ4RB1D4FlM+aDyUI1jSZw=; b=0TKKKs7FsH2LmSAlfO1H+sJ2vn/kdubqtSh9S47T6XFjkMi7dWPPnEi+scf5AJ4JVD Y+z9gK6yf+LGTgfIyZ/hEUJpoE2Nck+blQ/Xp2n4/AlOJprkbVcrMgJt53jTD7Hyl4ac 4z7vmpyD6/jFkDjdQAK2G8mUYIF1jiw/SPNzVddhMCEdnCradkH5fq+DfQsXnlwS//Zs CZ5EOUS6/gzJLgF8P82rlD5qoVWyQdxb7/4spUxMlheOEIkMgyJB3LNzf54zVef77igu gG40R/IyAPJ1KDToiOo/rDme/3b1GBrxKsmxIEM0oMDSiap/n/1f/jnjz9jBbUcsLbaY JGTw== ARC-Authentication-Results: i=1; mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=CCA6wmRi; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from sourceware.org (ip-8-43-85-97.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id f12-20020aa7d84c000000b0050bd5e5d7a8si10612910eds.223.2023.05.15.02.46.21 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 15 May 2023 02:46:21 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org header.s=default header.b=CCA6wmRi; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=NONE dis=NONE) header.from=gnu.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id D4C733836F2E for ; Mon, 15 May 2023 09:44:28 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org D4C733836F2E DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1684143868; bh=IwLDbiSLFV+8f0471qNa7nZ4RB1D4FlM+aDyUI1jSZw=; h=To:Cc:Subject:Date:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:List-Subscribe:From:Reply-To:From; b=CCA6wmRi15jM0KGaMwi7Dhw7f6cKkXnxDdjUWes9OOzaIoYP5rJWT0A5RMVaOjVTt XlyjCla2SE0hJp9/6siA5nG7EgLenthnZdLL0w9dXO2yDPVn2cSYrW/tF7bQLjQzvH yS4Rl9ZH40uYe6wG1MYALpFP9iMBGHfy8vilRlRs= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x330.google.com (mail-wm1-x330.google.com [IPv6:2a00:1450:4864:20::330]) by sourceware.org (Postfix) with ESMTPS id A4FC3385416D for ; Mon, 15 May 2023 09:42:47 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org A4FC3385416D Received: by mail-wm1-x330.google.com with SMTP id 5b1f17b1804b1-3f4c6c4b51eso54635205e9.2 for ; Mon, 15 May 2023 02:42:47 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1684143766; x=1686735766; 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=IwLDbiSLFV+8f0471qNa7nZ4RB1D4FlM+aDyUI1jSZw=; b=hp/HJg3R1BP3gl9inC2NdKjF3fuTSKgnrgpkDW4/TSNQ5QuJfvXgz7tbqQTnXR1Iav lRIFzr1uJNX+Y189DVw0/M98Xd7UH6WhqMTzyC95PjDEFGBlTuQ8R2M7Ne+o6RkPnQFc MKaKb8ALJUs9DFKdiu98lumYA3K3YyiqXh5URoyv1xL1UM9f0L8DFITmqc84AkfjCAqK Z3FtA7PRp2sr8AjEg88CT2S23LmXCKtNsmQccyv3/7dgDHPec/TCVXcE3H9LYgFFvF4Y uM/IWRMHdH4UeS7ozH/YK2PwgUlPwQuYizAdDCK403YfKTRS3CTKtqPnoyy4vMUqUEhA FuOg== X-Gm-Message-State: AC+VfDwH4qx0RfBNLpu53ZqFMz7+InfVfXWtZUylwd4z8XE/BbMPDQhU JgK9R9BNsqOOMS4XPd0Uyh/+zoqZLwmPVVfAoZe4uA== X-Received: by 2002:a7b:ca51:0:b0:3f4:2174:b29d with SMTP id m17-20020a7bca51000000b003f42174b29dmr20914761wml.1.1684143766388; Mon, 15 May 2023 02:42:46 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id x10-20020adfffca000000b002e61e002943sm31732945wrs.116.2023.05.15.02.42.45 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Mon, 15 May 2023 02:42:45 -0700 (PDT) To: gcc-patches@gcc.gnu.org Cc: Eric Botcazou Subject: [COMMITTED] ada: Fix invalid JSON for extended variant record with -gnatRj Date: Mon, 15 May 2023 11:42:44 +0200 Message-Id: <20230515094244.1407771-1-poulhies@adacore.com> X-Mailer: git-send-email 2.40.0 MIME-Version: 1.0 X-Spam-Status: No, score=-13.4 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, 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.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-Patchwork-Original-From: =?utf-8?q?Marc_Poulhi=C3=A8s_via_Gcc-patches?= From: =?utf-8?q?Marc_Poulhi=C3=A8s?= Reply-To: =?utf-8?q?Marc_Poulhi=C3=A8s?= Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: =?utf-8?q?INBOX?= X-GMAIL-THRID: =?utf-8?q?1765952959604690993?= X-GMAIL-MSGID: =?utf-8?q?1765952959604690993?= From: Eric Botcazou This fixes the output of -gnatRj for an extension of a tagged type which has a variant part and also deals with the case where the parent type is private with unknown discriminants. gcc/ada/ * repinfo.ads (JSON output format): Document special case of Present member of a Variant object. * repinfo.adb (List_Structural_Record_Layout): Change the type of Ext_Level parameter to Integer. Restrict the first recursion with increasing levels to the fixed part and implement a second recursion with decreasing levels for the variant part. Deal with an extension of a type with unknown discriminants. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/repinfo.adb | 56 ++++++++++++++++++++++++++++++++++++++------- gcc/ada/repinfo.ads | 5 +++- 2 files changed, 52 insertions(+), 9 deletions(-) diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index e39856b7a82..6a30bc7898b 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -991,12 +991,17 @@ package body Repinfo is procedure List_Structural_Record_Layout (Ent : Entity_Id; Ext_Ent : Entity_Id; - Ext_Level : Nat := 0; + Ext_Level : Integer := 0; Variant : Node_Id := Empty; Indent : Natural := 0); -- 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. + -- Ext_Level is the number of successive extensions between them, + -- with the convention that this number is positive when we are + -- called from the fixed part of Ext_Ent and negative when we are + -- called from the variant part of Ext_Ent, if any; this is needed + -- because the fixed and variant parts of a parent of an extension + -- cannot be listed contiguously from this extension's viewpoint. -- If Variant is present, it's for a variant in the variant part -- instead of the common part of Ent. Indent is the indentation. @@ -1362,7 +1367,7 @@ package body Repinfo is procedure List_Structural_Record_Layout (Ent : Entity_Id; Ext_Ent : Entity_Id; - Ext_Level : Nat := 0; + Ext_Level : Integer := 0; Variant : Node_Id := Empty; Indent : Natural := 0) is @@ -1381,7 +1386,16 @@ package body Repinfo is Derived_Disc : Entity_Id; begin - Derived_Disc := First_Discriminant (Ext_Ent); + -- Deal with an extension of a type with unknown discriminants + + if Has_Unknown_Discriminants (Ext_Ent) + and then Present (Underlying_Record_View (Ext_Ent)) + then + Derived_Disc := + First_Discriminant (Underlying_Record_View (Ext_Ent)); + else + Derived_Disc := First_Discriminant (Ext_Ent); + end if; -- Loop over the discriminants of the extension @@ -1418,6 +1432,7 @@ package body Repinfo is Comp : Node_Id; Comp_List : Node_Id; First : Boolean := True; + Parent_Ent : Entity_Id := Empty; Var : Node_Id; -- Start of processing for List_Structural_Record_Layout @@ -1471,8 +1486,11 @@ package body Repinfo is raise Not_In_Extended_Main; end if; - List_Structural_Record_Layout - (Parent_Type, Ext_Ent, Ext_Level + 1); + Parent_Ent := Parent_Type; + if Ext_Level >= 0 then + List_Structural_Record_Layout + (Parent_Ent, Ext_Ent, Ext_Level + 1); + end if; end if; First := False; @@ -1488,6 +1506,7 @@ package body Repinfo is if Has_Discriminants (Ent) and then not Is_Unchecked_Union (Ent) + and then Ext_Level >= 0 then Disc := First_Discriminant (Ent); while Present (Disc) loop @@ -1509,7 +1528,12 @@ package body Repinfo is if No (Listed_Disc) then goto Continue_Disc; + + elsif not Known_Normalized_Position (Listed_Disc) then + Listed_Disc := + Original_Record_Component (Listed_Disc); end if; + else Listed_Disc := Disc; end if; @@ -1543,7 +1567,9 @@ package body Repinfo is -- Now deal with the regular components, if any - if Present (Component_Items (Comp_List)) then + if Present (Component_Items (Comp_List)) + and then (Present (Variant) or else Ext_Level >= 0) + then Comp := First_Non_Pragma (Component_Items (Comp_List)); while Present (Comp) loop @@ -1571,6 +1597,20 @@ package body Repinfo is end loop; end if; + -- Stop there if we are called from the fixed part of Ext_Ent, + -- we'll do the variant part when called from its variant part. + + if Ext_Level > 0 then + return; + end if; + + -- List the layout of the variant part of the parent, if any + + if Present (Parent_Ent) then + List_Structural_Record_Layout + (Parent_Ent, Ext_Ent, Ext_Level - 1); + end if; + -- We are done if there is no variant part if No (Variant_Part (Comp_List)) then @@ -1582,7 +1622,7 @@ package body Repinfo is Write_Line (" ],"); Spaces (Indent); Write_Str (" """); - for J in 1 .. Ext_Level loop + for J in Ext_Level .. -1 loop Write_Str ("parent_"); end loop; Write_Str ("variant"" : ["); diff --git a/gcc/ada/repinfo.ads b/gcc/ada/repinfo.ads index 4787b97e29c..db9919a0e2e 100644 --- a/gcc/ada/repinfo.ads +++ b/gcc/ada/repinfo.ads @@ -244,7 +244,10 @@ package Repinfo is -- "present" and "record" are present for every variant. The value of -- "present" is a boolean expression that evaluates to true when the -- components of the variant are contained in the record type and to - -- false when they are not. The value of "record" is the list of + -- false when they are not, with the exception that a value of 1 means + -- that the components of the variant are contained in the record type + -- only when the "present" member of all the preceding variants in the + -- variant list evaluates to false. The value of "record" is the list of -- components in the variant. "variant" is present only if the variant -- itself has a variant part and its value is the list of (sub)variants.