From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 20975 invoked by alias); 30 Oct 2014 11:35:11 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 20879 invoked by uid 89); 30 Oct 2014 11:35:11 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=1.8 required=5.0 tests=BAYES_50,FORM_FRAUD,T_FILL_THIS_FORM_SHORT autolearn=no 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; Thu, 30 Oct 2014 11:35:04 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 3C9DB116166; Thu, 30 Oct 2014 07:35:02 -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 w9FzXl2bD2IV; Thu, 30 Oct 2014 07:35:02 -0400 (EDT) Received: from kwai.gnat.com (unknown [IPv6:2620:20:4000:0:7a2b:cbff:fe60:cb11]) by rock.gnat.com (Postfix) with ESMTP id 1D73A1160BC; Thu, 30 Oct 2014 07:35:02 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 17D1B3FE21; Thu, 30 Oct 2014 07:35:02 -0400 (EDT) Date: Thu, 30 Oct 2014 12:35:00 -0000 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Aspect/pragma Extensions_Visible Message-ID: <20141030113502.GA26873@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="ew6BAiZeqk4r7MaW" Content-Disposition: inline User-Agent: Mutt/1.5.21 (2010-09-15) X-SW-Source: 2014-10/txt/msg03200.txt.bz2 --ew6BAiZeqk4r7MaW Content-Type: text/plain; charset=us-ascii Content-Disposition: inline Content-length: 6377 This patch implements aspect/pragma Extensions_Visible. This construct has the following rules: Extensions_Visible is a Boolean-valued aspect which may be specified for a subprogram. If directly specified, the aspect_definition shall be a static [Boolean] expression. The aspect is inherited by an inherited primitive subprogram. If the aspect is neither inherited nor directly specified for a subprogram, then the aspect is False. If the Extensions_Visible aspect is False for a subprogram, then certain restrictions are imposed on the use of any parameter of the subprogram which is of a specific tagged type (or of a private type whose full view is a specific tagged type). Such a parameter shall not be converted implicitly or explicitly to a class-wide type. Such a parameter shall not be passed as an actual parameter in a call to a subprogram whose Extensions_Visible aspect is True. These restrictions also apply to any parenthesized expression, qualified expression, or type conversion whose operand is subject to these restrictions, and to any conditional expression having at least one dependent_expression which is subject to these restrictions. A subprogram whose Extensions_Visible aspect is True shall not override an inherited primitive operation of a tagged type whose Extensions_Visible aspect is False. If a nonnull type extension inherits a procedure having both a False Extensions_Visible aspect and one or more controlling out-mode parameters, then the inherited procedure requires overriding. The Extensions_Visible aspect shall not be specified for a subprogram which has no parameters of either a specific tagged type or a private type unless the subprogram is declared in an instance of a generic unit and the corresponding subprogram in the generic unit satisfies this rule. ------------ -- Source -- ------------ -- extensions_visible_illegal_2.ads package Extensions_Visible_Illegal_2 with SPARK_Mode is type T is tagged record X : Integer; end record; procedure Proc (Param : in T); procedure Proc_2 (Param : out T) with Extensions_Visible => False; type Extension is new T with record Y : Integer; end record; overriding procedure Proc (Param : in Extension) with Extensions_Visible; type Null_Extension is new T with null record; overriding procedure Proc (Param : in Null_Extension) with Extensions_Visible; end Extensions_Visible_Illegal_2; ---------------------------- -- Compilation and output -- ---------------------------- $ gcc -c extensions_visible_illegal_2.ads extensions_visible_illegal_2.ads:9:09: type must be declared abstract or "Proc_2" overridden extensions_visible_illegal_2.ads:9:09: "Proc_2" at line 7 is subject to Extensions_Visible False extensions_visible_illegal_2.ads:13:25: subprogram "Proc" with Extensions_Visible True cannot override subprogram at line 6 with Extensions_Visible False extensions_visible_illegal_2.ads:17:25: subprogram "Proc" with Extensions_Visible True cannot override subprogram at line 6 with Extensions_Visible False Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-30 Hristian Kirtchev * aspects.adb: Add an entry for aspect Extensions_Visible in table Canonical_Aspect. * aspects.ads: Add entry for aspect Extensions_Visible in tables Aspect_Argument, Aspect_Delay, Aspect_Id, Aspect_Names, Implementation_Defined_Aspect. * einfo.adb (Get_Pragma): Include pragma Extensions_Visible in the list of contract pragmas. * par-prag.adb Pragma Extensions_Visible does not require special processing from the parser. * sem_ch3.adb (Analyze_Object_Declaration): Prevent an implicit class-wide conversion of a formal parameter of a specific tagged type whose related subprogram is subject to pragma Extensions_Visible with value "False". (Check_Abstract_Overriding): Add various overriding checks related to pragma Extensions_Visible. (Derive_Subprogram): A subprogram subject to pragma Extensions_Visible with value False requires overriding if the subprogram has at least one controlling OUT parameter. (Is_EVF_Procedure): New routine. * sem_ch4.adb (Analyze_Type_Conversion): A formal parameter of a specific tagged type whose related subprogram is subject to pragma Extensions_Visible with value "False" cannot appear in a class-wide conversion. * sem_ch6.adb (Analyze_Subprogram_Contract): Remove the assertion to account for pragma Extensions_Visible. (Check_Overriding_Indicator): An overriding subprogram inherits the contact of the overridden subprogram. (New_Overloaded_Entity): An overriding subprogram inherits the contact of the overridden subprogram. * sem_ch13.adb (Analyze_Aspect_Specifications): Add processing for aspect Extensions_Visible. (Check_Aspect_At_Freeze_Point): Aspect Extensions_Visible does not require special processing at the freeze point. * sem_prag.adb Add an entry for pragma Extensions_Visible in table Sig_Flags. (Analyze_Pragma): Ensure that various SPARK pragmas lack identifiers in their arguments. Add processing for pragma Extensions_Visible. (Chain_CTC): Code reformatting. * sem_res.adb (Resolve_Actuals): A formal parameter of a specific tagged type whose related subprogram is subject to pragma Extensions_Visible with value "False" cannot act as an actual in a subprogram with value "True". * sem_util.adb (Add_Classification): New routine. (Add_Contract_Item): Account for pragma Extensions_Visible. Code reformatting. (Add_Contract_Test_Case): New routine. (Add_Pre_Post_Condition): New routine. (Extensions_Visible_Status): New routine. (Inherit_Subprogram_Contract): New routine. (Is_EVF_Expression): New routine. (Is_Specific_Tagged_Type): New routine. * sem_util.ads Add type Extensions_Visible_Mode and document all values. (Add_Contract_Item): Add pragma Extensions_Visible to the comment on usage. (Inherit_Subprogram_Contract): New routine. (Is_EVF_Expression): New routine. (Is_Specific_Tagged_Type): New routine. * sinfo.adb (Is_Inherited): New routine. (Set_Is_Inherited): New routine. * sinfo.ads Add flag Is_Inherited along with its usage in nodes. (Is_Inherited): New routine along with pragma Inline. (Set_Is_Inherited): New routine along with pragma Inline. * snames.ads-tmpl: Add predefined name "Extensions_Visible" and a new Pragma_Id for the pragma. --ew6BAiZeqk4r7MaW Content-Type: text/plain; charset=us-ascii Content-Disposition: attachment; filename=difs Content-length: 55679 Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 216770) +++ sem_ch3.adb (working copy) @@ -590,6 +590,12 @@ -- Propagate static and dynamic predicate flags from a parent to the -- subtype in a subtype declaration with and without constraints. + function Is_EVF_Procedure (Subp : Entity_Id) return Boolean; + -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram. + -- Determine whether subprogram Subp is a procedure subject to pragma + -- Extensions_Visible with value False and has at least one controlling + -- parameter of mode OUT. + function Is_Valid_Constraint_Kind (T_Kind : Type_Kind; Constraint_Kind : Node_Kind) return Boolean; @@ -3638,8 +3644,8 @@ and then Is_Access_Constant (Etype (E)) then Error_Msg_N - ("access to variable cannot be initialized " - & "with an access-to-constant expression", E); + ("access to variable cannot be initialized with an " + & "access-to-constant expression", E); end if; if not Assignment_OK (N) then @@ -3694,6 +3700,17 @@ Check_SPARK_05_Restriction ("initialization expression is not appropriate", E); end if; + + -- A formal parameter of a specific tagged type whose related + -- subprogram is subject to pragma Extensions_Visible with value + -- "False" cannot be implicitly converted to a class-wide type by + -- means of an initialization expression. + + if Is_Class_Wide_Type (T) and then Is_EVF_Expression (E) then + Error_Msg_N + ("formal parameter with Extensions_Visible False cannot be " + & "implicitly converted to class-wide type", E); + end if; end if; -- If the No_Streams restriction is set, check that the type of the @@ -9790,6 +9807,15 @@ then null; + -- A null extension is not obliged to override an inherited + -- procedure subject to pragma Extensions_Visible with value + -- False and at least one controlling OUT parameter. + + elsif Is_Null_Extension (T) + and then Is_EVF_Procedure (Subp) + then + null; + else Error_Msg_NE ("type must be declared abstract or & overridden", @@ -9833,6 +9859,16 @@ ("\& subprogram# is not visible", T, Subp); + -- Clarify the case where a non-null extension must + -- override inherited procedure subject to pragma + -- Extensions_Visible with value False and at least + -- one controlling OUT param. + + elsif Is_EVF_Procedure (E) then + Error_Msg_NE + ("\& # is subject to Extensions_Visible False", + T, Subp); + else Error_Msg_NE ("\& has been inherited from subprogram #", @@ -9902,6 +9938,20 @@ Error_Msg_Node_2 := Subp; Error_Msg_N ("nonabstract type& has abstract subprogram&!", T); end if; + + -- A subprogram subject to pragma Extensions_Visible with value + -- "True" cannot override a subprogram subject to the same pragma + -- with value "False". + + elsif Extensions_Visible_Status (Subp) = Extensions_Visible_True + and then Present (Overridden_Operation (Subp)) + and then Extensions_Visible_Status (Overridden_Operation (Subp)) = + Extensions_Visible_False + then + Error_Msg_Sloc := Sloc (Overridden_Operation (Subp)); + Error_Msg_N + ("subprogram & with Extensions_Visible True cannot override " + & "subprogram # with Extensions_Visible False", Subp); end if; -- Ada 2012 (AI05-0030): Perform checks related to pragma Implemented @@ -14254,8 +14304,7 @@ -- Start of processing for Derive_Subprogram begin - New_Subp := - New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); + New_Subp := New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); Set_Ekind (New_Subp, Ekind (Parent_Subp)); Set_Contract (New_Subp, Make_Contract (Sloc (New_Subp))); @@ -14490,6 +14539,10 @@ -- Ada 2005 (AI-228): Calculate the "require overriding" and "abstract" -- properties of the subprogram, as defined in RM-3.9.3(4/2-6/2). + -- A subprogram subject to pragma Extensions_Visible with value False + -- requires overriding if the subprogram has at least one controlling + -- OUT parameter. + elsif Ada_Version >= Ada_2005 and then (Is_Abstract_Subprogram (Alias (New_Subp)) or else (Is_Tagged_Type (Derived_Type) @@ -14500,7 +14553,8 @@ E_Anonymous_Access_Type and then Designated_Type (Etype (New_Subp)) = Derived_Type - and then not Is_Null_Extension (Derived_Type))) + and then not Is_Null_Extension (Derived_Type)) + or else Is_EVF_Procedure (Alias (New_Subp))) and then No (Actual_Subp) then if not Is_Tagged_Type (Derived_Type) @@ -17339,6 +17393,35 @@ (Subt, Has_Dynamic_Predicate_Aspect (Par)); end Inherit_Predicate_Flags; + ---------------------- + -- Is_EVF_Procedure -- + ---------------------- + + function Is_EVF_Procedure (Subp : Entity_Id) return Boolean is + Formal : Entity_Id; + + begin + -- Examine the formals of an Extensions_Visible False procedure looking + -- for a controlling OUT parameter. + + if Ekind (Subp) = E_Procedure + and then Extensions_Visible_Status (Subp) = Extensions_Visible_False + then + Formal := First_Formal (Subp); + while Present (Formal) loop + if Ekind (Formal) = E_Out_Parameter + and then Is_Controlling_Formal (Formal) + then + return True; + end if; + + Next_Formal (Formal); + end loop; + end if; + + return False; + end Is_EVF_Procedure; + ----------------------- -- Is_Null_Extension -- ----------------------- Index: sinfo.adb =================================================================== --- sinfo.adb (revision 216770) +++ sinfo.adb (working copy) @@ -1889,6 +1889,14 @@ return Flag11 (N); end Is_In_Discriminant_Check; + function Is_Inherited + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag4 (N); + end Is_Inherited; + function Is_Machine_Number (N : Node_Id) return Boolean is begin @@ -5078,6 +5086,14 @@ Set_Flag11 (N, Val); end Set_Is_In_Discriminant_Check; + procedure Set_Is_Inherited + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag4 (N, Val); + end Set_Is_Inherited; + procedure Set_Is_Machine_Number (N : Node_Id; Val : Boolean := True) is begin Index: sinfo.ads =================================================================== --- sinfo.ads (revision 216770) +++ sinfo.ads (working copy) @@ -1573,6 +1573,10 @@ -- discriminant check has a correct value cannot be performed in this -- case (or the discriminant check may be optimized away). + -- Is_Inherited (Flag4-Sem) + -- This flag is set in an N_Pragma node that appears in a N_Contract node + -- to indicate that the pragma has been inherited from a parent context. + -- Is_Machine_Number (Flag11-Sem) -- This flag is set in an N_Real_Literal node to indicate that the value -- is a machine number. This avoids some unnecessary cases of converting @@ -2384,11 +2388,12 @@ -- Next_Rep_Item (Node5-Sem) -- Class_Present (Flag6) set if from Aspect with 'Class -- From_Aspect_Specification (Flag13-Sem) + -- Import_Interface_Present (Flag16-Sem) + -- Is_Checked (Flag11-Sem) -- Is_Delayed_Aspect (Flag14-Sem) -- Is_Disabled (Flag15-Sem) -- Is_Ignored (Flag9-Sem) - -- Is_Checked (Flag11-Sem) - -- Import_Interface_Present (Flag16-Sem) + -- Is_Inherited (Flag4-Sem) -- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set -- Uneval_Old_Accept (Flag7-Sem) -- Uneval_Old_Warn (Flag18-Sem) @@ -9229,6 +9234,9 @@ function Is_In_Discriminant_Check (N : Node_Id) return Boolean; -- Flag11 + function Is_Inherited + (N : Node_Id) return Boolean; -- Flag4 + function Is_Machine_Number (N : Node_Id) return Boolean; -- Flag11 @@ -10246,6 +10254,9 @@ procedure Set_Is_In_Discriminant_Check (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Is_Inherited + (N : Node_Id; Val : Boolean := True); -- Flag4 + procedure Set_Is_Machine_Number (N : Node_Id; Val : Boolean := True); -- Flag11 @@ -12629,6 +12640,7 @@ pragma Inline (Is_Folded_In_Parser); pragma Inline (Is_Ignored); pragma Inline (Is_In_Discriminant_Check); + pragma Inline (Is_Inherited); pragma Inline (Is_Machine_Number); pragma Inline (Is_Null_Loop); pragma Inline (Is_Overloaded); @@ -12963,6 +12975,7 @@ pragma Inline (Set_Is_Folded_In_Parser); pragma Inline (Set_Is_Ignored); pragma Inline (Set_Is_In_Discriminant_Check); + pragma Inline (Set_Is_Inherited); pragma Inline (Set_Is_Machine_Number); pragma Inline (Set_Is_Null_Loop); pragma Inline (Set_Is_Overloaded); Index: einfo.adb =================================================================== --- einfo.adb (revision 216770) +++ einfo.adb (working copy) @@ -6684,31 +6684,32 @@ function Get_Pragma (E : Entity_Id; Id : Pragma_Id) return Node_Id is Is_CDG : constant Boolean := - Id = Pragma_Abstract_State or else - Id = Pragma_Async_Readers or else - Id = Pragma_Async_Writers or else - Id = Pragma_Depends or else - Id = Pragma_Effective_Reads or else - Id = Pragma_Effective_Writes or else - Id = Pragma_Global or else - Id = Pragma_Initial_Condition or else - Id = Pragma_Initializes or else - Id = Pragma_Part_Of or else - Id = Pragma_Refined_Depends or else - Id = Pragma_Refined_Global or else + Id = Pragma_Abstract_State or else + Id = Pragma_Async_Readers or else + Id = Pragma_Async_Writers or else + Id = Pragma_Depends or else + Id = Pragma_Effective_Reads or else + Id = Pragma_Effective_Writes or else + Id = Pragma_Extensions_Visible or else + Id = Pragma_Global or else + Id = Pragma_Initial_Condition or else + Id = Pragma_Initializes or else + Id = Pragma_Part_Of or else + Id = Pragma_Refined_Depends or else + Id = Pragma_Refined_Global or else Id = Pragma_Refined_State; Is_CTC : constant Boolean := - Id = Pragma_Contract_Cases or else + Id = Pragma_Contract_Cases or else Id = Pragma_Test_Case; Is_PPC : constant Boolean := - Id = Pragma_Precondition or else - Id = Pragma_Postcondition or else + Id = Pragma_Precondition or else + Id = Pragma_Postcondition or else Id = Pragma_Refined_Post; In_Contract : constant Boolean := Is_CDG or Is_CTC or Is_PPC; - Item : Node_Id; - Items : Node_Id; + Item : Node_Id; + Items : Node_Id; begin -- Handle pragmas that appear in N_Contract nodes. Those have to be Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 216770) +++ sem_prag.adb (working copy) @@ -3842,9 +3842,9 @@ -- pragma is inserted in its declarative part. elsif From_Aspect_Specification (N) + and then Ent = Current_Scope and then Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body - and then Ent = Current_Scope then OK := True; @@ -5370,7 +5370,9 @@ --------------- procedure Chain_CTC (PO : Node_Id) is - S : Entity_Id; + Name : constant String_Id := Get_Name_From_CTC_Pragma (N); + CTC : Node_Id; + S : Entity_Id; begin if Nkind (PO) = N_Abstract_Subprogram_Declaration then @@ -5399,32 +5401,24 @@ -- There should not be another test-case with the same name -- associated to this subprogram. - declare - Name : constant String_Id := Get_Name_From_CTC_Pragma (N); - CTC : Node_Id; + CTC := Contract_Test_Cases (Contract (S)); + while Present (CTC) loop - begin - CTC := Contract_Test_Cases (Contract (S)); - while Present (CTC) loop + -- Omit pragma Contract_Cases because it does not introduce + -- a unique case name and it does not follow the syntax of + -- Test_Case. - -- Omit pragma Contract_Cases because it does not introduce - -- a unique case name and it does not follow the syntax of - -- Test_Case. + if Pragma_Name (CTC) = Name_Contract_Cases then + null; - if Pragma_Name (CTC) = Name_Contract_Cases then - null; + elsif String_Equal (Name, Get_Name_From_CTC_Pragma (CTC)) then + Error_Msg_Sloc := Sloc (CTC); + Error_Pragma ("name for pragma% is already used#"); + end if; - elsif String_Equal - (Name, Get_Name_From_CTC_Pragma (CTC)) - then - Error_Msg_Sloc := Sloc (CTC); - Error_Pragma ("name for pragma% is already used#"); - end if; + CTC := Next_Pragma (CTC); + end loop; - CTC := Next_Pragma (CTC); - end loop; - end; - -- Chain spec CTC pragma to list for subprogram Add_Contract_Item (N, S); @@ -10518,6 +10512,7 @@ begin GNAT_Pragma; + Check_No_Identifiers; Check_Arg_Count (1); Ensure_Aggregate_Form (Arg1); @@ -12292,6 +12287,7 @@ begin GNAT_Pragma; + Check_No_Identifiers; Check_Arg_Count (1); Ensure_Aggregate_Form (Arg1); @@ -12805,12 +12801,11 @@ Expression => Get_Pragma_Arg (Arg1))))); Analyze (N); - -------------------------------------- - -- Pragma_Default_Initial_Condition -- - -------------------------------------- + ------------------------------- + -- Default_Initial_Condition -- + ------------------------------- - -- pragma Pragma_Default_Initial_Condition - -- [ (null | boolean_EXPRESSION) ]; + -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ]; when Pragma_Default_Initial_Condition => Default_Init_Cond : declare Discard : Boolean; @@ -12819,6 +12814,7 @@ begin GNAT_Pragma; + Check_No_Identifiers; Check_At_Most_N_Arguments (1); Stmt := Prev (N); @@ -13883,6 +13879,135 @@ Ada_Version_Pragma := Empty; end if; + ------------------------ + -- Extensions_Visible -- + ------------------------ + + -- pragma Extensions_Visible [ (boolean_EXPRESSION) ]; + + when Pragma_Extensions_Visible => Extensions_Visible : declare + Context : constant Node_Id := Parent (N); + Expr : Node_Id; + Formal : Entity_Id; + Subp : Entity_Id; + Stmt : Node_Id; + + Has_OK_Formal : Boolean := False; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_At_Most_N_Arguments (1); + + Subp := Empty; + Stmt := Prev (N); + while Present (Stmt) loop + + -- Skip prior pragmas, but check for duplicates + + if Nkind (Stmt) = N_Pragma then + if Pragma_Name (Stmt) = Pname then + Error_Msg_Name_1 := Pname; + Error_Msg_Sloc := Sloc (Stmt); + Error_Msg_N ("pragma % duplicates pragma declared#", N); + end if; + + -- Skip internally generated code + + elsif not Comes_From_Source (Stmt) then + null; + + -- The associated [generic] subprogram declaration has been + -- found, stop the search. + + elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration, + N_Subprogram_Declaration) + then + Subp := Defining_Entity (Stmt); + exit; + + -- The pragma does not apply to a legal construct, issue an + -- error and stop the analysis. + + else + Error_Pragma ("pragma % must apply to a subprogram"); + return; + end if; + + Stmt := Prev (Stmt); + end loop; + + -- When the pragma applies to a stand alone subprogram body, it + -- appears within the declarations of the body. In that case the + -- enclosing construct is the proper context. This check is done + -- after the traversal above to allow for duplicate detection. + + if Nkind (Context) = N_Subprogram_Body + and then No (Corresponding_Spec (Context)) + then + Subp := Defining_Entity (Context); + end if; + + if No (Subp) then + Error_Pragma ("pragma % must apply to a subprogram"); + return; + end if; + + -- Examine the formals of the related subprogram + + Formal := First_Formal (Subp); + while Present (Formal) loop + + -- At least one of the formals is of a specific tagged type, + -- the pragma is legal. + + if Is_Specific_Tagged_Type (Etype (Formal)) then + Has_OK_Formal := True; + exit; + + -- A generic subprogram with at least one formal of a private + -- type ensures the legality of the pragma because the actual + -- may be specifically tagged. Note that this is verified by + -- the check above at instantiation time. + + elsif Is_Private_Type (Etype (Formal)) + and then Is_Generic_Type (Etype (Formal)) + then + Has_OK_Formal := True; + exit; + end if; + + Next_Formal (Formal); + end loop; + + if not Has_OK_Formal then + Error_Msg_Name_1 := Pname; + Error_Msg_N (Fix_Error ("incorrect placement of pragma %"), N); + Error_Msg_NE + ("\subprogram & lacks parameter of specific tagged or " + & "generic private type", N, Subp); + return; + end if; + + -- Analyze the Boolean expression (if any) + + if Present (Arg1) then + Expr := Get_Pragma_Arg (Arg1); + + Analyze_And_Resolve (Expr, Standard_Boolean); + + if not Is_OK_Static_Expression (Expr) then + Error_Pragma_Arg + ("expression of pragma % must be static", Expr); + return; + end if; + end if; + + -- Chain the pragma on the contract for further processing + + Add_Contract_Item (N, Subp); + end Extensions_Visible; + -------------- -- External -- -------------- @@ -14713,6 +14838,7 @@ begin GNAT_Pragma; + Check_No_Identifiers; Check_Arg_Count (1); -- Ensure the proper placement of the pragma. Initial_Condition @@ -14827,6 +14953,7 @@ begin GNAT_Pragma; + Check_No_Identifiers; Check_Arg_Count (1); Ensure_Aggregate_Form (Arg1); @@ -15760,6 +15887,15 @@ when Pragma_License => GNAT_Pragma; + + -- Do not analyze pragma any further in CodePeer mode, to avoid + -- extraneous errors in this implementation-dependent pragma, + -- which has a different profile on other compilers. + + if CodePeer_Mode then + return; + end if; + Check_Arg_Count (1); Check_No_Identifiers; Check_Valid_Configuration_Pragma; @@ -17296,6 +17432,7 @@ begin GNAT_Pragma; + Check_No_Identifiers; Check_Arg_Count (1); -- Ensure the proper placement of the pragma. Part_Of must appear @@ -18675,6 +18812,7 @@ begin GNAT_Pragma; + Check_No_Identifiers; Check_Arg_Count (1); -- Ensure the proper placement of the pragma. Refined states must @@ -24918,6 +25056,7 @@ Pragma_Export_Valued_Procedure => -1, Pragma_Extend_System => -1, Pragma_Extensions_Allowed => 0, + Pragma_Extensions_Visible => 0, Pragma_External => -1, Pragma_Favor_Top_Level => 0, Pragma_External_Name_Casing => 0, Index: sem_util.adb =================================================================== --- sem_util.adb (revision 216770) +++ sem_util.adb (working copy) @@ -251,9 +251,53 @@ procedure Add_Contract_Item (Prag : Node_Id; Id : Entity_Id) is Items : constant Node_Id := Contract (Id); - Nam : Name_Id; - N : Node_Id; + procedure Add_Classification; + -- Prepend Prag to the list of classifications + + procedure Add_Contract_Test_Case; + -- Prepend Prag to the list of contract and test cases + + procedure Add_Pre_Post_Condition; + -- Prepend Prag to the list of pre- and postconditions + + ------------------------ + -- Add_Classification -- + ------------------------ + + procedure Add_Classification is + begin + Set_Next_Pragma (Prag, Classifications (Items)); + Set_Classifications (Items, Prag); + end Add_Classification; + + ---------------------------- + -- Add_Contract_Test_Case -- + ---------------------------- + + procedure Add_Contract_Test_Case is + begin + Set_Next_Pragma (Prag, Contract_Test_Cases (Items)); + Set_Contract_Test_Cases (Items, Prag); + end Add_Contract_Test_Case; + + ---------------------------- + -- Add_Pre_Post_Condition -- + ---------------------------- + + procedure Add_Pre_Post_Condition is + begin + Set_Next_Pragma (Prag, Pre_Post_Conditions (Items)); + Set_Pre_Post_Conditions (Items, Prag); + end Add_Pre_Post_Condition; + + -- Local variables + + Nam : Name_Id; + PPC : Node_Id; + + -- Start of processing for Add_Contract_Item + begin -- The related context must have a contract and the item to be added -- must be a pragma. @@ -275,14 +319,12 @@ Name_Initial_Condition, Name_Initializes) then - Set_Next_Pragma (Prag, Classifications (Items)); - Set_Classifications (Items, Prag); + Add_Classification; -- Indicator Part_Of must be associated with a package instantiation elsif Nam = Name_Part_Of and then Is_Generic_Instance (Id) then - Set_Next_Pragma (Prag, Classifications (Items)); - Set_Classifications (Items, Prag); + Add_Classification; -- The pragma is not a proper contract item @@ -295,8 +337,7 @@ elsif Ekind (Id) = E_Package_Body then if Nam = Name_Refined_State then - Set_Next_Pragma (Prag, Classifications (Items)); - Set_Classifications (Items, Prag); + Add_Classification; -- The pragma is not a proper contract item @@ -308,6 +349,7 @@ -- applicable pragmas are: -- Contract_Cases -- Depends + -- Extensions_Visible -- Global -- Post -- Postcondition @@ -319,51 +361,49 @@ or else Is_Generic_Subprogram (Id) or else Is_Subprogram (Id) then - if Nam_In (Nam, Name_Precondition, + if Nam_In (Nam, Name_Pre, + Name_Precondition, + Name_uPre, + Name_Post, Name_Postcondition, - Name_Pre, - Name_Post, - Name_uPre, Name_uPost) then - -- Before we add a precondition or postcondition to the list, - -- make sure we do not have a disallowed duplicate, which can - -- happen if we use a pragma for Pre[_Class] or Post[_Class] - -- instead of the corresponding aspect. + -- Before we add a precondition or postcondition to the list, make + -- sure we do not have a disallowed duplicate, which can happen if + -- we use a pragma for Pre[_Class] or Post[_Class] instead of the + -- corresponding aspect. if not From_Aspect_Specification (Prag) - and then Nam_In (Nam, Name_Pre_Class, - Name_Pre, + and then Nam_In (Nam, Name_Pre, Name_uPre, - Name_Post_Class, Name_Post, - Name_uPost) + Name_Post_Class) then - N := Pre_Post_Conditions (Items); - while Present (N) loop - if not Split_PPC (N) - and then Original_Aspect_Name (N) = Nam + PPC := Pre_Post_Conditions (Items); + while Present (PPC) loop + if not Split_PPC (PPC) + and then Original_Aspect_Name (PPC) = Nam then - Error_Msg_Sloc := Sloc (N); + Error_Msg_Sloc := Sloc (PPC); Error_Msg_NE ("duplication of aspect for & given#", Prag, Id); return; - else - N := Next_Pragma (N); end if; + + PPC := Next_Pragma (PPC); end loop; end if; - Set_Next_Pragma (Prag, Pre_Post_Conditions (Items)); - Set_Pre_Post_Conditions (Items, Prag); + Add_Pre_Post_Condition; elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then - Set_Next_Pragma (Prag, Contract_Test_Cases (Items)); - Set_Contract_Test_Cases (Items, Prag); + Add_Contract_Test_Case; - elsif Nam_In (Nam, Name_Depends, Name_Global) then - Set_Next_Pragma (Prag, Classifications (Items)); - Set_Classifications (Items, Prag); + elsif Nam_In (Nam, Name_Depends, + Name_Extensions_Visible, + Name_Global) + then + Add_Classification; -- The pragma is not a proper contract item @@ -377,13 +417,11 @@ -- Refined_Post elsif Ekind (Id) = E_Subprogram_Body then - if Nam = Name_Refined_Post then - Set_Next_Pragma (Prag, Pre_Post_Conditions (Items)); - Set_Pre_Post_Conditions (Items, Prag); + if Nam_In (Nam, Name_Refined_Depends, Name_Refined_Global) then + Add_Classification; - elsif Nam_In (Nam, Name_Refined_Depends, Name_Refined_Global) then - Set_Next_Pragma (Prag, Classifications (Items)); - Set_Classifications (Items, Prag); + elsif Nam = Name_Refined_Post then + Add_Pre_Post_Condition; -- The pragma is not a proper contract item @@ -405,8 +443,7 @@ Name_Effective_Writes, Name_Part_Of) then - Set_Next_Pragma (Prag, Classifications (Items)); - Set_Classifications (Items, Prag); + Add_Classification; -- The pragma is not a proper contract item @@ -5772,6 +5809,84 @@ end if; end Explain_Limited_Type; + ------------------------------- + -- Extensions_Visible_Status -- + ------------------------------- + + function Extensions_Visible_Status + (Id : Entity_Id) return Extensions_Visible_Mode + is + Arg1 : Node_Id; + Expr : Node_Id; + Prag : Node_Id; + Subp : Entity_Id; + + begin + if SPARK_Mode = On then + + -- When a formal parameter is subject to Extensions_Visible, the + -- pragma is stored in the contract of related subprogram. + + if Is_Formal (Id) then + Subp := Scope (Id); + + elsif Is_Subprogram_Or_Generic_Subprogram (Id) then + Subp := Id; + + -- No other construct carries this pragma + + else + return Extensions_Visible_None; + end if; + + Prag := Get_Pragma (Subp, Pragma_Extensions_Visible); + + -- Extract the value from the Boolean expression (if any) + + if Present (Prag) then + Arg1 := First (Pragma_Argument_Associations (Prag)); + + -- The pragma appears with an argument + + if Present (Arg1) then + Expr := Get_Pragma_Arg (Arg1); + + -- Guarg against cascading errors when the argument of pragma + -- Extensions_Visible is not a valid static Boolean expression. + + if Error_Posted (Expr) then + return Extensions_Visible_None; + + elsif Is_True (Expr_Value (Expr)) then + return Extensions_Visible_True; + + else + return Extensions_Visible_False; + end if; + + -- Otherwise the pragma defaults to True + + else + return Extensions_Visible_True; + end if; + + -- Otherwise pragma Expresions_Visible is not inherited or directly + -- specified, its value defaults to "False". + + else + return Extensions_Visible_False; + end if; + + -- When SPARK_Mode is disabled, all semantic checks related to pragma + -- Extensions_Visible are disabled as well. Instead of saturating the + -- code with "if SPARK_Mode /= Off then" checks, the predicate returns + -- a default value. + + else + return Extensions_Visible_None; + end if; + end Extensions_Visible_Status; + ----------------- -- Find_Actual -- ----------------- @@ -9331,6 +9446,51 @@ end Inherit_Rep_Item_Chain; --------------------------------- + -- Inherit_Subprogram_Contract -- + --------------------------------- + + procedure Inherit_Subprogram_Contract + (Subp : Entity_Id; + From_Subp : Entity_Id) + is + procedure Inherit_Pragma (Prag_Id : Pragma_Id); + -- Propagate a pragma denoted by Prag_Id from From_Subp's contract to + -- Subp's contract. + + -------------------- + -- Inherit_Pragma -- + -------------------- + + procedure Inherit_Pragma (Prag_Id : Pragma_Id) is + Prag : constant Node_Id := Get_Pragma (From_Subp, Prag_Id); + New_Prag : Node_Id; + + begin + -- A pragma cannot be part of more than one First_Pragma/Next_Pragma + -- chains, therefore the node must be replicated. The new pragma is + -- flagged is inherited for distrinction purposes. + + if Present (Prag) then + New_Prag := New_Copy_Tree (Prag); + Set_Is_Inherited (New_Prag); + + Add_Contract_Item (New_Prag, Subp); + end if; + end Inherit_Pragma; + + -- Start of processing for Inherit_Subprogram_Contract + + begin + -- Inheritance is carried out only when both subprograms have contracts + + if Present (Contract (Subp)) + and then Present (Contract (From_Subp)) + then + Inherit_Pragma (Pragma_Extensions_Visible); + end if; + end Inherit_Subprogram_Contract; + + --------------------------------- -- Insert_Explicit_Dereference -- --------------------------------- @@ -10516,6 +10676,71 @@ end if; end Is_Expression_Function; + ----------------------- + -- Is_EVF_Expression -- + ----------------------- + + function Is_EVF_Expression (N : Node_Id) return Boolean is + Orig_N : constant Node_Id := Original_Node (N); + Alt : Node_Id; + Expr : Node_Id; + Id : Entity_Id; + + begin + -- Detect a reference to a formal parameter of a specific tagged type + -- whose related subprogram is subject to pragma Expresions_Visible with + -- value "False". + + if Is_Entity_Name (N) and then Present (Entity (N)) then + Id := Entity (N); + + return + Is_Formal (Id) + and then Is_Specific_Tagged_Type (Etype (Id)) + and then Extensions_Visible_Status (Id) = + Extensions_Visible_False; + + -- A case expression is an EVF expression when it contains at least one + -- EVF dependent_expression. Note that a case expression may have been + -- expanded, hence the use of Original_Node. + + elsif Nkind (Orig_N) = N_Case_Expression then + Alt := First (Alternatives (Orig_N)); + while Present (Alt) loop + if Is_EVF_Expression (Expression (Alt)) then + return True; + end if; + + Next (Alt); + end loop; + + -- An if expression is an EVF expression when it contains at least one + -- EVF dependent_expression. Note that an if expression may have been + -- expanded, hence the use of Original_Node. + + elsif Nkind (Orig_N) = N_If_Expression then + Expr := Next (First (Expressions (Orig_N))); + while Present (Expr) loop + if Is_EVF_Expression (Expr) then + return True; + end if; + + Next (Expr); + end loop; + + -- A qualified expression or a type conversion is an EVF expression when + -- its operand is an EVF expression. + + elsif Nkind_In (N, N_Qualified_Expression, + N_Unchecked_Type_Conversion, + N_Type_Conversion) + then + return Is_EVF_Expression (Expression (N)); + end if; + + return False; + end Is_EVF_Expression; + -------------- -- Is_False -- -------------- @@ -11885,6 +12110,27 @@ end if; end Is_SPARK_05_Object_Reference; + ----------------------------- + -- Is_Specific_Tagged_Type -- + ----------------------------- + + function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean is + Full_Typ : Entity_Id; + + begin + -- Handle private types + + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Full_Typ := Full_View (Typ); + else + Full_Typ := Typ; + end if; + + -- A specific tagged type is a non-class-wide tagged type + + return Is_Tagged_Type (Full_Typ) and not Is_Class_Wide_Type (Full_Typ); + end Is_Specific_Tagged_Type; + ------------------ -- Is_Statement -- ------------------ Index: sem_util.ads =================================================================== --- sem_util.ads (revision 216770) +++ sem_util.ads (working copy) @@ -60,6 +60,7 @@ -- Depends -- Effective_Reads -- Effective_Writes + -- Extensions_Visible -- Global -- Initial_Condition -- Initializes @@ -566,6 +567,26 @@ -- continuation lines to the message explaining why type T is limited. -- Messages are placed at node N. + type Extensions_Visible_Mode is + (Extensions_Visible_None, + -- Extensions_Visible does not yield a mode when SPARK_Mode is off. This + -- value acts as a default in a non-SPARK compilation. + + Extensions_Visible_False, + -- A value of "False" signifies that Extensions_Visible is either + -- missing or the pragma is present and the value of its Boolean + -- expression is False. + + Extensions_Visible_True); + -- A value of "True" signifies that Extensions_Visible is present and + -- the value of its Boolean expression is True. + + function Extensions_Visible_Status + (Id : Entity_Id) return Extensions_Visible_Mode; + -- Given the entity of a subprogram or formal parameter subject to pragma + -- Extensions_Visible, return the Boolean value denoted by the expression + -- of the pragma. + procedure Find_Actual (N : Node_Id; Formal : out Entity_Id; @@ -1087,6 +1108,14 @@ -- Inherit the rep item chain of type From_Typ without clobbering any -- existing rep items on Typ's chain. Typ is the destination type. + procedure Inherit_Subprogram_Contract + (Subp : Entity_Id; + From_Subp : Entity_Id); + -- Inherit relevant contract items from source subprogram From_Subp. Subp + -- denotes the destination subprogram. The inherited items are: + -- Extensions_Visible + -- ??? it would be nice if this routine handles Pre'Class and Post'Class + procedure Insert_Explicit_Dereference (N : Node_Id); -- In a context that requires a composite or subprogram type and where a -- prefix is an access type, rewrite the access type node N (which is the @@ -1208,6 +1237,16 @@ -- expression function call, and should be inlined unconditionally. Also -- used to determine that such a call does not constitute a freeze point. + function Is_EVF_Expression (N : Node_Id) return Boolean; + -- Determine whether node N denotes a reference to a formal parameter of + -- a specific tagged type whose related subprogram is subject to pragma + -- Extensions_Visible with value "False". Several other constructs fall + -- under this category: + -- 1) A qualified expression whose operand is EVF + -- 2) A type conversion whose operand is EVF + -- 3) An if expression with at least one EVF dependent_expression + -- 4) A case expression with at least one EVF dependent_expression + function Is_False (U : Uint) return Boolean; pragma Inline (Is_False); -- The argument is a Uint value which is the Boolean'Pos value of a Boolean @@ -1345,6 +1384,9 @@ -- constants, formal parameters, and selected_components of those are -- valid objects in SPARK 2005. + function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean; + -- Determine whether an arbitrary [private] type is specifically tagged + function Is_Statement (N : Node_Id) return Boolean; pragma Inline (Is_Statement); -- Check if the node N is a statement node. Note that this includes Index: sem_res.adb =================================================================== --- sem_res.adb (revision 216770) +++ sem_res.adb (working copy) @@ -3260,8 +3260,8 @@ if not Is_Aliased_View (Act) then Error_Msg_NE - ("object in prefixed call to& must be aliased" - & " (RM-2005 4.3.1 (13))", + ("object in prefixed call to& must be aliased " + & "(RM-2005 4.3.1 (13))", Prefix (Act), Nam); end if; @@ -4418,6 +4418,22 @@ end if; end if; + -- A formal parameter of a specific tagged type whose related + -- subprogram is subject to pragma Extensions_Visible with value + -- "False" cannot act as an actual in a subprogram with value + -- "True". + + if Is_EVF_Expression (A) + and then Extensions_Visible_Status (Nam) = + Extensions_Visible_True + then + Error_Msg_N + ("formal parameter with Extensions_Visible False cannot act " + & "as actual parameter", A); + Error_Msg_NE + ("\subprogram & has Extensions_Visible True", A, Nam); + end if; + Next_Actual (A); -- Case where actual is not present Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 216770) +++ sem_ch4.adb (working copy) @@ -4944,14 +4944,13 @@ procedure Analyze_Type_Conversion (N : Node_Id) is Expr : constant Node_Id := Expression (N); - T : Entity_Id; + Typ : Entity_Id; begin - -- If Conversion_OK is set, then the Etype is already set, and the - -- only processing required is to analyze the expression. This is - -- used to construct certain "illegal" conversions which are not - -- allowed by Ada semantics, but can be handled OK by Gigi, see - -- Sinfo for further details. + -- If Conversion_OK is set, then the Etype is already set, and the only + -- processing required is to analyze the expression. This is used to + -- construct certain "illegal" conversions which are not allowed by Ada + -- semantics, but can be handled by Gigi, see Sinfo for further details. if Conversion_OK (N) then Analyze (Expr); @@ -4962,9 +4961,9 @@ -- checks to make sure the argument of the conversion is appropriate. Find_Type (Subtype_Mark (N)); - T := Entity (Subtype_Mark (N)); - Set_Etype (N, T); - Check_Fully_Declared (T, N); + Typ := Entity (Subtype_Mark (N)); + Set_Etype (N, Typ); + Check_Fully_Declared (Typ, N); Analyze_Expression (Expr); Validate_Remote_Type_Type_Conversion (N); @@ -5002,7 +5001,7 @@ elsif Nkind (Expr) = N_Character_Literal then if Ada_Version = Ada_83 then - Resolve (Expr, T); + Resolve (Expr, Typ); else Error_Msg_N ("argument of conversion cannot be character literal", N); @@ -5010,14 +5009,23 @@ end if; elsif Nkind (Expr) = N_Attribute_Reference - and then - Nam_In (Attribute_Name (Expr), Name_Access, - Name_Unchecked_Access, - Name_Unrestricted_Access) + and then Nam_In (Attribute_Name (Expr), Name_Access, + Name_Unchecked_Access, + Name_Unrestricted_Access) then Error_Msg_N ("argument of conversion cannot be access", N); Error_Msg_N ("\use qualified expression instead", N); end if; + + -- A formal parameter of a specific tagged type whose related subprogram + -- is subject to pragma Extensions_Visible with value "False" cannot + -- appear in a class-wide conversion. + + if Is_Class_Wide_Type (Typ) and then Is_EVF_Expression (Expr) then + Error_Msg_N + ("formal parameter with Extensions_Visible False cannot be " + & "converted to class-wide type", Expr); + end if; end Analyze_Type_Conversion; ---------------------- @@ -7603,7 +7611,7 @@ if not Is_Aliased_View (Obj) then Error_Msg_NE ("object in prefixed call to & must be aliased " - & " (RM-2005 4.3.1 (13))", Prefix (First_Actual), Subprog); + & "(RM-2005 4.3.1 (13))", Prefix (First_Actual), Subprog); end if; Analyze (First_Actual); Index: aspects.adb =================================================================== --- aspects.adb (revision 216770) +++ aspects.adb (working copy) @@ -522,6 +522,7 @@ Aspect_Effective_Writes => Aspect_Effective_Writes, Aspect_Elaborate_Body => Aspect_Elaborate_Body, Aspect_Export => Aspect_Export, + Aspect_Extensions_Visible => Aspect_Extensions_Visible, Aspect_External_Name => Aspect_External_Name, Aspect_External_Tag => Aspect_External_Tag, Aspect_Favor_Top_Level => Aspect_Favor_Top_Level, Index: aspects.ads =================================================================== --- aspects.ads (revision 216770) +++ aspects.ads (working copy) @@ -94,6 +94,7 @@ Aspect_Dimension_System, -- GNAT Aspect_Dispatching_Domain, Aspect_Dynamic_Predicate, + Aspect_Extensions_Visible, -- GNAT Aspect_External_Name, Aspect_External_Tag, Aspect_Global, -- GNAT @@ -230,6 +231,7 @@ Aspect_Dimension_System => True, Aspect_Effective_Reads => True, Aspect_Effective_Writes => True, + Aspect_Extensions_Visible => True, Aspect_Favor_Top_Level => True, Aspect_Global => True, Aspect_Inline_Always => True, @@ -318,6 +320,7 @@ Aspect_Dimension_System => Expression, Aspect_Dispatching_Domain => Expression, Aspect_Dynamic_Predicate => Expression, + Aspect_Extensions_Visible => Optional_Expression, Aspect_External_Name => Expression, Aspect_External_Tag => Expression, Aspect_Global => Expression, @@ -408,9 +411,10 @@ Aspect_Effective_Reads => Name_Effective_Reads, Aspect_Effective_Writes => Name_Effective_Writes, Aspect_Elaborate_Body => Name_Elaborate_Body, + Aspect_Export => Name_Export, + Aspect_Extensions_Visible => Name_Extensions_Visible, Aspect_External_Name => Name_External_Name, Aspect_External_Tag => Name_External_Tag, - Aspect_Export => Name_Export, Aspect_Favor_Top_Level => Name_Favor_Top_Level, Aspect_Global => Name_Global, Aspect_Implicit_Dereference => Name_Implicit_Dereference, @@ -618,9 +622,9 @@ Aspect_Dispatching_Domain => Always_Delay, Aspect_Dynamic_Predicate => Always_Delay, Aspect_Elaborate_Body => Always_Delay, + Aspect_Export => Always_Delay, Aspect_External_Name => Always_Delay, Aspect_External_Tag => Always_Delay, - Aspect_Export => Always_Delay, Aspect_Favor_Top_Level => Always_Delay, Aspect_Implicit_Dereference => Always_Delay, Aspect_Import => Always_Delay, @@ -689,6 +693,7 @@ Aspect_Dimension_System => Never_Delay, Aspect_Effective_Reads => Never_Delay, Aspect_Effective_Writes => Never_Delay, + Aspect_Extensions_Visible => Never_Delay, Aspect_Global => Never_Delay, Aspect_Initial_Condition => Never_Delay, Aspect_Initializes => Never_Delay, Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 216770) +++ sem_ch6.adb (working copy) @@ -4074,8 +4074,12 @@ if Nam = Name_Depends then Depends := Prag; - else pragma Assert (Nam = Name_Global); + + elsif Nam = Name_Global then Global := Prag; + + -- Note that pragma Extensions_Visible has already been analyzed + end if; Prag := Next_Pragma (Prag); @@ -5696,10 +5700,12 @@ and then Present (Alias (Overridden_Subp)) and then Comes_From_Source (Alias (Overridden_Subp)) then - Set_Overridden_Operation (Subp, Alias (Overridden_Subp)); + Set_Overridden_Operation (Subp, Alias (Overridden_Subp)); + Inherit_Subprogram_Contract (Subp, Alias (Overridden_Subp)); else - Set_Overridden_Operation (Subp, Overridden_Subp); + Set_Overridden_Operation (Subp, Overridden_Subp); + Inherit_Subprogram_Contract (Subp, Overridden_Subp); end if; end if; end if; @@ -9457,9 +9463,12 @@ -- E overrides the operation from which S is inherited. if Present (Alias (S)) then - Set_Overridden_Operation (E, Alias (S)); + Set_Overridden_Operation (E, Alias (S)); + Inherit_Subprogram_Contract (E, Alias (S)); + else - Set_Overridden_Operation (E, S); + Set_Overridden_Operation (E, S); + Inherit_Subprogram_Contract (E, S); end if; if Comes_From_Source (E) then @@ -9625,7 +9634,8 @@ and then Present (Alias (E)) and then Comes_From_Source (Alias (E)) then - Set_Overridden_Operation (S, Alias (E)); + Set_Overridden_Operation (S, Alias (E)); + Inherit_Subprogram_Contract (S, Alias (E)); -- Normal case of setting entity as overridden @@ -9637,7 +9647,8 @@ -- must check whether the target is an init_proc. elsif not Is_Init_Proc (S) then - Set_Overridden_Operation (S, E); + Set_Overridden_Operation (S, E); + Inherit_Subprogram_Contract (S, E); end if; Check_Overriding_Indicator (S, E, Is_Primitive => True); @@ -9660,7 +9671,8 @@ Is_Predefined_Dispatching_Operation (Alias (E))) then if Present (Alias (E)) then - Set_Overridden_Operation (S, Alias (E)); + Set_Overridden_Operation (S, Alias (E)); + Inherit_Subprogram_Contract (S, Alias (E)); end if; end if; Index: par-prag.adb =================================================================== --- par-prag.adb (revision 216770) +++ par-prag.adb (working copy) @@ -1220,6 +1220,7 @@ Pragma_Export_Value | Pragma_Export_Valued_Procedure | Pragma_Extend_System | + Pragma_Extensions_Visible | Pragma_External | Pragma_External_Name_Casing | Pragma_Favor_Top_Level | Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 216770) +++ sem_ch13.adb (working copy) @@ -2256,6 +2256,21 @@ Insert_Pragma (Aitem); goto Continue; + -- Aspect Extensions_Visible is never delayed because it is + -- equivalent to a source pragma which appears after the + -- related subprogram. + + when Aspect_Extensions_Visible => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => Name_Extensions_Visible); + + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + -- Global -- Aspect Global is never delayed because it is equivalent to @@ -8817,6 +8832,7 @@ Aspect_Default_Initial_Condition | Aspect_Dimension | Aspect_Dimension_System | + Aspect_Extensions_Visible | Aspect_Implicit_Dereference | Aspect_Initial_Condition | Aspect_Initializes | Index: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 216770) +++ snames.ads-tmpl (working copy) @@ -494,6 +494,7 @@ Name_Export_Procedure : constant Name_Id := N + $; -- GNAT Name_Export_Value : constant Name_Id := N + $; -- GNAT Name_Export_Valued_Procedure : constant Name_Id := N + $; -- GNAT + Name_Extensions_Visible : constant Name_Id := N + $; -- GNAT Name_External : constant Name_Id := N + $; -- GNAT Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT Name_Global : constant Name_Id := N + $; -- GNAT @@ -1828,6 +1829,7 @@ Pragma_Export_Procedure, Pragma_Export_Value, Pragma_Export_Valued_Procedure, + Pragma_Extensions_Visible, Pragma_External, Pragma_Finalize_Storage_Only, Pragma_Global, --ew6BAiZeqk4r7MaW--