X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_prag.adb;h=469069437621b75092efdfeb508d8b0f0412d094;hb=d2500eb5291d59d84a61ef717bf1343e25d3b100;hp=ebc51619772e80911bc0877613b571c4de4bcb88;hpb=23255a5b14416256c1b36986cdc40840ce5ff434;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index ebc51619772..46906943762 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -29,6 +29,7 @@ -- to complete the syntax checks. Certain pragmas are handled partially or -- completely by the parser (see Par.Prag for further details). +with Aspects; use Aspects; with Atree; use Atree; with Casing; use Casing; with Checks; use Checks; @@ -37,8 +38,9 @@ with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; -with Exp_Ch7; use Exp_Ch7; with Exp_Dist; use Exp_Dist; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; with Lib; use Lib; with Lib.Writ; use Lib.Writ; with Lib.Xref; use Lib.Xref; @@ -179,6 +181,11 @@ package body Sem_Prag is -- original one, following the renaming chain) is returned. Otherwise the -- entity is returned unchanged. Should be in Einfo??? + procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id); + -- Preanalyze the boolean expressions in the Requires and Ensures arguments + -- of a Test_Case pragma if present (possibly Empty). We treat these as + -- spec expressions (i.e. similar to a default expression). + procedure rv; -- This is a dummy function called by the processing for pragma Reviewable. -- It is there for assisting front end debugging. By placing a Reviewable @@ -253,11 +260,106 @@ package body Sem_Prag is -- Preanalyze the boolean expression, we treat this as a spec expression -- (i.e. similar to a default expression). - pragma Assert (In_Pre_Post_Expression = False); - In_Pre_Post_Expression := True; Preanalyze_Spec_Expression (Get_Pragma_Arg (Arg1), Standard_Boolean); - In_Pre_Post_Expression := False; + + -- 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 Class_Present (N) then + declare + T : constant Entity_Id := Find_Dispatching_Type (S); + + ACW : Entity_Id := Empty; + -- Access to T'class, created if there is a controlling formal + -- that is an access parameter. + + 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. + + 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. + + ------------- + -- Get_ACW -- + ------------- + + function Get_ACW return Entity_Id is + Loc : constant Source_Ptr := Sloc (N); + Decl : Node_Id; + + 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)); + + Insert_Before (Unit_Declaration_Node (S), Decl); + Analyze (Decl); + ACW := Defining_Identifier (Decl); + Freeze_Before (Unit_Declaration_Node (S), ACW); + end if; + + return ACW; + end Get_ACW; + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + Loc : constant Source_Ptr := Sloc (N); + Typ : Entity_Id; + + 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); + + elsif Is_Access_Type (Etype (Entity (N))) + and then Designated_Type (Etype (Entity (N))) = T + then + Typ := Get_ACW; + else + Typ := Empty; + end if; + + 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; + + return OK; + end Process; + + procedure Replace_Type is new Traverse_Proc (Process); + + begin + Replace_Type (Get_Pragma_Arg (Arg1)); + end; + end if; -- Remove the subprogram from the scope stack now that the pre-analysis -- of the precondition/postcondition is done. @@ -271,9 +373,13 @@ package body Sem_Prag is procedure Analyze_Pragma (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Pname : constant Name_Id := Pragma_Name (N); Prag_Id : Pragma_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. + 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 @@ -350,12 +456,18 @@ package body Sem_Prag is -- Check the specified argument Arg to make sure that it is a valid -- locking policy name. If not give error and raise Pragma_Exit. - 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 : 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, 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 if present). - -- If not then give error and raise Pragma_Exit. + -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if + -- present). If not then give error and raise Pragma_Exit. procedure Check_Arg_Is_Queuing_Policy (Arg : Node_Id); -- Check the specified argument Arg to make sure that it is a valid @@ -410,6 +522,18 @@ package body Sem_Prag is -- Checks that Arg, whose expression is an entity name, references a -- first subtype. + 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. + + 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. + procedure Check_In_Main_Program; -- Common checks for pragmas that appear within a main program -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU). @@ -439,12 +563,12 @@ package body Sem_Prag is 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 Error_Pragmas raised. + -- identifier, then an error message is given and Pragma_Exit is raised. 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 Error_Pragmas raised. + -- 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. @@ -478,6 +602,16 @@ package body Sem_Prag is -- that the constraint is static as required by the restrictions for -- Unchecked_Union. + procedure Check_Test_Case; + -- Called to process a test-case pragma. 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. + -- This pragma 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_TC_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. + procedure Check_Valid_Configuration_Pragma; -- Legality checks for placement of a configuration pragma @@ -923,6 +1057,7 @@ package body Sem_Prag is if Is_Compilation_Unit (Ent) then declare Decl : constant Node_Id := Unit_Declaration_Node (Ent); + begin -- Case of pragma placed immediately after spec @@ -1020,8 +1155,8 @@ package body Sem_Prag is end Check_Arg_Is_One_Of; procedure Check_Arg_Is_One_Of - (Arg : Node_Id; - N1, N2, N3, N4 : Name_Id) + (Arg : Node_Id; + N1, N2, N3, N4, N5 : Name_Id) is Argx : constant Node_Id := Get_Pragma_Arg (Arg); @@ -1032,6 +1167,7 @@ package body Sem_Prag is and then Chars (Argx) /= N2 and then Chars (Argx) /= N3 and then Chars (Argx) /= N4 + and then Chars (Argx) /= N5 then Error_Pragma_Arg ("invalid argument for pragma%", Argx); end if; @@ -1364,6 +1500,48 @@ package body Sem_Prag is end if; end Check_First_Subtype; + ---------------------- + -- Check_Identifier -- + ---------------------- + + 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; + + -------------------------------- + -- Check_Identifier_Is_One_Of -- + -------------------------------- + + 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; + + 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; + --------------------------- -- Check_In_Main_Program -- --------------------------- @@ -1571,10 +1749,10 @@ package body Sem_Prag is PO : Node_Id; procedure Chain_PPC (PO : Node_Id); - -- If PO is a subprogram declaration node (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. + -- 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. --------------- -- Chain_PPC -- @@ -1637,7 +1815,7 @@ package body Sem_Prag is if Pragma_Name (N) = Name_Precondition then if not From_Aspect_Specification (N) then - P := Spec_PPC_List (S); + P := Spec_PPC_List (Contract (S)); while Present (P) loop if Pragma_Name (P) = Name_Precondition and then From_Aspect_Specification (P) @@ -1666,7 +1844,7 @@ package body Sem_Prag is begin for J in Inherited'Range loop - P := Spec_PPC_List (Inherited (J)); + P := Spec_PPC_List (Contract (Inherited (J))); while Present (P) loop if Pragma_Name (P) = Name_Precondition and then Class_Present (P) @@ -1691,8 +1869,8 @@ package body Sem_Prag is -- Chain spec PPC pragma to list for subprogram - Set_Next_Pragma (N, Spec_PPC_List (S)); - Set_Spec_PPC_List (S, N); + Set_Next_Pragma (N, Spec_PPC_List (Contract (S))); + Set_Spec_PPC_List (Contract (S), N); -- Return indicating spec case @@ -1700,7 +1878,7 @@ package body Sem_Prag is return; end Chain_PPC; - -- Start of processing for Check_Precondition_Postcondition + -- Start of processing for Check_Precondition_Postcondition begin if not Is_List_Member (N) then @@ -1716,10 +1894,9 @@ package body Sem_Prag is (Get_Pragma_Arg (Arg2), Standard_String); end if; - -- Record if pragma is enabled + -- Record if pragma is disabled if Check_Enabled (Pname) then - Set_Pragma_Enabled (N); Set_SCO_Pragma_Enabled (Loc); end if; @@ -1766,6 +1943,12 @@ package body Sem_Prag is Chain_PPC (PO); return; + elsif Nkind (PO) = N_Subprogram_Declaration + and then In_Instance + then + Chain_PPC (PO); + return; + -- For all other cases of non source code, do nothing else @@ -1801,6 +1984,15 @@ package body Sem_Prag is -- See if it is in the pragmas after a library level subprogram elsif Nkind (Parent (N)) = N_Compilation_Unit_Aux then + + -- In formal verification mode, analyze pragma expression for + -- correctness, as it is not expanded later. + + if Alfa_Mode then + Analyze_PPC_In_Decl_Part + (N, Defining_Entity (Unit (Parent (Parent (N))))); + end if; + Chain_PPC (Unit (Parent (Parent (N)))); return; end if; @@ -1871,6 +2063,161 @@ package body Sem_Prag is end case; end Check_Static_Constraint; + --------------------- + -- Check_Test_Case -- + --------------------- + + procedure Check_Test_Case is + P : Node_Id; + PO : Node_Id; + + procedure Chain_TC (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. + + -------------- + -- Chain_TC -- + -------------- + + procedure Chain_TC (PO : Node_Id) is + S : Entity_Id; + + begin + if Nkind (PO) = N_Abstract_Subprogram_Declaration then + if From_Aspect_Specification (N) then + Error_Pragma + ("aspect% cannot be applied to abstract subprogram"); + else + Error_Pragma + ("pragma% cannot be applied to abstract subprogram"); + end if; + + elsif Nkind (PO) = N_Entry_Declaration then + if From_Aspect_Specification (N) then + Error_Pragma ("aspect% cannot be applied to entry"); + else + Error_Pragma ("pragma% cannot be applied to entry"); + end if; + + elsif not Nkind_In (PO, N_Subprogram_Declaration, + N_Generic_Subprogram_Declaration) + then + Pragma_Misplaced; + end if; + + -- Here if we have [generic] subprogram declaration + + S := Defining_Unit_Name (Specification (PO)); + + -- 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. + + -- There should not be another test case with the same name + -- associated to this subprogram. + + declare + Name : constant String_Id := Get_Name_From_Test_Case_Pragma (N); + TC : Node_Id; + + begin + TC := Spec_TC_List (Contract (S)); + while Present (TC) loop + + if String_Equal + (Name, Get_Name_From_Test_Case_Pragma (TC)) + then + Error_Msg_Sloc := Sloc (TC); + + if From_Aspect_Specification (N) then + Error_Pragma ("name for aspect% is already used#"); + else + Error_Pragma ("name for pragma% is already used#"); + end if; + end if; + + TC := Next_Pragma (TC); + end loop; + end; + + -- Chain spec TC pragma to list for subprogram + + Set_Next_Pragma (N, Spec_TC_List (Contract (S))); + Set_Spec_TC_List (Contract (S), N); + end Chain_TC; + + -- Start of processing for Check_Test_Case + + begin + if not Is_List_Member (N) then + Pragma_Misplaced; + end if; + + -- Test cases 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 + Pragma_Misplaced; + end if; + + -- Search prior declarations + + P := N; + while Present (Prev (P)) loop + P := Prev (P); + + -- 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. + + if Nkind (P) not in N_Generic_Declaration then + PO := Original_Node (P); + else + PO := P; + end if; + + -- Skip past prior pragma + + if Nkind (PO) = N_Pragma then + null; + + -- Skip stuff not coming from source + + elsif not Comes_From_Source (PO) then + null; + + -- 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. + + 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; + + else + Chain_TC (PO); + return; + end if; + end loop; + + -- If we fall through, pragma was misplaced + + Pragma_Misplaced; + end Check_Test_Case; + -------------------------------------- -- Check_Valid_Configuration_Pragma -- -------------------------------------- @@ -3014,6 +3361,38 @@ package body Sem_Prag is Ent := E; + -- Ada_Pass_By_Copy special checking + + 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 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; + + -- Ada_Pass_By_Reference special checking + + 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 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; + -- 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. @@ -4423,6 +4802,18 @@ package body Sem_Prag is then null; 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. + + 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); end if; end if; @@ -4500,7 +4891,8 @@ package body Sem_Prag is -- 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. + -- case, with the result applying to the ancestors, and + -- also allows Inline to apply to all previous homonyms. if not From_Aspect_Specification (N) then while Present (Homonym (Subp)) @@ -4728,11 +5120,14 @@ package body Sem_Prag is (Get_Base_Subprogram (Subprogram_Def), Link_Nam); end if; - -- We allow duplicated export names in CIL, as they are always + -- 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. - if Convention (Subprogram_Def) /= Convention_CIL then + 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; @@ -4920,6 +5315,26 @@ package body Sem_Prag is elsif Id = Name_No_Dependence then Check_Unit_Name (Expr); + -- Case of No_Specification_Of_Aspect => Identifier. + + elsif Id = Name_No_Specification_Of_Aspect then + declare + A_Id : Aspect_Id; + + begin + if Nkind (Expr) /= N_Identifier then + A_Id := No_Aspect; + else + A_Id := Get_Aspect_Id (Chars (Expr)); + end if; + + 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; + -- All other cases of restriction identifier present else @@ -5031,10 +5446,13 @@ package body Sem_Prag is -- Start of processing for Process_Suppress_Unsuppress begin - -- Ignore pragma Suppress/Unsuppress in codepeer mode on user code: - -- we want to generate checks for analysis purposes, as set by -gnatC + -- 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 - if CodePeer_Mode and then Comes_From_Source (N) then + if (CodePeer_Mode or Alfa_Mode) + and then Comes_From_Source (N) + then return; end if; @@ -5778,6 +6196,8 @@ package body Sem_Prag is -- Deal with unrecognized pragma + Pname := Pragma_Name (N); + if not Is_Pragma_Name (Pname) then if Warn_On_Unrecognized_Pragma then Error_Msg_Name_1 := Pname; @@ -5800,6 +6220,10 @@ package body Sem_Prag is Prag_Id := Get_Pragma_Id (Pname); + if Present (Corresponding_Aspect (N)) then + Pname := Chars (Identifier (Corresponding_Aspect (N))); + end if; + -- Preset arguments Arg_Count := 0; @@ -6056,56 +6480,63 @@ package body Sem_Prag is -- external tool and a tool-specific function. These arguments are -- not analyzed. - when Pragma_Annotate => Annotate : begin + when Pragma_Annotate => Annotate : declare + Arg : Node_Id; + Exp : Node_Id; + + begin GNAT_Pragma; Check_At_Least_N_Arguments (1); Check_Arg_Is_Identifier (Arg1); Check_No_Identifiers; Store_Note (N); - declare - Arg : Node_Id; - Exp : Node_Id; + -- Second parameter is optional, it is never analyzed - begin - -- Second unanalyzed parameter is optional + if No (Arg2) then + null; - if No (Arg2) then - null; - else - Arg := Next (Arg2); - while Present (Arg) loop - Exp := Get_Pragma_Arg (Arg); - Analyze (Exp); + -- Here if we have a second parameter - if Is_Entity_Name (Exp) then - null; + else + -- Second parameter must be identifier - -- For string literals, we assume Standard_String as the - -- type, unless the string contains wide or wide_wide - -- characters. + Check_Arg_Is_Identifier (Arg2); - 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; + -- Process remaining parameters if any - elsif Is_Overloaded (Exp) then - Error_Pragma_Arg - ("ambiguous argument for pragma%", Exp); + Arg := Next (Arg2); + while Present (Arg) loop + Exp := Get_Pragma_Arg (Arg); + Analyze (Exp); + if Is_Entity_Name (Exp) then + null; + + -- For string literals, we assume Standard_String as the + -- type, unless the string contains wide or wide_wide + -- characters. + + 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); + Resolve (Exp, Standard_String); end if; - Next (Arg); - end loop; - end if; - end; + elsif Is_Overloaded (Exp) then + Error_Pragma_Arg + ("ambiguous argument for pragma%", Exp); + + else + Resolve (Exp); + end if; + + Next (Arg); + end loop; + end if; end Annotate; ------------ @@ -6148,7 +6579,7 @@ package body Sem_Prag is Rewrite (N, Make_Pragma (Loc, - Chars => Name_Check, + Chars => Name_Check, Pragma_Argument_Associations => Newa)); Analyze (N); end Assert; @@ -6157,7 +6588,7 @@ package body Sem_Prag is -- Assertion_Policy -- ---------------------- - -- pragma Assertion_Policy (Check | Ignore) + -- pragma Assertion_Policy (Check | Disable |Ignore) when Pragma_Assertion_Policy => Assertion_Policy : declare Policy : Node_Id; @@ -6167,7 +6598,7 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; Check_Arg_Count (1); Check_No_Identifiers; - Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore); + Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore); -- We treat pragma Assertion_Policy as equivalent to: @@ -6567,9 +6998,9 @@ package body Sem_Prag is -- Check -- ----------- - -- pragma Check ([Name =>] Identifier, - -- [Check =>] Boolean_Expression - -- [,[Message =>] String_Expression]); + -- pragma Check ([Name =>] IDENTIFIER, + -- [Check =>] Boolean_EXPRESSION + -- [,[Message =>] String_EXPRESSION]); when Pragma_Check => Check : declare Expr : Node_Id; @@ -6592,14 +7023,20 @@ package body Sem_Prag is Check_Arg_Is_Identifier (Arg1); + -- Completely ignore if disabled + + if Check_Disabled (Chars (Get_Pragma_Arg (Arg1))) then + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + return; + end if; + -- Indicate if pragma is enabled. The Original_Node reference here -- is to deal with pragma Assert rewritten as a Check pragma. Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1))); if Check_On then - Set_Pragma_Enabled (N); - Set_Pragma_Enabled (Original_Node (N)); Set_SCO_Pragma_Enabled (Loc); end if; @@ -6679,7 +7116,7 @@ package body Sem_Prag is -- [Name =>] IDENTIFIER, -- [Policy =>] POLICY_IDENTIFIER); - -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | IGNORE + -- POLICY_IDENTIFIER ::= ON | OFF | CHECK | DISABLE | IGNORE -- Note: this is a configuration pragma, but it is allowed to appear -- anywhere else. @@ -6690,7 +7127,7 @@ package body Sem_Prag is Check_Optional_Identifier (Arg1, Name_Name); Check_Optional_Identifier (Arg2, Name_Policy); Check_Arg_Is_One_Of - (Arg2, Name_On, Name_Off, Name_Check, Name_Ignore); + (Arg2, Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore); -- A Check_Policy pragma can appear either as a configuration -- pragma, or in a declarative part or a package spec (see RM @@ -7333,21 +7770,65 @@ package body Sem_Prag is -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT); when Pragma_Debug => Debug : declare - Cond : Node_Id; + Cond : Node_Id; + Call : Node_Id; begin GNAT_Pragma; + -- Skip analysis if disabled + + if Debug_Pragmas_Disabled then + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + return; + end if; + Cond := New_Occurrence_Of (Boolean_Literals (Debug_Pragmas_Enabled and Expander_Active), Loc); + if Debug_Pragmas_Enabled then + Set_SCO_Pragma_Enabled (Loc); + end if; + if Arg_Count = 2 then Cond := Make_And_Then (Loc, - Left_Opnd => Relocate_Node (Cond), - Right_Opnd => Get_Pragma_Arg (Arg1)); + Left_Opnd => Relocate_Node (Cond), + Right_Opnd => Get_Pragma_Arg (Arg1)); + Call := Get_Pragma_Arg (Arg2); + else + Call := Get_Pragma_Arg (Arg1); + end if; + + if Nkind_In (Call, + N_Indexed_Component, + N_Function_Call, + N_Identifier, + N_Selected_Component) + then + -- If this pragma Debug comes from source, its argument was + -- parsed as a name form (which is syntactically identical). + -- Change it to a procedure call statement now. + + Change_Name_To_Procedure_Call_Statement (Call); + + elsif Nkind (Call) = N_Procedure_Call_Statement then + + -- Already in the form of a procedure call statement: nothing + -- to do (could happen in case of an internally generated + -- pragma Debug). + + null; + + else + -- All other cases: diagnose error + + Error_Msg + ("argument of pragma% is not procedure call", Sloc (Call)); + return; end if; -- Rewrite into a conditional with an appropriate condition. We @@ -7361,8 +7842,7 @@ package body Sem_Prag is Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Relocate_Node (Debug_Statement (N)))))))); + Statements => New_List (Relocate_Node (Call))))))); Analyze (N); end Debug; @@ -7375,9 +7855,11 @@ package body Sem_Prag is when Pragma_Debug_Policy => GNAT_Pragma; Check_Arg_Count (1); - Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Ignore); + Check_Arg_Is_One_Of (Arg1, Name_Check, Name_Disable, Name_Ignore); Debug_Pragmas_Enabled := Chars (Get_Pragma_Arg (Arg1)) = Name_Check; + Debug_Pragmas_Disabled := + Chars (Get_Pragma_Arg (Arg1)) = Name_Disable; --------------------- -- Detect_Blocking -- @@ -7522,6 +8004,54 @@ package body Sem_Prag is end if; end Discard_Names; + ------------------------ + -- Dispatching_Domain -- + ------------------------ + + -- pragma Dispatching_Domain (EXPRESSION); + + when Pragma_Dispatching_Domain => Dispatching_Domain : declare + P : constant Node_Id := Parent (N); + Arg : Node_Id; + + begin + Ada_2012_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + + -- This pragma is born obsolete, but not the aspect + + if not From_Aspect_Specification (N) then + Check_Restriction + (No_Obsolescent_Features, Pragma_Identifier (N)); + end if; + + if Nkind (P) = N_Task_Definition then + Arg := Get_Pragma_Arg (Arg1); + + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain)); + + -- Anything else is incorrect + + else + Pragma_Misplaced; + end if; + + if Has_Pragma_Dispatching_Domain (P) then + Error_Pragma ("duplicate pragma% not allowed"); + else + Set_Has_Pragma_Dispatching_Domain (P, True); + + if Nkind (P) = N_Task_Definition then + Record_Rep_Item (Defining_Identifier (Parent (P)), N); + end if; + end if; + end Dispatching_Domain; + --------------- -- Elaborate -- --------------- @@ -8623,6 +9153,42 @@ package body Sem_Prag is end; end Ident; + ---------------------------- + -- Implementation_Defined -- + ---------------------------- + + -- pragma Implementation_Defined (local_NAME); + + -- Marks previously declared entity as implementation defined. For + -- an overloaded entity, applies to the most recent homonym. + + -- pragma Implementation_Defined; + + -- The form with no arguments appears anywhere within a scope, most + -- typically a package spec, and indicates that all entities that are + -- defined within the package spec are Implementation_Defined. + + when Pragma_Implementation_Defined => Implementation_Defined : declare + Ent : Entity_Id; + + begin + Check_No_Identifiers; + + -- Form with no arguments + + if Arg_Count = 0 then + Set_Is_Implementation_Defined (Current_Scope); + + -- Form with one argument + + else + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + Ent := Entity (Get_Pragma_Arg (Arg1)); + Set_Is_Implementation_Defined (Ent); + end if; + end Implementation_Defined; + ----------------- -- Implemented -- ----------------- @@ -9156,11 +9722,12 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; Check_Restriction (No_Initialize_Scalars, N); - -- Initialize_Scalars creates false positives in CodePeer, - -- so ignore this pragma in this mode. + -- Initialize_Scalars creates false positives in CodePeer, and + -- incorrect negative results in Alfa mode, so ignore this pragma + -- in these modes. if not Restriction_Active (No_Initialize_Scalars) - and then not CodePeer_Mode + and then not (CodePeer_Mode or Alfa_Mode) then Init_Or_Norm_Scalars := True; Initialize_Scalars := True; @@ -9187,10 +9754,10 @@ package body Sem_Prag is when Pragma_Inline_Always => GNAT_Pragma; - -- Pragma always active unless in CodePeer mode, since this causes - -- walk order issues. + -- Pragma always active unless in CodePeer or Alfa mode, since + -- this causes walk order issues. - if not CodePeer_Mode then + if not (CodePeer_Mode or Alfa_Mode) then Process_Inline (True); end if; @@ -9590,10 +10157,26 @@ package body Sem_Prag is if Typ = Any_Type then return; - elsif not Ekind_In (Typ, E_Private_Type, - E_Record_Type_With_Private, - E_Limited_Private_Type) + -- An invariant must apply to a private type, or appear in the + -- private part of a package spec and apply to a completion. + + elsif Ekind_In (Typ, E_Private_Type, + E_Record_Type_With_Private, + E_Limited_Private_Type) then + null; + + elsif In_Private_Part (Current_Scope) + and then Has_Private_Declaration (Typ) + then + null; + + elsif In_Private_Part (Current_Scope) then + Error_Pragma_Arg + ("pragma% only allowed for private type " & + "declared in visible part", Arg1); + + else Error_Pragma_Arg ("pragma% only allowed for private type", Arg1); end if; @@ -10251,16 +10834,23 @@ package body Sem_Prag is -- pragma Locking_Policy (policy_IDENTIFIER); when Pragma_Locking_Policy => declare - LP : Character; - + subtype LP_Range is Name_Id + range First_Locking_Policy_Name .. Last_Locking_Policy_Name; + LP_Val : LP_Range; + LP : Character; begin Check_Ada_83_Warning; Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Locking_Policy (Arg1); Check_Valid_Configuration_Pragma; - Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); - LP := Fold_Upper (Name_Buffer (1)); + LP_Val := Chars (Get_Pragma_Arg (Arg1)); + + case LP_Val is + when Name_Ceiling_Locking => LP := 'C'; + when Name_Inheritance_Locking => LP := 'I'; + when Name_Concurrent_Readers_Locking => LP := 'R'; + end case; if Locking_Policy /= ' ' and then Locking_Policy /= LP @@ -10629,10 +11219,11 @@ package body Sem_Prag is Check_Arg_Count (0); Check_Valid_Configuration_Pragma; - -- Normalize_Scalars creates false positives in CodePeer, so - -- ignore this pragma in this mode. + -- Normalize_Scalars creates false positives in CodePeer, and + -- incorrect negative results in Alfa mode, so ignore this pragma + -- in these modes. - if not CodePeer_Mode then + if not (CodePeer_Mode or Alfa_Mode) then Normalize_Scalars := True; Init_Or_Norm_Scalars := True; end if; @@ -10999,9 +11590,9 @@ package body Sem_Prag is -- In the context of static code analysis, we do not need -- complex front-end expansions related to pragma Pack, - -- so disable handling of pragma Pack in this case. + -- so disable handling of pragma Pack in these cases. - if CodePeer_Mode then + if CodePeer_Mode or Alfa_Mode then null; -- Don't attempt any packing for VM targets. We possibly @@ -11222,8 +11813,8 @@ package body Sem_Prag is -- Postcondition -- ------------------- - -- pragma Postcondition ([Check =>] Boolean_Expression - -- [,[Message =>] String_Expression]); + -- pragma Postcondition ([Check =>] Boolean_EXPRESSION + -- [,[Message =>] String_EXPRESSION]); when Pragma_Postcondition => Postcondition : declare In_Body : Boolean; @@ -11245,8 +11836,8 @@ package body Sem_Prag is -- Precondition -- ------------------ - -- pragma Precondition ([Check =>] Boolean_Expression - -- [,[Message =>] String_Expression]); + -- pragma Precondition ([Check =>] Boolean_EXPRESSION + -- [,[Message =>] String_EXPRESSION]); when Pragma_Precondition => Precondition : declare In_Body : Boolean; @@ -11650,12 +12241,21 @@ package body Sem_Prag is declare Argx : constant Node_Id := Get_Pragma_Arg (Arg1); + begin if Chars (Argx) = Name_Ravenscar then Set_Ravenscar_Profile (N); + elsif Chars (Argx) = Name_Restricted then Set_Profile_Restrictions - (Restricted, N, Warn => Treat_Restrictions_As_Warnings); + (Restricted, + N, Warn => Treat_Restrictions_As_Warnings); + + elsif Chars (Argx) = Name_No_Implementation_Extensions then + Set_Profile_Restrictions + (No_Implementation_Extensions, + N, Warn => Treat_Restrictions_As_Warnings); + else Error_Pragma_Arg ("& is not a valid profile", Argx); end if; @@ -11677,11 +12277,18 @@ package body Sem_Prag is declare Argx : constant Node_Id := Get_Pragma_Arg (Arg1); + begin if Chars (Argx) = Name_Ravenscar then Set_Profile_Restrictions (Ravenscar, N, Warn => True); + elsif Chars (Argx) = Name_Restricted then Set_Profile_Restrictions (Restricted, N, Warn => True); + + elsif Chars (Argx) = Name_No_Implementation_Extensions then + Set_Profile_Restrictions + (No_Implementation_Extensions, N, Warn => True); + else Error_Pragma_Arg ("& is not a valid profile", Argx); end if; @@ -12834,9 +13441,9 @@ package body Sem_Prag is end if; end; - -------------- + --------------- -- Task_Info -- - -------------- + --------------- -- pragma Task_Info (EXPRESSION); @@ -12953,6 +13560,41 @@ package body Sem_Prag is end if; end Task_Storage; + --------------- + -- Test_Case -- + --------------- + + -- pragma Test_Case ([Name =>] Static_String_EXPRESSION + -- ,[Mode =>] MODE_TYPE + -- [, Requires => Boolean_EXPRESSION] + -- [, Ensures => Boolean_EXPRESSION]); + + -- MODE_TYPE ::= Nominal | Robustness + + when Pragma_Test_Case => Test_Case : declare + begin + 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_Optional_Identifier (Arg1, Name_Name); + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Check_Optional_Identifier (Arg2, Name_Mode); + Check_Arg_Is_One_Of (Arg2, Name_Nominal, Name_Robustness); + + if Arg_Count = 4 then + Check_Identifier (Arg3, Name_Requires); + Check_Identifier (Arg4, Name_Ensures); + + elsif Arg_Count = 3 then + Check_Identifier_Is_One_Of (Arg3, Name_Requires, Name_Ensures); + end if; + + Check_Test_Case; + end Test_Case; + -------------------------- -- Thread_Local_Storage -- -------------------------- @@ -13817,6 +14459,64 @@ package body Sem_Prag is when Pragma_Exit => null; end Analyze_Pragma; + ----------------------------- + -- Analyze_TC_In_Decl_Part -- + ----------------------------- + + procedure Analyze_TC_In_Decl_Part (N : Node_Id; S : Entity_Id) is + begin + -- Install formals and push subprogram spec onto scope stack so that we + -- can see the formals from the pragma. + + Install_Formals (S); + Push_Scope (S); + + -- Preanalyze the boolean expressions, we treat these as spec + -- expressions (i.e. similar to a default expression). + + Preanalyze_TC_Args (Get_Requires_From_Test_Case_Pragma (N), + Get_Ensures_From_Test_Case_Pragma (N)); + + -- Remove the subprogram from the scope stack now that the pre-analysis + -- of the expressions in the test-case is done. + + End_Scope; + end Analyze_TC_In_Decl_Part; + + -------------------- + -- Check_Disabled -- + -------------------- + + function Check_Disabled (Nam : Name_Id) return Boolean is + PP : Node_Id; + + begin + -- Loop through entries in check policy list + + PP := Opt.Check_Policy_List; + loop + -- If there are no specific entries that matched, then nothing is + -- disabled, so return False. + + if No (PP) then + return False; + + -- Here we have an entry see if it matches + + else + declare + PPA : constant List_Id := Pragma_Argument_Associations (PP); + begin + if Nam = Chars (Get_Pragma_Arg (First (PPA))) then + return Chars (Get_Pragma_Arg (Last (PPA))) = Name_Disable; + else + PP := Next_Pragma (PP); + end if; + end; + end if; + end loop; + end Check_Disabled; + ------------------- -- Check_Enabled -- ------------------- @@ -14023,6 +14723,7 @@ package body Sem_Prag is Pragma_Default_Storage_Pool => -1, Pragma_Dimension => -1, Pragma_Discard_Names => 0, + Pragma_Dispatching_Domain => -1, Pragma_Elaborate => -1, Pragma_Elaborate_All => -1, Pragma_Elaborate_Body => -1, @@ -14044,6 +14745,7 @@ package body Sem_Prag is Pragma_Finalize_Storage_Only => 0, Pragma_Float_Representation => 0, Pragma_Ident => -1, + Pragma_Implementation_Defined => -1, Pragma_Implemented => -1, Pragma_Implicit_Packing => 0, Pragma_Import => +2, @@ -14144,6 +14846,7 @@ package body Sem_Prag is Pragma_Task_Info => -1, Pragma_Task_Name => -1, Pragma_Task_Storage => 0, + Pragma_Test_Case => -1, Pragma_Thread_Local_Storage => 0, Pragma_Time_Slice => -1, Pragma_Title => -1, @@ -14285,6 +14988,26 @@ package body Sem_Prag is end if; end Is_Pragma_String_Literal; + ------------------------ + -- Preanalyze_TC_Args -- + ------------------------ + + procedure Preanalyze_TC_Args (Arg_Req, Arg_Ens : Node_Id) is + begin + -- Preanalyze the boolean expressions, we treat these as spec + -- expressions (i.e. similar to a default expression). + + if Present (Arg_Req) then + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg_Req), Standard_Boolean); + end if; + + if Present (Arg_Ens) then + Preanalyze_Spec_Expression + (Get_Pragma_Arg (Arg_Ens), Standard_Boolean); + end if; + end Preanalyze_TC_Args; + -------------------------------------- -- Process_Compilation_Unit_Pragmas -- --------------------------------------