From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wr1-x436.google.com (mail-wr1-x436.google.com [IPv6:2a00:1450:4864:20::436]) by sourceware.org (Postfix) with ESMTPS id 75651385AC19 for ; Tue, 6 Sep 2022 07:15:42 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 75651385AC19 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com Received: by mail-wr1-x436.google.com with SMTP id b16so14015871wru.7 for ; Tue, 06 Sep 2022 00:15:42 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; h=content-disposition:mime-version:message-id:subject:cc:to:from:date :from:to:cc:subject:date; bh=5zLLZ0IjtQqq/NHSPz3LktY30b3kyOqgf/FmEutEYFQ=; b=E7eA8zbOoZlVm2K5AOT6zKxG1OEADf+lNYC0HVlUybpHWNB0FBB3XG9WMFa2D/E7MM yQbkiIBcuxygJcK7aszb1g/qm/daHo+mzR3YVvUXYCyzs+Hp0uuEAYYYbX/1i0qcjIXL KDoQSBs4iNXXweo76aWIxhM9DNSp0z47SfVCjXrlMDDt/r6+5JkAOorAkPs4l4FdXdlv aFCVp2WioXBmTYy37U6i8zo1ZvI/1hD43ix0HcBdBaW2oCa8tYd8b1+KPFMbyIrHiIdl wJOwD+fKUI0bPnwsfMG3VH+KFM5Op2b8/QWBBp2B+K5UlHeMfScuO5QLmGRyZkAi5OPf T4OQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-disposition:mime-version:message-id:subject:cc:to:from:date :x-gm-message-state:from:to:cc:subject:date; bh=5zLLZ0IjtQqq/NHSPz3LktY30b3kyOqgf/FmEutEYFQ=; b=zwHmB0yhLyTWgWBRuSPiJI6i1ht0pXJQo3titXWm5D5MFMz6yKijFllyGyjwooe4Zp 9Poup4+VaR8vYDxfdZs6xBaLcHgcPvmol6foYroATRy1ascH4aSoQXvK+fk2/7kupUn0 ak6gMeYhMN3ghQrXGYOndu6CcmL1T9XH4FfA+MZz770qUE0LYAPnr7VVGDuTmtBHUyIH g4YAkJmyMWRkboQ+LLDak++iXSLUv6FnubCo5S/PTEgKzFeAg49/q5AnsPdkAemJfSKz cG8RlTarByVKa+pinBp6senp5+9PmNeVjRUvznGlDJjGq3ukOiNiM5M+KzII3VBBWxoE 8L3g== X-Gm-Message-State: ACgBeo20L9bAe+eEiLq20PFWUVd3yPLZ0Jp0HrJmb4mCOZsRVBe2Xh2j P8u77PXMOMZuUQ0qoGGFxRAerEU6ipQwKA== X-Google-Smtp-Source: AA6agR5GDyxSNJDPMF0LNWqYQJgMtvSkCltSEnI/otwayoH3J9hGx0RZMNu9KWgVX9YXlSKbyO5Fag== X-Received: by 2002:adf:ed81:0:b0:226:a509:14b6 with SMTP id c1-20020adfed81000000b00226a50914b6mr26095455wro.150.1662448541253; Tue, 06 Sep 2022 00:15:41 -0700 (PDT) Received: from poulhies-Precision-5550 (static-176-191-105-132.ftth.abo.bbox.fr. [176.191.105.132]) by smtp.gmail.com with ESMTPSA id z7-20020a05600c0a0700b003a5c1e916c8sm35754568wmp.1.2022.09.06.00.15.40 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Sep 2022 00:15:40 -0700 (PDT) Date: Tue, 6 Sep 2022 09:15:40 +0200 From: Marc =?iso-8859-1?Q?Poulhi=E8s?= To: gcc-patches@gcc.gnu.org Cc: Piotr Trojanek Subject: [Ada] Improve detection of illegal Iterable aspects Message-ID: <20220906071540.GA1280186@poulhies-Precision-5550> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="k+w/mQv8wyuph6w0" Content-Disposition: inline X-Spam-Status: No, score=-12.8 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 List-Id: --k+w/mQv8wyuph6w0 Content-Type: text/plain; charset=us-ascii Content-Disposition: inline Handling of aspect Iterable was lacking guards against illegal code, so the compiler either crashed or emitted cryptic errors while expanding loops that rely on this aspect. Tested on x86_64-pc-linux-gnu, committed on trunk gcc/ada/ * doc/gnat_rm/implementation_defined_aspects.rst (Aspect Iterable): Include Last and Previous primitives in syntactic and semantic description. * exp_attr.adb (Expand_N_Attribute_Reference): Don't expect attributes like Iterable that can only appear in attribute definition clauses. * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Prevent crash on non-aggregate Iterable attribute; improve basic diagnosis of attribute values. (Resolve_Iterable_Operation): Improve checks for illegal primitives in aspect Iterable, e.g. with wrong number of formal parameters. (Validate_Iterable_Aspect): Prevent crashes on syntactically illegal aspect expression. * sem_util.adb (Get_Cursor_Type): Fix style. * gnat_ugn.texi, gnat_rm.texi: Regenerate. --k+w/mQv8wyuph6w0 Content-Type: text/x-diff; charset=us-ascii Content-Disposition: attachment; filename="patch.diff" diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst --- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst @@ -317,23 +317,27 @@ The following is a typical example of use: type List is private with Iterable => (First => First_Cursor, Next => Advance, - Has_Element => Cursor_Has_Element, - [Element => Get_Element]); + Has_Element => Cursor_Has_Element + [,Element => Get_Element] + [,Last => Last_Cursor] + [,Previous => Retreat]); -* The value denoted by ``First`` must denote a primitive operation of the - container type that returns a ``Cursor``, which must a be a type declared in +* The values of ``First`` and ``Last`` are primitive operations of the + container type that return a ``Cursor``, which must be a type declared in the container package or visible from it. For example: .. code-block:: ada function First_Cursor (Cont : Container) return Cursor; + function Last_Cursor (Cont : Container) return Cursor; -* The value of ``Next`` is a primitive operation of the container type that takes - both a container and a cursor and yields a cursor. For example: +* The values of ``Next`` and ``Previous`` are primitive operations of the container type that take + both a container and a cursor and yield a cursor. For example: .. code-block:: ada function Advance (Cont : Container; Position : Cursor) return Cursor; + function Retreat (Cont : Container; Position : Cursor) return Cursor; * The value of ``Has_Element`` is a primitive operation of the container type that takes both a container and a cursor and yields a boolean. For example: diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2079,7 +2079,8 @@ package body Exp_Attr is case Id is - -- Attributes related to Ada 2012 iterators + -- Attributes related to Ada 2012 iterators. They are only allowed in + -- attribute definition clauses and should never be expanded. when Attribute_Constant_Indexing | Attribute_Default_Iterator @@ -2088,7 +2089,7 @@ package body Exp_Attr is | Attribute_Iterator_Element | Attribute_Variable_Indexing => - null; + raise Program_Error; -- Internal attributes used to deal with Ada 2012 delayed aspects. These -- were already rejected by the parser. Thus they shouldn't appear here. diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -9774,33 +9774,37 @@ The following is a typical example of use: type List is private with Iterable => (First => First_Cursor, Next => Advance, - Has_Element => Cursor_Has_Element, - [Element => Get_Element]); + Has_Element => Cursor_Has_Element + [,Element => Get_Element] + [,Last => Last_Cursor] + [,Previous => Retreat]); @end example @itemize * @item -The value denoted by @code{First} must denote a primitive operation of the -container type that returns a @code{Cursor}, which must a be a type declared in +The values of @code{First} and @code{Last} are primitive operations of the +container type that return a @code{Cursor}, which must be a type declared in the container package or visible from it. For example: @end itemize @example function First_Cursor (Cont : Container) return Cursor; +function Last_Cursor (Cont : Container) return Cursor; @end example @itemize * @item -The value of @code{Next} is a primitive operation of the container type that takes -both a container and a cursor and yields a cursor. For example: +The values of @code{Next} and @code{Previous} are primitive operations of the container type that take +both a container and a cursor and yield a cursor. For example: @end itemize @example function Advance (Cont : Container; Position : Cursor) return Cursor; +function Retreat (Cont : Container; Position : Cursor) return Cursor; @end example diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -29308,8 +29308,8 @@ to permit their use in free software. @printindex ge -@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @anchor{cf}@w{ } +@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ } @c %**end of body @bye diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6959,6 +6959,7 @@ package body Sem_Ch13 is if Nkind (Expr) /= N_Aggregate then Error_Msg_N ("aspect Iterable must be an aggregate", Expr); + return; end if; declare @@ -6969,7 +6970,9 @@ package body Sem_Ch13 is while Present (Assoc) loop Analyze (Expression (Assoc)); - if not Is_Entity_Name (Expression (Assoc)) then + if not Is_Entity_Name (Expression (Assoc)) + or else Ekind (Entity (Expression (Assoc))) /= E_Function + then Error_Msg_N ("value must be a function", Assoc); end if; @@ -15875,22 +15878,34 @@ package body Sem_Ch13 is Ent := Entity (N); F1 := First_Formal (Ent); + F2 := Next_Formal (F1); - if Nam in Name_First | Name_Last then + if Nam = Name_First then - -- First or Last (Container) => Cursor + -- First (Container) => Cursor if Etype (Ent) /= Cursor then Error_Msg_N ("primitive for First must yield a cursor", N); + elsif Present (F2) then + Error_Msg_N ("no match for First iterable primitive", N); + end if; + + elsif Nam = Name_Last then + + -- Last (Container) => Cursor + + if Etype (Ent) /= Cursor then + Error_Msg_N ("primitive for Last must yield a cursor", N); + elsif Present (F2) then + Error_Msg_N ("no match for Last iterable primitive", N); end if; elsif Nam = Name_Next then -- Next (Container, Cursor) => Cursor - F2 := Next_Formal (F1); - - if Etype (F2) /= Cursor + if No (F2) + or else Etype (F2) /= Cursor or else Etype (Ent) /= Cursor or else Present (Next_Formal (F2)) then @@ -15901,9 +15916,8 @@ package body Sem_Ch13 is -- Previous (Container, Cursor) => Cursor - F2 := Next_Formal (F1); - - if Etype (F2) /= Cursor + if No (F2) + or else Etype (F2) /= Cursor or else Etype (Ent) /= Cursor or else Present (Next_Formal (F2)) then @@ -15914,9 +15928,8 @@ package body Sem_Ch13 is -- Has_Element (Container, Cursor) => Boolean - F2 := Next_Formal (F1); - - if Etype (F2) /= Cursor + if No (F2) + or else Etype (F2) /= Cursor or else Etype (Ent) /= Standard_Boolean or else Present (Next_Formal (F2)) then @@ -15924,7 +15937,8 @@ package body Sem_Ch13 is end if; elsif Nam = Name_Element then - F2 := Next_Formal (F1); + + -- Element (Container, Cursor) => Element_Type; if No (F2) or else Etype (F2) /= Cursor @@ -17084,34 +17098,41 @@ package body Sem_Ch13 is ------------------------------ procedure Validate_Iterable_Aspect (Typ : Entity_Id; ASN : Node_Id) is + Aggr : constant Node_Id := Expression (ASN); Assoc : Node_Id; Expr : Node_Id; Prim : Node_Id; - Cursor : constant Entity_Id := Get_Cursor_Type (ASN, Typ); + Cursor : Entity_Id; - First_Id : Entity_Id; - Last_Id : Entity_Id; - Next_Id : Entity_Id; - Has_Element_Id : Entity_Id; - Element_Id : Entity_Id; + First_Id : Entity_Id := Empty; + Last_Id : Entity_Id := Empty; + Next_Id : Entity_Id := Empty; + Has_Element_Id : Entity_Id := Empty; + Element_Id : Entity_Id := Empty; begin + if Nkind (Aggr) /= N_Aggregate then + Error_Msg_N ("aspect Iterable must be an aggregate", Aggr); + return; + end if; + + Cursor := Get_Cursor_Type (ASN, Typ); + -- If previous error aspect is unusable if Cursor = Any_Type then return; end if; - First_Id := Empty; - Last_Id := Empty; - Next_Id := Empty; - Has_Element_Id := Empty; - Element_Id := Empty; + if not Is_Empty_List (Expressions (Aggr)) then + Error_Msg_N + ("illegal positional association", First (Expressions (Aggr))); + end if; -- Each expression must resolve to a function with the proper signature - Assoc := First (Component_Associations (Expression (ASN))); + Assoc := First (Component_Associations (Aggr)); while Present (Assoc) loop Expr := Expression (Assoc); Analyze (Expr); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -10894,7 +10894,7 @@ package body Sem_Util is -- First. Assoc := First (Component_Associations (Expression (Aspect))); - First_Op := Any_Id; + First_Op := Any_Id; while Present (Assoc) loop if Chars (First (Choices (Assoc))) = Name_First then First_Op := Expression (Assoc); --k+w/mQv8wyuph6w0--