From d60951532b3f2386bd659afc0264e797710360c1 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 23 Apr 2013 18:07:33 +0200 Subject: [multiple changes] 2013-04-23 Hristian Kirtchev * exp_ch9.adb (Build_PPC_Wrapper): Correct the traversal of pre- and post-conditions. (Expand_N_Task_Type_Declaration): Use the correct attribute to check for pre- and post-conditions. * exp_ch13.adb (Expand_N_Freeze_Entity): Correct the traversal of pre- and post-conditions. Analyze delayed classification items. * freeze.adb (Freeze_Entity): Use the correct attribute to check for pre- and post- conditions. * sem_ch3.adb (Analyze_Declarations): Correct the traversal of pre- and post-conditions as well as contract- and test-cases. Analyze delayed pragmas Depends and Global. * sem_ch6.adb (Check_Subprogram_Contract): Use the correct attribute to check for pre- and post-conditions, as well as contract-cases and test-cases. (List_Inherited_Pre_Post_Aspects): Correct the traversal of pre- and post- conditions. (Process_Contract_Cases): Update the comment on usage. Correct the traversal of contract-cases. (Process_Post_Conditions): Update the comment on usage. Correct the traversal of pre- and post-conditions. (Process_PPCs): Correct the traversal of pre- and post-conditions. (Spec_Postconditions): Use the correct attribute to check for pre- and post- conditions, as well as contract-cases and test-cases. * sem_ch13.adb (Analyze_Aspect_Specifications): Reimplement the actions related to aspects Depends and Global. Code refactoring for pre- and post-conditions. (Insert_Delayed_Pragma): New routine. * sem_prag.adb (Add_Item): New routine. (Analyze_Depends_In_Decl_Part): New routine. (Analyze_Global_In_Decl_Part): New routine. (Analyze_Pragma): Reimplement the actions related to aspects Depends and Global. Verify that a body acts as a spec for pragma Contract_Cases. (Chain_PPC): Use Add_Contract_Item to chain a pragma. (Chain_CTC): Correct the traversal of contract- and test-cases. Use Add_Contract_Item to chain a pragma. (Chain_Contract_Cases): Correct the traversal of contract- and test-cases. Use Add_Contract_Item to chain a pragma. (Check_Precondition_Postcondition): Update the comment on usage. (Check_Test_Case): Update the comment on usage. * sem_prag.ads (Analyze_Depends_In_Decl_Part): New routine. (Analyze_Global_In_Decl_Part): New routine. * sem_util.ads, sem_util.adb (Add_Contract_Item): New routine. * sinfo.adb (Classifications): New routine. (Contract_Test_Cases): New routine. (Pre_Post_Conditions): New routine. (Set_Classifications): New routine. (Set_Contract_Test_Cases): New routine. (Set_Pre_Post_Conditions): New routine. (Set_Spec_CTC_List): Removed. (Set_Spec_PPC_List): Removed. (Spec_CTC_List): Removed. (Spec_PPC_List): Removed. * sinfo.ads: Update the structure of N_Contruct along with all related comments. (Classifications): New routine and pragma Inline. (Contract_Test_Cases): New routine and pragma Inline. (Pre_Post_Conditions): New routine and pragma Inline. (Set_Classifications): New routine and pragma Inline. (Set_Contract_Test_Cases): New routine and pragma Inline. (Set_Pre_Post_Conditions): New routine and pragma Inline. (Set_Spec_CTC_List): Removed. (Set_Spec_PPC_List): Removed. (Spec_CTC_List): Removed. (Spec_PPC_List): Removed. 2013-04-23 Doug Rupp * init.c (GNAT$STOP) [VMS]: Bump sigargs[0] count by 2 to account for LIB$STOP not having the chance to add the PC and PSL fields. From-SVN: r198198 --- gcc/ada/ChangeLog | 73 + gcc/ada/exp_ch13.adb | 14 +- gcc/ada/exp_ch9.adb | 4 +- gcc/ada/freeze.adb | 6 +- gcc/ada/init.c | 5 +- gcc/ada/sem_ch13.adb | 121 +- gcc/ada/sem_ch3.adb | 17 +- gcc/ada/sem_ch6.adb | 50 +- gcc/ada/sem_prag.adb | 16138 +++++++++++++++++++++++++------------------------ gcc/ada/sem_prag.ads | 6 + gcc/ada/sem_util.adb | 37 + gcc/ada/sem_util.ads | 5 + gcc/ada/sinfo.adb | 82 +- gcc/ada/sinfo.ads | 80 +- 14 files changed, 8451 insertions(+), 8187 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c475d59..f914728 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,76 @@ +2013-04-23 Hristian Kirtchev + + * exp_ch9.adb (Build_PPC_Wrapper): Correct the traversal of + pre- and post-conditions. + (Expand_N_Task_Type_Declaration): + Use the correct attribute to check for pre- and post-conditions. + * exp_ch13.adb (Expand_N_Freeze_Entity): Correct the traversal of + pre- and post-conditions. Analyze delayed classification items. + * freeze.adb (Freeze_Entity): Use the correct attribute to + check for pre- and post- conditions. + * sem_ch3.adb (Analyze_Declarations): Correct the traversal + of pre- and post-conditions as well as contract- and + test-cases. Analyze delayed pragmas Depends and Global. + * sem_ch6.adb (Check_Subprogram_Contract): Use the correct + attribute to check for pre- and post-conditions, as well as + contract-cases and test-cases. (List_Inherited_Pre_Post_Aspects): + Correct the traversal of pre- and post- conditions. + (Process_Contract_Cases): Update the comment on usage. Correct + the traversal of contract-cases. + (Process_Post_Conditions): Update the comment on usage. Correct the + traversal of pre- and post-conditions. + (Process_PPCs): Correct the traversal of pre- and post-conditions. + (Spec_Postconditions): Use the correct + attribute to check for pre- and post- conditions, as well as + contract-cases and test-cases. + * sem_ch13.adb (Analyze_Aspect_Specifications): Reimplement the + actions related to aspects Depends and Global. Code refactoring + for pre- and post-conditions. + (Insert_Delayed_Pragma): New routine. + * sem_prag.adb (Add_Item): New routine. + (Analyze_Depends_In_Decl_Part): New routine. + (Analyze_Global_In_Decl_Part): New routine. + (Analyze_Pragma): Reimplement the actions related to aspects Depends and + Global. Verify that a body acts as a spec for pragma Contract_Cases. + (Chain_PPC): Use Add_Contract_Item to chain a pragma. + (Chain_CTC): Correct the traversal of contract- + and test-cases. Use Add_Contract_Item to chain a pragma. + (Chain_Contract_Cases): Correct the traversal of contract- + and test-cases. Use Add_Contract_Item to chain a pragma. + (Check_Precondition_Postcondition): Update the comment on usage. + (Check_Test_Case): Update the comment on usage. + * sem_prag.ads (Analyze_Depends_In_Decl_Part): New routine. + (Analyze_Global_In_Decl_Part): New routine. + * sem_util.ads, sem_util.adb (Add_Contract_Item): New routine. + * sinfo.adb (Classifications): New routine. + (Contract_Test_Cases): New routine. + (Pre_Post_Conditions): New routine. + (Set_Classifications): New routine. + (Set_Contract_Test_Cases): New routine. + (Set_Pre_Post_Conditions): New routine. + (Set_Spec_CTC_List): Removed. + (Set_Spec_PPC_List): Removed. + (Spec_CTC_List): Removed. + (Spec_PPC_List): Removed. + * sinfo.ads: Update the structure of N_Contruct along with all + related comments. + (Classifications): New routine and pragma Inline. + (Contract_Test_Cases): New routine and pragma Inline. + (Pre_Post_Conditions): New routine and pragma Inline. + (Set_Classifications): New routine and pragma Inline. + (Set_Contract_Test_Cases): New routine and pragma Inline. + (Set_Pre_Post_Conditions): New routine and pragma Inline. + (Set_Spec_CTC_List): Removed. + (Set_Spec_PPC_List): Removed. + (Spec_CTC_List): Removed. + (Spec_PPC_List): Removed. + +2013-04-23 Doug Rupp + + * init.c (GNAT$STOP) [VMS]: Bump sigargs[0] count by 2 + to account for LIB$STOP not having the chance to add the PC and + PSL fields. + 2013-04-23 Robert Dewar * sem_ch13.adb: Minor code reorganization (remove some redundant diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index ba36805..d6525b2 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -568,9 +568,21 @@ package body Exp_Ch13 is declare Prag : Node_Id; begin - Prag := Spec_PPC_List (Contract (E)); + Prag := Pre_Post_Conditions (Contract (E)); while Present (Prag) loop Analyze_PPC_In_Decl_Part (Prag, E); + + Prag := Next_Pragma (Prag); + end loop; + + Prag := Classifications (Contract (E)); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Depends then + Analyze_Depends_In_Decl_Part (Prag); + else + Analyze_Global_In_Decl_Part (Prag); + end if; + Prag := Next_Pragma (Prag); end loop; end; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 69eaaff..84b50ac 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -1925,7 +1925,7 @@ package body Exp_Ch9 is P : Node_Id; begin - P := Spec_PPC_List (Contract (E)); + P := Pre_Post_Conditions (Contract (E)); if No (P) then return; end if; @@ -11840,7 +11840,7 @@ package body Exp_Ch9 is Ent := First_Entity (Tasktyp); while Present (Ent) loop if Ekind_In (Ent, E_Entry, E_Entry_Family) - and then Present (Spec_PPC_List (Contract (Ent))) + and then Present (Pre_Post_Conditions (Contract (Ent))) then Build_PPC_Wrapper (Ent, N); end if; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 95a73a6..d4f46fa 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3119,11 +3119,11 @@ package body Freeze is if Is_Subprogram (E) and then Is_Imported (E) and then Present (Contract (E)) - and then Present (Spec_PPC_List (Contract (E))) + and then Present (Pre_Post_Conditions (Contract (E))) then Error_Msg_NE - ("pre/post conditions on imported subprogram " - & "are not enforced??", E, Spec_PPC_List (Contract (E))); + ("pre/post conditions on imported subprogram are not " + & "enforced??", E, Pre_Post_Conditions (Contract (E))); end if; end if; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 68b4035..1b2e188 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1297,7 +1297,10 @@ void GNAT$STOP (int *sigargs) { /* Note that there are no mechargs. We rely on the fact that condtions - raised from DEClib I/O do not require an "adjust". */ + raised from DEClib I/O do not require an "adjust". Also the count + will be off by 2, since LIB$STOP didn't get a chance to add the + PC and PSL fields, so we bump it so PUTMSG comes out right. */ + sigargs [0] += 2; __gnat_handle_vms_condition (sigargs, 0); } #endif diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 8afa5099..b91dd89 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -925,6 +925,57 @@ package body Sem_Ch13 is ----------------------------------- procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is + procedure Insert_Delayed_Pragma (Prag : Node_Id); + -- Insert a postcondition-like pragma into the tree depending on the + -- context. Prag one of the following: Pre, Post, Depends or Global. + + --------------------------- + -- Insert_Delayed_Pragma -- + --------------------------- + + procedure Insert_Delayed_Pragma (Prag : Node_Id) is + Aux : Node_Id; + + begin + -- When the context is a library unit, the pragma is added to the + -- Pragmas_After list. + + if Nkind (Parent (N)) = N_Compilation_Unit then + Aux := Aux_Decls_Node (Parent (N)); + + if No (Pragmas_After (Aux)) then + Set_Pragmas_After (Aux, New_List); + end if; + + Prepend (Prag, Pragmas_After (Aux)); + + -- Pragmas associated with subprogram bodies are inserted in the + -- declarative part. + + elsif Nkind (N) = N_Subprogram_Body then + if No (Declarations (N)) then + Set_Declarations (N, New_List); + end if; + + Append (Prag, Declarations (N)); + + -- Default + + else + Insert_After (N, Prag); + + -- Analyze the pragma before analyzing the proper body of a stub. + -- This ensures that the pragma will appear on the proper contract + -- list (see N_Contract). + + if Nkind (N) = N_Subprogram_Body_Stub then + Analyze (Prag); + end if; + end if; + end Insert_Delayed_Pragma; + + -- Local variables + Aspect : Node_Id; Aitem : Node_Id; Ent : Node_Id; @@ -1535,6 +1586,8 @@ package body Sem_Ch13 is -- Aspect Depends must be delayed because it mentions names -- of inputs and output that are classified by aspect Global. + -- The aspect and pragma are treated the same way as a post + -- condition. when Aspect_Depends => Make_Aitem_Pragma @@ -1543,11 +1596,24 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Depends); + -- Decorate the aspect and pragma + + Set_Aspect_Rep_Item (Aspect, Aitem); + Set_Corresponding_Aspect (Aitem, Aspect); + Set_From_Aspect_Specification (Aitem); + Set_Is_Delayed_Aspect (Aitem); + Set_Is_Delayed_Aspect (Aspect); + Set_Parent (Aitem, Aspect); + + Insert_Delayed_Pragma (Aitem); + goto Continue; + -- Global -- Aspect Global must be delayed because it can mention names -- and benefit from the forward visibility rules applicable to - -- aspects of subprograms. + -- aspects of subprograms. The aspect and pragma are treated + -- the same way as a post condition. when Aspect_Global => Make_Aitem_Pragma @@ -1556,6 +1622,18 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Global); + -- Decorate the aspect and pragma + + Set_Aspect_Rep_Item (Aspect, Aitem); + Set_Corresponding_Aspect (Aitem, Aspect); + Set_From_Aspect_Specification (Aitem); + Set_Is_Delayed_Aspect (Aitem); + Set_Is_Delayed_Aspect (Aspect); + Set_Parent (Aitem, Aspect); + + Insert_Delayed_Pragma (Aitem); + goto Continue; + -- Relative_Deadline when Aspect_Relative_Deadline => @@ -1727,46 +1805,7 @@ package body Sem_Ch13 is -- about delay issues, since the pragmas themselves deal -- with delay of visibility for the expression analysis. - -- If the entity is a library-level subprogram, the pre/ - -- postconditions must be treated as late pragmas. Note - -- that they must be prepended, not appended, to the list, - -- so that split AND THEN sections are processed in the - -- correct order. - - if Nkind (Parent (N)) = N_Compilation_Unit then - declare - Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); - - begin - if No (Pragmas_After (Aux)) then - Set_Pragmas_After (Aux, New_List); - end if; - - Prepend (Aitem, Pragmas_After (Aux)); - end; - - -- If it is a subprogram body, add pragmas to list of - -- declarations in body. - - elsif Nkind (N) = N_Subprogram_Body then - if No (Declarations (N)) then - Set_Declarations (N, New_List); - end if; - - Append (Aitem, Declarations (N)); - - else - Insert_After (N, Aitem); - - -- Pre/Postconditions on stubs are analyzed at once, - -- because the proper body is analyzed next, and the - -- contract must be captured before the body. - - if Nkind (N) = N_Subprogram_Body_Stub then - Analyze (Aitem); - end if; - end if; - + Insert_Delayed_Pragma (Aitem); goto Continue; end; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 73ba462..e09facd 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2202,7 +2202,7 @@ package body Sem_Ch3 is -- Analyze preconditions and postconditions - Prag := Spec_PPC_List (Contract (Sent)); + Prag := Pre_Post_Conditions (Contract (Sent)); while Present (Prag) loop Analyze_PPC_In_Decl_Part (Prag, Sent); Prag := Next_Pragma (Prag); @@ -2210,12 +2210,25 @@ package body Sem_Ch3 is -- Analyze contract-cases and test-cases - Prag := Spec_CTC_List (Contract (Sent)); + Prag := Contract_Test_Cases (Contract (Sent)); while Present (Prag) loop Analyze_CTC_In_Decl_Part (Prag, Sent); Prag := Next_Pragma (Prag); end loop; + -- Analyze classification pragmas + + Prag := Classifications (Contract (Sent)); + while Present (Prag) loop + if Pragma_Name (Prag) = Name_Depends then + Analyze_Depends_In_Decl_Part (Prag); + else + Analyze_Global_In_Decl_Part (Prag); + end if; + + Prag := Next_Pragma (Prag); + end loop; + -- At this point, entities have been attached to identifiers. -- This is required to be able to detect suspicious contracts. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 43f94e1..42c9fb2 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -7091,15 +7091,15 @@ package body Sem_Ch6 is -- not considered as trivial. procedure Process_Contract_Cases (Spec : Node_Id); - -- This processes the Spec_CTC_List from Spec, processing any contract - -- case from the list. The caller has checked that Spec_CTC_List is - -- non-Empty. + -- This processes the Contract_Test_Cases from Spec, processing any + -- contract case from the list. The caller has checked that list + -- Contract_Test_Cases is non-Empty. procedure Process_Post_Conditions (Spec : Node_Id; Class : Boolean); - -- This processes the Spec_PPC_List from Spec, processing any + -- This processes the Pre_Post_Conditions from Spec, processing any -- postcondition from the list. If Class is True, then only -- postconditions marked with Class_Present are considered. The - -- caller has checked that Spec_PPC_List is non-Empty. + -- caller has checked that Pre_Post_Conditions is non-Empty. function Find_Attribute_Result is new Traverse_Func (Check_Attr_Result); @@ -7207,7 +7207,7 @@ package body Sem_Ch6 is pragma Unreferenced (Ignored); begin - Prag := Spec_CTC_List (Contract (Spec)); + Prag := Contract_Test_Cases (Contract (Spec)); loop if Pragma_Name (Prag) = Name_Contract_Cases then Aggr := @@ -7269,7 +7269,7 @@ package body Sem_Ch6 is pragma Unreferenced (Ignored); begin - Prag := Spec_PPC_List (Contract (Spec)); + Prag := Pre_Post_Conditions (Contract (Spec)); loop Arg := First (Pragma_Argument_Associations (Prag)); @@ -7322,7 +7322,7 @@ package body Sem_Ch6 is -- Process spec postconditions - if Present (Spec_PPC_List (Contract (Spec_Id))) then + if Present (Pre_Post_Conditions (Contract (Spec_Id))) then Process_Post_Conditions (Spec_Id, Class => False); end if; @@ -7333,14 +7333,14 @@ package body Sem_Ch6 is -- type. This may cause more warnings to be issued than necessary. ??? -- for J in Inherited'Range loop --- if Present (Spec_PPC_List (Contract (Inherited (J)))) then +-- if Present (Pre_Post_Conditions (Contract (Inherited (J)))) then -- Process_Post_Conditions (Inherited (J), Class => True); -- end if; -- end loop; -- Process contract cases - if Present (Spec_CTC_List (Contract (Spec_Id))) then + if Present (Contract_Test_Cases (Contract (Spec_Id))) then Process_Contract_Cases (Spec_Id); end if; @@ -9446,7 +9446,7 @@ package body Sem_Ch6 is begin for J in Inherited'Range loop - P := Spec_PPC_List (Contract (Inherited (J))); + P := Pre_Post_Conditions (Contract (Inherited (J))); while Present (P) loop Error_Msg_Sloc := Sloc (P); @@ -12033,7 +12033,7 @@ package body Sem_Ch6 is -- the body will be analyzed and converted when we scan the body -- declarations below. - Prag := Spec_PPC_List (Contract (Spec_Id)); + Prag := Pre_Post_Conditions (Contract (Spec_Id)); while Present (Prag) loop if Pragma_Name (Prag) = Name_Precondition then @@ -12062,7 +12062,7 @@ package body Sem_Ch6 is -- Now deal with inherited preconditions for J in Inherited'Range loop - Prag := Spec_PPC_List (Contract (Inherited (J))); + Prag := Pre_Post_Conditions (Contract (Inherited (J))); while Present (Prag) loop if Pragma_Name (Prag) = Name_Precondition @@ -12210,17 +12210,17 @@ package body Sem_Ch6 is if Present (Spec_Id) then Spec_Postconditions : declare procedure Process_Contract_Cases (Spec : Node_Id); - -- This processes the Spec_CTC_List from Spec, processing any - -- contract-cases from the list. The caller has checked that - -- Spec_CTC_List is non-Empty. + -- This processes the Contract_Test_Cases from Spec, processing + -- any contract-cases from the list. The caller has checked that + -- Contract_Test_Cases is non-Empty. procedure Process_Post_Conditions (Spec : Node_Id; Class : Boolean); - -- This processes the Spec_PPC_List from Spec, processing any - -- postconditions from the list. If Class is True, then only - -- postconditions marked with Class_Present are considered. - -- The caller has checked that Spec_PPC_List is non-Empty. + -- This processes the Pre_Post_Conditions from Spec, processing + -- any postconditions from the list. If Class is True, then only + -- postconditions marked with Class_Present are considered. The + -- caller has checked that Pre_Post_Conditions is non-Empty. ---------------------------- -- Process_Contract_Cases -- @@ -12230,7 +12230,7 @@ package body Sem_Ch6 is begin -- Loop through Contract_Cases pragmas from spec - Prag := Spec_CTC_List (Contract (Spec)); + Prag := Contract_Test_Cases (Contract (Spec)); loop if Pragma_Name (Prag) = Name_Contract_Cases then Expand_Contract_Cases (Prag, Spec_Id); @@ -12260,7 +12260,7 @@ package body Sem_Ch6 is -- Loop through PPC pragmas from spec - Prag := Spec_PPC_List (Contract (Spec)); + Prag := Pre_Post_Conditions (Contract (Spec)); loop if Pragma_Name (Prag) = Name_Postcondition and then (not Class or else Class_Present (Prag)) @@ -12286,20 +12286,20 @@ package body Sem_Ch6 is begin -- Process postconditions expressed as contract-cases - if Present (Spec_CTC_List (Contract (Spec_Id))) then + if Present (Contract_Test_Cases (Contract (Spec_Id))) then Process_Contract_Cases (Spec_Id); end if; -- Process spec postconditions - if Present (Spec_PPC_List (Contract (Spec_Id))) then + if Present (Pre_Post_Conditions (Contract (Spec_Id))) then Process_Post_Conditions (Spec_Id, Class => False); end if; -- Process inherited postconditions for J in Inherited'Range loop - if Present (Spec_PPC_List (Contract (Inherited (J)))) then + if Present (Pre_Post_Conditions (Contract (Inherited (J)))) then Process_Post_Conditions (Inherited (J), Class => True); end if; end loop; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 8e7c3bd..a29f526 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -168,6 +168,11 @@ package body Sem_Prag is -- Local Subprograms and Variables -- ------------------------------------- + procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id); + -- Subsidiary routine to the analysis of pragmas Depends and Global. Append + -- an input or output item to a list. If the list is empty, a new one is + -- created. + function Adjust_External_Name_Case (N : Node_Id) return Node_Id; -- This routine is used for possible casing adjustment of an explicit -- external name supplied as a string literal (the node N), according to @@ -213,6 +218,19 @@ package body Sem_Prag is -- pragma. Entity name for unit and its parents is taken from item in -- previous with_clause that mentions the unit. + -------------- + -- Add_Item -- + -------------- + + procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is + begin + if No (To_List) then + To_List := New_Elmt_List; + end if; + + Append_Unique_Elmt (Item, To_List); + end Add_Item; + ------------------------------- -- Adjust_External_Name_Case -- ------------------------------- @@ -333,9977 +351,10354 @@ package body Sem_Prag is End_Scope; end Analyze_CTC_In_Decl_Part; - ------------------------------ - -- Analyze_PPC_In_Decl_Part -- - ------------------------------ + ---------------------------------- + -- Analyze_Depends_In_Decl_Part -- + ---------------------------------- + + procedure Analyze_Depends_In_Decl_Part (N : Node_Id) is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + Loc : constant Source_Ptr := Sloc (N); + + All_Inputs_Seen : Elist_Id := No_Elist; + -- A list containing the entities of all the inputs processed so far. + -- This Elist is populated with unique entities because the same input + -- may appear in multiple input lists. + + Global_Seen : Boolean := False; + -- A flag set when pragma Global has been processed + + Outputs_Seen : Elist_Id := No_Elist; + -- A list containing the entities of all the outputs processed so far. + -- The elements of this list may come from different output lists. + + Null_Output_Seen : Boolean := False; + -- A flag used to track the legality of a null output + + Result_Seen : Boolean := False; + -- A flag set when Subp_Id'Result is processed + + Subp_Id : Entity_Id; + -- The entity of the subprogram subject to pragma Depends + + Subp_Inputs : Elist_Id := No_Elist; + Subp_Outputs : Elist_Id := No_Elist; + -- Two lists containing the full set of inputs and output of the related + -- subprograms. Note that these lists contain both nodes and entities. + + procedure Analyze_Dependency_Clause + (Clause : Node_Id; + Is_Last : Boolean); + -- Verify the legality of a single dependency clause. Flag Is_Last + -- denotes whether Clause is the last clause in the relation. + + function Appears_In + (List : Elist_Id; + Item_Id : Entity_Id) return Boolean; + -- Determine whether a particular item appears in a mixed list of nodes + -- and entities. + + procedure Check_Function_Return; + -- Verify that Funtion'Result appears as one of the outputs + + procedure Check_Mode + (Item : Node_Id; + Item_Id : Entity_Id; + Is_Input : Boolean; + Self_Ref : Boolean); + -- Ensure that an item has a proper "in", "in out" or "out" mode + -- depending on its function. If this is not the case, emit an error. + -- Item and Item_Id denote the attributes of an item. Flag Is_Input + -- should be set when item comes from an input list. Flag Self_Ref + -- should be set when the item is an output and the dependency clause + -- has operator "+". + + procedure Check_Usage + (Subp_Items : Elist_Id; + Used_Items : Elist_Id; + Is_Input : Boolean); + -- Verify that all items from Subp_Items appear in Used_Items. Emit an + -- error if this is not the case. + + procedure Collect_Subprogram_Inputs_Outputs; + -- Gather all inputs and outputs of the subprogram. These are the formal + -- parameters and entities classified in pragma Global. + + procedure Normalize_Clause (Clause : Node_Id); + -- Remove a self-dependency "+" from the input list of a clause. + -- Depending on the contents of the relation, either split the the + -- clause into multiple smaller clauses or perform the normalization in + -- place. - procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is - Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + ------------------------------- + -- Analyze_Dependency_Clause -- + ------------------------------- - begin - -- Install formals and push subprogram spec onto scope stack so that we - -- can see the formals from the pragma. + procedure Analyze_Dependency_Clause + (Clause : Node_Id; + Is_Last : Boolean) + is + procedure Analyze_Input_List (Inputs : Node_Id); + -- Verify the legality of a single input list + + procedure Analyze_Input_Output + (Item : Node_Id; + Is_Input : Boolean; + Self_Ref : Boolean; + Top_Level : Boolean; + Seen : in out Elist_Id; + Null_Seen : in out Boolean); + -- Verify the legality of a single input or output item. Flag + -- Is_Input should be set whenever Item is an input, False when it + -- denotes an output. Flag Self_Ref should be set when the item is an + -- output and the dependency clause has a "+". Flag Top_Level should + -- be set whenever Item appears immediately within an input or output + -- list. Seen is a collection of all abstract states, variables and + -- formals processed so far. Flag Null_Seen denotes whether a null + -- input or output has been encountered. - Install_Formals (S); - Push_Scope (S); + ------------------------ + -- Analyze_Input_List -- + ------------------------ - -- Preanalyze the boolean expression, we treat this as a spec expression - -- (i.e. similar to a default expression). + procedure Analyze_Input_List (Inputs : Node_Id) is + Inputs_Seen : Elist_Id := No_Elist; + -- A list containing the entities of all inputs that appear in the + -- current input list. - Preanalyze_Assert_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); + Null_Input_Seen : Boolean := False; + -- A flag used to track the legality of a null input - -- In ASIS mode, for a pragma generated from a source aspect, also - -- analyze the original aspect expression. + Input : Node_Id; - if ASIS_Mode and then Present (Corresponding_Aspect (N)) then - Preanalyze_Assert_Expression - (Expression (Corresponding_Aspect (N)), Standard_Boolean); - end if; + begin + -- Multiple inputs appear as an aggregate - -- For a class-wide condition, a reference to a controlling formal must - -- be interpreted as having the class-wide type (or an access to such) - -- so that the inherited condition can be properly applied to any - -- overriding operation (see ARM12 6.6.1 (7)). + if Nkind (Inputs) = N_Aggregate then + if Present (Component_Associations (Inputs)) then + Error_Msg_N + ("nested dependency relations not allowed", Inputs); - if Class_Present (N) then - Class_Wide_Condition : declare - T : constant Entity_Id := Find_Dispatching_Type (S); + elsif Present (Expressions (Inputs)) then + Input := First (Expressions (Inputs)); + while Present (Input) loop + Analyze_Input_Output + (Item => Input, + Is_Input => True, + Self_Ref => False, + Top_Level => False, + Seen => Inputs_Seen, + Null_Seen => Null_Input_Seen); - ACW : Entity_Id := Empty; - -- Access to T'class, created if there is a controlling formal - -- that is an access parameter. + Next (Input); + end loop; - function Get_ACW return Entity_Id; - -- If the expression has a reference to an controlling access - -- parameter, create an access to T'class for the necessary - -- conversions if one does not exist. + else + Error_Msg_N ("malformed input dependency list", Inputs); + end if; - function Process (N : Node_Id) return Traverse_Result; - -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class - -- aspect for a primitive subprogram of a tagged type T, a name - -- that denotes a formal parameter of type T is interpreted as - -- having type T'Class. Similarly, a name that denotes a formal - -- accessparameter of type access-to-T is interpreted as having - -- type access-to-T'Class. This ensures the expression is well- - -- defined for a primitive subprogram of a type descended from T. + -- Process a solitary input - ------------- - -- Get_ACW -- - ------------- + else + Analyze_Input_Output + (Item => Inputs, + Is_Input => True, + Self_Ref => False, + Top_Level => False, + Seen => Inputs_Seen, + Null_Seen => Null_Input_Seen); + end if; - function Get_ACW return Entity_Id is - Loc : constant Source_Ptr := Sloc (N); - Decl : Node_Id; + -- Detect an illegal dependency clause of the form - begin - if No (ACW) then - Decl := Make_Full_Type_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'T'), - Type_Definition => - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Class_Wide_Type (T), Loc), - All_Present => True)); + -- (null =>[+] null) - Insert_Before (Unit_Declaration_Node (S), Decl); - Analyze (Decl); - ACW := Defining_Identifier (Decl); - Freeze_Before (Unit_Declaration_Node (S), ACW); + if Null_Output_Seen and then Null_Input_Seen then + Error_Msg_N + ("null dependency clause cannot have a null input list", + Inputs); + end if; + end Analyze_Input_List; + + -------------------------- + -- Analyze_Input_Output -- + -------------------------- + + procedure Analyze_Input_Output + (Item : Node_Id; + Is_Input : Boolean; + Self_Ref : Boolean; + Top_Level : Boolean; + Seen : in out Elist_Id; + Null_Seen : in out Boolean) + is + Is_Output : constant Boolean := not Is_Input; + Grouped : Node_Id; + Item_Id : Entity_Id; + + begin + -- Multiple input or output items appear as an aggregate + + if Nkind (Item) = N_Aggregate then + if not Top_Level then + Error_Msg_N ("nested grouping of items not allowed", Item); + + elsif Present (Component_Associations (Item)) then + Error_Msg_N + ("nested dependency relations not allowed", Item); + + -- Recursively analyze the grouped items + + elsif Present (Expressions (Item)) then + Grouped := First (Expressions (Item)); + while Present (Grouped) loop + Analyze_Input_Output + (Item => Grouped, + Is_Input => Is_Input, + Self_Ref => Self_Ref, + Top_Level => False, + Seen => Seen, + Null_Seen => Null_Seen); + + Next (Grouped); + end loop; + + else + Error_Msg_N ("malformed dependency list", Item); end if; - return ACW; - end Get_ACW; + -- Process Function'Result in the context of a dependency clause - ------------- - -- Process -- - ------------- + elsif Nkind (Item) = N_Attribute_Reference + and then Attribute_Name (Item) = Name_Result + then + -- It is sufficent to analyze the prefix of 'Result in order to + -- establish legality of the attribute. - function Process (N : Node_Id) return Traverse_Result is - Loc : constant Source_Ptr := Sloc (N); - Typ : Entity_Id; + Analyze (Prefix (Item)); - begin - if Is_Entity_Name (N) - and then Is_Formal (Entity (N)) - and then Nkind (Parent (N)) /= N_Type_Conversion + -- The prefix of 'Result must denote the function for which + -- aspect/pragma Depends applies. + + if not Is_Entity_Name (Prefix (Item)) + or else Ekind (Subp_Id) /= E_Function + or else Entity (Prefix (Item)) /= Subp_Id then - if Etype (Entity (N)) = T then - Typ := Class_Wide_Type (T); + Error_Msg_Name_1 := Name_Result; + Error_Msg_N + ("prefix of attribute % must denote the enclosing " + & "function", Item); - elsif Is_Access_Type (Etype (Entity (N))) - and then Designated_Type (Etype (Entity (N))) = T - then - Typ := Get_ACW; - else - Typ := Empty; - end if; + -- Function'Result is allowed to appear on the output side of a + -- dependency clause. - if Present (Typ) then - Rewrite (N, - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (Typ, Loc), - Expression => New_Occurrence_Of (Entity (N), Loc))); - Set_Etype (N, Typ); + elsif Is_Input then + Error_Msg_N ("function result cannot act as input", Item); + + else + Result_Seen := True; + end if; + + -- Detect multiple uses of null in a single dependency list or + -- throughout the whole relation. Verify the placement of a null + -- output list relative to the other clauses. + + elsif Nkind (Item) = N_Null then + if Null_Seen then + Error_Msg_N + ("multiple null dependency relations not allowed", Item); + else + Null_Seen := True; + + if Is_Output and then not Is_Last then + Error_Msg_N + ("null output list must be the last clause in a " + & "dependency relation", Item); end if; end if; - return OK; - end Process; + -- Default case - procedure Replace_Type is new Traverse_Proc (Process); + else + Analyze (Item); - -- Start of processing for Class_Wide_Condition + -- Find the entity of the item. If this is a renaming, climb + -- the renaming chain to reach the root object. Renamings of + -- non-entire objects do not yield an entity (Empty). - begin - if not Present (T) then - Error_Msg_Name_1 := - Chars (Identifier (Corresponding_Aspect (N))); + Item_Id := Entity_Of (Item); - Error_Msg_Name_2 := Name_Class; + if Present (Item_Id) then + if Ekind_In (Item_Id, E_Abstract_State, + E_In_Parameter, + E_In_Out_Parameter, + E_Out_Parameter, + E_Variable) + then + -- Ensure that the item is of the correct mode depending + -- on its function. - Error_Msg_N - ("aspect `%''%` can only be specified for a primitive " - & "operation of a tagged type", Corresponding_Aspect (N)); - end if; + Check_Mode (Item, Item_Id, Is_Input, Self_Ref); - Replace_Type (Get_Pragma_Arg (Arg1)); - end Class_Wide_Condition; - end if; + -- Detect multiple uses of the same state, variable or + -- formal parameter. If this is not the case, add the + -- item to the list of processed relations. - -- Remove the subprogram from the scope stack now that the pre-analysis - -- of the precondition/postcondition is done. + if Contains (Seen, Item_Id) then + Error_Msg_N ("duplicate use of item", Item); + else + Add_Item (Item_Id, Seen); + end if; - End_Scope; - end Analyze_PPC_In_Decl_Part; + -- Detect an illegal use of an input related to a null + -- output. Such input items cannot appear in other input + -- lists. - -------------------- - -- Analyze_Pragma -- - -------------------- + if Null_Output_Seen + and then Contains (All_Inputs_Seen, Item_Id) + then + Error_Msg_N + ("input of a null output list appears in multiple " + & "input lists", Item); + else + Add_Item (Item_Id, All_Inputs_Seen); + end if; - procedure Analyze_Pragma (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Prag_Id : Pragma_Id; + -- When the item renames an entire object, replace the + -- item with a reference to the object. - Pname : Name_Id; - -- Name of the source pragma, or name of the corresponding aspect for - -- pragmas which originate in a source aspect. In the latter case, the - -- name may be different from the pragma name. + if Present (Renamed_Object (Entity (Item))) then + Rewrite (Item, + New_Reference_To (Item_Id, Sloc (Item))); + Analyze (Item); + end if; - Pragma_Exit : exception; - -- This exception is used to exit pragma processing completely. It is - -- used when an error is detected, and no further processing is - -- required. It is also used if an earlier error has left the tree in - -- a state where the pragma should not be processed. + -- All other input/output items are illegal - Arg_Count : Nat; - -- Number of pragma argument associations + else + Error_Msg_N + ("item must denote variable, state or formal " + & "parameter", Item); + end if; - Arg1 : Node_Id; - Arg2 : Node_Id; - Arg3 : Node_Id; - Arg4 : Node_Id; - -- First four pragma arguments (pragma argument association nodes, or - -- Empty if the corresponding argument does not exist). + -- All other input/output items are illegal - type Name_List is array (Natural range <>) of Name_Id; - type Args_List is array (Natural range <>) of Node_Id; - -- Types used for arguments to Check_Arg_Order and Gather_Associations + else + Error_Msg_N + ("item must denote variable, state or formal parameter", + Item); + end if; + end if; + end Analyze_Input_Output; - procedure Ada_2005_Pragma; - -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In - -- Ada 95 mode, these are implementation defined pragmas, so should be - -- caught by the No_Implementation_Pragmas restriction. + -- Local variables - procedure Ada_2012_Pragma; - -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05. - -- In Ada 95 or 05 mode, these are implementation defined pragmas, so - -- should be caught by the No_Implementation_Pragmas restriction. + Inputs : Node_Id; + Output : Node_Id; + Self_Ref : Boolean; - procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id); - -- Subsidiary routine to the analysis of pragmas Depends and Global. - -- Append an input or output item to a list. If the list is empty, a - -- new one is created. + -- Start of processing for Analyze_Dependency_Clause - procedure Check_Ada_83_Warning; - -- Issues a warning message for the current pragma if operating in Ada - -- 83 mode (used for language pragmas that are not a standard part of - -- Ada 83). This procedure does not raise Error_Pragma. Also notes use - -- of 95 pragma. + begin + Inputs := Expression (Clause); + Self_Ref := False; - procedure Check_Arg_Count (Required : Nat); - -- Check argument count for pragma is equal to given parameter. If not, - -- then issue an error message and raise Pragma_Exit. + -- An input list with a self-dependency appears as operator "+" where + -- the actuals inputs are the right operand. - -- Note: all routines whose name is Check_Arg_Is_xxx take an argument - -- Arg which can either be a pragma argument association, in which case - -- the check is applied to the expression of the association or an - -- expression directly. + if Nkind (Inputs) = N_Op_Plus then + Inputs := Right_Opnd (Inputs); + Self_Ref := True; + end if; - procedure Check_Arg_Is_External_Name (Arg : Node_Id); - -- Check that an argument has the right form for an EXTERNAL_NAME - -- parameter of an extended import/export pragma. The rule is that the - -- name must be an identifier or string literal (in Ada 83 mode) or a - -- static string expression (in Ada 95 mode). + -- Process the output_list of a dependency_clause - procedure Check_Arg_Is_Identifier (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is an - -- identifier. If not give error and raise Pragma_Exit. + Output := First (Choices (Clause)); + while Present (Output) loop + Analyze_Input_Output + (Item => Output, + Is_Input => False, + Self_Ref => Self_Ref, + Top_Level => True, + Seen => Outputs_Seen, + Null_Seen => Null_Output_Seen); - procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is an integer - -- literal. If not give error and raise Pragma_Exit. + Next (Output); + end loop; - procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it has the proper - -- syntactic form for a local name and meets the semantic requirements - -- for a local name. The local name is analyzed as part of the - -- processing for this call. In addition, the local name is required - -- to represent an entity at the library level. + -- Process the input_list of a dependency_clause - procedure Check_Arg_Is_Local_Name (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it has the proper - -- syntactic form for a local name and meets the semantic requirements - -- for a local name. The local name is analyzed as part of the - -- processing for this call. + Analyze_Input_List (Inputs); + end Analyze_Dependency_Clause; - procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is a valid - -- locking policy name. If not give error and raise Pragma_Exit. + ---------------- + -- Appears_In -- + ---------------- - procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is a valid - -- elaboration policy name. If not give error and raise Pragma_Exit. + function Appears_In + (List : Elist_Id; + Item_Id : Entity_Id) return Boolean + is + Elmt : Elmt_Id; + Id : Entity_Id; - procedure Check_Arg_Is_One_Of - (Arg : Node_Id; - N1, N2 : Name_Id); - procedure Check_Arg_Is_One_Of - (Arg : Node_Id; - N1, N2, N3 : Name_Id); - procedure Check_Arg_Is_One_Of - (Arg : Node_Id; - N1, N2, N3, N4 : Name_Id); - procedure Check_Arg_Is_One_Of - (Arg : Node_Id; - N1, N2, N3, N4, N5 : Name_Id); - -- Check the specified argument Arg to make sure that it is an - -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if - -- present). If not then give error and raise Pragma_Exit. + begin + if Present (List) then + Elmt := First_Elmt (List); + while Present (Elmt) loop + if Nkind (Node (Elmt)) = N_Defining_Identifier then + Id := Node (Elmt); + else + Id := Entity (Node (Elmt)); + end if; - procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is a valid - -- queuing policy name. If not give error and raise Pragma_Exit. + if Id = Item_Id then + return True; + end if; - procedure Check_Arg_Is_Static_Expression - (Arg : Node_Id; - Typ : Entity_Id := Empty); - -- Check the specified argument Arg to make sure that it is a static - -- expression of the given type (i.e. it will be analyzed and resolved - -- using this type, which can be any valid argument to Resolve, e.g. - -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If - -- Typ is left Empty, then any static expression is allowed. + Next_Elmt (Elmt); + end loop; + end if; - procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is a valid task - -- dispatching policy name. If not give error and raise Pragma_Exit. + return False; + end Appears_In; - procedure Check_Arg_Order (Names : Name_List); - -- Checks for an instance of two arguments with identifiers for the - -- current pragma which are not in the sequence indicated by Names, - -- and if so, generates a fatal message about bad order of arguments. + ---------------------------- + -- Check_Function_Return -- + ---------------------------- - procedure Check_At_Least_N_Arguments (N : Nat); - -- Check there are at least N arguments present + procedure Check_Function_Return is + begin + if Ekind (Subp_Id) = E_Function and then not Result_Seen then + Error_Msg_NE + ("result of & must appear in exactly one output list", + N, Subp_Id); + end if; + end Check_Function_Return; - procedure Check_At_Most_N_Arguments (N : Nat); - -- Check there are no more than N arguments present + ---------------- + -- Check_Mode -- + ---------------- - procedure Check_Component - (Comp : Node_Id; - UU_Typ : Entity_Id; - In_Variant_Part : Boolean := False); - -- Examine an Unchecked_Union component for correct use of per-object - -- constrained subtypes, and for restrictions on finalizable components. - -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part - -- should be set when Comp comes from a record variant. + procedure Check_Mode + (Item : Node_Id; + Item_Id : Entity_Id; + Is_Input : Boolean; + Self_Ref : Boolean) + is + begin + -- Input - procedure Check_Test_Case; - -- Called to process a test-case pragma. It starts with checking pragma - -- arguments, and the rest of the treatment is similar to the one for - -- pre- and postcondition in Check_Precondition_Postcondition, except - -- the placement rules for the test-case pragma are stricter. These - -- pragmas may only occur after a subprogram spec declared directly - -- in a package spec unit. In this case, the pragma is chained to the - -- subprogram in question (using Spec_CTC_List and Next_Pragma) and - -- analysis of the pragma is delayed till the end of the spec. In all - -- other cases, an error message for bad placement is given. + if Is_Input then + if Ekind (Item_Id) = E_Out_Parameter + or else (Global_Seen + and then not Appears_In (Subp_Inputs, Item_Id)) + then + Error_Msg_NE + ("item & must have mode in or in out", Item, Item_Id); + end if; - procedure Check_Duplicate_Pragma (E : Entity_Id); - -- Check if a rep item of the same name as the current pragma is already - -- chained as a rep pragma to the given entity. If so give a message - -- about the duplicate, and then raise Pragma_Exit so does not return. + -- Self-referential output - procedure Check_Duplicated_Export_Name (Nam : Node_Id); - -- Nam is an N_String_Literal node containing the external name set by - -- an Import or Export pragma (or extended Import or Export pragma). - -- This procedure checks for possible duplications if this is the export - -- case, and if found, issues an appropriate error message. + elsif Self_Ref then - procedure Check_Expr_Is_Static_Expression - (Expr : Node_Id; - Typ : Entity_Id := Empty); - -- Check the specified expression Expr to make sure that it is a static - -- expression of the given type (i.e. it will be analyzed and resolved - -- using this type, which can be any valid argument to Resolve, e.g. - -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If - -- Typ is left Empty, then any static expression is allowed. + -- A self-referential state or variable must appear in both input + -- and output lists of a subprogram. - procedure Check_First_Subtype (Arg : Node_Id); - -- Checks that Arg, whose expression is an entity name, references a - -- first subtype. + if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then + if Global_Seen + and then not + (Appears_In (Subp_Inputs, Item_Id) + and then + Appears_In (Subp_Outputs, Item_Id)) + then + Error_Msg_NE ("item & must have mode in out", Item, Item_Id); + end if; - procedure Check_Identifier (Arg : Node_Id; Id : Name_Id); - -- Checks that the given argument has an identifier, and if so, requires - -- it to match the given identifier name. If there is no identifier, or - -- a non-matching identifier, then an error message is given and - -- Pragma_Exit is raised. + -- Self-referential parameter - procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); - -- Checks that the given argument has an identifier, and if so, requires - -- it to match one of the given identifier names. If there is no - -- identifier, or a non-matching identifier, then an error message is - -- given and Pragma_Exit is raised. + elsif Ekind (Item_Id) /= E_In_Out_Parameter then + Error_Msg_NE ("item & must have mode in out", Item, Item_Id); + end if; - procedure Check_In_Main_Program; - -- Common checks for pragmas that appear within a main program - -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU). + -- Regular output - procedure Check_Interrupt_Or_Attach_Handler; - -- Common processing for first argument of pragma Interrupt_Handler or - -- pragma Attach_Handler. + elsif Ekind (Item_Id) = E_In_Parameter + or else + (Global_Seen and then not Appears_In (Subp_Outputs, Item_Id)) + then + Error_Msg_NE + ("item & must have mode out or in out", Item, Item_Id); + end if; + end Check_Mode; - procedure Check_Loop_Pragma_Placement; - -- Verify whether pragma Loop_Invariant or Loop_Optimize or Loop_Variant - -- appear immediately within a construct restricted to loops. + ----------------- + -- Check_Usage -- + ----------------- - procedure Check_Is_In_Decl_Part_Or_Package_Spec; - -- Check that pragma appears in a declarative part, or in a package - -- specification, i.e. that it does not occur in a statement sequence - -- in a body. + procedure Check_Usage + (Subp_Items : Elist_Id; + Used_Items : Elist_Id; + Is_Input : Boolean) + is + procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id); + -- Emit an error concerning the erroneous usage of an item - procedure Check_No_Identifier (Arg : Node_Id); - -- Checks that the given argument does not have an identifier. If - -- an identifier is present, then an error message is issued, and - -- Pragma_Exit is raised. + ----------------- + -- Usage_Error -- + ----------------- - procedure Check_No_Identifiers; - -- Checks that none of the arguments to the pragma has an identifier. - -- If any argument has an identifier, then an error message is issued, - -- and Pragma_Exit is raised. + procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is + begin + if Is_Input then + Error_Msg_NE + ("item & must appear in at least one input list of aspect " + & "Depends", Item, Item_Id); + else + Error_Msg_NE + ("item & must appear in exactly one output list of aspect " + & "Depends", Item, Item_Id); + end if; + end Usage_Error; - procedure Check_No_Link_Name; - -- Checks that no link name is specified + -- Local variables - procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); - -- Checks if the given argument has an identifier, and if so, requires - -- it to match the given identifier name. If there is a non-matching - -- identifier, then an error message is given and Pragma_Exit is raised. + Elmt : Elmt_Id; + Item : Node_Id; + Item_Id : Entity_Id; - procedure Check_Optional_Identifier (Arg : Node_Id; Id : String); - -- Checks if the given argument has an identifier, and if so, requires - -- it to match the given identifier name. If there is a non-matching - -- identifier, then an error message is given and Pragma_Exit is raised. - -- In this version of the procedure, the identifier name is given as - -- a string with lower case letters. + -- Start of processing for Check_Usage - procedure Check_Precondition_Postcondition (In_Body : out Boolean); - -- Called to process a precondition or postcondition pragma. There are - -- three cases: - -- - -- The pragma appears after a subprogram spec - -- - -- If the corresponding check is not enabled, the pragma is analyzed - -- but otherwise ignored and control returns with In_Body set False. - -- - -- If the check is enabled, then the first step is to analyze the - -- pragma, but this is skipped if the subprogram spec appears within - -- a package specification (because this is the case where we delay - -- analysis till the end of the spec). Then (whether or not it was - -- analyzed), the pragma is chained to the subprogram in question - -- (using Spec_PPC_List and Next_Pragma) and control returns to the - -- caller with In_Body set False. - -- - -- The pragma appears at the start of subprogram body declarations - -- - -- In this case an immediate return to the caller is made with - -- In_Body set True, and the pragma is NOT analyzed. - -- - -- In all other cases, an error message for bad placement is given + begin + if No (Subp_Items) then + return; + end if; - procedure Check_Static_Constraint (Constr : Node_Id); - -- Constr is a constraint from an N_Subtype_Indication node from a - -- component constraint in an Unchecked_Union type. This routine checks - -- that the constraint is static as required by the restrictions for - -- Unchecked_Union. + -- Each input or output of the subprogram must appear in a dependency + -- relation. - procedure Check_Valid_Configuration_Pragma; - -- Legality checks for placement of a configuration pragma + Elmt := First_Elmt (Subp_Items); + while Present (Elmt) loop + Item := Node (Elmt); - procedure Check_Valid_Library_Unit_Pragma; - -- Legality checks for library unit pragmas. A special case arises for - -- pragmas in generic instances that come from copies of the original - -- library unit pragmas in the generic templates. In the case of other - -- than library level instantiations these can appear in contexts which - -- would normally be invalid (they only apply to the original template - -- and to library level instantiations), and they are simply ignored, - -- which is implemented by rewriting them as null statements. + if Nkind (Item) = N_Defining_Identifier then + Item_Id := Item; + else + Item_Id := Entity (Item); + end if; - procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id); - -- Check an Unchecked_Union variant for lack of nested variants and - -- presence of at least one component. UU_Typ is the related Unchecked_ - -- Union type. + -- The item does not appear in a dependency - procedure Error_Pragma (Msg : String); - pragma No_Return (Error_Pragma); - -- Outputs error message for current pragma. The message contains a % - -- that will be replaced with the pragma name, and the flag is placed - -- on the pragma itself. Pragma_Exit is then raised. Note: this routine - -- calls Fix_Error (see spec of that procedure for details). + if not Contains (Used_Items, Item_Id) then + if Is_Formal (Item_Id) then + Usage_Error (Item, Item_Id); - procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id); - pragma No_Return (Error_Pragma_Arg); - -- Outputs error message for current pragma. The message may contain - -- a % that will be replaced with the pragma name. The parameter Arg - -- may either be a pragma argument association, in which case the flag - -- is placed on the expression of this association, or an expression, - -- in which case the flag is placed directly on the expression. The - -- message is placed using Error_Msg_N, so the message may also contain - -- an & insertion character which will reference the given Arg value. - -- After placing the message, Pragma_Exit is raised. Note: this routine - -- calls Fix_Error (see spec of that procedure for details). + -- States and global variables are not used properly only when + -- the subprogram is subject to pragma Global. - procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id); - pragma No_Return (Error_Pragma_Arg); - -- Similar to above form of Error_Pragma_Arg except that two messages - -- are provided, the second is a continuation comment starting with \. + elsif Global_Seen then + Usage_Error (Item, Item_Id); + end if; + end if; - procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id); - pragma No_Return (Error_Pragma_Arg_Ident); - -- Outputs error message for current pragma. The message may contain - -- a % that will be replaced with the pragma name. The parameter Arg - -- must be a pragma argument association with a non-empty identifier - -- (i.e. its Chars field must be set), and the error message is placed - -- on the identifier. The message is placed using Error_Msg_N so - -- the message may also contain an & insertion character which will - -- reference the identifier. After placing the message, Pragma_Exit - -- is raised. Note: this routine calls Fix_Error (see spec of that - -- procedure for details). + Next_Elmt (Elmt); + end loop; + end Check_Usage; - procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id); - pragma No_Return (Error_Pragma_Ref); - -- Outputs error message for current pragma. The message may contain - -- a % that will be replaced with the pragma name. The parameter Ref - -- must be an entity whose name can be referenced by & and sloc by #. - -- After placing the message, Pragma_Exit is raised. Note: this routine - -- calls Fix_Error (see spec of that procedure for details). + --------------------------------------- + -- Collect_Subprogram_Inputs_Outputs -- + --------------------------------------- - function Find_Lib_Unit_Name return Entity_Id; - -- Used for a library unit pragma to find the entity to which the - -- library unit pragma applies, returns the entity found. + procedure Collect_Subprogram_Inputs_Outputs is + procedure Collect_Global_List + (List : Node_Id; + Mode : Name_Id := Name_Input); + -- Collect all relevant items from a global list - procedure Find_Program_Unit_Name (Id : Node_Id); - -- If the pragma is a compilation unit pragma, the id must denote the - -- compilation unit in the same compilation, and the pragma must appear - -- in the list of preceding or trailing pragmas. If it is a program - -- unit pragma that is not a compilation unit pragma, then the - -- identifier must be visible. + ------------------------- + -- Collect_Global_List -- + ------------------------- - function Find_Unique_Parameterless_Procedure - (Name : Entity_Id; - Arg : Node_Id) return Entity_Id; - -- Used for a procedure pragma to find the unique parameterless - -- procedure identified by Name, returns it if it exists, otherwise - -- errors out and uses Arg as the pragma argument for the message. + procedure Collect_Global_List + (List : Node_Id; + Mode : Name_Id := Name_Input) + is + procedure Collect_Global_Item + (Item : Node_Id; + Mode : Name_Id); + -- Add an item to the proper subprogram input or output collection - procedure Fix_Error (Msg : in out String); - -- This is called prior to issuing an error message. Msg is a string - -- that typically contains the substring "pragma". If the pragma comes - -- from an aspect, each such "pragma" substring is replaced with the - -- characters "aspect", and Error_Msg_Name_1 is set to the name of the - -- aspect (which may be different from the pragma name). If the current - -- pragma results from rewriting another pragma, then Error_Msg_Name_1 - -- is set to the original pragma name. + ------------------------- + -- Collect_Global_Item -- + ------------------------- - procedure Gather_Associations - (Names : Name_List; - Args : out Args_List); - -- This procedure is used to gather the arguments for a pragma that - -- permits arbitrary ordering of parameters using the normal rules - -- for named and positional parameters. The Names argument is a list - -- of Name_Id values that corresponds to the allowed pragma argument - -- association identifiers in order. The result returned in Args is - -- a list of corresponding expressions that are the pragma arguments. - -- Note that this is a list of expressions, not of pragma argument - -- associations (Gather_Associations has completely checked all the - -- optional identifiers when it returns). An entry in Args is Empty - -- on return if the corresponding argument is not present. + procedure Collect_Global_Item + (Item : Node_Id; + Mode : Name_Id) + is + begin + if Nam_In (Mode, Name_In_Out, Name_Input) then + Add_Item (Item, Subp_Inputs); + end if; - procedure GNAT_Pragma; - -- Called for all GNAT defined pragmas to check the relevant restriction - -- (No_Implementation_Pragmas). + if Nam_In (Mode, Name_In_Out, Name_Output) then + Add_Item (Item, Subp_Outputs); + end if; + end Collect_Global_Item; - procedure S14_Pragma; - -- Called for all pragmas defined for formal verification to check that - -- the S14_Extensions flag is set. - -- This name needs fixing ??? There is no such thing as an - -- "S14_Extensions" flag ??? + -- Local variables - function Is_Before_First_Decl - (Pragma_Node : Node_Id; - Decls : List_Id) return Boolean; - -- Return True if Pragma_Node is before the first declarative item in - -- Decls where Decls is the list of declarative items. + Assoc : Node_Id; + Item : Node_Id; - function Is_Configuration_Pragma return Boolean; - -- Determines if the placement of the current pragma is appropriate - -- for a configuration pragma. + -- Start of processing for Collect_Global_List - function Is_In_Context_Clause return Boolean; - -- Returns True if pragma appears within the context clause of a unit, - -- and False for any other placement (does not generate any messages). + begin + -- Single global item declaration - function Is_Static_String_Expression (Arg : Node_Id) return Boolean; - -- Analyzes the argument, and determines if it is a static string - -- expression, returns True if so, False if non-static or not String. + if Nkind_In (List, N_Identifier, N_Selected_Component) then + Collect_Global_Item (List, Mode); - procedure Pragma_Misplaced; - pragma No_Return (Pragma_Misplaced); - -- Issue fatal error message for misplaced pragma + -- Simple global list or moded global list declaration - procedure Process_Atomic_Shared_Volatile; - -- Common processing for pragmas Atomic, Shared, Volatile. Note that - -- Shared is an obsolete Ada 83 pragma, treated as being identical - -- in effect to pragma Atomic. + else + if Present (Expressions (List)) then + Item := First (Expressions (List)); + while Present (Item) loop + Collect_Global_Item (Item, Mode); - procedure Process_Compile_Time_Warning_Or_Error; - -- Common processing for Compile_Time_Error and Compile_Time_Warning + Next (Item); + end loop; - procedure Process_Convention - (C : out Convention_Id; - Ent : out Entity_Id); - -- Common processing for Convention, Interface, Import and Export. - -- Checks first two arguments of pragma, and sets the appropriate - -- convention value in the specified entity or entities. On return - -- C is the convention, Ent is the referenced entity. + else + Assoc := First (Component_Associations (List)); + while Present (Assoc) loop + Collect_Global_List + (List => Expression (Assoc), + Mode => Chars (First (Choices (Assoc)))); - procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id); - -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is - -- Name_Suppress for Disable and Name_Unsuppress for Enable. + Next (Assoc); + end loop; + end if; + end if; + end Collect_Global_List; - procedure Process_Extended_Import_Export_Exception_Pragma - (Arg_Internal : Node_Id; - Arg_External : Node_Id; - Arg_Form : Node_Id; - Arg_Code : Node_Id); - -- Common processing for the pragmas Import/Export_Exception. The three - -- arguments correspond to the three named parameters of the pragma. An - -- argument is empty if the corresponding parameter is not present in - -- the pragma. + -- Local variables - procedure Process_Extended_Import_Export_Object_Pragma - (Arg_Internal : Node_Id; - Arg_External : Node_Id; - Arg_Size : Node_Id); - -- Common processing for the pragmas Import/Export_Object. The three - -- arguments correspond to the three named parameters of the pragmas. An - -- argument is empty if the corresponding parameter is not present in - -- the pragma. + Formal : Entity_Id; + Global : Node_Id; + List : Node_Id; - procedure Process_Extended_Import_Export_Internal_Arg - (Arg_Internal : Node_Id := Empty); - -- Common processing for all extended Import and Export pragmas. The - -- argument is the pragma parameter for the Internal argument. If - -- Arg_Internal is empty or inappropriate, an error message is posted. - -- Otherwise, on normal return, the Entity_Field of Arg_Internal is - -- set to identify the referenced entity. + -- Start of processing for Collect_Subprogram_Inputs_Outputs - procedure Process_Extended_Import_Export_Subprogram_Pragma - (Arg_Internal : Node_Id; - Arg_External : Node_Id; - Arg_Parameter_Types : Node_Id; - Arg_Result_Type : Node_Id := Empty; - Arg_Mechanism : Node_Id; - Arg_Result_Mechanism : Node_Id := Empty; - Arg_First_Optional_Parameter : Node_Id := Empty); - -- Common processing for all extended Import and Export pragmas applying - -- to subprograms. The caller omits any arguments that do not apply to - -- the pragma in question (for example, Arg_Result_Type can be non-Empty - -- only in the Import_Function and Export_Function cases). The argument - -- names correspond to the allowed pragma association identifiers. + begin + -- Process all formal parameters - procedure Process_Generic_List; - -- Common processing for Share_Generic and Inline_Generic + Formal := First_Formal (Subp_Id); + while Present (Formal) loop + if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then + Add_Item (Formal, Subp_Inputs); + end if; - procedure Process_Import_Or_Interface; - -- Common processing for Import of Interface + if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then + Add_Item (Formal, Subp_Outputs); + end if; - procedure Process_Import_Predefined_Type; - -- Processing for completing a type with pragma Import. This is used - -- to declare types that match predefined C types, especially for cases - -- without corresponding Ada predefined type. + Next_Formal (Formal); + end loop; - type Inline_Status is (Suppressed, Disabled, Enabled); - -- Inline status of a subprogram, indicated as follows: - -- Suppressed: inlining is suppressed for the subprogram - -- Disabled: no inlining is requested for the subprogram - -- Enabled: inlining is requested/required for the subprogram + -- If the subprogram is subject to pragma Global, traverse all global + -- lists and gather the relevant items. - procedure Process_Inline (Status : Inline_Status); - -- Common processing for Inline, Inline_Always and No_Inline. Parameter - -- indicates the inline status specified by the pragma. + Global := Find_Aspect (Subp_Id, Aspect_Global); + if Present (Global) then + Global_Seen := True; - procedure Process_Interface_Name - (Subprogram_Def : Entity_Id; - Ext_Arg : Node_Id; - Link_Arg : Node_Id); - -- Given the last two arguments of pragma Import, pragma Export, or - -- pragma Interface_Name, performs validity checks and sets the - -- Interface_Name field of the given subprogram entity to the - -- appropriate external or link name, depending on the arguments given. - -- Ext_Arg is always present, but Link_Arg may be missing. Note that - -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and - -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg - -- nor Link_Arg is present, the interface name is set to the default - -- from the subprogram name. + -- Retrieve the pragma as it contains the analyzed lists - procedure Process_Interrupt_Or_Attach_Handler; - -- Common processing for Interrupt and Attach_Handler pragmas + Global := Aspect_Rep_Item (Global); - procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean); - -- Common processing for Restrictions and Restriction_Warnings pragmas. - -- Warn is True for Restriction_Warnings, or for Restrictions if the - -- flag Treat_Restrictions_As_Warnings is set, and False if this flag - -- is not set in the Restrictions case. + -- The pragma may not have been analyzed because of the arbitrary + -- declaration order of aspects. Make sure that it is analyzed for + -- the purposes of item extraction. - procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); - -- Common processing for Suppress and Unsuppress. The boolean parameter - -- Suppress_Case is True for the Suppress case, and False for the - -- Unsuppress case. + if not Analyzed (Global) then + Analyze_Global_In_Decl_Part (Global); + end if; - procedure Set_Exported (E : Entity_Id; Arg : Node_Id); - -- This procedure sets the Is_Exported flag for the given entity, - -- checking that the entity was not previously imported. Arg is - -- the argument that specified the entity. A check is also made - -- for exporting inappropriate entities. + List := + Expression (First (Pragma_Argument_Associations (Global))); - procedure Set_Extended_Import_Export_External_Name - (Internal_Ent : Entity_Id; - Arg_External : Node_Id); - -- Common processing for all extended import export pragmas. The first - -- argument, Internal_Ent, is the internal entity, which has already - -- been checked for validity by the caller. Arg_External is from the - -- Import or Export pragma, and may be null if no External parameter - -- was present. If Arg_External is present and is a non-null string - -- (a null string is treated as the default), then the Interface_Name - -- field of Internal_Ent is set appropriately. + -- Nothing to be done for a null global list - procedure Set_Imported (E : Entity_Id); - -- This procedure sets the Is_Imported flag for the given entity, - -- checking that it is not previously exported or imported. + if Nkind (List) /= N_Null then + Collect_Global_List (List); + end if; + end if; + end Collect_Subprogram_Inputs_Outputs; - procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id); - -- Mech is a parameter passing mechanism (see Import_Function syntax - -- for MECHANISM_NAME). This routine checks that the mechanism argument - -- has the right form, and if not issues an error message. If the - -- argument has the right form then the Mechanism field of Ent is - -- set appropriately. + ---------------------- + -- Normalize_Clause -- + ---------------------- - procedure Set_Rational_Profile; - -- Activate the set of configuration pragmas and permissions that make - -- up the Rational profile. + procedure Normalize_Clause (Clause : Node_Id) is + procedure Create_Or_Modify_Clause + (Output : Node_Id; + Outputs : Node_Id; + Inputs : Node_Id; + After : Node_Id; + In_Place : Boolean; + Multiple : Boolean); + -- Create a brand new clause to represent the self-reference or + -- modify the input and/or output lists of an existing clause. Output + -- denotes a self-referencial output. Outputs is the output list of a + -- clause. Inputs is the input list of a clause. After denotes the + -- clause after which the new clause is to be inserted. Flag In_Place + -- should be set when normalizing the last output of an output list. + -- Flag Multiple should be set when Output comes from a list with + -- multiple items. - procedure Set_Ravenscar_Profile (N : Node_Id); - -- Activate the set of configuration pragmas and restrictions that make - -- up the Ravenscar Profile. N is the corresponding pragma node, which - -- is used for error messages on any constructs that violate the - -- profile. + ----------------------------- + -- Create_Or_Modify_Clause -- + ----------------------------- - --------------------- - -- Ada_2005_Pragma -- - --------------------- + procedure Create_Or_Modify_Clause + (Output : Node_Id; + Outputs : Node_Id; + Inputs : Node_Id; + After : Node_Id; + In_Place : Boolean; + Multiple : Boolean) + is + procedure Propagate_Output + (Output : Node_Id; + Inputs : Node_Id); + -- Handle the various cases of output propagation to the input + -- list. Output denotes a self-referencial output item. Inputs is + -- the input list of a clause. - procedure Ada_2005_Pragma is - begin - if Ada_Version <= Ada_95 then - Check_Restriction (No_Implementation_Pragmas, N); - end if; - end Ada_2005_Pragma; + ---------------------- + -- Propagate_Output -- + ---------------------- - --------------------- - -- Ada_2012_Pragma -- - --------------------- + procedure Propagate_Output + (Output : Node_Id; + Inputs : Node_Id) + is + function In_Input_List + (Item : Entity_Id; + Inputs : List_Id) return Boolean; + -- Determine whether a particulat item appears in the input + -- list of a clause. + + ------------------- + -- In_Input_List -- + ------------------- + + function In_Input_List + (Item : Entity_Id; + Inputs : List_Id) return Boolean + is + Elmt : Node_Id; - procedure Ada_2012_Pragma is - begin - if Ada_Version <= Ada_2005 then - Check_Restriction (No_Implementation_Pragmas, N); - end if; - end Ada_2012_Pragma; + begin + Elmt := First (Inputs); + while Present (Elmt) loop + if Entity_Of (Elmt) = Item then + return True; + end if; - -------------- - -- Add_Item -- - -------------- + Next (Elmt); + end loop; - procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is - begin - if No (To_List) then - To_List := New_Elmt_List; - end if; + return False; + end In_Input_List; - Append_Unique_Elmt (Item, To_List); - end Add_Item; + -- Local variables - -------------------------- - -- Check_Ada_83_Warning -- - -------------------------- + Output_Id : constant Entity_Id := Entity_Of (Output); + Grouped : List_Id; - procedure Check_Ada_83_Warning is - begin - if Ada_Version = Ada_83 and then Comes_From_Source (N) then - Error_Msg_N ("(Ada 83) pragma& is non-standard??", N); - end if; - end Check_Ada_83_Warning; + -- Start of processing for Propagate_Output - --------------------- - -- Check_Arg_Count -- - --------------------- + begin + -- The clause is of the form: - procedure Check_Arg_Count (Required : Nat) is - begin - if Arg_Count /= Required then - Error_Pragma ("wrong number of arguments for pragma%"); - end if; - end Check_Arg_Count; + -- (Output =>+ null) - -------------------------------- - -- Check_Arg_Is_External_Name -- - -------------------------------- + -- Remove the null input and replace it with a copy of the + -- output: - procedure Check_Arg_Is_External_Name (Arg : Node_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); + -- (Output => Output) - begin - if Nkind (Argx) = N_Identifier then - return; + if Nkind (Inputs) = N_Null then + Rewrite (Inputs, New_Copy_Tree (Output)); - else - Analyze_And_Resolve (Argx, Standard_String); + -- The clause is of the form: - if Is_OK_Static_Expression (Argx) then - return; + -- (Output =>+ (Input1, ..., InputN)) - elsif Etype (Argx) = Any_Type then - raise Pragma_Exit; + -- Determine whether the output is not already mentioned in the + -- input list and if not, add it to the list of inputs: - -- An interesting special case, if we have a string literal and - -- we are in Ada 83 mode, then we allow it even though it will - -- not be flagged as static. This allows expected Ada 83 mode - -- use of external names which are string literals, even though - -- technically these are not static in Ada 83. + -- (Output => (Output, Input1, ..., InputN)) - elsif Ada_Version = Ada_83 - and then Nkind (Argx) = N_String_Literal - then - return; + elsif Nkind (Inputs) = N_Aggregate then + Grouped := Expressions (Inputs); - -- Static expression that raises Constraint_Error. This has - -- already been flagged, so just exit from pragma processing. + if not In_Input_List + (Item => Output_Id, + Inputs => Grouped) + then + Prepend_To (Grouped, New_Copy_Tree (Output)); + end if; - elsif Is_Static_Expression (Argx) then - raise Pragma_Exit; + -- The clause is of the form: - -- Here we have a real error (non-static expression) + -- (Output =>+ Input) - else - Error_Msg_Name_1 := Pname; + -- If the input does not mention the output, group the two + -- together: - declare - Msg : String := - "argument for pragma% must be a identifier or " - & "static string expression!"; - begin - Fix_Error (Msg); - Flag_Non_Static_Expr (Msg, Argx); - raise Pragma_Exit; - end; - end if; - end if; - end Check_Arg_Is_External_Name; + -- (Output => (Output, Input)) - ----------------------------- - -- Check_Arg_Is_Identifier -- - ----------------------------- + elsif Entity_Of (Inputs) /= Output_Id then + Rewrite (Inputs, + Make_Aggregate (Loc, + Expressions => New_List ( + New_Copy_Tree (Output), + New_Copy_Tree (Inputs)))); + end if; + end Propagate_Output; - procedure Check_Arg_Is_Identifier (Arg : Node_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); - begin - if Nkind (Argx) /= N_Identifier then - Error_Pragma_Arg - ("argument for pragma% must be identifier", Argx); - end if; - end Check_Arg_Is_Identifier; + -- Local variables - ---------------------------------- - -- Check_Arg_Is_Integer_Literal -- - ---------------------------------- + Loc : constant Source_Ptr := Sloc (Output); + Clause : Node_Id; - procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); - begin - if Nkind (Argx) /= N_Integer_Literal then - Error_Pragma_Arg - ("argument for pragma% must be integer literal", Argx); - end if; - end Check_Arg_Is_Integer_Literal; + -- Start of processing for Create_Or_Modify_Clause - ------------------------------------------- - -- Check_Arg_Is_Library_Level_Local_Name -- - ------------------------------------------- + begin + -- A function result cannot depend on itself because it cannot + -- appear in the input list of a relation. - -- LOCAL_NAME ::= - -- DIRECT_NAME - -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR - -- | library_unit_NAME + if Nkind (Output) = N_Attribute_Reference + and then Attribute_Name (Output) = Name_Result + then + Error_Msg_N ("function result cannot depend on itself", Output); + return; - procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is - begin - Check_Arg_Is_Local_Name (Arg); + -- A null output depending on itself does not require any + -- normalization. - if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg))) - and then Comes_From_Source (N) - then - Error_Pragma_Arg - ("argument for pragma% must be library level entity", Arg); - end if; - end Check_Arg_Is_Library_Level_Local_Name; + elsif Nkind (Output) = N_Null then + return; + end if; - ----------------------------- - -- Check_Arg_Is_Local_Name -- - ----------------------------- + -- When performing the transformation in place, simply add the + -- output to the list of inputs (if not already there). This case + -- arises when dealing with the last output of an output list - + -- we perform the normalization in place to avoid generating a + -- malformed tree. - -- LOCAL_NAME ::= - -- DIRECT_NAME - -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR - -- | library_unit_NAME + if In_Place then + Propagate_Output (Output, Inputs); - procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); + -- A list with multiple outputs is slowly trimmed until only + -- one element remains. When this happens, replace the + -- aggregate with the element itself. - begin - Analyze (Argx); + if Multiple then + Remove (Output); + Rewrite (Outputs, Output); + end if; - if Nkind (Argx) not in N_Direct_Name - and then (Nkind (Argx) /= N_Attribute_Reference - or else Present (Expressions (Argx)) - or else Nkind (Prefix (Argx)) /= N_Identifier) - and then (not Is_Entity_Name (Argx) - or else not Is_Compilation_Unit (Entity (Argx))) - then - Error_Pragma_Arg ("argument for pragma% must be local name", Argx); - end if; + -- Default case - -- No further check required if not an entity name + else + -- Unchain the output from its output list as it will appear in + -- a new clause. Note that we cannot simply rewrite the output + -- as null because this will violate the semantics of aspect or + -- pragma Depends. - if not Is_Entity_Name (Argx) then - null; + Remove (Output); - else - declare - OK : Boolean; - Ent : constant Entity_Id := Entity (Argx); - Scop : constant Entity_Id := Scope (Ent); + -- Create a new clause of the form: - begin - -- Case of a pragma applied to a compilation unit: pragma must - -- occur immediately after the program unit in the compilation. + -- (Output => Inputs) - if Is_Compilation_Unit (Ent) then - declare - Decl : constant Node_Id := Unit_Declaration_Node (Ent); + Clause := + Make_Component_Association (Loc, + Choices => New_List (Output), + Expression => New_Copy_Tree (Inputs)); - begin - -- Case of pragma placed immediately after spec + -- The new clause contains replicated content that has already + -- been analyzed. There is not need to reanalyze it or + -- renormalize it again. - if Parent (N) = Aux_Decls_Node (Parent (Decl)) then - OK := True; + Set_Analyzed (Clause); - -- Case of pragma placed immediately after body + Propagate_Output + (Output => First (Choices (Clause)), + Inputs => Expression (Clause)); - elsif Nkind (Decl) = N_Subprogram_Declaration - and then Present (Corresponding_Body (Decl)) - then - OK := Parent (N) = - Aux_Decls_Node - (Parent (Unit_Declaration_Node - (Corresponding_Body (Decl)))); + Insert_After (After, Clause); + end if; + end Create_Or_Modify_Clause; - -- All other cases are illegal + -- Local variables - else - OK := False; - end if; - end; + Outputs : constant Node_Id := First (Choices (Clause)); + Inputs : Node_Id; + Last_Output : Node_Id; + Next_Output : Node_Id; + Output : Node_Id; - -- Special restricted placement rule from 10.2.1(11.8/2) + -- Start of processing for Normalize_Clause - elsif Is_Generic_Formal (Ent) - and then Prag_Id = Pragma_Preelaborable_Initialization - then - OK := List_Containing (N) = - Generic_Formal_Declarations - (Unit_Declaration_Node (Scop)); + begin + -- A self-dependency appears as operator "+". Remove the "+" from the + -- tree by moving the real inputs to their proper place. - -- Default case, just check that the pragma occurs in the scope - -- of the entity denoted by the name. + if Nkind (Expression (Clause)) = N_Op_Plus then + Rewrite (Expression (Clause), Right_Opnd (Expression (Clause))); + Inputs := Expression (Clause); - else - OK := Current_Scope = Scop; - end if; + -- Multiple outputs appear as an aggregate - if not OK then - Error_Pragma_Arg - ("pragma% argument must be in same declarative part", Arg); - end if; - end; - end if; - end Check_Arg_Is_Local_Name; + if Nkind (Outputs) = N_Aggregate then + Last_Output := Last (Expressions (Outputs)); - --------------------------------- - -- Check_Arg_Is_Locking_Policy -- - --------------------------------- + Output := First (Expressions (Outputs)); + while Present (Output) loop - procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); + -- Normalization may remove an output from its list, + -- preserve the subsequent output now. - begin - Check_Arg_Is_Identifier (Argx); + Next_Output := Next (Output); - if not Is_Locking_Policy_Name (Chars (Argx)) then - Error_Pragma_Arg ("& is not a valid locking policy name", Argx); + Create_Or_Modify_Clause + (Output => Output, + Outputs => Outputs, + Inputs => Inputs, + After => Clause, + In_Place => Output = Last_Output, + Multiple => True); + + Output := Next_Output; + end loop; + + -- Solitary output + + else + Create_Or_Modify_Clause + (Output => Outputs, + Outputs => Empty, + Inputs => Inputs, + After => Empty, + In_Place => True, + Multiple => False); + end if; end if; - end Check_Arg_Is_Locking_Policy; + end Normalize_Clause; - ----------------------------------------------- - -- Check_Arg_Is_Partition_Elaboration_Policy -- - ----------------------------------------------- + -- Local variables - procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); + Clause : Node_Id; + Errors : Nat; + Last_Clause : Node_Id; + Subp_Decl : Node_Id; - begin - Check_Arg_Is_Identifier (Argx); + -- Start of processing for Analyze_Depends_In_Decl_Part - if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then - Error_Pragma_Arg - ("& is not a valid partition elaboration policy name", Argx); - end if; - end Check_Arg_Is_Partition_Elaboration_Policy; + begin + Set_Analyzed (N); - ------------------------- - -- Check_Arg_Is_One_Of -- - ------------------------- + Subp_Decl := Parent (Corresponding_Aspect (N)); + Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); + Clause := Expression (Arg1); - procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); + -- Empty dependency list - begin - Check_Arg_Is_Identifier (Argx); + if Nkind (Clause) = N_Null then - if not Nam_In (Chars (Argx), N1, N2) then - Error_Msg_Name_2 := N1; - Error_Msg_Name_3 := N2; - Error_Pragma_Arg ("argument for pragma% must be% or%", Argx); - end if; - end Check_Arg_Is_One_Of; + -- Gather all states, variables and formal parameters that the + -- subprogram may depend on. These items are obtained from the + -- parameter profile or pragma Global (if available). - procedure Check_Arg_Is_One_Of - (Arg : Node_Id; - N1, N2, N3 : Name_Id) - is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); + Collect_Subprogram_Inputs_Outputs; - begin - Check_Arg_Is_Identifier (Argx); + -- Verify that every input or output of the subprogram appear in a + -- dependency. - if not Nam_In (Chars (Argx), N1, N2, N3) then - Error_Pragma_Arg ("invalid argument for pragma%", Argx); - end if; - end Check_Arg_Is_One_Of; + Check_Usage (Subp_Inputs, All_Inputs_Seen, True); + Check_Usage (Subp_Outputs, Outputs_Seen, False); + Check_Function_Return; - procedure Check_Arg_Is_One_Of - (Arg : Node_Id; - N1, N2, N3, N4 : Name_Id) - is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); + -- Dependency clauses appear as component associations of an aggregate - begin - Check_Arg_Is_Identifier (Argx); + elsif Nkind (Clause) = N_Aggregate + and then Present (Component_Associations (Clause)) + then + Last_Clause := Last (Component_Associations (Clause)); - if not Nam_In (Chars (Argx), N1, N2, N3, N4) then - Error_Pragma_Arg ("invalid argument for pragma%", Argx); - end if; - end Check_Arg_Is_One_Of; + -- Gather all states, variables and formal parameters that the + -- subprogram may depend on. These items are obtained from the + -- parameter profile or pragma Global (if available). - procedure Check_Arg_Is_One_Of - (Arg : Node_Id; - N1, N2, N3, N4, N5 : Name_Id) - is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); + Collect_Subprogram_Inputs_Outputs; - begin - Check_Arg_Is_Identifier (Argx); + -- Ensure that the formal parameters are visible when analyzing all + -- clauses. This falls out of the general rule of aspects pertaining + -- to subprogram declarations. Skip the installation for subprogram + -- bodies because the formals are already visible. - if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then - Error_Pragma_Arg ("invalid argument for pragma%", Argx); + if Nkind (Subp_Decl) = N_Subprogram_Declaration then + Push_Scope (Subp_Id); + Install_Formals (Subp_Id); end if; - end Check_Arg_Is_One_Of; - --------------------------------- - -- Check_Arg_Is_Queuing_Policy -- - --------------------------------- + Clause := First (Component_Associations (Clause)); + while Present (Clause) loop + Errors := Serious_Errors_Detected; - procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); + -- Normalization may create extra clauses that contain replicated + -- input and output names. There is no need to reanalyze or + -- renormalize these extra clauses. - begin - Check_Arg_Is_Identifier (Argx); + if not Analyzed (Clause) then + Set_Analyzed (Clause); - if not Is_Queuing_Policy_Name (Chars (Argx)) then - Error_Pragma_Arg ("& is not a valid queuing policy name", Argx); - end if; - end Check_Arg_Is_Queuing_Policy; - - ------------------------------------ - -- Check_Arg_Is_Static_Expression -- - ------------------------------------ - - procedure Check_Arg_Is_Static_Expression - (Arg : Node_Id; - Typ : Entity_Id := Empty) - is - begin - Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ); - end Check_Arg_Is_Static_Expression; + Analyze_Dependency_Clause + (Clause => Clause, + Is_Last => Clause = Last_Clause); - ------------------------------------------ - -- Check_Arg_Is_Task_Dispatching_Policy -- - ------------------------------------------ + -- Do not normalize an erroneous clause because the inputs or + -- outputs may denote illegal items. - procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); + if Errors = Serious_Errors_Detected then + Normalize_Clause (Clause); + end if; + end if; - begin - Check_Arg_Is_Identifier (Argx); + Next (Clause); + end loop; - if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then - Error_Pragma_Arg - ("& is not a valid task dispatching policy name", Argx); + if Nkind (Subp_Decl) = N_Subprogram_Declaration then + End_Scope; end if; - end Check_Arg_Is_Task_Dispatching_Policy; - --------------------- - -- Check_Arg_Order -- - --------------------- + -- Verify that every input or output of the subprogram appear in a + -- dependency. - procedure Check_Arg_Order (Names : Name_List) is - Arg : Node_Id; + Check_Usage (Subp_Inputs, All_Inputs_Seen, True); + Check_Usage (Subp_Outputs, Outputs_Seen, False); + Check_Function_Return; - Highest_So_Far : Natural := 0; - -- Highest index in Names seen do far + -- The top level dependency relation is malformed - begin - Arg := Arg1; - for J in 1 .. Arg_Count loop - if Chars (Arg) /= No_Name then - for K in Names'Range loop - if Chars (Arg) = Names (K) then - if K < Highest_So_Far then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("parameters out of order for pragma%", Arg); - Error_Msg_Name_1 := Names (K); - Error_Msg_Name_2 := Names (Highest_So_Far); - Error_Msg_N ("\% must appear before %", Arg); - raise Pragma_Exit; + else + Error_Msg_N ("malformed dependency relation", Clause); + end if; + end Analyze_Depends_In_Decl_Part; - else - Highest_So_Far := K; - end if; - end if; - end loop; - end if; + --------------------------------- + -- Analyze_Global_In_Decl_Part -- + --------------------------------- - Arg := Next (Arg); - end loop; - end Check_Arg_Order; + procedure Analyze_Global_In_Decl_Part (N : Node_Id) is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); - -------------------------------- - -- Check_At_Least_N_Arguments -- - -------------------------------- + Seen : Elist_Id := No_Elist; + -- A list containing the entities of all the items processed so far. It + -- plays a role in detecting distinct entities. - procedure Check_At_Least_N_Arguments (N : Nat) is - begin - if Arg_Count < N then - Error_Pragma ("too few arguments for pragma%"); - end if; - end Check_At_Least_N_Arguments; + Subp_Id : Entity_Id; + -- The entity of the subprogram subject to pragma Global - ------------------------------- - -- Check_At_Most_N_Arguments -- - ------------------------------- + Contract_Seen : Boolean := False; + In_Out_Seen : Boolean := False; + Input_Seen : Boolean := False; + Output_Seen : Boolean := False; + -- Flags used to verify the consistency of modes - procedure Check_At_Most_N_Arguments (N : Nat) is - Arg : Node_Id; - begin - if Arg_Count > N then - Arg := Arg1; - for J in 1 .. N loop - Next (Arg); - Error_Pragma_Arg ("too many arguments for pragma%", Arg); - end loop; - end if; - end Check_At_Most_N_Arguments; + procedure Analyze_Global_List + (List : Node_Id; + Global_Mode : Name_Id := Name_Input); + -- Verify the legality of a single global list declaration. Global_Mode + -- denotes the current mode in effect. - --------------------- - -- Check_Component -- - --------------------- + ------------------------- + -- Analyze_Global_List -- + ------------------------- - procedure Check_Component - (Comp : Node_Id; - UU_Typ : Entity_Id; - In_Variant_Part : Boolean := False) + procedure Analyze_Global_List + (List : Node_Id; + Global_Mode : Name_Id := Name_Input) is - Comp_Id : constant Entity_Id := Defining_Identifier (Comp); - Sindic : constant Node_Id := - Subtype_Indication (Component_Definition (Comp)); - Typ : constant Entity_Id := Etype (Comp_Id); + procedure Analyze_Global_Item + (Item : Node_Id; + Global_Mode : Name_Id); + -- Verify the legality of a single global item declaration. + -- Global_Mode denotes the current mode in effect. + + procedure Check_Duplicate_Mode + (Mode : Node_Id; + Status : in out Boolean); + -- Flag Status denotes whether a particular mode has been seen while + -- processing a global list. This routine verifies that Mode is not a + -- duplicate mode and sets the flag Status. + + procedure Check_Mode_Restriction_In_Function (Mode : Node_Id); + -- Mode denotes either In_Out or Output. Depending on the kind of the + -- related subprogram, emit an error if those two modes apply to a + -- function. - begin - -- Ada 2005 (AI-216): If a component subtype is subject to a per- - -- object constraint, then the component type shall be an Unchecked_ - -- Union. + ------------------------- + -- Analyze_Global_Item -- + ------------------------- - if Nkind (Sindic) = N_Subtype_Indication - and then Has_Per_Object_Constraint (Comp_Id) - and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic))) - then - Error_Msg_N - ("component subtype subject to per-object constraint " - & "must be an Unchecked_Union", Comp); + procedure Analyze_Global_Item + (Item : Node_Id; + Global_Mode : Name_Id) + is + Item_Id : Entity_Id; - -- Ada 2012 (AI05-0026): For an unchecked union type declared within - -- the body of a generic unit, or within the body of any of its - -- descendant library units, no part of the type of a component - -- declared in a variant_part of the unchecked union type shall be of - -- a formal private type or formal private extension declared within - -- the formal part of the generic unit. + begin + -- Detect one of the following cases - elsif Ada_Version >= Ada_2012 - and then In_Generic_Body (UU_Typ) - and then In_Variant_Part - and then Is_Private_Type (Typ) - and then Is_Generic_Type (Typ) - then - Error_Msg_N - ("component of unchecked union cannot be of generic type", Comp); + -- with Global => (null, Name) + -- with Global => (Name_1, null, Name_2) + -- with Global => (Name, null) - elsif Needs_Finalization (Typ) then - Error_Msg_N - ("component of unchecked union cannot be controlled", Comp); + if Nkind (Item) = N_Null then + Error_Msg_N ("cannot mix null and non-null global items", Item); + return; + end if; - elsif Has_Task (Typ) then - Error_Msg_N - ("component of unchecked union cannot have tasks", Comp); - end if; - end Check_Component; + Analyze (Item); - ---------------------------- - -- Check_Duplicate_Pragma -- - ---------------------------- + -- Find the entity of the item. If this is a renaming, climb the + -- renaming chain to reach the root object. Renamings of non- + -- entire objects do not yield an entity (Empty). - procedure Check_Duplicate_Pragma (E : Entity_Id) is - Id : Entity_Id := E; - P : Node_Id; + Item_Id := Entity_Of (Item); - begin - -- Nothing to do if this pragma comes from an aspect specification, - -- since we could not be duplicating a pragma, and we dealt with the - -- case of duplicated aspects in Analyze_Aspect_Specifications. + if Present (Item_Id) then - if From_Aspect_Specification (N) then - return; - end if; + -- A global item cannot reference a formal parameter. Do this + -- check first to provide a better error diagnostic. - -- Otherwise current pragma may duplicate previous pragma or a - -- previously given aspect specification or attribute definition - -- clause for the same pragma. + if Is_Formal (Item_Id) then + Error_Msg_N + ("global item cannot reference formal parameter", Item); + return; - P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False); + -- The only legal references are those to abstract states and + -- variables. - if Present (P) then - Error_Msg_Name_1 := Pragma_Name (N); - Error_Msg_Sloc := Sloc (P); + elsif not Ekind_In (Item_Id, E_Abstract_State, E_Variable) then + Error_Msg_N + ("global item must denote variable or state", Item); + return; + end if; - -- For a single protected or a single task object, the error is - -- issued on the original entity. + -- When the item renames an entire object, replace the item + -- with a reference to the object. - if Ekind_In (Id, E_Task_Type, E_Protected_Type) then - Id := Defining_Identifier (Original_Node (Parent (Id))); - end if; + if Present (Renamed_Object (Entity (Item))) then + Rewrite (Item, New_Reference_To (Item_Id, Sloc (Item))); + Analyze (Item); + end if; + + -- Some form of illegal construct masquerading as a name - if Nkind (P) = N_Aspect_Specification - or else From_Aspect_Specification (P) - then - Error_Msg_NE ("aspect% for & previously given#", N, Id); else - Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id); + Error_Msg_N ("global item must denote variable or state", Item); + return; end if; - raise Pragma_Exit; - end if; - end Check_Duplicate_Pragma; + -- The same entity might be referenced through various way. Check + -- the entity of the item rather than the item itself. - ---------------------------------- - -- Check_Duplicated_Export_Name -- - ---------------------------------- + if Contains (Seen, Item_Id) then + Error_Msg_N ("duplicate global item", Item); - procedure Check_Duplicated_Export_Name (Nam : Node_Id) is - String_Val : constant String_Id := Strval (Nam); + -- Add the entity of the current item to the list of processed + -- items. - begin - -- We are only interested in the export case, and in the case of - -- generics, it is the instance, not the template, that is the - -- problem (the template will generate a warning in any case). + else + Add_Item (Item_Id, Seen); + end if; - if not Inside_A_Generic - and then (Prag_Id = Pragma_Export - or else - Prag_Id = Pragma_Export_Procedure - or else - Prag_Id = Pragma_Export_Valued_Procedure - or else - Prag_Id = Pragma_Export_Function) - then - for J in Externals.First .. Externals.Last loop - if String_Equal (String_Val, Strval (Externals.Table (J))) then - Error_Msg_Sloc := Sloc (Externals.Table (J)); - Error_Msg_N ("external name duplicates name given#", Nam); - exit; + if Ekind (Item_Id) = E_Abstract_State + and then Is_Volatile_State (Item_Id) + then + -- A global item of mode In_Out or Output cannot denote a + -- volatile Input state. + + if Is_Input_State (Item_Id) + and then Nam_In (Global_Mode, Name_In_Out, Name_Output) + then + Error_Msg_N + ("global item of mode In_Out or Output cannot reference " + & "Volatile Input state", Item); + + -- A global item of mode In_Out or Input cannot reference a + -- volatile Output state. + + elsif Is_Output_State (Item_Id) + and then Nam_In (Global_Mode, Name_In_Out, Name_Input) + then + Error_Msg_N + ("global item of mode In_Out or Input cannot reference " + & "Volatile Output state", Item); end if; - end loop; + end if; + end Analyze_Global_Item; - Externals.Append (Nam); - end if; - end Check_Duplicated_Export_Name; + -------------------------- + -- Check_Duplicate_Mode -- + -------------------------- - ------------------------------------- - -- Check_Expr_Is_Static_Expression -- - ------------------------------------- + procedure Check_Duplicate_Mode + (Mode : Node_Id; + Status : in out Boolean) + is + begin + if Status then + Error_Msg_N ("duplicate global mode", Mode); + end if; - procedure Check_Expr_Is_Static_Expression - (Expr : Node_Id; - Typ : Entity_Id := Empty) - is - begin - if Present (Typ) then - Analyze_And_Resolve (Expr, Typ); - else - Analyze_And_Resolve (Expr); - end if; + Status := True; + end Check_Duplicate_Mode; - if Is_OK_Static_Expression (Expr) then - return; + ---------------------------------------- + -- Check_Mode_Restriction_In_Function -- + ---------------------------------------- - elsif Etype (Expr) = Any_Type then - raise Pragma_Exit; + procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is + begin + if Ekind (Subp_Id) = E_Function then + Error_Msg_N + ("global mode & not applicable to functions", Mode); + end if; + end Check_Mode_Restriction_In_Function; - -- An interesting special case, if we have a string literal and we - -- are in Ada 83 mode, then we allow it even though it will not be - -- flagged as static. This allows the use of Ada 95 pragmas like - -- Import in Ada 83 mode. They will of course be flagged with - -- warnings as usual, but will not cause errors. + -- Local variables - elsif Ada_Version = Ada_83 - and then Nkind (Expr) = N_String_Literal - then - return; + Assoc : Node_Id; + Item : Node_Id; + Mode : Node_Id; - -- Static expression that raises Constraint_Error. This has already - -- been flagged, so just exit from pragma processing. - - elsif Is_Static_Expression (Expr) then - raise Pragma_Exit; - - -- Finally, we have a real error - - else - Error_Msg_Name_1 := Pname; - - declare - Msg : String := - "argument for pragma% must be a static expression!"; - begin - Fix_Error (Msg); - Flag_Non_Static_Expr (Msg, Expr); - end; - - raise Pragma_Exit; - end if; - end Check_Expr_Is_Static_Expression; - - ------------------------- - -- Check_First_Subtype -- - ------------------------- - - procedure Check_First_Subtype (Arg : Node_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); - Ent : constant Entity_Id := Entity (Argx); + -- Start of processing for Analyze_Global_List begin - if Is_First_Subtype (Ent) then - null; + -- Single global item declaration - elsif Is_Type (Ent) then - Error_Pragma_Arg - ("pragma% cannot apply to subtype", Argx); + if Nkind_In (List, N_Identifier, N_Selected_Component) then + Analyze_Global_Item (List, Global_Mode); - elsif Is_Object (Ent) then - Error_Pragma_Arg - ("pragma% cannot apply to object, requires a type", Argx); + -- Simple global list or moded global list declaration - else - Error_Pragma_Arg - ("pragma% cannot apply to&, requires a type", Argx); - end if; - end Check_First_Subtype; + elsif Nkind (List) = N_Aggregate then - ---------------------- - -- Check_Identifier -- - ---------------------- + -- The declaration of a simple global list appear as a collection + -- of expressions. - procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is - begin - if Present (Arg) - and then Nkind (Arg) = N_Pragma_Argument_Association - then - if Chars (Arg) = No_Name or else Chars (Arg) /= Id then - Error_Msg_Name_1 := Pname; - Error_Msg_Name_2 := Id; - Error_Msg_N ("pragma% argument expects identifier%", Arg); - raise Pragma_Exit; - end if; - end if; - end Check_Identifier; + if Present (Expressions (List)) then + if Present (Component_Associations (List)) then + Error_Msg_N + ("cannot mix moded and non-moded global lists", List); + end if; - -------------------------------- - -- Check_Identifier_Is_One_Of -- - -------------------------------- + Item := First (Expressions (List)); + while Present (Item) loop + Analyze_Global_Item (Item, Global_Mode); - procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is - begin - if Present (Arg) - and then Nkind (Arg) = N_Pragma_Argument_Association - then - if Chars (Arg) = No_Name then - Error_Msg_Name_1 := Pname; - Error_Msg_N ("pragma% argument expects an identifier", Arg); - raise Pragma_Exit; + Next (Item); + end loop; - elsif Chars (Arg) /= N1 - and then Chars (Arg) /= N2 - then - Error_Msg_Name_1 := Pname; - Error_Msg_N ("invalid identifier for pragma% argument", Arg); - raise Pragma_Exit; - end if; - end if; - end Check_Identifier_Is_One_Of; + -- The declaration of a moded global list appears as a collection + -- of component associations where individual choices denote + -- modes. - --------------------------- - -- Check_In_Main_Program -- - --------------------------- + elsif Present (Component_Associations (List)) then + if Present (Expressions (List)) then + Error_Msg_N + ("cannot mix moded and non-moded global lists", List); + end if; - procedure Check_In_Main_Program is - P : constant Node_Id := Parent (N); + Assoc := First (Component_Associations (List)); + while Present (Assoc) loop + Mode := First (Choices (Assoc)); - begin - -- Must be at in subprogram body + if Nkind (Mode) = N_Identifier then + if Chars (Mode) = Name_Contract_In then + Check_Duplicate_Mode (Mode, Contract_Seen); - if Nkind (P) /= N_Subprogram_Body then - Error_Pragma ("% pragma allowed only in subprogram"); + elsif Chars (Mode) = Name_In_Out then + Check_Duplicate_Mode (Mode, In_Out_Seen); + Check_Mode_Restriction_In_Function (Mode); - -- Otherwise warn if obviously not main program + elsif Chars (Mode) = Name_Input then + Check_Duplicate_Mode (Mode, Input_Seen); - elsif Present (Parameter_Specifications (Specification (P))) - or else not Is_Compilation_Unit (Defining_Entity (P)) - then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("??pragma% is only effective in main program", N); - end if; - end Check_In_Main_Program; + elsif Chars (Mode) = Name_Output then + Check_Duplicate_Mode (Mode, Output_Seen); + Check_Mode_Restriction_In_Function (Mode); - --------------------------------------- - -- Check_Interrupt_Or_Attach_Handler -- - --------------------------------------- + else + Error_Msg_N ("invalid mode selector", Mode); + end if; - procedure Check_Interrupt_Or_Attach_Handler is - Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); - Handler_Proc, Proc_Scope : Entity_Id; + else + Error_Msg_N ("invalid mode selector", Mode); + end if; - begin - Analyze (Arg1_X); + -- Items in a moded list appear as a collection of + -- expressions. Reuse the existing machinery to analyze + -- them. - if Prag_Id = Pragma_Interrupt_Handler then - Check_Restriction (No_Dynamic_Attachment, N); - end if; + Analyze_Global_List + (List => Expression (Assoc), + Global_Mode => Chars (Mode)); - Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); - Proc_Scope := Scope (Handler_Proc); + Next (Assoc); + end loop; - -- On AAMP only, a pragma Interrupt_Handler is supported for - -- nonprotected parameterless procedures. + -- Something went horribly wrong, we have a malformed tree - if not AAMP_On_Target - or else Prag_Id = Pragma_Attach_Handler - then - if Ekind (Proc_Scope) /= E_Protected_Type then - Error_Pragma_Arg - ("argument of pragma% must be protected procedure", Arg1); + else + raise Program_Error; end if; - if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then - Error_Pragma ("pragma% must be in protected definition"); - end if; - end if; + -- Any other attempt to declare a global item is erroneous - if not Is_Library_Level_Entity (Proc_Scope) - or else (AAMP_On_Target - and then not Is_Library_Level_Entity (Handler_Proc)) - then - Error_Pragma_Arg - ("argument for pragma% must be library level entity", Arg1); + else + Error_Msg_N ("malformed global list declaration", List); end if; + end Analyze_Global_List; - -- AI05-0033: A pragma cannot appear within a generic body, because - -- instance can be in a nested scope. The check that protected type - -- is itself a library-level declaration is done elsewhere. + -- Local variables - -- Note: we omit this check in Relaxed_RM_Semantics mode to properly - -- handle code prior to AI-0033. Analysis tools typically are not - -- interested in this pragma in any case, so no need to worry too - -- much about its placement. + List : Node_Id; + Subp_Decl : Node_Id; - if Inside_A_Generic then - if Ekind (Scope (Current_Scope)) = E_Generic_Package - and then In_Package_Body (Scope (Current_Scope)) - and then not Relaxed_RM_Semantics - then - Error_Pragma ("pragma% cannot be used inside a generic"); - end if; - end if; - end Check_Interrupt_Or_Attach_Handler; + -- Start of processing for Analyze_Global_In_Decl_List - --------------------------------- - -- Check_Loop_Pragma_Placement -- - --------------------------------- + begin + Set_Analyzed (N); - procedure Check_Loop_Pragma_Placement is - procedure Placement_Error (Constr : Node_Id); - pragma No_Return (Placement_Error); - -- Node Constr denotes the last loop restricted construct before we - -- encountered an illegal relation between enclosing constructs. Emit - -- an error depending on what Constr was. + Subp_Decl := Parent (Corresponding_Aspect (N)); + Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); + List := Expression (Arg1); - --------------------- - -- Placement_Error -- - --------------------- + -- There is nothing to be done for a null global list - procedure Placement_Error (Constr : Node_Id) is - begin - if Nkind (Constr) = N_Pragma then - Error_Pragma - ("pragma % must appear immediately within the statements " - & "of a loop"); - else - Error_Pragma_Arg - ("block containing pragma % must appear immediately within " - & "the statements of a loop", Constr); - end if; - end Placement_Error; + if Nkind (List) = N_Null then + null; - -- Local declarations + -- Analyze the various forms of global lists and items. Note that some + -- of these may be malformed in which case the analysis emits error + -- messages. - Prev : Node_Id; - Stmt : Node_Id; + elsif Nkind (Subp_Decl) = N_Subprogram_Body then + Analyze_Global_List (List); - -- Start of processing for Check_Loop_Pragma_Placement + -- Ensure that the formal parameters are visible when processing an + -- item. This falls out of the general rule of aspects pertaining to + -- subprogram declarations. - begin - Prev := N; - Stmt := Parent (N); - while Present (Stmt) loop + else + Push_Scope (Subp_Id); + Install_Formals (Subp_Id); - -- The pragma or previous block must appear immediately within the - -- current block's declarative or statement part. + Analyze_Global_List (List); - if Nkind (Stmt) = N_Block_Statement then - if (No (Declarations (Stmt)) - or else List_Containing (Prev) /= Declarations (Stmt)) - and then - List_Containing (Prev) /= - Statements (Handled_Statement_Sequence (Stmt)) - then - Placement_Error (Prev); - return; + End_Scope; + end if; + end Analyze_Global_In_Decl_Part; - -- Keep inspecting the parents because we are now within a - -- chain of nested blocks. + ------------------------------ + -- Analyze_PPC_In_Decl_Part -- + ------------------------------ - else - Prev := Stmt; - Stmt := Parent (Stmt); - end if; + procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id) is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); - -- The pragma or previous block must appear immediately within the - -- statements of the loop. + begin + -- Install formals and push subprogram spec onto scope stack so that we + -- can see the formals from the pragma. - elsif Nkind (Stmt) = N_Loop_Statement then - if List_Containing (Prev) /= Statements (Stmt) then - Placement_Error (Prev); - end if; + Install_Formals (S); + Push_Scope (S); - -- Stop the traversal because we reached the innermost loop - -- regardless of whether we encountered an error or not. + -- Preanalyze the boolean expression, we treat this as a spec expression + -- (i.e. similar to a default expression). - return; + Preanalyze_Assert_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); - -- Ignore a handled statement sequence. Note that this node may - -- be related to a subprogram body in which case we will emit an - -- error on the next iteration of the search. + -- In ASIS mode, for a pragma generated from a source aspect, also + -- analyze the original aspect expression. - elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then - Stmt := Parent (Stmt); + if ASIS_Mode and then Present (Corresponding_Aspect (N)) then + Preanalyze_Assert_Expression + (Expression (Corresponding_Aspect (N)), Standard_Boolean); + end if; - -- Any other statement breaks the chain from the pragma to the - -- loop. + -- For a class-wide condition, a reference to a controlling formal must + -- be interpreted as having the class-wide type (or an access to such) + -- so that the inherited condition can be properly applied to any + -- overriding operation (see ARM12 6.6.1 (7)). - else - Placement_Error (Prev); - return; - end if; - end loop; - end Check_Loop_Pragma_Placement; + if Class_Present (N) then + Class_Wide_Condition : declare + T : constant Entity_Id := Find_Dispatching_Type (S); - ------------------------------------------- - -- Check_Is_In_Decl_Part_Or_Package_Spec -- - ------------------------------------------- + ACW : Entity_Id := Empty; + -- Access to T'class, created if there is a controlling formal + -- that is an access parameter. - procedure Check_Is_In_Decl_Part_Or_Package_Spec is - P : Node_Id; + function Get_ACW return Entity_Id; + -- If the expression has a reference to an controlling access + -- parameter, create an access to T'class for the necessary + -- conversions if one does not exist. - begin - P := Parent (N); - loop - if No (P) then - exit; + function Process (N : Node_Id) return Traverse_Result; + -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class + -- aspect for a primitive subprogram of a tagged type T, a name + -- that denotes a formal parameter of type T is interpreted as + -- having type T'Class. Similarly, a name that denotes a formal + -- accessparameter of type access-to-T is interpreted as having + -- type access-to-T'Class. This ensures the expression is well- + -- defined for a primitive subprogram of a type descended from T. - elsif Nkind (P) = N_Handled_Sequence_Of_Statements then - exit; + ------------- + -- Get_ACW -- + ------------- - elsif Nkind_In (P, N_Package_Specification, - N_Block_Statement) - then - return; + function Get_ACW return Entity_Id is + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; - -- Note: the following tests seem a little peculiar, because - -- they test for bodies, but if we were in the statement part - -- of the body, we would already have hit the handled statement - -- sequence, so the only way we get here is by being in the - -- declarative part of the body. + begin + if No (ACW) then + Decl := Make_Full_Type_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'T'), + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Class_Wide_Type (T), Loc), + All_Present => True)); - elsif Nkind_In (P, N_Subprogram_Body, - N_Package_Body, - N_Task_Body, - N_Entry_Body) - then - return; - end if; + Insert_Before (Unit_Declaration_Node (S), Decl); + Analyze (Decl); + ACW := Defining_Identifier (Decl); + Freeze_Before (Unit_Declaration_Node (S), ACW); + end if; - P := Parent (P); - end loop; + return ACW; + end Get_ACW; - Error_Pragma ("pragma% is not in declarative part or package spec"); - end Check_Is_In_Decl_Part_Or_Package_Spec; + ------------- + -- Process -- + ------------- - ------------------------- - -- Check_No_Identifier -- - ------------------------- + function Process (N : Node_Id) return Traverse_Result is + Loc : constant Source_Ptr := Sloc (N); + Typ : Entity_Id; - procedure Check_No_Identifier (Arg : Node_Id) is - begin - if Nkind (Arg) = N_Pragma_Argument_Association - and then Chars (Arg) /= No_Name - then - Error_Pragma_Arg_Ident - ("pragma% does not permit identifier& here", Arg); - end if; - end Check_No_Identifier; + begin + if Is_Entity_Name (N) + and then Is_Formal (Entity (N)) + and then Nkind (Parent (N)) /= N_Type_Conversion + then + if Etype (Entity (N)) = T then + Typ := Class_Wide_Type (T); - -------------------------- - -- Check_No_Identifiers -- - -------------------------- + elsif Is_Access_Type (Etype (Entity (N))) + and then Designated_Type (Etype (Entity (N))) = T + then + Typ := Get_ACW; + else + Typ := Empty; + end if; - procedure Check_No_Identifiers is - Arg_Node : Node_Id; - begin - if Arg_Count > 0 then - Arg_Node := Arg1; - while Present (Arg_Node) loop - Check_No_Identifier (Arg_Node); - Next (Arg_Node); - end loop; - end if; - end Check_No_Identifiers; + if Present (Typ) then + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Typ, Loc), + Expression => New_Occurrence_Of (Entity (N), Loc))); + Set_Etype (N, Typ); + end if; + end if; - ------------------------ - -- Check_No_Link_Name -- - ------------------------ + return OK; + end Process; - procedure Check_No_Link_Name is - begin - if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then - Arg4 := Arg3; - end if; + procedure Replace_Type is new Traverse_Proc (Process); - if Present (Arg4) then - Error_Pragma_Arg - ("Link_Name argument not allowed for Import Intrinsic", Arg4); - end if; - end Check_No_Link_Name; + -- Start of processing for Class_Wide_Condition - ------------------------------- - -- Check_Optional_Identifier -- - ------------------------------- + begin + if not Present (T) then + Error_Msg_Name_1 := + Chars (Identifier (Corresponding_Aspect (N))); - procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is - begin - if Present (Arg) - and then Nkind (Arg) = N_Pragma_Argument_Association - and then Chars (Arg) /= No_Name - then - if Chars (Arg) /= Id then - Error_Msg_Name_1 := Pname; - Error_Msg_Name_2 := Id; - Error_Msg_N ("pragma% argument expects identifier%", Arg); - raise Pragma_Exit; + Error_Msg_Name_2 := Name_Class; + + Error_Msg_N + ("aspect `%''%` can only be specified for a primitive " + & "operation of a tagged type", Corresponding_Aspect (N)); end if; - end if; - end Check_Optional_Identifier; - procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is - begin - Name_Buffer (1 .. Id'Length) := Id; - Name_Len := Id'Length; - Check_Optional_Identifier (Arg, Name_Find); - end Check_Optional_Identifier; + Replace_Type (Get_Pragma_Arg (Arg1)); + end Class_Wide_Condition; + end if; - -------------------------------------- - -- Check_Precondition_Postcondition -- - -------------------------------------- + -- Remove the subprogram from the scope stack now that the pre-analysis + -- of the precondition/postcondition is done. - procedure Check_Precondition_Postcondition (In_Body : out Boolean) is - P : Node_Id; - PO : Node_Id; + End_Scope; + end Analyze_PPC_In_Decl_Part; - procedure Chain_PPC (PO : Node_Id); - -- If PO is an entry or a [generic] subprogram declaration node, then - -- the precondition/postcondition applies to this subprogram and the - -- processing for the pragma is completed. Otherwise the pragma is - -- misplaced. + -------------------- + -- Analyze_Pragma -- + -------------------- - --------------- - -- Chain_PPC -- - --------------- + procedure Analyze_Pragma (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Prag_Id : Pragma_Id; - procedure Chain_PPC (PO : Node_Id) is - S : Entity_Id; + Pname : Name_Id; + -- Name of the source pragma, or name of the corresponding aspect for + -- pragmas which originate in a source aspect. In the latter case, the + -- name may be different from the pragma name. - begin - if Nkind (PO) = N_Abstract_Subprogram_Declaration then - if not From_Aspect_Specification (N) then - Error_Pragma - ("pragma% cannot be applied to abstract subprogram"); + Pragma_Exit : exception; + -- This exception is used to exit pragma processing completely. It is + -- used when an error is detected, and no further processing is + -- required. It is also used if an earlier error has left the tree in + -- a state where the pragma should not be processed. - elsif Class_Present (N) then - null; + Arg_Count : Nat; + -- Number of pragma argument associations - else - Error_Pragma - ("aspect % requires ''Class for abstract subprogram"); - end if; + Arg1 : Node_Id; + Arg2 : Node_Id; + Arg3 : Node_Id; + Arg4 : Node_Id; + -- First four pragma arguments (pragma argument association nodes, or + -- Empty if the corresponding argument does not exist). - -- AI05-0230: The same restriction applies to null procedures. For - -- compatibility with earlier uses of the Ada pragma, apply this - -- rule only to aspect specifications. + type Name_List is array (Natural range <>) of Name_Id; + type Args_List is array (Natural range <>) of Node_Id; + -- Types used for arguments to Check_Arg_Order and Gather_Associations - -- The above discrpency needs documentation. Robert is dubious - -- about whether it is a good idea ??? + procedure Ada_2005_Pragma; + -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In + -- Ada 95 mode, these are implementation defined pragmas, so should be + -- caught by the No_Implementation_Pragmas restriction. - elsif Nkind (PO) = N_Subprogram_Declaration - and then Nkind (Specification (PO)) = N_Procedure_Specification - and then Null_Present (Specification (PO)) - and then From_Aspect_Specification (N) - and then not Class_Present (N) - then - Error_Pragma - ("aspect % requires ''Class for null procedure"); + procedure Ada_2012_Pragma; + -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05. + -- In Ada 95 or 05 mode, these are implementation defined pragmas, so + -- should be caught by the No_Implementation_Pragmas restriction. - -- Pre/postconditions are legal on a subprogram body if it is not - -- a completion of a declaration. They are also legal on a stub - -- with no previous declarations (this is checked when processing - -- the corresponding aspects). - - elsif Nkind (PO) = N_Subprogram_Body - and then Acts_As_Spec (PO) - then - null; - - elsif Nkind (PO) = N_Subprogram_Body_Stub then - null; + procedure Check_Ada_83_Warning; + -- Issues a warning message for the current pragma if operating in Ada + -- 83 mode (used for language pragmas that are not a standard part of + -- Ada 83). This procedure does not raise Error_Pragma. Also notes use + -- of 95 pragma. - elsif not Nkind_In (PO, N_Subprogram_Declaration, - N_Expression_Function, - N_Generic_Subprogram_Declaration, - N_Entry_Declaration) - then - Pragma_Misplaced; - end if; + procedure Check_Arg_Count (Required : Nat); + -- Check argument count for pragma is equal to given parameter. If not, + -- then issue an error message and raise Pragma_Exit. - -- Here if we have [generic] subprogram or entry declaration + -- Note: all routines whose name is Check_Arg_Is_xxx take an argument + -- Arg which can either be a pragma argument association, in which case + -- the check is applied to the expression of the association or an + -- expression directly. - if Nkind (PO) = N_Entry_Declaration then - S := Defining_Entity (PO); - else - S := Defining_Unit_Name (Specification (PO)); + procedure Check_Arg_Is_External_Name (Arg : Node_Id); + -- Check that an argument has the right form for an EXTERNAL_NAME + -- parameter of an extended import/export pragma. The rule is that the + -- name must be an identifier or string literal (in Ada 83 mode) or a + -- static string expression (in Ada 95 mode). - if Nkind (S) = N_Defining_Program_Unit_Name then - S := Defining_Identifier (S); - end if; - end if; + procedure Check_Arg_Is_Identifier (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is an + -- identifier. If not give error and raise Pragma_Exit. - -- Note: we do not analyze the pragma at this point. Instead we - -- delay this analysis until the end of the declarative part in - -- which the pragma appears. This implements the required delay - -- in this analysis, allowing forward references. The analysis - -- happens at the end of Analyze_Declarations. + procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is an integer + -- literal. If not give error and raise Pragma_Exit. - -- Chain spec PPC pragma to list for subprogram + procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it has the proper + -- syntactic form for a local name and meets the semantic requirements + -- for a local name. The local name is analyzed as part of the + -- processing for this call. In addition, the local name is required + -- to represent an entity at the library level. - Set_Next_Pragma (N, Spec_PPC_List (Contract (S))); - Set_Spec_PPC_List (Contract (S), N); + procedure Check_Arg_Is_Local_Name (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it has the proper + -- syntactic form for a local name and meets the semantic requirements + -- for a local name. The local name is analyzed as part of the + -- processing for this call. - -- Return indicating spec case + procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is a valid + -- locking policy name. If not give error and raise Pragma_Exit. - In_Body := False; - return; - end Chain_PPC; + procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is a valid + -- elaboration policy name. If not give error and raise Pragma_Exit. - -- Start of processing for Check_Precondition_Postcondition + procedure Check_Arg_Is_One_Of + (Arg : Node_Id; + N1, N2 : Name_Id); + procedure Check_Arg_Is_One_Of + (Arg : Node_Id; + N1, N2, N3 : Name_Id); + procedure Check_Arg_Is_One_Of + (Arg : Node_Id; + N1, N2, N3, N4 : Name_Id); + procedure Check_Arg_Is_One_Of + (Arg : Node_Id; + N1, N2, N3, N4, N5 : Name_Id); + -- Check the specified argument Arg to make sure that it is an + -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if + -- present). If not then give error and raise Pragma_Exit. - begin - if not Is_List_Member (N) then - Pragma_Misplaced; - end if; + procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is a valid + -- queuing policy name. If not give error and raise Pragma_Exit. - -- Preanalyze message argument if present. Visibility in this - -- argument is established at the point of pragma occurrence. + procedure Check_Arg_Is_Static_Expression + (Arg : Node_Id; + Typ : Entity_Id := Empty); + -- Check the specified argument Arg to make sure that it is a static + -- expression of the given type (i.e. it will be analyzed and resolved + -- using this type, which can be any valid argument to Resolve, e.g. + -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If + -- Typ is left Empty, then any static expression is allowed. - if Arg_Count = 2 then - Check_Optional_Identifier (Arg2, Name_Message); - Preanalyze_Spec_Expression - (Get_Pragma_Arg (Arg2), Standard_String); - end if; + procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); + -- Check the specified argument Arg to make sure that it is a valid task + -- dispatching policy name. If not give error and raise Pragma_Exit. - -- For a pragma PPC in the extended main source unit, record enabled - -- status in SCO. + procedure Check_Arg_Order (Names : Name_List); + -- Checks for an instance of two arguments with identifiers for the + -- current pragma which are not in the sequence indicated by Names, + -- and if so, generates a fatal message about bad order of arguments. - if not Is_Ignored (N) and then not Split_PPC (N) then - Set_SCO_Pragma_Enabled (Loc); - end if; + procedure Check_At_Least_N_Arguments (N : Nat); + -- Check there are at least N arguments present - -- If we are within an inlined body, the legality of the pragma - -- has been checked already. + procedure Check_At_Most_N_Arguments (N : Nat); + -- Check there are no more than N arguments present - if In_Inlined_Body then - In_Body := True; - return; - end if; + procedure Check_Component + (Comp : Node_Id; + UU_Typ : Entity_Id; + In_Variant_Part : Boolean := False); + -- Examine an Unchecked_Union component for correct use of per-object + -- constrained subtypes, and for restrictions on finalizable components. + -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part + -- should be set when Comp comes from a record variant. - -- Search prior declarations + procedure Check_Test_Case; + -- Called to process a test-case pragma. It starts with checking pragma + -- arguments, and the rest of the treatment is similar to the one for + -- pre- and postcondition in Check_Precondition_Postcondition, except + -- the placement rules for the test-case pragma are stricter. These + -- pragmas may only occur after a subprogram spec declared directly + -- in a package spec unit. In this case, the pragma is chained to the + -- subprogram in question (using Contract_Test_Cases and Next_Pragma) + -- and analysis of the pragma is delayed till the end of the spec. In + -- all other cases, an error message for bad placement is given. - P := N; - while Present (Prev (P)) loop - P := Prev (P); + procedure Check_Duplicate_Pragma (E : Entity_Id); + -- Check if a rep item of the same name as the current pragma is already + -- chained as a rep pragma to the given entity. If so give a message + -- about the duplicate, and then raise Pragma_Exit so does not return. - -- If the previous node is a generic subprogram, do not go to to - -- the original node, which is the unanalyzed tree: we need to - -- attach the pre/postconditions to the analyzed version at this - -- point. They get propagated to the original tree when analyzing - -- the corresponding body. + procedure Check_Duplicated_Export_Name (Nam : Node_Id); + -- Nam is an N_String_Literal node containing the external name set by + -- an Import or Export pragma (or extended Import or Export pragma). + -- This procedure checks for possible duplications if this is the export + -- case, and if found, issues an appropriate error message. - if Nkind (P) not in N_Generic_Declaration then - PO := Original_Node (P); - else - PO := P; - end if; + procedure Check_Expr_Is_Static_Expression + (Expr : Node_Id; + Typ : Entity_Id := Empty); + -- Check the specified expression Expr to make sure that it is a static + -- expression of the given type (i.e. it will be analyzed and resolved + -- using this type, which can be any valid argument to Resolve, e.g. + -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If + -- Typ is left Empty, then any static expression is allowed. - -- Skip past prior pragma + procedure Check_First_Subtype (Arg : Node_Id); + -- Checks that Arg, whose expression is an entity name, references a + -- first subtype. - if Nkind (PO) = N_Pragma then - null; + procedure Check_Identifier (Arg : Node_Id; Id : Name_Id); + -- Checks that the given argument has an identifier, and if so, requires + -- it to match the given identifier name. If there is no identifier, or + -- a non-matching identifier, then an error message is given and + -- Pragma_Exit is raised. - -- Skip stuff not coming from source + procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id); + -- Checks that the given argument has an identifier, and if so, requires + -- it to match one of the given identifier names. If there is no + -- identifier, or a non-matching identifier, then an error message is + -- given and Pragma_Exit is raised. - elsif not Comes_From_Source (PO) then + procedure Check_In_Main_Program; + -- Common checks for pragmas that appear within a main program + -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU). - -- The condition may apply to a subprogram instantiation + procedure Check_Interrupt_Or_Attach_Handler; + -- Common processing for first argument of pragma Interrupt_Handler or + -- pragma Attach_Handler. - if Nkind (PO) = N_Subprogram_Declaration - and then Present (Generic_Parent (Specification (PO))) - then - Chain_PPC (PO); - return; + procedure Check_Loop_Pragma_Placement; + -- Verify whether pragma Loop_Invariant or Loop_Optimize or Loop_Variant + -- appear immediately within a construct restricted to loops. - elsif Nkind (PO) = N_Subprogram_Declaration - and then In_Instance - then - Chain_PPC (PO); - return; + procedure Check_Is_In_Decl_Part_Or_Package_Spec; + -- Check that pragma appears in a declarative part, or in a package + -- specification, i.e. that it does not occur in a statement sequence + -- in a body. - -- For all other cases of non source code, do nothing + procedure Check_No_Identifier (Arg : Node_Id); + -- Checks that the given argument does not have an identifier. If + -- an identifier is present, then an error message is issued, and + -- Pragma_Exit is raised. - else - null; - end if; + procedure Check_No_Identifiers; + -- Checks that none of the arguments to the pragma has an identifier. + -- If any argument has an identifier, then an error message is issued, + -- and Pragma_Exit is raised. - -- Only remaining possibility is subprogram declaration + procedure Check_No_Link_Name; + -- Checks that no link name is specified - else - Chain_PPC (PO); - return; - end if; - end loop; + procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id); + -- Checks if the given argument has an identifier, and if so, requires + -- it to match the given identifier name. If there is a non-matching + -- identifier, then an error message is given and Pragma_Exit is raised. - -- If we fall through loop, pragma is at start of list, so see if it - -- is at the start of declarations of a subprogram body. + procedure Check_Optional_Identifier (Arg : Node_Id; Id : String); + -- Checks if the given argument has an identifier, and if so, requires + -- it to match the given identifier name. If there is a non-matching + -- identifier, then an error message is given and Pragma_Exit is raised. + -- In this version of the procedure, the identifier name is given as + -- a string with lower case letters. - if Nkind (Parent (N)) = N_Subprogram_Body - and then List_Containing (N) = Declarations (Parent (N)) - then - if Operating_Mode /= Generate_Code - or else Inside_A_Generic - then - -- Analyze pragma expression for correctness and for ASIS use + procedure Check_Precondition_Postcondition (In_Body : out Boolean); + -- Called to process a precondition or postcondition pragma. There are + -- three cases: + -- + -- The pragma appears after a subprogram spec + -- + -- If the corresponding check is not enabled, the pragma is analyzed + -- but otherwise ignored and control returns with In_Body set False. + -- + -- If the check is enabled, then the first step is to analyze the + -- pragma, but this is skipped if the subprogram spec appears within + -- a package specification (because this is the case where we delay + -- analysis till the end of the spec). Then (whether or not it was + -- analyzed), the pragma is chained to the subprogram in question + -- (using Pre_Post_Conditions and Next_Pragma) and control returns + -- to the caller with In_Body set False. + -- + -- The pragma appears at the start of subprogram body declarations + -- + -- In this case an immediate return to the caller is made with + -- In_Body set True, and the pragma is NOT analyzed. + -- + -- In all other cases, an error message for bad placement is given - Preanalyze_Assert_Expression - (Get_Pragma_Arg (Arg1), Standard_Boolean); + procedure Check_Static_Constraint (Constr : Node_Id); + -- Constr is a constraint from an N_Subtype_Indication node from a + -- component constraint in an Unchecked_Union type. This routine checks + -- that the constraint is static as required by the restrictions for + -- Unchecked_Union. - -- In ASIS mode, for a pragma generated from a source aspect, - -- also analyze the original aspect expression. + procedure Check_Valid_Configuration_Pragma; + -- Legality checks for placement of a configuration pragma - if ASIS_Mode and then Present (Corresponding_Aspect (N)) then - Preanalyze_Assert_Expression - (Expression (Corresponding_Aspect (N)), Standard_Boolean); - end if; - end if; + procedure Check_Valid_Library_Unit_Pragma; + -- Legality checks for library unit pragmas. A special case arises for + -- pragmas in generic instances that come from copies of the original + -- library unit pragmas in the generic templates. In the case of other + -- than library level instantiations these can appear in contexts which + -- would normally be invalid (they only apply to the original template + -- and to library level instantiations), and they are simply ignored, + -- which is implemented by rewriting them as null statements. - In_Body := True; - return; + procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id); + -- Check an Unchecked_Union variant for lack of nested variants and + -- presence of at least one component. UU_Typ is the related Unchecked_ + -- Union type. - -- See if it is in the pragmas after a library level subprogram + procedure Error_Pragma (Msg : String); + pragma No_Return (Error_Pragma); + -- Outputs error message for current pragma. The message contains a % + -- that will be replaced with the pragma name, and the flag is placed + -- on the pragma itself. Pragma_Exit is then raised. Note: this routine + -- calls Fix_Error (see spec of that procedure for details). - elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then + procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id); + pragma No_Return (Error_Pragma_Arg); + -- Outputs error message for current pragma. The message may contain + -- a % that will be replaced with the pragma name. The parameter Arg + -- may either be a pragma argument association, in which case the flag + -- is placed on the expression of this association, or an expression, + -- in which case the flag is placed directly on the expression. The + -- message is placed using Error_Msg_N, so the message may also contain + -- an & insertion character which will reference the given Arg value. + -- After placing the message, Pragma_Exit is raised. Note: this routine + -- calls Fix_Error (see spec of that procedure for details). - -- In formal verification mode, analyze pragma expression for - -- correctness, as it is not expanded later. + procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id); + pragma No_Return (Error_Pragma_Arg); + -- Similar to above form of Error_Pragma_Arg except that two messages + -- are provided, the second is a continuation comment starting with \. - if Alfa_Mode then - Analyze_PPC_In_Decl_Part - (N, Defining_Entity (Unit (Parent (Parent (N))))); - end if; + procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id); + pragma No_Return (Error_Pragma_Arg_Ident); + -- Outputs error message for current pragma. The message may contain + -- a % that will be replaced with the pragma name. The parameter Arg + -- must be a pragma argument association with a non-empty identifier + -- (i.e. its Chars field must be set), and the error message is placed + -- on the identifier. The message is placed using Error_Msg_N so + -- the message may also contain an & insertion character which will + -- reference the identifier. After placing the message, Pragma_Exit + -- is raised. Note: this routine calls Fix_Error (see spec of that + -- procedure for details). - Chain_PPC (Unit (Parent (Parent (N)))); - return; - end if; + procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id); + pragma No_Return (Error_Pragma_Ref); + -- Outputs error message for current pragma. The message may contain + -- a % that will be replaced with the pragma name. The parameter Ref + -- must be an entity whose name can be referenced by & and sloc by #. + -- After placing the message, Pragma_Exit is raised. Note: this routine + -- calls Fix_Error (see spec of that procedure for details). - -- If we fall through, pragma was misplaced + function Find_Lib_Unit_Name return Entity_Id; + -- Used for a library unit pragma to find the entity to which the + -- library unit pragma applies, returns the entity found. - Pragma_Misplaced; - end Check_Precondition_Postcondition; + procedure Find_Program_Unit_Name (Id : Node_Id); + -- If the pragma is a compilation unit pragma, the id must denote the + -- compilation unit in the same compilation, and the pragma must appear + -- in the list of preceding or trailing pragmas. If it is a program + -- unit pragma that is not a compilation unit pragma, then the + -- identifier must be visible. - ----------------------------- - -- Check_Static_Constraint -- - ----------------------------- + function Find_Unique_Parameterless_Procedure + (Name : Entity_Id; + Arg : Node_Id) return Entity_Id; + -- Used for a procedure pragma to find the unique parameterless + -- procedure identified by Name, returns it if it exists, otherwise + -- errors out and uses Arg as the pragma argument for the message. - -- Note: for convenience in writing this procedure, in addition to - -- the officially (i.e. by spec) allowed argument which is always a - -- constraint, it also allows ranges and discriminant associations. - -- Above is not clear ??? + procedure Fix_Error (Msg : in out String); + -- This is called prior to issuing an error message. Msg is a string + -- that typically contains the substring "pragma". If the pragma comes + -- from an aspect, each such "pragma" substring is replaced with the + -- characters "aspect", and Error_Msg_Name_1 is set to the name of the + -- aspect (which may be different from the pragma name). If the current + -- pragma results from rewriting another pragma, then Error_Msg_Name_1 + -- is set to the original pragma name. - procedure Check_Static_Constraint (Constr : Node_Id) is + procedure Gather_Associations + (Names : Name_List; + Args : out Args_List); + -- This procedure is used to gather the arguments for a pragma that + -- permits arbitrary ordering of parameters using the normal rules + -- for named and positional parameters. The Names argument is a list + -- of Name_Id values that corresponds to the allowed pragma argument + -- association identifiers in order. The result returned in Args is + -- a list of corresponding expressions that are the pragma arguments. + -- Note that this is a list of expressions, not of pragma argument + -- associations (Gather_Associations has completely checked all the + -- optional identifiers when it returns). An entry in Args is Empty + -- on return if the corresponding argument is not present. - procedure Require_Static (E : Node_Id); - -- Require given expression to be static expression + procedure GNAT_Pragma; + -- Called for all GNAT defined pragmas to check the relevant restriction + -- (No_Implementation_Pragmas). - -------------------- - -- Require_Static -- - -------------------- + procedure S14_Pragma; + -- Called for all pragmas defined for formal verification to check that + -- the S14_Extensions flag is set. + -- This name needs fixing ??? There is no such thing as an + -- "S14_Extensions" flag ??? - procedure Require_Static (E : Node_Id) is - begin - if not Is_OK_Static_Expression (E) then - Flag_Non_Static_Expr - ("non-static constraint not allowed in Unchecked_Union!", E); - raise Pragma_Exit; - end if; - end Require_Static; + function Is_Before_First_Decl + (Pragma_Node : Node_Id; + Decls : List_Id) return Boolean; + -- Return True if Pragma_Node is before the first declarative item in + -- Decls where Decls is the list of declarative items. - -- Start of processing for Check_Static_Constraint + function Is_Configuration_Pragma return Boolean; + -- Determines if the placement of the current pragma is appropriate + -- for a configuration pragma. - begin - case Nkind (Constr) is - when N_Discriminant_Association => - Require_Static (Expression (Constr)); + function Is_In_Context_Clause return Boolean; + -- Returns True if pragma appears within the context clause of a unit, + -- and False for any other placement (does not generate any messages). - when N_Range => - Require_Static (Low_Bound (Constr)); - Require_Static (High_Bound (Constr)); + function Is_Static_String_Expression (Arg : Node_Id) return Boolean; + -- Analyzes the argument, and determines if it is a static string + -- expression, returns True if so, False if non-static or not String. - when N_Attribute_Reference => - Require_Static (Type_Low_Bound (Etype (Prefix (Constr)))); - Require_Static (Type_High_Bound (Etype (Prefix (Constr)))); + procedure Pragma_Misplaced; + pragma No_Return (Pragma_Misplaced); + -- Issue fatal error message for misplaced pragma - when N_Range_Constraint => - Check_Static_Constraint (Range_Expression (Constr)); + procedure Process_Atomic_Shared_Volatile; + -- Common processing for pragmas Atomic, Shared, Volatile. Note that + -- Shared is an obsolete Ada 83 pragma, treated as being identical + -- in effect to pragma Atomic. - when N_Index_Or_Discriminant_Constraint => - declare - IDC : Entity_Id; - begin - IDC := First (Constraints (Constr)); - while Present (IDC) loop - Check_Static_Constraint (IDC); - Next (IDC); - end loop; - end; + procedure Process_Compile_Time_Warning_Or_Error; + -- Common processing for Compile_Time_Error and Compile_Time_Warning - when others => - null; - end case; - end Check_Static_Constraint; + procedure Process_Convention + (C : out Convention_Id; + Ent : out Entity_Id); + -- Common processing for Convention, Interface, Import and Export. + -- Checks first two arguments of pragma, and sets the appropriate + -- convention value in the specified entity or entities. On return + -- C is the convention, Ent is the referenced entity. - --------------------- - -- Check_Test_Case -- - --------------------- + procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id); + -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is + -- Name_Suppress for Disable and Name_Unsuppress for Enable. - procedure Check_Test_Case is - P : Node_Id; - PO : Node_Id; + procedure Process_Extended_Import_Export_Exception_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Form : Node_Id; + Arg_Code : Node_Id); + -- Common processing for the pragmas Import/Export_Exception. The three + -- arguments correspond to the three named parameters of the pragma. An + -- argument is empty if the corresponding parameter is not present in + -- the pragma. - procedure Chain_CTC (PO : Node_Id); - -- If PO is a [generic] subprogram declaration node, then the - -- test-case applies to this subprogram and the processing for - -- the pragma is completed. Otherwise the pragma is misplaced. + procedure Process_Extended_Import_Export_Object_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Size : Node_Id); + -- Common processing for the pragmas Import/Export_Object. The three + -- arguments correspond to the three named parameters of the pragmas. An + -- argument is empty if the corresponding parameter is not present in + -- the pragma. - --------------- - -- Chain_CTC -- - --------------- + procedure Process_Extended_Import_Export_Internal_Arg + (Arg_Internal : Node_Id := Empty); + -- Common processing for all extended Import and Export pragmas. The + -- argument is the pragma parameter for the Internal argument. If + -- Arg_Internal is empty or inappropriate, an error message is posted. + -- Otherwise, on normal return, the Entity_Field of Arg_Internal is + -- set to identify the referenced entity. - procedure Chain_CTC (PO : Node_Id) is - S : Entity_Id; + procedure Process_Extended_Import_Export_Subprogram_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Parameter_Types : Node_Id; + Arg_Result_Type : Node_Id := Empty; + Arg_Mechanism : Node_Id; + Arg_Result_Mechanism : Node_Id := Empty; + Arg_First_Optional_Parameter : Node_Id := Empty); + -- Common processing for all extended Import and Export pragmas applying + -- to subprograms. The caller omits any arguments that do not apply to + -- the pragma in question (for example, Arg_Result_Type can be non-Empty + -- only in the Import_Function and Export_Function cases). The argument + -- names correspond to the allowed pragma association identifiers. + + procedure Process_Generic_List; + -- Common processing for Share_Generic and Inline_Generic + + procedure Process_Import_Or_Interface; + -- Common processing for Import of Interface - begin - if Nkind (PO) = N_Abstract_Subprogram_Declaration then - Error_Pragma - ("pragma% cannot be applied to abstract subprogram"); + procedure Process_Import_Predefined_Type; + -- Processing for completing a type with pragma Import. This is used + -- to declare types that match predefined C types, especially for cases + -- without corresponding Ada predefined type. - elsif Nkind (PO) = N_Entry_Declaration then - Error_Pragma ("pragma% cannot be applied to entry"); + type Inline_Status is (Suppressed, Disabled, Enabled); + -- Inline status of a subprogram, indicated as follows: + -- Suppressed: inlining is suppressed for the subprogram + -- Disabled: no inlining is requested for the subprogram + -- Enabled: inlining is requested/required for the subprogram - elsif not Nkind_In (PO, N_Subprogram_Declaration, - N_Generic_Subprogram_Declaration) - then - Pragma_Misplaced; - end if; + procedure Process_Inline (Status : Inline_Status); + -- Common processing for Inline, Inline_Always and No_Inline. Parameter + -- indicates the inline status specified by the pragma. - -- Here if we have [generic] subprogram declaration + procedure Process_Interface_Name + (Subprogram_Def : Entity_Id; + Ext_Arg : Node_Id; + Link_Arg : Node_Id); + -- Given the last two arguments of pragma Import, pragma Export, or + -- pragma Interface_Name, performs validity checks and sets the + -- Interface_Name field of the given subprogram entity to the + -- appropriate external or link name, depending on the arguments given. + -- Ext_Arg is always present, but Link_Arg may be missing. Note that + -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and + -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg + -- nor Link_Arg is present, the interface name is set to the default + -- from the subprogram name. - S := Defining_Unit_Name (Specification (PO)); + procedure Process_Interrupt_Or_Attach_Handler; + -- Common processing for Interrupt and Attach_Handler pragmas - -- Note: we do not analyze the pragma at this point. Instead we - -- delay this analysis until the end of the declarative part in - -- which the pragma appears. This implements the required delay - -- in this analysis, allowing forward references. The analysis - -- happens at the end of Analyze_Declarations. + procedure Process_Restrictions_Or_Restriction_Warnings (Warn : Boolean); + -- Common processing for Restrictions and Restriction_Warnings pragmas. + -- Warn is True for Restriction_Warnings, or for Restrictions if the + -- flag Treat_Restrictions_As_Warnings is set, and False if this flag + -- is not set in the Restrictions case. - -- There should not be another test-case with the same name - -- associated to this subprogram. + procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean); + -- Common processing for Suppress and Unsuppress. The boolean parameter + -- Suppress_Case is True for the Suppress case, and False for the + -- Unsuppress case. - declare - Name : constant String_Id := Get_Name_From_CTC_Pragma (N); - CTC : Node_Id; + procedure Set_Exported (E : Entity_Id; Arg : Node_Id); + -- This procedure sets the Is_Exported flag for the given entity, + -- checking that the entity was not previously imported. Arg is + -- the argument that specified the entity. A check is also made + -- for exporting inappropriate entities. - begin - CTC := Spec_CTC_List (Contract (S)); - while Present (CTC) loop + procedure Set_Extended_Import_Export_External_Name + (Internal_Ent : Entity_Id; + Arg_External : Node_Id); + -- Common processing for all extended import export pragmas. The first + -- argument, Internal_Ent, is the internal entity, which has already + -- been checked for validity by the caller. Arg_External is from the + -- Import or Export pragma, and may be null if no External parameter + -- was present. If Arg_External is present and is a non-null string + -- (a null string is treated as the default), then the Interface_Name + -- field of Internal_Ent is set appropriately. - -- Omit pragma Contract_Cases because it does not introduce - -- a unique case name and it does not follow the syntax of - -- Test_Case. + procedure Set_Imported (E : Entity_Id); + -- This procedure sets the Is_Imported flag for the given entity, + -- checking that it is not previously exported or imported. - if Pragma_Name (CTC) = Name_Contract_Cases then - null; + procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id); + -- Mech is a parameter passing mechanism (see Import_Function syntax + -- for MECHANISM_NAME). This routine checks that the mechanism argument + -- has the right form, and if not issues an error message. If the + -- argument has the right form then the Mechanism field of Ent is + -- set appropriately. - 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; + procedure Set_Rational_Profile; + -- Activate the set of configuration pragmas and permissions that make + -- up the Rational profile. - CTC := Next_Pragma (CTC); - end loop; - end; + procedure Set_Ravenscar_Profile (N : Node_Id); + -- Activate the set of configuration pragmas and restrictions that make + -- up the Ravenscar Profile. N is the corresponding pragma node, which + -- is used for error messages on any constructs that violate the + -- profile. - -- Chain spec CTC pragma to list for subprogram + --------------------- + -- Ada_2005_Pragma -- + --------------------- - Set_Next_Pragma (N, Spec_CTC_List (Contract (S))); - Set_Spec_CTC_List (Contract (S), N); - end Chain_CTC; + procedure Ada_2005_Pragma is + begin + if Ada_Version <= Ada_95 then + Check_Restriction (No_Implementation_Pragmas, N); + end if; + end Ada_2005_Pragma; - -- Start of processing for Check_Test_Case + --------------------- + -- Ada_2012_Pragma -- + --------------------- + procedure Ada_2012_Pragma is begin - -- First check pragma arguments + if Ada_Version <= Ada_2005 then + Check_Restriction (No_Implementation_Pragmas, N); + end if; + end Ada_2012_Pragma; - GNAT_Pragma; - Check_At_Least_N_Arguments (2); - Check_At_Most_N_Arguments (4); - Check_Arg_Order - ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); + -------------------------- + -- Check_Ada_83_Warning -- + -------------------------- - Check_Optional_Identifier (Arg1, Name_Name); - Check_Arg_Is_Static_Expression (Arg1, Standard_String); + procedure Check_Ada_83_Warning is + begin + if Ada_Version = Ada_83 and then Comes_From_Source (N) then + Error_Msg_N ("(Ada 83) pragma& is non-standard??", N); + end if; + end Check_Ada_83_Warning; - -- In ASIS mode, for a pragma generated from a source aspect, also - -- analyze the original aspect expression. + --------------------- + -- Check_Arg_Count -- + --------------------- - if ASIS_Mode and then Present (Corresponding_Aspect (N)) then - Check_Expr_Is_Static_Expression - (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String); + procedure Check_Arg_Count (Required : Nat) is + begin + if Arg_Count /= Required then + Error_Pragma ("wrong number of arguments for pragma%"); end if; + end Check_Arg_Count; - Check_Optional_Identifier (Arg2, Name_Mode); - Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness); + -------------------------------- + -- Check_Arg_Is_External_Name -- + -------------------------------- - if Arg_Count = 4 then - Check_Identifier (Arg3, Name_Requires); - Check_Identifier (Arg4, Name_Ensures); + procedure Check_Arg_Is_External_Name (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); - elsif Arg_Count = 3 then - Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures); - end if; + begin + if Nkind (Argx) = N_Identifier then + return; - -- Check pragma placement + else + Analyze_And_Resolve (Argx, Standard_String); - if not Is_List_Member (N) then - Pragma_Misplaced; - end if; + if Is_OK_Static_Expression (Argx) then + return; - -- Test-case should only appear in package spec unit + elsif Etype (Argx) = Any_Type then + raise Pragma_Exit; - if Get_Source_Unit (N) = No_Unit - or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))), - N_Package_Declaration, - N_Generic_Package_Declaration) - then - Pragma_Misplaced; - end if; + -- An interesting special case, if we have a string literal and + -- we are in Ada 83 mode, then we allow it even though it will + -- not be flagged as static. This allows expected Ada 83 mode + -- use of external names which are string literals, even though + -- technically these are not static in Ada 83. - -- Search prior declarations + elsif Ada_Version = Ada_83 + and then Nkind (Argx) = N_String_Literal + then + return; - P := N; - while Present (Prev (P)) loop - P := Prev (P); + -- Static expression that raises Constraint_Error. This has + -- already been flagged, so just exit from pragma processing. - -- If the previous node is a generic subprogram, do not go to to - -- the original node, which is the unanalyzed tree: we need to - -- attach the test-case to the analyzed version at this point. - -- They get propagated to the original tree when analyzing the - -- corresponding body. + elsif Is_Static_Expression (Argx) then + raise Pragma_Exit; + + -- Here we have a real error (non-static expression) - if Nkind (P) not in N_Generic_Declaration then - PO := Original_Node (P); else - PO := P; + Error_Msg_Name_1 := Pname; + + declare + Msg : String := + "argument for pragma% must be a identifier or " + & "static string expression!"; + begin + Fix_Error (Msg); + Flag_Non_Static_Expr (Msg, Argx); + raise Pragma_Exit; + end; end if; + end if; + end Check_Arg_Is_External_Name; - -- Skip past prior pragma + ----------------------------- + -- Check_Arg_Is_Identifier -- + ----------------------------- - if Nkind (PO) = N_Pragma then - null; + procedure Check_Arg_Is_Identifier (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + begin + if Nkind (Argx) /= N_Identifier then + Error_Pragma_Arg + ("argument for pragma% must be identifier", Argx); + end if; + end Check_Arg_Is_Identifier; - -- Skip stuff not coming from source + ---------------------------------- + -- Check_Arg_Is_Integer_Literal -- + ---------------------------------- - elsif not Comes_From_Source (PO) then - null; + procedure Check_Arg_Is_Integer_Literal (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + begin + if Nkind (Argx) /= N_Integer_Literal then + Error_Pragma_Arg + ("argument for pragma% must be integer literal", Argx); + end if; + end Check_Arg_Is_Integer_Literal; - -- Only remaining possibility is subprogram declaration. First - -- check that it is declared directly in a package declaration. - -- This may be either the package declaration for the current unit - -- being defined or a local package declaration. + ------------------------------------------- + -- Check_Arg_Is_Library_Level_Local_Name -- + ------------------------------------------- - elsif not Present (Parent (Parent (PO))) - or else not Present (Parent (Parent (Parent (PO)))) - or else not Nkind_In (Parent (Parent (PO)), - N_Package_Declaration, - N_Generic_Package_Declaration) - then - Pragma_Misplaced; + -- LOCAL_NAME ::= + -- DIRECT_NAME + -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR + -- | library_unit_NAME - else - Chain_CTC (PO); - return; - end if; - end loop; + procedure Check_Arg_Is_Library_Level_Local_Name (Arg : Node_Id) is + begin + Check_Arg_Is_Local_Name (Arg); - -- If we fall through, pragma was misplaced + if not Is_Library_Level_Entity (Entity (Get_Pragma_Arg (Arg))) + and then Comes_From_Source (N) + then + Error_Pragma_Arg + ("argument for pragma% must be library level entity", Arg); + end if; + end Check_Arg_Is_Library_Level_Local_Name; - Pragma_Misplaced; - end Check_Test_Case; + ----------------------------- + -- Check_Arg_Is_Local_Name -- + ----------------------------- - -------------------------------------- - -- Check_Valid_Configuration_Pragma -- - -------------------------------------- + -- LOCAL_NAME ::= + -- DIRECT_NAME + -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR + -- | library_unit_NAME - -- A configuration pragma must appear in the context clause of a - -- compilation unit, and only other pragmas may precede it. Note that - -- the test also allows use in a configuration pragma file. + procedure Check_Arg_Is_Local_Name (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); - procedure Check_Valid_Configuration_Pragma is begin - if not Is_Configuration_Pragma then - Error_Pragma ("incorrect placement for configuration pragma%"); - end if; - end Check_Valid_Configuration_Pragma; + Analyze (Argx); - ------------------------------------- - -- Check_Valid_Library_Unit_Pragma -- - ------------------------------------- + if Nkind (Argx) not in N_Direct_Name + and then (Nkind (Argx) /= N_Attribute_Reference + or else Present (Expressions (Argx)) + or else Nkind (Prefix (Argx)) /= N_Identifier) + and then (not Is_Entity_Name (Argx) + or else not Is_Compilation_Unit (Entity (Argx))) + then + Error_Pragma_Arg ("argument for pragma% must be local name", Argx); + end if; - procedure Check_Valid_Library_Unit_Pragma is - Plist : List_Id; - Parent_Node : Node_Id; - Unit_Name : Entity_Id; - Unit_Kind : Node_Kind; - Unit_Node : Node_Id; - Sindex : Source_File_Index; + -- No further check required if not an entity name - begin - if not Is_List_Member (N) then - Pragma_Misplaced; + if not Is_Entity_Name (Argx) then + null; else - Plist := List_Containing (N); - Parent_Node := Parent (Plist); + declare + OK : Boolean; + Ent : constant Entity_Id := Entity (Argx); + Scop : constant Entity_Id := Scope (Ent); - if Parent_Node = Empty then - Pragma_Misplaced; + begin + -- Case of a pragma applied to a compilation unit: pragma must + -- occur immediately after the program unit in the compilation. - -- Case of pragma appearing after a compilation unit. In this case - -- it must have an argument with the corresponding name and must - -- be part of the following pragmas of its parent. + if Is_Compilation_Unit (Ent) then + declare + Decl : constant Node_Id := Unit_Declaration_Node (Ent); - elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then - if Plist /= Pragmas_After (Parent_Node) then - Pragma_Misplaced; + begin + -- Case of pragma placed immediately after spec - elsif Arg_Count = 0 then - Error_Pragma - ("argument required if outside compilation unit"); + if Parent (N) = Aux_Decls_Node (Parent (Decl)) then + OK := True; - else - Check_No_Identifiers; - Check_Arg_Count (1); - Unit_Node := Unit (Parent (Parent_Node)); - Unit_Kind := Nkind (Unit_Node); + -- Case of pragma placed immediately after body - Analyze (Get_Pragma_Arg (Arg1)); + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + then + OK := Parent (N) = + Aux_Decls_Node + (Parent (Unit_Declaration_Node + (Corresponding_Body (Decl)))); - if Unit_Kind = N_Generic_Subprogram_Declaration - or else Unit_Kind = N_Subprogram_Declaration - then - Unit_Name := Defining_Entity (Unit_Node); + -- All other cases are illegal - elsif Unit_Kind in N_Generic_Instantiation then - Unit_Name := Defining_Entity (Unit_Node); + else + OK := False; + end if; + end; - else - Unit_Name := Cunit_Entity (Current_Sem_Unit); - end if; + -- Special restricted placement rule from 10.2.1(11.8/2) - if Chars (Unit_Name) /= - Chars (Entity (Get_Pragma_Arg (Arg1))) - then - Error_Pragma_Arg - ("pragma% argument is not current unit name", Arg1); - end if; + elsif Is_Generic_Formal (Ent) + and then Prag_Id = Pragma_Preelaborable_Initialization + then + OK := List_Containing (N) = + Generic_Formal_Declarations + (Unit_Declaration_Node (Scop)); - if Ekind (Unit_Name) = E_Package - and then Present (Renamed_Entity (Unit_Name)) - then - Error_Pragma ("pragma% not allowed for renamed package"); - end if; + -- Default case, just check that the pragma occurs in the scope + -- of the entity denoted by the name. + + else + OK := Current_Scope = Scop; end if; - -- Pragma appears other than after a compilation unit + if not OK then + Error_Pragma_Arg + ("pragma% argument must be in same declarative part", Arg); + end if; + end; + end if; + end Check_Arg_Is_Local_Name; - else - -- Here we check for the generic instantiation case and also - -- for the case of processing a generic formal package. We - -- detect these cases by noting that the Sloc on the node - -- does not belong to the current compilation unit. + --------------------------------- + -- Check_Arg_Is_Locking_Policy -- + --------------------------------- - Sindex := Source_Index (Current_Sem_Unit); + procedure Check_Arg_Is_Locking_Policy (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); - if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then - Rewrite (N, Make_Null_Statement (Loc)); - return; + begin + Check_Arg_Is_Identifier (Argx); - -- If before first declaration, the pragma applies to the - -- enclosing unit, and the name if present must be this name. + if not Is_Locking_Policy_Name (Chars (Argx)) then + Error_Pragma_Arg ("& is not a valid locking policy name", Argx); + end if; + end Check_Arg_Is_Locking_Policy; - elsif Is_Before_First_Decl (N, Plist) then - Unit_Node := Unit_Declaration_Node (Current_Scope); - Unit_Kind := Nkind (Unit_Node); + ----------------------------------------------- + -- Check_Arg_Is_Partition_Elaboration_Policy -- + ----------------------------------------------- - if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then - Pragma_Misplaced; + procedure Check_Arg_Is_Partition_Elaboration_Policy (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); - elsif Unit_Kind = N_Subprogram_Body - and then not Acts_As_Spec (Unit_Node) - then - Pragma_Misplaced; + begin + Check_Arg_Is_Identifier (Argx); - elsif Nkind (Parent_Node) = N_Package_Body then - Pragma_Misplaced; + if not Is_Partition_Elaboration_Policy_Name (Chars (Argx)) then + Error_Pragma_Arg + ("& is not a valid partition elaboration policy name", Argx); + end if; + end Check_Arg_Is_Partition_Elaboration_Policy; - elsif Nkind (Parent_Node) = N_Package_Specification - and then Plist = Private_Declarations (Parent_Node) - then - Pragma_Misplaced; + ------------------------- + -- Check_Arg_Is_One_Of -- + ------------------------- - elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration - or else Nkind (Parent_Node) = - N_Generic_Subprogram_Declaration) - and then Plist = Generic_Formal_Declarations (Parent_Node) - then - Pragma_Misplaced; + procedure Check_Arg_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); - elsif Arg_Count > 0 then - Analyze (Get_Pragma_Arg (Arg1)); + begin + Check_Arg_Is_Identifier (Argx); + + if not Nam_In (Chars (Argx), N1, N2) then + Error_Msg_Name_2 := N1; + Error_Msg_Name_3 := N2; + Error_Pragma_Arg ("argument for pragma% must be% or%", Argx); + end if; + end Check_Arg_Is_One_Of; + + procedure Check_Arg_Is_One_Of + (Arg : Node_Id; + N1, N2, N3 : Name_Id) + is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + + begin + Check_Arg_Is_Identifier (Argx); + + if not Nam_In (Chars (Argx), N1, N2, N3) then + Error_Pragma_Arg ("invalid argument for pragma%", Argx); + end if; + end Check_Arg_Is_One_Of; - if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then - Error_Pragma_Arg - ("name in pragma% must be enclosing unit", Arg1); - end if; + procedure Check_Arg_Is_One_Of + (Arg : Node_Id; + N1, N2, N3, N4 : Name_Id) + is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); - -- It is legal to have no argument in this context + begin + Check_Arg_Is_Identifier (Argx); - else - return; - end if; + if not Nam_In (Chars (Argx), N1, N2, N3, N4) then + Error_Pragma_Arg ("invalid argument for pragma%", Argx); + end if; + end Check_Arg_Is_One_Of; - -- Error if not before first declaration. This is because a - -- library unit pragma argument must be the name of a library - -- unit (RM 10.1.5(7)), but the only names permitted in this - -- context are (RM 10.1.5(6)) names of subprogram declarations, - -- generic subprogram declarations or generic instantiations. + procedure Check_Arg_Is_One_Of + (Arg : Node_Id; + N1, N2, N3, N4, N5 : Name_Id) + is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); - else - Error_Pragma - ("pragma% misplaced, must be before first declaration"); - end if; - end if; + begin + Check_Arg_Is_Identifier (Argx); + + if not Nam_In (Chars (Argx), N1, N2, N3, N4, N5) then + Error_Pragma_Arg ("invalid argument for pragma%", Argx); end if; - end Check_Valid_Library_Unit_Pragma; + end Check_Arg_Is_One_Of; - ------------------- - -- Check_Variant -- - ------------------- + --------------------------------- + -- Check_Arg_Is_Queuing_Policy -- + --------------------------------- - procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is - Clist : constant Node_Id := Component_List (Variant); - Comp : Node_Id; + procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); begin - Comp := First (Component_Items (Clist)); - while Present (Comp) loop - Check_Component (Comp, UU_Typ, In_Variant_Part => True); - Next (Comp); - end loop; - end Check_Variant; + Check_Arg_Is_Identifier (Argx); - ------------------ - -- Error_Pragma -- - ------------------ + if not Is_Queuing_Policy_Name (Chars (Argx)) then + Error_Pragma_Arg ("& is not a valid queuing policy name", Argx); + end if; + end Check_Arg_Is_Queuing_Policy; - procedure Error_Pragma (Msg : String) is - MsgF : String := Msg; + ------------------------------------ + -- Check_Arg_Is_Static_Expression -- + ------------------------------------ + + procedure Check_Arg_Is_Static_Expression + (Arg : Node_Id; + Typ : Entity_Id := Empty) + is begin - Error_Msg_Name_1 := Pname; - Fix_Error (MsgF); - Error_Msg_N (MsgF, N); - raise Pragma_Exit; - end Error_Pragma; + Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ); + end Check_Arg_Is_Static_Expression; - ---------------------- - -- Error_Pragma_Arg -- - ---------------------- + ------------------------------------------ + -- Check_Arg_Is_Task_Dispatching_Policy -- + ------------------------------------------ - procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is - MsgF : String := Msg; - begin - Error_Msg_Name_1 := Pname; - Fix_Error (MsgF); - Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); - raise Pragma_Exit; - end Error_Pragma_Arg; + procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); - procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is - MsgF : String := Msg1; begin - Error_Msg_Name_1 := Pname; - Fix_Error (MsgF); - Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); - Error_Pragma_Arg (Msg2, Arg); - end Error_Pragma_Arg; + Check_Arg_Is_Identifier (Argx); - ---------------------------- - -- Error_Pragma_Arg_Ident -- - ---------------------------- + if not Is_Task_Dispatching_Policy_Name (Chars (Argx)) then + Error_Pragma_Arg + ("& is not a valid task dispatching policy name", Argx); + end if; + end Check_Arg_Is_Task_Dispatching_Policy; - procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is - MsgF : String := Msg; - begin - Error_Msg_Name_1 := Pname; - Fix_Error (MsgF); - Error_Msg_N (MsgF, Arg); - raise Pragma_Exit; - end Error_Pragma_Arg_Ident; + --------------------- + -- Check_Arg_Order -- + --------------------- - ---------------------- - -- Error_Pragma_Ref -- - ---------------------- + procedure Check_Arg_Order (Names : Name_List) is + Arg : Node_Id; + + Highest_So_Far : Natural := 0; + -- Highest index in Names seen do far - procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is - MsgF : String := Msg; begin - Error_Msg_Name_1 := Pname; - Fix_Error (MsgF); - Error_Msg_Sloc := Sloc (Ref); - Error_Msg_NE (MsgF, N, Ref); - raise Pragma_Exit; - end Error_Pragma_Ref; + Arg := Arg1; + for J in 1 .. Arg_Count loop + if Chars (Arg) /= No_Name then + for K in Names'Range loop + if Chars (Arg) = Names (K) then + if K < Highest_So_Far then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("parameters out of order for pragma%", Arg); + Error_Msg_Name_1 := Names (K); + Error_Msg_Name_2 := Names (Highest_So_Far); + Error_Msg_N ("\% must appear before %", Arg); + raise Pragma_Exit; - ------------------------ - -- Find_Lib_Unit_Name -- - ------------------------ + else + Highest_So_Far := K; + end if; + end if; + end loop; + end if; - function Find_Lib_Unit_Name return Entity_Id is + Arg := Next (Arg); + end loop; + end Check_Arg_Order; + + -------------------------------- + -- Check_At_Least_N_Arguments -- + -------------------------------- + + procedure Check_At_Least_N_Arguments (N : Nat) is begin - -- Return inner compilation unit entity, for case of nested - -- categorization pragmas. This happens in generic unit. + if Arg_Count < N then + Error_Pragma ("too few arguments for pragma%"); + end if; + end Check_At_Least_N_Arguments; - if Nkind (Parent (N)) = N_Package_Specification - and then Defining_Entity (Parent (N)) /= Current_Scope - then - return Defining_Entity (Parent (N)); - else - return Current_Scope; + ------------------------------- + -- Check_At_Most_N_Arguments -- + ------------------------------- + + procedure Check_At_Most_N_Arguments (N : Nat) is + Arg : Node_Id; + begin + if Arg_Count > N then + Arg := Arg1; + for J in 1 .. N loop + Next (Arg); + Error_Pragma_Arg ("too many arguments for pragma%", Arg); + end loop; end if; - end Find_Lib_Unit_Name; + end Check_At_Most_N_Arguments; - ---------------------------- - -- Find_Program_Unit_Name -- - ---------------------------- + --------------------- + -- Check_Component -- + --------------------- - procedure Find_Program_Unit_Name (Id : Node_Id) is - Unit_Name : Entity_Id; - Unit_Kind : Node_Kind; - P : constant Node_Id := Parent (N); + procedure Check_Component + (Comp : Node_Id; + UU_Typ : Entity_Id; + In_Variant_Part : Boolean := False) + is + Comp_Id : constant Entity_Id := Defining_Identifier (Comp); + Sindic : constant Node_Id := + Subtype_Indication (Component_Definition (Comp)); + Typ : constant Entity_Id := Etype (Comp_Id); begin - if Nkind (P) = N_Compilation_Unit then - Unit_Kind := Nkind (Unit (P)); + -- Ada 2005 (AI-216): If a component subtype is subject to a per- + -- object constraint, then the component type shall be an Unchecked_ + -- Union. - if Unit_Kind = N_Subprogram_Declaration - or else Unit_Kind = N_Package_Declaration - or else Unit_Kind in N_Generic_Declaration - then - Unit_Name := Defining_Entity (Unit (P)); + if Nkind (Sindic) = N_Subtype_Indication + and then Has_Per_Object_Constraint (Comp_Id) + and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic))) + then + Error_Msg_N + ("component subtype subject to per-object constraint " + & "must be an Unchecked_Union", Comp); - if Chars (Id) = Chars (Unit_Name) then - Set_Entity (Id, Unit_Name); - Set_Etype (Id, Etype (Unit_Name)); - else - Set_Etype (Id, Any_Type); - Error_Pragma - ("cannot find program unit referenced by pragma%"); - end if; + -- Ada 2012 (AI05-0026): For an unchecked union type declared within + -- the body of a generic unit, or within the body of any of its + -- descendant library units, no part of the type of a component + -- declared in a variant_part of the unchecked union type shall be of + -- a formal private type or formal private extension declared within + -- the formal part of the generic unit. + + elsif Ada_Version >= Ada_2012 + and then In_Generic_Body (UU_Typ) + and then In_Variant_Part + and then Is_Private_Type (Typ) + and then Is_Generic_Type (Typ) + then + Error_Msg_N + ("component of unchecked union cannot be of generic type", Comp); - else - Set_Etype (Id, Any_Type); - Error_Pragma ("pragma% inapplicable to this unit"); - end if; + elsif Needs_Finalization (Typ) then + Error_Msg_N + ("component of unchecked union cannot be controlled", Comp); - else - Analyze (Id); + elsif Has_Task (Typ) then + Error_Msg_N + ("component of unchecked union cannot have tasks", Comp); end if; - end Find_Program_Unit_Name; + end Check_Component; - ----------------------------------------- - -- Find_Unique_Parameterless_Procedure -- - ----------------------------------------- + ---------------------------- + -- Check_Duplicate_Pragma -- + ---------------------------- - function Find_Unique_Parameterless_Procedure - (Name : Entity_Id; - Arg : Node_Id) return Entity_Id - is - Proc : Entity_Id := Empty; + procedure Check_Duplicate_Pragma (E : Entity_Id) is + Id : Entity_Id := E; + P : Node_Id; begin - -- The body of this procedure needs some comments ??? + -- Nothing to do if this pragma comes from an aspect specification, + -- since we could not be duplicating a pragma, and we dealt with the + -- case of duplicated aspects in Analyze_Aspect_Specifications. - if not Is_Entity_Name (Name) then - Error_Pragma_Arg - ("argument of pragma% must be entity name", Arg); + if From_Aspect_Specification (N) then + return; + end if; - elsif not Is_Overloaded (Name) then - Proc := Entity (Name); + -- Otherwise current pragma may duplicate previous pragma or a + -- previously given aspect specification or attribute definition + -- clause for the same pragma. - if Ekind (Proc) /= E_Procedure - or else Present (First_Formal (Proc)) - then - Error_Pragma_Arg - ("argument of pragma% must be parameterless procedure", Arg); - end if; + P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False); - else - declare - Found : Boolean := False; - It : Interp; - Index : Interp_Index; + if Present (P) then + Error_Msg_Name_1 := Pragma_Name (N); + Error_Msg_Sloc := Sloc (P); - begin - Get_First_Interp (Name, Index, It); - while Present (It.Nam) loop - Proc := It.Nam; + -- For a single protected or a single task object, the error is + -- issued on the original entity. - if Ekind (Proc) = E_Procedure - and then No (First_Formal (Proc)) - then - if not Found then - Found := True; - Set_Entity (Name, Proc); - Set_Is_Overloaded (Name, False); - else - Error_Pragma_Arg - ("ambiguous handler name for pragma% ", Arg); - end if; - end if; + if Ekind_In (Id, E_Task_Type, E_Protected_Type) then + Id := Defining_Identifier (Original_Node (Parent (Id))); + end if; - Get_Next_Interp (Index, It); - end loop; + if Nkind (P) = N_Aspect_Specification + or else From_Aspect_Specification (P) + then + Error_Msg_NE ("aspect% for & previously given#", N, Id); + else + Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id); + end if; - if not Found then - Error_Pragma_Arg - ("argument of pragma% must be parameterless procedure", - Arg); - else - Proc := Entity (Name); - end if; - end; + raise Pragma_Exit; end if; + end Check_Duplicate_Pragma; - return Proc; - end Find_Unique_Parameterless_Procedure; + ---------------------------------- + -- Check_Duplicated_Export_Name -- + ---------------------------------- - --------------- - -- Fix_Error -- - --------------- + procedure Check_Duplicated_Export_Name (Nam : Node_Id) is + String_Val : constant String_Id := Strval (Nam); - procedure Fix_Error (Msg : in out String) is begin - -- If we have a rewriting of another pragma, go to that pragma + -- We are only interested in the export case, and in the case of + -- generics, it is the instance, not the template, that is the + -- problem (the template will generate a warning in any case). - if Is_Rewrite_Substitution (N) - and then Nkind (Original_Node (N)) = N_Pragma + if not Inside_A_Generic + and then (Prag_Id = Pragma_Export + or else + Prag_Id = Pragma_Export_Procedure + or else + Prag_Id = Pragma_Export_Valued_Procedure + or else + Prag_Id = Pragma_Export_Function) then - Error_Msg_Name_1 := Pragma_Name (Original_Node (N)); - end if; - - -- Case where pragma comes from an aspect specification - - if From_Aspect_Specification (N) then - - -- Change appearence of "pragma" in message to "aspect" - - for J in Msg'First .. Msg'Last - 5 loop - if Msg (J .. J + 5) = "pragma" then - Msg (J .. J + 5) := "aspect"; + for J in Externals.First .. Externals.Last loop + if String_Equal (String_Val, Strval (Externals.Table (J))) then + Error_Msg_Sloc := Sloc (Externals.Table (J)); + Error_Msg_N ("external name duplicates name given#", Nam); + exit; end if; end loop; - -- Get name from corresponding aspect - - Error_Msg_Name_1 := Original_Name (N); + Externals.Append (Nam); end if; - end Fix_Error; + end Check_Duplicated_Export_Name; - ------------------------- - -- Gather_Associations -- - ------------------------- + ------------------------------------- + -- Check_Expr_Is_Static_Expression -- + ------------------------------------- - procedure Gather_Associations - (Names : Name_List; - Args : out Args_List) + procedure Check_Expr_Is_Static_Expression + (Expr : Node_Id; + Typ : Entity_Id := Empty) is - Arg : Node_Id; - begin - -- Initialize all parameters to Empty + if Present (Typ) then + Analyze_And_Resolve (Expr, Typ); + else + Analyze_And_Resolve (Expr); + end if; - for J in Args'Range loop - Args (J) := Empty; - end loop; + if Is_OK_Static_Expression (Expr) then + return; - -- That's all we have to do if there are no argument associations + elsif Etype (Expr) = Any_Type then + raise Pragma_Exit; - if No (Pragma_Argument_Associations (N)) then + -- An interesting special case, if we have a string literal and we + -- are in Ada 83 mode, then we allow it even though it will not be + -- flagged as static. This allows the use of Ada 95 pragmas like + -- Import in Ada 83 mode. They will of course be flagged with + -- warnings as usual, but will not cause errors. + + elsif Ada_Version = Ada_83 + and then Nkind (Expr) = N_String_Literal + then return; - end if; - -- Otherwise first deal with any positional parameters present + -- Static expression that raises Constraint_Error. This has already + -- been flagged, so just exit from pragma processing. - Arg := First (Pragma_Argument_Associations (N)); - for Index in Args'Range loop - exit when No (Arg) or else Chars (Arg) /= No_Name; - Args (Index) := Get_Pragma_Arg (Arg); - Next (Arg); - end loop; + elsif Is_Static_Expression (Expr) then + raise Pragma_Exit; - -- Positional parameters all processed, if any left, then we - -- have too many positional parameters. + -- Finally, we have a real error - if Present (Arg) and then Chars (Arg) = No_Name then - Error_Pragma_Arg - ("too many positional associations for pragma%", Arg); + else + Error_Msg_Name_1 := Pname; + + declare + Msg : String := + "argument for pragma% must be a static expression!"; + begin + Fix_Error (Msg); + Flag_Non_Static_Expr (Msg, Expr); + end; + + raise Pragma_Exit; end if; + end Check_Expr_Is_Static_Expression; - -- Process named parameters if any are present + ------------------------- + -- Check_First_Subtype -- + ------------------------- - while Present (Arg) loop - if Chars (Arg) = No_Name then - Error_Pragma_Arg - ("positional association cannot follow named association", - Arg); + procedure Check_First_Subtype (Arg : Node_Id) is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); + Ent : constant Entity_Id := Entity (Argx); - else - for Index in Names'Range loop - if Names (Index) = Chars (Arg) then - if Present (Args (Index)) then - Error_Pragma_Arg - ("duplicate argument association for pragma%", Arg); - else - Args (Index) := Get_Pragma_Arg (Arg); - exit; - end if; - end if; + begin + if Is_First_Subtype (Ent) then + null; - if Index = Names'Last then - Error_Msg_Name_1 := Pname; - Error_Msg_N ("pragma% does not allow & argument", Arg); + elsif Is_Type (Ent) then + Error_Pragma_Arg + ("pragma% cannot apply to subtype", Argx); - -- Check for possible misspelling + elsif Is_Object (Ent) then + Error_Pragma_Arg + ("pragma% cannot apply to object, requires a type", Argx); + + else + Error_Pragma_Arg + ("pragma% cannot apply to&, requires a type", Argx); + end if; + end Check_First_Subtype; - for Index1 in Names'Range loop - if Is_Bad_Spelling_Of - (Chars (Arg), Names (Index1)) - then - Error_Msg_Name_1 := Names (Index1); - Error_Msg_N -- CODEFIX - ("\possible misspelling of%", Arg); - exit; - end if; - end loop; + ---------------------- + -- Check_Identifier -- + ---------------------- - raise Pragma_Exit; - end if; - end loop; + procedure Check_Identifier (Arg : Node_Id; Id : Name_Id) is + begin + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + if Chars (Arg) = No_Name or else Chars (Arg) /= Id then + Error_Msg_Name_1 := Pname; + Error_Msg_Name_2 := Id; + Error_Msg_N ("pragma% argument expects identifier%", Arg); + raise Pragma_Exit; end if; + end if; + end Check_Identifier; - Next (Arg); - end loop; - end Gather_Associations; - - ----------------- - -- GNAT_Pragma -- - ----------------- + -------------------------------- + -- Check_Identifier_Is_One_Of -- + -------------------------------- - procedure GNAT_Pragma is + procedure Check_Identifier_Is_One_Of (Arg : Node_Id; N1, N2 : Name_Id) is begin - -- We need to check the No_Implementation_Pragmas restriction for - -- the case of a pragma from source. Note that the case of aspects - -- generating corresponding pragmas marks these pragmas as not being - -- from source, so this test also catches that case. + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + if Chars (Arg) = No_Name then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("pragma% argument expects an identifier", Arg); + raise Pragma_Exit; - if Comes_From_Source (N) then - Check_Restriction (No_Implementation_Pragmas, N); + elsif Chars (Arg) /= N1 + and then Chars (Arg) /= N2 + then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("invalid identifier for pragma% argument", Arg); + raise Pragma_Exit; + end if; end if; - end GNAT_Pragma; + end Check_Identifier_Is_One_Of; - -------------------------- - -- Is_Before_First_Decl -- - -------------------------- + --------------------------- + -- Check_In_Main_Program -- + --------------------------- - function Is_Before_First_Decl - (Pragma_Node : Node_Id; - Decls : List_Id) return Boolean - is - Item : Node_Id := First (Decls); + procedure Check_In_Main_Program is + P : constant Node_Id := Parent (N); begin - -- Only other pragmas can come before this pragma - - loop - if No (Item) or else Nkind (Item) /= N_Pragma then - return False; + -- Must be at in subprogram body - elsif Item = Pragma_Node then - return True; - end if; + if Nkind (P) /= N_Subprogram_Body then + Error_Pragma ("% pragma allowed only in subprogram"); - Next (Item); - end loop; - end Is_Before_First_Decl; + -- Otherwise warn if obviously not main program - ----------------------------- - -- Is_Configuration_Pragma -- - ----------------------------- + elsif Present (Parameter_Specifications (Specification (P))) + or else not Is_Compilation_Unit (Defining_Entity (P)) + then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("??pragma% is only effective in main program", N); + end if; + end Check_In_Main_Program; - -- A configuration pragma must appear in the context clause of a - -- compilation unit, and only other pragmas may precede it. Note that - -- the test below also permits use in a configuration pragma file. + --------------------------------------- + -- Check_Interrupt_Or_Attach_Handler -- + --------------------------------------- - function Is_Configuration_Pragma return Boolean is - Lis : constant List_Id := List_Containing (N); - Par : constant Node_Id := Parent (N); - Prg : Node_Id; + procedure Check_Interrupt_Or_Attach_Handler is + Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); + Handler_Proc, Proc_Scope : Entity_Id; begin - -- If no parent, then we are in the configuration pragma file, - -- so the placement is definitely appropriate. - - if No (Par) then - return True; + Analyze (Arg1_X); - -- Otherwise we must be in the context clause of a compilation unit - -- and the only thing allowed before us in the context list is more - -- configuration pragmas. + if Prag_Id = Pragma_Interrupt_Handler then + Check_Restriction (No_Dynamic_Attachment, N); + end if; - elsif Nkind (Par) = N_Compilation_Unit - and then Context_Items (Par) = Lis - then - Prg := First (Lis); + Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1); + Proc_Scope := Scope (Handler_Proc); - loop - if Prg = N then - return True; - elsif Nkind (Prg) /= N_Pragma then - return False; - end if; + -- On AAMP only, a pragma Interrupt_Handler is supported for + -- nonprotected parameterless procedures. - Next (Prg); - end loop; + if not AAMP_On_Target + or else Prag_Id = Pragma_Attach_Handler + then + if Ekind (Proc_Scope) /= E_Protected_Type then + Error_Pragma_Arg + ("argument of pragma% must be protected procedure", Arg1); + end if; - else - return False; + if Parent (N) /= Protected_Definition (Parent (Proc_Scope)) then + Error_Pragma ("pragma% must be in protected definition"); + end if; end if; - end Is_Configuration_Pragma; - -------------------------- - -- Is_In_Context_Clause -- - -------------------------- - - function Is_In_Context_Clause return Boolean is - Plist : List_Id; - Parent_Node : Node_Id; + if not Is_Library_Level_Entity (Proc_Scope) + or else (AAMP_On_Target + and then not Is_Library_Level_Entity (Handler_Proc)) + then + Error_Pragma_Arg + ("argument for pragma% must be library level entity", Arg1); + end if; - begin - if not Is_List_Member (N) then - return False; + -- AI05-0033: A pragma cannot appear within a generic body, because + -- instance can be in a nested scope. The check that protected type + -- is itself a library-level declaration is done elsewhere. - else - Plist := List_Containing (N); - Parent_Node := Parent (Plist); + -- Note: we omit this check in Relaxed_RM_Semantics mode to properly + -- handle code prior to AI-0033. Analysis tools typically are not + -- interested in this pragma in any case, so no need to worry too + -- much about its placement. - if Parent_Node = Empty - or else Nkind (Parent_Node) /= N_Compilation_Unit - or else Context_Items (Parent_Node) /= Plist + if Inside_A_Generic then + if Ekind (Scope (Current_Scope)) = E_Generic_Package + and then In_Package_Body (Scope (Current_Scope)) + and then not Relaxed_RM_Semantics then - return False; + Error_Pragma ("pragma% cannot be used inside a generic"); end if; end if; - - return True; - end Is_In_Context_Clause; + end Check_Interrupt_Or_Attach_Handler; --------------------------------- - -- Is_Static_String_Expression -- + -- Check_Loop_Pragma_Placement -- --------------------------------- - function Is_Static_String_Expression (Arg : Node_Id) return Boolean is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); + procedure Check_Loop_Pragma_Placement is + procedure Placement_Error (Constr : Node_Id); + pragma No_Return (Placement_Error); + -- Node Constr denotes the last loop restricted construct before we + -- encountered an illegal relation between enclosing constructs. Emit + -- an error depending on what Constr was. + + --------------------- + -- Placement_Error -- + --------------------- + + procedure Placement_Error (Constr : Node_Id) is + begin + if Nkind (Constr) = N_Pragma then + Error_Pragma + ("pragma % must appear immediately within the statements " + & "of a loop"); + else + Error_Pragma_Arg + ("block containing pragma % must appear immediately within " + & "the statements of a loop", Constr); + end if; + end Placement_Error; + + -- Local declarations + + Prev : Node_Id; + Stmt : Node_Id; + + -- Start of processing for Check_Loop_Pragma_Placement begin - Analyze_And_Resolve (Argx); - return Is_OK_Static_Expression (Argx) - and then Nkind (Argx) = N_String_Literal; - end Is_Static_String_Expression; + Prev := N; + Stmt := Parent (N); + while Present (Stmt) loop + + -- The pragma or previous block must appear immediately within the + -- current block's declarative or statement part. + + if Nkind (Stmt) = N_Block_Statement then + if (No (Declarations (Stmt)) + or else List_Containing (Prev) /= Declarations (Stmt)) + and then + List_Containing (Prev) /= + Statements (Handled_Statement_Sequence (Stmt)) + then + Placement_Error (Prev); + return; + + -- Keep inspecting the parents because we are now within a + -- chain of nested blocks. - ---------------------- - -- Pragma_Misplaced -- - ---------------------- + else + Prev := Stmt; + Stmt := Parent (Stmt); + end if; - procedure Pragma_Misplaced is - begin - Error_Pragma ("incorrect placement of pragma%"); - end Pragma_Misplaced; + -- The pragma or previous block must appear immediately within the + -- statements of the loop. - ------------------------------------ - -- Process_Atomic_Shared_Volatile -- - ------------------------------------ + elsif Nkind (Stmt) = N_Loop_Statement then + if List_Containing (Prev) /= Statements (Stmt) then + Placement_Error (Prev); + end if; - procedure Process_Atomic_Shared_Volatile is - E_Id : Node_Id; - E : Entity_Id; - D : Node_Id; - K : Node_Kind; - Utyp : Entity_Id; + -- Stop the traversal because we reached the innermost loop + -- regardless of whether we encountered an error or not. - procedure Set_Atomic (E : Entity_Id); - -- Set given type as atomic, and if no explicit alignment was given, - -- set alignment to unknown, since back end knows what the alignment - -- requirements are for atomic arrays. Note: this step is necessary - -- for derived types. + return; - ---------------- - -- Set_Atomic -- - ---------------- + -- Ignore a handled statement sequence. Note that this node may + -- be related to a subprogram body in which case we will emit an + -- error on the next iteration of the search. - procedure Set_Atomic (E : Entity_Id) is - begin - Set_Is_Atomic (E); + elsif Nkind (Stmt) = N_Handled_Sequence_Of_Statements then + Stmt := Parent (Stmt); - if not Has_Alignment_Clause (E) then - Set_Alignment (E, Uint_0); - end if; - end Set_Atomic; + -- Any other statement breaks the chain from the pragma to the + -- loop. - -- Start of processing for Process_Atomic_Shared_Volatile + else + Placement_Error (Prev); + return; + end if; + end loop; + end Check_Loop_Pragma_Placement; - begin - Check_Ada_83_Warning; - Check_No_Identifiers; - Check_Arg_Count (1); - Check_Arg_Is_Local_Name (Arg1); - E_Id := Get_Pragma_Arg (Arg1); + ------------------------------------------- + -- Check_Is_In_Decl_Part_Or_Package_Spec -- + ------------------------------------------- - if Etype (E_Id) = Any_Type then - return; - end if; + procedure Check_Is_In_Decl_Part_Or_Package_Spec is + P : Node_Id; - E := Entity (E_Id); - D := Declaration_Node (E); - K := Nkind (D); + begin + P := Parent (N); + loop + if No (P) then + exit; - -- Check duplicate before we chain ourselves! + elsif Nkind (P) = N_Handled_Sequence_Of_Statements then + exit; - Check_Duplicate_Pragma (E); + elsif Nkind_In (P, N_Package_Specification, + N_Block_Statement) + then + return; - -- Now check appropriateness of the entity + -- Note: the following tests seem a little peculiar, because + -- they test for bodies, but if we were in the statement part + -- of the body, we would already have hit the handled statement + -- sequence, so the only way we get here is by being in the + -- declarative part of the body. - if Is_Type (E) then - if Rep_Item_Too_Early (E, N) - or else - Rep_Item_Too_Late (E, N) + elsif Nkind_In (P, N_Subprogram_Body, + N_Package_Body, + N_Task_Body, + N_Entry_Body) then return; - else - Check_First_Subtype (Arg1); end if; - if Prag_Id /= Pragma_Volatile then - Set_Atomic (E); - Set_Atomic (Underlying_Type (E)); - Set_Atomic (Base_Type (E)); - end if; + P := Parent (P); + end loop; - -- Attribute belongs on the base type. If the view of the type is - -- currently private, it also belongs on the underlying type. + Error_Pragma ("pragma% is not in declarative part or package spec"); + end Check_Is_In_Decl_Part_Or_Package_Spec; - Set_Is_Volatile (Base_Type (E)); - Set_Is_Volatile (Underlying_Type (E)); + ------------------------- + -- Check_No_Identifier -- + ------------------------- - Set_Treat_As_Volatile (E); - Set_Treat_As_Volatile (Underlying_Type (E)); + procedure Check_No_Identifier (Arg : Node_Id) is + begin + if Nkind (Arg) = N_Pragma_Argument_Association + and then Chars (Arg) /= No_Name + then + Error_Pragma_Arg_Ident + ("pragma% does not permit identifier& here", Arg); + end if; + end Check_No_Identifier; - elsif K = N_Object_Declaration - or else (K = N_Component_Declaration - and then Original_Record_Component (E) = E) + -------------------------- + -- Check_No_Identifiers -- + -------------------------- + + procedure Check_No_Identifiers is + Arg_Node : Node_Id; + begin + if Arg_Count > 0 then + Arg_Node := Arg1; + while Present (Arg_Node) loop + Check_No_Identifier (Arg_Node); + Next (Arg_Node); + end loop; + end if; + end Check_No_Identifiers; + + ------------------------ + -- Check_No_Link_Name -- + ------------------------ + + procedure Check_No_Link_Name is + begin + if Present (Arg3) and then Chars (Arg3) = Name_Link_Name then + Arg4 := Arg3; + end if; + + if Present (Arg4) then + Error_Pragma_Arg + ("Link_Name argument not allowed for Import Intrinsic", Arg4); + end if; + end Check_No_Link_Name; + + ------------------------------- + -- Check_Optional_Identifier -- + ------------------------------- + + procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id) is + begin + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + and then Chars (Arg) /= No_Name then - if Rep_Item_Too_Late (E, N) then - return; + if Chars (Arg) /= Id then + Error_Msg_Name_1 := Pname; + Error_Msg_Name_2 := Id; + Error_Msg_N ("pragma% argument expects identifier%", Arg); + raise Pragma_Exit; end if; + end if; + end Check_Optional_Identifier; - if Prag_Id /= Pragma_Volatile then - Set_Is_Atomic (E); + procedure Check_Optional_Identifier (Arg : Node_Id; Id : String) is + begin + Name_Buffer (1 .. Id'Length) := Id; + Name_Len := Id'Length; + Check_Optional_Identifier (Arg, Name_Find); + end Check_Optional_Identifier; - -- If the object declaration has an explicit initialization, a - -- temporary may have to be created to hold the expression, to - -- ensure that access to the object remain atomic. + -------------------------------------- + -- Check_Precondition_Postcondition -- + -------------------------------------- - if Nkind (Parent (E)) = N_Object_Declaration - and then Present (Expression (Parent (E))) - then - Set_Has_Delayed_Freeze (E); - end if; + procedure Check_Precondition_Postcondition (In_Body : out Boolean) is + P : Node_Id; + PO : Node_Id; - -- An interesting improvement here. If an object of composite - -- type X is declared atomic, and the type X isn't, that's a - -- pity, since it may not have appropriate alignment etc. We - -- can rescue this in the special case where the object and - -- type are in the same unit by just setting the type as - -- atomic, so that the back end will process it as atomic. + procedure Chain_PPC (PO : Node_Id); + -- If PO is an entry or a [generic] subprogram declaration node, then + -- the precondition/postcondition applies to this subprogram and the + -- processing for the pragma is completed. Otherwise the pragma is + -- misplaced. - -- Note: we used to do this for elementary types as well, - -- but that turns out to be a bad idea and can have unwanted - -- effects, most notably if the type is elementary, the object - -- a simple component within a record, and both are in a spec: - -- every object of this type in the entire program will be - -- treated as atomic, thus incurring a potentially costly - -- synchronization operation for every access. + --------------- + -- Chain_PPC -- + --------------- - -- Of course it would be best if the back end could just adjust - -- the alignment etc for the specific object, but that's not - -- something we are capable of doing at this point. + procedure Chain_PPC (PO : Node_Id) is + S : Entity_Id; - Utyp := Underlying_Type (Etype (E)); + begin + if Nkind (PO) = N_Abstract_Subprogram_Declaration then + if not From_Aspect_Specification (N) then + Error_Pragma + ("pragma% cannot be applied to abstract subprogram"); - if Present (Utyp) - and then Is_Composite_Type (Utyp) - and then Sloc (E) > No_Location - and then Sloc (Utyp) > No_Location - and then - Get_Source_File_Index (Sloc (E)) = - Get_Source_File_Index (Sloc (Underlying_Type (Etype (E)))) - then - Set_Is_Atomic (Underlying_Type (Etype (E))); + elsif Class_Present (N) then + null; + + else + Error_Pragma + ("aspect % requires ''Class for abstract subprogram"); end if; - end if; - Set_Is_Volatile (E); - Set_Treat_As_Volatile (E); + -- AI05-0230: The same restriction applies to null procedures. For + -- compatibility with earlier uses of the Ada pragma, apply this + -- rule only to aspect specifications. + + -- The above discrpency needs documentation. Robert is dubious + -- about whether it is a good idea ??? - else - Error_Pragma_Arg - ("inappropriate entity for pragma%", Arg1); - end if; - end Process_Atomic_Shared_Volatile; + elsif Nkind (PO) = N_Subprogram_Declaration + and then Nkind (Specification (PO)) = N_Procedure_Specification + and then Null_Present (Specification (PO)) + and then From_Aspect_Specification (N) + and then not Class_Present (N) + then + Error_Pragma + ("aspect % requires ''Class for null procedure"); - ------------------------------------------- - -- Process_Compile_Time_Warning_Or_Error -- - ------------------------------------------- + -- Pre/postconditions are legal on a subprogram body if it is not + -- a completion of a declaration. They are also legal on a stub + -- with no previous declarations (this is checked when processing + -- the corresponding aspects). - procedure Process_Compile_Time_Warning_Or_Error is - Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); + elsif Nkind (PO) = N_Subprogram_Body + and then Acts_As_Spec (PO) + then + null; - begin - Check_Arg_Count (2); - Check_No_Identifiers; - Check_Arg_Is_Static_Expression (Arg2, Standard_String); - Analyze_And_Resolve (Arg1x, Standard_Boolean); + elsif Nkind (PO) = N_Subprogram_Body_Stub then + null; - if Compile_Time_Known_Value (Arg1x) then - if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then - declare - Str : constant String_Id := - Strval (Get_Pragma_Arg (Arg2)); - Len : constant Int := String_Length (Str); - Cont : Boolean; - Ptr : Nat; - CC : Char_Code; - C : Character; - Cent : constant Entity_Id := - Cunit_Entity (Current_Sem_Unit); + elsif not Nkind_In (PO, N_Subprogram_Declaration, + N_Expression_Function, + N_Generic_Subprogram_Declaration, + N_Entry_Declaration) + then + Pragma_Misplaced; + end if; - Force : constant Boolean := - Prag_Id = Pragma_Compile_Time_Warning - and then - Is_Spec_Name (Unit_Name (Current_Sem_Unit)) - and then (Ekind (Cent) /= E_Package - or else not In_Private_Part (Cent)); - -- Set True if this is the warning case, and we are in the - -- visible part of a package spec, or in a subprogram spec, - -- in which case we want to force the client to see the - -- warning, even though it is not in the main unit. + -- Here if we have [generic] subprogram or entry declaration - begin - -- Loop through segments of message separated by line feeds. - -- We output these segments as separate messages with - -- continuation marks for all but the first. + if Nkind (PO) = N_Entry_Declaration then + S := Defining_Entity (PO); + else + S := Defining_Unit_Name (Specification (PO)); - Cont := False; - Ptr := 1; - loop - Error_Msg_Strlen := 0; + if Nkind (S) = N_Defining_Program_Unit_Name then + S := Defining_Identifier (S); + end if; + end if; - -- Loop to copy characters from argument to error message - -- string buffer. + -- Note: we do not analyze the pragma at this point. Instead we + -- delay this analysis until the end of the declarative part in + -- which the pragma appears. This implements the required delay + -- in this analysis, allowing forward references. The analysis + -- happens at the end of Analyze_Declarations. - loop - exit when Ptr > Len; - CC := Get_String_Char (Str, Ptr); - Ptr := Ptr + 1; + -- Chain spec PPC pragma to list for subprogram - -- Ignore wide chars ??? else store character + Add_Contract_Item (N, S); - if In_Character_Range (CC) then - C := Get_Character (CC); - exit when C = ASCII.LF; - Error_Msg_Strlen := Error_Msg_Strlen + 1; - Error_Msg_String (Error_Msg_Strlen) := C; - end if; - end loop; + -- Return indicating spec case - -- Here with one line ready to go + In_Body := False; + return; + end Chain_PPC; - Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning; + -- Start of processing for Check_Precondition_Postcondition - -- If this is a warning in a spec, then we want clients - -- to see the warning, so mark the message with the - -- special sequence !! to force the warning. In the case - -- of a package spec, we do not force this if we are in - -- the private part of the spec. + begin + if not Is_List_Member (N) then + Pragma_Misplaced; + end if; - if Force then - if Cont = False then - Error_Msg_N ("<~!!", Arg1); - Cont := True; - else - Error_Msg_N ("\<~!!", Arg1); - end if; + -- Preanalyze message argument if present. Visibility in this + -- argument is established at the point of pragma occurrence. - -- Error, rather than warning, or in a body, so we do not - -- need to force visibility for client (error will be - -- output in any case, and this is the situation in which - -- we do not want a client to get a warning, since the - -- warning is in the body or the spec private part). + if Arg_Count = 2 then + Check_Optional_Identifier (Arg2, Name_Message); + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg2), Standard_String); + end if; - else - if Cont = False then - Error_Msg_N ("<~", Arg1); - Cont := True; - else - Error_Msg_N ("\<~", Arg1); - end if; - end if; + -- For a pragma PPC in the extended main source unit, record enabled + -- status in SCO. - exit when Ptr > Len; - end loop; - end; - end if; + if not Is_Ignored (N) and then not Split_PPC (N) then + Set_SCO_Pragma_Enabled (Loc); end if; - end Process_Compile_Time_Warning_Or_Error; - ------------------------ - -- Process_Convention -- - ------------------------ + -- If we are within an inlined body, the legality of the pragma + -- has been checked already. - procedure Process_Convention - (C : out Convention_Id; - Ent : out Entity_Id) - is - Id : Node_Id; - E : Entity_Id; - E1 : Entity_Id; - Cname : Name_Id; - Comp_Unit : Unit_Number_Type; + if In_Inlined_Body then + In_Body := True; + return; + end if; - procedure Diagnose_Multiple_Pragmas (S : Entity_Id); - -- Called if we have more than one Export/Import/Convention pragma. - -- This is generally illegal, but we have a special case of allowing - -- Import and Interface to coexist if they specify the convention in - -- a consistent manner. We are allowed to do this, since Interface is - -- an implementation defined pragma, and we choose to do it since we - -- know Rational allows this combination. S is the entity id of the - -- subprogram in question. This procedure also sets the special flag - -- Import_Interface_Present in both pragmas in the case where we do - -- have matching Import and Interface pragmas. + -- Search prior declarations - procedure Set_Convention_From_Pragma (E : Entity_Id); - -- Set convention in entity E, and also flag that the entity has a - -- convention pragma. If entity is for a private or incomplete type, - -- also set convention and flag on underlying type. This procedure - -- also deals with the special case of C_Pass_By_Copy convention. + P := N; + while Present (Prev (P)) loop + P := Prev (P); - ------------------------------- - -- Diagnose_Multiple_Pragmas -- - ------------------------------- + -- If the previous node is a generic subprogram, do not go to to + -- the original node, which is the unanalyzed tree: we need to + -- attach the pre/postconditions to the analyzed version at this + -- point. They get propagated to the original tree when analyzing + -- the corresponding body. - procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is - Pdec : constant Node_Id := Declaration_Node (S); - Decl : Node_Id; - Err : Boolean; + if Nkind (P) not in N_Generic_Declaration then + PO := Original_Node (P); + else + PO := P; + end if; - function Same_Convention (Decl : Node_Id) return Boolean; - -- Decl is a pragma node. This function returns True if this - -- pragma has a first argument that is an identifier with a - -- Chars field corresponding to the Convention_Id C. + -- Skip past prior pragma - function Same_Name (Decl : Node_Id) return Boolean; - -- Decl is a pragma node. This function returns True if this - -- pragma has a second argument that is an identifier with a - -- Chars field that matches the Chars of the current subprogram. + if Nkind (PO) = N_Pragma then + null; - --------------------- - -- Same_Convention -- - --------------------- + -- Skip stuff not coming from source - function Same_Convention (Decl : Node_Id) return Boolean is - Arg1 : constant Node_Id := - First (Pragma_Argument_Associations (Decl)); + elsif not Comes_From_Source (PO) then - begin - if Present (Arg1) then - declare - Arg : constant Node_Id := Get_Pragma_Arg (Arg1); - begin - if Nkind (Arg) = N_Identifier - and then Is_Convention_Name (Chars (Arg)) - and then Get_Convention_Id (Chars (Arg)) = C - then - return True; - end if; - end; - end if; + -- The condition may apply to a subprogram instantiation - return False; - end Same_Convention; + if Nkind (PO) = N_Subprogram_Declaration + and then Present (Generic_Parent (Specification (PO))) + then + Chain_PPC (PO); + return; - --------------- - -- Same_Name -- - --------------- + elsif Nkind (PO) = N_Subprogram_Declaration + and then In_Instance + then + Chain_PPC (PO); + return; - function Same_Name (Decl : Node_Id) return Boolean is - Arg1 : constant Node_Id := - First (Pragma_Argument_Associations (Decl)); - Arg2 : Node_Id; + -- For all other cases of non source code, do nothing - begin - if No (Arg1) then - return False; + else + null; end if; - Arg2 := Next (Arg1); + -- Only remaining possibility is subprogram declaration - if No (Arg2) then - return False; - end if; + else + Chain_PPC (PO); + return; + end if; + end loop; - declare - Arg : constant Node_Id := Get_Pragma_Arg (Arg2); - begin - if Nkind (Arg) = N_Identifier - and then Chars (Arg) = Chars (S) - then - return True; - end if; - end; + -- If we fall through loop, pragma is at start of list, so see if it + -- is at the start of declarations of a subprogram body. - return False; - end Same_Name; + if Nkind (Parent (N)) = N_Subprogram_Body + and then List_Containing (N) = Declarations (Parent (N)) + then + if Operating_Mode /= Generate_Code + or else Inside_A_Generic + then + -- Analyze pragma expression for correctness and for ASIS use - -- Start of processing for Diagnose_Multiple_Pragmas + Preanalyze_Assert_Expression + (Get_Pragma_Arg (Arg1), Standard_Boolean); - begin - Err := True; + -- In ASIS mode, for a pragma generated from a source aspect, + -- also analyze the original aspect expression. - -- Definitely give message if we have Convention/Export here + if ASIS_Mode and then Present (Corresponding_Aspect (N)) then + Preanalyze_Assert_Expression + (Expression (Corresponding_Aspect (N)), Standard_Boolean); + end if; + end if; - if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then - null; + In_Body := True; + return; - -- If we have an Import or Export, scan back from pragma to - -- find any previous pragma applying to the same procedure. - -- The scan will be terminated by the start of the list, or - -- hitting the subprogram declaration. This won't allow one - -- pragma to appear in the public part and one in the private - -- part, but that seems very unlikely in practice. + -- See if it is in the pragmas after a library level subprogram - else - Decl := Prev (N); - while Present (Decl) and then Decl /= Pdec loop + elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then - -- Look for pragma with same name as us + -- In formal verification mode, analyze pragma expression for + -- correctness, as it is not expanded later. - if Nkind (Decl) = N_Pragma - and then Same_Name (Decl) - then - -- Give error if same as our pragma or Export/Convention + if Alfa_Mode then + Analyze_PPC_In_Decl_Part + (N, Defining_Entity (Unit (Parent (Parent (N))))); + end if; - if Nam_In (Pragma_Name (Decl), Name_Export, - Name_Convention, - Pragma_Name (N)) - then - exit; + Chain_PPC (Unit (Parent (Parent (N)))); + return; + end if; - -- Case of Import/Interface or the other way round + -- If we fall through, pragma was misplaced - elsif Nam_In (Pragma_Name (Decl), Name_Interface, - Name_Import) - then - -- Here we know that we have Import and Interface. It - -- doesn't matter which way round they are. See if - -- they specify the same convention. If so, all OK, - -- and set special flags to stop other messages + Pragma_Misplaced; + end Check_Precondition_Postcondition; - if Same_Convention (Decl) then - Set_Import_Interface_Present (N); - Set_Import_Interface_Present (Decl); - Err := False; + ----------------------------- + -- Check_Static_Constraint -- + ----------------------------- - -- If different conventions, special message + -- Note: for convenience in writing this procedure, in addition to + -- the officially (i.e. by spec) allowed argument which is always a + -- constraint, it also allows ranges and discriminant associations. + -- Above is not clear ??? - else - Error_Msg_Sloc := Sloc (Decl); - Error_Pragma_Arg - ("convention differs from that given#", Arg1); - return; - end if; - end if; - end if; + procedure Check_Static_Constraint (Constr : Node_Id) is - Next (Decl); - end loop; - end if; + procedure Require_Static (E : Node_Id); + -- Require given expression to be static expression - -- Give message if needed if we fall through those tests - -- except on Relaxed_RM_Semantics where we let go: either this - -- is a case accepted/ignored by other Ada compilers (e.g. - -- a mix of Convention and Import), or another error will be - -- generated later (e.g. using both Import and Export). + -------------------- + -- Require_Static -- + -------------------- - if Err and not Relaxed_RM_Semantics then - Error_Pragma_Arg - ("at most one Convention/Export/Import pragma is allowed", - Arg2); + procedure Require_Static (E : Node_Id) is + begin + if not Is_OK_Static_Expression (E) then + Flag_Non_Static_Expr + ("non-static constraint not allowed in Unchecked_Union!", E); + raise Pragma_Exit; end if; - end Diagnose_Multiple_Pragmas; + end Require_Static; - -------------------------------- - -- Set_Convention_From_Pragma -- - -------------------------------- + -- Start of processing for Check_Static_Constraint - procedure Set_Convention_From_Pragma (E : Entity_Id) is - begin - -- Ada 2005 (AI-430): Check invalid attempt to change convention - -- for an overridden dispatching operation. Technically this is - -- an amendment and should only be done in Ada 2005 mode. However, - -- this is clearly a mistake, since the problem that is addressed - -- by this AI is that there is a clear gap in the RM! + begin + case Nkind (Constr) is + when N_Discriminant_Association => + Require_Static (Expression (Constr)); - if Is_Dispatching_Operation (E) - and then Present (Overridden_Operation (E)) - and then C /= Convention (Overridden_Operation (E)) - then - Error_Pragma_Arg - ("cannot change convention for overridden dispatching " - & "operation", Arg1); - end if; + when N_Range => + Require_Static (Low_Bound (Constr)); + Require_Static (High_Bound (Constr)); - -- Set the convention + when N_Attribute_Reference => + Require_Static (Type_Low_Bound (Etype (Prefix (Constr)))); + Require_Static (Type_High_Bound (Etype (Prefix (Constr)))); - Set_Convention (E, C); - Set_Has_Convention_Pragma (E); + when N_Range_Constraint => + Check_Static_Constraint (Range_Expression (Constr)); - if Is_Incomplete_Or_Private_Type (E) - and then Present (Underlying_Type (E)) - then - Set_Convention (Underlying_Type (E), C); - Set_Has_Convention_Pragma (Underlying_Type (E), True); - end if; + when N_Index_Or_Discriminant_Constraint => + declare + IDC : Entity_Id; + begin + IDC := First (Constraints (Constr)); + while Present (IDC) loop + Check_Static_Constraint (IDC); + Next (IDC); + end loop; + end; - -- A class-wide type should inherit the convention of the specific - -- root type (although this isn't specified clearly by the RM). + when others => + null; + end case; + end Check_Static_Constraint; - if Is_Type (E) and then Present (Class_Wide_Type (E)) then - Set_Convention (Class_Wide_Type (E), C); - end if; + --------------------- + -- Check_Test_Case -- + --------------------- - -- If the entity is a record type, then check for special case of - -- C_Pass_By_Copy, which is treated the same as C except that the - -- special record flag is set. This convention is only permitted - -- on record types (see AI95-00131). + procedure Check_Test_Case is + P : Node_Id; + PO : Node_Id; - if Cname = Name_C_Pass_By_Copy then - if Is_Record_Type (E) then - Set_C_Pass_By_Copy (Base_Type (E)); - elsif Is_Incomplete_Or_Private_Type (E) - and then Is_Record_Type (Underlying_Type (E)) - then - Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E))); - else - Error_Pragma_Arg - ("C_Pass_By_Copy convention allowed only for record type", - Arg2); - end if; - end if; + procedure Chain_CTC (PO : Node_Id); + -- If PO is a [generic] subprogram declaration node, then the + -- test-case applies to this subprogram and the processing for + -- the pragma is completed. Otherwise the pragma is misplaced. - -- If the entity is a derived boolean type, check for the special - -- case of convention C, C++, or Fortran, where we consider any - -- nonzero value to represent true. + --------------- + -- Chain_CTC -- + --------------- - if Is_Discrete_Type (E) - and then Root_Type (Etype (E)) = Standard_Boolean - and then - (C = Convention_C - or else - C = Convention_CPP - or else - C = Convention_Fortran) + procedure Chain_CTC (PO : Node_Id) is + S : Entity_Id; + + begin + if Nkind (PO) = N_Abstract_Subprogram_Declaration then + Error_Pragma + ("pragma% cannot be applied to abstract subprogram"); + + elsif Nkind (PO) = N_Entry_Declaration then + Error_Pragma ("pragma% cannot be applied to entry"); + + elsif not Nkind_In (PO, N_Subprogram_Declaration, + N_Generic_Subprogram_Declaration) then - Set_Nonzero_Is_True (Base_Type (E)); + Pragma_Misplaced; end if; - end Set_Convention_From_Pragma; - -- Start of processing for Process_Convention + -- Here if we have [generic] subprogram declaration - begin - Check_At_Least_N_Arguments (2); - Check_Optional_Identifier (Arg1, Name_Convention); - Check_Arg_Is_Identifier (Arg1); - Cname := Chars (Get_Pragma_Arg (Arg1)); + S := Defining_Unit_Name (Specification (PO)); - -- C_Pass_By_Copy is treated as a synonym for convention C (this is - -- tested again below to set the critical flag). + -- Note: we do not analyze the pragma at this point. Instead we + -- delay this analysis until the end of the declarative part in + -- which the pragma appears. This implements the required delay + -- in this analysis, allowing forward references. The analysis + -- happens at the end of Analyze_Declarations. - if Cname = Name_C_Pass_By_Copy then - C := Convention_C; + -- There should not be another test-case with the same name + -- associated to this subprogram. - -- Otherwise we must have something in the standard convention list + declare + Name : constant String_Id := Get_Name_From_CTC_Pragma (N); + CTC : Node_Id; - elsif Is_Convention_Name (Cname) then - C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1))); + begin + CTC := Contract_Test_Cases (Contract (S)); + while Present (CTC) loop - -- In DEC VMS, it seems that there is an undocumented feature that - -- any unrecognized convention is treated as the default, which for - -- us is convention C. It does not seem so terrible to do this - -- unconditionally, silently in the VMS case, and with a warning - -- in the non-VMS case. + -- Omit pragma Contract_Cases because it does not introduce + -- a unique case name and it does not follow the syntax of + -- Test_Case. - else - if Warn_On_Export_Import and not OpenVMS_On_Target then - Error_Msg_N - ("??unrecognized convention name, C assumed", - Get_Pragma_Arg (Arg1)); - end if; + if Pragma_Name (CTC) = Name_Contract_Cases then + null; - C := Convention_C; - 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; - Check_Optional_Identifier (Arg2, Name_Entity); - Check_Arg_Is_Local_Name (Arg2); + CTC := Next_Pragma (CTC); + end loop; + end; - Id := Get_Pragma_Arg (Arg2); - Analyze (Id); + -- Chain spec CTC pragma to list for subprogram - if not Is_Entity_Name (Id) then - Error_Pragma_Arg ("entity name required", Arg2); - end if; + Add_Contract_Item (N, S); + end Chain_CTC; - E := Entity (Id); + -- Start of processing for Check_Test_Case - -- Set entity to return + begin + -- First check pragma arguments - Ent := E; + GNAT_Pragma; + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (4); + Check_Arg_Order + ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); - -- Ada_Pass_By_Copy special checking + Check_Optional_Identifier (Arg1, Name_Name); + Check_Arg_Is_Static_Expression (Arg1, Standard_String); - if C = Convention_Ada_Pass_By_Copy then - if not Is_First_Subtype (E) then - Error_Pragma_Arg - ("convention `Ada_Pass_By_Copy` only " - & "allowed for types", Arg2); - end if; + -- In ASIS mode, for a pragma generated from a source aspect, also + -- analyze the original aspect expression. - if Is_By_Reference_Type (E) then - Error_Pragma_Arg - ("convention `Ada_Pass_By_Copy` not allowed for " - & "by-reference type", Arg1); - end if; + if ASIS_Mode and then Present (Corresponding_Aspect (N)) then + Check_Expr_Is_Static_Expression + (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String); end if; - -- Ada_Pass_By_Reference special checking + Check_Optional_Identifier (Arg2, Name_Mode); + Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness); - if C = Convention_Ada_Pass_By_Reference then - if not Is_First_Subtype (E) then - Error_Pragma_Arg - ("convention `Ada_Pass_By_Reference` only " - & "allowed for types", Arg2); - end if; + if Arg_Count = 4 then + Check_Identifier (Arg3, Name_Requires); + Check_Identifier (Arg4, Name_Ensures); - if Is_By_Copy_Type (E) then - Error_Pragma_Arg - ("convention `Ada_Pass_By_Reference` not allowed for " - & "by-copy type", Arg1); - end if; + elsif Arg_Count = 3 then + Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures); end if; - -- Go to renamed subprogram if present, since convention applies to - -- the actual renamed entity, not to the renaming entity. If the - -- subprogram is inherited, go to parent subprogram. + -- Check pragma placement - if Is_Subprogram (E) - and then Present (Alias (E)) + if not Is_List_Member (N) then + Pragma_Misplaced; + end if; + + -- Test-case should only appear in package spec unit + + if Get_Source_Unit (N) = No_Unit + or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))), + N_Package_Declaration, + N_Generic_Package_Declaration) then - if Nkind (Parent (Declaration_Node (E))) = - N_Subprogram_Renaming_Declaration - then - if Scope (E) /= Scope (Alias (E)) then - Error_Pragma_Ref - ("cannot apply pragma% to non-local entity&#", E); - end if; + Pragma_Misplaced; + end if; - E := Alias (E); + -- Search prior declarations - elsif Nkind_In (Parent (E), N_Full_Type_Declaration, - N_Private_Extension_Declaration) - and then Scope (E) = Scope (Alias (E)) - then - E := Alias (E); + P := N; + while Present (Prev (P)) loop + P := Prev (P); - -- Return the parent subprogram the entity was inherited from + -- If the previous node is a generic subprogram, do not go to to + -- the original node, which is the unanalyzed tree: we need to + -- attach the test-case to the analyzed version at this point. + -- They get propagated to the original tree when analyzing the + -- corresponding body. - Ent := E; + if Nkind (P) not in N_Generic_Declaration then + PO := Original_Node (P); + else + PO := P; end if; - end if; - - -- Check that we are not applying this to a specless body - -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada - -- compilers. - if Is_Subprogram (E) - and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body - and then not Relaxed_RM_Semantics - then - Error_Pragma - ("pragma% requires separate spec and must come before body"); - end if; + -- Skip past prior pragma - -- Check that we are not applying this to a named constant + if Nkind (PO) = N_Pragma then + null; - if Ekind_In (E, E_Named_Integer, E_Named_Real) then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("cannot apply pragma% to named constant!", - Get_Pragma_Arg (Arg2)); - Error_Pragma_Arg - ("\supply appropriate type for&!", Arg2); - end if; + -- Skip stuff not coming from source - if Ekind (E) = E_Enumeration_Literal then - Error_Pragma ("enumeration literal not allowed for pragma%"); - end if; + elsif not Comes_From_Source (PO) then + null; - -- Check for rep item appearing too early or too late + -- Only remaining possibility is subprogram declaration. First + -- check that it is declared directly in a package declaration. + -- This may be either the package declaration for the current unit + -- being defined or a local package declaration. - if Etype (E) = Any_Type - or else Rep_Item_Too_Early (E, N) - then - raise Pragma_Exit; + elsif not Present (Parent (Parent (PO))) + or else not Present (Parent (Parent (Parent (PO)))) + or else not Nkind_In (Parent (Parent (PO)), + N_Package_Declaration, + N_Generic_Package_Declaration) + then + Pragma_Misplaced; - elsif Present (Underlying_Type (E)) then - E := Underlying_Type (E); - end if; + else + Chain_CTC (PO); + return; + end if; + end loop; - if Rep_Item_Too_Late (E, N) then - raise Pragma_Exit; - end if; + -- If we fall through, pragma was misplaced - if Has_Convention_Pragma (E) then - Diagnose_Multiple_Pragmas (E); + Pragma_Misplaced; + end Check_Test_Case; - elsif Convention (E) = Convention_Protected - or else Ekind (Scope (E)) = E_Protected_Type - then - Error_Pragma_Arg - ("a protected operation cannot be given a different convention", - Arg2); - end if; + -------------------------------------- + -- Check_Valid_Configuration_Pragma -- + -------------------------------------- - -- For Intrinsic, a subprogram is required + -- A configuration pragma must appear in the context clause of a + -- compilation unit, and only other pragmas may precede it. Note that + -- the test also allows use in a configuration pragma file. - if C = Convention_Intrinsic - and then not Is_Subprogram (E) - and then not Is_Generic_Subprogram (E) - then - Error_Pragma_Arg - ("second argument of pragma% must be a subprogram", Arg2); + procedure Check_Valid_Configuration_Pragma is + begin + if not Is_Configuration_Pragma then + Error_Pragma ("incorrect placement for configuration pragma%"); end if; + end Check_Valid_Configuration_Pragma; - -- Stdcall case + ------------------------------------- + -- Check_Valid_Library_Unit_Pragma -- + ------------------------------------- - if C = Convention_Stdcall then + procedure Check_Valid_Library_Unit_Pragma is + Plist : List_Id; + Parent_Node : Node_Id; + Unit_Name : Entity_Id; + Unit_Kind : Node_Kind; + Unit_Node : Node_Id; + Sindex : Source_File_Index; - -- A dispatching call is not allowed. A dispatching subprogram - -- cannot be used to interface to the Win32 API, so in fact this - -- check does not impose any effective restriction. + begin + if not Is_List_Member (N) then + Pragma_Misplaced; - if Is_Dispatching_Operation (E) then + else + Plist := List_Containing (N); + Parent_Node := Parent (Plist); - Error_Pragma - ("dispatching subprograms cannot use Stdcall convention"); + if Parent_Node = Empty then + Pragma_Misplaced; - -- Subprogram is allowed, but not a generic subprogram, and not a - -- dispatching operation. + -- Case of pragma appearing after a compilation unit. In this case + -- it must have an argument with the corresponding name and must + -- be part of the following pragmas of its parent. - elsif not Is_Subprogram (E) - and then not Is_Generic_Subprogram (E) + elsif Nkind (Parent_Node) = N_Compilation_Unit_Aux then + if Plist /= Pragmas_After (Parent_Node) then + Pragma_Misplaced; - -- A variable is OK + elsif Arg_Count = 0 then + Error_Pragma + ("argument required if outside compilation unit"); - and then Ekind (E) /= E_Variable + else + Check_No_Identifiers; + Check_Arg_Count (1); + Unit_Node := Unit (Parent (Parent_Node)); + Unit_Kind := Nkind (Unit_Node); - -- An access to subprogram is also allowed + Analyze (Get_Pragma_Arg (Arg1)); - and then not - (Is_Access_Type (E) - and then Ekind (Designated_Type (E)) = E_Subprogram_Type) - then - Error_Pragma_Arg - ("second argument of pragma% must be subprogram (type)", - Arg2); - end if; - end if; + if Unit_Kind = N_Generic_Subprogram_Declaration + or else Unit_Kind = N_Subprogram_Declaration + then + Unit_Name := Defining_Entity (Unit_Node); - if not Is_Subprogram (E) - and then not Is_Generic_Subprogram (E) - then - Set_Convention_From_Pragma (E); + elsif Unit_Kind in N_Generic_Instantiation then + Unit_Name := Defining_Entity (Unit_Node); - if Is_Type (E) then - Check_First_Subtype (Arg2); - Set_Convention_From_Pragma (Base_Type (E)); + else + Unit_Name := Cunit_Entity (Current_Sem_Unit); + end if; - -- For subprograms, we must set the convention on the - -- internally generated directly designated type as well. + if Chars (Unit_Name) /= + Chars (Entity (Get_Pragma_Arg (Arg1))) + then + Error_Pragma_Arg + ("pragma% argument is not current unit name", Arg1); + end if; - if Ekind (E) = E_Access_Subprogram_Type then - Set_Convention_From_Pragma (Directly_Designated_Type (E)); + if Ekind (Unit_Name) = E_Package + and then Present (Renamed_Entity (Unit_Name)) + then + Error_Pragma ("pragma% not allowed for renamed package"); + end if; end if; - end if; - -- For the subprogram case, set proper convention for all homonyms - -- in same scope and the same declarative part, i.e. the same - -- compilation unit. + -- Pragma appears other than after a compilation unit - else - Comp_Unit := Get_Source_Unit (E); - Set_Convention_From_Pragma (E); + else + -- Here we check for the generic instantiation case and also + -- for the case of processing a generic formal package. We + -- detect these cases by noting that the Sloc on the node + -- does not belong to the current compilation unit. - -- Treat a pragma Import as an implicit body, and pragma import - -- as implicit reference (for navigation in GPS). + Sindex := Source_Index (Current_Sem_Unit); - if Prag_Id = Pragma_Import then - Generate_Reference (E, Id, 'b'); + if Loc not in Source_First (Sindex) .. Source_Last (Sindex) then + Rewrite (N, Make_Null_Statement (Loc)); + return; - -- For exported entities we restrict the generation of references - -- to entities exported to foreign languages since entities - -- exported to Ada do not provide further information to GPS and - -- add undesired references to the output of the gnatxref tool. + -- If before first declaration, the pragma applies to the + -- enclosing unit, and the name if present must be this name. - elsif Prag_Id = Pragma_Export - and then Convention (E) /= Convention_Ada - then - Generate_Reference (E, Id, 'i'); - end if; + elsif Is_Before_First_Decl (N, Plist) then + Unit_Node := Unit_Declaration_Node (Current_Scope); + Unit_Kind := Nkind (Unit_Node); - -- If the pragma comes from from an aspect, it only applies - -- to the given entity, not its homonyms. + if Nkind (Parent (Unit_Node)) /= N_Compilation_Unit then + Pragma_Misplaced; - if From_Aspect_Specification (N) then - return; - end if; + elsif Unit_Kind = N_Subprogram_Body + and then not Acts_As_Spec (Unit_Node) + then + Pragma_Misplaced; - -- Otherwise Loop through the homonyms of the pragma argument's - -- entity, an apply convention to those in the current scope. + elsif Nkind (Parent_Node) = N_Package_Body then + Pragma_Misplaced; - E1 := Ent; + elsif Nkind (Parent_Node) = N_Package_Specification + and then Plist = Private_Declarations (Parent_Node) + then + Pragma_Misplaced; - loop - E1 := Homonym (E1); - exit when No (E1) or else Scope (E1) /= Current_Scope; + elsif (Nkind (Parent_Node) = N_Generic_Package_Declaration + or else Nkind (Parent_Node) = + N_Generic_Subprogram_Declaration) + and then Plist = Generic_Formal_Declarations (Parent_Node) + then + Pragma_Misplaced; - -- Do not set the pragma on inherited operations or on formal - -- subprograms. + elsif Arg_Count > 0 then + Analyze (Get_Pragma_Arg (Arg1)); - if Comes_From_Source (E1) - and then Comp_Unit = Get_Source_Unit (E1) - and then not Is_Formal_Subprogram (E1) - and then Nkind (Original_Node (Parent (E1))) /= - N_Full_Type_Declaration - then - if Present (Alias (E1)) - and then Scope (E1) /= Scope (Alias (E1)) - then - Error_Pragma_Ref - ("cannot apply pragma% to non-local entity& declared#", - E1); - end if; + if Entity (Get_Pragma_Arg (Arg1)) /= Current_Scope then + Error_Pragma_Arg + ("name in pragma% must be enclosing unit", Arg1); + end if; - Set_Convention_From_Pragma (E1); + -- It is legal to have no argument in this context - if Prag_Id = Pragma_Import then - Generate_Reference (E1, Id, 'b'); + else + return; end if; + + -- Error if not before first declaration. This is because a + -- library unit pragma argument must be the name of a library + -- unit (RM 10.1.5(7)), but the only names permitted in this + -- context are (RM 10.1.5(6)) names of subprogram declarations, + -- generic subprogram declarations or generic instantiations. + + else + Error_Pragma + ("pragma% misplaced, must be before first declaration"); end if; - end loop; + end if; end if; - end Process_Convention; + end Check_Valid_Library_Unit_Pragma; - ---------------------------------------- - -- Process_Disable_Enable_Atomic_Sync -- - ---------------------------------------- + ------------------- + -- Check_Variant -- + ------------------- + + procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is + Clist : constant Node_Id := Component_List (Variant); + Comp : Node_Id; - procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is begin - GNAT_Pragma; - Check_No_Identifiers; - Check_At_Most_N_Arguments (1); + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + Check_Component (Comp, UU_Typ, In_Variant_Part => True); + Next (Comp); + end loop; + end Check_Variant; - -- Modeled internally as - -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity]) + ------------------ + -- Error_Pragma -- + ------------------ - Rewrite (N, - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Loc, Nam), - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => - Make_Identifier (Loc, Name_Atomic_Synchronization))))); + procedure Error_Pragma (Msg : String) is + MsgF : String := Msg; + begin + Error_Msg_Name_1 := Pname; + Fix_Error (MsgF); + Error_Msg_N (MsgF, N); + raise Pragma_Exit; + end Error_Pragma; - if Present (Arg1) then - Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1)); - end if; + ---------------------- + -- Error_Pragma_Arg -- + ---------------------- - Analyze (N); - end Process_Disable_Enable_Atomic_Sync; + procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is + MsgF : String := Msg; + begin + Error_Msg_Name_1 := Pname; + Fix_Error (MsgF); + Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); + raise Pragma_Exit; + end Error_Pragma_Arg; - ----------------------------------------------------- - -- Process_Extended_Import_Export_Exception_Pragma -- - ----------------------------------------------------- + procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is + MsgF : String := Msg1; + begin + Error_Msg_Name_1 := Pname; + Fix_Error (MsgF); + Error_Msg_N (MsgF, Get_Pragma_Arg (Arg)); + Error_Pragma_Arg (Msg2, Arg); + end Error_Pragma_Arg; - procedure Process_Extended_Import_Export_Exception_Pragma - (Arg_Internal : Node_Id; - Arg_External : Node_Id; - Arg_Form : Node_Id; - Arg_Code : Node_Id) - is - Def_Id : Entity_Id; - Code_Val : Uint; + ---------------------------- + -- Error_Pragma_Arg_Ident -- + ---------------------------- + procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is + MsgF : String := Msg; begin - if not OpenVMS_On_Target then - Error_Pragma - ("??pragma% ignored (applies only to Open'V'M'S)"); - end if; + Error_Msg_Name_1 := Pname; + Fix_Error (MsgF); + Error_Msg_N (MsgF, Arg); + raise Pragma_Exit; + end Error_Pragma_Arg_Ident; - Process_Extended_Import_Export_Internal_Arg (Arg_Internal); - Def_Id := Entity (Arg_Internal); + ---------------------- + -- Error_Pragma_Ref -- + ---------------------- - if Ekind (Def_Id) /= E_Exception then - Error_Pragma_Arg - ("pragma% must refer to declared exception", Arg_Internal); - end if; + procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is + MsgF : String := Msg; + begin + Error_Msg_Name_1 := Pname; + Fix_Error (MsgF); + Error_Msg_Sloc := Sloc (Ref); + Error_Msg_NE (MsgF, N, Ref); + raise Pragma_Exit; + end Error_Pragma_Ref; - Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); + ------------------------ + -- Find_Lib_Unit_Name -- + ------------------------ - if Present (Arg_Form) then - Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS); - end if; + function Find_Lib_Unit_Name return Entity_Id is + begin + -- Return inner compilation unit entity, for case of nested + -- categorization pragmas. This happens in generic unit. - if Present (Arg_Form) - and then Chars (Arg_Form) = Name_Ada + if Nkind (Parent (N)) = N_Package_Specification + and then Defining_Entity (Parent (N)) /= Current_Scope then - null; + return Defining_Entity (Parent (N)); else - Set_Is_VMS_Exception (Def_Id); - Set_Exception_Code (Def_Id, No_Uint); + return Current_Scope; end if; + end Find_Lib_Unit_Name; - if Present (Arg_Code) then - if not Is_VMS_Exception (Def_Id) then - Error_Pragma_Arg - ("Code option for pragma% not allowed for Ada case", - Arg_Code); - end if; - - Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer); - Code_Val := Expr_Value (Arg_Code); - - if not UI_Is_In_Int_Range (Code_Val) then - Error_Pragma_Arg - ("Code option for pragma% must be in 32-bit range", - Arg_Code); - - else - Set_Exception_Code (Def_Id, Code_Val); - end if; - end if; - end Process_Extended_Import_Export_Exception_Pragma; + ---------------------------- + -- Find_Program_Unit_Name -- + ---------------------------- - ------------------------------------------------- - -- Process_Extended_Import_Export_Internal_Arg -- - ------------------------------------------------- + procedure Find_Program_Unit_Name (Id : Node_Id) is + Unit_Name : Entity_Id; + Unit_Kind : Node_Kind; + P : constant Node_Id := Parent (N); - procedure Process_Extended_Import_Export_Internal_Arg - (Arg_Internal : Node_Id := Empty) - is begin - if No (Arg_Internal) then - Error_Pragma ("Internal parameter required for pragma%"); - end if; + if Nkind (P) = N_Compilation_Unit then + Unit_Kind := Nkind (Unit (P)); - if Nkind (Arg_Internal) = N_Identifier then - null; + if Unit_Kind = N_Subprogram_Declaration + or else Unit_Kind = N_Package_Declaration + or else Unit_Kind in N_Generic_Declaration + then + Unit_Name := Defining_Entity (Unit (P)); - elsif Nkind (Arg_Internal) = N_Operator_Symbol - and then (Prag_Id = Pragma_Import_Function - or else - Prag_Id = Pragma_Export_Function) - then - null; + if Chars (Id) = Chars (Unit_Name) then + Set_Entity (Id, Unit_Name); + Set_Etype (Id, Etype (Unit_Name)); + else + Set_Etype (Id, Any_Type); + Error_Pragma + ("cannot find program unit referenced by pragma%"); + end if; + + else + Set_Etype (Id, Any_Type); + Error_Pragma ("pragma% inapplicable to this unit"); + end if; else - Error_Pragma_Arg - ("wrong form for Internal parameter for pragma%", Arg_Internal); + Analyze (Id); end if; + end Find_Program_Unit_Name; - Check_Arg_Is_Local_Name (Arg_Internal); - end Process_Extended_Import_Export_Internal_Arg; - - -------------------------------------------------- - -- Process_Extended_Import_Export_Object_Pragma -- - -------------------------------------------------- + ----------------------------------------- + -- Find_Unique_Parameterless_Procedure -- + ----------------------------------------- - procedure Process_Extended_Import_Export_Object_Pragma - (Arg_Internal : Node_Id; - Arg_External : Node_Id; - Arg_Size : Node_Id) + function Find_Unique_Parameterless_Procedure + (Name : Entity_Id; + Arg : Node_Id) return Entity_Id is - Def_Id : Entity_Id; + Proc : Entity_Id := Empty; begin - Process_Extended_Import_Export_Internal_Arg (Arg_Internal); - Def_Id := Entity (Arg_Internal); + -- The body of this procedure needs some comments ??? - if not Ekind_In (Def_Id, E_Constant, E_Variable) then + if not Is_Entity_Name (Name) then Error_Pragma_Arg - ("pragma% must designate an object", Arg_Internal); - end if; + ("argument of pragma% must be entity name", Arg); - if Has_Rep_Pragma (Def_Id, Name_Common_Object) - or else - Has_Rep_Pragma (Def_Id, Name_Psect_Object) - then - Error_Pragma_Arg - ("previous Common/Psect_Object applies, pragma % not permitted", - Arg_Internal); - end if; + elsif not Is_Overloaded (Name) then + Proc := Entity (Name); - if Rep_Item_Too_Late (Def_Id, N) then - raise Pragma_Exit; - end if; + if Ekind (Proc) /= E_Procedure + or else Present (First_Formal (Proc)) + then + Error_Pragma_Arg + ("argument of pragma% must be parameterless procedure", Arg); + end if; - Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); + else + declare + Found : Boolean := False; + It : Interp; + Index : Interp_Index; - if Present (Arg_Size) then - Check_Arg_Is_External_Name (Arg_Size); - end if; + begin + Get_First_Interp (Name, Index, It); + while Present (It.Nam) loop + Proc := It.Nam; - -- Export_Object case + if Ekind (Proc) = E_Procedure + and then No (First_Formal (Proc)) + then + if not Found then + Found := True; + Set_Entity (Name, Proc); + Set_Is_Overloaded (Name, False); + else + Error_Pragma_Arg + ("ambiguous handler name for pragma% ", Arg); + end if; + end if; - if Prag_Id = Pragma_Export_Object then - if not Is_Library_Level_Entity (Def_Id) then - Error_Pragma_Arg - ("argument for pragma% must be library level entity", - Arg_Internal); - end if; + Get_Next_Interp (Index, It); + end loop; - if Ekind (Current_Scope) = E_Generic_Package then - Error_Pragma ("pragma& cannot appear in a generic unit"); - end if; + if not Found then + Error_Pragma_Arg + ("argument of pragma% must be parameterless procedure", + Arg); + else + Proc := Entity (Name); + end if; + end; + end if; - if not Size_Known_At_Compile_Time (Etype (Def_Id)) then - Error_Pragma_Arg - ("exported object must have compile time known size", - Arg_Internal); - end if; + return Proc; + end Find_Unique_Parameterless_Procedure; - if Warn_On_Export_Import and then Is_Exported (Def_Id) then - Error_Msg_N ("??duplicate Export_Object pragma", N); - else - Set_Exported (Def_Id, Arg_Internal); - end if; + --------------- + -- Fix_Error -- + --------------- - -- Import_Object case + procedure Fix_Error (Msg : in out String) is + begin + -- If we have a rewriting of another pragma, go to that pragma - else - if Is_Concurrent_Type (Etype (Def_Id)) then - Error_Pragma_Arg - ("cannot use pragma% for task/protected object", - Arg_Internal); - end if; + if Is_Rewrite_Substitution (N) + and then Nkind (Original_Node (N)) = N_Pragma + then + Error_Msg_Name_1 := Pragma_Name (Original_Node (N)); + end if; - if Ekind (Def_Id) = E_Constant then - Error_Pragma_Arg - ("cannot import a constant", Arg_Internal); - end if; + -- Case where pragma comes from an aspect specification - if Warn_On_Export_Import - and then Has_Discriminants (Etype (Def_Id)) - then - Error_Msg_N - ("imported value must be initialized??", Arg_Internal); - end if; + if From_Aspect_Specification (N) then - if Warn_On_Export_Import - and then Is_Access_Type (Etype (Def_Id)) - then - Error_Pragma_Arg - ("cannot import object of an access type??", Arg_Internal); - end if; + -- Change appearence of "pragma" in message to "aspect" - if Warn_On_Export_Import - and then Is_Imported (Def_Id) - then - Error_Msg_N ("??duplicate Import_Object pragma", N); + for J in Msg'First .. Msg'Last - 5 loop + if Msg (J .. J + 5) = "pragma" then + Msg (J .. J + 5) := "aspect"; + end if; + end loop; - -- Check for explicit initialization present. Note that an - -- initialization generated by the code generator, e.g. for an - -- access type, does not count here. + -- Get name from corresponding aspect - elsif Present (Expression (Parent (Def_Id))) - and then - Comes_From_Source - (Original_Node (Expression (Parent (Def_Id)))) - then - Error_Msg_Sloc := Sloc (Def_Id); - Error_Pragma_Arg - ("imported entities cannot be initialized (RM B.1(24))", - "\no initialization allowed for & declared#", Arg1); - else - Set_Imported (Def_Id); - Note_Possible_Modification (Arg_Internal, Sure => False); - end if; + Error_Msg_Name_1 := Original_Name (N); end if; - end Process_Extended_Import_Export_Object_Pragma; + end Fix_Error; - ------------------------------------------------------ - -- Process_Extended_Import_Export_Subprogram_Pragma -- - ------------------------------------------------------ + ------------------------- + -- Gather_Associations -- + ------------------------- - procedure Process_Extended_Import_Export_Subprogram_Pragma - (Arg_Internal : Node_Id; - Arg_External : Node_Id; - Arg_Parameter_Types : Node_Id; - Arg_Result_Type : Node_Id := Empty; - Arg_Mechanism : Node_Id; - Arg_Result_Mechanism : Node_Id := Empty; - Arg_First_Optional_Parameter : Node_Id := Empty) + procedure Gather_Associations + (Names : Name_List; + Args : out Args_List) is - Ent : Entity_Id; - Def_Id : Entity_Id; - Hom_Id : Entity_Id; - Formal : Entity_Id; - Ambiguous : Boolean; - Match : Boolean; - Dval : Node_Id; + Arg : Node_Id; - function Same_Base_Type - (Ptype : Node_Id; - Formal : Entity_Id) return Boolean; - -- Determines if Ptype references the type of Formal. Note that only - -- the base types need to match according to the spec. Ptype here is - -- the argument from the pragma, which is either a type name, or an - -- access attribute. + begin + -- Initialize all parameters to Empty - -------------------- - -- Same_Base_Type -- - -------------------- + for J in Args'Range loop + Args (J) := Empty; + end loop; - function Same_Base_Type - (Ptype : Node_Id; - Formal : Entity_Id) return Boolean - is - Ftyp : constant Entity_Id := Base_Type (Etype (Formal)); - Pref : Node_Id; + -- That's all we have to do if there are no argument associations - begin - -- Case where pragma argument is typ'Access + if No (Pragma_Argument_Associations (N)) then + return; + end if; - if Nkind (Ptype) = N_Attribute_Reference - and then Attribute_Name (Ptype) = Name_Access - then - Pref := Prefix (Ptype); - Find_Type (Pref); + -- Otherwise first deal with any positional parameters present - if not Is_Entity_Name (Pref) - or else Entity (Pref) = Any_Type - then - raise Pragma_Exit; - end if; + Arg := First (Pragma_Argument_Associations (N)); + for Index in Args'Range loop + exit when No (Arg) or else Chars (Arg) /= No_Name; + Args (Index) := Get_Pragma_Arg (Arg); + Next (Arg); + end loop; - -- We have a match if the corresponding argument is of an - -- anonymous access type, and its designated type matches the - -- type of the prefix of the access attribute + -- Positional parameters all processed, if any left, then we + -- have too many positional parameters. - return Ekind (Ftyp) = E_Anonymous_Access_Type - and then Base_Type (Entity (Pref)) = - Base_Type (Etype (Designated_Type (Ftyp))); + if Present (Arg) and then Chars (Arg) = No_Name then + Error_Pragma_Arg + ("too many positional associations for pragma%", Arg); + end if; - -- Case where pragma argument is a type name + -- Process named parameters if any are present + + while Present (Arg) loop + if Chars (Arg) = No_Name then + Error_Pragma_Arg + ("positional association cannot follow named association", + Arg); else - Find_Type (Ptype); + for Index in Names'Range loop + if Names (Index) = Chars (Arg) then + if Present (Args (Index)) then + Error_Pragma_Arg + ("duplicate argument association for pragma%", Arg); + else + Args (Index) := Get_Pragma_Arg (Arg); + exit; + end if; + end if; - if not Is_Entity_Name (Ptype) - or else Entity (Ptype) = Any_Type - then - raise Pragma_Exit; - end if; + if Index = Names'Last then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("pragma% does not allow & argument", Arg); - -- We have a match if the corresponding argument is of the type - -- given in the pragma (comparing base types) + -- Check for possible misspelling - return Base_Type (Entity (Ptype)) = Ftyp; + for Index1 in Names'Range loop + if Is_Bad_Spelling_Of + (Chars (Arg), Names (Index1)) + then + Error_Msg_Name_1 := Names (Index1); + Error_Msg_N -- CODEFIX + ("\possible misspelling of%", Arg); + exit; + end if; + end loop; + + raise Pragma_Exit; + end if; + end loop; end if; - end Same_Base_Type; - -- Start of processing for - -- Process_Extended_Import_Export_Subprogram_Pragma + Next (Arg); + end loop; + end Gather_Associations; + ----------------- + -- GNAT_Pragma -- + ----------------- + + procedure GNAT_Pragma is begin - Process_Extended_Import_Export_Internal_Arg (Arg_Internal); - Ent := Empty; - Ambiguous := False; + -- We need to check the No_Implementation_Pragmas restriction for + -- the case of a pragma from source. Note that the case of aspects + -- generating corresponding pragmas marks these pragmas as not being + -- from source, so this test also catches that case. - -- Loop through homonyms (overloadings) of the entity + if Comes_From_Source (N) then + Check_Restriction (No_Implementation_Pragmas, N); + end if; + end GNAT_Pragma; - Hom_Id := Entity (Arg_Internal); - while Present (Hom_Id) loop - Def_Id := Get_Base_Subprogram (Hom_Id); + -------------------------- + -- Is_Before_First_Decl -- + -------------------------- - -- We need a subprogram in the current scope + function Is_Before_First_Decl + (Pragma_Node : Node_Id; + Decls : List_Id) return Boolean + is + Item : Node_Id := First (Decls); - if not Is_Subprogram (Def_Id) - or else Scope (Def_Id) /= Current_Scope - then - null; + begin + -- Only other pragmas can come before this pragma - else - Match := True; + loop + if No (Item) or else Nkind (Item) /= N_Pragma then + return False; - -- Pragma cannot apply to subprogram body + elsif Item = Pragma_Node then + return True; + end if; - if Is_Subprogram (Def_Id) - and then Nkind (Parent (Declaration_Node (Def_Id))) = - N_Subprogram_Body - then - Error_Pragma - ("pragma% requires separate spec" - & " and must come before body"); + Next (Item); + end loop; + end Is_Before_First_Decl; + + ----------------------------- + -- Is_Configuration_Pragma -- + ----------------------------- + + -- A configuration pragma must appear in the context clause of a + -- compilation unit, and only other pragmas may precede it. Note that + -- the test below also permits use in a configuration pragma file. + + function Is_Configuration_Pragma return Boolean is + Lis : constant List_Id := List_Containing (N); + Par : constant Node_Id := Parent (N); + Prg : Node_Id; + + begin + -- If no parent, then we are in the configuration pragma file, + -- so the placement is definitely appropriate. + + if No (Par) then + return True; + + -- Otherwise we must be in the context clause of a compilation unit + -- and the only thing allowed before us in the context list is more + -- configuration pragmas. + + elsif Nkind (Par) = N_Compilation_Unit + and then Context_Items (Par) = Lis + then + Prg := First (Lis); + + loop + if Prg = N then + return True; + elsif Nkind (Prg) /= N_Pragma then + return False; end if; - -- Test result type if given, note that the result type - -- parameter can only be present for the function cases. + Next (Prg); + end loop; - if Present (Arg_Result_Type) - and then not Same_Base_Type (Arg_Result_Type, Def_Id) - then - Match := False; + else + return False; + end if; + end Is_Configuration_Pragma; - elsif Etype (Def_Id) /= Standard_Void_Type - and then - Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure) - then - Match := False; + -------------------------- + -- Is_In_Context_Clause -- + -------------------------- - -- Test parameter types if given. Note that this parameter - -- has not been analyzed (and must not be, since it is - -- semantic nonsense), so we get it as the parser left it. + function Is_In_Context_Clause return Boolean is + Plist : List_Id; + Parent_Node : Node_Id; - elsif Present (Arg_Parameter_Types) then - Check_Matching_Types : declare - Formal : Entity_Id; - Ptype : Node_Id; + begin + if not Is_List_Member (N) then + return False; - begin - Formal := First_Formal (Def_Id); + else + Plist := List_Containing (N); + Parent_Node := Parent (Plist); - if Nkind (Arg_Parameter_Types) = N_Null then - if Present (Formal) then - Match := False; - end if; + if Parent_Node = Empty + or else Nkind (Parent_Node) /= N_Compilation_Unit + or else Context_Items (Parent_Node) /= Plist + then + return False; + end if; + end if; - -- A list of one type, e.g. (List) is parsed as - -- a parenthesized expression. + return True; + end Is_In_Context_Clause; - elsif Nkind (Arg_Parameter_Types) /= N_Aggregate - and then Paren_Count (Arg_Parameter_Types) = 1 - then - if No (Formal) - or else Present (Next_Formal (Formal)) - then - Match := False; - else - Match := - Same_Base_Type (Arg_Parameter_Types, Formal); - end if; + --------------------------------- + -- Is_Static_String_Expression -- + --------------------------------- - -- A list of more than one type is parsed as a aggregate + function Is_Static_String_Expression (Arg : Node_Id) return Boolean is + Argx : constant Node_Id := Get_Pragma_Arg (Arg); - elsif Nkind (Arg_Parameter_Types) = N_Aggregate - and then Paren_Count (Arg_Parameter_Types) = 0 - then - Ptype := First (Expressions (Arg_Parameter_Types)); - while Present (Ptype) or else Present (Formal) loop - if No (Ptype) - or else No (Formal) - or else not Same_Base_Type (Ptype, Formal) - then - Match := False; - exit; - else - Next_Formal (Formal); - Next (Ptype); - end if; - end loop; + begin + Analyze_And_Resolve (Argx); + return Is_OK_Static_Expression (Argx) + and then Nkind (Argx) = N_String_Literal; + end Is_Static_String_Expression; - -- Anything else is of the wrong form + ---------------------- + -- Pragma_Misplaced -- + ---------------------- - else - Error_Pragma_Arg - ("wrong form for Parameter_Types parameter", - Arg_Parameter_Types); - end if; - end Check_Matching_Types; - end if; + procedure Pragma_Misplaced is + begin + Error_Pragma ("incorrect placement of pragma%"); + end Pragma_Misplaced; - -- Match is now False if the entry we found did not match - -- either a supplied Parameter_Types or Result_Types argument + ------------------------------------ + -- Process_Atomic_Shared_Volatile -- + ------------------------------------ - if Match then - if No (Ent) then - Ent := Def_Id; + procedure Process_Atomic_Shared_Volatile is + E_Id : Node_Id; + E : Entity_Id; + D : Node_Id; + K : Node_Kind; + Utyp : Entity_Id; - -- Ambiguous case, the flag Ambiguous shows if we already - -- detected this and output the initial messages. + procedure Set_Atomic (E : Entity_Id); + -- Set given type as atomic, and if no explicit alignment was given, + -- set alignment to unknown, since back end knows what the alignment + -- requirements are for atomic arrays. Note: this step is necessary + -- for derived types. - else - if not Ambiguous then - Ambiguous := True; - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("pragma% does not uniquely identify subprogram!", - N); - Error_Msg_Sloc := Sloc (Ent); - Error_Msg_N ("matching subprogram #!", N); - Ent := Empty; - end if; + ---------------- + -- Set_Atomic -- + ---------------- - Error_Msg_Sloc := Sloc (Def_Id); - Error_Msg_N ("matching subprogram #!", N); - end if; - end if; - end if; + procedure Set_Atomic (E : Entity_Id) is + begin + Set_Is_Atomic (E); - Hom_Id := Homonym (Hom_Id); - end loop; + if not Has_Alignment_Clause (E) then + Set_Alignment (E, Uint_0); + end if; + end Set_Atomic; - -- See if we found an entry + -- Start of processing for Process_Atomic_Shared_Volatile - if No (Ent) then - if not Ambiguous then - if Is_Generic_Subprogram (Entity (Arg_Internal)) then - Error_Pragma - ("pragma% cannot be given for generic subprogram"); - else - Error_Pragma - ("pragma% does not identify local subprogram"); - end if; - end if; + begin + Check_Ada_83_Warning; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + if Etype (E_Id) = Any_Type then return; end if; - -- Import pragmas must be for imported entities - - if Prag_Id = Pragma_Import_Function - or else - Prag_Id = Pragma_Import_Procedure - or else - Prag_Id = Pragma_Import_Valued_Procedure - then - if not Is_Imported (Ent) then - Error_Pragma - ("pragma Import or Interface must precede pragma%"); - end if; - - -- Here we have the Export case which can set the entity as exported + E := Entity (E_Id); + D := Declaration_Node (E); + K := Nkind (D); - -- But does not do so if the specified external name is null, since - -- that is taken as a signal in DEC Ada 83 (with which we want to be - -- compatible) to request no external name. + -- Check duplicate before we chain ourselves! - elsif Nkind (Arg_External) = N_String_Literal - and then String_Length (Strval (Arg_External)) = 0 - then - null; + Check_Duplicate_Pragma (E); - -- In all other cases, set entity as exported + -- Now check appropriateness of the entity - else - Set_Exported (Ent, Arg_Internal); - end if; + if Is_Type (E) then + if Rep_Item_Too_Early (E, N) + or else + Rep_Item_Too_Late (E, N) + then + return; + else + Check_First_Subtype (Arg1); + end if; - -- Special processing for Valued_Procedure cases + if Prag_Id /= Pragma_Volatile then + Set_Atomic (E); + Set_Atomic (Underlying_Type (E)); + Set_Atomic (Base_Type (E)); + end if; - if Prag_Id = Pragma_Import_Valued_Procedure - or else - Prag_Id = Pragma_Export_Valued_Procedure - then - Formal := First_Formal (Ent); + -- Attribute belongs on the base type. If the view of the type is + -- currently private, it also belongs on the underlying type. - if No (Formal) then - Error_Pragma ("at least one parameter required for pragma%"); + Set_Is_Volatile (Base_Type (E)); + Set_Is_Volatile (Underlying_Type (E)); - elsif Ekind (Formal) /= E_Out_Parameter then - Error_Pragma ("first parameter must have mode out for pragma%"); + Set_Treat_As_Volatile (E); + Set_Treat_As_Volatile (Underlying_Type (E)); - else - Set_Is_Valued_Procedure (Ent); + elsif K = N_Object_Declaration + or else (K = N_Component_Declaration + and then Original_Record_Component (E) = E) + then + if Rep_Item_Too_Late (E, N) then + return; end if; - end if; - Set_Extended_Import_Export_External_Name (Ent, Arg_External); + if Prag_Id /= Pragma_Volatile then + Set_Is_Atomic (E); + + -- If the object declaration has an explicit initialization, a + -- temporary may have to be created to hold the expression, to + -- ensure that access to the object remain atomic. - -- Process Result_Mechanism argument if present. We have already - -- checked that this is only allowed for the function case. + if Nkind (Parent (E)) = N_Object_Declaration + and then Present (Expression (Parent (E))) + then + Set_Has_Delayed_Freeze (E); + end if; - if Present (Arg_Result_Mechanism) then - Set_Mechanism_Value (Ent, Arg_Result_Mechanism); - end if; + -- An interesting improvement here. If an object of composite + -- type X is declared atomic, and the type X isn't, that's a + -- pity, since it may not have appropriate alignment etc. We + -- can rescue this in the special case where the object and + -- type are in the same unit by just setting the type as + -- atomic, so that the back end will process it as atomic. - -- Process Mechanism parameter if present. Note that this parameter - -- is not analyzed, and must not be analyzed since it is semantic - -- nonsense, so we get it in exactly as the parser left it. + -- Note: we used to do this for elementary types as well, + -- but that turns out to be a bad idea and can have unwanted + -- effects, most notably if the type is elementary, the object + -- a simple component within a record, and both are in a spec: + -- every object of this type in the entire program will be + -- treated as atomic, thus incurring a potentially costly + -- synchronization operation for every access. - if Present (Arg_Mechanism) then - declare - Formal : Entity_Id; - Massoc : Node_Id; - Mname : Node_Id; - Choice : Node_Id; + -- Of course it would be best if the back end could just adjust + -- the alignment etc for the specific object, but that's not + -- something we are capable of doing at this point. - begin - -- A single mechanism association without a formal parameter - -- name is parsed as a parenthesized expression. All other - -- cases are parsed as aggregates, so we rewrite the single - -- parameter case as an aggregate for consistency. + Utyp := Underlying_Type (Etype (E)); - if Nkind (Arg_Mechanism) /= N_Aggregate - and then Paren_Count (Arg_Mechanism) = 1 + if Present (Utyp) + and then Is_Composite_Type (Utyp) + and then Sloc (E) > No_Location + and then Sloc (Utyp) > No_Location + and then + Get_Source_File_Index (Sloc (E)) = + Get_Source_File_Index (Sloc (Underlying_Type (Etype (E)))) then - Rewrite (Arg_Mechanism, - Make_Aggregate (Sloc (Arg_Mechanism), - Expressions => New_List ( - Relocate_Node (Arg_Mechanism)))); + Set_Is_Atomic (Underlying_Type (Etype (E))); end if; + end if; - -- Case of only mechanism name given, applies to all formals + Set_Is_Volatile (E); + Set_Treat_As_Volatile (E); - if Nkind (Arg_Mechanism) /= N_Aggregate then - Formal := First_Formal (Ent); - while Present (Formal) loop - Set_Mechanism_Value (Formal, Arg_Mechanism); - Next_Formal (Formal); - end loop; + else + Error_Pragma_Arg + ("inappropriate entity for pragma%", Arg1); + end if; + end Process_Atomic_Shared_Volatile; - -- Case of list of mechanism associations given + ------------------------------------------- + -- Process_Compile_Time_Warning_Or_Error -- + ------------------------------------------- - else - if Null_Record_Present (Arg_Mechanism) then - Error_Pragma_Arg - ("inappropriate form for Mechanism parameter", - Arg_Mechanism); - end if; + procedure Process_Compile_Time_Warning_Or_Error is + Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); - -- Deal with positional ones first + begin + Check_Arg_Count (2); + Check_No_Identifiers; + Check_Arg_Is_Static_Expression (Arg2, Standard_String); + Analyze_And_Resolve (Arg1x, Standard_Boolean); - Formal := First_Formal (Ent); + if Compile_Time_Known_Value (Arg1x) then + if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then + declare + Str : constant String_Id := + Strval (Get_Pragma_Arg (Arg2)); + Len : constant Int := String_Length (Str); + Cont : Boolean; + Ptr : Nat; + CC : Char_Code; + C : Character; + Cent : constant Entity_Id := + Cunit_Entity (Current_Sem_Unit); - if Present (Expressions (Arg_Mechanism)) then - Mname := First (Expressions (Arg_Mechanism)); - while Present (Mname) loop - if No (Formal) then - Error_Pragma_Arg - ("too many mechanism associations", Mname); - end if; + Force : constant Boolean := + Prag_Id = Pragma_Compile_Time_Warning + and then + Is_Spec_Name (Unit_Name (Current_Sem_Unit)) + and then (Ekind (Cent) /= E_Package + or else not In_Private_Part (Cent)); + -- Set True if this is the warning case, and we are in the + -- visible part of a package spec, or in a subprogram spec, + -- in which case we want to force the client to see the + -- warning, even though it is not in the main unit. - Set_Mechanism_Value (Formal, Mname); - Next_Formal (Formal); - Next (Mname); - end loop; - end if; + begin + -- Loop through segments of message separated by line feeds. + -- We output these segments as separate messages with + -- continuation marks for all but the first. - -- Deal with named entries + Cont := False; + Ptr := 1; + loop + Error_Msg_Strlen := 0; - if Present (Component_Associations (Arg_Mechanism)) then - Massoc := First (Component_Associations (Arg_Mechanism)); - while Present (Massoc) loop - Choice := First (Choices (Massoc)); + -- Loop to copy characters from argument to error message + -- string buffer. - if Nkind (Choice) /= N_Identifier - or else Present (Next (Choice)) - then - Error_Pragma_Arg - ("incorrect form for mechanism association", - Massoc); - end if; + loop + exit when Ptr > Len; + CC := Get_String_Char (Str, Ptr); + Ptr := Ptr + 1; - Formal := First_Formal (Ent); - loop - if No (Formal) then - Error_Pragma_Arg - ("parameter name & not present", Choice); - end if; + -- Ignore wide chars ??? else store character - if Chars (Choice) = Chars (Formal) then - Set_Mechanism_Value - (Formal, Expression (Massoc)); + if In_Character_Range (CC) then + C := Get_Character (CC); + exit when C = ASCII.LF; + Error_Msg_Strlen := Error_Msg_Strlen + 1; + Error_Msg_String (Error_Msg_Strlen) := C; + end if; + end loop; - -- Set entity on identifier (needed by ASIS) + -- Here with one line ready to go - Set_Entity (Choice, Formal); + Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning; - exit; - end if; + -- If this is a warning in a spec, then we want clients + -- to see the warning, so mark the message with the + -- special sequence !! to force the warning. In the case + -- of a package spec, we do not force this if we are in + -- the private part of the spec. - Next_Formal (Formal); - end loop; + if Force then + if Cont = False then + Error_Msg_N ("<~!!", Arg1); + Cont := True; + else + Error_Msg_N ("\<~!!", Arg1); + end if; - Next (Massoc); - end loop; - end if; - end if; - end; - end if; + -- Error, rather than warning, or in a body, so we do not + -- need to force visibility for client (error will be + -- output in any case, and this is the situation in which + -- we do not want a client to get a warning, since the + -- warning is in the body or the spec private part). - -- Process First_Optional_Parameter argument if present. We have - -- already checked that this is only allowed for the Import case. + else + if Cont = False then + Error_Msg_N ("<~", Arg1); + Cont := True; + else + Error_Msg_N ("\<~", Arg1); + end if; + end if; - if Present (Arg_First_Optional_Parameter) then - if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then - Error_Pragma_Arg - ("first optional parameter must be formal parameter name", - Arg_First_Optional_Parameter); + exit when Ptr > Len; + end loop; + end; end if; + end if; + end Process_Compile_Time_Warning_Or_Error; - Formal := First_Formal (Ent); - loop - if No (Formal) then - Error_Pragma_Arg - ("specified formal parameter& not found", - Arg_First_Optional_Parameter); - end if; - - exit when Chars (Formal) = - Chars (Arg_First_Optional_Parameter); - - Next_Formal (Formal); - end loop; + ------------------------ + -- Process_Convention -- + ------------------------ - Set_First_Optional_Parameter (Ent, Formal); + procedure Process_Convention + (C : out Convention_Id; + Ent : out Entity_Id) + is + Id : Node_Id; + E : Entity_Id; + E1 : Entity_Id; + Cname : Name_Id; + Comp_Unit : Unit_Number_Type; - -- Check specified and all remaining formals have right form + procedure Diagnose_Multiple_Pragmas (S : Entity_Id); + -- Called if we have more than one Export/Import/Convention pragma. + -- This is generally illegal, but we have a special case of allowing + -- Import and Interface to coexist if they specify the convention in + -- a consistent manner. We are allowed to do this, since Interface is + -- an implementation defined pragma, and we choose to do it since we + -- know Rational allows this combination. S is the entity id of the + -- subprogram in question. This procedure also sets the special flag + -- Import_Interface_Present in both pragmas in the case where we do + -- have matching Import and Interface pragmas. - while Present (Formal) loop - if Ekind (Formal) /= E_In_Parameter then - Error_Msg_NE - ("optional formal& is not of mode in!", - Arg_First_Optional_Parameter, Formal); + procedure Set_Convention_From_Pragma (E : Entity_Id); + -- Set convention in entity E, and also flag that the entity has a + -- convention pragma. If entity is for a private or incomplete type, + -- also set convention and flag on underlying type. This procedure + -- also deals with the special case of C_Pass_By_Copy convention. - else - Dval := Default_Value (Formal); + ------------------------------- + -- Diagnose_Multiple_Pragmas -- + ------------------------------- - if No (Dval) then - Error_Msg_NE - ("optional formal& does not have default value!", - Arg_First_Optional_Parameter, Formal); + procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is + Pdec : constant Node_Id := Declaration_Node (S); + Decl : Node_Id; + Err : Boolean; - elsif Compile_Time_Known_Value_Or_Aggr (Dval) then - null; + function Same_Convention (Decl : Node_Id) return Boolean; + -- Decl is a pragma node. This function returns True if this + -- pragma has a first argument that is an identifier with a + -- Chars field corresponding to the Convention_Id C. - else - Error_Msg_FE - ("default value for optional formal& is non-static!", - Arg_First_Optional_Parameter, Formal); - end if; - end if; + function Same_Name (Decl : Node_Id) return Boolean; + -- Decl is a pragma node. This function returns True if this + -- pragma has a second argument that is an identifier with a + -- Chars field that matches the Chars of the current subprogram. - Set_Is_Optional_Parameter (Formal); - Next_Formal (Formal); - end loop; - end if; - end Process_Extended_Import_Export_Subprogram_Pragma; + --------------------- + -- Same_Convention -- + --------------------- - -------------------------- - -- Process_Generic_List -- - -------------------------- + function Same_Convention (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); - procedure Process_Generic_List is - Arg : Node_Id; - Exp : Node_Id; + begin + if Present (Arg1) then + declare + Arg : constant Node_Id := Get_Pragma_Arg (Arg1); + begin + if Nkind (Arg) = N_Identifier + and then Is_Convention_Name (Chars (Arg)) + and then Get_Convention_Id (Chars (Arg)) = C + then + return True; + end if; + end; + end if; - begin - Check_No_Identifiers; - Check_At_Least_N_Arguments (1); + return False; + end Same_Convention; - Arg := Arg1; - while Present (Arg) loop - Exp := Get_Pragma_Arg (Arg); - Analyze (Exp); + --------------- + -- Same_Name -- + --------------- - if not Is_Entity_Name (Exp) - or else - (not Is_Generic_Instance (Entity (Exp)) - and then - not Is_Generic_Unit (Entity (Exp))) - then - Error_Pragma_Arg - ("pragma% argument must be name of generic unit/instance", - Arg); - end if; + function Same_Name (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + Arg2 : Node_Id; - Next (Arg); - end loop; - end Process_Generic_List; + begin + if No (Arg1) then + return False; + end if; - ------------------------------------ - -- Process_Import_Predefined_Type -- - ------------------------------------ + Arg2 := Next (Arg1); - procedure Process_Import_Predefined_Type is - Loc : constant Source_Ptr := Sloc (N); - Elmt : Elmt_Id; - Ftyp : Node_Id := Empty; - Decl : Node_Id; - Def : Node_Id; - Nam : Name_Id; + if No (Arg2) then + return False; + end if; - begin - String_To_Name_Buffer (Strval (Expression (Arg3))); - Nam := Name_Find; + declare + Arg : constant Node_Id := Get_Pragma_Arg (Arg2); + begin + if Nkind (Arg) = N_Identifier + and then Chars (Arg) = Chars (S) + then + return True; + end if; + end; - Elmt := First_Elmt (Predefined_Float_Types); - while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop - Next_Elmt (Elmt); - end loop; + return False; + end Same_Name; - Ftyp := Node (Elmt); + -- Start of processing for Diagnose_Multiple_Pragmas - if Present (Ftyp) then + begin + Err := True; - -- Don't build a derived type declaration, because predefined C - -- types have no declaration anywhere, so cannot really be named. - -- Instead build a full type declaration, starting with an - -- appropriate type definition is built + -- Definitely give message if we have Convention/Export here - if Is_Floating_Point_Type (Ftyp) then - Def := Make_Floating_Point_Definition (Loc, - Make_Integer_Literal (Loc, Digits_Value (Ftyp)), - Make_Real_Range_Specification (Loc, - Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))), - Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp))))); + if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then + null; - -- Should never have a predefined type we cannot handle + -- If we have an Import or Export, scan back from pragma to + -- find any previous pragma applying to the same procedure. + -- The scan will be terminated by the start of the list, or + -- hitting the subprogram declaration. This won't allow one + -- pragma to appear in the public part and one in the private + -- part, but that seems very unlikely in practice. else - raise Program_Error; - end if; + Decl := Prev (N); + while Present (Decl) and then Decl /= Pdec loop - -- Build and insert a Full_Type_Declaration, which will be - -- analyzed as soon as this list entry has been analyzed. + -- Look for pragma with same name as us - Decl := Make_Full_Type_Declaration (Loc, - Make_Defining_Identifier (Loc, Chars (Expression (Arg2))), - Type_Definition => Def); + if Nkind (Decl) = N_Pragma + and then Same_Name (Decl) + then + -- Give error if same as our pragma or Export/Convention - Insert_After (N, Decl); - Mark_Rewrite_Insertion (Decl); + if Nam_In (Pragma_Name (Decl), Name_Export, + Name_Convention, + Pragma_Name (N)) + then + exit; - else - Error_Pragma_Arg ("no matching type found for pragma%", - Arg2); - end if; - end Process_Import_Predefined_Type; + -- Case of Import/Interface or the other way round - --------------------------------- - -- Process_Import_Or_Interface -- - --------------------------------- + elsif Nam_In (Pragma_Name (Decl), Name_Interface, + Name_Import) + then + -- Here we know that we have Import and Interface. It + -- doesn't matter which way round they are. See if + -- they specify the same convention. If so, all OK, + -- and set special flags to stop other messages - procedure Process_Import_Or_Interface is - C : Convention_Id; - Def_Id : Entity_Id; - Hom_Id : Entity_Id; + if Same_Convention (Decl) then + Set_Import_Interface_Present (N); + Set_Import_Interface_Present (Decl); + Err := False; - begin - Process_Convention (C, Def_Id); - Kill_Size_Check_Code (Def_Id); - Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False); + -- If different conventions, special message - if Ekind_In (Def_Id, E_Variable, E_Constant) then + else + Error_Msg_Sloc := Sloc (Decl); + Error_Pragma_Arg + ("convention differs from that given#", Arg1); + return; + end if; + end if; + end if; - -- We do not permit Import to apply to a renaming declaration + Next (Decl); + end loop; + end if; - if Present (Renamed_Object (Def_Id)) then + -- Give message if needed if we fall through those tests + -- except on Relaxed_RM_Semantics where we let go: either this + -- is a case accepted/ignored by other Ada compilers (e.g. + -- a mix of Convention and Import), or another error will be + -- generated later (e.g. using both Import and Export). + + if Err and not Relaxed_RM_Semantics then Error_Pragma_Arg - ("pragma% not allowed for object renaming", Arg2); + ("at most one Convention/Export/Import pragma is allowed", + Arg2); + end if; + end Diagnose_Multiple_Pragmas; - -- User initialization is not allowed for imported object, but - -- the object declaration may contain a default initialization, - -- that will be discarded. Note that an explicit initialization - -- only counts if it comes from source, otherwise it is simply - -- the code generator making an implicit initialization explicit. + -------------------------------- + -- Set_Convention_From_Pragma -- + -------------------------------- - elsif Present (Expression (Parent (Def_Id))) - and then Comes_From_Source (Expression (Parent (Def_Id))) + procedure Set_Convention_From_Pragma (E : Entity_Id) is + begin + -- Ada 2005 (AI-430): Check invalid attempt to change convention + -- for an overridden dispatching operation. Technically this is + -- an amendment and should only be done in Ada 2005 mode. However, + -- this is clearly a mistake, since the problem that is addressed + -- by this AI is that there is a clear gap in the RM! + + if Is_Dispatching_Operation (E) + and then Present (Overridden_Operation (E)) + and then C /= Convention (Overridden_Operation (E)) then - Error_Msg_Sloc := Sloc (Def_Id); Error_Pragma_Arg - ("no initialization allowed for declaration of& #", - "\imported entities cannot be initialized (RM B.1(24))", - Arg2); + ("cannot change convention for overridden dispatching " + & "operation", Arg1); + end if; - else - Set_Imported (Def_Id); - Process_Interface_Name (Def_Id, Arg3, Arg4); + -- Set the convention - -- Note that we do not set Is_Public here. That's because we - -- only want to set it if there is no address clause, and we - -- don't know that yet, so we delay that processing till - -- freeze time. + Set_Convention (E, C); + Set_Has_Convention_Pragma (E); - -- pragma Import completes deferred constants + if Is_Incomplete_Or_Private_Type (E) + and then Present (Underlying_Type (E)) + then + Set_Convention (Underlying_Type (E), C); + Set_Has_Convention_Pragma (Underlying_Type (E), True); + end if; - if Ekind (Def_Id) = E_Constant then - Set_Has_Completion (Def_Id); - end if; + -- A class-wide type should inherit the convention of the specific + -- root type (although this isn't specified clearly by the RM). - -- It is not possible to import a constant of an unconstrained - -- array type (e.g. string) because there is no simple way to - -- write a meaningful subtype for it. + if Is_Type (E) and then Present (Class_Wide_Type (E)) then + Set_Convention (Class_Wide_Type (E), C); + end if; - if Is_Array_Type (Etype (Def_Id)) - and then not Is_Constrained (Etype (Def_Id)) + -- If the entity is a record type, then check for special case of + -- C_Pass_By_Copy, which is treated the same as C except that the + -- special record flag is set. This convention is only permitted + -- on record types (see AI95-00131). + + if Cname = Name_C_Pass_By_Copy then + if Is_Record_Type (E) then + Set_C_Pass_By_Copy (Base_Type (E)); + elsif Is_Incomplete_Or_Private_Type (E) + and then Is_Record_Type (Underlying_Type (E)) then - Error_Msg_NE - ("imported constant& must have a constrained subtype", - N, Def_Id); + Set_C_Pass_By_Copy (Base_Type (Underlying_Type (E))); + else + Error_Pragma_Arg + ("C_Pass_By_Copy convention allowed only for record type", + Arg2); end if; end if; - elsif Is_Subprogram (Def_Id) - or else Is_Generic_Subprogram (Def_Id) - then - -- If the name is overloaded, pragma applies to all of the denoted - -- entities in the same declarative part, unless the pragma comes - -- from an aspect specification. + -- If the entity is a derived boolean type, check for the special + -- case of convention C, C++, or Fortran, where we consider any + -- nonzero value to represent true. - Hom_Id := Def_Id; - while Present (Hom_Id) loop + if Is_Discrete_Type (E) + and then Root_Type (Etype (E)) = Standard_Boolean + and then + (C = Convention_C + or else + C = Convention_CPP + or else + C = Convention_Fortran) + then + Set_Nonzero_Is_True (Base_Type (E)); + end if; + end Set_Convention_From_Pragma; - Def_Id := Get_Base_Subprogram (Hom_Id); + -- Start of processing for Process_Convention - -- Ignore inherited subprograms because the pragma will apply - -- to the parent operation, which is the one called. + begin + Check_At_Least_N_Arguments (2); + Check_Optional_Identifier (Arg1, Name_Convention); + Check_Arg_Is_Identifier (Arg1); + Cname := Chars (Get_Pragma_Arg (Arg1)); - if Is_Overloadable (Def_Id) - and then Present (Alias (Def_Id)) - then - null; + -- C_Pass_By_Copy is treated as a synonym for convention C (this is + -- tested again below to set the critical flag). - -- If it is not a subprogram, it must be in an outer scope and - -- pragma does not apply. + if Cname = Name_C_Pass_By_Copy then + C := Convention_C; - elsif not Is_Subprogram (Def_Id) - and then not Is_Generic_Subprogram (Def_Id) - then - null; + -- Otherwise we must have something in the standard convention list - -- The pragma does not apply to primitives of interfaces + elsif Is_Convention_Name (Cname) then + C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1))); - elsif Is_Dispatching_Operation (Def_Id) - and then Present (Find_Dispatching_Type (Def_Id)) - and then Is_Interface (Find_Dispatching_Type (Def_Id)) - then - null; + -- In DEC VMS, it seems that there is an undocumented feature that + -- any unrecognized convention is treated as the default, which for + -- us is convention C. It does not seem so terrible to do this + -- unconditionally, silently in the VMS case, and with a warning + -- in the non-VMS case. - -- Verify that the homonym is in the same declarative part (not - -- just the same scope). If the pragma comes from an aspect - -- specification we know that it is part of the declaration. + else + if Warn_On_Export_Import and not OpenVMS_On_Target then + Error_Msg_N + ("??unrecognized convention name, C assumed", + Get_Pragma_Arg (Arg1)); + end if; - elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) - and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux - and then not From_Aspect_Specification (N) - then - exit; + C := Convention_C; + end if; - else - Set_Imported (Def_Id); + Check_Optional_Identifier (Arg2, Name_Entity); + Check_Arg_Is_Local_Name (Arg2); - -- Reject an Import applied to an abstract subprogram + Id := Get_Pragma_Arg (Arg2); + Analyze (Id); - if Is_Subprogram (Def_Id) - and then Is_Abstract_Subprogram (Def_Id) - then - Error_Msg_Sloc := Sloc (Def_Id); - Error_Msg_NE - ("cannot import abstract subprogram& declared#", - Arg2, Def_Id); - end if; + if not Is_Entity_Name (Id) then + Error_Pragma_Arg ("entity name required", Arg2); + end if; - -- Special processing for Convention_Intrinsic + E := Entity (Id); - if C = Convention_Intrinsic then + -- Set entity to return - -- Link_Name argument not allowed for intrinsic + Ent := E; - Check_No_Link_Name; + -- Ada_Pass_By_Copy special checking - Set_Is_Intrinsic_Subprogram (Def_Id); + if C = Convention_Ada_Pass_By_Copy then + if not Is_First_Subtype (E) then + Error_Pragma_Arg + ("convention `Ada_Pass_By_Copy` only " + & "allowed for types", Arg2); + end if; - -- If no external name is present, then check that this - -- is a valid intrinsic subprogram. If an external name - -- is present, then this is handled by the back end. + if Is_By_Reference_Type (E) then + Error_Pragma_Arg + ("convention `Ada_Pass_By_Copy` not allowed for " + & "by-reference type", Arg1); + end if; + end if; - if No (Arg3) then - Check_Intrinsic_Subprogram - (Def_Id, Get_Pragma_Arg (Arg2)); - end if; - end if; + -- Ada_Pass_By_Reference special checking - -- All interfaced procedures need an external symbol created - -- for them since they are always referenced from another - -- object file. + if C = Convention_Ada_Pass_By_Reference then + if not Is_First_Subtype (E) then + Error_Pragma_Arg + ("convention `Ada_Pass_By_Reference` only " + & "allowed for types", Arg2); + end if; - Set_Is_Public (Def_Id); + if Is_By_Copy_Type (E) then + Error_Pragma_Arg + ("convention `Ada_Pass_By_Reference` not allowed for " + & "by-copy type", Arg1); + end if; + end if; - -- Verify that the subprogram does not have a completion - -- through a renaming declaration. For other completions the - -- pragma appears as a too late representation. + -- Go to renamed subprogram if present, since convention applies to + -- the actual renamed entity, not to the renaming entity. If the + -- subprogram is inherited, go to parent subprogram. - declare - Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); + if Is_Subprogram (E) + and then Present (Alias (E)) + then + if Nkind (Parent (Declaration_Node (E))) = + N_Subprogram_Renaming_Declaration + then + if Scope (E) /= Scope (Alias (E)) then + Error_Pragma_Ref + ("cannot apply pragma% to non-local entity&#", E); + end if; - begin - if Present (Decl) - and then Nkind (Decl) = N_Subprogram_Declaration - and then Present (Corresponding_Body (Decl)) - and then Nkind (Unit_Declaration_Node - (Corresponding_Body (Decl))) = - N_Subprogram_Renaming_Declaration - then - Error_Msg_Sloc := Sloc (Def_Id); - Error_Msg_NE - ("cannot import&, renaming already provided for " - & "declaration #", N, Def_Id); - end if; - end; + E := Alias (E); + + elsif Nkind_In (Parent (E), N_Full_Type_Declaration, + N_Private_Extension_Declaration) + and then Scope (E) = Scope (Alias (E)) + then + E := Alias (E); + + -- Return the parent subprogram the entity was inherited from + + Ent := E; + end if; + end if; + + -- Check that we are not applying this to a specless body + -- Relax this check if Relaxed_RM_Semantics to accomodate other Ada + -- compilers. + + if Is_Subprogram (E) + and then Nkind (Parent (Declaration_Node (E))) = N_Subprogram_Body + and then not Relaxed_RM_Semantics + then + Error_Pragma + ("pragma% requires separate spec and must come before body"); + end if; + + -- Check that we are not applying this to a named constant - Set_Has_Completion (Def_Id); - Process_Interface_Name (Def_Id, Arg3, Arg4); - end if; + if Ekind_In (E, E_Named_Integer, E_Named_Real) then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("cannot apply pragma% to named constant!", + Get_Pragma_Arg (Arg2)); + Error_Pragma_Arg + ("\supply appropriate type for&!", Arg2); + end if; - if Is_Compilation_Unit (Hom_Id) then + if Ekind (E) = E_Enumeration_Literal then + Error_Pragma ("enumeration literal not allowed for pragma%"); + end if; - -- Its possible homonyms are not affected by the pragma. - -- Such homonyms might be present in the context of other - -- units being compiled. + -- Check for rep item appearing too early or too late - exit; + if Etype (E) = Any_Type + or else Rep_Item_Too_Early (E, N) + then + raise Pragma_Exit; - elsif From_Aspect_Specification (N) then - exit; + elsif Present (Underlying_Type (E)) then + E := Underlying_Type (E); + end if; - else - Hom_Id := Homonym (Hom_Id); - end if; - end loop; + if Rep_Item_Too_Late (E, N) then + raise Pragma_Exit; + end if; - -- When the convention is Java or CIL, we also allow Import to be - -- given for packages, generic packages, exceptions, record - -- components, and access to subprograms. + if Has_Convention_Pragma (E) then + Diagnose_Multiple_Pragmas (E); - elsif (C = Convention_Java or else C = Convention_CIL) - and then - (Is_Package_Or_Generic_Package (Def_Id) - or else Ekind (Def_Id) = E_Exception - or else Ekind (Def_Id) = E_Access_Subprogram_Type - or else Nkind (Parent (Def_Id)) = N_Component_Declaration) + elsif Convention (E) = Convention_Protected + or else Ekind (Scope (E)) = E_Protected_Type then - Set_Imported (Def_Id); - Set_Is_Public (Def_Id); - Process_Interface_Name (Def_Id, Arg3, Arg4); + Error_Pragma_Arg + ("a protected operation cannot be given a different convention", + Arg2); + end if; - -- Import a CPP class + -- For Intrinsic, a subprogram is required - elsif C = Convention_CPP - and then (Is_Record_Type (Def_Id) - or else Ekind (Def_Id) = E_Incomplete_Type) + if C = Convention_Intrinsic + and then not Is_Subprogram (E) + and then not Is_Generic_Subprogram (E) then - if Ekind (Def_Id) = E_Incomplete_Type then - if Present (Full_View (Def_Id)) then - Def_Id := Full_View (Def_Id); + Error_Pragma_Arg + ("second argument of pragma% must be a subprogram", Arg2); + end if; - else - Error_Msg_N - ("cannot import 'C'P'P type before full declaration seen", - Get_Pragma_Arg (Arg2)); + -- Stdcall case - -- Although we have reported the error we decorate it as - -- CPP_Class to avoid reporting spurious errors + if C = Convention_Stdcall then - Set_Is_CPP_Class (Def_Id); - return; - end if; - end if; + -- A dispatching call is not allowed. A dispatching subprogram + -- cannot be used to interface to the Win32 API, so in fact this + -- check does not impose any effective restriction. - -- Types treated as CPP classes must be declared limited (note: - -- this used to be a warning but there is no real benefit to it - -- since we did effectively intend to treat the type as limited - -- anyway). + if Is_Dispatching_Operation (E) then - if not Is_Limited_Type (Def_Id) then - Error_Msg_N - ("imported 'C'P'P type must be limited", - Get_Pragma_Arg (Arg2)); - end if; + Error_Pragma + ("dispatching subprograms cannot use Stdcall convention"); - if Etype (Def_Id) /= Def_Id - and then not Is_CPP_Class (Root_Type (Def_Id)) - then - Error_Msg_N ("root type must be a 'C'P'P type", Arg1); - end if; + -- Subprogram is allowed, but not a generic subprogram, and not a + -- dispatching operation. - Set_Is_CPP_Class (Def_Id); + elsif not Is_Subprogram (E) + and then not Is_Generic_Subprogram (E) - -- Imported CPP types must not have discriminants (because C++ - -- classes do not have discriminants). + -- A variable is OK - if Has_Discriminants (Def_Id) then - Error_Msg_N - ("imported 'C'P'P type cannot have discriminants", - First (Discriminant_Specifications - (Declaration_Node (Def_Id)))); - end if; + and then Ekind (E) /= E_Variable - -- Check that components of imported CPP types do not have default - -- expressions. For private types this check is performed when the - -- full view is analyzed (see Process_Full_View). + -- An access to subprogram is also allowed - if not Is_Private_Type (Def_Id) then - Check_CPP_Type_Has_No_Defaults (Def_Id); + and then not + (Is_Access_Type (E) + and then Ekind (Designated_Type (E)) = E_Subprogram_Type) + then + Error_Pragma_Arg + ("second argument of pragma% must be subprogram (type)", + Arg2); end if; + end if; - elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then - Check_No_Link_Name; - Check_Arg_Count (3); - Check_Arg_Is_Static_Expression (Arg3, Standard_String); + if not Is_Subprogram (E) + and then not Is_Generic_Subprogram (E) + then + Set_Convention_From_Pragma (E); - Process_Import_Predefined_Type; + if Is_Type (E) then + Check_First_Subtype (Arg2); + Set_Convention_From_Pragma (Base_Type (E)); - else - Error_Pragma_Arg - ("second argument of pragma% must be object, subprogram " - & "or incomplete type", - Arg2); - end if; + -- For subprograms, we must set the convention on the + -- internally generated directly designated type as well. - -- If this pragma applies to a compilation unit, then the unit, which - -- is a subprogram, does not require (or allow) a body. We also do - -- not need to elaborate imported procedures. + if Ekind (E) = E_Access_Subprogram_Type then + Set_Convention_From_Pragma (Directly_Designated_Type (E)); + end if; + end if; - if Nkind (Parent (N)) = N_Compilation_Unit_Aux then - declare - Cunit : constant Node_Id := Parent (Parent (N)); - begin - Set_Body_Required (Cunit, False); - end; - end if; - end Process_Import_Or_Interface; + -- For the subprogram case, set proper convention for all homonyms + -- in same scope and the same declarative part, i.e. the same + -- compilation unit. - -------------------- - -- Process_Inline -- - -------------------- + else + Comp_Unit := Get_Source_Unit (E); + Set_Convention_From_Pragma (E); - procedure Process_Inline (Status : Inline_Status) is - Assoc : Node_Id; - Decl : Node_Id; - Subp_Id : Node_Id; - Subp : Entity_Id; - Applies : Boolean; + -- Treat a pragma Import as an implicit body, and pragma import + -- as implicit reference (for navigation in GPS). - Effective : Boolean := False; - -- Set True if inline has some effect, i.e. if there is at least one - -- subprogram set as inlined as a result of the use of the pragma. + if Prag_Id = Pragma_Import then + Generate_Reference (E, Id, 'b'); - procedure Make_Inline (Subp : Entity_Id); - -- Subp is the defining unit name of the subprogram declaration. Set - -- the flag, as well as the flag in the corresponding body, if there - -- is one present. + -- For exported entities we restrict the generation of references + -- to entities exported to foreign languages since entities + -- exported to Ada do not provide further information to GPS and + -- add undesired references to the output of the gnatxref tool. - procedure Set_Inline_Flags (Subp : Entity_Id); - -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also - -- Has_Pragma_Inline_Always for the Inline_Always case. + elsif Prag_Id = Pragma_Export + and then Convention (E) /= Convention_Ada + then + Generate_Reference (E, Id, 'i'); + end if; - function Inlining_Not_Possible (Subp : Entity_Id) return Boolean; - -- Returns True if it can be determined at this stage that inlining - -- is not possible, for example if the body is available and contains - -- exception handlers, we prevent inlining, since otherwise we can - -- get undefined symbols at link time. This function also emits a - -- warning if front-end inlining is enabled and the pragma appears - -- too late. - -- - -- ??? is business with link symbols still valid, or does it relate - -- to front end ZCX which is being phased out ??? + -- If the pragma comes from from an aspect, it only applies + -- to the given entity, not its homonyms. - --------------------------- - -- Inlining_Not_Possible -- - --------------------------- + if From_Aspect_Specification (N) then + return; + end if; - function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is - Decl : constant Node_Id := Unit_Declaration_Node (Subp); - Stats : Node_Id; + -- Otherwise Loop through the homonyms of the pragma argument's + -- entity, an apply convention to those in the current scope. - begin - if Nkind (Decl) = N_Subprogram_Body then - Stats := Handled_Statement_Sequence (Decl); - return Present (Exception_Handlers (Stats)) - or else Present (At_End_Proc (Stats)); + E1 := Ent; - elsif Nkind (Decl) = N_Subprogram_Declaration - and then Present (Corresponding_Body (Decl)) - then - if Front_End_Inlining - and then Analyzed (Corresponding_Body (Decl)) - then - Error_Msg_N ("pragma appears too late, ignored??", N); - return True; + loop + E1 := Homonym (E1); + exit when No (E1) or else Scope (E1) /= Current_Scope; - -- If the subprogram is a renaming as body, the body is just a - -- call to the renamed subprogram, and inlining is trivially - -- possible. + -- Do not set the pragma on inherited operations or on formal + -- subprograms. - elsif - Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = - N_Subprogram_Renaming_Declaration + if Comes_From_Source (E1) + and then Comp_Unit = Get_Source_Unit (E1) + and then not Is_Formal_Subprogram (E1) + and then Nkind (Original_Node (Parent (E1))) /= + N_Full_Type_Declaration then - return False; + if Present (Alias (E1)) + and then Scope (E1) /= Scope (Alias (E1)) + then + Error_Pragma_Ref + ("cannot apply pragma% to non-local entity& declared#", + E1); + end if; - else - Stats := - Handled_Statement_Sequence - (Unit_Declaration_Node (Corresponding_Body (Decl))); + Set_Convention_From_Pragma (E1); - return - Present (Exception_Handlers (Stats)) - or else Present (At_End_Proc (Stats)); + if Prag_Id = Pragma_Import then + Generate_Reference (E1, Id, 'b'); + end if; end if; + end loop; + end if; + end Process_Convention; - else - -- If body is not available, assume the best, the check is - -- performed again when compiling enclosing package bodies. - - return False; - end if; - end Inlining_Not_Possible; + ---------------------------------------- + -- Process_Disable_Enable_Atomic_Sync -- + ---------------------------------------- - ----------------- - -- Make_Inline -- - ----------------- + procedure Process_Disable_Enable_Atomic_Sync (Nam : Name_Id) is + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_At_Most_N_Arguments (1); - procedure Make_Inline (Subp : Entity_Id) is - Kind : constant Entity_Kind := Ekind (Subp); - Inner_Subp : Entity_Id := Subp; + -- Modeled internally as + -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity]) - begin - -- Ignore if bad type, avoid cascaded error + Rewrite (N, + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Loc, Nam), + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, Name_Atomic_Synchronization))))); - if Etype (Subp) = Any_Type then - Applies := True; - return; + if Present (Arg1) then + Append_To (Pragma_Argument_Associations (N), New_Copy (Arg1)); + end if; - -- Ignore if all inlining is suppressed + Analyze (N); + end Process_Disable_Enable_Atomic_Sync; - elsif Suppress_All_Inlining then - Applies := True; - return; + ----------------------------------------------------- + -- Process_Extended_Import_Export_Exception_Pragma -- + ----------------------------------------------------- - -- If inlining is not possible, for now do not treat as an error + procedure Process_Extended_Import_Export_Exception_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Form : Node_Id; + Arg_Code : Node_Id) + is + Def_Id : Entity_Id; + Code_Val : Uint; - elsif Status /= Suppressed - and then Inlining_Not_Possible (Subp) - then - Applies := True; - return; + begin + if not OpenVMS_On_Target then + Error_Pragma + ("??pragma% ignored (applies only to Open'V'M'S)"); + end if; - -- Here we have a candidate for inlining, but we must exclude - -- derived operations. Otherwise we would end up trying to inline - -- a phantom declaration, and the result would be to drag in a - -- body which has no direct inlining associated with it. That - -- would not only be inefficient but would also result in the - -- backend doing cross-unit inlining in cases where it was - -- definitely inappropriate to do so. + Process_Extended_Import_Export_Internal_Arg (Arg_Internal); + Def_Id := Entity (Arg_Internal); - -- However, a simple Comes_From_Source test is insufficient, since - -- we do want to allow inlining of generic instances which also do - -- not come from source. We also need to recognize specs generated - -- by the front-end for bodies that carry the pragma. Finally, - -- predefined operators do not come from source but are not - -- inlineable either. + if Ekind (Def_Id) /= E_Exception then + Error_Pragma_Arg + ("pragma% must refer to declared exception", Arg_Internal); + end if; - elsif Is_Generic_Instance (Subp) - or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration - then - null; + Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); - elsif not Comes_From_Source (Subp) - and then Scope (Subp) /= Standard_Standard - then - Applies := True; - return; - end if; + if Present (Arg_Form) then + Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS); + end if; - -- The referenced entity must either be the enclosing entity, or - -- an entity declared within the current open scope. + if Present (Arg_Form) + and then Chars (Arg_Form) = Name_Ada + then + null; + else + Set_Is_VMS_Exception (Def_Id); + Set_Exception_Code (Def_Id, No_Uint); + end if; - if Present (Scope (Subp)) - and then Scope (Subp) /= Current_Scope - and then Subp /= Current_Scope - then + if Present (Arg_Code) then + if not Is_VMS_Exception (Def_Id) then Error_Pragma_Arg - ("argument of% must be entity in current scope", Assoc); - return; + ("Code option for pragma% not allowed for Ada case", + Arg_Code); end if; - -- Processing for procedure, operator or function. If subprogram - -- is aliased (as for an instance) indicate that the renamed - -- entity (if declared in the same unit) is inlined. + Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer); + Code_Val := Expr_Value (Arg_Code); - if Is_Subprogram (Subp) then - Inner_Subp := Ultimate_Alias (Inner_Subp); + if not UI_Is_In_Int_Range (Code_Val) then + Error_Pragma_Arg + ("Code option for pragma% must be in 32-bit range", + Arg_Code); - if In_Same_Source_Unit (Subp, Inner_Subp) then - Set_Inline_Flags (Inner_Subp); + else + Set_Exception_Code (Def_Id, Code_Val); + end if; + end if; + end Process_Extended_Import_Export_Exception_Pragma; - Decl := Parent (Parent (Inner_Subp)); + ------------------------------------------------- + -- Process_Extended_Import_Export_Internal_Arg -- + ------------------------------------------------- - if Nkind (Decl) = N_Subprogram_Declaration - and then Present (Corresponding_Body (Decl)) - then - Set_Inline_Flags (Corresponding_Body (Decl)); + procedure Process_Extended_Import_Export_Internal_Arg + (Arg_Internal : Node_Id := Empty) + is + begin + if No (Arg_Internal) then + Error_Pragma ("Internal parameter required for pragma%"); + end if; - elsif Is_Generic_Instance (Subp) then + if Nkind (Arg_Internal) = N_Identifier then + null; - -- Indicate that the body needs to be created for - -- inlining subsequent calls. The instantiation node - -- follows the declaration of the wrapper package - -- created for it. + elsif Nkind (Arg_Internal) = N_Operator_Symbol + and then (Prag_Id = Pragma_Import_Function + or else + Prag_Id = Pragma_Export_Function) + then + null; - if Scope (Subp) /= Standard_Standard - and then - Need_Subprogram_Instance_Body - (Next (Unit_Declaration_Node (Scope (Alias (Subp)))), - Subp) - then - null; - end if; + else + Error_Pragma_Arg + ("wrong form for Internal parameter for pragma%", Arg_Internal); + end if; - -- Inline is a program unit pragma (RM 10.1.5) and cannot - -- appear in a formal part to apply to a formal subprogram. - -- Do not apply check within an instance or a formal package - -- the test will have been applied to the original generic. + Check_Arg_Is_Local_Name (Arg_Internal); + end Process_Extended_Import_Export_Internal_Arg; - elsif Nkind (Decl) in N_Formal_Subprogram_Declaration - and then List_Containing (Decl) = List_Containing (N) - and then not In_Instance - then - Error_Msg_N - ("Inline cannot apply to a formal subprogram", N); + -------------------------------------------------- + -- Process_Extended_Import_Export_Object_Pragma -- + -------------------------------------------------- - -- If Subp is a renaming, it is the renamed entity that - -- will appear in any call, and be inlined. However, for - -- ASIS uses it is convenient to indicate that the renaming - -- itself is an inlined subprogram, so that some gnatcheck - -- rules can be applied in the absence of expansion. + procedure Process_Extended_Import_Export_Object_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Size : Node_Id) + is + Def_Id : Entity_Id; - elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then - Set_Inline_Flags (Subp); - end if; - end if; + begin + Process_Extended_Import_Export_Internal_Arg (Arg_Internal); + Def_Id := Entity (Arg_Internal); - Applies := True; + if not Ekind_In (Def_Id, E_Constant, E_Variable) then + Error_Pragma_Arg + ("pragma% must designate an object", Arg_Internal); + end if; - -- For a generic subprogram set flag as well, for use at the point - -- of instantiation, to determine whether the body should be - -- generated. + if Has_Rep_Pragma (Def_Id, Name_Common_Object) + or else + Has_Rep_Pragma (Def_Id, Name_Psect_Object) + then + Error_Pragma_Arg + ("previous Common/Psect_Object applies, pragma % not permitted", + Arg_Internal); + end if; - elsif Is_Generic_Subprogram (Subp) then - Set_Inline_Flags (Subp); - Applies := True; + if Rep_Item_Too_Late (Def_Id, N) then + raise Pragma_Exit; + end if; - -- Literals are by definition inlined + Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); - elsif Kind = E_Enumeration_Literal then - null; + if Present (Arg_Size) then + Check_Arg_Is_External_Name (Arg_Size); + end if; - -- Anything else is an error + -- Export_Object case - else + if Prag_Id = Pragma_Export_Object then + if not Is_Library_Level_Entity (Def_Id) then Error_Pragma_Arg - ("expect subprogram name for pragma%", Assoc); + ("argument for pragma% must be library level entity", + Arg_Internal); end if; - end Make_Inline; - ---------------------- - -- Set_Inline_Flags -- - ---------------------- - - procedure Set_Inline_Flags (Subp : Entity_Id) is - begin - -- First set the Has_Pragma_XXX flags and issue the appropriate - -- errors and warnings for suspicious combinations. + if Ekind (Current_Scope) = E_Generic_Package then + Error_Pragma ("pragma& cannot appear in a generic unit"); + end if; - if Prag_Id = Pragma_No_Inline then - if Has_Pragma_Inline_Always (Subp) then - Error_Msg_N - ("Inline_Always and No_Inline are mutually exclusive", N); - elsif Has_Pragma_Inline (Subp) then - Error_Msg_NE - ("Inline and No_Inline both specified for& ??", - N, Entity (Subp_Id)); - end if; + if not Size_Known_At_Compile_Time (Etype (Def_Id)) then + Error_Pragma_Arg + ("exported object must have compile time known size", + Arg_Internal); + end if; - Set_Has_Pragma_No_Inline (Subp); + if Warn_On_Export_Import and then Is_Exported (Def_Id) then + Error_Msg_N ("??duplicate Export_Object pragma", N); else - if Prag_Id = Pragma_Inline_Always then - if Has_Pragma_No_Inline (Subp) then - Error_Msg_N - ("Inline_Always and No_Inline are mutually exclusive", - N); - end if; - - Set_Has_Pragma_Inline_Always (Subp); - else - if Has_Pragma_No_Inline (Subp) then - Error_Msg_NE - ("Inline and No_Inline both specified for& ??", - N, Entity (Subp_Id)); - end if; - end if; - - if not Has_Pragma_Inline (Subp) then - Set_Has_Pragma_Inline (Subp); - Effective := True; - end if; + Set_Exported (Def_Id, Arg_Internal); end if; - -- Then adjust the Is_Inlined flag. It can never be set if the - -- subprogram is subject to pragma No_Inline. + -- Import_Object case - case Status is - when Suppressed => - Set_Is_Inlined (Subp, False); - when Disabled => - null; - when Enabled => - if not Has_Pragma_No_Inline (Subp) then - Set_Is_Inlined (Subp, True); - end if; - end case; - end Set_Inline_Flags; + else + if Is_Concurrent_Type (Etype (Def_Id)) then + Error_Pragma_Arg + ("cannot use pragma% for task/protected object", + Arg_Internal); + end if; - -- Start of processing for Process_Inline + if Ekind (Def_Id) = E_Constant then + Error_Pragma_Arg + ("cannot import a constant", Arg_Internal); + end if; - begin - Check_No_Identifiers; - Check_At_Least_N_Arguments (1); + if Warn_On_Export_Import + and then Has_Discriminants (Etype (Def_Id)) + then + Error_Msg_N + ("imported value must be initialized??", Arg_Internal); + end if; - if Status = Enabled then - Inline_Processing_Required := True; - end if; + if Warn_On_Export_Import + and then Is_Access_Type (Etype (Def_Id)) + then + Error_Pragma_Arg + ("cannot import object of an access type??", Arg_Internal); + end if; - Assoc := Arg1; - while Present (Assoc) loop - Subp_Id := Get_Pragma_Arg (Assoc); - Analyze (Subp_Id); - Applies := False; + if Warn_On_Export_Import + and then Is_Imported (Def_Id) + then + Error_Msg_N ("??duplicate Import_Object pragma", N); - if Is_Entity_Name (Subp_Id) then - Subp := Entity (Subp_Id); + -- Check for explicit initialization present. Note that an + -- initialization generated by the code generator, e.g. for an + -- access type, does not count here. - if Subp = Any_Id then + elsif Present (Expression (Parent (Def_Id))) + and then + Comes_From_Source + (Original_Node (Expression (Parent (Def_Id)))) + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Pragma_Arg + ("imported entities cannot be initialized (RM B.1(24))", + "\no initialization allowed for & declared#", Arg1); + else + Set_Imported (Def_Id); + Note_Possible_Modification (Arg_Internal, Sure => False); + end if; + end if; + end Process_Extended_Import_Export_Object_Pragma; - -- If previous error, avoid cascaded errors + ------------------------------------------------------ + -- Process_Extended_Import_Export_Subprogram_Pragma -- + ------------------------------------------------------ - Check_Error_Detected; - Applies := True; - Effective := True; + procedure Process_Extended_Import_Export_Subprogram_Pragma + (Arg_Internal : Node_Id; + Arg_External : Node_Id; + Arg_Parameter_Types : Node_Id; + Arg_Result_Type : Node_Id := Empty; + Arg_Mechanism : Node_Id; + Arg_Result_Mechanism : Node_Id := Empty; + Arg_First_Optional_Parameter : Node_Id := Empty) + is + Ent : Entity_Id; + Def_Id : Entity_Id; + Hom_Id : Entity_Id; + Formal : Entity_Id; + Ambiguous : Boolean; + Match : Boolean; + Dval : Node_Id; - else - Make_Inline (Subp); + function Same_Base_Type + (Ptype : Node_Id; + Formal : Entity_Id) return Boolean; + -- Determines if Ptype references the type of Formal. Note that only + -- the base types need to match according to the spec. Ptype here is + -- the argument from the pragma, which is either a type name, or an + -- access attribute. - -- For the pragma case, climb homonym chain. This is - -- what implements allowing the pragma in the renaming - -- case, with the result applying to the ancestors, and - -- also allows Inline to apply to all previous homonyms. + -------------------- + -- Same_Base_Type -- + -------------------- - if not From_Aspect_Specification (N) then - while Present (Homonym (Subp)) - and then Scope (Homonym (Subp)) = Current_Scope - loop - Make_Inline (Homonym (Subp)); - Subp := Homonym (Subp); - end loop; - end if; - end if; - end if; + function Same_Base_Type + (Ptype : Node_Id; + Formal : Entity_Id) return Boolean + is + Ftyp : constant Entity_Id := Base_Type (Etype (Formal)); + Pref : Node_Id; - if not Applies then - Error_Pragma_Arg - ("inappropriate argument for pragma%", Assoc); + begin + -- Case where pragma argument is typ'Access - elsif not Effective - and then Warn_On_Redundant_Constructs - and then not (Status = Suppressed or else Suppress_All_Inlining) + if Nkind (Ptype) = N_Attribute_Reference + and then Attribute_Name (Ptype) = Name_Access then - if Inlining_Not_Possible (Subp) then - Error_Msg_NE - ("pragma Inline for& is ignored?r?", - N, Entity (Subp_Id)); - else - Error_Msg_NE - ("pragma Inline for& is redundant?r?", - N, Entity (Subp_Id)); + Pref := Prefix (Ptype); + Find_Type (Pref); + + if not Is_Entity_Name (Pref) + or else Entity (Pref) = Any_Type + then + raise Pragma_Exit; end if; - end if; - Next (Assoc); - end loop; - end Process_Inline; + -- We have a match if the corresponding argument is of an + -- anonymous access type, and its designated type matches the + -- type of the prefix of the access attribute - ---------------------------- - -- Process_Interface_Name -- - ---------------------------- + return Ekind (Ftyp) = E_Anonymous_Access_Type + and then Base_Type (Entity (Pref)) = + Base_Type (Etype (Designated_Type (Ftyp))); - procedure Process_Interface_Name - (Subprogram_Def : Entity_Id; - Ext_Arg : Node_Id; - Link_Arg : Node_Id) - is - Ext_Nam : Node_Id; - Link_Nam : Node_Id; - String_Val : String_Id; + -- Case where pragma argument is a type name - procedure Check_Form_Of_Interface_Name - (SN : Node_Id; - Ext_Name_Case : Boolean); - -- SN is a string literal node for an interface name. This routine - -- performs some minimal checks that the name is reasonable. In - -- particular that no spaces or other obviously incorrect characters - -- appear. This is only a warning, since any characters are allowed. - -- Ext_Name_Case is True for an External_Name, False for a Link_Name. + else + Find_Type (Ptype); - ---------------------------------- - -- Check_Form_Of_Interface_Name -- - ---------------------------------- + if not Is_Entity_Name (Ptype) + or else Entity (Ptype) = Any_Type + then + raise Pragma_Exit; + end if; - procedure Check_Form_Of_Interface_Name - (SN : Node_Id; - Ext_Name_Case : Boolean) - is - S : constant String_Id := Strval (Expr_Value_S (SN)); - SL : constant Nat := String_Length (S); - C : Char_Code; + -- We have a match if the corresponding argument is of the type + -- given in the pragma (comparing base types) - begin - if SL = 0 then - Error_Msg_N ("interface name cannot be null string", SN); + return Base_Type (Entity (Ptype)) = Ftyp; end if; + end Same_Base_Type; - for J in 1 .. SL loop - C := Get_String_Char (S, J); + -- Start of processing for + -- Process_Extended_Import_Export_Subprogram_Pragma - -- Look for dubious character and issue unconditional warning. - -- Definitely dubious if not in character range. + begin + Process_Extended_Import_Export_Internal_Arg (Arg_Internal); + Ent := Empty; + Ambiguous := False; - if not In_Character_Range (C) + -- Loop through homonyms (overloadings) of the entity - -- For all cases except CLI target, - -- commas, spaces and slashes are dubious (in CLI, we use - -- commas and backslashes in external names to specify - -- assembly version and public key, while slashes and spaces - -- can be used in names to mark nested classes and - -- valuetypes). + Hom_Id := Entity (Arg_Internal); + while Present (Hom_Id) loop + Def_Id := Get_Base_Subprogram (Hom_Id); - or else ((not Ext_Name_Case or else VM_Target /= CLI_Target) - and then (Get_Character (C) = ',' - or else - Get_Character (C) = '\')) - or else (VM_Target /= CLI_Target - and then (Get_Character (C) = ' ' - or else - Get_Character (C) = '/')) + -- We need a subprogram in the current scope + + if not Is_Subprogram (Def_Id) + or else Scope (Def_Id) /= Current_Scope + then + null; + + else + Match := True; + + -- Pragma cannot apply to subprogram body + + if Is_Subprogram (Def_Id) + and then Nkind (Parent (Declaration_Node (Def_Id))) = + N_Subprogram_Body then - Error_Msg - ("??interface name contains illegal character", - Sloc (SN) + Source_Ptr (J)); + Error_Pragma + ("pragma% requires separate spec" + & " and must come before body"); end if; - end loop; - end Check_Form_Of_Interface_Name; - -- Start of processing for Process_Interface_Name + -- Test result type if given, note that the result type + -- parameter can only be present for the function cases. - begin - if No (Link_Arg) then - if No (Ext_Arg) then - if VM_Target = CLI_Target - and then Ekind (Subprogram_Def) = E_Package - and then Nkind (Parent (Subprogram_Def)) = - N_Package_Specification - and then Present (Generic_Parent (Parent (Subprogram_Def))) + if Present (Arg_Result_Type) + and then not Same_Base_Type (Arg_Result_Type, Def_Id) then - Set_Interface_Name - (Subprogram_Def, - Interface_Name - (Generic_Parent (Parent (Subprogram_Def)))); - end if; + Match := False; - return; + elsif Etype (Def_Id) /= Standard_Void_Type + and then + Nam_In (Pname, Name_Export_Procedure, Name_Import_Procedure) + then + Match := False; - elsif Chars (Ext_Arg) = Name_Link_Name then - Ext_Nam := Empty; - Link_Nam := Expression (Ext_Arg); + -- Test parameter types if given. Note that this parameter + -- has not been analyzed (and must not be, since it is + -- semantic nonsense), so we get it as the parser left it. - else - Check_Optional_Identifier (Ext_Arg, Name_External_Name); - Ext_Nam := Expression (Ext_Arg); - Link_Nam := Empty; - end if; + elsif Present (Arg_Parameter_Types) then + Check_Matching_Types : declare + Formal : Entity_Id; + Ptype : Node_Id; - else - Check_Optional_Identifier (Ext_Arg, Name_External_Name); - Check_Optional_Identifier (Link_Arg, Name_Link_Name); - Ext_Nam := Expression (Ext_Arg); - Link_Nam := Expression (Link_Arg); - end if; + begin + Formal := First_Formal (Def_Id); - -- Check expressions for external name and link name are static + if Nkind (Arg_Parameter_Types) = N_Null then + if Present (Formal) then + Match := False; + end if; - if Present (Ext_Nam) then - Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String); - Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True); + -- A list of one type, e.g. (List) is parsed as + -- a parenthesized expression. - -- Verify that external name is not the name of a local entity, - -- which would hide the imported one and could lead to run-time - -- surprises. The problem can only arise for entities declared in - -- a package body (otherwise the external name is fully qualified - -- and will not conflict). + elsif Nkind (Arg_Parameter_Types) /= N_Aggregate + and then Paren_Count (Arg_Parameter_Types) = 1 + then + if No (Formal) + or else Present (Next_Formal (Formal)) + then + Match := False; + else + Match := + Same_Base_Type (Arg_Parameter_Types, Formal); + end if; - declare - Nam : Name_Id; - E : Entity_Id; - Par : Node_Id; + -- A list of more than one type is parsed as a aggregate - begin - if Prag_Id = Pragma_Import then - String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam))); - Nam := Name_Find; - E := Entity_Id (Get_Name_Table_Info (Nam)); + elsif Nkind (Arg_Parameter_Types) = N_Aggregate + and then Paren_Count (Arg_Parameter_Types) = 0 + then + Ptype := First (Expressions (Arg_Parameter_Types)); + while Present (Ptype) or else Present (Formal) loop + if No (Ptype) + or else No (Formal) + or else not Same_Base_Type (Ptype, Formal) + then + Match := False; + exit; + else + Next_Formal (Formal); + Next (Ptype); + end if; + end loop; - if Nam /= Chars (Subprogram_Def) - and then Present (E) - and then not Is_Overloadable (E) - and then Is_Immediately_Visible (E) - and then not Is_Imported (E) - and then Ekind (Scope (E)) = E_Package - then - Par := Parent (E); - while Present (Par) loop - if Nkind (Par) = N_Package_Body then - Error_Msg_Sloc := Sloc (E); - Error_Msg_NE - ("imported entity is hidden by & declared#", - Ext_Arg, E); - exit; - end if; + -- Anything else is of the wrong form - Par := Parent (Par); - end loop; + else + Error_Pragma_Arg + ("wrong form for Parameter_Types parameter", + Arg_Parameter_Types); + end if; + end Check_Matching_Types; + end if; + + -- Match is now False if the entry we found did not match + -- either a supplied Parameter_Types or Result_Types argument + + if Match then + if No (Ent) then + Ent := Def_Id; + + -- Ambiguous case, the flag Ambiguous shows if we already + -- detected this and output the initial messages. + + else + if not Ambiguous then + Ambiguous := True; + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("pragma% does not uniquely identify subprogram!", + N); + Error_Msg_Sloc := Sloc (Ent); + Error_Msg_N ("matching subprogram #!", N); + Ent := Empty; + end if; + + Error_Msg_Sloc := Sloc (Def_Id); + Error_Msg_N ("matching subprogram #!", N); end if; end if; - end; - end if; + end if; - if Present (Link_Nam) then - Check_Arg_Is_Static_Expression (Link_Nam, Standard_String); - Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False); - end if; + Hom_Id := Homonym (Hom_Id); + end loop; - -- If there is no link name, just set the external name + -- See if we found an entry - if No (Link_Nam) then - Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)); + if No (Ent) then + if not Ambiguous then + if Is_Generic_Subprogram (Entity (Arg_Internal)) then + Error_Pragma + ("pragma% cannot be given for generic subprogram"); + else + Error_Pragma + ("pragma% does not identify local subprogram"); + end if; + end if; - -- For the Link_Name case, the given literal is preceded by an - -- asterisk, which indicates to GCC that the given name should be - -- taken literally, and in particular that no prepending of - -- underlines should occur, even in systems where this is the - -- normal default. + return; + end if; + + -- Import pragmas must be for imported entities + + if Prag_Id = Pragma_Import_Function + or else + Prag_Id = Pragma_Import_Procedure + or else + Prag_Id = Pragma_Import_Valued_Procedure + then + if not Is_Imported (Ent) then + Error_Pragma + ("pragma Import or Interface must precede pragma%"); + end if; - else - Start_String; + -- Here we have the Export case which can set the entity as exported - if VM_Target = No_VM then - Store_String_Char (Get_Char_Code ('*')); - end if; + -- But does not do so if the specified external name is null, since + -- that is taken as a signal in DEC Ada 83 (with which we want to be + -- compatible) to request no external name. - String_Val := Strval (Expr_Value_S (Link_Nam)); - Store_String_Chars (String_Val); - Link_Nam := - Make_String_Literal (Sloc (Link_Nam), - Strval => End_String); - end if; + elsif Nkind (Arg_External) = N_String_Literal + and then String_Length (Strval (Arg_External)) = 0 + then + null; - -- Set the interface name. If the entity is a generic instance, use - -- its alias, which is the callable entity. + -- In all other cases, set entity as exported - if Is_Generic_Instance (Subprogram_Def) then - Set_Encoded_Interface_Name - (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam); else - Set_Encoded_Interface_Name - (Get_Base_Subprogram (Subprogram_Def), Link_Nam); + Set_Exported (Ent, Arg_Internal); end if; - -- We allow duplicated export names in CIL/Java, as they are always - -- enclosed in a namespace that differentiates them, and overloaded - -- entities are supported by the VM. + -- Special processing for Valued_Procedure cases - if Convention (Subprogram_Def) /= Convention_CIL - and then - Convention (Subprogram_Def) /= Convention_Java + if Prag_Id = Pragma_Import_Valued_Procedure + or else + Prag_Id = Pragma_Export_Valued_Procedure then - Check_Duplicated_Export_Name (Link_Nam); - end if; - end Process_Interface_Name; + Formal := First_Formal (Ent); - ----------------------------------------- - -- Process_Interrupt_Or_Attach_Handler -- - ----------------------------------------- + if No (Formal) then + Error_Pragma ("at least one parameter required for pragma%"); - procedure Process_Interrupt_Or_Attach_Handler is - Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); - Handler_Proc : constant Entity_Id := Entity (Arg1_X); - Proc_Scope : constant Entity_Id := Scope (Handler_Proc); + elsif Ekind (Formal) /= E_Out_Parameter then + Error_Pragma ("first parameter must have mode out for pragma%"); - begin - Set_Is_Interrupt_Handler (Handler_Proc); + else + Set_Is_Valued_Procedure (Ent); + end if; + end if; - -- If the pragma is not associated with a handler procedure within a - -- protected type, then it must be for a nonprotected procedure for - -- the AAMP target, in which case we don't associate a representation - -- item with the procedure's scope. + Set_Extended_Import_Export_External_Name (Ent, Arg_External); - if Ekind (Proc_Scope) = E_Protected_Type then - if Prag_Id = Pragma_Interrupt_Handler - or else - Prag_Id = Pragma_Attach_Handler - then - Record_Rep_Item (Proc_Scope, N); - end if; + -- Process Result_Mechanism argument if present. We have already + -- checked that this is only allowed for the function case. + + if Present (Arg_Result_Mechanism) then + Set_Mechanism_Value (Ent, Arg_Result_Mechanism); end if; - end Process_Interrupt_Or_Attach_Handler; - -------------------------------------------------- - -- Process_Restrictions_Or_Restriction_Warnings -- - -------------------------------------------------- + -- Process Mechanism parameter if present. Note that this parameter + -- is not analyzed, and must not be analyzed since it is semantic + -- nonsense, so we get it in exactly as the parser left it. - -- Note: some of the simple identifier cases were handled in par-prag, - -- but it is harmless (and more straightforward) to simply handle all - -- cases here, even if it means we repeat a bit of work in some cases. + if Present (Arg_Mechanism) then + declare + Formal : Entity_Id; + Massoc : Node_Id; + Mname : Node_Id; + Choice : Node_Id; - procedure Process_Restrictions_Or_Restriction_Warnings - (Warn : Boolean) - is - Arg : Node_Id; - R_Id : Restriction_Id; - Id : Name_Id; - Expr : Node_Id; - Val : Uint; + begin + -- A single mechanism association without a formal parameter + -- name is parsed as a parenthesized expression. All other + -- cases are parsed as aggregates, so we rewrite the single + -- parameter case as an aggregate for consistency. - procedure Check_Unit_Name (N : Node_Id); - -- Checks unit name parameter for No_Dependence. Returns if it has - -- an appropriate form, otherwise raises pragma argument error. + if Nkind (Arg_Mechanism) /= N_Aggregate + and then Paren_Count (Arg_Mechanism) = 1 + then + Rewrite (Arg_Mechanism, + Make_Aggregate (Sloc (Arg_Mechanism), + Expressions => New_List ( + Relocate_Node (Arg_Mechanism)))); + end if; - --------------------- - -- Check_Unit_Name -- - --------------------- + -- Case of only mechanism name given, applies to all formals - procedure Check_Unit_Name (N : Node_Id) is - begin - if Nkind (N) = N_Selected_Component then - Check_Unit_Name (Prefix (N)); - Check_Unit_Name (Selector_Name (N)); + if Nkind (Arg_Mechanism) /= N_Aggregate then + Formal := First_Formal (Ent); + while Present (Formal) loop + Set_Mechanism_Value (Formal, Arg_Mechanism); + Next_Formal (Formal); + end loop; - elsif Nkind (N) = N_Identifier then - return; + -- Case of list of mechanism associations given - else - Error_Pragma_Arg - ("wrong form for unit name for No_Dependence", N); - end if; - end Check_Unit_Name; + else + if Null_Record_Present (Arg_Mechanism) then + Error_Pragma_Arg + ("inappropriate form for Mechanism parameter", + Arg_Mechanism); + end if; - -- Start of processing for Process_Restrictions_Or_Restriction_Warnings + -- Deal with positional ones first - begin - -- Ignore all Restrictions pragma in CodePeer mode + Formal := First_Formal (Ent); - if CodePeer_Mode then - return; - end if; + if Present (Expressions (Arg_Mechanism)) then + Mname := First (Expressions (Arg_Mechanism)); + while Present (Mname) loop + if No (Formal) then + Error_Pragma_Arg + ("too many mechanism associations", Mname); + end if; - Check_Ada_83_Warning; - Check_At_Least_N_Arguments (1); - Check_Valid_Configuration_Pragma; + Set_Mechanism_Value (Formal, Mname); + Next_Formal (Formal); + Next (Mname); + end loop; + end if; - Arg := Arg1; - while Present (Arg) loop - Id := Chars (Arg); - Expr := Get_Pragma_Arg (Arg); + -- Deal with named entries - -- Case of no restriction identifier present + if Present (Component_Associations (Arg_Mechanism)) then + Massoc := First (Component_Associations (Arg_Mechanism)); + while Present (Massoc) loop + Choice := First (Choices (Massoc)); - if Id = No_Name then - if Nkind (Expr) /= N_Identifier then - Error_Pragma_Arg - ("invalid form for restriction", Arg); - end if; + if Nkind (Choice) /= N_Identifier + or else Present (Next (Choice)) + then + Error_Pragma_Arg + ("incorrect form for mechanism association", + Massoc); + end if; - R_Id := - Get_Restriction_Id - (Process_Restriction_Synonyms (Expr)); + Formal := First_Formal (Ent); + loop + if No (Formal) then + Error_Pragma_Arg + ("parameter name & not present", Choice); + end if; - if R_Id not in All_Boolean_Restrictions then - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("invalid restriction identifier&", Get_Pragma_Arg (Arg)); + if Chars (Choice) = Chars (Formal) then + Set_Mechanism_Value + (Formal, Expression (Massoc)); - -- Check for possible misspelling + -- Set entity on identifier (needed by ASIS) - for J in Restriction_Id loop - declare - Rnm : constant String := Restriction_Id'Image (J); + Set_Entity (Choice, Formal); - begin - Name_Buffer (1 .. Rnm'Length) := Rnm; - Name_Len := Rnm'Length; - Set_Casing (All_Lower_Case); + exit; + end if; - if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then - Set_Casing - (Identifier_Casing (Current_Source_File)); - Error_Msg_String (1 .. Rnm'Length) := - Name_Buffer (1 .. Name_Len); - Error_Msg_Strlen := Rnm'Length; - Error_Msg_N -- CODEFIX - ("\possible misspelling of ""~""", - Get_Pragma_Arg (Arg)); - exit; - end if; - end; - end loop; + Next_Formal (Formal); + end loop; + + Next (Massoc); + end loop; + end if; + end if; + end; + end if; + + -- Process First_Optional_Parameter argument if present. We have + -- already checked that this is only allowed for the Import case. + + if Present (Arg_First_Optional_Parameter) then + if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then + Error_Pragma_Arg + ("first optional parameter must be formal parameter name", + Arg_First_Optional_Parameter); + end if; - raise Pragma_Exit; + Formal := First_Formal (Ent); + loop + if No (Formal) then + Error_Pragma_Arg + ("specified formal parameter& not found", + Arg_First_Optional_Parameter); end if; - if Implementation_Restriction (R_Id) then - Check_Restriction (No_Implementation_Restrictions, Arg); - end if; + exit when Chars (Formal) = + Chars (Arg_First_Optional_Parameter); - -- Special processing for No_Elaboration_Code restriction + Next_Formal (Formal); + end loop; - if R_Id = No_Elaboration_Code then + Set_First_Optional_Parameter (Ent, Formal); - -- Restriction is only recognized within a configuration - -- pragma file, or within a unit of the main extended - -- program. Note: the test for Main_Unit is needed to - -- properly include the case of configuration pragma files. + -- Check specified and all remaining formals have right form - if not (Current_Sem_Unit = Main_Unit - or else In_Extended_Main_Source_Unit (N)) - then - return; + while Present (Formal) loop + if Ekind (Formal) /= E_In_Parameter then + Error_Msg_NE + ("optional formal& is not of mode in!", + Arg_First_Optional_Parameter, Formal); - -- Don't allow in a subunit unless already specified in - -- body or spec. + else + Dval := Default_Value (Formal); - elsif Nkind (Parent (N)) = N_Compilation_Unit - and then Nkind (Unit (Parent (N))) = N_Subunit - and then not Restriction_Active (No_Elaboration_Code) - then - Error_Msg_N - ("invalid specification of ""No_Elaboration_Code""", - N); - Error_Msg_N - ("\restriction cannot be specified in a subunit", N); - Error_Msg_N - ("\unless also specified in body or spec", N); - return; + if No (Dval) then + Error_Msg_NE + ("optional formal& does not have default value!", + Arg_First_Optional_Parameter, Formal); - -- If we have a No_Elaboration_Code pragma that we - -- accept, then it needs to be added to the configuration - -- restrcition set so that we get proper application to - -- other units in the main extended source as required. + elsif Compile_Time_Known_Value_Or_Aggr (Dval) then + null; else - Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); + Error_Msg_FE + ("default value for optional formal& is non-static!", + Arg_First_Optional_Parameter, Formal); end if; end if; - -- If this is a warning, then set the warning unless we already - -- have a real restriction active (we never want a warning to - -- override a real restriction). + Set_Is_Optional_Parameter (Formal); + Next_Formal (Formal); + end loop; + end if; + end Process_Extended_Import_Export_Subprogram_Pragma; - if Warn then - if not Restriction_Active (R_Id) then - Set_Restriction (R_Id, N); - Restriction_Warnings (R_Id) := True; - end if; + -------------------------- + -- Process_Generic_List -- + -------------------------- - -- If real restriction case, then set it and make sure that the - -- restriction warning flag is off, since a real restriction - -- always overrides a warning. + procedure Process_Generic_List is + Arg : Node_Id; + Exp : Node_Id; - else - Set_Restriction (R_Id, N); - Restriction_Warnings (R_Id) := False; - end if; + begin + Check_No_Identifiers; + Check_At_Least_N_Arguments (1); - -- Check for obsolescent restrictions in Ada 2005 mode + Arg := Arg1; + while Present (Arg) loop + Exp := Get_Pragma_Arg (Arg); + Analyze (Exp); - if not Warn - and then Ada_Version >= Ada_2005 - and then (R_Id = No_Asynchronous_Control - or else - R_Id = No_Unchecked_Deallocation - or else - R_Id = No_Unchecked_Conversion) - then - Check_Restriction (No_Obsolescent_Features, N); - end if; + if not Is_Entity_Name (Exp) + or else + (not Is_Generic_Instance (Entity (Exp)) + and then + not Is_Generic_Unit (Entity (Exp))) + then + Error_Pragma_Arg + ("pragma% argument must be name of generic unit/instance", + Arg); + end if; - -- A very special case that must be processed here: pragma - -- Restrictions (No_Exceptions) turns off all run-time - -- checking. This is a bit dubious in terms of the formal - -- language definition, but it is what is intended by RM - -- H.4(12). Restriction_Warnings never affects generated code - -- so this is done only in the real restriction case. + Next (Arg); + end loop; + end Process_Generic_List; - -- Atomic_Synchronization is not a real check, so it is not - -- affected by this processing). + ------------------------------------ + -- Process_Import_Predefined_Type -- + ------------------------------------ - if R_Id = No_Exceptions and then not Warn then - for J in Scope_Suppress.Suppress'Range loop - if J /= Atomic_Synchronization then - Scope_Suppress.Suppress (J) := True; - end if; - end loop; - end if; + procedure Process_Import_Predefined_Type is + Loc : constant Source_Ptr := Sloc (N); + Elmt : Elmt_Id; + Ftyp : Node_Id := Empty; + Decl : Node_Id; + Def : Node_Id; + Nam : Name_Id; - -- Case of No_Dependence => unit-name. Note that the parser - -- already made the necessary entry in the No_Dependence table. + begin + String_To_Name_Buffer (Strval (Expression (Arg3))); + Nam := Name_Find; - elsif Id = Name_No_Dependence then - Check_Unit_Name (Expr); + Elmt := First_Elmt (Predefined_Float_Types); + while Present (Elmt) and then Chars (Node (Elmt)) /= Nam loop + Next_Elmt (Elmt); + end loop; - -- Case of No_Specification_Of_Aspect => Identifier. + Ftyp := Node (Elmt); - elsif Id = Name_No_Specification_Of_Aspect then - declare - A_Id : Aspect_Id; + if Present (Ftyp) then - begin - if Nkind (Expr) /= N_Identifier then - A_Id := No_Aspect; - else - A_Id := Get_Aspect_Id (Chars (Expr)); - end if; + -- Don't build a derived type declaration, because predefined C + -- types have no declaration anywhere, so cannot really be named. + -- Instead build a full type declaration, starting with an + -- appropriate type definition is built - if A_Id = No_Aspect then - Error_Pragma_Arg ("invalid restriction name", Arg); - else - Set_Restriction_No_Specification_Of_Aspect (Expr, Warn); - end if; - end; + if Is_Floating_Point_Type (Ftyp) then + Def := Make_Floating_Point_Definition (Loc, + Make_Integer_Literal (Loc, Digits_Value (Ftyp)), + Make_Real_Range_Specification (Loc, + Make_Real_Literal (Loc, Realval (Type_Low_Bound (Ftyp))), + Make_Real_Literal (Loc, Realval (Type_High_Bound (Ftyp))))); - elsif Id = Name_No_Use_Of_Attribute then - if Nkind (Expr) /= N_Identifier - or else not Is_Attribute_Name (Chars (Expr)) - then - Error_Msg_N ("unknown attribute name?", Expr); + -- Should never have a predefined type we cannot handle - else - Set_Restriction_No_Use_Of_Attribute (Expr, Warn); - end if; + else + raise Program_Error; + end if; - elsif Id = Name_No_Use_Of_Pragma then - if Nkind (Expr) /= N_Identifier - or else not Is_Pragma_Name (Chars (Expr)) - then - Error_Msg_N ("unknown pragma name?", Expr); + -- Build and insert a Full_Type_Declaration, which will be + -- analyzed as soon as this list entry has been analyzed. - else - Set_Restriction_No_Use_Of_Pragma (Expr, Warn); - end if; + Decl := Make_Full_Type_Declaration (Loc, + Make_Defining_Identifier (Loc, Chars (Expression (Arg2))), + Type_Definition => Def); - -- All other cases of restriction identifier present + Insert_After (N, Decl); + Mark_Rewrite_Insertion (Decl); - else - R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg)); - Analyze_And_Resolve (Expr, Any_Integer); + else + Error_Pragma_Arg ("no matching type found for pragma%", + Arg2); + end if; + end Process_Import_Predefined_Type; + + --------------------------------- + -- Process_Import_Or_Interface -- + --------------------------------- + + procedure Process_Import_Or_Interface is + C : Convention_Id; + Def_Id : Entity_Id; + Hom_Id : Entity_Id; + + begin + Process_Convention (C, Def_Id); + Kill_Size_Check_Code (Def_Id); + Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False); + + if Ekind_In (Def_Id, E_Variable, E_Constant) then + + -- We do not permit Import to apply to a renaming declaration + + if Present (Renamed_Object (Def_Id)) then + Error_Pragma_Arg + ("pragma% not allowed for object renaming", Arg2); + + -- User initialization is not allowed for imported object, but + -- the object declaration may contain a default initialization, + -- that will be discarded. Note that an explicit initialization + -- only counts if it comes from source, otherwise it is simply + -- the code generator making an implicit initialization explicit. + + elsif Present (Expression (Parent (Def_Id))) + and then Comes_From_Source (Expression (Parent (Def_Id))) + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Pragma_Arg + ("no initialization allowed for declaration of& #", + "\imported entities cannot be initialized (RM B.1(24))", + Arg2); + + else + Set_Imported (Def_Id); + Process_Interface_Name (Def_Id, Arg3, Arg4); - if R_Id not in All_Parameter_Restrictions then - Error_Pragma_Arg - ("invalid restriction parameter identifier", Arg); + -- Note that we do not set Is_Public here. That's because we + -- only want to set it if there is no address clause, and we + -- don't know that yet, so we delay that processing till + -- freeze time. - elsif not Is_OK_Static_Expression (Expr) then - Flag_Non_Static_Expr - ("value must be static expression!", Expr); - raise Pragma_Exit; + -- pragma Import completes deferred constants - elsif not Is_Integer_Type (Etype (Expr)) - or else Expr_Value (Expr) < 0 - then - Error_Pragma_Arg - ("value must be non-negative integer", Arg); + if Ekind (Def_Id) = E_Constant then + Set_Has_Completion (Def_Id); end if; - -- Restriction pragma is active - - Val := Expr_Value (Expr); + -- It is not possible to import a constant of an unconstrained + -- array type (e.g. string) because there is no simple way to + -- write a meaningful subtype for it. - if not UI_Is_In_Int_Range (Val) then - Error_Pragma_Arg - ("pragma ignored, value too large??", Arg); + if Is_Array_Type (Etype (Def_Id)) + and then not Is_Constrained (Etype (Def_Id)) + then + Error_Msg_NE + ("imported constant& must have a constrained subtype", + N, Def_Id); end if; + end if; - -- Warning case. If the real restriction is active, then we - -- ignore the request, since warning never overrides a real - -- restriction. Otherwise we set the proper warning. Note that - -- this circuit sets the warning again if it is already set, - -- which is what we want, since the constant may have changed. + elsif Is_Subprogram (Def_Id) + or else Is_Generic_Subprogram (Def_Id) + then + -- If the name is overloaded, pragma applies to all of the denoted + -- entities in the same declarative part, unless the pragma comes + -- from an aspect specification. - if Warn then - if not Restriction_Active (R_Id) then - Set_Restriction - (R_Id, N, Integer (UI_To_Int (Val))); - Restriction_Warnings (R_Id) := True; - end if; + Hom_Id := Def_Id; + while Present (Hom_Id) loop - -- Real restriction case, set restriction and make sure warning - -- flag is off since real restriction always overrides warning. + Def_Id := Get_Base_Subprogram (Hom_Id); - else - Set_Restriction (R_Id, N, Integer (UI_To_Int (Val))); - Restriction_Warnings (R_Id) := False; - end if; - end if; + -- Ignore inherited subprograms because the pragma will apply + -- to the parent operation, which is the one called. - Next (Arg); - end loop; - end Process_Restrictions_Or_Restriction_Warnings; + if Is_Overloadable (Def_Id) + and then Present (Alias (Def_Id)) + then + null; - --------------------------------- - -- Process_Suppress_Unsuppress -- - --------------------------------- + -- If it is not a subprogram, it must be in an outer scope and + -- pragma does not apply. - -- Note: this procedure makes entries in the check suppress data - -- structures managed by Sem. See spec of package Sem for full - -- details on how we handle recording of check suppression. + elsif not Is_Subprogram (Def_Id) + and then not Is_Generic_Subprogram (Def_Id) + then + null; - procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is - C : Check_Id; - E_Id : Node_Id; - E : Entity_Id; + -- The pragma does not apply to primitives of interfaces - In_Package_Spec : constant Boolean := - Is_Package_Or_Generic_Package (Current_Scope) - and then not In_Package_Body (Current_Scope); + elsif Is_Dispatching_Operation (Def_Id) + and then Present (Find_Dispatching_Type (Def_Id)) + and then Is_Interface (Find_Dispatching_Type (Def_Id)) + then + null; - procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); - -- Used to suppress a single check on the given entity + -- Verify that the homonym is in the same declarative part (not + -- just the same scope). If the pragma comes from an aspect + -- specification we know that it is part of the declaration. - -------------------------------- - -- Suppress_Unsuppress_Echeck -- - -------------------------------- + elsif Parent (Unit_Declaration_Node (Def_Id)) /= Parent (N) + and then Nkind (Parent (N)) /= N_Compilation_Unit_Aux + and then not From_Aspect_Specification (N) + then + exit; - procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is - begin - -- Check for error of trying to set atomic synchronization for - -- a non-atomic variable. + else + Set_Imported (Def_Id); - if C = Atomic_Synchronization - and then not (Is_Atomic (E) or else Has_Atomic_Components (E)) - then - Error_Msg_N - ("pragma & requires atomic type or variable", - Pragma_Identifier (Original_Node (N))); - end if; + -- Reject an Import applied to an abstract subprogram - Set_Checks_May_Be_Suppressed (E); + if Is_Subprogram (Def_Id) + and then Is_Abstract_Subprogram (Def_Id) + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Msg_NE + ("cannot import abstract subprogram& declared#", + Arg2, Def_Id); + end if; - if In_Package_Spec then - Push_Global_Suppress_Stack_Entry - (Entity => E, - Check => C, - Suppress => Suppress_Case); - else - Push_Local_Suppress_Stack_Entry - (Entity => E, - Check => C, - Suppress => Suppress_Case); - end if; + -- Special processing for Convention_Intrinsic - -- If this is a first subtype, and the base type is distinct, - -- then also set the suppress flags on the base type. + if C = Convention_Intrinsic then - if Is_First_Subtype (E) and then Etype (E) /= E then - Suppress_Unsuppress_Echeck (Etype (E), C); - end if; - end Suppress_Unsuppress_Echeck; + -- Link_Name argument not allowed for intrinsic - -- Start of processing for Process_Suppress_Unsuppress + Check_No_Link_Name; - begin - -- Ignore pragma Suppress/Unsuppress in CodePeer and Alfa modes on - -- user code: we want to generate checks for analysis purposes, as - -- set respectively by -gnatC and -gnatd.F + Set_Is_Intrinsic_Subprogram (Def_Id); - if (CodePeer_Mode or Alfa_Mode) and then Comes_From_Source (N) then - return; - end if; + -- If no external name is present, then check that this + -- is a valid intrinsic subprogram. If an external name + -- is present, then this is handled by the back end. - -- Suppress/Unsuppress can appear as a configuration pragma, or in a - -- declarative part or a package spec (RM 11.5(5)). + if No (Arg3) then + Check_Intrinsic_Subprogram + (Def_Id, Get_Pragma_Arg (Arg2)); + end if; + end if; - if not Is_Configuration_Pragma then - Check_Is_In_Decl_Part_Or_Package_Spec; - end if; + -- All interfaced procedures need an external symbol created + -- for them since they are always referenced from another + -- object file. - Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (2); - Check_No_Identifier (Arg1); - Check_Arg_Is_Identifier (Arg1); + Set_Is_Public (Def_Id); - C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1))); + -- Verify that the subprogram does not have a completion + -- through a renaming declaration. For other completions the + -- pragma appears as a too late representation. - if C = No_Check_Id then - Error_Pragma_Arg - ("argument of pragma% is not valid check name", Arg1); - end if; + declare + Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); - if Arg_Count = 1 then + begin + if Present (Decl) + and then Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + and then Nkind (Unit_Declaration_Node + (Corresponding_Body (Decl))) = + N_Subprogram_Renaming_Declaration + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Msg_NE + ("cannot import&, renaming already provided for " + & "declaration #", N, Def_Id); + end if; + end; - -- Make an entry in the local scope suppress table. This is the - -- table that directly shows the current value of the scope - -- suppress check for any check id value. + Set_Has_Completion (Def_Id); + Process_Interface_Name (Def_Id, Arg3, Arg4); + end if; - if C = All_Checks then + if Is_Compilation_Unit (Hom_Id) then - -- For All_Checks, we set all specific predefined checks with - -- the exception of Elaboration_Check, which is handled - -- specially because of not wanting All_Checks to have the - -- effect of deactivating static elaboration order processing. - -- Atomic_Synchronization is also not affected, since this is - -- not a real check. + -- Its possible homonyms are not affected by the pragma. + -- Such homonyms might be present in the context of other + -- units being compiled. - for J in Scope_Suppress.Suppress'Range loop - if J /= Elaboration_Check - and then - J /= Atomic_Synchronization - then - Scope_Suppress.Suppress (J) := Suppress_Case; - end if; - end loop; + exit; - -- If not All_Checks, and predefined check, then set appropriate - -- scope entry. Note that we will set Elaboration_Check if this - -- is explicitly specified. Atomic_Synchronization is allowed - -- only if internally generated and entity is atomic. + elsif From_Aspect_Specification (N) then + exit; - elsif C in Predefined_Check_Id - and then (not Comes_From_Source (N) - or else C /= Atomic_Synchronization) - then - Scope_Suppress.Suppress (C) := Suppress_Case; - end if; + else + Hom_Id := Homonym (Hom_Id); + end if; + end loop; - -- Also make an entry in the Local_Entity_Suppress table + -- When the convention is Java or CIL, we also allow Import to be + -- given for packages, generic packages, exceptions, record + -- components, and access to subprograms. - Push_Local_Suppress_Stack_Entry - (Entity => Empty, - Check => C, - Suppress => Suppress_Case); + elsif (C = Convention_Java or else C = Convention_CIL) + and then + (Is_Package_Or_Generic_Package (Def_Id) + or else Ekind (Def_Id) = E_Exception + or else Ekind (Def_Id) = E_Access_Subprogram_Type + or else Nkind (Parent (Def_Id)) = N_Component_Declaration) + then + Set_Imported (Def_Id); + Set_Is_Public (Def_Id); + Process_Interface_Name (Def_Id, Arg3, Arg4); - -- Case of two arguments present, where the check is suppressed for - -- a specified entity (given as the second argument of the pragma) + -- Import a CPP class - else - -- This is obsolescent in Ada 2005 mode + elsif C = Convention_CPP + and then (Is_Record_Type (Def_Id) + or else Ekind (Def_Id) = E_Incomplete_Type) + then + if Ekind (Def_Id) = E_Incomplete_Type then + if Present (Full_View (Def_Id)) then + Def_Id := Full_View (Def_Id); - if Ada_Version >= Ada_2005 then - Check_Restriction (No_Obsolescent_Features, Arg2); - end if; + else + Error_Msg_N + ("cannot import 'C'P'P type before full declaration seen", + Get_Pragma_Arg (Arg2)); - Check_Optional_Identifier (Arg2, Name_On); - E_Id := Get_Pragma_Arg (Arg2); - Analyze (E_Id); + -- Although we have reported the error we decorate it as + -- CPP_Class to avoid reporting spurious errors - if not Is_Entity_Name (E_Id) then - Error_Pragma_Arg - ("second argument of pragma% must be entity name", Arg2); + Set_Is_CPP_Class (Def_Id); + return; + end if; end if; - E := Entity (E_Id); + -- Types treated as CPP classes must be declared limited (note: + -- this used to be a warning but there is no real benefit to it + -- since we did effectively intend to treat the type as limited + -- anyway). - if E = Any_Id then - return; + if not Is_Limited_Type (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type must be limited", + Get_Pragma_Arg (Arg2)); end if; - -- Enforce RM 11.5(7) which requires that for a pragma that - -- appears within a package spec, the named entity must be - -- within the package spec. We allow the package name itself - -- to be mentioned since that makes sense, although it is not - -- strictly allowed by 11.5(7). - - if In_Package_Spec - and then E /= Current_Scope - and then Scope (E) /= Current_Scope + if Etype (Def_Id) /= Def_Id + and then not Is_CPP_Class (Root_Type (Def_Id)) then - Error_Pragma_Arg - ("entity in pragma% is not in package spec (RM 11.5(7))", - Arg2); + Error_Msg_N ("root type must be a 'C'P'P type", Arg1); end if; - -- Loop through homonyms. As noted below, in the case of a package - -- spec, only homonyms within the package spec are considered. - - loop - Suppress_Unsuppress_Echeck (E, C); - - if Is_Generic_Instance (E) - and then Is_Subprogram (E) - and then Present (Alias (E)) - then - Suppress_Unsuppress_Echeck (Alias (E), C); - end if; + Set_Is_CPP_Class (Def_Id); - -- Move to next homonym if not aspect spec case + -- Imported CPP types must not have discriminants (because C++ + -- classes do not have discriminants). - exit when From_Aspect_Specification (N); - E := Homonym (E); - exit when No (E); + if Has_Discriminants (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type cannot have discriminants", + First (Discriminant_Specifications + (Declaration_Node (Def_Id)))); + end if; - -- If we are within a package specification, the pragma only - -- applies to homonyms in the same scope. + -- Check that components of imported CPP types do not have default + -- expressions. For private types this check is performed when the + -- full view is analyzed (see Process_Full_View). - exit when In_Package_Spec - and then Scope (E) /= Current_Scope; - end loop; - end if; - end Process_Suppress_Unsuppress; + if not Is_Private_Type (Def_Id) then + Check_CPP_Type_Has_No_Defaults (Def_Id); + end if; - ------------------ - -- Set_Exported -- - ------------------ + elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then + Check_No_Link_Name; + Check_Arg_Count (3); + Check_Arg_Is_Static_Expression (Arg3, Standard_String); - procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is - begin - if Is_Imported (E) then - Error_Pragma_Arg - ("cannot export entity& that was previously imported", Arg); + Process_Import_Predefined_Type; - elsif Present (Address_Clause (E)) - and then not Relaxed_RM_Semantics - then + else Error_Pragma_Arg - ("cannot export entity& that has an address clause", Arg); + ("second argument of pragma% must be object, subprogram " + & "or incomplete type", + Arg2); end if; - Set_Is_Exported (E); - - -- Generate a reference for entity explicitly, because the - -- identifier may be overloaded and name resolution will not - -- generate one. + -- If this pragma applies to a compilation unit, then the unit, which + -- is a subprogram, does not require (or allow) a body. We also do + -- not need to elaborate imported procedures. - Generate_Reference (E, Arg); + if Nkind (Parent (N)) = N_Compilation_Unit_Aux then + declare + Cunit : constant Node_Id := Parent (Parent (N)); + begin + Set_Body_Required (Cunit, False); + end; + end if; + end Process_Import_Or_Interface; - -- Deal with exporting non-library level entity + -------------------- + -- Process_Inline -- + -------------------- - if not Is_Library_Level_Entity (E) then + procedure Process_Inline (Status : Inline_Status) is + Assoc : Node_Id; + Decl : Node_Id; + Subp_Id : Node_Id; + Subp : Entity_Id; + Applies : Boolean; - -- Not allowed at all for subprograms + Effective : Boolean := False; + -- Set True if inline has some effect, i.e. if there is at least one + -- subprogram set as inlined as a result of the use of the pragma. - if Is_Subprogram (E) then - Error_Pragma_Arg ("local subprogram& cannot be exported", Arg); + procedure Make_Inline (Subp : Entity_Id); + -- Subp is the defining unit name of the subprogram declaration. Set + -- the flag, as well as the flag in the corresponding body, if there + -- is one present. - -- Otherwise set public and statically allocated + procedure Set_Inline_Flags (Subp : Entity_Id); + -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also + -- Has_Pragma_Inline_Always for the Inline_Always case. - else - Set_Is_Public (E); - Set_Is_Statically_Allocated (E); + function Inlining_Not_Possible (Subp : Entity_Id) return Boolean; + -- Returns True if it can be determined at this stage that inlining + -- is not possible, for example if the body is available and contains + -- exception handlers, we prevent inlining, since otherwise we can + -- get undefined symbols at link time. This function also emits a + -- warning if front-end inlining is enabled and the pragma appears + -- too late. + -- + -- ??? is business with link symbols still valid, or does it relate + -- to front end ZCX which is being phased out ??? - -- Warn if the corresponding W flag is set and the pragma comes - -- from source. The latter may not be true e.g. on VMS where we - -- expand export pragmas for exception codes associated with - -- imported or exported exceptions. We do not want to generate - -- a warning for something that the user did not write. + --------------------------- + -- Inlining_Not_Possible -- + --------------------------- - if Warn_On_Export_Import - and then Comes_From_Source (Arg) - then - Error_Msg_NE - ("?x?& has been made static as a result of Export", - Arg, E); - Error_Msg_N - ("\?x?this usage is non-standard and non-portable", - Arg); - end if; - end if; - end if; + function Inlining_Not_Possible (Subp : Entity_Id) return Boolean is + Decl : constant Node_Id := Unit_Declaration_Node (Subp); + Stats : Node_Id; - if Warn_On_Export_Import and then Is_Type (E) then - Error_Msg_NE ("exporting a type has no effect?x?", Arg, E); - end if; + begin + if Nkind (Decl) = N_Subprogram_Body then + Stats := Handled_Statement_Sequence (Decl); + return Present (Exception_Handlers (Stats)) + or else Present (At_End_Proc (Stats)); - if Warn_On_Export_Import and Inside_A_Generic then - Error_Msg_NE - ("all instances of& will have the same external name?x?", - Arg, E); - end if; - end Set_Exported; + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + then + if Front_End_Inlining + and then Analyzed (Corresponding_Body (Decl)) + then + Error_Msg_N ("pragma appears too late, ignored??", N); + return True; - ---------------------------------------------- - -- Set_Extended_Import_Export_External_Name -- - ---------------------------------------------- + -- If the subprogram is a renaming as body, the body is just a + -- call to the renamed subprogram, and inlining is trivially + -- possible. - procedure Set_Extended_Import_Export_External_Name - (Internal_Ent : Entity_Id; - Arg_External : Node_Id) - is - Old_Name : constant Node_Id := Interface_Name (Internal_Ent); - New_Name : Node_Id; + elsif + Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = + N_Subprogram_Renaming_Declaration + then + return False; - begin - if No (Arg_External) then - return; - end if; + else + Stats := + Handled_Statement_Sequence + (Unit_Declaration_Node (Corresponding_Body (Decl))); - Check_Arg_Is_External_Name (Arg_External); + return + Present (Exception_Handlers (Stats)) + or else Present (At_End_Proc (Stats)); + end if; - if Nkind (Arg_External) = N_String_Literal then - if String_Length (Strval (Arg_External)) = 0 then - return; else - New_Name := Adjust_External_Name_Case (Arg_External); + -- If body is not available, assume the best, the check is + -- performed again when compiling enclosing package bodies. + + return False; end if; + end Inlining_Not_Possible; - elsif Nkind (Arg_External) = N_Identifier then - New_Name := Get_Default_External_Name (Arg_External); + ----------------- + -- Make_Inline -- + ----------------- - -- Check_Arg_Is_External_Name should let through only identifiers and - -- string literals or static string expressions (which are folded to - -- string literals). + procedure Make_Inline (Subp : Entity_Id) is + Kind : constant Entity_Kind := Ekind (Subp); + Inner_Subp : Entity_Id := Subp; - else - raise Program_Error; - end if; + begin + -- Ignore if bad type, avoid cascaded error - -- If we already have an external name set (by a prior normal Import - -- or Export pragma), then the external names must match + if Etype (Subp) = Any_Type then + Applies := True; + return; - if Present (Interface_Name (Internal_Ent)) then - Check_Matching_Internal_Names : declare - S1 : constant String_Id := Strval (Old_Name); - S2 : constant String_Id := Strval (New_Name); + -- Ignore if all inlining is suppressed - procedure Mismatch; - pragma No_Return (Mismatch); - -- Called if names do not match + elsif Suppress_All_Inlining then + Applies := True; + return; - -------------- - -- Mismatch -- - -------------- + -- If inlining is not possible, for now do not treat as an error - procedure Mismatch is - begin - Error_Msg_Sloc := Sloc (Old_Name); - Error_Pragma_Arg - ("external name does not match that given #", - Arg_External); - end Mismatch; + elsif Status /= Suppressed + and then Inlining_Not_Possible (Subp) + then + Applies := True; + return; - -- Start of processing for Check_Matching_Internal_Names + -- Here we have a candidate for inlining, but we must exclude + -- derived operations. Otherwise we would end up trying to inline + -- a phantom declaration, and the result would be to drag in a + -- body which has no direct inlining associated with it. That + -- would not only be inefficient but would also result in the + -- backend doing cross-unit inlining in cases where it was + -- definitely inappropriate to do so. - begin - if String_Length (S1) /= String_Length (S2) then - Mismatch; + -- However, a simple Comes_From_Source test is insufficient, since + -- we do want to allow inlining of generic instances which also do + -- not come from source. We also need to recognize specs generated + -- by the front-end for bodies that carry the pragma. Finally, + -- predefined operators do not come from source but are not + -- inlineable either. - else - for J in 1 .. String_Length (S1) loop - if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then - Mismatch; - end if; - end loop; - end if; - end Check_Matching_Internal_Names; + elsif Is_Generic_Instance (Subp) + or else Nkind (Parent (Parent (Subp))) = N_Subprogram_Declaration + then + null; - -- Otherwise set the given name + elsif not Comes_From_Source (Subp) + and then Scope (Subp) /= Standard_Standard + then + Applies := True; + return; + end if; - else - Set_Encoded_Interface_Name (Internal_Ent, New_Name); - Check_Duplicated_Export_Name (New_Name); - end if; - end Set_Extended_Import_Export_External_Name; + -- The referenced entity must either be the enclosing entity, or + -- an entity declared within the current open scope. - ------------------ - -- Set_Imported -- - ------------------ + if Present (Scope (Subp)) + and then Scope (Subp) /= Current_Scope + and then Subp /= Current_Scope + then + Error_Pragma_Arg + ("argument of% must be entity in current scope", Assoc); + return; + end if; - procedure Set_Imported (E : Entity_Id) is - begin - -- Error message if already imported or exported + -- Processing for procedure, operator or function. If subprogram + -- is aliased (as for an instance) indicate that the renamed + -- entity (if declared in the same unit) is inlined. - if Is_Exported (E) or else Is_Imported (E) then + if Is_Subprogram (Subp) then + Inner_Subp := Ultimate_Alias (Inner_Subp); - -- Error if being set Exported twice + if In_Same_Source_Unit (Subp, Inner_Subp) then + Set_Inline_Flags (Inner_Subp); - if Is_Exported (E) then - Error_Msg_NE ("entity& was previously exported", N, E); + Decl := Parent (Parent (Inner_Subp)); - -- Ignore error in CodePeer mode where we treat all imported - -- subprograms as unknown. + if Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + then + Set_Inline_Flags (Corresponding_Body (Decl)); - elsif CodePeer_Mode then - goto OK; + elsif Is_Generic_Instance (Subp) then - -- OK if Import/Interface case + -- Indicate that the body needs to be created for + -- inlining subsequent calls. The instantiation node + -- follows the declaration of the wrapper package + -- created for it. - elsif Import_Interface_Present (N) then - goto OK; + if Scope (Subp) /= Standard_Standard + and then + Need_Subprogram_Instance_Body + (Next (Unit_Declaration_Node (Scope (Alias (Subp)))), + Subp) + then + null; + end if; - -- Error if being set Imported twice + -- Inline is a program unit pragma (RM 10.1.5) and cannot + -- appear in a formal part to apply to a formal subprogram. + -- Do not apply check within an instance or a formal package + -- the test will have been applied to the original generic. - else - Error_Msg_NE ("entity& was previously imported", N, E); - end if; + elsif Nkind (Decl) in N_Formal_Subprogram_Declaration + and then List_Containing (Decl) = List_Containing (N) + and then not In_Instance + then + Error_Msg_N + ("Inline cannot apply to a formal subprogram", N); - Error_Msg_Name_1 := Pname; - Error_Msg_N - ("\(pragma% applies to all previous entities)", N); + -- If Subp is a renaming, it is the renamed entity that + -- will appear in any call, and be inlined. However, for + -- ASIS uses it is convenient to indicate that the renaming + -- itself is an inlined subprogram, so that some gnatcheck + -- rules can be applied in the absence of expansion. - Error_Msg_Sloc := Sloc (E); - Error_Msg_NE ("\import not allowed for& declared#", N, E); + elsif Nkind (Decl) = N_Subprogram_Renaming_Declaration then + Set_Inline_Flags (Subp); + end if; + end if; - -- Here if not previously imported or exported, OK to import + Applies := True; - else - Set_Is_Imported (E); + -- For a generic subprogram set flag as well, for use at the point + -- of instantiation, to determine whether the body should be + -- generated. - -- If the entity is an object that is not at the library level, - -- then it is statically allocated. We do not worry about objects - -- with address clauses in this context since they are not really - -- imported in the linker sense. + elsif Is_Generic_Subprogram (Subp) then + Set_Inline_Flags (Subp); + Applies := True; - if Is_Object (E) - and then not Is_Library_Level_Entity (E) - and then No (Address_Clause (E)) - then - Set_Is_Statically_Allocated (E); - end if; - end if; + -- Literals are by definition inlined - <> null; - end Set_Imported; + elsif Kind = E_Enumeration_Literal then + null; - ------------------------- - -- Set_Mechanism_Value -- - ------------------------- + -- Anything else is an error - -- Note: the mechanism name has not been analyzed (and cannot indeed be - -- analyzed, since it is semantic nonsense), so we get it in the exact - -- form created by the parser. + else + Error_Pragma_Arg + ("expect subprogram name for pragma%", Assoc); + end if; + end Make_Inline; - procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is - Class : Node_Id; - Param : Node_Id; - Mech_Name_Id : Name_Id; + ---------------------- + -- Set_Inline_Flags -- + ---------------------- - procedure Bad_Class; - pragma No_Return (Bad_Class); - -- Signal bad descriptor class name + procedure Set_Inline_Flags (Subp : Entity_Id) is + begin + -- First set the Has_Pragma_XXX flags and issue the appropriate + -- errors and warnings for suspicious combinations. - procedure Bad_Mechanism; - pragma No_Return (Bad_Mechanism); - -- Signal bad mechanism name + if Prag_Id = Pragma_No_Inline then + if Has_Pragma_Inline_Always (Subp) then + Error_Msg_N + ("Inline_Always and No_Inline are mutually exclusive", N); + elsif Has_Pragma_Inline (Subp) then + Error_Msg_NE + ("Inline and No_Inline both specified for& ??", + N, Entity (Subp_Id)); + end if; - --------------- - -- Bad_Class -- - --------------- + Set_Has_Pragma_No_Inline (Subp); + else + if Prag_Id = Pragma_Inline_Always then + if Has_Pragma_No_Inline (Subp) then + Error_Msg_N + ("Inline_Always and No_Inline are mutually exclusive", + N); + end if; - procedure Bad_Class is - begin - Error_Pragma_Arg ("unrecognized descriptor class name", Class); - end Bad_Class; + Set_Has_Pragma_Inline_Always (Subp); + else + if Has_Pragma_No_Inline (Subp) then + Error_Msg_NE + ("Inline and No_Inline both specified for& ??", + N, Entity (Subp_Id)); + end if; + end if; - ------------------------- - -- Bad_Mechanism_Value -- - ------------------------- + if not Has_Pragma_Inline (Subp) then + Set_Has_Pragma_Inline (Subp); + Effective := True; + end if; + end if; - procedure Bad_Mechanism is - begin - Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name); - end Bad_Mechanism; + -- Then adjust the Is_Inlined flag. It can never be set if the + -- subprogram is subject to pragma No_Inline. - -- Start of processing for Set_Mechanism_Value + case Status is + when Suppressed => + Set_Is_Inlined (Subp, False); + when Disabled => + null; + when Enabled => + if not Has_Pragma_No_Inline (Subp) then + Set_Is_Inlined (Subp, True); + end if; + end case; + end Set_Inline_Flags; + + -- Start of processing for Process_Inline begin - if Mechanism (Ent) /= Default_Mechanism then - Error_Msg_NE - ("mechanism for & has already been set", Mech_Name, Ent); + Check_No_Identifiers; + Check_At_Least_N_Arguments (1); + + if Status = Enabled then + Inline_Processing_Required := True; end if; - -- MECHANISM_NAME ::= value | reference | descriptor | - -- short_descriptor + Assoc := Arg1; + while Present (Assoc) loop + Subp_Id := Get_Pragma_Arg (Assoc); + Analyze (Subp_Id); + Applies := False; - if Nkind (Mech_Name) = N_Identifier then - if Chars (Mech_Name) = Name_Value then - Set_Mechanism (Ent, By_Copy); - return; + if Is_Entity_Name (Subp_Id) then + Subp := Entity (Subp_Id); - elsif Chars (Mech_Name) = Name_Reference then - Set_Mechanism (Ent, By_Reference); - return; + if Subp = Any_Id then - elsif Chars (Mech_Name) = Name_Descriptor then - Check_VMS (Mech_Name); + -- If previous error, avoid cascaded errors - -- Descriptor => Short_Descriptor if pragma was given + Check_Error_Detected; + Applies := True; + Effective := True; - if Short_Descriptors then - Set_Mechanism (Ent, By_Short_Descriptor); else - Set_Mechanism (Ent, By_Descriptor); - end if; + Make_Inline (Subp); - return; + -- For the pragma case, climb homonym chain. This is + -- what implements allowing the pragma in the renaming + -- case, with the result applying to the ancestors, and + -- also allows Inline to apply to all previous homonyms. - elsif Chars (Mech_Name) = Name_Short_Descriptor then - Check_VMS (Mech_Name); - Set_Mechanism (Ent, By_Short_Descriptor); - return; + if not From_Aspect_Specification (N) then + while Present (Homonym (Subp)) + and then Scope (Homonym (Subp)) = Current_Scope + loop + Make_Inline (Homonym (Subp)); + Subp := Homonym (Subp); + end loop; + end if; + end if; + end if; - elsif Chars (Mech_Name) = Name_Copy then + if not Applies then Error_Pragma_Arg - ("bad mechanism name, Value assumed", Mech_Name); + ("inappropriate argument for pragma%", Assoc); - else - Bad_Mechanism; + elsif not Effective + and then Warn_On_Redundant_Constructs + and then not (Status = Suppressed or else Suppress_All_Inlining) + then + if Inlining_Not_Possible (Subp) then + Error_Msg_NE + ("pragma Inline for& is ignored?r?", + N, Entity (Subp_Id)); + else + Error_Msg_NE + ("pragma Inline for& is redundant?r?", + N, Entity (Subp_Id)); + end if; end if; - -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | - -- short_descriptor (CLASS_NAME) - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca - - -- Note: this form is parsed as an indexed component - - elsif Nkind (Mech_Name) = N_Indexed_Component then - Class := First (Expressions (Mech_Name)); - - if Nkind (Prefix (Mech_Name)) /= N_Identifier - or else - not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor, - Name_Short_Descriptor) - or else Present (Next (Class)) - then - Bad_Mechanism; - else - Mech_Name_Id := Chars (Prefix (Mech_Name)); + Next (Assoc); + end loop; + end Process_Inline; - -- Change Descriptor => Short_Descriptor if pragma was given + ---------------------------- + -- Process_Interface_Name -- + ---------------------------- - if Mech_Name_Id = Name_Descriptor - and then Short_Descriptors - then - Mech_Name_Id := Name_Short_Descriptor; - end if; - end if; + procedure Process_Interface_Name + (Subprogram_Def : Entity_Id; + Ext_Arg : Node_Id; + Link_Arg : Node_Id) + is + Ext_Nam : Node_Id; + Link_Nam : Node_Id; + String_Val : String_Id; - -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | - -- short_descriptor (Class => CLASS_NAME) - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca + procedure Check_Form_Of_Interface_Name + (SN : Node_Id; + Ext_Name_Case : Boolean); + -- SN is a string literal node for an interface name. This routine + -- performs some minimal checks that the name is reasonable. In + -- particular that no spaces or other obviously incorrect characters + -- appear. This is only a warning, since any characters are allowed. + -- Ext_Name_Case is True for an External_Name, False for a Link_Name. - -- Note: this form is parsed as a function call + ---------------------------------- + -- Check_Form_Of_Interface_Name -- + ---------------------------------- - elsif Nkind (Mech_Name) = N_Function_Call then - Param := First (Parameter_Associations (Mech_Name)); + procedure Check_Form_Of_Interface_Name + (SN : Node_Id; + Ext_Name_Case : Boolean) + is + S : constant String_Id := Strval (Expr_Value_S (SN)); + SL : constant Nat := String_Length (S); + C : Char_Code; - if Nkind (Name (Mech_Name)) /= N_Identifier - or else - not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor, - Name_Short_Descriptor) - or else Present (Next (Param)) - or else No (Selector_Name (Param)) - or else Chars (Selector_Name (Param)) /= Name_Class - then - Bad_Mechanism; - else - Class := Explicit_Actual_Parameter (Param); - Mech_Name_Id := Chars (Name (Mech_Name)); + begin + if SL = 0 then + Error_Msg_N ("interface name cannot be null string", SN); end if; - else - Bad_Mechanism; - end if; - - -- Fall through here with Class set to descriptor class name + for J in 1 .. SL loop + C := Get_String_Char (S, J); - Check_VMS (Mech_Name); + -- Look for dubious character and issue unconditional warning. + -- Definitely dubious if not in character range. - if Nkind (Class) /= N_Identifier then - Bad_Class; + if not In_Character_Range (C) - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBS - then - Set_Mechanism (Ent, By_Descriptor_UBS); + -- For all cases except CLI target, + -- commas, spaces and slashes are dubious (in CLI, we use + -- commas and backslashes in external names to specify + -- assembly version and public key, while slashes and spaces + -- can be used in names to mark nested classes and + -- valuetypes). - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBSB - then - Set_Mechanism (Ent, By_Descriptor_UBSB); + or else ((not Ext_Name_Case or else VM_Target /= CLI_Target) + and then (Get_Character (C) = ',' + or else + Get_Character (C) = '\')) + or else (VM_Target /= CLI_Target + and then (Get_Character (C) = ' ' + or else + Get_Character (C) = '/')) + then + Error_Msg + ("??interface name contains illegal character", + Sloc (SN) + Source_Ptr (J)); + end if; + end loop; + end Check_Form_Of_Interface_Name; - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBA - then - Set_Mechanism (Ent, By_Descriptor_UBA); + -- Start of processing for Process_Interface_Name - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_S - then - Set_Mechanism (Ent, By_Descriptor_S); + begin + if No (Link_Arg) then + if No (Ext_Arg) then + if VM_Target = CLI_Target + and then Ekind (Subprogram_Def) = E_Package + and then Nkind (Parent (Subprogram_Def)) = + N_Package_Specification + and then Present (Generic_Parent (Parent (Subprogram_Def))) + then + Set_Interface_Name + (Subprogram_Def, + Interface_Name + (Generic_Parent (Parent (Subprogram_Def)))); + end if; - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_SB - then - Set_Mechanism (Ent, By_Descriptor_SB); + return; - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_A - then - Set_Mechanism (Ent, By_Descriptor_A); + elsif Chars (Ext_Arg) = Name_Link_Name then + Ext_Nam := Empty; + Link_Nam := Expression (Ext_Arg); - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_NCA - then - Set_Mechanism (Ent, By_Descriptor_NCA); + else + Check_Optional_Identifier (Ext_Arg, Name_External_Name); + Ext_Nam := Expression (Ext_Arg); + Link_Nam := Empty; + end if; - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBS - then - Set_Mechanism (Ent, By_Short_Descriptor_UBS); + else + Check_Optional_Identifier (Ext_Arg, Name_External_Name); + Check_Optional_Identifier (Link_Arg, Name_Link_Name); + Ext_Nam := Expression (Ext_Arg); + Link_Nam := Expression (Link_Arg); + end if; - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBSB - then - Set_Mechanism (Ent, By_Short_Descriptor_UBSB); + -- Check expressions for external name and link name are static - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBA - then - Set_Mechanism (Ent, By_Short_Descriptor_UBA); + if Present (Ext_Nam) then + Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String); + Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True); - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_S - then - Set_Mechanism (Ent, By_Short_Descriptor_S); + -- Verify that external name is not the name of a local entity, + -- which would hide the imported one and could lead to run-time + -- surprises. The problem can only arise for entities declared in + -- a package body (otherwise the external name is fully qualified + -- and will not conflict). - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_SB - then - Set_Mechanism (Ent, By_Short_Descriptor_SB); + declare + Nam : Name_Id; + E : Entity_Id; + Par : Node_Id; - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_A - then - Set_Mechanism (Ent, By_Short_Descriptor_A); + begin + if Prag_Id = Pragma_Import then + String_To_Name_Buffer (Strval (Expr_Value_S (Ext_Nam))); + Nam := Name_Find; + E := Entity_Id (Get_Name_Table_Info (Nam)); - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_NCA - then - Set_Mechanism (Ent, By_Short_Descriptor_NCA); + if Nam /= Chars (Subprogram_Def) + and then Present (E) + and then not Is_Overloadable (E) + and then Is_Immediately_Visible (E) + and then not Is_Imported (E) + and then Ekind (Scope (E)) = E_Package + then + Par := Parent (E); + while Present (Par) loop + if Nkind (Par) = N_Package_Body then + Error_Msg_Sloc := Sloc (E); + Error_Msg_NE + ("imported entity is hidden by & declared#", + Ext_Arg, E); + exit; + end if; - else - Bad_Class; + Par := Parent (Par); + end loop; + end if; + end if; + end; end if; - end Set_Mechanism_Value; - -------------------------- - -- Set_Rational_Profile -- - -------------------------- + if Present (Link_Nam) then + Check_Arg_Is_Static_Expression (Link_Nam, Standard_String); + Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False); + end if; - -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and - -- and extension to the semantics of renaming declarations. + -- If there is no link name, just set the external name - procedure Set_Rational_Profile is - begin - Implicit_Packing := True; - Overriding_Renamings := True; - Use_VADS_Size := True; - end Set_Rational_Profile; + if No (Link_Nam) then + Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)); - --------------------------- - -- Set_Ravenscar_Profile -- - --------------------------- + -- For the Link_Name case, the given literal is preceded by an + -- asterisk, which indicates to GCC that the given name should be + -- taken literally, and in particular that no prepending of + -- underlines should occur, even in systems where this is the + -- normal default. - -- The tasks to be done here are + else + Start_String; - -- Set required policies + if VM_Target = No_VM then + Store_String_Char (Get_Char_Code ('*')); + end if; - -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) - -- pragma Locking_Policy (Ceiling_Locking) + String_Val := Strval (Expr_Value_S (Link_Nam)); + Store_String_Chars (String_Val); + Link_Nam := + Make_String_Literal (Sloc (Link_Nam), + Strval => End_String); + end if; - -- Set Detect_Blocking mode + -- Set the interface name. If the entity is a generic instance, use + -- its alias, which is the callable entity. - -- Set required restrictions (see System.Rident for detailed list) + if Is_Generic_Instance (Subprogram_Def) then + Set_Encoded_Interface_Name + (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam); + else + Set_Encoded_Interface_Name + (Get_Base_Subprogram (Subprogram_Def), Link_Nam); + end if; - -- Set the No_Dependence rules - -- No_Dependence => Ada.Asynchronous_Task_Control - -- No_Dependence => Ada.Calendar - -- No_Dependence => Ada.Execution_Time.Group_Budget - -- No_Dependence => Ada.Execution_Time.Timers - -- No_Dependence => Ada.Task_Attributes - -- No_Dependence => System.Multiprocessors.Dispatching_Domains + -- We allow duplicated export names in CIL/Java, as they are always + -- enclosed in a namespace that differentiates them, and overloaded + -- entities are supported by the VM. - procedure Set_Ravenscar_Profile (N : Node_Id) is - Prefix_Entity : Entity_Id; - Selector_Entity : Entity_Id; - Prefix_Node : Node_Id; - Node : Node_Id; + if Convention (Subprogram_Def) /= Convention_CIL + and then + Convention (Subprogram_Def) /= Convention_Java + then + Check_Duplicated_Export_Name (Link_Nam); + end if; + end Process_Interface_Name; - begin - -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) + ----------------------------------------- + -- Process_Interrupt_Or_Attach_Handler -- + ----------------------------------------- - if Task_Dispatching_Policy /= ' ' - and then Task_Dispatching_Policy /= 'F' - then - Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; - Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); + procedure Process_Interrupt_Or_Attach_Handler is + Arg1_X : constant Node_Id := Get_Pragma_Arg (Arg1); + Handler_Proc : constant Entity_Id := Entity (Arg1_X); + Proc_Scope : constant Entity_Id := Scope (Handler_Proc); - -- Set the FIFO_Within_Priorities policy, but always preserve - -- System_Location since we like the error message with the run time - -- name. + begin + Set_Is_Interrupt_Handler (Handler_Proc); - else - Task_Dispatching_Policy := 'F'; + -- If the pragma is not associated with a handler procedure within a + -- protected type, then it must be for a nonprotected procedure for + -- the AAMP target, in which case we don't associate a representation + -- item with the procedure's scope. - if Task_Dispatching_Policy_Sloc /= System_Location then - Task_Dispatching_Policy_Sloc := Loc; + if Ekind (Proc_Scope) = E_Protected_Type then + if Prag_Id = Pragma_Interrupt_Handler + or else + Prag_Id = Pragma_Attach_Handler + then + Record_Rep_Item (Proc_Scope, N); end if; end if; + end Process_Interrupt_Or_Attach_Handler; - -- pragma Locking_Policy (Ceiling_Locking) + -------------------------------------------------- + -- Process_Restrictions_Or_Restriction_Warnings -- + -------------------------------------------------- - if Locking_Policy /= ' ' - and then Locking_Policy /= 'C' - then - Error_Msg_Sloc := Locking_Policy_Sloc; - Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); + -- Note: some of the simple identifier cases were handled in par-prag, + -- but it is harmless (and more straightforward) to simply handle all + -- cases here, even if it means we repeat a bit of work in some cases. - -- Set the Ceiling_Locking policy, but preserve System_Location since - -- we like the error message with the run time name. + procedure Process_Restrictions_Or_Restriction_Warnings + (Warn : Boolean) + is + Arg : Node_Id; + R_Id : Restriction_Id; + Id : Name_Id; + Expr : Node_Id; + Val : Uint; - else - Locking_Policy := 'C'; + procedure Check_Unit_Name (N : Node_Id); + -- Checks unit name parameter for No_Dependence. Returns if it has + -- an appropriate form, otherwise raises pragma argument error. - if Locking_Policy_Sloc /= System_Location then - Locking_Policy_Sloc := Loc; + --------------------- + -- Check_Unit_Name -- + --------------------- + + procedure Check_Unit_Name (N : Node_Id) is + begin + if Nkind (N) = N_Selected_Component then + Check_Unit_Name (Prefix (N)); + Check_Unit_Name (Selector_Name (N)); + + elsif Nkind (N) = N_Identifier then + return; + + else + Error_Pragma_Arg + ("wrong form for unit name for No_Dependence", N); end if; - end if; + end Check_Unit_Name; - -- pragma Detect_Blocking + -- Start of processing for Process_Restrictions_Or_Restriction_Warnings - Detect_Blocking := True; + begin + -- Ignore all Restrictions pragma in CodePeer mode - -- Set the corresponding restrictions + if CodePeer_Mode then + return; + end if; - Set_Profile_Restrictions - (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings); + Check_Ada_83_Warning; + Check_At_Least_N_Arguments (1); + Check_Valid_Configuration_Pragma; - -- Set the No_Dependence restrictions + Arg := Arg1; + while Present (Arg) loop + Id := Chars (Arg); + Expr := Get_Pragma_Arg (Arg); - -- The following No_Dependence restrictions: - -- No_Dependence => Ada.Asynchronous_Task_Control - -- No_Dependence => Ada.Calendar - -- No_Dependence => Ada.Task_Attributes - -- are already set by previous call to Set_Profile_Restrictions. + -- Case of no restriction identifier present - -- Set the following restrictions which were added to Ada 2005: - -- No_Dependence => Ada.Execution_Time.Group_Budget - -- No_Dependence => Ada.Execution_Time.Timers + if Id = No_Name then + if Nkind (Expr) /= N_Identifier then + Error_Pragma_Arg + ("invalid form for restriction", Arg); + end if; - if Ada_Version >= Ada_2005 then - Name_Buffer (1 .. 3) := "ada"; - Name_Len := 3; + R_Id := + Get_Restriction_Id + (Process_Restriction_Synonyms (Expr)); - Prefix_Entity := Make_Identifier (Loc, Name_Find); + if R_Id not in All_Boolean_Restrictions then + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("invalid restriction identifier&", Get_Pragma_Arg (Arg)); - Name_Buffer (1 .. 14) := "execution_time"; - Name_Len := 14; + -- Check for possible misspelling - Selector_Entity := Make_Identifier (Loc, Name_Find); + for J in Restriction_Id loop + declare + Rnm : constant String := Restriction_Id'Image (J); - Prefix_Node := - Make_Selected_Component - (Sloc => Loc, - Prefix => Prefix_Entity, - Selector_Name => Selector_Entity); + begin + Name_Buffer (1 .. Rnm'Length) := Rnm; + Name_Len := Rnm'Length; + Set_Casing (All_Lower_Case); - Name_Buffer (1 .. 13) := "group_budgets"; - Name_Len := 13; + if Is_Bad_Spelling_Of (Chars (Expr), Name_Enter) then + Set_Casing + (Identifier_Casing (Current_Source_File)); + Error_Msg_String (1 .. Rnm'Length) := + Name_Buffer (1 .. Name_Len); + Error_Msg_Strlen := Rnm'Length; + Error_Msg_N -- CODEFIX + ("\possible misspelling of ""~""", + Get_Pragma_Arg (Arg)); + exit; + end if; + end; + end loop; - Selector_Entity := Make_Identifier (Loc, Name_Find); + raise Pragma_Exit; + end if; - Node := - Make_Selected_Component - (Sloc => Loc, - Prefix => Prefix_Node, - Selector_Name => Selector_Entity); + if Implementation_Restriction (R_Id) then + Check_Restriction (No_Implementation_Restrictions, Arg); + end if; - Set_Restriction_No_Dependence - (Unit => Node, - Warn => Treat_Restrictions_As_Warnings, - Profile => Ravenscar); + -- Special processing for No_Elaboration_Code restriction - Name_Buffer (1 .. 6) := "timers"; - Name_Len := 6; + if R_Id = No_Elaboration_Code then - Selector_Entity := Make_Identifier (Loc, Name_Find); + -- Restriction is only recognized within a configuration + -- pragma file, or within a unit of the main extended + -- program. Note: the test for Main_Unit is needed to + -- properly include the case of configuration pragma files. - Node := - Make_Selected_Component - (Sloc => Loc, - Prefix => Prefix_Node, - Selector_Name => Selector_Entity); + if not (Current_Sem_Unit = Main_Unit + or else In_Extended_Main_Source_Unit (N)) + then + return; - Set_Restriction_No_Dependence - (Unit => Node, - Warn => Treat_Restrictions_As_Warnings, - Profile => Ravenscar); - end if; + -- Don't allow in a subunit unless already specified in + -- body or spec. - -- Set the following restrictions which was added to Ada 2012 (see - -- AI-0171): - -- No_Dependence => System.Multiprocessors.Dispatching_Domains + elsif Nkind (Parent (N)) = N_Compilation_Unit + and then Nkind (Unit (Parent (N))) = N_Subunit + and then not Restriction_Active (No_Elaboration_Code) + then + Error_Msg_N + ("invalid specification of ""No_Elaboration_Code""", + N); + Error_Msg_N + ("\restriction cannot be specified in a subunit", N); + Error_Msg_N + ("\unless also specified in body or spec", N); + return; - if Ada_Version >= Ada_2012 then - Name_Buffer (1 .. 6) := "system"; - Name_Len := 6; + -- If we have a No_Elaboration_Code pragma that we + -- accept, then it needs to be added to the configuration + -- restrcition set so that we get proper application to + -- other units in the main extended source as required. - Prefix_Entity := Make_Identifier (Loc, Name_Find); + else + Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); + end if; + end if; - Name_Buffer (1 .. 15) := "multiprocessors"; - Name_Len := 15; + -- If this is a warning, then set the warning unless we already + -- have a real restriction active (we never want a warning to + -- override a real restriction). - Selector_Entity := Make_Identifier (Loc, Name_Find); + if Warn then + if not Restriction_Active (R_Id) then + Set_Restriction (R_Id, N); + Restriction_Warnings (R_Id) := True; + end if; - Prefix_Node := - Make_Selected_Component - (Sloc => Loc, - Prefix => Prefix_Entity, - Selector_Name => Selector_Entity); + -- If real restriction case, then set it and make sure that the + -- restriction warning flag is off, since a real restriction + -- always overrides a warning. - Name_Buffer (1 .. 19) := "dispatching_domains"; - Name_Len := 19; + else + Set_Restriction (R_Id, N); + Restriction_Warnings (R_Id) := False; + end if; - Selector_Entity := Make_Identifier (Loc, Name_Find); + -- Check for obsolescent restrictions in Ada 2005 mode - Node := - Make_Selected_Component - (Sloc => Loc, - Prefix => Prefix_Node, - Selector_Name => Selector_Entity); + if not Warn + and then Ada_Version >= Ada_2005 + and then (R_Id = No_Asynchronous_Control + or else + R_Id = No_Unchecked_Deallocation + or else + R_Id = No_Unchecked_Conversion) + then + Check_Restriction (No_Obsolescent_Features, N); + end if; - Set_Restriction_No_Dependence - (Unit => Node, - Warn => Treat_Restrictions_As_Warnings, - Profile => Ravenscar); - end if; - end Set_Ravenscar_Profile; + -- A very special case that must be processed here: pragma + -- Restrictions (No_Exceptions) turns off all run-time + -- checking. This is a bit dubious in terms of the formal + -- language definition, but it is what is intended by RM + -- H.4(12). Restriction_Warnings never affects generated code + -- so this is done only in the real restriction case. - ---------------- - -- S14_Pragma -- - ---------------- + -- Atomic_Synchronization is not a real check, so it is not + -- affected by this processing). - procedure S14_Pragma is - begin - if not Formal_Extensions then - Error_Pragma ("pragma% requires the use of debug switch -gnatd.V"); - end if; - end S14_Pragma; + if R_Id = No_Exceptions and then not Warn then + for J in Scope_Suppress.Suppress'Range loop + if J /= Atomic_Synchronization then + Scope_Suppress.Suppress (J) := True; + end if; + end loop; + end if; - -- Start of processing for Analyze_Pragma + -- Case of No_Dependence => unit-name. Note that the parser + -- already made the necessary entry in the No_Dependence table. - begin - -- The following code is a defense against recursion. Not clear that - -- this can happen legitimately, but perhaps some error situations - -- can cause it, and we did see this recursion during testing. + elsif Id = Name_No_Dependence then + Check_Unit_Name (Expr); - if Analyzed (N) then - return; - else - Set_Analyzed (N, True); - end if; + -- Case of No_Specification_Of_Aspect => Identifier. - -- Deal with unrecognized pragma + elsif Id = Name_No_Specification_Of_Aspect then + declare + A_Id : Aspect_Id; - Pname := Pragma_Name (N); + begin + if Nkind (Expr) /= N_Identifier then + A_Id := No_Aspect; + else + A_Id := Get_Aspect_Id (Chars (Expr)); + end if; - if not Is_Pragma_Name (Pname) then - if Warn_On_Unrecognized_Pragma then - Error_Msg_Name_1 := Pname; - Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N)); + if A_Id = No_Aspect then + Error_Pragma_Arg ("invalid restriction name", Arg); + else + Set_Restriction_No_Specification_Of_Aspect (Expr, Warn); + end if; + end; - for PN in First_Pragma_Name .. Last_Pragma_Name loop - if Is_Bad_Spelling_Of (Pname, PN) then - Error_Msg_Name_1 := PN; - Error_Msg_N -- CODEFIX - ("\?g?possible misspelling of %!", Pragma_Identifier (N)); - exit; + elsif Id = Name_No_Use_Of_Attribute then + if Nkind (Expr) /= N_Identifier + or else not Is_Attribute_Name (Chars (Expr)) + then + Error_Msg_N ("unknown attribute name?", Expr); + + else + Set_Restriction_No_Use_Of_Attribute (Expr, Warn); end if; - end loop; - end if; - return; - end if; + elsif Id = Name_No_Use_Of_Pragma then + if Nkind (Expr) /= N_Identifier + or else not Is_Pragma_Name (Chars (Expr)) + then + Error_Msg_N ("unknown pragma name?", Expr); - -- Here to start processing for recognized pragma + else + Set_Restriction_No_Use_Of_Pragma (Expr, Warn); + end if; - Prag_Id := Get_Pragma_Id (Pname); - Pname := Original_Name (N); + -- All other cases of restriction identifier present - -- Check applicable policy. We skip this for a pragma that came from - -- an aspect, since we already dealt with the Disable case, and we set - -- the Is_Ignored flag at the time the aspect was analyzed. + else + R_Id := Get_Restriction_Id (Process_Restriction_Synonyms (Arg)); + Analyze_And_Resolve (Expr, Any_Integer); - if not From_Aspect_Specification (N) then - Check_Applicable_Policy (N); + if R_Id not in All_Parameter_Restrictions then + Error_Pragma_Arg + ("invalid restriction parameter identifier", Arg); - -- If pragma is disabled, rewrite as NULL and skip analysis + elsif not Is_OK_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("value must be static expression!", Expr); + raise Pragma_Exit; - if Is_Disabled (N) then - Rewrite (N, Make_Null_Statement (Loc)); - Analyze (N); - raise Pragma_Exit; - end if; - end if; + elsif not Is_Integer_Type (Etype (Expr)) + or else Expr_Value (Expr) < 0 + then + Error_Pragma_Arg + ("value must be non-negative integer", Arg); + end if; - -- Preset arguments + -- Restriction pragma is active - Arg_Count := 0; - Arg1 := Empty; - Arg2 := Empty; - Arg3 := Empty; - Arg4 := Empty; + Val := Expr_Value (Expr); - if Present (Pragma_Argument_Associations (N)) then - Arg_Count := List_Length (Pragma_Argument_Associations (N)); - Arg1 := First (Pragma_Argument_Associations (N)); + if not UI_Is_In_Int_Range (Val) then + Error_Pragma_Arg + ("pragma ignored, value too large??", Arg); + end if; - if Present (Arg1) then - Arg2 := Next (Arg1); + -- Warning case. If the real restriction is active, then we + -- ignore the request, since warning never overrides a real + -- restriction. Otherwise we set the proper warning. Note that + -- this circuit sets the warning again if it is already set, + -- which is what we want, since the constant may have changed. - if Present (Arg2) then - Arg3 := Next (Arg2); + if Warn then + if not Restriction_Active (R_Id) then + Set_Restriction + (R_Id, N, Integer (UI_To_Int (Val))); + Restriction_Warnings (R_Id) := True; + end if; - if Present (Arg3) then - Arg4 := Next (Arg3); + -- Real restriction case, set restriction and make sure warning + -- flag is off since real restriction always overrides warning. + + else + Set_Restriction (R_Id, N, Integer (UI_To_Int (Val))); + Restriction_Warnings (R_Id) := False; end if; end if; - end if; - end if; - Check_Restriction_No_Use_Of_Pragma (N); + Next (Arg); + end loop; + end Process_Restrictions_Or_Restriction_Warnings; - -- An enumeration type defines the pragmas that are supported by the - -- implementation. Get_Pragma_Id (in package Prag) transforms a name - -- into the corresponding enumeration value for the following case. + --------------------------------- + -- Process_Suppress_Unsuppress -- + --------------------------------- - case Prag_Id is + -- Note: this procedure makes entries in the check suppress data + -- structures managed by Sem. See spec of package Sem for full + -- details on how we handle recording of check suppression. - ----------------- - -- Abort_Defer -- - ----------------- + procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is + C : Check_Id; + E_Id : Node_Id; + E : Entity_Id; - -- pragma Abort_Defer; + In_Package_Spec : constant Boolean := + Is_Package_Or_Generic_Package (Current_Scope) + and then not In_Package_Body (Current_Scope); - when Pragma_Abort_Defer => - GNAT_Pragma; - Check_Arg_Count (0); + procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); + -- Used to suppress a single check on the given entity - -- The only required semantic processing is to check the - -- placement. This pragma must appear at the start of the - -- statement sequence of a handled sequence of statements. + -------------------------------- + -- Suppress_Unsuppress_Echeck -- + -------------------------------- - if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements - or else N /= First (Statements (Parent (N))) + procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is + begin + -- Check for error of trying to set atomic synchronization for + -- a non-atomic variable. + + if C = Atomic_Synchronization + and then not (Is_Atomic (E) or else Has_Atomic_Components (E)) then - Pragma_Misplaced; + Error_Msg_N + ("pragma & requires atomic type or variable", + Pragma_Identifier (Original_Node (N))); end if; - -------------------- - -- Abstract_State -- - -------------------- - - -- pragma Abstract_State (ABSTRACT_STATE_LIST) - - -- ABSTRACT_STATE_LIST ::= - -- null - -- | STATE_NAME_WITH_PROPERTIES {, STATE_NAME_WITH_PROPERTIES} + Set_Checks_May_Be_Suppressed (E); - -- STATE_NAME_WITH_PROPERTIES ::= - -- STATE_NAME - -- | (STATE_NAME with PROPERTY_LIST) + if In_Package_Spec then + Push_Global_Suppress_Stack_Entry + (Entity => E, + Check => C, + Suppress => Suppress_Case); + else + Push_Local_Suppress_Stack_Entry + (Entity => E, + Check => C, + Suppress => Suppress_Case); + end if; - -- PROPERTY_LIST ::= PROPERTY {, PROPERTY} - -- PROPERTY ::= SIMPLE_PROPERTY | NAME_VALUE_PROPERTY + -- If this is a first subtype, and the base type is distinct, + -- then also set the suppress flags on the base type. - -- SIMPLE_PROPERTY ::= IDENTIFIER - -- NAME_VALUE_PROPERTY ::= IDENTIFIER => EXPRESSION + if Is_First_Subtype (E) and then Etype (E) /= E then + Suppress_Unsuppress_Echeck (Etype (E), C); + end if; + end Suppress_Unsuppress_Echeck; - -- STATE_NAME ::= DEFINING_IDENTIFIER + -- Start of processing for Process_Suppress_Unsuppress - when Pragma_Abstract_State => Abstract_State : declare - Pack_Id : Entity_Id; + begin + -- Ignore pragma Suppress/Unsuppress in CodePeer and Alfa modes on + -- user code: we want to generate checks for analysis purposes, as + -- set respectively by -gnatC and -gnatd.F - -- Flags used to verify the consistency of states + if (CodePeer_Mode or Alfa_Mode) and then Comes_From_Source (N) then + return; + end if; - Non_Null_Seen : Boolean := False; - Null_Seen : Boolean := False; + -- Suppress/Unsuppress can appear as a configuration pragma, or in a + -- declarative part or a package spec (RM 11.5(5)). - procedure Analyze_Abstract_State (State : Node_Id); - -- Verify the legality of a single state declaration. Create and - -- decorate a state abstraction entity and introduce it into the - -- visibility chain. + if not Is_Configuration_Pragma then + Check_Is_In_Decl_Part_Or_Package_Spec; + end if; - ---------------------------- - -- Analyze_Abstract_State -- - ---------------------------- + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + Check_No_Identifier (Arg1); + Check_Arg_Is_Identifier (Arg1); - procedure Analyze_Abstract_State (State : Node_Id) is - procedure Check_Duplicate_Property - (Prop : Node_Id; - Status : in out Boolean); - -- Flag Status denotes whether a particular property has been - -- seen while processing a state. This routine verifies that - -- Prop is not a duplicate property and sets the flag Status. + C := Get_Check_Id (Chars (Get_Pragma_Arg (Arg1))); - ------------------------------ - -- Check_Duplicate_Property -- - ------------------------------ + if C = No_Check_Id then + Error_Pragma_Arg + ("argument of pragma% is not valid check name", Arg1); + end if; - procedure Check_Duplicate_Property - (Prop : Node_Id; - Status : in out Boolean) - is - begin - if Status then - Error_Msg_N ("duplicate state property", Prop); - end if; + if Arg_Count = 1 then - Status := True; - end Check_Duplicate_Property; + -- Make an entry in the local scope suppress table. This is the + -- table that directly shows the current value of the scope + -- suppress check for any check id value. - -- Local variables + if C = All_Checks then - Errors : constant Nat := Serious_Errors_Detected; - Loc : constant Source_Ptr := Sloc (State); - Assoc : Node_Id; - Id : Entity_Id; - Is_Null : Boolean := False; - Level : Uint := Uint_0; - Name : Name_Id; - Prop : Node_Id; + -- For All_Checks, we set all specific predefined checks with + -- the exception of Elaboration_Check, which is handled + -- specially because of not wanting All_Checks to have the + -- effect of deactivating static elaboration order processing. + -- Atomic_Synchronization is also not affected, since this is + -- not a real check. - -- Flags used to verify the consistency of properties + for J in Scope_Suppress.Suppress'Range loop + if J /= Elaboration_Check + and then + J /= Atomic_Synchronization + then + Scope_Suppress.Suppress (J) := Suppress_Case; + end if; + end loop; - Input_Seen : Boolean := False; - Integrity_Seen : Boolean := False; - Output_Seen : Boolean := False; - Volatile_Seen : Boolean := False; + -- If not All_Checks, and predefined check, then set appropriate + -- scope entry. Note that we will set Elaboration_Check if this + -- is explicitly specified. Atomic_Synchronization is allowed + -- only if internally generated and entity is atomic. - -- Start of processing for Analyze_Abstract_State + elsif C in Predefined_Check_Id + and then (not Comes_From_Source (N) + or else C /= Atomic_Synchronization) + then + Scope_Suppress.Suppress (C) := Suppress_Case; + end if; - begin - -- A package with a null abstract state is not allowed to - -- declare additional states. + -- Also make an entry in the Local_Entity_Suppress table - if Null_Seen then - Error_Msg_NE - ("package & has null abstract state", State, Pack_Id); + Push_Local_Suppress_Stack_Entry + (Entity => Empty, + Check => C, + Suppress => Suppress_Case); - -- Null states appear as internally generated entities + -- Case of two arguments present, where the check is suppressed for + -- a specified entity (given as the second argument of the pragma) - elsif Nkind (State) = N_Null then - Name := New_Internal_Name ('S'); - Is_Null := True; - Null_Seen := True; + else + -- This is obsolescent in Ada 2005 mode - -- Catch a case where a null state appears in a list of - -- non-null states. + if Ada_Version >= Ada_2005 then + Check_Restriction (No_Obsolescent_Features, Arg2); + end if; - if Non_Null_Seen then - Error_Msg_NE - ("package & has non-null abstract state", - State, Pack_Id); - end if; + Check_Optional_Identifier (Arg2, Name_On); + E_Id := Get_Pragma_Arg (Arg2); + Analyze (E_Id); - -- Simple state declaration + if not Is_Entity_Name (E_Id) then + Error_Pragma_Arg + ("second argument of pragma% must be entity name", Arg2); + end if; - elsif Nkind (State) = N_Identifier then - Name := Chars (State); - Non_Null_Seen := True; + E := Entity (E_Id); - -- State declaration with various properties. This construct - -- appears as an extension aggregate in the tree. + if E = Any_Id then + return; + end if; - elsif Nkind (State) = N_Extension_Aggregate then - if Nkind (Ancestor_Part (State)) = N_Identifier then - Name := Chars (Ancestor_Part (State)); - Non_Null_Seen := True; - else - Error_Msg_N - ("state name must be an identifier", - Ancestor_Part (State)); - end if; + -- Enforce RM 11.5(7) which requires that for a pragma that + -- appears within a package spec, the named entity must be + -- within the package spec. We allow the package name itself + -- to be mentioned since that makes sense, although it is not + -- strictly allowed by 11.5(7). - -- Process properties Input, Output and Volatile. Ensure - -- that none of them appear more than once. + if In_Package_Spec + and then E /= Current_Scope + and then Scope (E) /= Current_Scope + then + Error_Pragma_Arg + ("entity in pragma% is not in package spec (RM 11.5(7))", + Arg2); + end if; - Prop := First (Expressions (State)); - while Present (Prop) loop - if Nkind (Prop) = N_Identifier then - if Chars (Prop) = Name_Input then - Check_Duplicate_Property (Prop, Input_Seen); - elsif Chars (Prop) = Name_Output then - Check_Duplicate_Property (Prop, Output_Seen); - elsif Chars (Prop) = Name_Volatile then - Check_Duplicate_Property (Prop, Volatile_Seen); - else - Error_Msg_N ("invalid state property", Prop); - end if; - else - Error_Msg_N ("invalid state property", Prop); - end if; + -- Loop through homonyms. As noted below, in the case of a package + -- spec, only homonyms within the package spec are considered. - Next (Prop); - end loop; + loop + Suppress_Unsuppress_Echeck (E, C); - -- Volatile requires exactly one Input or Output + if Is_Generic_Instance (E) + and then Is_Subprogram (E) + and then Present (Alias (E)) + then + Suppress_Unsuppress_Echeck (Alias (E), C); + end if; - if Volatile_Seen - and then - ((Input_Seen and then Output_Seen) -- both - or else - (not Input_Seen and then not Output_Seen)) -- none - then - Error_Msg_N - ("property Volatile requires exactly one Input or " - & "Output", State); - end if; + -- Move to next homonym if not aspect spec case - -- Either Input or Output require Volatile + exit when From_Aspect_Specification (N); + E := Homonym (E); + exit when No (E); - if (Input_Seen or Output_Seen) - and then not Volatile_Seen - then - Error_Msg_N - ("properties Input and Output require Volatile", State); - end if; + -- If we are within a package specification, the pragma only + -- applies to homonyms in the same scope. - -- State property Integrity appears as a component - -- association. + exit when In_Package_Spec + and then Scope (E) /= Current_Scope; + end loop; + end if; + end Process_Suppress_Unsuppress; - Assoc := First (Component_Associations (State)); - while Present (Assoc) loop - Prop := First (Choices (Assoc)); - while Present (Prop) loop - if Nkind (Prop) = N_Identifier - and then Chars (Prop) = Name_Integrity - then - Check_Duplicate_Property (Prop, Integrity_Seen); - else - Error_Msg_N ("invalid state property", Prop); - end if; + ------------------ + -- Set_Exported -- + ------------------ - Next (Prop); - end loop; + procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is + begin + if Is_Imported (E) then + Error_Pragma_Arg + ("cannot export entity& that was previously imported", Arg); - if Nkind (Expression (Assoc)) = N_Integer_Literal then - Level := Intval (Expression (Assoc)); - else - Error_Msg_N - ("integrity level must be an integer literal", - Expression (Assoc)); - end if; + elsif Present (Address_Clause (E)) + and then not Relaxed_RM_Semantics + then + Error_Pragma_Arg + ("cannot export entity& that has an address clause", Arg); + end if; - Next (Assoc); - end loop; + Set_Is_Exported (E); - -- Any other attempt to declare a state is erroneous + -- Generate a reference for entity explicitly, because the + -- identifier may be overloaded and name resolution will not + -- generate one. - else - Error_Msg_N ("malformed abstract state declaration", State); - end if; + Generate_Reference (E, Arg); - -- Do not generate a state abstraction entity if it was not - -- properly declared. + -- Deal with exporting non-library level entity - if Serious_Errors_Detected > Errors then - return; - end if; + if not Is_Library_Level_Entity (E) then - -- The generated state abstraction reuses the same characters - -- from the original state declaration. Decorate the entity. + -- Not allowed at all for subprograms - Id := Make_Defining_Identifier (Loc, New_External_Name (Name)); - Set_Comes_From_Source (Id, not Is_Null); - Set_Parent (Id, State); - Set_Ekind (Id, E_Abstract_State); - Set_Etype (Id, Standard_Void_Type); - Set_Integrity_Level (Id, Level); - Set_Refined_State (Id, Empty); + if Is_Subprogram (E) then + Error_Pragma_Arg ("local subprogram& cannot be exported", Arg); - -- Every non-null state must be nameable and resolvable the - -- same way a constant is. + -- Otherwise set public and statically allocated - if not Is_Null then - Push_Scope (Pack_Id); - Enter_Name (Id); - Pop_Scope; - end if; + else + Set_Is_Public (E); + Set_Is_Statically_Allocated (E); - -- Associate the state with its related package + -- Warn if the corresponding W flag is set and the pragma comes + -- from source. The latter may not be true e.g. on VMS where we + -- expand export pragmas for exception codes associated with + -- imported or exported exceptions. We do not want to generate + -- a warning for something that the user did not write. - if No (Abstract_States (Pack_Id)) then - Set_Abstract_States (Pack_Id, New_Elmt_List); + if Warn_On_Export_Import + and then Comes_From_Source (Arg) + then + Error_Msg_NE + ("?x?& has been made static as a result of Export", + Arg, E); + Error_Msg_N + ("\?x?this usage is non-standard and non-portable", + Arg); end if; + end if; + end if; - Append_Elmt (Id, Abstract_States (Pack_Id)); - end Analyze_Abstract_State; + if Warn_On_Export_Import and then Is_Type (E) then + Error_Msg_NE ("exporting a type has no effect?x?", Arg, E); + end if; - -- Local variables + if Warn_On_Export_Import and Inside_A_Generic then + Error_Msg_NE + ("all instances of& will have the same external name?x?", + Arg, E); + end if; + end Set_Exported; - Par : Node_Id; - State : Node_Id; + ---------------------------------------------- + -- Set_Extended_Import_Export_External_Name -- + ---------------------------------------------- - -- Start of processing for Abstract_State + procedure Set_Extended_Import_Export_External_Name + (Internal_Ent : Entity_Id; + Arg_External : Node_Id) + is + Old_Name : constant Node_Id := Interface_Name (Internal_Ent); + New_Name : Node_Id; - begin - GNAT_Pragma; - S14_Pragma; - Check_Arg_Count (1); + begin + if No (Arg_External) then + return; + end if; - -- Ensure the proper placement of the pragma. Abstract states must - -- be associated with a package declaration. + Check_Arg_Is_External_Name (Arg_External); - if From_Aspect_Specification (N) then - Par := Parent (Corresponding_Aspect (N)); + if Nkind (Arg_External) = N_String_Literal then + if String_Length (Strval (Arg_External)) = 0 then + return; else - Par := Parent (Parent (N)); + New_Name := Adjust_External_Name_Case (Arg_External); end if; - if Nkind (Par) = N_Compilation_Unit then - Par := Unit (Par); - end if; + elsif Nkind (Arg_External) = N_Identifier then + New_Name := Get_Default_External_Name (Arg_External); - if Nkind (Par) /= N_Package_Declaration then - Pragma_Misplaced; - return; - end if; + -- Check_Arg_Is_External_Name should let through only identifiers and + -- string literals or static string expressions (which are folded to + -- string literals). - Pack_Id := Defining_Entity (Par); - State := Expression (Arg1); + else + raise Program_Error; + end if; - -- Multiple abstract states appear as an aggregate + -- If we already have an external name set (by a prior normal Import + -- or Export pragma), then the external names must match - if Nkind (State) = N_Aggregate then - State := First (Expressions (State)); - while Present (State) loop - Analyze_Abstract_State (State); + if Present (Interface_Name (Internal_Ent)) then + Check_Matching_Internal_Names : declare + S1 : constant String_Id := Strval (Old_Name); + S2 : constant String_Id := Strval (New_Name); - Next (State); - end loop; + procedure Mismatch; + pragma No_Return (Mismatch); + -- Called if names do not match - -- Various forms of a single abstract state. Note that these may - -- include malformed state declarations. + -------------- + -- Mismatch -- + -------------- - else - Analyze_Abstract_State (State); - end if; - end Abstract_State; + procedure Mismatch is + begin + Error_Msg_Sloc := Sloc (Old_Name); + Error_Pragma_Arg + ("external name does not match that given #", + Arg_External); + end Mismatch; - ------------ - -- Ada_83 -- - ------------ + -- Start of processing for Check_Matching_Internal_Names - -- pragma Ada_83; + begin + if String_Length (S1) /= String_Length (S2) then + Mismatch; - -- Note: this pragma also has some specific processing in Par.Prag - -- because we want to set the Ada version mode during parsing. + else + for J in 1 .. String_Length (S1) loop + if Get_String_Char (S1, J) /= Get_String_Char (S2, J) then + Mismatch; + end if; + end loop; + end if; + end Check_Matching_Internal_Names; - when Pragma_Ada_83 => - GNAT_Pragma; - Check_Arg_Count (0); + -- Otherwise set the given name - -- We really should check unconditionally for proper configuration - -- pragma placement, since we really don't want mixed Ada modes - -- within a single unit, and the GNAT reference manual has always - -- said this was a configuration pragma, but we did not check and - -- are hesitant to add the check now. + else + Set_Encoded_Interface_Name (Internal_Ent, New_Name); + Check_Duplicated_Export_Name (New_Name); + end if; + end Set_Extended_Import_Export_External_Name; - -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012 - -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005 - -- or Ada 2012 mode. + ------------------ + -- Set_Imported -- + ------------------ - if Ada_Version >= Ada_2005 then - Check_Valid_Configuration_Pragma; - end if; + procedure Set_Imported (E : Entity_Id) is + begin + -- Error message if already imported or exported - -- Now set Ada 83 mode + if Is_Exported (E) or else Is_Imported (E) then - Ada_Version := Ada_83; - Ada_Version_Explicit := Ada_Version; + -- Error if being set Exported twice - ------------ - -- Ada_95 -- - ------------ + if Is_Exported (E) then + Error_Msg_NE ("entity& was previously exported", N, E); - -- pragma Ada_95; + -- Ignore error in CodePeer mode where we treat all imported + -- subprograms as unknown. - -- Note: this pragma also has some specific processing in Par.Prag - -- because we want to set the Ada 83 version mode during parsing. + elsif CodePeer_Mode then + goto OK; - when Pragma_Ada_95 => - GNAT_Pragma; - Check_Arg_Count (0); + -- OK if Import/Interface case - -- We really should check unconditionally for proper configuration - -- pragma placement, since we really don't want mixed Ada modes - -- within a single unit, and the GNAT reference manual has always - -- said this was a configuration pragma, but we did not check and - -- are hesitant to add the check now. + elsif Import_Interface_Present (N) then + goto OK; - -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 - -- or Ada 95, so we must check if we are in Ada 2005 mode. + -- Error if being set Imported twice - if Ada_Version >= Ada_2005 then - Check_Valid_Configuration_Pragma; + else + Error_Msg_NE ("entity& was previously imported", N, E); end if; - -- Now set Ada 95 mode - - Ada_Version := Ada_95; - Ada_Version_Explicit := Ada_Version; - - --------------------- - -- Ada_05/Ada_2005 -- - --------------------- + Error_Msg_Name_1 := Pname; + Error_Msg_N + ("\(pragma% applies to all previous entities)", N); - -- pragma Ada_05; - -- pragma Ada_05 (LOCAL_NAME); + Error_Msg_Sloc := Sloc (E); + Error_Msg_NE ("\import not allowed for& declared#", N, E); - -- pragma Ada_2005; - -- pragma Ada_2005 (LOCAL_NAME): + -- Here if not previously imported or exported, OK to import - -- Note: these pragmas also have some specific processing in Par.Prag - -- because we want to set the Ada 2005 version mode during parsing. + else + Set_Is_Imported (E); - when Pragma_Ada_05 | Pragma_Ada_2005 => declare - E_Id : Node_Id; + -- If the entity is an object that is not at the library level, + -- then it is statically allocated. We do not worry about objects + -- with address clauses in this context since they are not really + -- imported in the linker sense. - begin - GNAT_Pragma; + if Is_Object (E) + and then not Is_Library_Level_Entity (E) + and then No (Address_Clause (E)) + then + Set_Is_Statically_Allocated (E); + end if; + end if; - if Arg_Count = 1 then - Check_Arg_Is_Local_Name (Arg1); - E_Id := Get_Pragma_Arg (Arg1); + <> null; + end Set_Imported; - if Etype (E_Id) = Any_Type then - return; - end if; + ------------------------- + -- Set_Mechanism_Value -- + ------------------------- - Set_Is_Ada_2005_Only (Entity (E_Id)); - Record_Rep_Item (Entity (E_Id), N); + -- Note: the mechanism name has not been analyzed (and cannot indeed be + -- analyzed, since it is semantic nonsense), so we get it in the exact + -- form created by the parser. - else - Check_Arg_Count (0); + procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is + Class : Node_Id; + Param : Node_Id; + Mech_Name_Id : Name_Id; - -- For Ada_2005 we unconditionally enforce the documented - -- configuration pragma placement, since we do not want to - -- tolerate mixed modes in a unit involving Ada 2005. That - -- would cause real difficulties for those cases where there - -- are incompatibilities between Ada 95 and Ada 2005. + procedure Bad_Class; + pragma No_Return (Bad_Class); + -- Signal bad descriptor class name - Check_Valid_Configuration_Pragma; + procedure Bad_Mechanism; + pragma No_Return (Bad_Mechanism); + -- Signal bad mechanism name - -- Now set appropriate Ada mode + --------------- + -- Bad_Class -- + --------------- - Ada_Version := Ada_2005; - Ada_Version_Explicit := Ada_2005; - end if; - end; + procedure Bad_Class is + begin + Error_Pragma_Arg ("unrecognized descriptor class name", Class); + end Bad_Class; - --------------------- - -- Ada_12/Ada_2012 -- - --------------------- + ------------------------- + -- Bad_Mechanism_Value -- + ------------------------- - -- pragma Ada_12; - -- pragma Ada_12 (LOCAL_NAME); + procedure Bad_Mechanism is + begin + Error_Pragma_Arg ("unrecognized mechanism name", Mech_Name); + end Bad_Mechanism; - -- pragma Ada_2012; - -- pragma Ada_2012 (LOCAL_NAME): + -- Start of processing for Set_Mechanism_Value - -- Note: these pragmas also have some specific processing in Par.Prag - -- because we want to set the Ada 2012 version mode during parsing. + begin + if Mechanism (Ent) /= Default_Mechanism then + Error_Msg_NE + ("mechanism for & has already been set", Mech_Name, Ent); + end if; - when Pragma_Ada_12 | Pragma_Ada_2012 => declare - E_Id : Node_Id; + -- MECHANISM_NAME ::= value | reference | descriptor | + -- short_descriptor - begin - GNAT_Pragma; + if Nkind (Mech_Name) = N_Identifier then + if Chars (Mech_Name) = Name_Value then + Set_Mechanism (Ent, By_Copy); + return; - if Arg_Count = 1 then - Check_Arg_Is_Local_Name (Arg1); - E_Id := Get_Pragma_Arg (Arg1); + elsif Chars (Mech_Name) = Name_Reference then + Set_Mechanism (Ent, By_Reference); + return; - if Etype (E_Id) = Any_Type then - return; - end if; + elsif Chars (Mech_Name) = Name_Descriptor then + Check_VMS (Mech_Name); - Set_Is_Ada_2012_Only (Entity (E_Id)); - Record_Rep_Item (Entity (E_Id), N); + -- Descriptor => Short_Descriptor if pragma was given - else - Check_Arg_Count (0); + if Short_Descriptors then + Set_Mechanism (Ent, By_Short_Descriptor); + else + Set_Mechanism (Ent, By_Descriptor); + end if; - -- For Ada_2012 we unconditionally enforce the documented - -- configuration pragma placement, since we do not want to - -- tolerate mixed modes in a unit involving Ada 2012. That - -- would cause real difficulties for those cases where there - -- are incompatibilities between Ada 95 and Ada 2012. We could - -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it. + return; - Check_Valid_Configuration_Pragma; + elsif Chars (Mech_Name) = Name_Short_Descriptor then + Check_VMS (Mech_Name); + Set_Mechanism (Ent, By_Short_Descriptor); + return; - -- Now set appropriate Ada mode + elsif Chars (Mech_Name) = Name_Copy then + Error_Pragma_Arg + ("bad mechanism name, Value assumed", Mech_Name); - Ada_Version := Ada_2012; - Ada_Version_Explicit := Ada_2012; + else + Bad_Mechanism; end if; - end; - ---------------------- - -- All_Calls_Remote -- - ---------------------- + -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | + -- short_descriptor (CLASS_NAME) + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca - -- pragma All_Calls_Remote [(library_package_NAME)]; + -- Note: this form is parsed as an indexed component - when Pragma_All_Calls_Remote => All_Calls_Remote : declare - Lib_Entity : Entity_Id; + elsif Nkind (Mech_Name) = N_Indexed_Component then + Class := First (Expressions (Mech_Name)); - begin - Check_Ada_83_Warning; - Check_Valid_Library_Unit_Pragma; + if Nkind (Prefix (Mech_Name)) /= N_Identifier + or else + not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor, + Name_Short_Descriptor) + or else Present (Next (Class)) + then + Bad_Mechanism; + else + Mech_Name_Id := Chars (Prefix (Mech_Name)); - if Nkind (N) = N_Null_Statement then - return; + -- Change Descriptor => Short_Descriptor if pragma was given + + if Mech_Name_Id = Name_Descriptor + and then Short_Descriptors + then + Mech_Name_Id := Name_Short_Descriptor; + end if; end if; - Lib_Entity := Find_Lib_Unit_Name; + -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | + -- short_descriptor (Class => CLASS_NAME) + -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca - -- This pragma should only apply to a RCI unit (RM E.2.3(23)) + -- Note: this form is parsed as a function call - if Present (Lib_Entity) - and then not Debug_Flag_U + elsif Nkind (Mech_Name) = N_Function_Call then + Param := First (Parameter_Associations (Mech_Name)); + + if Nkind (Name (Mech_Name)) /= N_Identifier + or else + not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor, + Name_Short_Descriptor) + or else Present (Next (Param)) + or else No (Selector_Name (Param)) + or else Chars (Selector_Name (Param)) /= Name_Class then - if not Is_Remote_Call_Interface (Lib_Entity) then - Error_Pragma ("pragma% only apply to rci unit"); + Bad_Mechanism; + else + Class := Explicit_Actual_Parameter (Param); + Mech_Name_Id := Chars (Name (Mech_Name)); + end if; - -- Set flag for entity of the library unit + else + Bad_Mechanism; + end if; - else - Set_Has_All_Calls_Remote (Lib_Entity); - end if; + -- Fall through here with Class set to descriptor class name - end if; - end All_Calls_Remote; + Check_VMS (Mech_Name); - -------------- - -- Annotate -- - -------------- + if Nkind (Class) /= N_Identifier then + Bad_Class; - -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]); - -- ARG ::= NAME | EXPRESSION + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_UBS + then + Set_Mechanism (Ent, By_Descriptor_UBS); - -- The first two arguments are by convention intended to refer to an - -- external tool and a tool-specific function. These arguments are - -- not analyzed. + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_UBSB + then + Set_Mechanism (Ent, By_Descriptor_UBSB); - when Pragma_Annotate => Annotate : declare - Arg : Node_Id; - Exp : Node_Id; + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_UBA + then + Set_Mechanism (Ent, By_Descriptor_UBA); - begin - GNAT_Pragma; - Check_At_Least_N_Arguments (1); - Check_Arg_Is_Identifier (Arg1); - Check_No_Identifiers; - Store_Note (N); + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_S + then + Set_Mechanism (Ent, By_Descriptor_S); - -- Second parameter is optional, it is never analyzed + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_SB + then + Set_Mechanism (Ent, By_Descriptor_SB); - if No (Arg2) then - null; + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_A + then + Set_Mechanism (Ent, By_Descriptor_A); - -- Here if we have a second parameter + elsif Mech_Name_Id = Name_Descriptor + and then Chars (Class) = Name_NCA + then + Set_Mechanism (Ent, By_Descriptor_NCA); - else - -- Second parameter must be identifier + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBS + then + Set_Mechanism (Ent, By_Short_Descriptor_UBS); - Check_Arg_Is_Identifier (Arg2); + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBSB + then + Set_Mechanism (Ent, By_Short_Descriptor_UBSB); - -- Process remaining parameters if any + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_UBA + then + Set_Mechanism (Ent, By_Short_Descriptor_UBA); - Arg := Next (Arg2); - while Present (Arg) loop - Exp := Get_Pragma_Arg (Arg); - Analyze (Exp); + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_S + then + Set_Mechanism (Ent, By_Short_Descriptor_S); - if Is_Entity_Name (Exp) then - null; + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_SB + then + Set_Mechanism (Ent, By_Short_Descriptor_SB); - -- For string literals, we assume Standard_String as the - -- type, unless the string contains wide or wide_wide - -- characters. + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_A + then + Set_Mechanism (Ent, By_Short_Descriptor_A); - elsif Nkind (Exp) = N_String_Literal then - if Has_Wide_Wide_Character (Exp) then - Resolve (Exp, Standard_Wide_Wide_String); - elsif Has_Wide_Character (Exp) then - Resolve (Exp, Standard_Wide_String); - else - Resolve (Exp, Standard_String); - end if; + elsif Mech_Name_Id = Name_Short_Descriptor + and then Chars (Class) = Name_NCA + then + Set_Mechanism (Ent, By_Short_Descriptor_NCA); - elsif Is_Overloaded (Exp) then - Error_Pragma_Arg - ("ambiguous argument for pragma%", Exp); + else + Bad_Class; + end if; + end Set_Mechanism_Value; - else - Resolve (Exp); - end if; + -------------------------- + -- Set_Rational_Profile -- + -------------------------- - Next (Arg); - end loop; - end if; - end Annotate; + -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and + -- and extension to the semantics of renaming declarations. - --------------------------- - -- Assert/Assert_And_Cut -- - --------------------------- + procedure Set_Rational_Profile is + begin + Implicit_Packing := True; + Overriding_Renamings := True; + Use_VADS_Size := True; + end Set_Rational_Profile; + + --------------------------- + -- Set_Ravenscar_Profile -- + --------------------------- - -- pragma Assert - -- ( [Check => ] Boolean_EXPRESSION - -- [, [Message =>] Static_String_EXPRESSION]); + -- The tasks to be done here are - -- pragma Assert_And_Cut - -- ( [Check => ] Boolean_EXPRESSION - -- [, [Message =>] Static_String_EXPRESSION]); + -- Set required policies - when Pragma_Assert | Pragma_Assert_And_Cut => Assert : declare - Expr : Node_Id; - Newa : List_Id; + -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) + -- pragma Locking_Policy (Ceiling_Locking) - begin - if Prag_Id = Pragma_Assert then - Ada_2005_Pragma; - else -- Pragma_Assert_And_Cut - GNAT_Pragma; - S14_Pragma; - end if; + -- Set Detect_Blocking mode - Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (2); - Check_Arg_Order ((Name_Check, Name_Message)); - Check_Optional_Identifier (Arg1, Name_Check); + -- Set required restrictions (see System.Rident for detailed list) - -- We treat pragma Assert[_And_Cut] as equivalent to: + -- Set the No_Dependence rules + -- No_Dependence => Ada.Asynchronous_Task_Control + -- No_Dependence => Ada.Calendar + -- No_Dependence => Ada.Execution_Time.Group_Budget + -- No_Dependence => Ada.Execution_Time.Timers + -- No_Dependence => Ada.Task_Attributes + -- No_Dependence => System.Multiprocessors.Dispatching_Domains - -- pragma Check (Assert[_And_Cut], condition [, msg]); + procedure Set_Ravenscar_Profile (N : Node_Id) is + Prefix_Entity : Entity_Id; + Selector_Entity : Entity_Id; + Prefix_Node : Node_Id; + Node : Node_Id; - -- So rewrite pragma in this manner, transfer the message - -- argument if present, and analyze the result + begin + -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities) - -- Pragma Assert_And_Cut is treated exactly like pragma Assert by - -- the frontend. Formal verification tools may use it to "cut" the - -- paths through the code, to make verification tractable. When - -- dealing with a semantically analyzed tree, the information that - -- a Check node N corresponds to a source Assert_And_Cut pragma - -- can be retrieved from the pragma kind of Original_Node(N). + if Task_Dispatching_Policy /= ' ' + and then Task_Dispatching_Policy /= 'F' + then + Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; + Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); - Expr := Get_Pragma_Arg (Arg1); - Newa := New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Pname)), - Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Expr)); + -- Set the FIFO_Within_Priorities policy, but always preserve + -- System_Location since we like the error message with the run time + -- name. - if Arg_Count > 1 then - Check_Optional_Identifier (Arg2, Name_Message); - Append_To (Newa, New_Copy_Tree (Arg2)); + else + Task_Dispatching_Policy := 'F'; + + if Task_Dispatching_Policy_Sloc /= System_Location then + Task_Dispatching_Policy_Sloc := Loc; end if; + end if; - Rewrite (N, - Make_Pragma (Loc, - Chars => Name_Check, - Pragma_Argument_Associations => Newa)); - Analyze (N); - end Assert; + -- pragma Locking_Policy (Ceiling_Locking) - ---------------------- - -- Assertion_Policy -- - ---------------------- + if Locking_Policy /= ' ' + and then Locking_Policy /= 'C' + then + Error_Msg_Sloc := Locking_Policy_Sloc; + Error_Pragma ("Profile (Ravenscar) incompatible with policy#"); - -- pragma Assertion_Policy (POLICY_IDENTIFIER); + -- Set the Ceiling_Locking policy, but preserve System_Location since + -- we like the error message with the run time name. - -- The following form is Ada 2012 only, but we allow it in all modes + else + Locking_Policy := 'C'; - -- Pragma Assertion_Policy ( - -- ASSERTION_KIND => POLICY_IDENTIFIER - -- {, ASSERTION_KIND => POLICY_IDENTIFIER}); + if Locking_Policy_Sloc /= System_Location then + Locking_Policy_Sloc := Loc; + end if; + end if; - -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND + -- pragma Detect_Blocking - -- RM_ASSERTION_KIND ::= Assert | - -- Static_Predicate | - -- Dynamic_Predicate | - -- Pre | - -- Pre'Class | - -- Post | - -- Post'Class | - -- Type_Invariant | - -- Type_Invariant'Class + Detect_Blocking := True; - -- ID_ASSERTION_KIND ::= Assert_And_Cut | - -- Assume | - -- Contract_Cases | - -- Debug | - -- Loop_Invariant | - -- Loop_Variant | - -- Postcondition | - -- Precondition | - -- Predicate | - -- Statement_Assertions - -- - -- Note: The RM_ASSERTION_KIND list is language-defined, and the - -- ID_ASSERTION_KIND list contains implementation-defined additions - -- recognized by GNAT. The effect is to control the behavior of - -- identically named aspects and pragmas, depending on the specified - -- policy identifier: + -- Set the corresponding restrictions - -- POLICY_IDENTIFIER ::= Check | Disable | Ignore + Set_Profile_Restrictions + (Ravenscar, N, Warn => Treat_Restrictions_As_Warnings); - -- Note: Check and Ignore are language-defined. Disable is a GNAT - -- implementation defined addition that results in totally ignoring - -- the corresponding assertion. If Disable is specified, then the - -- argument of the assertion is not even analyzed. This is useful - -- when the aspect/pragma argument references entities in a with'ed - -- package that is replaced by a dummy package in the final build. + -- Set the No_Dependence restrictions - -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class, - -- and Type_Invariant'Class were recognized by the parser and - -- transformed into references to the special internal identifiers - -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special - -- processing is required here. + -- The following No_Dependence restrictions: + -- No_Dependence => Ada.Asynchronous_Task_Control + -- No_Dependence => Ada.Calendar + -- No_Dependence => Ada.Task_Attributes + -- are already set by previous call to Set_Profile_Restrictions. - when Pragma_Assertion_Policy => Assertion_Policy : declare - LocP : Source_Ptr; - Policy : Node_Id; - Arg : Node_Id; - Kind : Name_Id; + -- Set the following restrictions which were added to Ada 2005: + -- No_Dependence => Ada.Execution_Time.Group_Budget + -- No_Dependence => Ada.Execution_Time.Timers - begin - Ada_2005_Pragma; + if Ada_Version >= Ada_2005 then + Name_Buffer (1 .. 3) := "ada"; + Name_Len := 3; - -- This can always appear as a configuration pragma + Prefix_Entity := Make_Identifier (Loc, Name_Find); - if Is_Configuration_Pragma then - null; + Name_Buffer (1 .. 14) := "execution_time"; + Name_Len := 14; - -- It can also appear in a declarative part or package spec in Ada - -- 2012 mode. We allow this in other modes, but in that case we - -- consider that we have an Ada 2012 pragma on our hands. + Selector_Entity := Make_Identifier (Loc, Name_Find); - else - Check_Is_In_Decl_Part_Or_Package_Spec; - Ada_2012_Pragma; - end if; + Prefix_Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Entity, + Selector_Name => Selector_Entity); - -- One argument case with no identifier (first form above) + Name_Buffer (1 .. 13) := "group_budgets"; + Name_Len := 13; - if Arg_Count = 1 - and then (Nkind (Arg1) /= N_Pragma_Argument_Association - or else Chars (Arg1) = No_Name) - then - Check_Arg_Is_One_Of - (Arg1, Name_Check, Name_Disable, Name_Ignore); + Selector_Entity := Make_Identifier (Loc, Name_Find); - -- Treat one argument Assertion_Policy as equivalent to: + Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Node, + Selector_Name => Selector_Entity); - -- pragma Check_Policy (Assertion, policy) + Set_Restriction_No_Dependence + (Unit => Node, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); - -- So rewrite pragma in that manner and link on to the chain - -- of Check_Policy pragmas, marking the pragma as analyzed. + Name_Buffer (1 .. 6) := "timers"; + Name_Len := 6; - Policy := Get_Pragma_Arg (Arg1); + Selector_Entity := Make_Identifier (Loc, Name_Find); - Rewrite (N, - Make_Pragma (Loc, - Chars => Name_Check_Policy, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Assertion)), + Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Node, + Selector_Name => Selector_Entity); - Make_Pragma_Argument_Association (Loc, - Expression => - Make_Identifier (Sloc (Policy), Chars (Policy)))))); - Analyze (N); + Set_Restriction_No_Dependence + (Unit => Node, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + end if; - -- Here if we have two or more arguments + -- Set the following restrictions which was added to Ada 2012 (see + -- AI-0171): + -- No_Dependence => System.Multiprocessors.Dispatching_Domains - else - Check_At_Least_N_Arguments (1); - Ada_2012_Pragma; + if Ada_Version >= Ada_2012 then + Name_Buffer (1 .. 6) := "system"; + Name_Len := 6; - -- Loop through arguments + Prefix_Entity := Make_Identifier (Loc, Name_Find); - Arg := Arg1; - while Present (Arg) loop - LocP := Sloc (Arg); + Name_Buffer (1 .. 15) := "multiprocessors"; + Name_Len := 15; + + Selector_Entity := Make_Identifier (Loc, Name_Find); + + Prefix_Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Entity, + Selector_Name => Selector_Entity); + + Name_Buffer (1 .. 19) := "dispatching_domains"; + Name_Len := 19; - -- Kind must be specified + Selector_Entity := Make_Identifier (Loc, Name_Find); - if Nkind (Arg) /= N_Pragma_Argument_Association - or else Chars (Arg) = No_Name - then - Error_Pragma_Arg - ("missing assertion kind for pragma%", Arg); - end if; + Node := + Make_Selected_Component + (Sloc => Loc, + Prefix => Prefix_Node, + Selector_Name => Selector_Entity); - -- Check Kind and Policy have allowed forms + Set_Restriction_No_Dependence + (Unit => Node, + Warn => Treat_Restrictions_As_Warnings, + Profile => Ravenscar); + end if; + end Set_Ravenscar_Profile; - Kind := Chars (Arg); + ---------------- + -- S14_Pragma -- + ---------------- - if not Is_Valid_Assertion_Kind (Kind) then - Error_Pragma_Arg - ("invalid assertion kind for pragma%", Arg); - end if; + procedure S14_Pragma is + begin + if not Formal_Extensions then + Error_Pragma ("pragma% requires the use of debug switch -gnatd.V"); + end if; + end S14_Pragma; - Check_Arg_Is_One_Of - (Arg, Name_Check, Name_Disable, Name_Ignore); + -- Start of processing for Analyze_Pragma - -- We rewrite the Assertion_Policy pragma as a series of - -- Check_Policy pragmas: + begin + -- The following code is a defense against recursion. Not clear that + -- this can happen legitimately, but perhaps some error situations + -- can cause it, and we did see this recursion during testing. - -- Check_Policy (Kind, Policy); + if Analyzed (N) then + return; + else + Set_Analyzed (N, True); + end if; - Insert_Action (N, - Make_Pragma (LocP, - Chars => Name_Check_Policy, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (LocP, - Expression => Make_Identifier (LocP, Kind)), - Make_Pragma_Argument_Association (LocP, - Expression => Get_Pragma_Arg (Arg))))); + -- Deal with unrecognized pragma - Arg := Next (Arg); - end loop; + Pname := Pragma_Name (N); - -- Rewrite the Assertion_Policy pragma as null since we have - -- now inserted all the equivalent Check pragmas. + if not Is_Pragma_Name (Pname) then + if Warn_On_Unrecognized_Pragma then + Error_Msg_Name_1 := Pname; + Error_Msg_N ("?g?unrecognized pragma%!", Pragma_Identifier (N)); - Rewrite (N, Make_Null_Statement (Loc)); - Analyze (N); - end if; - end Assertion_Policy; + for PN in First_Pragma_Name .. Last_Pragma_Name loop + if Is_Bad_Spelling_Of (Pname, PN) then + Error_Msg_Name_1 := PN; + Error_Msg_N -- CODEFIX + ("\?g?possible misspelling of %!", Pragma_Identifier (N)); + exit; + end if; + end loop; + end if; - ------------ - -- Assume -- - ------------ + return; + end if; - -- pragma Assume (boolean_EXPRESSION); + -- Here to start processing for recognized pragma - when Pragma_Assume => Assume : declare - begin - GNAT_Pragma; - S14_Pragma; - Check_Arg_Count (1); + Prag_Id := Get_Pragma_Id (Pname); + Pname := Original_Name (N); - -- Pragma Assume is transformed into pragma Check in the following - -- manner: + -- Check applicable policy. We skip this for a pragma that came from + -- an aspect, since we already dealt with the Disable case, and we set + -- the Is_Ignored flag at the time the aspect was analyzed. - -- pragma Check (Assume, Expr); + if not From_Aspect_Specification (N) then + Check_Applicable_Policy (N); - Rewrite (N, - Make_Pragma (Loc, - Chars => Name_Check, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Assume)), + -- If pragma is disabled, rewrite as NULL and skip analysis - Make_Pragma_Argument_Association (Loc, - Expression => Relocate_Node (Expression (Arg1)))))); + if Is_Disabled (N) then + Rewrite (N, Make_Null_Statement (Loc)); Analyze (N); - end Assume; + raise Pragma_Exit; + end if; + end if; - ------------------------------ - -- Assume_No_Invalid_Values -- - ------------------------------ + -- Preset arguments - -- pragma Assume_No_Invalid_Values (On | Off); + Arg_Count := 0; + Arg1 := Empty; + Arg2 := Empty; + Arg3 := Empty; + Arg4 := Empty; - when Pragma_Assume_No_Invalid_Values => - GNAT_Pragma; - Check_Valid_Configuration_Pragma; - Check_Arg_Count (1); - Check_No_Identifiers; - Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); + if Present (Pragma_Argument_Associations (N)) then + Arg_Count := List_Length (Pragma_Argument_Associations (N)); + Arg1 := First (Pragma_Argument_Associations (N)); - if Chars (Get_Pragma_Arg (Arg1)) = Name_On then - Assume_No_Invalid_Values := True; - else - Assume_No_Invalid_Values := False; + if Present (Arg1) then + Arg2 := Next (Arg1); + + if Present (Arg2) then + Arg3 := Next (Arg2); + + if Present (Arg3) then + Arg4 := Next (Arg3); + end if; end if; + end if; + end if; - -------------------------- - -- Attribute_Definition -- - -------------------------- + Check_Restriction_No_Use_Of_Pragma (N); - -- pragma Attribute_Definition - -- ([Attribute =>] ATTRIBUTE_DESIGNATOR, - -- [Entity =>] LOCAL_NAME, - -- [Expression =>] EXPRESSION | NAME); + -- An enumeration type defines the pragmas that are supported by the + -- implementation. Get_Pragma_Id (in package Prag) transforms a name + -- into the corresponding enumeration value for the following case. - when Pragma_Attribute_Definition => Attribute_Definition : declare - Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1); - Aname : Name_Id; + case Prag_Id is - begin + ----------------- + -- Abort_Defer -- + ----------------- + + -- pragma Abort_Defer; + + when Pragma_Abort_Defer => GNAT_Pragma; - Check_Arg_Count (3); - Check_Optional_Identifier (Arg1, "attribute"); - Check_Optional_Identifier (Arg2, "entity"); - Check_Optional_Identifier (Arg3, "expression"); + Check_Arg_Count (0); - if Nkind (Attribute_Designator) /= N_Identifier then - Error_Msg_N ("attribute name expected", Attribute_Designator); - return; - end if; + -- The only required semantic processing is to check the + -- placement. This pragma must appear at the start of the + -- statement sequence of a handled sequence of statements. - Check_Arg_Is_Local_Name (Arg2); + if Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements + or else N /= First (Statements (Parent (N))) + then + Pragma_Misplaced; + end if; - -- If the attribute is not recognized, then issue a warning (not - -- an error), and ignore the pragma. + -------------------- + -- Abstract_State -- + -------------------- - Aname := Chars (Attribute_Designator); + -- pragma Abstract_State (ABSTRACT_STATE_LIST) - if not Is_Attribute_Name (Aname) then - Bad_Attribute (Attribute_Designator, Aname, Warn => True); - return; - end if; + -- ABSTRACT_STATE_LIST ::= + -- null + -- | STATE_NAME_WITH_PROPERTIES {, STATE_NAME_WITH_PROPERTIES} - -- Otherwise, rewrite the pragma as an attribute definition clause + -- STATE_NAME_WITH_PROPERTIES ::= + -- STATE_NAME + -- | (STATE_NAME with PROPERTY_LIST) - Rewrite (N, - Make_Attribute_Definition_Clause (Loc, - Name => Get_Pragma_Arg (Arg2), - Chars => Aname, - Expression => Get_Pragma_Arg (Arg3))); - Analyze (N); - end Attribute_Definition; + -- PROPERTY_LIST ::= PROPERTY {, PROPERTY} + -- PROPERTY ::= SIMPLE_PROPERTY | NAME_VALUE_PROPERTY - --------------- - -- AST_Entry -- - --------------- + -- SIMPLE_PROPERTY ::= IDENTIFIER + -- NAME_VALUE_PROPERTY ::= IDENTIFIER => EXPRESSION - -- pragma AST_Entry (entry_IDENTIFIER); + -- STATE_NAME ::= DEFINING_IDENTIFIER - when Pragma_AST_Entry => AST_Entry : declare - Ent : Node_Id; + when Pragma_Abstract_State => Abstract_State : declare + Pack_Id : Entity_Id; - begin - GNAT_Pragma; - Check_VMS (N); - Check_Arg_Count (1); - Check_No_Identifiers; - Check_Arg_Is_Local_Name (Arg1); - Ent := Entity (Get_Pragma_Arg (Arg1)); + -- Flags used to verify the consistency of states - -- Note: the implementation of the AST_Entry pragma could handle - -- the entry family case fine, but for now we are consistent with - -- the DEC rules, and do not allow the pragma, which of course - -- has the effect of also forbidding the attribute. + Non_Null_Seen : Boolean := False; + Null_Seen : Boolean := False; - if Ekind (Ent) /= E_Entry then - Error_Pragma_Arg - ("pragma% argument must be simple entry name", Arg1); + procedure Analyze_Abstract_State (State : Node_Id); + -- Verify the legality of a single state declaration. Create and + -- decorate a state abstraction entity and introduce it into the + -- visibility chain. - elsif Is_AST_Entry (Ent) then - Error_Pragma_Arg - ("duplicate % pragma for entry", Arg1); + ---------------------------- + -- Analyze_Abstract_State -- + ---------------------------- - elsif Has_Homonym (Ent) then - Error_Pragma_Arg - ("pragma% argument cannot specify overloaded entry", Arg1); + procedure Analyze_Abstract_State (State : Node_Id) is + procedure Check_Duplicate_Property + (Prop : Node_Id; + Status : in out Boolean); + -- Flag Status denotes whether a particular property has been + -- seen while processing a state. This routine verifies that + -- Prop is not a duplicate property and sets the flag Status. - else - declare - FF : constant Entity_Id := First_Formal (Ent); + ------------------------------ + -- Check_Duplicate_Property -- + ------------------------------ + procedure Check_Duplicate_Property + (Prop : Node_Id; + Status : in out Boolean) + is begin - if Present (FF) then - if Present (Next_Formal (FF)) then - Error_Pragma_Arg - ("entry for pragma% can have only one argument", - Arg1); - - elsif Parameter_Mode (FF) /= E_In_Parameter then - Error_Pragma_Arg - ("entry parameter for pragma% must have mode IN", - Arg1); - end if; + if Status then + Error_Msg_N ("duplicate state property", Prop); end if; - end; - Set_Is_AST_Entry (Ent); - end if; - end AST_Entry; + Status := True; + end Check_Duplicate_Property; - ------------------ - -- Asynchronous -- - ------------------ + -- Local variables - -- pragma Asynchronous (LOCAL_NAME); + Errors : constant Nat := Serious_Errors_Detected; + Loc : constant Source_Ptr := Sloc (State); + Assoc : Node_Id; + Id : Entity_Id; + Is_Null : Boolean := False; + Level : Uint := Uint_0; + Name : Name_Id; + Prop : Node_Id; - when Pragma_Asynchronous => Asynchronous : declare - Nm : Entity_Id; - C_Ent : Entity_Id; - L : List_Id; - S : Node_Id; - N : Node_Id; - Formal : Entity_Id; + -- Flags used to verify the consistency of properties - procedure Process_Async_Pragma; - -- Common processing for procedure and access-to-procedure case + Input_Seen : Boolean := False; + Integrity_Seen : Boolean := False; + Output_Seen : Boolean := False; + Volatile_Seen : Boolean := False; - -------------------------- - -- Process_Async_Pragma -- - -------------------------- + -- Start of processing for Analyze_Abstract_State - procedure Process_Async_Pragma is begin - if No (L) then - Set_Is_Asynchronous (Nm); - return; - end if; + -- A package with a null abstract state is not allowed to + -- declare additional states. - -- The formals should be of mode IN (RM E.4.1(6)) + if Null_Seen then + Error_Msg_NE + ("package & has null abstract state", State, Pack_Id); - S := First (L); - while Present (S) loop - Formal := Defining_Identifier (S); + -- Null states appear as internally generated entities - if Nkind (Formal) = N_Defining_Identifier - and then Ekind (Formal) /= E_In_Parameter - then - Error_Pragma_Arg - ("pragma% procedure can only have IN parameter", - Arg1); - end if; + elsif Nkind (State) = N_Null then + Name := New_Internal_Name ('S'); + Is_Null := True; + Null_Seen := True; - Next (S); - end loop; + -- Catch a case where a null state appears in a list of + -- non-null states. - Set_Is_Asynchronous (Nm); - end Process_Async_Pragma; + if Non_Null_Seen then + Error_Msg_NE + ("package & has non-null abstract state", + State, Pack_Id); + end if; - -- Start of processing for pragma Asynchronous + -- Simple state declaration - begin - Check_Ada_83_Warning; - Check_No_Identifiers; - Check_Arg_Count (1); - Check_Arg_Is_Local_Name (Arg1); + elsif Nkind (State) = N_Identifier then + Name := Chars (State); + Non_Null_Seen := True; - if Debug_Flag_U then - return; - end if; + -- State declaration with various properties. This construct + -- appears as an extension aggregate in the tree. - C_Ent := Cunit_Entity (Current_Sem_Unit); - Analyze (Get_Pragma_Arg (Arg1)); - Nm := Entity (Get_Pragma_Arg (Arg1)); + elsif Nkind (State) = N_Extension_Aggregate then + if Nkind (Ancestor_Part (State)) = N_Identifier then + Name := Chars (Ancestor_Part (State)); + Non_Null_Seen := True; + else + Error_Msg_N + ("state name must be an identifier", + Ancestor_Part (State)); + end if; - if not Is_Remote_Call_Interface (C_Ent) - and then not Is_Remote_Types (C_Ent) - then - -- This pragma should only appear in an RCI or Remote Types - -- unit (RM E.4.1(4)). + -- Process properties Input, Output and Volatile. Ensure + -- that none of them appear more than once. - Error_Pragma - ("pragma% not in Remote_Call_Interface or Remote_Types unit"); - end if; + Prop := First (Expressions (State)); + while Present (Prop) loop + if Nkind (Prop) = N_Identifier then + if Chars (Prop) = Name_Input then + Check_Duplicate_Property (Prop, Input_Seen); + elsif Chars (Prop) = Name_Output then + Check_Duplicate_Property (Prop, Output_Seen); + elsif Chars (Prop) = Name_Volatile then + Check_Duplicate_Property (Prop, Volatile_Seen); + else + Error_Msg_N ("invalid state property", Prop); + end if; + else + Error_Msg_N ("invalid state property", Prop); + end if; - if Ekind (Nm) = E_Procedure - and then Nkind (Parent (Nm)) = N_Procedure_Specification - then - if not Is_Remote_Call_Interface (Nm) then - Error_Pragma_Arg - ("pragma% cannot be applied on non-remote procedure", - Arg1); - end if; + Next (Prop); + end loop; - L := Parameter_Specifications (Parent (Nm)); - Process_Async_Pragma; - return; + -- Volatile requires exactly one Input or Output - elsif Ekind (Nm) = E_Function then - Error_Pragma_Arg - ("pragma% cannot be applied to function", Arg1); + if Volatile_Seen + and then + ((Input_Seen and then Output_Seen) -- both + or else + (not Input_Seen and then not Output_Seen)) -- none + then + Error_Msg_N + ("property Volatile requires exactly one Input or " + & "Output", State); + end if; - elsif Is_Remote_Access_To_Subprogram_Type (Nm) then - if Is_Record_Type (Nm) then + -- Either Input or Output require Volatile - -- A record type that is the Equivalent_Type for a remote - -- access-to-subprogram type. + if (Input_Seen or Output_Seen) + and then not Volatile_Seen + then + Error_Msg_N + ("properties Input and Output require Volatile", State); + end if; - N := Declaration_Node (Corresponding_Remote_Type (Nm)); + -- State property Integrity appears as a component + -- association. - else - -- A non-expanded RAS type (distribution is not enabled) + Assoc := First (Component_Associations (State)); + while Present (Assoc) loop + Prop := First (Choices (Assoc)); + while Present (Prop) loop + if Nkind (Prop) = N_Identifier + and then Chars (Prop) = Name_Integrity + then + Check_Duplicate_Property (Prop, Integrity_Seen); + else + Error_Msg_N ("invalid state property", Prop); + end if; - N := Declaration_Node (Nm); - end if; + Next (Prop); + end loop; - if Nkind (N) = N_Full_Type_Declaration - and then Nkind (Type_Definition (N)) = - N_Access_Procedure_Definition - then - L := Parameter_Specifications (Type_Definition (N)); - Process_Async_Pragma; + if Nkind (Expression (Assoc)) = N_Integer_Literal then + Level := Intval (Expression (Assoc)); + else + Error_Msg_N + ("integrity level must be an integer literal", + Expression (Assoc)); + end if; - if Is_Asynchronous (Nm) - and then Expander_Active - and then Get_PCS_Name /= Name_No_DSA - then - RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm)); - end if; + Next (Assoc); + end loop; + + -- Any other attempt to declare a state is erroneous else - Error_Pragma_Arg - ("pragma% cannot reference access-to-function type", - Arg1); + Error_Msg_N ("malformed abstract state declaration", State); end if; - -- Only other possibility is Access-to-class-wide type + -- Do not generate a state abstraction entity if it was not + -- properly declared. - elsif Is_Access_Type (Nm) - and then Is_Class_Wide_Type (Designated_Type (Nm)) - then - Check_First_Subtype (Arg1); - Set_Is_Asynchronous (Nm); - if Expander_Active then - RACW_Type_Is_Asynchronous (Nm); + if Serious_Errors_Detected > Errors then + return; end if; - else - Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1); - end if; - end Asynchronous; + -- The generated state abstraction reuses the same characters + -- from the original state declaration. Decorate the entity. - ------------ - -- Atomic -- - ------------ + Id := Make_Defining_Identifier (Loc, New_External_Name (Name)); + Set_Comes_From_Source (Id, not Is_Null); + Set_Parent (Id, State); + Set_Ekind (Id, E_Abstract_State); + Set_Etype (Id, Standard_Void_Type); + Set_Integrity_Level (Id, Level); + Set_Refined_State (Id, Empty); - -- pragma Atomic (LOCAL_NAME); + -- Every non-null state must be nameable and resolvable the + -- same way a constant is. - when Pragma_Atomic => - Process_Atomic_Shared_Volatile; + if not Is_Null then + Push_Scope (Pack_Id); + Enter_Name (Id); + Pop_Scope; + end if; - ----------------------- - -- Atomic_Components -- - ----------------------- + -- Associate the state with its related package - -- pragma Atomic_Components (array_LOCAL_NAME); + if No (Abstract_States (Pack_Id)) then + Set_Abstract_States (Pack_Id, New_Elmt_List); + end if; - -- This processing is shared by Volatile_Components + Append_Elmt (Id, Abstract_States (Pack_Id)); + end Analyze_Abstract_State; - when Pragma_Atomic_Components | - Pragma_Volatile_Components => + -- Local variables - Atomic_Components : declare - E_Id : Node_Id; - E : Entity_Id; - D : Node_Id; - K : Node_Kind; + Par : Node_Id; + State : Node_Id; + + -- Start of processing for Abstract_State begin - Check_Ada_83_Warning; - Check_No_Identifiers; + GNAT_Pragma; + S14_Pragma; Check_Arg_Count (1); - Check_Arg_Is_Local_Name (Arg1); - E_Id := Get_Pragma_Arg (Arg1); - if Etype (E_Id) = Any_Type then - return; - end if; + -- Ensure the proper placement of the pragma. Abstract states must + -- be associated with a package declaration. - E := Entity (E_Id); + if From_Aspect_Specification (N) then + Par := Parent (Corresponding_Aspect (N)); + else + Par := Parent (Parent (N)); + end if; - Check_Duplicate_Pragma (E); + if Nkind (Par) = N_Compilation_Unit then + Par := Unit (Par); + end if; - if Rep_Item_Too_Early (E, N) - or else - Rep_Item_Too_Late (E, N) - then + if Nkind (Par) /= N_Package_Declaration then + Pragma_Misplaced; return; end if; - D := Declaration_Node (E); - K := Nkind (D); + Pack_Id := Defining_Entity (Par); + State := Expression (Arg1); - if (K = N_Full_Type_Declaration and then Is_Array_Type (E)) - or else - ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable) - and then Nkind (D) = N_Object_Declaration - and then Nkind (Object_Definition (D)) = - N_Constrained_Array_Definition) - then - -- The flag is set on the object, or on the base type + -- Multiple abstract states appear as an aggregate - if Nkind (D) /= N_Object_Declaration then - E := Base_Type (E); - end if; + if Nkind (State) = N_Aggregate then + State := First (Expressions (State)); + while Present (State) loop + Analyze_Abstract_State (State); - Set_Has_Volatile_Components (E); + Next (State); + end loop; - if Prag_Id = Pragma_Atomic_Components then - Set_Has_Atomic_Components (E); - end if; + -- Various forms of a single abstract state. Note that these may + -- include malformed state declarations. else - Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); + Analyze_Abstract_State (State); end if; - end Atomic_Components; + end Abstract_State; - -------------------- - -- Attach_Handler -- - -------------------- + ------------ + -- Ada_83 -- + ------------ - -- pragma Attach_Handler (handler_NAME, EXPRESSION); + -- pragma Ada_83; - when Pragma_Attach_Handler => - Check_Ada_83_Warning; - Check_No_Identifiers; - Check_Arg_Count (2); + -- Note: this pragma also has some specific processing in Par.Prag + -- because we want to set the Ada version mode during parsing. - if No_Run_Time_Mode then - Error_Msg_CRT ("Attach_Handler pragma", N); - else - Check_Interrupt_Or_Attach_Handler; + when Pragma_Ada_83 => + GNAT_Pragma; + Check_Arg_Count (0); - -- The expression that designates the attribute may depend on a - -- discriminant, and is therefore a per-object expression, to - -- be expanded in the init proc. If expansion is enabled, then - -- perform semantic checks on a copy only. + -- We really should check unconditionally for proper configuration + -- pragma placement, since we really don't want mixed Ada modes + -- within a single unit, and the GNAT reference manual has always + -- said this was a configuration pragma, but we did not check and + -- are hesitant to add the check now. - if Expander_Active then - declare - Temp : constant Node_Id := - New_Copy_Tree (Get_Pragma_Arg (Arg2)); - begin - Set_Parent (Temp, N); - Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); - end; + -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012 + -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005 + -- or Ada 2012 mode. - else - Analyze (Get_Pragma_Arg (Arg2)); - Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID)); - end if; + if Ada_Version >= Ada_2005 then + Check_Valid_Configuration_Pragma; + end if; - Process_Interrupt_Or_Attach_Handler; + -- Now set Ada 83 mode + + Ada_Version := Ada_83; + Ada_Version_Explicit := Ada_Version; + + ------------ + -- Ada_95 -- + ------------ + + -- pragma Ada_95; + + -- Note: this pragma also has some specific processing in Par.Prag + -- because we want to set the Ada 83 version mode during parsing. + + when Pragma_Ada_95 => + GNAT_Pragma; + Check_Arg_Count (0); + + -- We really should check unconditionally for proper configuration + -- pragma placement, since we really don't want mixed Ada modes + -- within a single unit, and the GNAT reference manual has always + -- said this was a configuration pragma, but we did not check and + -- are hesitant to add the check now. + + -- However, we really cannot tolerate mixing Ada 2005 with Ada 83 + -- or Ada 95, so we must check if we are in Ada 2005 mode. + + if Ada_Version >= Ada_2005 then + Check_Valid_Configuration_Pragma; end if; - -------------------- - -- C_Pass_By_Copy -- - -------------------- + -- Now set Ada 95 mode - -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION); + Ada_Version := Ada_95; + Ada_Version_Explicit := Ada_Version; - when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare - Arg : Node_Id; - Val : Uint; + --------------------- + -- Ada_05/Ada_2005 -- + --------------------- + + -- pragma Ada_05; + -- pragma Ada_05 (LOCAL_NAME); + + -- pragma Ada_2005; + -- pragma Ada_2005 (LOCAL_NAME): + + -- Note: these pragmas also have some specific processing in Par.Prag + -- because we want to set the Ada 2005 version mode during parsing. + + when Pragma_Ada_05 | Pragma_Ada_2005 => declare + E_Id : Node_Id; begin GNAT_Pragma; - Check_Valid_Configuration_Pragma; - Check_Arg_Count (1); - Check_Optional_Identifier (Arg1, "max_size"); - Arg := Get_Pragma_Arg (Arg1); - Check_Arg_Is_Static_Expression (Arg, Any_Integer); + if Arg_Count = 1 then + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); - Val := Expr_Value (Arg); + if Etype (E_Id) = Any_Type then + return; + end if; - if Val <= 0 then - Error_Pragma_Arg - ("maximum size for pragma% must be positive", Arg1); + Set_Is_Ada_2005_Only (Entity (E_Id)); + Record_Rep_Item (Entity (E_Id), N); - elsif UI_Is_In_Int_Range (Val) then - Default_C_Record_Mechanism := UI_To_Int (Val); + else + Check_Arg_Count (0); - -- If a giant value is given, Int'Last will do well enough. - -- If sometime someone complains that a record larger than - -- two gigabytes is not copied, we will worry about it then! + -- For Ada_2005 we unconditionally enforce the documented + -- configuration pragma placement, since we do not want to + -- tolerate mixed modes in a unit involving Ada 2005. That + -- would cause real difficulties for those cases where there + -- are incompatibilities between Ada 95 and Ada 2005. - else - Default_C_Record_Mechanism := Mechanism_Type'Last; - end if; - end C_Pass_By_Copy; + Check_Valid_Configuration_Pragma; - ----------- - -- Check -- - ----------- + -- Now set appropriate Ada mode + + Ada_Version := Ada_2005; + Ada_Version_Explicit := Ada_2005; + end if; + end; - -- pragma Check ([Name =>] CHECK_KIND, - -- [Check =>] Boolean_EXPRESSION - -- [,[Message =>] String_EXPRESSION]); + --------------------- + -- Ada_12/Ada_2012 -- + --------------------- - -- CHECK_KIND ::= IDENTIFIER | - -- Pre'Class | - -- Post'Class | - -- Invariant'Class | - -- Type_Invariant'Class + -- pragma Ada_12; + -- pragma Ada_12 (LOCAL_NAME); - -- The identifiers Assertions and Statement_Assertions are not - -- allowed, since they have special meaning for Check_Policy. + -- pragma Ada_2012; + -- pragma Ada_2012 (LOCAL_NAME): - when Pragma_Check => Check : declare - Expr : Node_Id; - Eloc : Source_Ptr; - Cname : Name_Id; - Str : Node_Id; + -- Note: these pragmas also have some specific processing in Par.Prag + -- because we want to set the Ada 2012 version mode during parsing. - Check_On : Boolean; - -- Set True if category of assertions referenced by Name enabled + when Pragma_Ada_12 | Pragma_Ada_2012 => declare + E_Id : Node_Id; begin GNAT_Pragma; - Check_At_Least_N_Arguments (2); - Check_At_Most_N_Arguments (3); - Check_Optional_Identifier (Arg1, Name_Name); - Check_Optional_Identifier (Arg2, Name_Check); - if Arg_Count = 3 then - Check_Optional_Identifier (Arg3, Name_Message); - Str := Get_Pragma_Arg (Arg3); - end if; - - Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1)); - Check_Arg_Is_Identifier (Arg1); - Cname := Chars (Get_Pragma_Arg (Arg1)); + if Arg_Count = 1 then + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); - -- Check forbidden name Assertions or Statement_Assertions + if Etype (E_Id) = Any_Type then + return; + end if; - case Cname is - when Name_Assertions => - Error_Pragma_Arg - ("""Assertions"" is not allowed as a check kind " - & "for pragma%", Arg1); + Set_Is_Ada_2012_Only (Entity (E_Id)); + Record_Rep_Item (Entity (E_Id), N); - when Name_Statement_Assertions => - Error_Pragma_Arg - ("""Statement_Assertions"" is not allowed as a check kind " - & "for pragma%", Arg1); + else + Check_Arg_Count (0); - when others => - null; - end case; + -- For Ada_2012 we unconditionally enforce the documented + -- configuration pragma placement, since we do not want to + -- tolerate mixed modes in a unit involving Ada 2012. That + -- would cause real difficulties for those cases where there + -- are incompatibilities between Ada 95 and Ada 2012. We could + -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it. - -- Set Check_On to indicate check status + Check_Valid_Configuration_Pragma; - -- If this comes from an aspect, we have already taken care of - -- the policy active when the aspect was analyzed, and Is_Ignored - -- is set appropriately already. + -- Now set appropriate Ada mode - if From_Aspect_Specification (N) then - Check_On := not Is_Ignored (N); + Ada_Version := Ada_2012; + Ada_Version_Explicit := Ada_2012; + end if; + end; - -- Otherwise check the status right now + ---------------------- + -- All_Calls_Remote -- + ---------------------- - else - case Check_Kind (Cname) is - when Name_Ignore => - Check_On := False; + -- pragma All_Calls_Remote [(library_package_NAME)]; - when Name_Check => - Check_On := True; + when Pragma_All_Calls_Remote => All_Calls_Remote : declare + Lib_Entity : Entity_Id; - -- For disable, rewrite pragma as null statement and skip - -- rest of the analysis of the pragma. + begin + Check_Ada_83_Warning; + Check_Valid_Library_Unit_Pragma; - when Name_Disable => - Rewrite (N, Make_Null_Statement (Loc)); - Analyze (N); - raise Pragma_Exit; + if Nkind (N) = N_Null_Statement then + return; + end if; - -- No other possibilities + Lib_Entity := Find_Lib_Unit_Name; - when others => - raise Program_Error; - end case; - end if; + -- This pragma should only apply to a RCI unit (RM E.2.3(23)) - -- If check kind was not Disable, then continue pragma analysis + if Present (Lib_Entity) + and then not Debug_Flag_U + then + if not Is_Remote_Call_Interface (Lib_Entity) then + Error_Pragma ("pragma% only apply to rci unit"); - Expr := Get_Pragma_Arg (Arg2); + -- Set flag for entity of the library unit - -- Deal with SCO generation + else + Set_Has_All_Calls_Remote (Lib_Entity); + end if; - case Cname is - when Name_Predicate | - Name_Invariant => + end if; + end All_Calls_Remote; - -- Nothing to do: since checks occur in client units, - -- the SCO for the aspect in the declaration unit is - -- conservatively always enabled. + -------------- + -- Annotate -- + -------------- - null; + -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]); + -- ARG ::= NAME | EXPRESSION - when others => + -- The first two arguments are by convention intended to refer to an + -- external tool and a tool-specific function. These arguments are + -- not analyzed. - if Check_On and then not Split_PPC (N) then + when Pragma_Annotate => Annotate : declare + Arg : Node_Id; + Exp : Node_Id; - -- Mark pragma/aspect SCO as enabled + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_Arg_Is_Identifier (Arg1); + Check_No_Identifiers; + Store_Note (N); - Set_SCO_Pragma_Enabled (Loc); - end if; - end case; + -- Second parameter is optional, it is never analyzed - -- Deal with analyzing the string argument. + if No (Arg2) then + null; - if Arg_Count = 3 then + -- Here if we have a second parameter - -- If checks are not on we don't want any expansion (since - -- such expansion would not get properly deleted) but - -- we do want to analyze (to get proper references). - -- The Preanalyze_And_Resolve routine does just what we want + else + -- Second parameter must be identifier - if not Check_On then - Preanalyze_And_Resolve (Str, Standard_String); + Check_Arg_Is_Identifier (Arg2); - -- Otherwise we need a proper analysis and expansion + -- Process remaining parameters if any - else - Analyze_And_Resolve (Str, Standard_String); - end if; - end if; + Arg := Next (Arg2); + while Present (Arg) loop + Exp := Get_Pragma_Arg (Arg); + Analyze (Exp); - -- Now you might think we could just do the same with the Boolean - -- expression if checks are off (and expansion is on) and then - -- rewrite the check as a null statement. This would work but we - -- would lose the useful warnings about an assertion being bound - -- to fail even if assertions are turned off. + if Is_Entity_Name (Exp) then + null; - -- So instead we wrap the boolean expression in an if statement - -- that looks like: + -- For string literals, we assume Standard_String as the + -- type, unless the string contains wide or wide_wide + -- characters. - -- if False and then condition then - -- null; - -- end if; + elsif Nkind (Exp) = N_String_Literal then + if Has_Wide_Wide_Character (Exp) then + Resolve (Exp, Standard_Wide_Wide_String); + elsif Has_Wide_Character (Exp) then + Resolve (Exp, Standard_Wide_String); + else + Resolve (Exp, Standard_String); + end if; - -- The reason we do this rewriting during semantic analysis - -- rather than as part of normal expansion is that we cannot - -- analyze and expand the code for the boolean expression - -- directly, or it may cause insertion of actions that would - -- escape the attempt to suppress the check code. + elsif Is_Overloaded (Exp) then + Error_Pragma_Arg + ("ambiguous argument for pragma%", Exp); - -- Note that the Sloc for the if statement corresponds to the - -- argument condition, not the pragma itself. The reason for - -- this is that we may generate a warning if the condition is - -- False at compile time, and we do not want to delete this - -- warning when we delete the if statement. + else + Resolve (Exp); + end if; - if Expander_Active and not Check_On then - Eloc := Sloc (Expr); + Next (Arg); + end loop; + end if; + end Annotate; - Rewrite (N, - Make_If_Statement (Eloc, - Condition => - Make_And_Then (Eloc, - Left_Opnd => New_Occurrence_Of (Standard_False, Eloc), - Right_Opnd => Expr), - Then_Statements => New_List ( - Make_Null_Statement (Eloc)))); + --------------------------- + -- Assert/Assert_And_Cut -- + --------------------------- - In_Assertion_Expr := In_Assertion_Expr + 1; - Analyze (N); - In_Assertion_Expr := In_Assertion_Expr - 1; + -- pragma Assert + -- ( [Check => ] Boolean_EXPRESSION + -- [, [Message =>] Static_String_EXPRESSION]); - -- Check is active or expansion not active. In these cases we can - -- just go ahead and analyze the boolean with no worries. + -- pragma Assert_And_Cut + -- ( [Check => ] Boolean_EXPRESSION + -- [, [Message =>] Static_String_EXPRESSION]); - else - In_Assertion_Expr := In_Assertion_Expr + 1; - Analyze_And_Resolve (Expr, Any_Boolean); - In_Assertion_Expr := In_Assertion_Expr - 1; + when Pragma_Assert | Pragma_Assert_And_Cut => Assert : declare + Expr : Node_Id; + Newa : List_Id; + + begin + if Prag_Id = Pragma_Assert then + Ada_2005_Pragma; + else -- Pragma_Assert_And_Cut + GNAT_Pragma; + S14_Pragma; end if; - end Check; - -------------------------- - -- Check_Float_Overflow -- - -------------------------- + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); + Check_Arg_Order ((Name_Check, Name_Message)); + Check_Optional_Identifier (Arg1, Name_Check); - -- pragma Check_Float_Overflow; + -- We treat pragma Assert[_And_Cut] as equivalent to: - when Pragma_Check_Float_Overflow => - GNAT_Pragma; - Check_Valid_Configuration_Pragma; - Check_Arg_Count (0); - Check_Float_Overflow := True; + -- pragma Check (Assert[_And_Cut], condition [, msg]); - ---------------- - -- Check_Name -- - ---------------- + -- So rewrite pragma in this manner, transfer the message + -- argument if present, and analyze the result - -- pragma Check_Name (check_IDENTIFIER); + -- Pragma Assert_And_Cut is treated exactly like pragma Assert by + -- the frontend. Formal verification tools may use it to "cut" the + -- paths through the code, to make verification tractable. When + -- dealing with a semantically analyzed tree, the information that + -- a Check node N corresponds to a source Assert_And_Cut pragma + -- can be retrieved from the pragma kind of Original_Node(N). - when Pragma_Check_Name => - Check_No_Identifiers; - GNAT_Pragma; - Check_Valid_Configuration_Pragma; - Check_Arg_Count (1); - Check_Arg_Is_Identifier (Arg1); + Expr := Get_Pragma_Arg (Arg1); + Newa := New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Pname)), + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Expr)); - declare - Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); + if Arg_Count > 1 then + Check_Optional_Identifier (Arg2, Name_Message); + Append_To (Newa, New_Copy_Tree (Arg2)); + end if; - begin - for J in Check_Names.First .. Check_Names.Last loop - if Check_Names.Table (J) = Nam then - return; - end if; - end loop; + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => Newa)); + Analyze (N); + end Assert; - Check_Names.Append (Nam); - end; + ---------------------- + -- Assertion_Policy -- + ---------------------- - ------------------ - -- Check_Policy -- - ------------------ + -- pragma Assertion_Policy (POLICY_IDENTIFIER); - -- This is the old style syntax, which is still allowed in all modes: + -- The following form is Ada 2012 only, but we allow it in all modes - -- pragma Check_Policy ([Name =>] CHECK_KIND - -- [Policy =>] POLICY_IDENTIFIER); + -- Pragma Assertion_Policy ( + -- ASSERTION_KIND => POLICY_IDENTIFIER + -- {, ASSERTION_KIND => POLICY_IDENTIFIER}); - -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore + -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND - -- CHECK_KIND ::= IDENTIFIER | - -- Pre'Class | - -- Post'Class | - -- Type_Invariant'Class | - -- Invariant'Class + -- RM_ASSERTION_KIND ::= Assert | + -- Static_Predicate | + -- Dynamic_Predicate | + -- Pre | + -- Pre'Class | + -- Post | + -- Post'Class | + -- Type_Invariant | + -- Type_Invariant'Class - -- This is the new style syntax, compatible with Assertion_Policy - -- and also allowed in all modes. + -- ID_ASSERTION_KIND ::= Assert_And_Cut | + -- Assume | + -- Contract_Cases | + -- Debug | + -- Loop_Invariant | + -- Loop_Variant | + -- Postcondition | + -- Precondition | + -- Predicate | + -- Statement_Assertions + -- + -- Note: The RM_ASSERTION_KIND list is language-defined, and the + -- ID_ASSERTION_KIND list contains implementation-defined additions + -- recognized by GNAT. The effect is to control the behavior of + -- identically named aspects and pragmas, depending on the specified + -- policy identifier: - -- Pragma Check_Policy ( - -- CHECK_KIND => POLICY_IDENTIFIER - -- {, CHECK_KIND => POLICY_IDENTIFIER}); + -- POLICY_IDENTIFIER ::= Check | Disable | Ignore - -- Note: the identifiers Name and Policy are not allowed as - -- Check_Kind values. This avoids ambiguities between the old and - -- new form syntax. + -- Note: Check and Ignore are language-defined. Disable is a GNAT + -- implementation defined addition that results in totally ignoring + -- the corresponding assertion. If Disable is specified, then the + -- argument of the assertion is not even analyzed. This is useful + -- when the aspect/pragma argument references entities in a with'ed + -- package that is replaced by a dummy package in the final build. - when Pragma_Check_Policy => Check_Policy : declare - Kind : Node_Id; + -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class, + -- and Type_Invariant'Class were recognized by the parser and + -- transformed into references to the special internal identifiers + -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special + -- processing is required here. + + when Pragma_Assertion_Policy => Assertion_Policy : declare + LocP : Source_Ptr; + Policy : Node_Id; + Arg : Node_Id; + Kind : Name_Id; begin - GNAT_Pragma; - Check_At_Least_N_Arguments (1); + Ada_2005_Pragma; - -- A Check_Policy pragma can appear either as a configuration - -- pragma, or in a declarative part or a package spec (see RM - -- 11.5(5) for rules for Suppress/Unsuppress which are also - -- followed for Check_Policy). + -- This can always appear as a configuration pragma - if not Is_Configuration_Pragma then + if Is_Configuration_Pragma then + null; + + -- It can also appear in a declarative part or package spec in Ada + -- 2012 mode. We allow this in other modes, but in that case we + -- consider that we have an Ada 2012 pragma on our hands. + + else Check_Is_In_Decl_Part_Or_Package_Spec; + Ada_2012_Pragma; end if; - -- Figure out if we have the old or new syntax. We have the - -- old syntax if the first argument has no identifier, or the - -- identifier is Name. + -- One argument case with no identifier (first form above) - if Nkind (Arg1) /= N_Pragma_Argument_Association - or else Nam_In (Chars (Arg1), No_Name, Name_Name) + if Arg_Count = 1 + and then (Nkind (Arg1) /= N_Pragma_Argument_Association + or else Chars (Arg1) = No_Name) then - -- Old syntax - - Check_Arg_Count (2); - Check_Optional_Identifier (Arg1, Name_Name); - Kind := Get_Pragma_Arg (Arg1); - Rewrite_Assertion_Kind (Kind); - Check_Arg_Is_Identifier (Arg1); - - -- Check forbidden check kind - - if Nam_In (Chars (Kind), Name_Name, Name_Policy) then - Error_Msg_Name_2 := Chars (Kind); - Error_Pragma_Arg - ("pragma% does not allow% as check name", Arg1); - end if; - - -- Check policy - - Check_Optional_Identifier (Arg2, Name_Policy); Check_Arg_Is_One_Of - (Arg2, - Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore); - - -- And chain pragma on the Check_Policy_List for search - - Set_Next_Pragma (N, Opt.Check_Policy_List); - Opt.Check_Policy_List := N; + (Arg1, Name_Check, Name_Disable, Name_Ignore); - -- For the new syntax, what we do is to convert each argument to - -- an old syntax equivalent. We do that because we want to chain - -- old style Check_Policy pragmas for the search (we don't want - -- to have to deal with multiple arguments in the search). + -- Treat one argument Assertion_Policy as equivalent to: - else - declare - Arg : Node_Id; - Argx : Node_Id; - LocP : Source_Ptr; + -- pragma Check_Policy (Assertion, policy) - begin - Arg := Arg1; - while Present (Arg) loop - LocP := Sloc (Arg); - Argx := Get_Pragma_Arg (Arg); + -- So rewrite pragma in that manner and link on to the chain + -- of Check_Policy pragmas, marking the pragma as analyzed. - -- Kind must be specified + Policy := Get_Pragma_Arg (Arg1); - if Nkind (Arg) /= N_Pragma_Argument_Association - or else Chars (Arg) = No_Name - then - Error_Pragma_Arg - ("missing assertion kind for pragma%", Arg); - end if; + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check_Policy, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Assertion)), - -- Construct equivalent old form syntax Check_Policy - -- pragma and insert it to get remaining checks. + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Sloc (Policy), Chars (Policy)))))); + Analyze (N); - Insert_Action (N, - Make_Pragma (LocP, - Chars => Name_Check_Policy, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (LocP, - Expression => - Make_Identifier (LocP, Chars (Arg))), - Make_Pragma_Argument_Association (Sloc (Argx), - Expression => Argx)))); + -- Here if we have two or more arguments - Arg := Next (Arg); - end loop; + else + Check_At_Least_N_Arguments (1); + Ada_2012_Pragma; - -- Rewrite original Check_Policy pragma to null, since we - -- have converted it into a series of old syntax pragmas. + -- Loop through arguments - Rewrite (N, Make_Null_Statement (Loc)); - Analyze (N); - end; - end if; - end Check_Policy; + Arg := Arg1; + while Present (Arg) loop + LocP := Sloc (Arg); - --------------------- - -- CIL_Constructor -- - --------------------- + -- Kind must be specified - -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME); + if Nkind (Arg) /= N_Pragma_Argument_Association + or else Chars (Arg) = No_Name + then + Error_Pragma_Arg + ("missing assertion kind for pragma%", Arg); + end if; - -- Processing for this pragma is shared with Java_Constructor + -- Check Kind and Policy have allowed forms - ------------- - -- Comment -- - ------------- + Kind := Chars (Arg); - -- pragma Comment (static_string_EXPRESSION) + if not Is_Valid_Assertion_Kind (Kind) then + Error_Pragma_Arg + ("invalid assertion kind for pragma%", Arg); + end if; - -- Processing for pragma Comment shares the circuitry for pragma - -- Ident. The only differences are that Ident enforces a limit of 31 - -- characters on its argument, and also enforces limitations on - -- placement for DEC compatibility. Pragma Comment shares neither of - -- these restrictions. + Check_Arg_Is_One_Of + (Arg, Name_Check, Name_Disable, Name_Ignore); - ------------------- - -- Common_Object -- - ------------------- + -- We rewrite the Assertion_Policy pragma as a series of + -- Check_Policy pragmas: - -- pragma Common_Object ( - -- [Internal =>] LOCAL_NAME - -- [, [External =>] EXTERNAL_SYMBOL] - -- [, [Size =>] EXTERNAL_SYMBOL]); + -- Check_Policy (Kind, Policy); - -- Processing for this pragma is shared with Psect_Object + Insert_Action (N, + Make_Pragma (LocP, + Chars => Name_Check_Policy, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (LocP, + Expression => Make_Identifier (LocP, Kind)), + Make_Pragma_Argument_Association (LocP, + Expression => Get_Pragma_Arg (Arg))))); - ------------------------ - -- Compile_Time_Error -- - ------------------------ + Arg := Next (Arg); + end loop; - -- pragma Compile_Time_Error - -- (boolean_EXPRESSION, static_string_EXPRESSION); + -- Rewrite the Assertion_Policy pragma as null since we have + -- now inserted all the equivalent Check pragmas. - when Pragma_Compile_Time_Error => - GNAT_Pragma; - Process_Compile_Time_Warning_Or_Error; + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + end if; + end Assertion_Policy; - -------------------------- - -- Compile_Time_Warning -- - -------------------------- + ------------ + -- Assume -- + ------------ - -- pragma Compile_Time_Warning - -- (boolean_EXPRESSION, static_string_EXPRESSION); + -- pragma Assume (boolean_EXPRESSION); - when Pragma_Compile_Time_Warning => + when Pragma_Assume => Assume : declare + begin GNAT_Pragma; - Process_Compile_Time_Warning_Or_Error; + S14_Pragma; + Check_Arg_Count (1); - ------------------- - -- Compiler_Unit -- - ------------------- + -- Pragma Assume is transformed into pragma Check in the following + -- manner: - when Pragma_Compiler_Unit => - GNAT_Pragma; - Check_Arg_Count (0); - Set_Is_Compiler_Unit (Get_Source_Unit (N)); + -- pragma Check (Assume, Expr); - ----------------------------- - -- Complete_Representation -- - ----------------------------- + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Assume)), - -- pragma Complete_Representation; + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expression (Arg1)))))); + Analyze (N); + end Assume; - when Pragma_Complete_Representation => + ------------------------------ + -- Assume_No_Invalid_Values -- + ------------------------------ + + -- pragma Assume_No_Invalid_Values (On | Off); + + when Pragma_Assume_No_Invalid_Values => GNAT_Pragma; - Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); - if Nkind (Parent (N)) /= N_Record_Representation_Clause then - Error_Pragma - ("pragma & must appear within record representation clause"); + if Chars (Get_Pragma_Arg (Arg1)) = Name_On then + Assume_No_Invalid_Values := True; + else + Assume_No_Invalid_Values := False; end if; - ---------------------------- - -- Complex_Representation -- - ---------------------------- + -------------------------- + -- Attribute_Definition -- + -------------------------- - -- pragma Complex_Representation ([Entity =>] LOCAL_NAME); + -- pragma Attribute_Definition + -- ([Attribute =>] ATTRIBUTE_DESIGNATOR, + -- [Entity =>] LOCAL_NAME, + -- [Expression =>] EXPRESSION | NAME); - when Pragma_Complex_Representation => Complex_Representation : declare - E_Id : Entity_Id; - E : Entity_Id; - Ent : Entity_Id; + when Pragma_Attribute_Definition => Attribute_Definition : declare + Attribute_Designator : constant Node_Id := Get_Pragma_Arg (Arg1); + Aname : Name_Id; begin GNAT_Pragma; - Check_Arg_Count (1); - Check_Optional_Identifier (Arg1, Name_Entity); - Check_Arg_Is_Local_Name (Arg1); - E_Id := Get_Pragma_Arg (Arg1); + Check_Arg_Count (3); + Check_Optional_Identifier (Arg1, "attribute"); + Check_Optional_Identifier (Arg2, "entity"); + Check_Optional_Identifier (Arg3, "expression"); - if Etype (E_Id) = Any_Type then + if Nkind (Attribute_Designator) /= N_Identifier then + Error_Msg_N ("attribute name expected", Attribute_Designator); return; end if; - E := Entity (E_Id); - - if not Is_Record_Type (E) then - Error_Pragma_Arg - ("argument for pragma% must be record type", Arg1); - end if; - - Ent := First_Entity (E); - - if No (Ent) - or else No (Next_Entity (Ent)) - or else Present (Next_Entity (Next_Entity (Ent))) - or else not Is_Floating_Point_Type (Etype (Ent)) - or else Etype (Ent) /= Etype (Next_Entity (Ent)) - then - Error_Pragma_Arg - ("record for pragma% must have two fields of the same " - & "floating-point type", Arg1); + Check_Arg_Is_Local_Name (Arg2); - else - Set_Has_Complex_Representation (Base_Type (E)); + -- If the attribute is not recognized, then issue a warning (not + -- an error), and ignore the pragma. - -- We need to treat the type has having a non-standard - -- representation, for back-end purposes, even though in - -- general a complex will have the default representation - -- of a record with two real components. + Aname := Chars (Attribute_Designator); - Set_Has_Non_Standard_Rep (Base_Type (E)); + if not Is_Attribute_Name (Aname) then + Bad_Attribute (Attribute_Designator, Aname, Warn => True); + return; end if; - end Complex_Representation; - ------------------------- - -- Component_Alignment -- - ------------------------- + -- Otherwise, rewrite the pragma as an attribute definition clause - -- pragma Component_Alignment ( - -- [Form =>] ALIGNMENT_CHOICE - -- [, [Name =>] type_LOCAL_NAME]); - -- - -- ALIGNMENT_CHOICE ::= - -- Component_Size - -- | Component_Size_4 - -- | Storage_Unit - -- | Default + Rewrite (N, + Make_Attribute_Definition_Clause (Loc, + Name => Get_Pragma_Arg (Arg2), + Chars => Aname, + Expression => Get_Pragma_Arg (Arg3))); + Analyze (N); + end Attribute_Definition; - when Pragma_Component_Alignment => Component_AlignmentP : declare - Args : Args_List (1 .. 2); - Names : constant Name_List (1 .. 2) := ( - Name_Form, - Name_Name); + --------------- + -- AST_Entry -- + --------------- - Form : Node_Id renames Args (1); - Name : Node_Id renames Args (2); + -- pragma AST_Entry (entry_IDENTIFIER); - Atype : Component_Alignment_Kind; - Typ : Entity_Id; + when Pragma_AST_Entry => AST_Entry : declare + Ent : Node_Id; begin GNAT_Pragma; - Gather_Associations (Names, Args); - - if No (Form) then - Error_Pragma ("missing Form argument for pragma%"); - end if; + Check_VMS (N); + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_Local_Name (Arg1); + Ent := Entity (Get_Pragma_Arg (Arg1)); - Check_Arg_Is_Identifier (Form); + -- Note: the implementation of the AST_Entry pragma could handle + -- the entry family case fine, but for now we are consistent with + -- the DEC rules, and do not allow the pragma, which of course + -- has the effect of also forbidding the attribute. - -- Get proper alignment, note that Default = Component_Size on all - -- machines we have so far, and we want to set this value rather - -- than the default value to indicate that it has been explicitly - -- set (and thus will not get overridden by the default component - -- alignment for the current scope) + if Ekind (Ent) /= E_Entry then + Error_Pragma_Arg + ("pragma% argument must be simple entry name", Arg1); - if Chars (Form) = Name_Component_Size then - Atype := Calign_Component_Size; + elsif Is_AST_Entry (Ent) then + Error_Pragma_Arg + ("duplicate % pragma for entry", Arg1); - elsif Chars (Form) = Name_Component_Size_4 then - Atype := Calign_Component_Size_4; + elsif Has_Homonym (Ent) then + Error_Pragma_Arg + ("pragma% argument cannot specify overloaded entry", Arg1); - elsif Chars (Form) = Name_Default then - Atype := Calign_Component_Size; + else + declare + FF : constant Entity_Id := First_Formal (Ent); - elsif Chars (Form) = Name_Storage_Unit then - Atype := Calign_Storage_Unit; + begin + if Present (FF) then + if Present (Next_Formal (FF)) then + Error_Pragma_Arg + ("entry for pragma% can have only one argument", + Arg1); - else - Error_Pragma_Arg - ("invalid Form parameter for pragma%", Form); + elsif Parameter_Mode (FF) /= E_In_Parameter then + Error_Pragma_Arg + ("entry parameter for pragma% must have mode IN", + Arg1); + end if; + end if; + end; + + Set_Is_AST_Entry (Ent); end if; + end AST_Entry; - -- Case with no name, supplied, affects scope table entry + ------------------ + -- Asynchronous -- + ------------------ - if No (Name) then - Scope_Stack.Table - (Scope_Stack.Last).Component_Alignment_Default := Atype; + -- pragma Asynchronous (LOCAL_NAME); - -- Case of name supplied + when Pragma_Asynchronous => Asynchronous : declare + Nm : Entity_Id; + C_Ent : Entity_Id; + L : List_Id; + S : Node_Id; + N : Node_Id; + Formal : Entity_Id; - else - Check_Arg_Is_Local_Name (Name); - Find_Type (Name); - Typ := Entity (Name); + procedure Process_Async_Pragma; + -- Common processing for procedure and access-to-procedure case - if Typ = Any_Type - or else Rep_Item_Too_Early (Typ, N) - then + -------------------------- + -- Process_Async_Pragma -- + -------------------------- + + procedure Process_Async_Pragma is + begin + if No (L) then + Set_Is_Asynchronous (Nm); return; - else - Typ := Underlying_Type (Typ); end if; - if not Is_Record_Type (Typ) - and then not Is_Array_Type (Typ) - then - Error_Pragma_Arg - ("Name parameter of pragma% must identify record or " - & "array type", Name); - end if; + -- The formals should be of mode IN (RM E.4.1(6)) - -- An explicit Component_Alignment pragma overrides an - -- implicit pragma Pack, but not an explicit one. + S := First (L); + while Present (S) loop + Formal := Defining_Identifier (S); - if not Has_Pragma_Pack (Base_Type (Typ)) then - Set_Is_Packed (Base_Type (Typ), False); - Set_Component_Alignment (Base_Type (Typ), Atype); - end if; - end if; - end Component_AlignmentP; + if Nkind (Formal) = N_Defining_Identifier + and then Ekind (Formal) /= E_In_Parameter + then + Error_Pragma_Arg + ("pragma% procedure can only have IN parameter", + Arg1); + end if; - -------------------- - -- Contract_Cases -- - -------------------- + Next (S); + end loop; - -- pragma Contract_Cases (CONTRACT_CASE_LIST); + Set_Is_Asynchronous (Nm); + end Process_Async_Pragma; - -- CONTRACT_CASE_LIST ::= CONTRACT_CASE {, CONTRACT_CASE} + -- Start of processing for pragma Asynchronous - -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE + begin + Check_Ada_83_Warning; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); - -- CASE_GUARD ::= boolean_EXPRESSION | others + if Debug_Flag_U then + return; + end if; - -- CONSEQUENCE ::= boolean_EXPRESSION + C_Ent := Cunit_Entity (Current_Sem_Unit); + Analyze (Get_Pragma_Arg (Arg1)); + Nm := Entity (Get_Pragma_Arg (Arg1)); - when Pragma_Contract_Cases => Contract_Cases : declare - Others_Seen : Boolean := False; + if not Is_Remote_Call_Interface (C_Ent) + and then not Is_Remote_Types (C_Ent) + then + -- This pragma should only appear in an RCI or Remote Types + -- unit (RM E.4.1(4)). - procedure Analyze_Contract_Case (Contract_Case : Node_Id); - -- Verify the legality of a single contract case + Error_Pragma + ("pragma% not in Remote_Call_Interface or Remote_Types unit"); + end if; - procedure Chain_Contract_Cases (Subp_Id : Entity_Id); - -- Chain pragma Contract_Cases to the contract of a subprogram. - -- Subp_Id is the related subprogram. + if Ekind (Nm) = E_Procedure + and then Nkind (Parent (Nm)) = N_Procedure_Specification + then + if not Is_Remote_Call_Interface (Nm) then + Error_Pragma_Arg + ("pragma% cannot be applied on non-remote procedure", + Arg1); + end if; - --------------------------- - -- Analyze_Contract_Case -- - --------------------------- + L := Parameter_Specifications (Parent (Nm)); + Process_Async_Pragma; + return; - procedure Analyze_Contract_Case (Contract_Case : Node_Id) is - Case_Guard : Node_Id; - Extra_Guard : Node_Id; + elsif Ekind (Nm) = E_Function then + Error_Pragma_Arg + ("pragma% cannot be applied to function", Arg1); - begin - if Nkind (Contract_Case) = N_Component_Association then - Case_Guard := First (Choices (Contract_Case)); + elsif Is_Remote_Access_To_Subprogram_Type (Nm) then + if Is_Record_Type (Nm) then - -- Each contract case must have exactly on case guard + -- A record type that is the Equivalent_Type for a remote + -- access-to-subprogram type. - Extra_Guard := Next (Case_Guard); + N := Declaration_Node (Corresponding_Remote_Type (Nm)); - if Present (Extra_Guard) then - Error_Pragma_Arg - ("contract case may have only one case guard", - Extra_Guard); - end if; + else + -- A non-expanded RAS type (distribution is not enabled) - -- Check the placement of "others" (if available) + N := Declaration_Node (Nm); + end if; - if Nkind (Case_Guard) = N_Others_Choice then - if Others_Seen then - Error_Pragma_Arg - ("only one others choice allowed in pragma %", - Case_Guard); - else - Others_Seen := True; - end if; + if Nkind (N) = N_Full_Type_Declaration + and then Nkind (Type_Definition (N)) = + N_Access_Procedure_Definition + then + L := Parameter_Specifications (Type_Definition (N)); + Process_Async_Pragma; - elsif Others_Seen then - Error_Pragma_Arg - ("others must be the last choice in pragma %", N); + if Is_Asynchronous (Nm) + and then Expander_Active + and then Get_PCS_Name /= Name_No_DSA + then + RACW_Type_Is_Asynchronous (Underlying_RACW_Type (Nm)); end if; - -- The contract case is malformed - else Error_Pragma_Arg - ("wrong syntax in contract case", Contract_Case); + ("pragma% cannot reference access-to-function type", + Arg1); end if; - end Analyze_Contract_Case; - -------------------------- - -- Chain_Contract_Cases -- - -------------------------- + -- Only other possibility is Access-to-class-wide type - procedure Chain_Contract_Cases (Subp_Id : Entity_Id) is - CTC : Node_Id; + elsif Is_Access_Type (Nm) + and then Is_Class_Wide_Type (Designated_Type (Nm)) + then + Check_First_Subtype (Arg1); + Set_Is_Asynchronous (Nm); + if Expander_Active then + RACW_Type_Is_Asynchronous (Nm); + end if; - begin - Check_Duplicate_Pragma (Subp_Id); - CTC := Spec_CTC_List (Contract (Subp_Id)); - while Present (CTC) loop - if Chars (Pragma_Identifier (CTC)) = Pname then - Error_Msg_Name_1 := Pname; - Error_Msg_Sloc := Sloc (CTC); + else + Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1); + end if; + end Asynchronous; - if From_Aspect_Specification (CTC) then - Error_Msg_NE - ("aspect% for & previously given#", N, Subp_Id); - else - Error_Msg_NE - ("pragma% for & duplicates pragma#", N, Subp_Id); - end if; + ------------ + -- Atomic -- + ------------ + + -- pragma Atomic (LOCAL_NAME); + + when Pragma_Atomic => + Process_Atomic_Shared_Volatile; + + ----------------------- + -- Atomic_Components -- + ----------------------- + + -- pragma Atomic_Components (array_LOCAL_NAME); + + -- This processing is shared by Volatile_Components + + when Pragma_Atomic_Components | + Pragma_Volatile_Components => + + Atomic_Components : declare + E_Id : Node_Id; + E : Entity_Id; + D : Node_Id; + K : Node_Kind; + + begin + Check_Ada_83_Warning; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); - raise Pragma_Exit; - end if; + if Etype (E_Id) = Any_Type then + return; + end if; - CTC := Next_Pragma (CTC); - end loop; + E := Entity (E_Id); - -- Prepend pragma Contract_Cases to the contract + Check_Duplicate_Pragma (E); - Set_Next_Pragma (N, Spec_CTC_List (Contract (Subp_Id))); - Set_Spec_CTC_List (Contract (Subp_Id), N); - end Chain_Contract_Cases; + if Rep_Item_Too_Early (E, N) + or else + Rep_Item_Too_Late (E, N) + then + return; + end if; - -- Local variables + D := Declaration_Node (E); + K := Nkind (D); - Context : constant Node_Id := Parent (N); - All_Cases : Node_Id; - Decl : Node_Id; - Contract_Case : Node_Id; - Subp_Decl : Node_Id; - Subp_Id : Entity_Id; + if (K = N_Full_Type_Declaration and then Is_Array_Type (E)) + or else + ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable) + and then Nkind (D) = N_Object_Declaration + and then Nkind (Object_Definition (D)) = + N_Constrained_Array_Definition) + then + -- The flag is set on the object, or on the base type - -- Start of processing for Contract_Cases + if Nkind (D) /= N_Object_Declaration then + E := Base_Type (E); + end if; - begin - GNAT_Pragma; - Check_Arg_Count (1); + Set_Has_Volatile_Components (E); - -- Check the placement of the pragma + if Prag_Id = Pragma_Atomic_Components then + Set_Has_Atomic_Components (E); + end if; - if not Is_List_Member (N) then - Pragma_Misplaced; + else + Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; + end Atomic_Components; - -- Aspect/pragma Contract_Cases may be associated with a library - -- level subprogram. + -------------------- + -- Attach_Handler -- + -------------------- - if Nkind (Context) = N_Compilation_Unit_Aux then - Subp_Decl := Unit (Parent (Context)); + -- pragma Attach_Handler (handler_NAME, EXPRESSION); - if not Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) - then - Pragma_Misplaced; - end if; + when Pragma_Attach_Handler => + Check_Ada_83_Warning; + Check_No_Identifiers; + Check_Arg_Count (2); - Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); + if No_Run_Time_Mode then + Error_Msg_CRT ("Attach_Handler pragma", N); + else + Check_Interrupt_Or_Attach_Handler; - -- The aspect/pragma appears in a subprogram body. The placement - -- is legal when the body acts as a spec. + -- The expression that designates the attribute may depend on a + -- discriminant, and is therefore a per-object expression, to + -- be expanded in the init proc. If expansion is enabled, then + -- perform semantic checks on a copy only. - elsif Nkind (Context) = N_Subprogram_Body then - Subp_Id := Defining_Unit_Name (Specification (Context)); + if Expander_Active then + declare + Temp : constant Node_Id := + New_Copy_Tree (Get_Pragma_Arg (Arg2)); + begin + Set_Parent (Temp, N); + Preanalyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); + end; - if Ekind (Subp_Id) = E_Subprogram_Body then - Error_Pragma - ("pragma % may not appear in a subprogram body that acts " - & "as completion"); + else + Analyze (Get_Pragma_Arg (Arg2)); + Resolve (Get_Pragma_Arg (Arg2), RTE (RE_Interrupt_ID)); end if; - -- Nested subprogram case, the aspect/pragma must apply to the - -- subprogram spec. + Process_Interrupt_Or_Attach_Handler; + end if; - else - Decl := N; - while Present (Prev (Decl)) loop - Decl := Prev (Decl); + -------------------- + -- C_Pass_By_Copy -- + -------------------- - if Nkind (Decl) in N_Generic_Declaration then - Subp_Decl := Decl; - else - Subp_Decl := Original_Node (Decl); - end if; + -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION); - -- Skip prior pragmas + when Pragma_C_Pass_By_Copy => C_Pass_By_Copy : declare + Arg : Node_Id; + Val : Uint; - if Nkind (Subp_Decl) = N_Pragma then - null; + begin + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, "max_size"); - -- Skip internally generated code + Arg := Get_Pragma_Arg (Arg1); + Check_Arg_Is_Static_Expression (Arg, Any_Integer); - elsif not Comes_From_Source (Subp_Decl) then - null; + Val := Expr_Value (Arg); - -- We have found the related subprogram + if Val <= 0 then + Error_Pragma_Arg + ("maximum size for pragma% must be positive", Arg1); - elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration, - N_Subprogram_Declaration) - then - exit; + elsif UI_Is_In_Int_Range (Val) then + Default_C_Record_Mechanism := UI_To_Int (Val); - else - Pragma_Misplaced; - end if; - end loop; + -- If a giant value is given, Int'Last will do well enough. + -- If sometime someone complains that a record larger than + -- two gigabytes is not copied, we will worry about it then! - Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); + else + Default_C_Record_Mechanism := Mechanism_Type'Last; end if; + end C_Pass_By_Copy; - All_Cases := Expression (Arg1); + ----------- + -- Check -- + ----------- - -- Multiple contract cases appear in aggregate form + -- pragma Check ([Name =>] CHECK_KIND, + -- [Check =>] Boolean_EXPRESSION + -- [,[Message =>] String_EXPRESSION]); - if Nkind (All_Cases) = N_Aggregate then - if No (Component_Associations (All_Cases)) then - Error_Pragma ("wrong syntax for pragma %"); + -- CHECK_KIND ::= IDENTIFIER | + -- Pre'Class | + -- Post'Class | + -- Invariant'Class | + -- Type_Invariant'Class - -- Individual contract cases appear as component associations + -- The identifiers Assertions and Statement_Assertions are not + -- allowed, since they have special meaning for Check_Policy. - else - Contract_Case := First (Component_Associations (All_Cases)); - while Present (Contract_Case) loop - Analyze_Contract_Case (Contract_Case); + when Pragma_Check => Check : declare + Expr : Node_Id; + Eloc : Source_Ptr; + Cname : Name_Id; + Str : Node_Id; - Next (Contract_Case); - end loop; - end if; - else - Error_Pragma ("wrong syntax for pragma %"); + Check_On : Boolean; + -- Set True if category of assertions referenced by Name enabled + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (2); + Check_At_Most_N_Arguments (3); + Check_Optional_Identifier (Arg1, Name_Name); + Check_Optional_Identifier (Arg2, Name_Check); + + if Arg_Count = 3 then + Check_Optional_Identifier (Arg3, Name_Message); + Str := Get_Pragma_Arg (Arg3); end if; - Chain_Contract_Cases (Subp_Id); - end Contract_Cases; + Rewrite_Assertion_Kind (Get_Pragma_Arg (Arg1)); + Check_Arg_Is_Identifier (Arg1); + Cname := Chars (Get_Pragma_Arg (Arg1)); - ---------------- - -- Controlled -- - ---------------- + -- Check forbidden name Assertions or Statement_Assertions - -- pragma Controlled (first_subtype_LOCAL_NAME); + case Cname is + when Name_Assertions => + Error_Pragma_Arg + ("""Assertions"" is not allowed as a check kind " + & "for pragma%", Arg1); - when Pragma_Controlled => Controlled : declare - Arg : Node_Id; + when Name_Statement_Assertions => + Error_Pragma_Arg + ("""Statement_Assertions"" is not allowed as a check kind " + & "for pragma%", Arg1); - begin - Check_No_Identifiers; - Check_Arg_Count (1); - Check_Arg_Is_Local_Name (Arg1); - Arg := Get_Pragma_Arg (Arg1); + when others => + null; + end case; - if not Is_Entity_Name (Arg) - or else not Is_Access_Type (Entity (Arg)) - then - Error_Pragma_Arg ("pragma% requires access type", Arg1); - else - Set_Has_Pragma_Controlled (Base_Type (Entity (Arg))); - end if; - end Controlled; + -- Set Check_On to indicate check status - ---------------- - -- Convention -- - ---------------- + -- If this comes from an aspect, we have already taken care of + -- the policy active when the aspect was analyzed, and Is_Ignored + -- is set appropriately already. - -- pragma Convention ([Convention =>] convention_IDENTIFIER, - -- [Entity =>] LOCAL_NAME); + if From_Aspect_Specification (N) then + Check_On := not Is_Ignored (N); - when Pragma_Convention => Convention : declare - C : Convention_Id; - E : Entity_Id; - pragma Warnings (Off, C); - pragma Warnings (Off, E); - begin - Check_Arg_Order ((Name_Convention, Name_Entity)); - Check_Ada_83_Warning; - Check_Arg_Count (2); - Process_Convention (C, E); - end Convention; + -- Otherwise check the status right now - --------------------------- - -- Convention_Identifier -- - --------------------------- + else + case Check_Kind (Cname) is + when Name_Ignore => + Check_On := False; - -- pragma Convention_Identifier ([Name =>] IDENTIFIER, - -- [Convention =>] convention_IDENTIFIER); + when Name_Check => + Check_On := True; - when Pragma_Convention_Identifier => Convention_Identifier : declare - Idnam : Name_Id; - Cname : Name_Id; + -- For disable, rewrite pragma as null statement and skip + -- rest of the analysis of the pragma. - begin - GNAT_Pragma; - Check_Arg_Order ((Name_Name, Name_Convention)); - Check_Arg_Count (2); - Check_Optional_Identifier (Arg1, Name_Name); - Check_Optional_Identifier (Arg2, Name_Convention); - Check_Arg_Is_Identifier (Arg1); - Check_Arg_Is_Identifier (Arg2); - Idnam := Chars (Get_Pragma_Arg (Arg1)); - Cname := Chars (Get_Pragma_Arg (Arg2)); + when Name_Disable => + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + raise Pragma_Exit; - if Is_Convention_Name (Cname) then - Record_Convention_Identifier - (Idnam, Get_Convention_Id (Cname)); - else - Error_Pragma_Arg - ("second arg for % pragma must be convention", Arg2); + -- No other possibilities + + when others => + raise Program_Error; + end case; end if; - end Convention_Identifier; - --------------- - -- CPP_Class -- - --------------- + -- If check kind was not Disable, then continue pragma analysis - -- pragma CPP_Class ([Entity =>] local_NAME) + Expr := Get_Pragma_Arg (Arg2); - when Pragma_CPP_Class => CPP_Class : declare - begin - GNAT_Pragma; + -- Deal with SCO generation - if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("'G'N'A'T pragma cpp'_class is now obsolete and has no " - & "effect; replace it by pragma import?j?", N); - end if; + case Cname is + when Name_Predicate | + Name_Invariant => - Check_Arg_Count (1); + -- Nothing to do: since checks occur in client units, + -- the SCO for the aspect in the declaration unit is + -- conservatively always enabled. - Rewrite (N, - Make_Pragma (Loc, - Chars => Name_Import, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_CPP)), - New_Copy (First (Pragma_Argument_Associations (N)))))); - Analyze (N); - end CPP_Class; + null; - --------------------- - -- CPP_Constructor -- - --------------------- + when others => - -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME - -- [, [External_Name =>] static_string_EXPRESSION ] - -- [, [Link_Name =>] static_string_EXPRESSION ]); + if Check_On and then not Split_PPC (N) then - when Pragma_CPP_Constructor => CPP_Constructor : declare - Elmt : Elmt_Id; - Id : Entity_Id; - Def_Id : Entity_Id; - Tag_Typ : Entity_Id; + -- Mark pragma/aspect SCO as enabled - begin - GNAT_Pragma; - Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (3); - Check_Optional_Identifier (Arg1, Name_Entity); - Check_Arg_Is_Local_Name (Arg1); + Set_SCO_Pragma_Enabled (Loc); + end if; + end case; - Id := Get_Pragma_Arg (Arg1); - Find_Program_Unit_Name (Id); + -- Deal with analyzing the string argument. - -- If we did not find the name, we are done + if Arg_Count = 3 then - if Etype (Id) = Any_Type then - return; - end if; + -- If checks are not on we don't want any expansion (since + -- such expansion would not get properly deleted) but + -- we do want to analyze (to get proper references). + -- The Preanalyze_And_Resolve routine does just what we want - Def_Id := Entity (Id); + if not Check_On then + Preanalyze_And_Resolve (Str, Standard_String); - -- Check if already defined as constructor + -- Otherwise we need a proper analysis and expansion - if Is_Constructor (Def_Id) then - Error_Msg_N - ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1); - return; + else + Analyze_And_Resolve (Str, Standard_String); + end if; end if; - if Ekind (Def_Id) = E_Function - and then (Is_CPP_Class (Etype (Def_Id)) - or else (Is_Class_Wide_Type (Etype (Def_Id)) - and then - Is_CPP_Class (Root_Type (Etype (Def_Id))))) - then - if Scope (Def_Id) /= Scope (Etype (Def_Id)) then - Error_Msg_N - ("'C'P'P constructor must be defined in the scope of " - & "its returned type", Arg1); - end if; + -- Now you might think we could just do the same with the Boolean + -- expression if checks are off (and expansion is on) and then + -- rewrite the check as a null statement. This would work but we + -- would lose the useful warnings about an assertion being bound + -- to fail even if assertions are turned off. - if Arg_Count >= 2 then - Set_Imported (Def_Id); - Set_Is_Public (Def_Id); - Process_Interface_Name (Def_Id, Arg2, Arg3); - end if; + -- So instead we wrap the boolean expression in an if statement + -- that looks like: - Set_Has_Completion (Def_Id); - Set_Is_Constructor (Def_Id); - Set_Convention (Def_Id, Convention_CPP); + -- if False and then condition then + -- null; + -- end if; - -- Imported C++ constructors are not dispatching primitives - -- because in C++ they don't have a dispatch table slot. - -- However, in Ada the constructor has the profile of a - -- function that returns a tagged type and therefore it has - -- been treated as a primitive operation during semantic - -- analysis. We now remove it from the list of primitive - -- operations of the type. + -- The reason we do this rewriting during semantic analysis + -- rather than as part of normal expansion is that we cannot + -- analyze and expand the code for the boolean expression + -- directly, or it may cause insertion of actions that would + -- escape the attempt to suppress the check code. - if Is_Tagged_Type (Etype (Def_Id)) - and then not Is_Class_Wide_Type (Etype (Def_Id)) - and then Is_Dispatching_Operation (Def_Id) - then - Tag_Typ := Etype (Def_Id); + -- Note that the Sloc for the if statement corresponds to the + -- argument condition, not the pragma itself. The reason for + -- this is that we may generate a warning if the condition is + -- False at compile time, and we do not want to delete this + -- warning when we delete the if statement. - Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); - while Present (Elmt) and then Node (Elmt) /= Def_Id loop - Next_Elmt (Elmt); - end loop; + if Expander_Active and not Check_On then + Eloc := Sloc (Expr); - Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); - Set_Is_Dispatching_Operation (Def_Id, False); - end if; + Rewrite (N, + Make_If_Statement (Eloc, + Condition => + Make_And_Then (Eloc, + Left_Opnd => New_Occurrence_Of (Standard_False, Eloc), + Right_Opnd => Expr), + Then_Statements => New_List ( + Make_Null_Statement (Eloc)))); - -- For backward compatibility, if the constructor returns a - -- class wide type, and we internally change the return type to - -- the corresponding root type. + In_Assertion_Expr := In_Assertion_Expr + 1; + Analyze (N); + In_Assertion_Expr := In_Assertion_Expr - 1; + + -- Check is active or expansion not active. In these cases we can + -- just go ahead and analyze the boolean with no worries. - if Is_Class_Wide_Type (Etype (Def_Id)) then - Set_Etype (Def_Id, Root_Type (Etype (Def_Id))); - end if; else - Error_Pragma_Arg - ("pragma% requires function returning a 'C'P'P_Class type", - Arg1); + In_Assertion_Expr := In_Assertion_Expr + 1; + Analyze_And_Resolve (Expr, Any_Boolean); + In_Assertion_Expr := In_Assertion_Expr - 1; end if; - end CPP_Constructor; + end Check; - ----------------- - -- CPP_Virtual -- - ----------------- + -------------------------- + -- Check_Float_Overflow -- + -------------------------- - when Pragma_CPP_Virtual => CPP_Virtual : declare - begin + -- pragma Check_Float_Overflow; + + when Pragma_Check_Float_Overflow => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (0); + Check_Float_Overflow := True; + + ---------------- + -- Check_Name -- + ---------------- + + -- pragma Check_Name (check_IDENTIFIER); + + when Pragma_Check_Name => + Check_No_Identifiers; GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (1); + Check_Arg_Is_Identifier (Arg1); + + declare + Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1)); + + begin + for J in Check_Names.First .. Check_Names.Last loop + if Check_Names.Table (J) = Nam then + return; + end if; + end loop; + + Check_Names.Append (Nam); + end; + + ------------------ + -- Check_Policy -- + ------------------ + + -- This is the old style syntax, which is still allowed in all modes: - if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("'G'N'A'T pragma cpp'_virtual is now obsolete and has no " - & "effect?j?", N); - end if; - end CPP_Virtual; + -- pragma Check_Policy ([Name =>] CHECK_KIND + -- [Policy =>] POLICY_IDENTIFIER); - ---------------- - -- CPP_Vtable -- - ---------------- + -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore - when Pragma_CPP_Vtable => CPP_Vtable : declare - begin - GNAT_Pragma; + -- CHECK_KIND ::= IDENTIFIER | + -- Pre'Class | + -- Post'Class | + -- Type_Invariant'Class | + -- Invariant'Class - if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("'G'N'A'T pragma cpp'_vtable is now obsolete and has no " - & "effect?j?", N); - end if; - end CPP_Vtable; + -- This is the new style syntax, compatible with Assertion_Policy + -- and also allowed in all modes. - --------- - -- CPU -- - --------- + -- Pragma Check_Policy ( + -- CHECK_KIND => POLICY_IDENTIFIER + -- {, CHECK_KIND => POLICY_IDENTIFIER}); - -- pragma CPU (EXPRESSION); + -- Note: the identifiers Name and Policy are not allowed as + -- Check_Kind values. This avoids ambiguities between the old and + -- new form syntax. - when Pragma_CPU => CPU : declare - P : constant Node_Id := Parent (N); - Arg : Node_Id; - Ent : Entity_Id; + when Pragma_Check_Policy => Check_Policy : declare + Kind : Node_Id; begin - Ada_2012_Pragma; - Check_No_Identifiers; - Check_Arg_Count (1); + GNAT_Pragma; + Check_At_Least_N_Arguments (1); - -- Subprogram case + -- A Check_Policy pragma can appear either as a configuration + -- pragma, or in a declarative part or a package spec (see RM + -- 11.5(5) for rules for Suppress/Unsuppress which are also + -- followed for Check_Policy). - if Nkind (P) = N_Subprogram_Body then - Check_In_Main_Program; + if not Is_Configuration_Pragma then + Check_Is_In_Decl_Part_Or_Package_Spec; + end if; - Arg := Get_Pragma_Arg (Arg1); - Analyze_And_Resolve (Arg, Any_Integer); + -- Figure out if we have the old or new syntax. We have the + -- old syntax if the first argument has no identifier, or the + -- identifier is Name. - Ent := Defining_Unit_Name (Specification (P)); + if Nkind (Arg1) /= N_Pragma_Argument_Association + or else Nam_In (Chars (Arg1), No_Name, Name_Name) + then + -- Old syntax - if Nkind (Ent) = N_Defining_Program_Unit_Name then - Ent := Defining_Identifier (Ent); + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Name); + Kind := Get_Pragma_Arg (Arg1); + Rewrite_Assertion_Kind (Kind); + Check_Arg_Is_Identifier (Arg1); + + -- Check forbidden check kind + + if Nam_In (Chars (Kind), Name_Name, Name_Policy) then + Error_Msg_Name_2 := Chars (Kind); + Error_Pragma_Arg + ("pragma% does not allow% as check name", Arg1); end if; - -- Must be static + -- Check policy - if not Is_Static_Expression (Arg) then - Flag_Non_Static_Expr - ("main subprogram affinity is not static!", Arg); - raise Pragma_Exit; + Check_Optional_Identifier (Arg2, Name_Policy); + Check_Arg_Is_One_Of + (Arg2, + Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore); - -- If constraint error, then we already signalled an error + -- And chain pragma on the Check_Policy_List for search - elsif Raises_Constraint_Error (Arg) then - null; + Set_Next_Pragma (N, Opt.Check_Policy_List); + Opt.Check_Policy_List := N; - -- Otherwise check in range + -- For the new syntax, what we do is to convert each argument to + -- an old syntax equivalent. We do that because we want to chain + -- old style Check_Policy pragmas for the search (we don't want + -- to have to deal with multiple arguments in the search). - else - declare - CPU_Id : constant Entity_Id := RTE (RE_CPU_Range); - -- This is the entity System.Multiprocessors.CPU_Range; + else + declare + Arg : Node_Id; + Argx : Node_Id; + LocP : Source_Ptr; - Val : constant Uint := Expr_Value (Arg); + begin + Arg := Arg1; + while Present (Arg) loop + LocP := Sloc (Arg); + Argx := Get_Pragma_Arg (Arg); - begin - if Val < Expr_Value (Type_Low_Bound (CPU_Id)) - or else - Val > Expr_Value (Type_High_Bound (CPU_Id)) + -- Kind must be specified + + if Nkind (Arg) /= N_Pragma_Argument_Association + or else Chars (Arg) = No_Name then Error_Pragma_Arg - ("main subprogram CPU is out of range", Arg1); + ("missing assertion kind for pragma%", Arg); end if; - end; - end if; - - Set_Main_CPU - (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); - - -- Task case - elsif Nkind (P) = N_Task_Definition then - Arg := Get_Pragma_Arg (Arg1); - Ent := Defining_Identifier (Parent (P)); + -- Construct equivalent old form syntax Check_Policy + -- pragma and insert it to get remaining checks. - -- The expression must be analyzed in the special manner - -- described in "Handling of Default and Per-Object - -- Expressions" in sem.ads. + Insert_Action (N, + Make_Pragma (LocP, + Chars => Name_Check_Policy, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (LocP, + Expression => + Make_Identifier (LocP, Chars (Arg))), + Make_Pragma_Argument_Association (Sloc (Argx), + Expression => Argx)))); - Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); + Arg := Next (Arg); + end loop; - -- Anything else is incorrect + -- Rewrite original Check_Policy pragma to null, since we + -- have converted it into a series of old syntax pragmas. - else - Pragma_Misplaced; + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + end; end if; + end Check_Policy; - -- Check duplicate pragma before we chain the pragma in the Rep - -- Item chain of Ent. + --------------------- + -- CIL_Constructor -- + --------------------- - Check_Duplicate_Pragma (Ent); - Record_Rep_Item (Ent, N); - end CPU; + -- pragma CIL_Constructor ([Entity =>] LOCAL_NAME); - ----------- - -- Debug -- - ----------- + -- Processing for this pragma is shared with Java_Constructor - -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); + ------------- + -- Comment -- + ------------- - when Pragma_Debug => Debug : declare - Cond : Node_Id; - Call : Node_Id; + -- pragma Comment (static_string_EXPRESSION) - begin - GNAT_Pragma; + -- Processing for pragma Comment shares the circuitry for pragma + -- Ident. The only differences are that Ident enforces a limit of 31 + -- characters on its argument, and also enforces limitations on + -- placement for DEC compatibility. Pragma Comment shares neither of + -- these restrictions. - -- The condition for executing the call is that the expander - -- is active and that we are not ignoring this debug pragma. + ------------------- + -- Common_Object -- + ------------------- - Cond := - New_Occurrence_Of - (Boolean_Literals - (Expander_Active and then not Is_Ignored (N)), - Loc); + -- pragma Common_Object ( + -- [Internal =>] LOCAL_NAME + -- [, [External =>] EXTERNAL_SYMBOL] + -- [, [Size =>] EXTERNAL_SYMBOL]); - if not Is_Ignored (N) then - Set_SCO_Pragma_Enabled (Loc); - end if; + -- Processing for this pragma is shared with Psect_Object - if Arg_Count = 2 then - Cond := - Make_And_Then (Loc, - Left_Opnd => Relocate_Node (Cond), - Right_Opnd => Get_Pragma_Arg (Arg1)); - Call := Get_Pragma_Arg (Arg2); - else - Call := Get_Pragma_Arg (Arg1); - end if; + ------------------------ + -- Compile_Time_Error -- + ------------------------ - if Nkind_In (Call, - N_Indexed_Component, - N_Function_Call, - N_Identifier, - N_Expanded_Name, - N_Selected_Component) - then - -- If this pragma Debug comes from source, its argument was - -- parsed as a name form (which is syntactically identical). - -- In a generic context a parameterless call will be left as - -- an expanded name (if global) or selected_component if local. - -- Change it to a procedure call statement now. + -- pragma Compile_Time_Error + -- (boolean_EXPRESSION, static_string_EXPRESSION); - Change_Name_To_Procedure_Call_Statement (Call); + when Pragma_Compile_Time_Error => + GNAT_Pragma; + Process_Compile_Time_Warning_Or_Error; - elsif Nkind (Call) = N_Procedure_Call_Statement then + -------------------------- + -- Compile_Time_Warning -- + -------------------------- - -- Already in the form of a procedure call statement: nothing - -- to do (could happen in case of an internally generated - -- pragma Debug). + -- pragma Compile_Time_Warning + -- (boolean_EXPRESSION, static_string_EXPRESSION); - null; + when Pragma_Compile_Time_Warning => + GNAT_Pragma; + Process_Compile_Time_Warning_Or_Error; + + ------------------- + -- Compiler_Unit -- + ------------------- - else - -- All other cases: diagnose error + when Pragma_Compiler_Unit => + GNAT_Pragma; + Check_Arg_Count (0); + Set_Is_Compiler_Unit (Get_Source_Unit (N)); - Error_Msg - ("argument of pragma ""Debug"" is not procedure call", - Sloc (Call)); - return; - end if; + ----------------------------- + -- Complete_Representation -- + ----------------------------- - -- Rewrite into a conditional with an appropriate condition. We - -- wrap the procedure call in a block so that overhead from e.g. - -- use of the secondary stack does not generate execution overhead - -- for suppressed conditions. + -- pragma Complete_Representation; - -- Normally the analysis that follows will freeze the subprogram - -- being called. However, if the call is to a null procedure, - -- we want to freeze it before creating the block, because the - -- analysis that follows may be done with expansion disabled, in - -- which case the body will not be generated, leading to spurious - -- errors. + when Pragma_Complete_Representation => + GNAT_Pragma; + Check_Arg_Count (0); - if Nkind (Call) = N_Procedure_Call_Statement - and then Is_Entity_Name (Name (Call)) - then - Analyze (Name (Call)); - Freeze_Before (N, Entity (Name (Call))); + if Nkind (Parent (N)) /= N_Record_Representation_Clause then + Error_Pragma + ("pragma & must appear within record representation clause"); end if; - Rewrite (N, Make_Implicit_If_Statement (N, - Condition => Cond, - Then_Statements => New_List ( - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Relocate_Node (Call))))))); - Analyze (N); - end Debug; + ---------------------------- + -- Complex_Representation -- + ---------------------------- - ------------------ - -- Debug_Policy -- - ------------------ + -- pragma Complex_Representation ([Entity =>] LOCAL_NAME); - -- pragma Debug_Policy (On | Off | Check | Disable | Ignore) + when Pragma_Complex_Representation => Complex_Representation : declare + E_Id : Entity_Id; + E : Entity_Id; + Ent : Entity_Id; - when Pragma_Debug_Policy => + begin GNAT_Pragma; Check_Arg_Count (1); - Check_No_Identifiers; - Check_Arg_Is_Identifier (Arg1); - - -- Exactly equivalent to pragma Check_Policy (Debug, arg), so - -- rewrite it that way, and let the rest of the checking come - -- from analyzing the rewritten pragma. - - Rewrite (N, - Make_Pragma (Loc, - Chars => Name_Check_Policy, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Debug)), - - Make_Pragma_Argument_Association (Loc, - Expression => Get_Pragma_Arg (Arg1))))); - Analyze (N); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); - ------------- - -- Depends -- - ------------- + if Etype (E_Id) = Any_Type then + return; + end if; - -- pragma Depends (DEPENDENCY_RELATION); + E := Entity (E_Id); - -- DEPENDENCY_RELATION ::= - -- null - -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE} + if not Is_Record_Type (E) then + Error_Pragma_Arg + ("argument for pragma% must be record type", Arg1); + end if; - -- DEPENDENCY_CLAUSE ::= - -- OUTPUT_LIST =>[+] INPUT_LIST - -- | NULL_DEPENDENCY_CLAUSE + Ent := First_Entity (E); - -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST + if No (Ent) + or else No (Next_Entity (Ent)) + or else Present (Next_Entity (Next_Entity (Ent))) + or else not Is_Floating_Point_Type (Etype (Ent)) + or else Etype (Ent) /= Etype (Next_Entity (Ent)) + then + Error_Pragma_Arg + ("record for pragma% must have two fields of the same " + & "floating-point type", Arg1); - -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT}) + else + Set_Has_Complex_Representation (Base_Type (E)); - -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT}) + -- We need to treat the type has having a non-standard + -- representation, for back-end purposes, even though in + -- general a complex will have the default representation + -- of a record with two real components. - -- OUTPUT ::= NAME | FUNCTION_RESULT - -- INPUT ::= NAME + Set_Has_Non_Standard_Rep (Base_Type (E)); + end if; + end Complex_Representation; - -- where FUNCTION_RESULT is a function Result attribute_reference + ------------------------- + -- Component_Alignment -- + ------------------------- - when Pragma_Depends => Depends : declare - All_Inputs_Seen : Elist_Id := No_Elist; - -- A list containing the entities of all the inputs processed so - -- far. This Elist is populated with unique entities because the - -- same input may appear in multiple input lists. + -- pragma Component_Alignment ( + -- [Form =>] ALIGNMENT_CHOICE + -- [, [Name =>] type_LOCAL_NAME]); + -- + -- ALIGNMENT_CHOICE ::= + -- Component_Size + -- | Component_Size_4 + -- | Storage_Unit + -- | Default - Global_Seen : Boolean := False; - -- A flag set when pragma Global has been processed + when Pragma_Component_Alignment => Component_AlignmentP : declare + Args : Args_List (1 .. 2); + Names : constant Name_List (1 .. 2) := ( + Name_Form, + Name_Name); - Outputs_Seen : Elist_Id := No_Elist; - -- A list containing the entities of all the outputs processed so - -- far. The elements of this list may come from different output - -- lists. + Form : Node_Id renames Args (1); + Name : Node_Id renames Args (2); - Null_Output_Seen : Boolean := False; - -- A flag used to track the legality of a null output + Atype : Component_Alignment_Kind; + Typ : Entity_Id; - Result_Seen : Boolean := False; - -- A flag set when Subp_Id'Result is processed + begin + GNAT_Pragma; + Gather_Associations (Names, Args); - Subp_Id : Entity_Id; - -- The entity of the subprogram subject to pragma Depends - - Subp_Inputs : Elist_Id := No_Elist; - Subp_Outputs : Elist_Id := No_Elist; - -- Two lists containing the full set of inputs and output of the - -- related subprograms. Note that these lists contain both nodes - -- and entities. - - procedure Analyze_Dependency_Clause - (Clause : Node_Id; - Is_Last : Boolean); - -- Verify the legality of a single dependency clause. Flag Is_Last - -- denotes whether Clause is the last clause in the relation. - - function Appears_In - (List : Elist_Id; - Item_Id : Entity_Id) return Boolean; - -- Determine whether a particular item appears in a mixed list of - -- nodes and entities. - - procedure Check_Function_Return; - -- Verify that Funtion'Result appears as one of the outputs - - procedure Check_Mode - (Item : Node_Id; - Item_Id : Entity_Id; - Is_Input : Boolean; - Self_Ref : Boolean); - -- Ensure that an item has a proper "in", "in out" or "out" mode - -- depending on its function. If this is not the case, emit an - -- error. Item and Item_Id denote the attributes of an item. Flag - -- Is_Input should be set when item comes from an input list. - -- Flag Self_Ref should be set when the item is an output and the - -- dependency clause has operator "+". - - procedure Check_Usage - (Subp_Items : Elist_Id; - Used_Items : Elist_Id; - Is_Input : Boolean); - -- Verify that all items from Subp_Items appear in Used_Items. - -- Emit an error if this is not the case. - - procedure Collect_Subprogram_Inputs_Outputs; - -- Gather all inputs and outputs of the subprogram. These are the - -- formal parameters and entities classified in pragma Global. - - procedure Normalize_Clause (Clause : Node_Id); - -- Remove a self-dependency "+" from the input list of a clause. - -- Depending on the contents of the relation, either split the - -- the clause into multiple smaller clauses or perform the - -- normalization in place. - - ------------------------------- - -- Analyze_Dependency_Clause -- - ------------------------------- - - procedure Analyze_Dependency_Clause - (Clause : Node_Id; - Is_Last : Boolean) - is - procedure Analyze_Input_List (Inputs : Node_Id); - -- Verify the legality of a single input list - - procedure Analyze_Input_Output - (Item : Node_Id; - Is_Input : Boolean; - Self_Ref : Boolean; - Top_Level : Boolean; - Seen : in out Elist_Id; - Null_Seen : in out Boolean); - -- Verify the legality of a single input or output item. Flag - -- Is_Input should be set whenever Item is an input, False when - -- it denotes an output. Flag Self_Ref should be set when the - -- item is an output and the dependency clause has a "+". Flag - -- Top_Level should be set whenever Item appears immediately - -- within an input or output list. Seen is a collection of all - -- abstract states, variables and formals processed so far. - -- Flag Null_Seen denotes whether a null input or output has - -- been encountered. - - ------------------------ - -- Analyze_Input_List -- - ------------------------ - - procedure Analyze_Input_List (Inputs : Node_Id) is - Inputs_Seen : Elist_Id := No_Elist; - -- A list containing the entities of all inputs that appear - -- in the current input list. - - Null_Input_Seen : Boolean := False; - -- A flag used to track the legality of a null input - - Input : Node_Id; + if No (Form) then + Error_Pragma ("missing Form argument for pragma%"); + end if; - begin - -- Multiple inputs appear as an aggregate + Check_Arg_Is_Identifier (Form); - if Nkind (Inputs) = N_Aggregate then - if Present (Component_Associations (Inputs)) then - Error_Msg_N - ("nested dependency relations not allowed", Inputs); - - elsif Present (Expressions (Inputs)) then - Input := First (Expressions (Inputs)); - while Present (Input) loop - Analyze_Input_Output - (Item => Input, - Is_Input => True, - Self_Ref => False, - Top_Level => False, - Seen => Inputs_Seen, - Null_Seen => Null_Input_Seen); - - Next (Input); - end loop; + -- Get proper alignment, note that Default = Component_Size on all + -- machines we have so far, and we want to set this value rather + -- than the default value to indicate that it has been explicitly + -- set (and thus will not get overridden by the default component + -- alignment for the current scope) - else - Error_Msg_N - ("malformed input dependency list", Inputs); - end if; + if Chars (Form) = Name_Component_Size then + Atype := Calign_Component_Size; - -- Process a solitary input + elsif Chars (Form) = Name_Component_Size_4 then + Atype := Calign_Component_Size_4; - else - Analyze_Input_Output - (Item => Inputs, - Is_Input => True, - Self_Ref => False, - Top_Level => False, - Seen => Inputs_Seen, - Null_Seen => Null_Input_Seen); - end if; + elsif Chars (Form) = Name_Default then + Atype := Calign_Component_Size; - -- Detect an illegal dependency clause of the form + elsif Chars (Form) = Name_Storage_Unit then + Atype := Calign_Storage_Unit; - -- (null =>[+] null) + else + Error_Pragma_Arg + ("invalid Form parameter for pragma%", Form); + end if; - if Null_Output_Seen and then Null_Input_Seen then - Error_Msg_N - ("null dependency clause cannot have a null input list", - Inputs); - end if; - end Analyze_Input_List; - - -------------------------- - -- Analyze_Input_Output -- - -------------------------- - - procedure Analyze_Input_Output - (Item : Node_Id; - Is_Input : Boolean; - Self_Ref : Boolean; - Top_Level : Boolean; - Seen : in out Elist_Id; - Null_Seen : in out Boolean) - is - Is_Output : constant Boolean := not Is_Input; - Grouped : Node_Id; - Item_Id : Entity_Id; + -- Case with no name, supplied, affects scope table entry - begin - -- Multiple input or output items appear as an aggregate + if No (Name) then + Scope_Stack.Table + (Scope_Stack.Last).Component_Alignment_Default := Atype; - if Nkind (Item) = N_Aggregate then - if not Top_Level then - Error_Msg_N - ("nested grouping of items not allowed", Item); + -- Case of name supplied - elsif Present (Component_Associations (Item)) then - Error_Msg_N - ("nested dependency relations not allowed", Item); - - -- Recursively analyze the grouped items - - elsif Present (Expressions (Item)) then - Grouped := First (Expressions (Item)); - while Present (Grouped) loop - Analyze_Input_Output - (Item => Grouped, - Is_Input => Is_Input, - Self_Ref => Self_Ref, - Top_Level => False, - Seen => Seen, - Null_Seen => Null_Seen); - - Next (Grouped); - end loop; + else + Check_Arg_Is_Local_Name (Name); + Find_Type (Name); + Typ := Entity (Name); - else - Error_Msg_N ("malformed dependency list", Item); - end if; + if Typ = Any_Type + or else Rep_Item_Too_Early (Typ, N) + then + return; + else + Typ := Underlying_Type (Typ); + end if; - -- Process Function'Result in the context of a dependency - -- clause. + if not Is_Record_Type (Typ) + and then not Is_Array_Type (Typ) + then + Error_Pragma_Arg + ("Name parameter of pragma% must identify record or " + & "array type", Name); + end if; - elsif Nkind (Item) = N_Attribute_Reference - and then Attribute_Name (Item) = Name_Result - then - -- It is sufficent to analyze the prefix of 'Result in - -- order to establish legality of the attribute. + -- An explicit Component_Alignment pragma overrides an + -- implicit pragma Pack, but not an explicit one. - Analyze (Prefix (Item)); + if not Has_Pragma_Pack (Base_Type (Typ)) then + Set_Is_Packed (Base_Type (Typ), False); + Set_Component_Alignment (Base_Type (Typ), Atype); + end if; + end if; + end Component_AlignmentP; - -- The prefix of 'Result must denote the function for - -- which aspect/pragma Depends applies. + -------------------- + -- Contract_Cases -- + -------------------- - if not Is_Entity_Name (Prefix (Item)) - or else Ekind (Subp_Id) /= E_Function - or else Entity (Prefix (Item)) /= Subp_Id - then - Error_Msg_Name_1 := Name_Result; - Error_Msg_N - ("prefix of attribute % must denote the enclosing " - & "function", Item); + -- pragma Contract_Cases (CONTRACT_CASE_LIST); - -- Function'Result is allowed to appear on the output - -- side of a dependency clause. + -- CONTRACT_CASE_LIST ::= CONTRACT_CASE {, CONTRACT_CASE} - elsif Is_Input then - Error_Msg_N - ("function result cannot act as input", Item); + -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE - else - Result_Seen := True; - end if; + -- CASE_GUARD ::= boolean_EXPRESSION | others - -- Detect multiple uses of null in a single dependency list - -- or throughout the whole relation. Verify the placement of - -- a null output list relative to the other clauses. + -- CONSEQUENCE ::= boolean_EXPRESSION - elsif Nkind (Item) = N_Null then - if Null_Seen then - Error_Msg_N - ("multiple null dependency relations not allowed", - Item); - else - Null_Seen := True; + when Pragma_Contract_Cases => Contract_Cases : declare + Others_Seen : Boolean := False; - if Is_Output and then not Is_Last then - Error_Msg_N - ("null output list must be the last clause in " - & "a dependency relation", Item); - end if; - end if; + procedure Analyze_Contract_Case (Contract_Case : Node_Id); + -- Verify the legality of a single contract case - -- Default case + procedure Chain_Contract_Cases (Subp_Id : Entity_Id); + -- Chain pragma Contract_Cases to the contract of a subprogram. + -- Subp_Id is the related subprogram. - else - Analyze (Item); + --------------------------- + -- Analyze_Contract_Case -- + --------------------------- - -- Find the entity of the item. If this is a renaming, - -- climb the renaming chain to reach the root object. - -- Renamings of non-entire objects do not yield an - -- entity (Empty). + procedure Analyze_Contract_Case (Contract_Case : Node_Id) is + Case_Guard : Node_Id; + Extra_Guard : Node_Id; - Item_Id := Entity_Of (Item); + begin + if Nkind (Contract_Case) = N_Component_Association then + Case_Guard := First (Choices (Contract_Case)); - if Present (Item_Id) then - if Ekind_In (Item_Id, E_Abstract_State, - E_In_Parameter, - E_In_Out_Parameter, - E_Out_Parameter, - E_Variable) - then - -- Ensure that the item is of the correct mode - -- depending on its function. + -- Each contract case must have exactly on case guard - Check_Mode (Item, Item_Id, Is_Input, Self_Ref); + Extra_Guard := Next (Case_Guard); - -- Detect multiple uses of the same state, variable - -- or formal parameter. If this is not the case, - -- add the item to the list of processed relations. + if Present (Extra_Guard) then + Error_Pragma_Arg + ("contract case may have only one case guard", + Extra_Guard); + end if; - if Contains (Seen, Item_Id) then - Error_Msg_N ("duplicate use of item", Item); - else - Add_Item (Item_Id, Seen); - end if; + -- Check the placement of "others" (if available) - -- Detect an illegal use of an input related to a - -- null output. Such input items cannot appear in - -- other input lists. + if Nkind (Case_Guard) = N_Others_Choice then + if Others_Seen then + Error_Pragma_Arg + ("only one others choice allowed in pragma %", + Case_Guard); + else + Others_Seen := True; + end if; - if Null_Output_Seen - and then Contains (All_Inputs_Seen, Item_Id) - then - Error_Msg_N - ("input of a null output list appears in " - & "multiple input lists", Item); - else - Add_Item (Item_Id, All_Inputs_Seen); - end if; + elsif Others_Seen then + Error_Pragma_Arg + ("others must be the last choice in pragma %", N); + end if; - -- When the item renames an entire object, replace - -- the item with a reference to the object. + -- The contract case is malformed - if Present (Renamed_Object (Entity (Item))) then - Rewrite (Item, - New_Reference_To (Item_Id, Sloc (Item))); - Analyze (Item); - end if; + else + Error_Pragma_Arg + ("wrong syntax in contract case", Contract_Case); + end if; + end Analyze_Contract_Case; - -- All other input/output items are illegal + -------------------------- + -- Chain_Contract_Cases -- + -------------------------- - else - Error_Msg_N - ("item must denote variable, state or formal " - & "parameter", Item); - end if; + procedure Chain_Contract_Cases (Subp_Id : Entity_Id) is + CTC : Node_Id; - -- All other input/output items are illegal + begin + Check_Duplicate_Pragma (Subp_Id); + CTC := Contract_Test_Cases (Contract (Subp_Id)); + while Present (CTC) loop + if Chars (Pragma_Identifier (CTC)) = Pname then + Error_Msg_Name_1 := Pname; + Error_Msg_Sloc := Sloc (CTC); + if From_Aspect_Specification (CTC) then + Error_Msg_NE + ("aspect% for & previously given#", N, Subp_Id); else - Error_Msg_N - ("item must denote variable, state or formal " - & "parameter", Item); + Error_Msg_NE + ("pragma% for & duplicates pragma#", N, Subp_Id); end if; - end if; - end Analyze_Input_Output; - - -- Local variables - Inputs : Node_Id; - Output : Node_Id; - Self_Ref : Boolean; - - -- Start of processing for Analyze_Dependency_Clause + raise Pragma_Exit; + end if; - begin - Inputs := Expression (Clause); - Self_Ref := False; + CTC := Next_Pragma (CTC); + end loop; - -- An input list with a self-dependency appears as operator "+" - -- where the actuals inputs are the right operand. + -- Prepend pragma Contract_Cases to the contract - if Nkind (Inputs) = N_Op_Plus then - Inputs := Right_Opnd (Inputs); - Self_Ref := True; - end if; + Add_Contract_Item (N, Subp_Id); + end Chain_Contract_Cases; - -- Process the output_list of a dependency_clause + -- Local variables - Output := First (Choices (Clause)); - while Present (Output) loop - Analyze_Input_Output - (Item => Output, - Is_Input => False, - Self_Ref => Self_Ref, - Top_Level => True, - Seen => Outputs_Seen, - Null_Seen => Null_Output_Seen); - - Next (Output); - end loop; + Context : constant Node_Id := Parent (N); + All_Cases : Node_Id; + Decl : Node_Id; + Contract_Case : Node_Id; + Subp_Decl : Node_Id; + Subp_Id : Entity_Id; - -- Process the input_list of a dependency_clause + -- Start of processing for Contract_Cases - Analyze_Input_List (Inputs); - end Analyze_Dependency_Clause; + begin + GNAT_Pragma; + Check_Arg_Count (1); - ---------------- - -- Appears_In -- - ---------------- + -- Check the placement of the pragma - function Appears_In - (List : Elist_Id; - Item_Id : Entity_Id) return Boolean - is - Elmt : Elmt_Id; - Id : Entity_Id; + if not Is_List_Member (N) then + Pragma_Misplaced; + end if; - begin - if Present (List) then - Elmt := First_Elmt (List); - while Present (Elmt) loop - if Nkind (Node (Elmt)) = N_Defining_Identifier then - Id := Node (Elmt); - else - Id := Entity (Node (Elmt)); - end if; + -- Aspect/pragma Contract_Cases may be associated with a library + -- level subprogram. - if Id = Item_Id then - return True; - end if; + if Nkind (Context) = N_Compilation_Unit_Aux then + Subp_Decl := Unit (Parent (Context)); - Next_Elmt (Elmt); - end loop; + if not Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration, + N_Subprogram_Declaration) + then + Pragma_Misplaced; end if; - return False; - end Appears_In; + Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); - ---------------------------- - -- Check_Function_Return -- - ---------------------------- + -- The aspect/pragma appears in a subprogram body. The placement + -- is legal when the body acts as a spec. - procedure Check_Function_Return is - begin - if Ekind (Subp_Id) = E_Function and then not Result_Seen then - Error_Msg_NE - ("result of & must appear in exactly one output list", - N, Subp_Id); + elsif Nkind (Context) = N_Subprogram_Body then + Subp_Id := Defining_Unit_Name (Specification (Context)); + + if not Acts_As_Spec (Context) then + Error_Pragma + ("pragma % may not appear in a subprogram body that acts " + & "as completion"); end if; - end Check_Function_Return; - ---------------- - -- Check_Mode -- - ---------------- + -- Nested subprogram case, the aspect/pragma must apply to the + -- subprogram spec. - procedure Check_Mode - (Item : Node_Id; - Item_Id : Entity_Id; - Is_Input : Boolean; - Self_Ref : Boolean) - is - begin - -- Input + else + Decl := N; + while Present (Prev (Decl)) loop + Decl := Prev (Decl); - if Is_Input then - if Ekind (Item_Id) = E_Out_Parameter - or else (Global_Seen - and then not Appears_In (Subp_Inputs, Item_Id)) - then - Error_Msg_NE - ("item & must have mode in or in out", Item, Item_Id); + if Nkind (Decl) in N_Generic_Declaration then + Subp_Decl := Decl; + else + Subp_Decl := Original_Node (Decl); end if; - -- Self-referential output + -- Skip prior pragmas - elsif Self_Ref then + if Nkind (Subp_Decl) = N_Pragma then + null; - -- A self-referential state or variable must appear in both - -- input and output lists of a subprogram. + -- Skip internally generated code - if Ekind_In (Item_Id, E_Abstract_State, E_Variable) then - if Global_Seen - and then not - (Appears_In (Subp_Inputs, Item_Id) - and then - Appears_In (Subp_Outputs, Item_Id)) - then - Error_Msg_NE - ("item & must have mode in out", Item, Item_Id); - end if; + elsif not Comes_From_Source (Subp_Decl) then + null; - -- Self-referential parameter + -- We have found the related subprogram - elsif Ekind (Item_Id) /= E_In_Out_Parameter then - Error_Msg_NE - ("item & must have mode in out", Item, Item_Id); + elsif Nkind_In (Subp_Decl, N_Generic_Subprogram_Declaration, + N_Subprogram_Declaration) + then + exit; + + else + Pragma_Misplaced; end if; + end loop; - -- Regular output + Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); + end if; - elsif Ekind (Item_Id) = E_In_Parameter - or else - (Global_Seen - and then not Appears_In (Subp_Outputs, Item_Id)) - then - Error_Msg_NE - ("item & must have mode out or in out", Item, Item_Id); - end if; - end Check_Mode; + All_Cases := Expression (Arg1); - ----------------- - -- Check_Usage -- - ----------------- + -- Multiple contract cases appear in aggregate form - procedure Check_Usage - (Subp_Items : Elist_Id; - Used_Items : Elist_Id; - Is_Input : Boolean) - is - procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id); - -- Emit an error concerning the erroneous usage of an item + if Nkind (All_Cases) = N_Aggregate then + if No (Component_Associations (All_Cases)) then + Error_Pragma ("wrong syntax for pragma %"); - ----------------- - -- Usage_Error -- - ----------------- + -- Individual contract cases appear as component associations - procedure Usage_Error (Item : Node_Id; Item_Id : Entity_Id) is - begin - if Is_Input then - Error_Msg_NE - ("item & must appear in at least one input list of " - & "aspect Depends", Item, Item_Id); - else - Error_Msg_NE - ("item & must appear in exactly one output list of " - & "aspect Depends", Item, Item_Id); - end if; - end Usage_Error; + else + Contract_Case := First (Component_Associations (All_Cases)); + while Present (Contract_Case) loop + Analyze_Contract_Case (Contract_Case); - -- Local variables + Next (Contract_Case); + end loop; + end if; + else + Error_Pragma ("wrong syntax for pragma %"); + end if; + + Chain_Contract_Cases (Subp_Id); + end Contract_Cases; + + ---------------- + -- Controlled -- + ---------------- - Elmt : Elmt_Id; - Item : Node_Id; - Item_Id : Entity_Id; + -- pragma Controlled (first_subtype_LOCAL_NAME); - -- Start of processing for Check_Usage + when Pragma_Controlled => Controlled : declare + Arg : Node_Id; - begin - if No (Subp_Items) then - return; - end if; + begin + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + Arg := Get_Pragma_Arg (Arg1); - -- Each input or output of the subprogram must appear in a - -- dependency relation. + if not Is_Entity_Name (Arg) + or else not Is_Access_Type (Entity (Arg)) + then + Error_Pragma_Arg ("pragma% requires access type", Arg1); + else + Set_Has_Pragma_Controlled (Base_Type (Entity (Arg))); + end if; + end Controlled; - Elmt := First_Elmt (Subp_Items); - while Present (Elmt) loop - Item := Node (Elmt); + ---------------- + -- Convention -- + ---------------- - if Nkind (Item) = N_Defining_Identifier then - Item_Id := Item; - else - Item_Id := Entity (Item); - end if; + -- pragma Convention ([Convention =>] convention_IDENTIFIER, + -- [Entity =>] LOCAL_NAME); - -- The item does not appear in a dependency + when Pragma_Convention => Convention : declare + C : Convention_Id; + E : Entity_Id; + pragma Warnings (Off, C); + pragma Warnings (Off, E); + begin + Check_Arg_Order ((Name_Convention, Name_Entity)); + Check_Ada_83_Warning; + Check_Arg_Count (2); + Process_Convention (C, E); + end Convention; - if not Contains (Used_Items, Item_Id) then - if Is_Formal (Item_Id) then - Usage_Error (Item, Item_Id); + --------------------------- + -- Convention_Identifier -- + --------------------------- - -- States and global variables are not used properly only - -- when the subprogram is subject to pragma Global. + -- pragma Convention_Identifier ([Name =>] IDENTIFIER, + -- [Convention =>] convention_IDENTIFIER); - elsif Global_Seen then - Usage_Error (Item, Item_Id); - end if; - end if; + when Pragma_Convention_Identifier => Convention_Identifier : declare + Idnam : Name_Id; + Cname : Name_Id; - Next_Elmt (Elmt); - end loop; - end Check_Usage; + begin + GNAT_Pragma; + Check_Arg_Order ((Name_Name, Name_Convention)); + Check_Arg_Count (2); + Check_Optional_Identifier (Arg1, Name_Name); + Check_Optional_Identifier (Arg2, Name_Convention); + Check_Arg_Is_Identifier (Arg1); + Check_Arg_Is_Identifier (Arg2); + Idnam := Chars (Get_Pragma_Arg (Arg1)); + Cname := Chars (Get_Pragma_Arg (Arg2)); - --------------------------------------- - -- Collect_Subprogram_Inputs_Outputs -- - --------------------------------------- + if Is_Convention_Name (Cname) then + Record_Convention_Identifier + (Idnam, Get_Convention_Id (Cname)); + else + Error_Pragma_Arg + ("second arg for % pragma must be convention", Arg2); + end if; + end Convention_Identifier; - procedure Collect_Subprogram_Inputs_Outputs is - procedure Collect_Global_List - (List : Node_Id; - Mode : Name_Id := Name_Input); - -- Collect all relevant items from a global list + --------------- + -- CPP_Class -- + --------------- - ------------------------- - -- Collect_Global_List -- - ------------------------- + -- pragma CPP_Class ([Entity =>] local_NAME) - procedure Collect_Global_List - (List : Node_Id; - Mode : Name_Id := Name_Input) - is - procedure Collect_Global_Item - (Item : Node_Id; - Mode : Name_Id); - -- Add an item to the proper subprogram input or output - -- collection. - - ------------------------- - -- Collect_Global_Item -- - ------------------------- - - procedure Collect_Global_Item - (Item : Node_Id; - Mode : Name_Id) - is - begin - if Nam_In (Mode, Name_In_Out, Name_Input) then - Add_Item (Item, Subp_Inputs); - end if; + when Pragma_CPP_Class => CPP_Class : declare + begin + GNAT_Pragma; - if Nam_In (Mode, Name_In_Out, Name_Output) then - Add_Item (Item, Subp_Outputs); - end if; - end Collect_Global_Item; + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("'G'N'A'T pragma cpp'_class is now obsolete and has no " + & "effect; replace it by pragma import?j?", N); + end if; - -- Local variables + Check_Arg_Count (1); - Assoc : Node_Id; - Item : Node_Id; + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Import, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_CPP)), + New_Copy (First (Pragma_Argument_Associations (N)))))); + Analyze (N); + end CPP_Class; - -- Start of processing for Collect_Global_List + --------------------- + -- CPP_Constructor -- + --------------------- - begin - -- Single global item declaration + -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME + -- [, [External_Name =>] static_string_EXPRESSION ] + -- [, [Link_Name =>] static_string_EXPRESSION ]); - if Nkind_In (List, N_Identifier, N_Selected_Component) then - Collect_Global_Item (List, Mode); + when Pragma_CPP_Constructor => CPP_Constructor : declare + Elmt : Elmt_Id; + Id : Entity_Id; + Def_Id : Entity_Id; + Tag_Typ : Entity_Id; - -- Simple global list or moded global list declaration + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (3); + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); - else - if Present (Expressions (List)) then - Item := First (Expressions (List)); - while Present (Item) loop - Collect_Global_Item (Item, Mode); + Id := Get_Pragma_Arg (Arg1); + Find_Program_Unit_Name (Id); - Next (Item); - end loop; + -- If we did not find the name, we are done - else - Assoc := First (Component_Associations (List)); - while Present (Assoc) loop - Collect_Global_List - (List => Expression (Assoc), - Mode => Chars (First (Choices (Assoc)))); + if Etype (Id) = Any_Type then + return; + end if; - Next (Assoc); - end loop; - end if; - end if; - end Collect_Global_List; + Def_Id := Entity (Id); - -- Local variables + -- Check if already defined as constructor - Formal : Entity_Id; - Global : Node_Id; - List : Node_Id; + if Is_Constructor (Def_Id) then + Error_Msg_N + ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1); + return; + end if; - -- Start of processing for Collect_Subprogram_Inputs_Outputs + if Ekind (Def_Id) = E_Function + and then (Is_CPP_Class (Etype (Def_Id)) + or else (Is_Class_Wide_Type (Etype (Def_Id)) + and then + Is_CPP_Class (Root_Type (Etype (Def_Id))))) + then + if Scope (Def_Id) /= Scope (Etype (Def_Id)) then + Error_Msg_N + ("'C'P'P constructor must be defined in the scope of " + & "its returned type", Arg1); + end if; - begin - -- Process all formal parameters + if Arg_Count >= 2 then + Set_Imported (Def_Id); + Set_Is_Public (Def_Id); + Process_Interface_Name (Def_Id, Arg2, Arg3); + end if; - Formal := First_Formal (Subp_Id); - while Present (Formal) loop - if Ekind_In (Formal, E_In_Out_Parameter, - E_In_Parameter) - then - Add_Item (Formal, Subp_Inputs); - end if; + Set_Has_Completion (Def_Id); + Set_Is_Constructor (Def_Id); + Set_Convention (Def_Id, Convention_CPP); - if Ekind_In (Formal, E_In_Out_Parameter, - E_Out_Parameter) - then - Add_Item (Formal, Subp_Outputs); - end if; + -- Imported C++ constructors are not dispatching primitives + -- because in C++ they don't have a dispatch table slot. + -- However, in Ada the constructor has the profile of a + -- function that returns a tagged type and therefore it has + -- been treated as a primitive operation during semantic + -- analysis. We now remove it from the list of primitive + -- operations of the type. - Next_Formal (Formal); - end loop; + if Is_Tagged_Type (Etype (Def_Id)) + and then not Is_Class_Wide_Type (Etype (Def_Id)) + and then Is_Dispatching_Operation (Def_Id) + then + Tag_Typ := Etype (Def_Id); - -- If the subprogram is subject to pragma Global, traverse all - -- global lists and gather the relevant items. + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) and then Node (Elmt) /= Def_Id loop + Next_Elmt (Elmt); + end loop; - Global := Find_Aspect (Subp_Id, Aspect_Global); - if Present (Global) then - Global_Seen := True; + Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); + Set_Is_Dispatching_Operation (Def_Id, False); + end if; - -- Retrieve the pragma as it contains the analyzed lists + -- For backward compatibility, if the constructor returns a + -- class wide type, and we internally change the return type to + -- the corresponding root type. - Global := Aspect_Rep_Item (Global); + if Is_Class_Wide_Type (Etype (Def_Id)) then + Set_Etype (Def_Id, Root_Type (Etype (Def_Id))); + end if; + else + Error_Pragma_Arg + ("pragma% requires function returning a 'C'P'P_Class type", + Arg1); + end if; + end CPP_Constructor; - -- The pragma may not have been analyzed because of the - -- arbitrary declaration order of aspects. Make sure that - -- it is analyzed for the purposes of item extraction. + ----------------- + -- CPP_Virtual -- + ----------------- - if not Analyzed (Global) then - Analyze (Global); - end if; + when Pragma_CPP_Virtual => CPP_Virtual : declare + begin + GNAT_Pragma; - List := - Expression (First (Pragma_Argument_Associations (Global))); + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("'G'N'A'T pragma cpp'_virtual is now obsolete and has no " + & "effect?j?", N); + end if; + end CPP_Virtual; - -- Nothing to be done for a null global list + ---------------- + -- CPP_Vtable -- + ---------------- - if Nkind (List) /= N_Null then - Collect_Global_List (List); - end if; - end if; - end Collect_Subprogram_Inputs_Outputs; + when Pragma_CPP_Vtable => CPP_Vtable : declare + begin + GNAT_Pragma; - ---------------------- - -- Normalize_Clause -- - ---------------------- + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("'G'N'A'T pragma cpp'_vtable is now obsolete and has no " + & "effect?j?", N); + end if; + end CPP_Vtable; - procedure Normalize_Clause (Clause : Node_Id) is - procedure Create_Or_Modify_Clause - (Output : Node_Id; - Outputs : Node_Id; - Inputs : Node_Id; - After : Node_Id; - In_Place : Boolean; - Multiple : Boolean); - -- Create a brand new clause to represent the self-reference - -- or modify the input and/or output lists of an existing - -- clause. Output denotes a self-referencial output. Outputs - -- is the output list of a clause. Inputs is the input list - -- of a clause. After denotes the clause after which the new - -- clause is to be inserted. Flag In_Place should be set when - -- normalizing the last output of an output list. Flag Multiple - -- should be set when Output comes from a list with multiple - -- items. - - ----------------------------- - -- Create_Or_Modify_Clause -- - ----------------------------- - - procedure Create_Or_Modify_Clause - (Output : Node_Id; - Outputs : Node_Id; - Inputs : Node_Id; - After : Node_Id; - In_Place : Boolean; - Multiple : Boolean) - is - procedure Propagate_Output - (Output : Node_Id; - Inputs : Node_Id); - -- Handle the various cases of output propagation to the - -- input list. Output denotes a self-referencial output - -- item. Inputs is the input list of a clause. - - ---------------------- - -- Propagate_Output -- - ---------------------- - - procedure Propagate_Output - (Output : Node_Id; - Inputs : Node_Id) - is - function In_Input_List - (Item : Entity_Id; - Inputs : List_Id) return Boolean; - -- Determine whether a particulat item appears in the - -- input list of a clause. - - ------------------- - -- In_Input_List -- - ------------------- - - function In_Input_List - (Item : Entity_Id; - Inputs : List_Id) return Boolean - is - Elmt : Node_Id; + --------- + -- CPU -- + --------- - begin - Elmt := First (Inputs); - while Present (Elmt) loop - if Entity_Of (Elmt) = Item then - return True; - end if; + -- pragma CPU (EXPRESSION); - Next (Elmt); - end loop; + when Pragma_CPU => CPU : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + Ent : Entity_Id; - return False; - end In_Input_List; + begin + Ada_2012_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); - -- Local variables + -- Subprogram case - Output_Id : constant Entity_Id := Entity_Of (Output); - Grouped : List_Id; + if Nkind (P) = N_Subprogram_Body then + Check_In_Main_Program; - -- Start of processing for Propagate_Output + Arg := Get_Pragma_Arg (Arg1); + Analyze_And_Resolve (Arg, Any_Integer); - begin - -- The clause is of the form: + Ent := Defining_Unit_Name (Specification (P)); - -- (Output =>+ null) + if Nkind (Ent) = N_Defining_Program_Unit_Name then + Ent := Defining_Identifier (Ent); + end if; - -- Remove the null input and replace it with a copy of - -- the output: + -- Must be static - -- (Output => Output) + if not Is_Static_Expression (Arg) then + Flag_Non_Static_Expr + ("main subprogram affinity is not static!", Arg); + raise Pragma_Exit; - if Nkind (Inputs) = N_Null then - Rewrite (Inputs, New_Copy_Tree (Output)); + -- If constraint error, then we already signalled an error - -- The clause is of the form: + elsif Raises_Constraint_Error (Arg) then + null; - -- (Output =>+ (Input1, ..., InputN)) + -- Otherwise check in range - -- Determine whether the output is not already mentioned - -- in the input list and if not, add it to the list of - -- inputs: + else + declare + CPU_Id : constant Entity_Id := RTE (RE_CPU_Range); + -- This is the entity System.Multiprocessors.CPU_Range; - -- (Output => (Output, Input1, ..., InputN)) + Val : constant Uint := Expr_Value (Arg); - elsif Nkind (Inputs) = N_Aggregate then - Grouped := Expressions (Inputs); + begin + if Val < Expr_Value (Type_Low_Bound (CPU_Id)) + or else + Val > Expr_Value (Type_High_Bound (CPU_Id)) + then + Error_Pragma_Arg + ("main subprogram CPU is out of range", Arg1); + end if; + end; + end if; - if not In_Input_List - (Item => Output_Id, - Inputs => Grouped) - then - Prepend_To (Grouped, New_Copy_Tree (Output)); - end if; + Set_Main_CPU + (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg))); - -- The clause is of the form: + -- Task case - -- (Output =>+ Input) + elsif Nkind (P) = N_Task_Definition then + Arg := Get_Pragma_Arg (Arg1); + Ent := Defining_Identifier (Parent (P)); - -- If the input does not mention the output, group the - -- two together: + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. - -- (Output => (Output, Input)) + Preanalyze_Spec_Expression (Arg, RTE (RE_CPU_Range)); - elsif Entity_Of (Inputs) /= Output_Id then - Rewrite (Inputs, - Make_Aggregate (Loc, - Expressions => New_List ( - New_Copy_Tree (Output), - New_Copy_Tree (Inputs)))); - end if; - end Propagate_Output; + -- Anything else is incorrect - -- Local variables + else + Pragma_Misplaced; + end if; - Loc : constant Source_Ptr := Sloc (Output); - Clause : Node_Id; + -- Check duplicate pragma before we chain the pragma in the Rep + -- Item chain of Ent. - -- Start of processing for Create_Or_Modify_Clause + Check_Duplicate_Pragma (Ent); + Record_Rep_Item (Ent, N); + end CPU; - begin - -- A function result cannot depend on itself because it - -- cannot appear in the input list of a relation. + ----------- + -- Debug -- + ----------- - if Nkind (Output) = N_Attribute_Reference - and then Attribute_Name (Output) = Name_Result - then - Error_Msg_N - ("function result cannot depend on itself", Output); - return; + -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); - -- A null output depending on itself does not require any - -- normalization. + when Pragma_Debug => Debug : declare + Cond : Node_Id; + Call : Node_Id; - elsif Nkind (Output) = N_Null then - return; - end if; + begin + GNAT_Pragma; - -- When performing the transformation in place, simply add - -- the output to the list of inputs (if not already there). - -- This case arises when dealing with the last output of an - -- output list - we perform the normalization in place to - -- avoid generating a malformed tree. + -- The condition for executing the call is that the expander + -- is active and that we are not ignoring this debug pragma. - if In_Place then - Propagate_Output (Output, Inputs); + Cond := + New_Occurrence_Of + (Boolean_Literals + (Expander_Active and then not Is_Ignored (N)), + Loc); - -- A list with multiple outputs is slowly trimmed until - -- only one element remains. When this happens, replace - -- the aggregate with the element itself. + if not Is_Ignored (N) then + Set_SCO_Pragma_Enabled (Loc); + end if; - if Multiple then - Remove (Output); - Rewrite (Outputs, Output); - end if; + if Arg_Count = 2 then + Cond := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Cond), + Right_Opnd => Get_Pragma_Arg (Arg1)); + Call := Get_Pragma_Arg (Arg2); + else + Call := Get_Pragma_Arg (Arg1); + end if; - -- Default case + if Nkind_In (Call, + N_Indexed_Component, + N_Function_Call, + N_Identifier, + N_Expanded_Name, + N_Selected_Component) + then + -- If this pragma Debug comes from source, its argument was + -- parsed as a name form (which is syntactically identical). + -- In a generic context a parameterless call will be left as + -- an expanded name (if global) or selected_component if local. + -- Change it to a procedure call statement now. - else - -- Unchain the output from its output list as it will - -- appear in a new clause. Note that we cannot simply - -- rewrite the output as null because this will violate - -- the semantics of aspect/pragma Depends. + Change_Name_To_Procedure_Call_Statement (Call); - Remove (Output); + elsif Nkind (Call) = N_Procedure_Call_Statement then - -- Create a new clause of the form: + -- Already in the form of a procedure call statement: nothing + -- to do (could happen in case of an internally generated + -- pragma Debug). - -- (Output => Inputs) + null; - Clause := - Make_Component_Association (Loc, - Choices => New_List (Output), - Expression => New_Copy_Tree (Inputs)); + else + -- All other cases: diagnose error - -- The new clause contains replicated content that has - -- already been analyzed. There is not need to reanalyze - -- it or renormalize it again. + Error_Msg + ("argument of pragma ""Debug"" is not procedure call", + Sloc (Call)); + return; + end if; - Set_Analyzed (Clause); + -- Rewrite into a conditional with an appropriate condition. We + -- wrap the procedure call in a block so that overhead from e.g. + -- use of the secondary stack does not generate execution overhead + -- for suppressed conditions. - Propagate_Output - (Output => First (Choices (Clause)), - Inputs => Expression (Clause)); + -- Normally the analysis that follows will freeze the subprogram + -- being called. However, if the call is to a null procedure, + -- we want to freeze it before creating the block, because the + -- analysis that follows may be done with expansion disabled, in + -- which case the body will not be generated, leading to spurious + -- errors. - Insert_After (After, Clause); - end if; - end Create_Or_Modify_Clause; + if Nkind (Call) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (Call)) + then + Analyze (Name (Call)); + Freeze_Before (N, Entity (Name (Call))); + end if; - -- Local variables + Rewrite (N, Make_Implicit_If_Statement (N, + Condition => Cond, + Then_Statements => New_List ( + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Relocate_Node (Call))))))); + Analyze (N); + end Debug; - Outputs : constant Node_Id := First (Choices (Clause)); - Inputs : Node_Id; - Last_Output : Node_Id; - Next_Output : Node_Id; - Output : Node_Id; + ------------------ + -- Debug_Policy -- + ------------------ - -- Start of processing for Normalize_Clause + -- pragma Debug_Policy (On | Off | Check | Disable | Ignore) - begin - -- A self-dependency appears as operator "+". Remove the "+" - -- from the tree by moving the real inputs to their proper - -- place. + when Pragma_Debug_Policy => + GNAT_Pragma; + Check_Arg_Count (1); + Check_No_Identifiers; + Check_Arg_Is_Identifier (Arg1); - if Nkind (Expression (Clause)) = N_Op_Plus then - Rewrite - (Expression (Clause), Right_Opnd (Expression (Clause))); - Inputs := Expression (Clause); + -- Exactly equivalent to pragma Check_Policy (Debug, arg), so + -- rewrite it that way, and let the rest of the checking come + -- from analyzing the rewritten pragma. - -- Multiple outputs appear as an aggregate + Rewrite (N, + Make_Pragma (Loc, + Chars => Name_Check_Policy, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Debug)), - if Nkind (Outputs) = N_Aggregate then - Last_Output := Last (Expressions (Outputs)); + Make_Pragma_Argument_Association (Loc, + Expression => Get_Pragma_Arg (Arg1))))); + Analyze (N); - Output := First (Expressions (Outputs)); - while Present (Output) loop + ------------- + -- Depends -- + ------------- - -- Normalization may remove an output from its list, - -- preserve the subsequent output now. + -- pragma Depends (DEPENDENCY_RELATION); - Next_Output := Next (Output); + -- DEPENDENCY_RELATION ::= + -- null + -- | DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE} - Create_Or_Modify_Clause - (Output => Output, - Outputs => Outputs, - Inputs => Inputs, - After => Clause, - In_Place => Output = Last_Output, - Multiple => True); + -- DEPENDENCY_CLAUSE ::= + -- OUTPUT_LIST =>[+] INPUT_LIST + -- | NULL_DEPENDENCY_CLAUSE - Output := Next_Output; - end loop; + -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST - -- Solitary output + -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT}) - else - Create_Or_Modify_Clause - (Output => Outputs, - Outputs => Empty, - Inputs => Inputs, - After => Empty, - In_Place => True, - Multiple => False); - end if; - end if; - end Normalize_Clause; + -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT}) - -- Local variables + -- OUTPUT ::= NAME | FUNCTION_RESULT + -- INPUT ::= NAME - Clause : Node_Id; - Errors : Nat; - Last_Clause : Node_Id; - Subp_Decl : Node_Id; + -- where FUNCTION_RESULT is a function Result attribute_reference - -- Start of processing for Depends + when Pragma_Depends => Depends : declare + Subp_Decl : Node_Id; + Subp_Id : Entity_Id; begin GNAT_Pragma; @@ -10311,95 +10706,36 @@ package body Sem_Prag is Check_Arg_Count (1); -- Ensure the proper placement of the pragma. Depends must be - -- associated with a subprogram declaration. + -- associated with a subprogram declaration or a body that acts + -- as a spec. Subp_Decl := Parent (Corresponding_Aspect (N)); - if Nkind (Subp_Decl) /= N_Subprogram_Declaration then + if Nkind (Subp_Decl) /= N_Subprogram_Declaration + and then (Nkind (Subp_Decl) /= N_Subprogram_Body + or else not Acts_As_Spec (Subp_Decl)) + then Pragma_Misplaced; return; end if; Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); - Clause := Expression (Arg1); - -- Empty dependency list + -- The pragma is analyzed at the end of the declarative part which + -- contains the related subprogram. Reset the analyzed flag. - if Nkind (Clause) = N_Null then + Set_Analyzed (N, False); - -- Gather all states, variables and formal parameters that the - -- subprogram may depend on. These items are obtained from the - -- parameter profile or pragma Global (if available). + -- When the aspect/pragma appears on a subprogram body, perform + -- the full analysis now. - Collect_Subprogram_Inputs_Outputs; + if Nkind (Subp_Decl) = N_Subprogram_Body then + Analyze_Depends_In_Decl_Part (N); - -- Verify that every input or output of the subprogram appear - -- in a dependency. - - Check_Usage (Subp_Inputs, All_Inputs_Seen, True); - Check_Usage (Subp_Outputs, Outputs_Seen, False); - Check_Function_Return; - - -- Dependency clauses appear as component associations of an - -- aggregate. - - elsif Nkind (Clause) = N_Aggregate - and then Present (Component_Associations (Clause)) - then - Last_Clause := Last (Component_Associations (Clause)); - - -- Gather all states, variables and formal parameters that the - -- subprogram may depend on. These items are obtained from the - -- parameter profile or pragma Global (if available). - - Collect_Subprogram_Inputs_Outputs; - - -- Ensure that the formal parameters are visible when analyzing - -- all clauses. This falls out of the general rule of aspects - -- pertaining to subprogram declarations. - - Push_Scope (Subp_Id); - Install_Formals (Subp_Id); - - Clause := First (Component_Associations (Clause)); - while Present (Clause) loop - Errors := Serious_Errors_Detected; - - -- Normalization may create extra clauses that contain - -- replicated input and output names. There is no need - -- to reanalyze or renormalize these extra clauses. - - if not Analyzed (Clause) then - Set_Analyzed (Clause); - - Analyze_Dependency_Clause - (Clause => Clause, - Is_Last => Clause = Last_Clause); - - -- Do not normalize an erroneous clause because the - -- inputs or outputs may denote illegal items. - - if Errors = Serious_Errors_Detected then - Normalize_Clause (Clause); - end if; - end if; - - Next (Clause); - end loop; - - End_Scope; - - -- Verify that every input or output of the subprogram appear - -- in a dependency. - - Check_Usage (Subp_Inputs, All_Inputs_Seen, True); - Check_Usage (Subp_Outputs, Outputs_Seen, False); - Check_Function_Return; - - -- The top level dependency relation is malformed + -- Chain the pragma on the contract for further processing else - Error_Msg_N ("malformed dependency relation", Clause); + Add_Contract_Item (N, Subp_Id); end if; end Depends; @@ -11640,290 +11976,8 @@ package body Sem_Prag is -- GLOBAL_ITEM ::= NAME when Pragma_Global => Global : declare - Subp_Id : Entity_Id; - - Seen : Elist_Id := No_Elist; - -- A list containing the entities of all the items processed so - -- far. It plays a role in detecting distinct entities. - - Contract_Seen : Boolean := False; - In_Out_Seen : Boolean := False; - Input_Seen : Boolean := False; - Output_Seen : Boolean := False; - -- Flags used to verify the consistency of modes - - procedure Analyze_Global_List - (List : Node_Id; - Global_Mode : Name_Id := Name_Input); - -- Verify the legality of a single global list declaration. - -- Global_Mode denotes the current mode in effect. - - ------------------------- - -- Analyze_Global_List -- - ------------------------- - - procedure Analyze_Global_List - (List : Node_Id; - Global_Mode : Name_Id := Name_Input) - is - procedure Analyze_Global_Item - (Item : Node_Id; - Global_Mode : Name_Id); - -- Verify the legality of a single global item declaration. - -- Global_Mode denotes the current mode in effect. - - procedure Check_Duplicate_Mode - (Mode : Node_Id; - Status : in out Boolean); - -- Flag Status denotes whether a particular mode has been seen - -- while processing a global list. This routine verifies that - -- Mode is not a duplicate mode and sets the flag Status. - - procedure Check_Mode_Restriction_In_Function (Mode : Node_Id); - -- Mode denotes either In_Out or Output. Depending on the kind - -- of the related subprogram, emit an error if those two modes - -- apply to a function. - - ------------------------- - -- Analyze_Global_Item -- - ------------------------- - - procedure Analyze_Global_Item - (Item : Node_Id; - Global_Mode : Name_Id) - is - Item_Id : Entity_Id; - - begin - -- Detect one of the following cases - - -- with Global => (null, Name) - -- with Global => (Name_1, null, Name_2) - -- with Global => (Name, null) - - if Nkind (Item) = N_Null then - Error_Msg_N - ("cannot mix null and non-null global items", Item); - return; - end if; - - Analyze (Item); - - -- Find the entity of the item. If this is a renaming, climb - -- the renaming chain to reach the root object. Renamings of - -- non-entire objects do not yield an entity (Empty). - - Item_Id := Entity_Of (Item); - - if Present (Item_Id) then - - -- A global item cannot reference a formal parameter. Do - -- this check first to provide a better error diagnostic. - - if Is_Formal (Item_Id) then - Error_Msg_N - ("global item cannot reference formal parameter", - Item); - return; - - -- The only legal references are those to abstract states - -- and variables. - - elsif not Ekind_In (Item_Id, E_Abstract_State, - E_Variable) - then - Error_Msg_N - ("global item must denote variable or state", Item); - return; - end if; - - -- When the item renames an entire object, replace the - -- item with a reference to the object. - - if Present (Renamed_Object (Entity (Item))) then - Rewrite (Item, - New_Reference_To (Item_Id, Sloc (Item))); - Analyze (Item); - end if; - - -- Some form of illegal construct masquerading as a name - - else - Error_Msg_N - ("global item must denote variable or state", Item); - return; - end if; - - -- The same entity might be referenced through various way. - -- Check the entity of the item rather than the item itself. - - if Contains (Seen, Item_Id) then - Error_Msg_N ("duplicate global item", Item); - - -- Add the entity of the current item to the list of - -- processed items. - - else - Add_Item (Item_Id, Seen); - end if; - - if Ekind (Item_Id) = E_Abstract_State - and then Is_Volatile_State (Item_Id) - then - -- A global item of mode In_Out or Output cannot denote a - -- volatile Input state. - - if Is_Input_State (Item_Id) - and then Nam_In (Global_Mode, Name_In_Out, Name_Output) - then - Error_Msg_N - ("global item of mode In_Out or Output cannot " - & "reference Volatile Input state", Item); - - -- A global item of mode In_Out or Input cannot reference - -- a volatile Output state. - - elsif Is_Output_State (Item_Id) - and then Nam_In (Global_Mode, Name_In_Out, Name_Input) - then - Error_Msg_N - ("global item of mode In_Out or Input cannot " - & "reference Volatile Output state", Item); - end if; - end if; - end Analyze_Global_Item; - - -------------------------- - -- Check_Duplicate_Mode -- - -------------------------- - - procedure Check_Duplicate_Mode - (Mode : Node_Id; - Status : in out Boolean) - is - begin - if Status then - Error_Msg_N ("duplicate global mode", Mode); - end if; - - Status := True; - end Check_Duplicate_Mode; - - ---------------------------------------- - -- Check_Mode_Restriction_In_Function -- - ---------------------------------------- - - procedure Check_Mode_Restriction_In_Function (Mode : Node_Id) is - begin - if Ekind (Subp_Id) = E_Function then - Error_Msg_N - ("global mode & not applicable to functions", Mode); - end if; - end Check_Mode_Restriction_In_Function; - - -- Local variables - - Assoc : Node_Id; - Item : Node_Id; - Mode : Node_Id; - - -- Start of processing for Analyze_Global_List - - begin - -- Single global item declaration - - if Nkind_In (List, N_Identifier, N_Selected_Component) then - Analyze_Global_Item (List, Global_Mode); - - -- Simple global list or moded global list declaration - - elsif Nkind (List) = N_Aggregate then - - -- The declaration of a simple global list appear as a - -- collection of expressions. - - if Present (Expressions (List)) then - if Present (Component_Associations (List)) then - Error_Msg_N - ("cannot mix moded and non-moded global lists", - List); - end if; - - Item := First (Expressions (List)); - while Present (Item) loop - Analyze_Global_Item (Item, Global_Mode); - - Next (Item); - end loop; - - -- The declaration of a moded global list appears as a - -- collection of component associations where individual - -- choices denote modes. - - elsif Present (Component_Associations (List)) then - if Present (Expressions (List)) then - Error_Msg_N - ("cannot mix moded and non-moded global lists", - List); - end if; - - Assoc := First (Component_Associations (List)); - while Present (Assoc) loop - Mode := First (Choices (Assoc)); - - if Nkind (Mode) = N_Identifier then - if Chars (Mode) = Name_Contract_In then - Check_Duplicate_Mode (Mode, Contract_Seen); - - elsif Chars (Mode) = Name_In_Out then - Check_Duplicate_Mode (Mode, In_Out_Seen); - Check_Mode_Restriction_In_Function (Mode); - - elsif Chars (Mode) = Name_Input then - Check_Duplicate_Mode (Mode, Input_Seen); - - elsif Chars (Mode) = Name_Output then - Check_Duplicate_Mode (Mode, Output_Seen); - Check_Mode_Restriction_In_Function (Mode); - - else - Error_Msg_N ("invalid mode selector", Mode); - end if; - - else - Error_Msg_N ("invalid mode selector", Mode); - end if; - - -- Items in a moded list appear as a collection of - -- expressions. Reuse the existing machinery to - -- analyze them. - - Analyze_Global_List - (List => Expression (Assoc), - Global_Mode => Chars (Mode)); - - Next (Assoc); - end loop; - - -- Something went horribly wrong, we have a malformed tree - - else - raise Program_Error; - end if; - - -- Any other attempt to declare a global item is erroneous - - else - Error_Msg_N ("malformed global list declaration", List); - end if; - end Analyze_Global_List; - - -- Local variables - - List : Node_Id; - Subp : Node_Id; - - -- Start of processing for Global + Subp_Decl : Node_Id; + Subp_Id : Entity_Id; begin GNAT_Pragma; @@ -11931,38 +11985,36 @@ package body Sem_Prag is Check_Arg_Count (1); -- Ensure the proper placement of the pragma. Global must be - -- associated with a subprogram declaration. + -- associated with a subprogram declaration or a body that acts + -- as a spec. - Subp := Parent (Corresponding_Aspect (N)); + Subp_Decl := Parent (Corresponding_Aspect (N)); - if Nkind (Subp) /= N_Subprogram_Declaration then + if Nkind (Subp_Decl) /= N_Subprogram_Declaration + and then (Nkind (Subp_Decl) /= N_Subprogram_Body + or else not Acts_As_Spec (Subp_Decl)) + then Pragma_Misplaced; return; end if; - Subp_Id := Defining_Unit_Name (Specification (Subp)); - List := Expression (Arg1); - - -- There is nothing to be done for a null global list + Subp_Id := Defining_Unit_Name (Specification (Subp_Decl)); - if Nkind (List) = N_Null then - null; + -- The pragma is analyzed at the end of the declarative part which + -- contains the related subprogram. Reset the analyzed flag. - -- Analyze the various forms of global lists and items. Note that - -- some of these may be malformed in which case the analysis emits - -- error messages. + Set_Analyzed (N, False); - else - -- Ensure that the formal parameters are visible when - -- processing an item. This falls out of the general rule of - -- aspects pertaining to subprogram declarations. + -- When the aspect/pragma appears on a subprogram body, perform + -- the full analysis now. - Push_Scope (Subp_Id); - Install_Formals (Subp_Id); + if Nkind (Subp_Decl) = N_Subprogram_Body then + Analyze_Global_In_Decl_Part (N); - Analyze_Global_List (List); + -- Chain the pragma on the contract for further processing - End_Scope; + else + Add_Contract_Item (N, Subp_Id); end if; end Global; diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index 3ec3e3b..5bf118a 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -46,6 +46,12 @@ package Sem_Prag is -- expressions in the pragma as "spec expressions" (see section in Sem -- "Handling of Default and Per-Object Expressions..."). + procedure Analyze_Depends_In_Decl_Part (N : Node_Id); + -- Perform full analysis of delayed pragma Depends + + procedure Analyze_Global_In_Decl_Part (N : Node_Id); + -- Perform full analysis of delayed pragma Global + procedure Analyze_PPC_In_Decl_Part (N : Node_Id; S : Entity_Id); -- Special analyze routine for precondition/postcondition pragma that -- appears within a declarative part where the pragma is associated diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e82080e..51c63de 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -208,6 +208,43 @@ package body Sem_Util is Append_Elmt (A, L); end Add_Access_Type_To_Process; + ----------------------- + -- Add_Contract_Item -- + ----------------------- + + procedure Add_Contract_Item (Item : Node_Id; Subp_Id : Entity_Id) is + Items : constant Node_Id := Contract (Subp_Id); + Nam : Name_Id; + + begin + if Present (Items) and then Nkind (Item) = N_Pragma then + Nam := Pragma_Name (Item); + + if Nam_In (Nam, Name_Precondition, Name_Postcondition) then + Set_Next_Pragma (Item, Pre_Post_Conditions (Items)); + Set_Pre_Post_Conditions (Items, Item); + + elsif Nam_In (Nam, Name_Contract_Cases, Name_Test_Case) then + Set_Next_Pragma (Item, Contract_Test_Cases (Items)); + Set_Contract_Test_Cases (Items, Item); + + elsif Nam_In (Nam, Name_Depends, Name_Global) then + Set_Next_Pragma (Item, Classifications (Items)); + Set_Classifications (Items, Item); + + -- The pragma is not a proper contract item + + else + raise Program_Error; + end if; + + -- The subprogram has not been properly decorated or the item is illegal + + else + raise Program_Error; + end if; + end Add_Contract_Item; + ---------------------------- -- Add_Global_Declaration -- ---------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 6151315..66c31c9 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -43,6 +43,11 @@ package Sem_Util is -- Add A to the list of access types to process when expanding the -- freeze node of E. + procedure Add_Contract_Item (Item : Node_Id; Subp_Id : Entity_Id); + -- Add a contract item (pragma Precondition, Postcondition, Test_Case, + -- Contract_Cases, Global, Depends) to the contract of a subprogram. Item + -- denotes a pragma and Subp_Id is the related subprogram. + procedure Add_Global_Declaration (N : Node_Id); -- These procedures adds a declaration N at the library level, to be -- elaborated before any other code in the unit. It is used for example diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index dc7d973..c8eab8a 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -423,6 +423,14 @@ package body Sinfo is return Flag6 (N); end Class_Present; + function Classifications + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + return Node3 (N); + end Classifications; + function Comes_From_Extended_Return_Statement (N : Node_Id) return Boolean is begin @@ -585,6 +593,14 @@ package body Sinfo is return Flag16 (N); end Context_Pending; + function Contract_Test_Cases + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + return Node2 (N); + end Contract_Test_Cases; + function Controlling_Argument (N : Node_Id) return Node_Id is begin @@ -2494,6 +2510,14 @@ package body Sinfo is return List4 (N); end Pragmas_Before; + function Pre_Post_Conditions + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + return Node1 (N); + end Pre_Post_Conditions; + function Prefix (N : Node_Id) return Node_Id is begin @@ -2832,22 +2856,6 @@ package body Sinfo is return Node1 (N); end Source_Type; - function Spec_PPC_List - (N : Node_Id) return Node_Id is - begin - pragma Assert (False - or else NT (N).Nkind = N_Contract); - return Node1 (N); - end Spec_PPC_List; - - function Spec_CTC_List - (N : Node_Id) return Node_Id is - begin - pragma Assert (False - or else NT (N).Nkind = N_Contract); - return Node2 (N); - end Spec_CTC_List; - function Specification (N : Node_Id) return Node_Id is begin @@ -3532,8 +3540,16 @@ package body Sinfo is Set_Flag6 (N, Val); end Set_Class_Present; + procedure Set_Classifications + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + Set_Node3 (N, Val); -- semantic field, no parent set + end Set_Classifications; + procedure Set_Comes_From_Extended_Return_Statement - (N : Node_Id; Val : Boolean := True) is + (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False or else NT (N).Nkind = N_Simple_Return_Statement); @@ -3694,6 +3710,14 @@ package body Sinfo is Set_Flag16 (N, Val); end Set_Context_Pending; + procedure Set_Contract_Test_Cases + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + Set_Node2 (N, Val); -- semantic field, no parent set + end Set_Contract_Test_Cases; + procedure Set_Controlling_Argument (N : Node_Id; Val : Node_Id) is begin @@ -5594,6 +5618,14 @@ package body Sinfo is Set_List4_With_Parent (N, Val); end Set_Pragmas_Before; + procedure Set_Pre_Post_Conditions + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Contract); + Set_Node1 (N, Val); -- semantic field, no parent set + end Set_Pre_Post_Conditions; + procedure Set_Prefix (N : Node_Id; Val : Node_Id) is begin @@ -5932,22 +5964,6 @@ package body Sinfo is Set_Node1 (N, Val); -- semantic field, no parent set end Set_Source_Type; - procedure Set_Spec_PPC_List - (N : Node_Id; Val : Node_Id) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Contract); - Set_Node1 (N, Val); -- semantic field, no parent set - end Set_Spec_PPC_List; - - procedure Set_Spec_CTC_List - (N : Node_Id; Val : Node_Id) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Contract); - Set_Node2 (N, Val); -- semantic field, no parent set - end Set_Spec_CTC_List; - procedure Set_Specification (N : Node_Id; Val : Node_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 7ded7db..5529bd5 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -7038,22 +7038,23 @@ package Sinfo is -- N_Contract -- Sloc points to the subprogram's name - -- Spec_PPC_List (Node1) (set to Empty if none) - -- Spec_CTC_List (Node2) (set to Empty if none) - - -- Spec_PPC_List points to a list of Precondition and Postcondition - -- pragma nodes for preconditions and postconditions declared in the - -- spec of the entry/subprogram. The last pragma encountered is at the - -- head of this list, so it is in reverse order of textual appearance. - -- Note that this includes precondition/postcondition pragmas generated - -- to correspond to Pre/Post aspects. - - -- Spec_CTC_List points to a list of Contract_Cases and Test_Case pragma - -- nodes for contract-cases and test-cases declared in the spec of the - -- entry/subprogram. The last pragma encountered is at the head of this - -- list, so it is in reverse order of textual appearance. Note that - -- this includes contract-cases and test-case pragmas generated from - -- Contract_Cases and Test_Case aspects. + -- Pre_Post_Conditions (Node1) (set to Empty if none) + -- Contract_Test_Cases (Node2) (set to Empty if none) + -- Classifications (Node3) (set to Empty if none) + + -- Pre_Post_Conditions contains a collection of pragmas that correspond + -- to pre- and post-conditions associated with an entry or a subprogram. + -- The pragmas can either come from source or be the byproduct of aspect + -- expansion. The ordering in the list is of LIFO fasion. + + -- Contract_Test_Cases contains a collection of pragmas that correspond + -- to aspects/pragmas Contract_Cases and Test_Case. The ordering in the + -- list is of LIFO fasion. + + -- Classifications contains pragmas that either categorize subprogram + -- inputs and outputs or establish dependencies between them. Currently + -- pragmas Depends and Global are stored in this list. The ordering is + -- of LIFO fasion. ------------------- -- Expanded_Name -- @@ -8306,6 +8307,9 @@ package Sinfo is function Class_Present (N : Node_Id) return Boolean; -- Flag6 + function Classifications + (N : Node_Id) return Node_Id; -- Node3 + function Comes_From_Extended_Return_Statement (N : Node_Id) return Boolean; -- Flag18 @@ -8360,6 +8364,9 @@ package Sinfo is function Context_Items (N : Node_Id) return List_Id; -- List1 + function Contract_Test_Cases + (N : Node_Id) return Node_Id; -- Node2 + function Controlling_Argument (N : Node_Id) return Node_Id; -- Node1 @@ -8954,6 +8961,9 @@ package Sinfo is function Pragmas_Before (N : Node_Id) return List_Id; -- List4 + function Pre_Post_Conditions + (N : Node_Id) return Node_Id; -- Node1 + function Prefix (N : Node_Id) return Node_Id; -- Node3 @@ -9062,12 +9072,6 @@ package Sinfo is function Source_Type (N : Node_Id) return Entity_Id; -- Node1 - function Spec_PPC_List - (N : Node_Id) return Node_Id; -- Node1 - - function Spec_CTC_List - (N : Node_Id) return Node_Id; -- Node2 - function Specification (N : Node_Id) return Node_Id; -- Node1 @@ -9296,6 +9300,9 @@ package Sinfo is procedure Set_Class_Present (N : Node_Id; Val : Boolean := True); -- Flag6 + procedure Set_Classifications + (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Comes_From_Extended_Return_Statement (N : Node_Id; Val : Boolean := True); -- Flag18 @@ -9350,6 +9357,9 @@ package Sinfo is procedure Set_Context_Pending (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Contract_Test_Cases + (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Controlling_Argument (N : Node_Id; Val : Node_Id); -- Node1 @@ -9941,6 +9951,9 @@ package Sinfo is procedure Set_Pragmas_Before (N : Node_Id; Val : List_Id); -- List4 + procedure Set_Pre_Post_Conditions + (N : Node_Id; Val : Node_Id); -- Node1 + procedure Set_Prefix (N : Node_Id; Val : Node_Id); -- Node3 @@ -10049,12 +10062,6 @@ package Sinfo is procedure Set_Source_Type (N : Node_Id; Val : Entity_Id); -- Node1 - procedure Set_Spec_PPC_List - (N : Node_Id; Val : Node_Id); -- Node1 - - procedure Set_Spec_CTC_List - (N : Node_Id; Val : Node_Id); -- Node2 - procedure Set_Specification (N : Node_Id; Val : Node_Id); -- Node1 @@ -11701,9 +11708,9 @@ package Sinfo is 5 => False), -- Etype (Node5-Sem) N_Contract => - (1 => False, -- Spec_PPC_List (Node1) - 2 => False, -- Spec_CTC_List (Node2) - 3 => False, -- unused + (1 => False, -- Pre_Post_Conditions (Node1) + 2 => False, -- Contract_Test_Cases (Node2) + 3 => False, -- Classifications (Node3) 4 => False, -- unused 5 => False), -- unused @@ -11946,6 +11953,7 @@ package Sinfo is pragma Inline (Choice_Parameter); pragma Inline (Choices); pragma Inline (Class_Present); + pragma Inline (Classifications); pragma Inline (Comes_From_Extended_Return_Statement); pragma Inline (Compile_Time_Known_Aggregate); pragma Inline (Component_Associations); @@ -11964,6 +11972,7 @@ package Sinfo is pragma Inline (Context_Installed); pragma Inline (Context_Items); pragma Inline (Context_Pending); + pragma Inline (Contract_Test_Cases); pragma Inline (Controlling_Argument); pragma Inline (Convert_To_Return_False); pragma Inline (Conversion_OK); @@ -12162,6 +12171,7 @@ package Sinfo is pragma Inline (Pragma_Identifier); pragma Inline (Pragmas_After); pragma Inline (Pragmas_Before); + pragma Inline (Pre_Post_Conditions); pragma Inline (Prefix); pragma Inline (Premature_Use); pragma Inline (Present_Expr); @@ -12198,8 +12208,6 @@ package Sinfo is pragma Inline (Selector_Names); pragma Inline (Shift_Count_OK); pragma Inline (Source_Type); - pragma Inline (Spec_PPC_List); - pragma Inline (Spec_CTC_List); pragma Inline (Specification); pragma Inline (Split_PPC); pragma Inline (Statements); @@ -12273,6 +12281,7 @@ package Sinfo is pragma Inline (Set_Choice_Parameter); pragma Inline (Set_Choices); pragma Inline (Set_Class_Present); + pragma Inline (Set_Classifications); pragma Inline (Set_Comes_From_Extended_Return_Statement); pragma Inline (Set_Compile_Time_Known_Aggregate); pragma Inline (Set_Component_Associations); @@ -12291,6 +12300,7 @@ package Sinfo is pragma Inline (Set_Context_Installed); pragma Inline (Set_Context_Items); pragma Inline (Set_Context_Pending); + pragma Inline (Set_Contract_Test_Cases); pragma Inline (Set_Controlling_Argument); pragma Inline (Set_Conversion_OK); pragma Inline (Set_Convert_To_Return_False); @@ -12487,6 +12497,7 @@ package Sinfo is pragma Inline (Set_Pragma_Identifier); pragma Inline (Set_Pragmas_After); pragma Inline (Set_Pragmas_Before); + pragma Inline (Set_Pre_Post_Conditions); pragma Inline (Set_Prefix); pragma Inline (Set_Premature_Use); pragma Inline (Set_Present_Expr); @@ -12522,9 +12533,6 @@ package Sinfo is pragma Inline (Set_Selector_Names); pragma Inline (Set_Shift_Count_OK); pragma Inline (Set_Source_Type); - pragma Inline (Set_Spec_CTC_List); - pragma Inline (Set_Spec_PPC_List); - pragma Inline (Set_Specification); pragma Inline (Set_Split_PPC); pragma Inline (Set_Statements); pragma Inline (Set_Storage_Pool); -- cgit v1.1