From patchwork Mon Oct 14 12:47:04 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 283200 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 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (Client did not present a certificate) by ozlabs.org (Postfix) with ESMTPS id A33D02C035E for ; Mon, 14 Oct 2013 23:47:18 +1100 (EST) 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=ERADeOcixO/OctRq4B/sZF5cpiUKMAR18yvRniUjqpapw3I8SX i7Tl2h1nNXLPefK+SLckKTMNYBmW7IwEJsSKMur3/hZh4G6RcFkiG66c6wOB1oyS oBkg3SPf6S7oQxUboe5wcGqonV8+ze7s5ipIS4pOAIZXUT7IfkVKYlU1E= 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=Npipt+iwfdrtUwGceoP1aQxboZg=; b=LmvpcL2p6Jp148377acw 3hLytxruHFMZmpsUmR/AoYHSYhC9XJpzhlFoeY9mj3tRi1SdaXJ0evQZTcdZIKEG 0w9SgnnpH9uwwO7L03MGHC/lVWw6Fzk8BE9HvOi3jxHdmEUFvknn1VQJeuKHcjpQ 58F81B5PgWT0eJqHadHHeTI= Received: (qmail 12383 invoked by alias); 14 Oct 2013 12:47:08 -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 12355 invoked by uid 89); 14 Oct 2013 12:47:08 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham version=3.3.2 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 (AES256-SHA encrypted) ESMTPS; Mon, 14 Oct 2013 12:47:07 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 6F6F21165A9; Mon, 14 Oct 2013 08:47:27 -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 ubUOcMzSNvtt; Mon, 14 Oct 2013 08:47:27 -0400 (EDT) Received: from kwai.gnat.com (unknown [IPv6:2620:20:4000:0:a6ba:dbff:fe26:1f63]) by rock.gnat.com (Postfix) with ESMTP id 5E703116580; Mon, 14 Oct 2013 08:47:27 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id F0F433FB31; Mon, 14 Oct 2013 08:47:04 -0400 (EDT) Date: Mon, 14 Oct 2013 08:47:04 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Implement new attribute Library_Level Message-ID: <20131014124704.GA29656@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) This implements a new attribute Standard'Library_Level (Standard is the only allowed prefix), which returns a Boolean value which is True if the attribute is evaluated at the library level (e.g. with a package declaration), and false if evaluated elsewhere (e.g. within a subprogram body). In the case of generics, the value indicates the placement of the instantiation, not the template, and indeed the use of this attribute within a generic is the intended common application as shown in this example: 1. generic 2. package LLTestP is 3. pragma Compile_Time_Warning 4. (not Standard'Library_Level, 5. "LLTest should be instantiated at library level"); 6. end; 1. with LLTestP; 2. package LLTestP1 is 3. package P is new LLTestP; 4. P1L : constant Boolean := Standard'Library_Level; 5. end; 1. with LLTestP; 2. with LLTestP1; use LLTestP1; 3. with Text_IO; use Text_IO; 4. procedure LLTest is 5. package P1 is new LLTestP; | >>> warning: in instantiation at lltestp.ads:4 >>> warning: LLTest should be instantiated at library level 6. begin 7. Put_Line (Boolean'Image (Standard'Library_Level)); 8. Put_Line (Boolean'Image (P1L)); 9. end; When run, LLTest outputs: FALSE TRUE Tested on x86_64-pc-linux-gnu, committed on trunk 2013-10-14 Robert Dewar * exp_attr.adb (Expand_N_Attribute_Reference): Add error entry for Library_Level attribute (which should not survive to expansion) * gnat_rm.texi: Document attribute Library_Level * sem_attr.adb (Analyze_Attribute, case Library_Level): Implement this new attribute (Set_Boolean_Result): Replaces Set_Result (Check_Standard_Prefix): Document that Check_E0 is called (Check_System_Prefix): New procedure * snames.ads-tmpl: Add entry for Library_Level attribute Index: gnat_rm.texi =================================================================== --- gnat_rm.texi (revision 203527) +++ gnat_rm.texi (working copy) @@ -337,6 +337,7 @@ * Attribute Integer_Value:: * Attribute Invalid_Value:: * Attribute Large:: +* Attribute Library_Level:: * Attribute Loop_Entry:: * Attribute Machine_Size:: * Attribute Mantissa:: @@ -7842,6 +7843,7 @@ * Attribute Integer_Value:: * Attribute Invalid_Value:: * Attribute Large:: +* Attribute Library_Level:: * Attribute Loop_Entry:: * Attribute Machine_Size:: * Attribute Mantissa:: @@ -8341,6 +8343,31 @@ the Ada 83 reference manual for an exact description of the semantics of this attribute. +@node Attribute Library_Level +@unnumberedsec Attribute Library_Level +@findex Library_Level +@noindent +@noindent +@code{Standard'Library_Level} (@code{Standard} is the only allowed +prefix) returns a Boolean value which is True if the attribute is +evaluated at the library level (e.g. with a package declaration), +and false if evaluated elsewhere (e.g. within a subprogram body). +In the case of generics, the value indicates the placement of +the instantiation, not the template, and indeed the use of this +attribute within a generic is the intended common application +as shown in this example: + +@smallexample @c ada +generic + ... +package Gen is + pragma Compile_Time_Error + (not Standard'Library_Level, + "Gen can only be instantiated at library level"); + ... +end Gen; +@end smallexample + @node Attribute Loop_Entry @unnumberedsec Attribute Loop_Entry @findex Loop_Entry Index: exp_attr.adb =================================================================== --- exp_attr.adb (revision 203521) +++ exp_attr.adb (working copy) @@ -6485,6 +6485,7 @@ Attribute_Has_Tagged_Values | Attribute_Large | Attribute_Last_Valid | + Attribute_Library_Level | Attribute_Lock_Free | Attribute_Machine_Emax | Attribute_Machine_Emin | Index: sem_attr.adb =================================================================== --- sem_attr.adb (revision 203521) +++ sem_attr.adb (working copy) @@ -189,6 +189,11 @@ -- where therefore the prefix of the attribute does not match the enclosing -- scope. + procedure Set_Boolean_Result (N : Node_Id; B : Boolean); + -- Rewrites node N with an occurrence of either Standard_False or + -- Standard_True, depending on the value of the parameter B. The + -- result is marked as a static expression. + ----------------------- -- Analyze_Attribute -- ----------------------- @@ -339,13 +344,17 @@ -- Verify that prefix of attribute N is a scalar type procedure Check_Standard_Prefix; - -- Verify that prefix of attribute N is package Standard + -- Verify that prefix of attribute N is package Standard. Also checks + -- that there are no arguments. procedure Check_Stream_Attribute (Nam : TSS_Name_Type); -- Validity checking for stream attribute. Nam is the TSS name of the -- corresponding possible defined attribute function (e.g. for the -- Read attribute, Nam will be TSS_Stream_Read). + procedure Check_System_Prefix; + -- Verify that prefix of attribute N is package System + procedure Check_PolyORB_Attribute; -- Validity checking for PolyORB/DSA attribute @@ -1972,6 +1981,17 @@ Check_Not_CPP_Type; end Check_Stream_Attribute; + ------------------------- + -- Check_System_Prefix -- + ------------------------- + + procedure Check_System_Prefix is + begin + if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then + Error_Attr ("only allowed prefix for % attribute is System", P); + end if; + end Check_System_Prefix; + ----------------------- -- Check_Task_Prefix -- ----------------------- @@ -3663,6 +3683,21 @@ Check_Array_Type; Set_Etype (N, Universal_Integer); + ------------------- + -- Library_Level -- + ------------------- + + when Attribute_Library_Level => + Check_E0; + Check_Standard_Prefix; + + if not Inside_A_Generic then + Set_Boolean_Result (N, + Nearest_Dynamic_Scope (Current_Scope) = Standard_Standard); + end if; + + Set_Etype (N, Standard_Boolean); + --------------- -- Lock_Free -- --------------- @@ -4965,36 +5000,11 @@ U : Node_Id; Unam : Unit_Name_Type; - procedure Set_Result (B : Boolean); - -- Replace restriction node by static constant False or True, - -- depending on the value of B. - - ---------------- - -- Set_Result -- - ---------------- - - procedure Set_Result (B : Boolean) is - begin - if B then - Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); - else - Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; - - Set_Is_Static_Expression (N); - end Set_Result; - - -- Start of processing for Restriction_Set - begin Check_E1; Analyze (P); + Check_System_Prefix; - if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then - Set_Result (False); - Error_Attr_P ("prefix of % attribute must be System"); - end if; - -- No_Dependence case if Nkind (E1) = N_Parameter_Association then @@ -5002,7 +5012,7 @@ U := Explicit_Actual_Parameter (E1); if not OK_No_Dependence_Unit_Name (U) then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Attr; end if; @@ -5013,14 +5023,14 @@ if Designate_Same_Unit (U, No_Dependences.Table (J).Unit) and then No_Dependences.Table (J).Warn = False then - Set_Result (True); + Set_Boolean_Result (N, True); return; end if; end loop; -- If not in the No_Dependence table, result is False - Set_Result (False); + Set_Boolean_Result (N, False); -- In this case, we must ensure that the binder will reject any -- other unit in the partition that sets No_Dependence for this @@ -5043,29 +5053,29 @@ else if Nkind (E1) /= N_Identifier then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Attr ("attribute % requires restriction identifier", E1); else R := Get_Restriction_Id (Process_Restriction_Synonyms (E1)); if R = Not_A_Restriction_Id then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Msg_Node_1 := E1; Error_Attr ("invalid restriction identifier &", E1); elsif R not in Partition_Boolean_Restrictions then - Set_Result (False); + Set_Boolean_Result (N, False); Error_Msg_Node_1 := E1; Error_Attr ("& is not a boolean partition-wide restriction", E1); end if; if Restriction_Active (R) then - Set_Result (True); + Set_Boolean_Result (N, True); else Check_Restriction (R, N); - Set_Result (False); + Set_Boolean_Result (N, False); end if; end if; end if; @@ -5596,11 +5606,8 @@ begin Check_E1; Analyze (P); + Check_System_Prefix; - if Nkind (P) /= N_Identifier or else Chars (P) /= Name_System then - Error_Attr_P ("prefix of % attribute must be System"); - end if; - Generate_Reference (RTE (RE_Address), P); Analyze_And_Resolve (E1, Any_Integer); Set_Etype (N, RTE (RE_Address)); @@ -6809,8 +6816,8 @@ return; end if; - -- Cases where P is not an object. Cannot do anything if P is - -- not the name of an entity. + -- Cases where P is not an object. Cannot do anything if P is not the + -- name of an entity. elsif not Is_Entity_Name (P) then Check_Expressions; @@ -6908,10 +6915,9 @@ -- We can fold 'Alignment applied to a type if the alignment is known -- (as happens for an alignment from an attribute definition clause). - -- At this stage, this can happen only for types (e.g. record - -- types) for which the size is always non-static. We exclude - -- generic types from consideration (since they have bogus - -- sizes set within templates). + -- At this stage, this can happen only for types (e.g. record types) for + -- which the size is always non-static. We exclude generic types from + -- consideration (since they have bogus sizes set within templates). elsif Id = Attribute_Alignment and then Is_Type (P_Entity) @@ -9118,6 +9124,7 @@ Attribute_First_Bit | Attribute_Input | Attribute_Last_Bit | + Attribute_Library_Level | Attribute_Maximum_Alignment | Attribute_Old | Attribute_Output | @@ -10421,6 +10428,23 @@ Eval_Attribute (N); end Resolve_Attribute; + ------------------------ + -- Set_Boolean_Result -- + ------------------------ + + procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + + begin + if B then + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + else + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); + end if; + + Set_Is_Static_Expression (N); + end Set_Boolean_Result; + -------------------------------- -- Stream_Attribute_Available -- -------------------------------- Index: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 203525) +++ snames.ads-tmpl (working copy) @@ -807,20 +807,15 @@ -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These - -- attributes are implemented in both Ada 83 and Ada 95 modes in GNAT. + -- attributes are implemented in all Ada modes in GNAT. -- The entries marked GNAT are attributes that are defined by GNAT and - -- implemented in both Ada 83 and Ada 95 modes. Full descriptions of these - -- implementation dependent attributes may be found in the appropriate - -- section in Sem_Attr. + -- implemented in all Ada modes. Full descriptions of these implementation + -- dependent attributes may be found in the appropriate Sem_Attr section. -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. - -- The entries marked HiLite are attributes that are defined by Hi-Lite - -- and implemented in GNAT operating under formal verification mode. The - -- entries are treated as illegal in all other contexts. - First_Attribute_Name : constant Name_Id := N + $; Name_Abort_Signal : constant Name_Id := N + $; -- GNAT Name_Access : constant Name_Id := N + $; @@ -881,8 +876,9 @@ Name_Last_Valid : constant Name_Id := N + $; -- Ada 12 Name_Leading_Part : constant Name_Id := N + $; Name_Length : constant Name_Id := N + $; + Name_Library_Level : constant Name_Id := N + $; -- GNAT Name_Lock_Free : constant Name_Id := N + $; -- GNAT - Name_Loop_Entry : constant Name_Id := N + $; -- HiLite + Name_Loop_Entry : constant Name_Id := N + $; -- GNAT Name_Machine_Emax : constant Name_Id := N + $; Name_Machine_Emin : constant Name_Id := N + $; Name_Machine_Mantissa : constant Name_Id := N + $; @@ -1498,6 +1494,7 @@ Attribute_Last_Valid, Attribute_Leading_Part, Attribute_Length, + Attribute_Library_Level, Attribute_Lock_Free, Attribute_Loop_Entry, Attribute_Machine_Emax,