X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Fada%2Fsem_prag.adb;h=8c89ea02c9609c841e13adfd8863bb5ca9a4ef05;hp=6d12b8fe4e752fe915b7ab167283c69d598975e1;hb=7717ea00902734bd90371e34af23d0b73287f875;hpb=6d94f7f95e910dce941a0f4bed322c16d3718b44 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 6d12b8fe4e7..8c89ea02c96 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -35,7 +35,9 @@ with Checks; use Checks; with Csets; use Csets; 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 Lib; use Lib; with Lib.Writ; use Lib.Writ; @@ -45,6 +47,7 @@ with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; with Output; use Output; +with Par_SCO; use Par_SCO; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; @@ -307,7 +310,12 @@ package body Sem_Prag is 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 + -- caught by the No_Implementation_Pragmas restriction. + + 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. procedure Check_Ada_83_Warning; -- Issues a warning message for the current pragma if operating in Ada @@ -368,15 +376,12 @@ package body Sem_Prag is procedure Check_Arg_Is_Static_Expression (Arg : Node_Id; - Typ : Entity_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. - - procedure Check_Arg_Is_String_Literal (Arg : Node_Id); - -- Check the specified argument Arg to make sure that it is a string - -- literal. If not give error and raise Pragma_Exit + -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If + -- Typ is left Empty, then any static expression is allowed. procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); -- Check the specified argument Arg to make sure that it is a valid task @@ -393,9 +398,14 @@ package body Sem_Prag is procedure Check_At_Most_N_Arguments (N : Nat); -- Check there are no more than N arguments present - procedure Check_Component (Comp : Node_Id); - -- Examine Unchecked_Union component for correct use of per-object + 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_Duplicated_Export_Name (Nam : Node_Id); -- Nam is an N_String_Literal node containing the external name set by @@ -484,9 +494,10 @@ package body Sem_Prag is -- and to library level instantiations), and they are simply ignored, -- which is implemented by rewriting them as null statements. - procedure Check_Variant (Variant : Node_Id); - -- Check Unchecked_Union variant for lack of nested variants and - -- presence of at least one component. + 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. procedure Error_Pragma (Msg : String); pragma No_Return (Error_Pragma); @@ -594,11 +605,13 @@ package body Sem_Prag is procedure Process_Compile_Time_Warning_Or_Error; -- Common processing for Compile_Time_Error and Compile_Time_Warning - procedure Process_Convention (C : out Convention_Id; E : out Entity_Id); + 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, E is the referenced entity. + -- C is the convention, Ent is the referenced entity. procedure Process_Extended_Import_Export_Exception_Pragma (Arg_Internal : Node_Id; @@ -725,6 +738,17 @@ package body Sem_Prag is end if; end Ada_2005_Pragma; + --------------------- + -- Ada_2012_Pragma -- + --------------------- + + procedure Ada_2012_Pragma is + begin + if Ada_Version <= Ada_05 then + Check_Restriction (No_Implementation_Pragmas, N); + end if; + end Ada_2012_Pragma; + -------------------------- -- Check_Ada_83_Warning -- -------------------------- @@ -966,12 +990,16 @@ package body Sem_Prag is procedure Check_Arg_Is_Static_Expression (Arg : Node_Id; - Typ : Entity_Id) + Typ : Entity_Id := Empty) is Argx : constant Node_Id := Get_Pragma_Arg (Arg); begin - Analyze_And_Resolve (Argx, Typ); + if Present (Typ) then + Analyze_And_Resolve (Argx, Typ); + else + Analyze_And_Resolve (Argx); + end if; if Is_OK_Static_Expression (Argx) then return; @@ -1006,19 +1034,6 @@ package body Sem_Prag is end if; end Check_Arg_Is_Static_Expression; - --------------------------------- - -- Check_Arg_Is_String_Literal -- - --------------------------------- - - procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is - Argx : constant Node_Id := Get_Pragma_Arg (Arg); - begin - if Nkind (Argx) /= N_String_Literal then - Error_Pragma_Arg - ("argument for pragma% must be string literal", Argx); - end if; - end Check_Arg_Is_String_Literal; - ------------------------------------------ -- Check_Arg_Is_Task_Dispatching_Policy -- ------------------------------------------ @@ -1102,39 +1117,80 @@ package body Sem_Prag is -- Check_Component -- --------------------- - procedure Check_Component (Comp : Node_Id) is - begin - if Nkind (Comp) = N_Component_Declaration then - declare - Sindic : constant Node_Id := - Subtype_Indication (Component_Definition (Comp)); - Typ : constant Entity_Id := - Etype (Defining_Identifier (Comp)); - begin - if Nkind (Sindic) = N_Subtype_Indication then + 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); - -- Ada 2005 (AI-216): If a component subtype is subject to - -- a per-object constraint, then the component type shall - -- be an Unchecked_Union. + function Inside_Generic_Body (Id : Entity_Id) return Boolean; + -- Determine whether entity Id appears inside a generic body - if Has_Per_Object_Constraint (Defining_Identifier (Comp)) - 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); - end if; - end if; + ------------------------- + -- Inside_Generic_Body -- + ------------------------- - if Is_Controlled (Typ) then - Error_Msg_N - ("component of unchecked union cannot be controlled", Comp); + function Inside_Generic_Body (Id : Entity_Id) return Boolean is + S : Entity_Id := Id; - elsif Has_Task (Typ) then - Error_Msg_N - ("component of unchecked union cannot have tasks", Comp); + begin + while Present (S) + and then S /= Standard_Standard + loop + if Ekind (S) = E_Generic_Package + and then In_Package_Body (S) + then + return True; end if; - end; + + S := Scope (S); + end loop; + + return False; + end Inside_Generic_Body; + + -- Start of processing for Check_Component + + 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. + + 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); + + -- 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 Inside_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); + + elsif Needs_Finalization (Typ) then + Error_Msg_N + ("component of Unchecked_Union cannot be controlled", Comp); + + elsif Has_Task (Typ) then + Error_Msg_N + ("component of Unchecked_Union cannot have tasks", Comp); end if; end Check_Component; @@ -1402,9 +1458,12 @@ package body Sem_Prag is Pragma_Misplaced; end if; - -- Record whether pragma is enabled + -- Record if pragma is enabled - Set_PPC_Enabled (N, Check_Enabled (Pname)); + if Check_Enabled (Pname) then + Set_Pragma_Enabled (N); + Set_SCO_Pragma_Enabled (Loc); + end if; -- If we are within an inlined body, the legality of the pragma -- has been checked already. @@ -1703,7 +1762,7 @@ package body Sem_Prag is -- Check_Variant -- ------------------- - procedure Check_Variant (Variant : Node_Id) is + procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is Clist : constant Node_Id := Component_List (Variant); Comp : Node_Id; @@ -1717,7 +1776,7 @@ package body Sem_Prag is Comp := First (Component_Items (Clist)); while Present (Comp) loop - Check_Component (Comp); + Check_Component (Comp, UU_Typ, In_Variant_Part => True); Next (Comp); end loop; end Check_Variant; @@ -1851,7 +1910,8 @@ package body Sem_Prag is Proc := Entity (Name); if Ekind (Proc) /= E_Procedure - or else Present (First_Formal (Proc)) then + or else Present (First_Formal (Proc)) + then Error_Pragma_Arg ("argument of pragma% must be parameterless procedure", Arg); end if; @@ -2341,20 +2401,185 @@ package body Sem_Prag is ------------------------ procedure Process_Convention - (C : out Convention_Id; - E : out Entity_Id) + (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; + 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. + 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. + ------------------------------- + -- Diagnose_Multiple_Pragmas -- + ------------------------------- + + procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is + Pdec : constant Node_Id := Declaration_Node (S); + Decl : Node_Id; + Err : Boolean; + + 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. + + 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. + + --------------------- + -- Same_Convention -- + --------------------- + + function Same_Convention (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + + 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; + + return False; + end Same_Convention; + + --------------- + -- Same_Name -- + --------------- + + function Same_Name (Decl : Node_Id) return Boolean is + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (Decl)); + Arg2 : Node_Id; + + begin + if No (Arg1) then + return False; + end if; + + Arg2 := Next (Arg1); + + if No (Arg2) then + return False; + end if; + + 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; + + return False; + end Same_Name; + + -- Start of processing for Diagnose_Multiple_Pragmas + + begin + Err := True; + + -- Definitely give message if we have Convention/Export here + + if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then + null; + + -- 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 + Decl := Prev (N); + while Present (Decl) and then Decl /= Pdec loop + + -- Look for pragma with same name as us + + if Nkind (Decl) = N_Pragma + and then Same_Name (Decl) + then + -- Give error if same as our pragma or Export/Convention + + if Pragma_Name (Decl) = Name_Export + or else + Pragma_Name (Decl) = Name_Convention + or else + Pragma_Name (Decl) = Pragma_Name (N) + then + exit; + + -- Case of Import/Interface or the other way round + + elsif Pragma_Name (Decl) = Name_Interface + or else + Pragma_Name (Decl) = 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 + + if Same_Convention (Decl) then + Set_Import_Interface_Present (N); + Set_Import_Interface_Present (Decl); + Err := False; + + -- If different conventions, special message + + else + Error_Msg_Sloc := Sloc (Decl); + Error_Pragma_Arg + ("convention differs from that given#", Arg1); + return; + end if; + end if; + end if; + + Next (Decl); + end loop; + end if; + + -- Give message if needed if we fall through those tests + + if Err then + Error_Pragma_Arg + ("at most one Convention/Export/Import pragma is allowed", + Arg2); + end if; + end Diagnose_Multiple_Pragmas; + -------------------------------- -- Set_Convention_From_Pragma -- -------------------------------- @@ -2476,6 +2701,10 @@ package body Sem_Prag is E := Entity (Id); + -- Set entity to return + + Ent := E; + -- 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. @@ -2498,6 +2727,10 @@ package body Sem_Prag is 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; @@ -2512,10 +2745,7 @@ package body Sem_Prag is -- Check that we are not applying this to a named constant - if Ekind (E) = E_Named_Integer - or else - Ekind (E) = E_Named_Real - then + 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!", @@ -2543,8 +2773,7 @@ package body Sem_Prag is end if; if Has_Convention_Pragma (E) then - Error_Pragma_Arg - ("at most one Convention/Export/Import pragma is allowed", Arg2); + Diagnose_Multiple_Pragmas (E); elsif Convention (E) = Convention_Protected or else Ekind (Scope (E)) = E_Protected_Type @@ -2572,7 +2801,7 @@ package body Sem_Prag is and then Ekind (E) /= E_Variable and then not (Is_Access_Type (E) - and then Ekind (Designated_Type (E)) = E_Subprogram_Type) + and then Ekind (Designated_Type (E)) = E_Subprogram_Type) then Error_Pragma_Arg ("second argument of pragma% must be subprogram (type)", @@ -2585,7 +2814,6 @@ package body Sem_Prag is Set_Convention_From_Pragma (E); if Is_Type (E) then - Check_First_Subtype (Arg2); Set_Convention_From_Pragma (Base_Type (E)); @@ -2611,7 +2839,9 @@ package body Sem_Prag is Generate_Reference (E, Id, 'b'); end if; - E1 := E; + -- Loop through the homonyms of the pragma argument's entity + + E1 := Ent; loop E1 := Homonym (E1); exit when No (E1) or else Scope (E1) /= Current_Scope; @@ -2636,7 +2866,7 @@ package body Sem_Prag is Set_Convention_From_Pragma (E1); if Prag_Id = Pragma_Import then - Generate_Reference (E, Id, 'b'); + Generate_Reference (E1, Id, 'b'); end if; end if; end loop; @@ -2751,9 +2981,7 @@ package body Sem_Prag is Process_Extended_Import_Export_Internal_Arg (Arg_Internal); Def_Id := Entity (Arg_Internal); - if Ekind (Def_Id) /= E_Constant - and then Ekind (Def_Id) /= E_Variable - then + if not Ekind_In (Def_Id, E_Constant, E_Variable) then Error_Pragma_Arg ("pragma% must designate an object", Arg_Internal); end if; @@ -2797,8 +3025,7 @@ package body Sem_Prag is end if; if Warn_On_Export_Import and then Is_Exported (Def_Id) then - Error_Msg_N - ("?duplicate Export_Object pragma", N); + Error_Msg_N ("?duplicate Export_Object pragma", N); else Set_Exported (Def_Id, Arg_Internal); end if; @@ -2838,8 +3065,8 @@ package body Sem_Prag is ("?duplicate Import_Object pragma", N); -- Check for explicit initialization present. Note that an - -- initialization that generated by the code generator, e.g. - -- for an access type, does not count here. + -- initialization generated by the code generator, e.g. for an + -- access type, does not count here. elsif Present (Expression (Parent (Def_Id))) and then @@ -3136,12 +3363,10 @@ package body Sem_Prag is Formal := First_Formal (Ent); if No (Formal) then - Error_Pragma - ("at least one parameter required for pragma%"); + Error_Pragma ("at least one parameter required for pragma%"); elsif Ekind (Formal) /= E_Out_Parameter then - Error_Pragma - ("first parameter must have mode out for pragma%"); + Error_Pragma ("first parameter must have mode out for pragma%"); else Set_Is_Valued_Procedure (Ent); @@ -3366,10 +3591,8 @@ package body Sem_Prag is Kill_Size_Check_Code (Def_Id); Note_Possible_Modification (Expression (Arg2), Sure => False); - if Ekind (Def_Id) = E_Variable - or else - Ekind (Def_Id) = E_Constant - then + 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 @@ -3456,6 +3679,17 @@ package body Sem_Prag is else Set_Imported (Def_Id); + -- Reject an Import applied to an abstract subprogram + + 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; + -- Special processing for Convention_Intrinsic if C = Convention_Intrinsic then @@ -3551,73 +3785,67 @@ package body Sem_Prag is elsif Is_Record_Type (Def_Id) and then C = Convention_CPP then - if not Is_Tagged_Type (Def_Id) then - Error_Msg_Sloc := Sloc (Def_Id); - Error_Pragma_Arg ("imported 'C'P'P type must be tagged", Arg2); - - else - -- Types treated as CPP classes are treated as limited, but we - -- don't require them to be declared this way. A warning is - -- issued to encourage the user to declare them as limited. - -- This is not an error, for compatibility reasons, because - -- these types have been supported this way for some time. + -- Types treated as CPP classes are treated as limited, but we + -- don't require them to be declared this way. A warning is + -- issued to encourage the user to declare them as limited. + -- This is not an error, for compatibility reasons, because + -- these types have been supported this way for some time. - if not Is_Limited_Type (Def_Id) then - Error_Msg_N - ("imported 'C'P'P type should be " & - "explicitly declared limited?", - Get_Pragma_Arg (Arg2)); - Error_Msg_N - ("\type will be considered limited", - Get_Pragma_Arg (Arg2)); - end if; + if not Is_Limited_Type (Def_Id) then + Error_Msg_N + ("imported 'C'P'P type should be " & + "explicitly declared limited?", + Get_Pragma_Arg (Arg2)); + Error_Msg_N + ("\type will be considered limited", + Get_Pragma_Arg (Arg2)); + end if; - Set_Is_CPP_Class (Def_Id); - Set_Is_Limited_Record (Def_Id); + Set_Is_CPP_Class (Def_Id); + Set_Is_Limited_Record (Def_Id); - -- Imported CPP types must not have discriminants (because C++ - -- classes do not have discriminants). + -- Imported CPP types must not have discriminants (because C++ + -- classes do not have discriminants). - 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 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; - -- Components of imported CPP types must not have default - -- expressions because the constructor (if any) is in the - -- C++ side. + -- Components of imported CPP types must not have default + -- expressions because the constructor (if any) is on the + -- C++ side. - declare - Tdef : constant Node_Id := - Type_Definition (Declaration_Node (Def_Id)); - Clist : Node_Id; - Comp : Node_Id; + declare + Tdef : constant Node_Id := + Type_Definition (Declaration_Node (Def_Id)); + Clist : Node_Id; + Comp : Node_Id; - begin - if Nkind (Tdef) = N_Record_Definition then - Clist := Component_List (Tdef); + begin + if Nkind (Tdef) = N_Record_Definition then + Clist := Component_List (Tdef); - else - pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); - Clist := Component_List (Record_Extension_Part (Tdef)); - end if; + else + pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition); + Clist := Component_List (Record_Extension_Part (Tdef)); + end if; - if Present (Clist) then - Comp := First (Component_Items (Clist)); - while Present (Comp) loop - if Present (Expression (Comp)) then - Error_Msg_N - ("component of imported 'C'P'P type cannot have" & - " default expression", Expression (Comp)); - end if; + if Present (Clist) then + Comp := First (Component_Items (Clist)); + while Present (Comp) loop + if Present (Expression (Comp)) then + Error_Msg_N + ("component of imported 'C'P'P type cannot have" & + " default expression", Expression (Comp)); + end if; - Next (Comp); - end loop; - end if; - end; - end if; + Next (Comp); + end loop; + end if; + end; else Error_Pragma_Arg @@ -3792,9 +4020,7 @@ package body Sem_Prag is -- entity (if declared in the same unit) is inlined. if Is_Subprogram (Subp) then - while Present (Alias (Inner_Subp)) loop - Inner_Subp := Alias (Inner_Subp); - end loop; + Inner_Subp := Ultimate_Alias (Inner_Subp); if In_Same_Source_Unit (Subp, Inner_Subp) then Set_Inline_Flags (Inner_Subp); @@ -4111,7 +4337,14 @@ package body Sem_Prag is Set_Encoded_Interface_Name (Get_Base_Subprogram (Subprogram_Def), Link_Nam); - Check_Duplicated_Export_Name (Link_Nam); + + -- We allow duplicated export names in CIL, 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 + Check_Duplicated_Export_Name (Link_Nam); + end if; end Process_Interface_Name; ----------------------------------------- @@ -4261,6 +4494,19 @@ package body Sem_Prag is Restriction_Warnings (R_Id) := False; end if; + -- Check for obsolescent restrictions in Ada 2005 mode + + 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; + -- 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 @@ -4452,6 +4698,12 @@ package body Sem_Prag is -- a specified entity (given as the second argument of the pragma) else + -- This is obsolescent in Ada 2005 mode + + if Ada_Version >= Ada_2005 then + Check_Restriction (No_Obsolescent_Features, Arg2); + end if; + Check_Optional_Identifier (Arg2, Name_On); E_Id := Expression (Arg2); Analyze (E_Id); @@ -4565,8 +4817,7 @@ package body Sem_Prag is end if; if Warn_On_Export_Import and then Is_Type (E) then - Error_Msg_NE - ("exporting a type has no effect?", Arg, E); + Error_Msg_NE ("exporting a type has no effect?", Arg, E); end if; if Warn_On_Export_Import and Inside_A_Generic then @@ -4666,8 +4917,19 @@ package body Sem_Prag is -- Error message if already imported or exported if Is_Exported (E) or else Is_Imported (E) then + + -- Error if being set Exported twice + if Is_Exported (E) then Error_Msg_NE ("entity& was previously exported", N, E); + + -- OK if Import/Interface case + + elsif Import_Interface_Present (N) then + goto OK; + + -- Error if being set Imported twice + else Error_Msg_NE ("entity& was previously imported", N, E); end if; @@ -4696,6 +4958,8 @@ package body Sem_Prag is Set_Is_Statically_Allocated (E); end if; end if; + + <> null; end Set_Imported; ------------------------- @@ -4707,8 +4971,8 @@ package body Sem_Prag is -- form created by the parser. procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is - Class : Node_Id; - Param : Node_Id; + Class : Node_Id; + Param : Node_Id; Mech_Name_Id : Name_Id; procedure Bad_Class; @@ -4757,7 +5021,15 @@ package body Sem_Prag is elsif Chars (Mech_Name) = Name_Descriptor then Check_VMS (Mech_Name); - Set_Mechanism (Ent, By_Descriptor); + + -- Descriptor => Short_Descriptor if pragma was given + + if Short_Descriptors then + Set_Mechanism (Ent, By_Short_Descriptor); + else + Set_Mechanism (Ent, By_Descriptor); + end if; + return; elsif Chars (Mech_Name) = Name_Short_Descriptor then @@ -4780,7 +5052,6 @@ package body Sem_Prag is -- 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 @@ -4791,6 +5062,14 @@ package body Sem_Prag is Bad_Mechanism; else Mech_Name_Id := Chars (Prefix (Mech_Name)); + + -- 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; -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | @@ -4800,7 +5079,6 @@ package body Sem_Prag is -- Note: this form is parsed as a function call elsif Nkind (Mech_Name) = N_Function_Call then - Param := First (Parameter_Associations (Mech_Name)); if Nkind (Name (Mech_Name)) /= N_Identifier @@ -4828,72 +5106,72 @@ package body Sem_Prag is Bad_Class; elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBS + and then Chars (Class) = Name_UBS then Set_Mechanism (Ent, By_Descriptor_UBS); elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBSB + and then Chars (Class) = Name_UBSB then Set_Mechanism (Ent, By_Descriptor_UBSB); elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBA + and then Chars (Class) = Name_UBA then Set_Mechanism (Ent, By_Descriptor_UBA); elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_S + and then Chars (Class) = Name_S then Set_Mechanism (Ent, By_Descriptor_S); elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_SB + and then Chars (Class) = Name_SB then Set_Mechanism (Ent, By_Descriptor_SB); elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_A + and then Chars (Class) = Name_A then Set_Mechanism (Ent, By_Descriptor_A); elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_NCA + and then Chars (Class) = Name_NCA then Set_Mechanism (Ent, By_Descriptor_NCA); elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBS + and then Chars (Class) = Name_UBS then Set_Mechanism (Ent, By_Short_Descriptor_UBS); elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBSB + and then Chars (Class) = Name_UBSB then Set_Mechanism (Ent, By_Short_Descriptor_UBSB); elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBA + and then Chars (Class) = Name_UBA then Set_Mechanism (Ent, By_Short_Descriptor_UBA); elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_S + and then Chars (Class) = Name_S then Set_Mechanism (Ent, By_Short_Descriptor_S); elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_SB + and then Chars (Class) = Name_SB then Set_Mechanism (Ent, By_Short_Descriptor_SB); elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_A + and then Chars (Class) = Name_A then Set_Mechanism (Ent, By_Short_Descriptor_A); elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_NCA + and then Chars (Class) = Name_NCA then Set_Mechanism (Ent, By_Short_Descriptor_NCA); @@ -5076,8 +5354,9 @@ package body Sem_Prag is -- 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. + -- 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. if Ada_Version >= Ada_05 then Check_Valid_Configuration_Pragma; @@ -5129,7 +5408,7 @@ package body Sem_Prag is -- pragma Ada_2005; -- pragma Ada_2005 (LOCAL_NAME): - -- Note: these pragma also have some specific processing in Par.Prag + -- 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 @@ -5166,6 +5445,54 @@ package body Sem_Prag is end if; end; + --------------------- + -- Ada_12/Ada_2012 -- + --------------------- + + -- pragma Ada_12; + -- pragma Ada_12 (LOCAL_NAME); + + -- pragma Ada_2012; + -- pragma Ada_2012 (LOCAL_NAME): + + -- Note: these pragmas also have some specific processing in Par.Prag + -- because we want to set the Ada 2012 version mode during parsing. + + when Pragma_Ada_12 | Pragma_Ada_2012 => declare + E_Id : Node_Id; + + begin + GNAT_Pragma; + + if Arg_Count = 1 then + Check_Arg_Is_Local_Name (Arg1); + E_Id := Expression (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + Set_Is_Ada_2012_Only (Entity (E_Id)); + + else + Check_Arg_Count (0); + + -- 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. + + Check_Valid_Configuration_Pragma; + + -- Now set Ada 2012 mode + + Ada_Version := Ada_12; + Ada_Version_Explicit := Ada_12; + end if; + end; + ---------------------- -- All_Calls_Remote -- ---------------------- @@ -5206,39 +5533,62 @@ package body Sem_Prag is -- Annotate -- -------------- - -- pragma Annotate (IDENTIFIER {, ARG}); + -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]); -- ARG ::= NAME | EXPRESSION + -- The first two arguments are by convention intended to refer to an + -- external tool and a tool-specific function. These arguments are + -- not analyzed. + when Pragma_Annotate => Annotate : 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; begin - Arg := Arg2; - while Present (Arg) loop - Exp := Expression (Arg); - Analyze (Exp); + -- Second unanalyzed parameter is optional - if Is_Entity_Name (Exp) then - null; + if No (Arg2) then + null; + else + Arg := Next (Arg2); + while Present (Arg) loop + Exp := Expression (Arg); + Analyze (Exp); - elsif Nkind (Exp) = N_String_Literal then - Resolve (Exp, Standard_String); + if Is_Entity_Name (Exp) then + null; - elsif Is_Overloaded (Exp) then - Error_Pragma_Arg ("ambiguous argument for pragma%", Exp); + -- For string literals, we assume Standard_String as the + -- type, unless the string contains wide or wide_wide + -- characters. - else - Resolve (Exp); - 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; - Next (Arg); - end loop; + 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; end Annotate; @@ -5619,14 +5969,6 @@ package body Sem_Prag is if Prag_Id = Pragma_Atomic_Components then Set_Has_Atomic_Components (E); - - if Is_Packed (E) then - Set_Is_Packed (E, False); - - Error_Pragma_Arg - ("?Pack canceled, cannot pack atomic components", - Arg1); - end if; end if; else @@ -5738,8 +6080,18 @@ package body Sem_Prag is end if; Check_Arg_Is_Identifier (Arg1); + + -- 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; + -- If expansion is active and the check is not enabled then we -- rewrite the Check as: @@ -6270,8 +6622,10 @@ package body Sem_Prag is -- [, [Link_Name =>] static_string_EXPRESSION ]); when Pragma_CPP_Constructor => CPP_Constructor : declare - Id : Entity_Id; - Def_Id : Entity_Id; + Elmt : Elmt_Id; + Id : Entity_Id; + Def_Id : Entity_Id; + Tag_Typ : Entity_Id; begin GNAT_Pragma; @@ -6291,9 +6645,19 @@ package body Sem_Prag is Def_Id := Entity (Id); + -- Check if already defined as constructor + + if Is_Constructor (Def_Id) then + Error_Msg_N + ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1); + return; + end if; + if Ekind (Def_Id) = E_Function - and then Is_Class_Wide_Type (Etype (Def_Id)) - and then Is_CPP_Class (Etype (Etype (Def_Id))) + 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 Arg_Count >= 2 then Set_Imported (Def_Id); @@ -6304,6 +6668,36 @@ package body Sem_Prag is Set_Has_Completion (Def_Id); Set_Is_Constructor (Def_Id); + -- 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. + + if Is_Tagged_Type (Etype (Def_Id)) + and then not Is_Class_Wide_Type (Etype (Def_Id)) + then + pragma Assert (Is_Dispatching_Operation (Def_Id)); + Tag_Typ := Etype (Def_Id); + + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) and then Node (Elmt) /= Def_Id loop + Next_Elmt (Elmt); + end loop; + + Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt); + Set_Is_Dispatching_Operation (Def_Id, False); + end if; + + -- For backward compatibility, if the constructor returns a + -- class wide type, and we internally change the return type to + -- the corresponding root type. + + 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", @@ -6405,6 +6799,24 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; Detect_Blocking := True; + --------------- + -- Dimension -- + --------------- + + when Pragma_Dimension => + GNAT_Pragma; + Check_Arg_Count (4); + Check_No_Identifiers; + Check_Arg_Is_Local_Name (Arg1); + + if not Is_Type (Arg1) then + Error_Pragma ("first argument for pragma% must be subtype"); + end if; + + Check_Arg_Is_Static_Expression (Arg2, Standard_Integer); + Check_Arg_Is_Static_Expression (Arg3, Standard_Integer); + Check_Arg_Is_Static_Expression (Arg4, Standard_Integer); + ------------------- -- Discard_Names -- ------------------- @@ -7185,8 +7597,11 @@ package body Sem_Prag is if Chars (Expression (Arg1)) = Name_On then Extensions_Allowed := True; + Ada_Version := Ada_Version_Type'Last; + else Extensions_Allowed := False; + Ada_Version := Ada_Version_Explicit; end if; -------------- @@ -7472,6 +7887,7 @@ package body Sem_Prag is Check_Arg_Count (1); Check_No_Identifiers; Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Store_Note (N); -- For pragma Ident, preserve DEC compatibility by requiring the -- pragma to appear in a declarative part or package spec. @@ -7520,12 +7936,12 @@ package body Sem_Prag is else -- In VMS, the effect of IDENT is achieved by passing - -- IDENTIFICATION=name as a --for-linker switch. + -- --identification=name as a --for-linker switch. if OpenVMS_On_Target then Start_String; Store_String_Chars - ("--for-linker=IDENTIFICATION="); + ("--for-linker=--identification="); String_To_Name_Buffer (Strval (Str)); Store_String_Chars (Name_Buffer (1 .. Name_Len)); @@ -7535,7 +7951,7 @@ package body Sem_Prag is -- associated with a with'd package. Replace_Linker_Option_String - (End_String, "--for-linker=IDENTIFICATION="); + (End_String, "--for-linker=--identification="); end if; Set_Ident_String (Current_Sem_Unit, Str); @@ -7560,49 +7976,105 @@ package body Sem_Prag is end; end Ident; - -------------------------- - -- Implemented_By_Entry -- - -------------------------- + ----------------- + -- Implemented -- + ----------------- - -- pragma Implemented_By_Entry (DIRECT_NAME); + -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind); + -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any - when Pragma_Implemented_By_Entry => Implemented_By_Entry : declare - Ent : Entity_Id; + when Pragma_Implemented => Implemented : declare + Proc_Id : Entity_Id; + Typ : Entity_Id; begin - Ada_2005_Pragma; - Check_Arg_Count (1); + Ada_2012_Pragma; + Check_Arg_Count (2); Check_No_Identifiers; Check_Arg_Is_Identifier (Arg1); Check_Arg_Is_Local_Name (Arg1); - Ent := Entity (Expression (Arg1)); + Check_Arg_Is_One_Of + (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure); + + -- Extract the name of the local procedure - -- Pragma Implemented_By_Entry must be applied only to protected - -- synchronized or task interface primitives. + Proc_Id := Entity (Expression (Arg1)); - if (Ekind (Ent) /= E_Function - and then Ekind (Ent) /= E_Procedure) - or else not Present (First_Formal (Ent)) - or else not Is_Concurrent_Interface (Etype (First_Formal (Ent))) + -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a + -- primitive procedure of a synchronized tagged type. + + if Ekind (Proc_Id) = E_Procedure + and then Is_Primitive (Proc_Id) + and then Present (First_Formal (Proc_Id)) then - Error_Pragma_Arg - ("pragma % must be applied to a concurrent interface " & - "primitive", Arg1); + Typ := Etype (First_Formal (Proc_Id)); - else - if Einfo.Implemented_By_Entry (Ent) - and then Warn_On_Redundant_Constructs + if Is_Tagged_Type (Typ) + and then + + -- Check for a protected, a synchronized or a task interface + + ((Is_Interface (Typ) + and then Is_Synchronized_Interface (Typ)) + + -- Check for a protected type or a task type that implements + -- an interface. + + or else + (Is_Concurrent_Record_Type (Typ) + and then Present (Interfaces (Typ))) + + -- Check for a private record extension with keyword + -- "synchronized". + + or else + (Ekind_In (Typ, E_Record_Type_With_Private, + E_Record_Subtype_With_Private) + and then Synchronized_Present (Parent (Typ)))) then - Error_Pragma ("?duplicate pragma%!"); + null; else - Set_Implemented_By_Entry (Ent); + Error_Pragma_Arg + ("controlling formal must be of synchronized " & + "tagged type", Arg1); + return; end if; + + -- Procedures declared inside a protected type must be accepted + + elsif Ekind (Proc_Id) = E_Procedure + and then Is_Protected_Type (Scope (Proc_Id)) + then + null; + + -- The first argument is not a primitive procedure + + else + Error_Pragma_Arg + ("pragma % must be applied to a primitive procedure", Arg1); + return; end if; - end Implemented_By_Entry; - ----------------------- + -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind + -- By_Protected_Procedure to the primitive procedure of a task + -- interface. + + if Chars (Arg2) = Name_By_Protected_Procedure + and then Is_Interface (Typ) + and then Is_Task_Interface (Typ) + then + Error_Pragma_Arg + ("implementation kind By_Protected_Procedure cannot be " & + "applied to a task interface primitive", Arg2); + return; + end if; + + Record_Rep_Item (Proc_Id, N); + end Implemented; + + ---------------------- -- Implicit_Packing -- - ----------------------- + ---------------------- -- pragma Implicit_Packing; @@ -7906,6 +8378,113 @@ package body Sem_Prag is Arg_First_Optional_Parameter => First_Optional_Parameter); end Import_Valued_Procedure; + ----------------- + -- Independent -- + ----------------- + + -- pragma Independent (LOCAL_NAME); + + when Pragma_Independent => Independent : declare + E_Id : Node_Id; + E : Entity_Id; + D : Node_Id; + K : Node_Kind; + + begin + Check_Ada_83_Warning; + Ada_2012_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Expression (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + E := Entity (E_Id); + D := Declaration_Node (E); + K := Nkind (D); + + 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; + + 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; + + else + Error_Pragma_Arg + ("inappropriate entity for pragma%", Arg1); + end if; + + Independence_Checks.Append ((N, E)); + end Independent; + + ---------------------------- + -- Independent_Components -- + ---------------------------- + + -- pragma Atomic_Components (array_LOCAL_NAME); + + -- This processing is shared by Volatile_Components + + when Pragma_Independent_Components => Independent_Components : declare + E_Id : Node_Id; + E : Entity_Id; + D : Node_Id; + K : Node_Kind; + + begin + Check_Ada_83_Warning; + Ada_2012_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Expression (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + E := Entity (E_Id); + + if Rep_Item_Too_Early (E, N) + or else + Rep_Item_Too_Late (E, N) + then + return; + end if; + + D := Declaration_Node (E); + K := Nkind (D); + + if (K = N_Full_Type_Declaration + and then (Is_Array_Type (E) or else Is_Record_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 + Independence_Checks.Append ((N, E)); + + else + Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); + end if; + end Independent_Components; + ------------------------ -- Initialize_Scalars -- ------------------------ @@ -7918,7 +8497,12 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; Check_Restriction (No_Initialize_Scalars, N); - if not Restriction_Active (No_Initialize_Scalars) then + -- Initialize_Scalars creates false positives in CodePeer, + -- so ignore this pragma in this mode. + + if not Restriction_Active (No_Initialize_Scalars) + and then not CodePeer_Mode + then Init_Or_Norm_Scalars := True; Initialize_Scalars := True; end if; @@ -7943,7 +8527,13 @@ package body Sem_Prag is when Pragma_Inline_Always => GNAT_Pragma; - Process_Inline (True); + + -- Pragma always active unless in CodePeer mode, since this causes + -- walk order issues. + + if not CodePeer_Mode then + Process_Inline (True); + end if; -------------------- -- Inline_Generic -- @@ -8005,6 +8595,14 @@ package body Sem_Prag is Check_At_Most_N_Arguments (4); Process_Import_Or_Interface; + -- In Ada 2005, the permission to use Interface (a reserved word) + -- as a pragma name is considered an obsolescent feature. + + if Ada_Version >= Ada_2005 then + Check_Restriction + (No_Obsolescent_Features, Pragma_Identifier (N)); + end if; + -------------------- -- Interface_Name -- -------------------- @@ -8819,7 +9417,7 @@ package body Sem_Prag is -- pragma Machine_Attribute ( -- [Entity =>] LOCAL_NAME, -- [Attribute_Name =>] static_string_EXPRESSION - -- [, [Info =>] static_string_EXPRESSION] ); + -- [, [Info =>] static_EXPRESSION] ); when Pragma_Machine_Attribute => Machine_Attribute : declare Def_Id : Entity_Id; @@ -8830,7 +9428,7 @@ package body Sem_Prag is if Arg_Count = 3 then Check_Optional_Identifier (Arg3, Name_Info); - Check_Arg_Is_Static_Expression (Arg3, Standard_String); + Check_Arg_Is_Static_Expression (Arg3); else Check_Arg_Count (2); end if; @@ -9000,7 +9598,7 @@ package body Sem_Prag is Arg : Node_Id; begin - GNAT_Pragma; + Ada_2005_Pragma; Check_At_Least_N_Arguments (1); -- Loop through arguments of pragma @@ -9026,9 +9624,7 @@ package body Sem_Prag is while Present (E) and then Scope (E) = Current_Scope loop - if Ekind (E) = E_Procedure - or else Ekind (E) = E_Generic_Procedure - then + if Ekind_In (E, E_Procedure, E_Generic_Procedure) then Set_No_Return (E); -- Set flag on any alias as well @@ -9123,8 +9719,14 @@ package body Sem_Prag is Check_Ada_83_Warning; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; - Normalize_Scalars := True; - Init_Or_Norm_Scalars := True; + + -- Normalize_Scalars creates false positives in CodePeer, so + -- ignore this pragma in this mode. + + if not CodePeer_Mode then + Normalize_Scalars := True; + Init_Or_Norm_Scalars := True; + end if; ----------------- -- Obsolescent -- @@ -9365,7 +9967,7 @@ package body Sem_Prag is -- pragma Optimize_Alignment (Time | Space | Off); - when Pragma_Optimize_Alignment => + when Pragma_Optimize_Alignment => Optimize_Alignment : begin GNAT_Pragma; Check_No_Identifiers; Check_Arg_Count (1); @@ -9391,6 +9993,42 @@ package body Sem_Prag is -- switch will get reset anyway at the start of each unit. Optimize_Alignment_Local := True; + end Optimize_Alignment; + + ------------- + -- Ordered -- + ------------- + + -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME); + + when Pragma_Ordered => Ordered : declare + Assoc : constant Node_Id := Arg1; + Type_Id : Node_Id; + Typ : Entity_Id; + + begin + GNAT_Pragma; + Check_No_Identifiers; + Check_Arg_Count (1); + Check_Arg_Is_Local_Name (Arg1); + + Type_Id := Expression (Assoc); + Find_Type (Type_Id); + Typ := Entity (Type_Id); + + if Typ = Any_Type then + return; + else + Typ := Underlying_Type (Typ); + end if; + + if not Is_Enumeration_Type (Typ) then + Error_Pragma ("pragma% must specify enumeration type"); + end if; + + Check_First_Subtype (Arg1); + Set_Has_Pragma_Ordered (Base_Type (Typ)); + end Ordered; ---------- -- Pack -- @@ -9402,6 +10040,8 @@ package body Sem_Prag is Assoc : constant Node_Id := Arg1; Type_Id : Node_Id; Typ : Entity_Id; + Ctyp : Entity_Id; + Ignore : Boolean := False; begin Check_No_Identifiers; @@ -9432,49 +10072,47 @@ package body Sem_Prag is -- Array type elsif Is_Array_Type (Typ) then + Ctyp := Component_Type (Typ); - -- Pack not allowed for aliased or atomic components + -- Ignore pack that does nothing - if Has_Aliased_Components (Base_Type (Typ)) then - Error_Pragma - ("pragma% ignored, cannot pack aliased components?"); - - elsif Has_Atomic_Components (Typ) - or else Is_Atomic (Component_Type (Typ)) + if Known_Static_Esize (Ctyp) + and then Known_Static_RM_Size (Ctyp) + and then Esize (Ctyp) = RM_Size (Ctyp) + and then Addressable (Esize (Ctyp)) then - Error_Pragma - ("?pragma% ignored, cannot pack atomic components"); + Ignore := True; end if; - -- If we had an explicit component size given, then we do not - -- let Pack override this given size. We also give a warning - -- that Pack is being ignored unless we can tell for sure that - -- the Pack would not have had any effect anyway. + -- Process OK pragma Pack. Note that if there is a separate + -- component clause present, the Pack will be cancelled. This + -- processing is in Freeze. - if Has_Component_Size_Clause (Typ) then - if Known_Static_RM_Size (Component_Type (Typ)) - and then - RM_Size (Component_Type (Typ)) = Component_Size (Typ) - then + if not Rep_Item_Too_Late (Typ, N) then + + -- 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. + + if CodePeer_Mode then null; - else - Error_Pragma - ("?pragma% ignored, explicit component size given"); - end if; - -- If no prior array component size given, Pack is effective + -- For normal non-VM target, do the packing - else - if not Rep_Item_Too_Late (Typ, N) then - if VM_Target = No_VM then + elsif VM_Target = No_VM then + if not Ignore then Set_Is_Packed (Base_Type (Typ)); - Set_Has_Pragma_Pack (Base_Type (Typ)); Set_Has_Non_Standard_Rep (Base_Type (Typ)); - - elsif not GNAT_Mode then - Error_Pragma - ("?pragma% ignored in this configuration"); end if; + + Set_Has_Pragma_Pack (Base_Type (Typ)); + + -- If we ignore the pack for VM_Targets, then warn about + -- this, except suppress the warning in GNAT mode. + + elsif not GNAT_Mode then + Error_Pragma + ("?pragma% ignored in this configuration"); end if; end if; @@ -9695,7 +10333,8 @@ package body Sem_Prag is -- If in spec, nothing more to do. If in body, then we convert the -- pragma to pragma Check (Precondition, cond [, msg]). Note we do -- this whether or not precondition checks are enabled. That works - -- fine since pragma Check will do this check. + -- fine since pragma Check will do this check, and will also + -- analyze the condition itself in the proper context. if In_Body then if Arg_Count = 2 then @@ -9703,8 +10342,6 @@ package body Sem_Prag is Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String); end if; - Analyze_And_Resolve (Get_Pragma_Arg (Arg1), Standard_Boolean); - Rewrite (N, Make_Pragma (Loc, Chars => Name_Check, @@ -9792,7 +10429,7 @@ package body Sem_Prag is -- This is one of the few cases where we need to test the value of -- Ada_Version_Explicit rather than Ada_Version (which is always - -- set to Ada_05 in a predefined unit), we need to know the + -- set to Ada_12 in a predefined unit), we need to know the -- explicit version set to know if this pragma is active. if Ada_Version_Explicit >= Ada_05 then @@ -10168,9 +10805,7 @@ package body Sem_Prag is Def_Id := Entity (Internal); - if Ekind (Def_Id) /= E_Constant - and then Ekind (Def_Id) /= E_Variable - then + if not Ekind_In (Def_Id, E_Constant, E_Variable) then Error_Pragma_Arg ("pragma% must designate an object", Internal); end if; @@ -10294,7 +10929,7 @@ package body Sem_Prag is -- This is one of the few cases where we need to test the value of -- Ada_Version_Explicit rather than Ada_Version (which is always - -- set to Ada_05 in a predefined unit), we need to know the + -- set to Ada_12 in a predefined unit), we need to know the -- explicit version set to know if this pragma is active. if Ada_Version_Explicit >= Ada_05 then @@ -10336,9 +10971,9 @@ package body Sem_Prag is loop Def_Id := Get_Base_Subprogram (E); - if Ekind (Def_Id) /= E_Function - and then Ekind (Def_Id) /= E_Generic_Function - and then Ekind (Def_Id) /= E_Operator + if not Ekind_In (Def_Id, E_Function, + E_Generic_Function, + E_Operator) then Error_Pragma_Arg ("pragma% requires a function name", Arg1); @@ -10358,8 +10993,9 @@ package body Sem_Prag is if not Effective and then Warn_On_Redundant_Constructs then - Error_Msg_NE ("pragma Pure_Function on& is redundant?", - N, Entity (E_Id)); + Error_Msg_NE + ("pragma Pure_Function on& is redundant?", + N, Entity (E_Id)); end if; end if; end Pure_Function; @@ -10532,10 +11168,8 @@ package body Sem_Prag is Set_Ravenscar_Profile (N); if Warn_On_Obsolescent_Feature then - Error_Msg_N - ("pragma Ravenscar is an obsolescent feature?", N); - Error_Msg_N - ("|use pragma Profile (Ravenscar) instead", N); + Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N); + Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N); end if; ------------------------- @@ -10554,8 +11188,7 @@ package body Sem_Prag is if Warn_On_Obsolescent_Feature then Error_Msg_N ("pragma Restricted_Run_Time is an obsolescent feature?", N); - Error_Msg_N - ("|use pragma Profile (Restricted) instead", N); + Error_Msg_N ("|use pragma Profile (Restricted) instead", N); end if; ------------------ @@ -10595,8 +11228,24 @@ package body Sem_Prag is when Pragma_Reviewable => Check_Ada_83_Warning; Check_Arg_Count (0); + + -- Call dummy debugging function rv. This is done to assist front + -- end debugging. By placing a Reviewable pragma in the source + -- program, a breakpoint on rv catches this place in the source, + -- allowing convenient stepping to the point of interest. + rv; + -------------------------- + -- Short_Circuit_And_Or -- + -------------------------- + + when Pragma_Short_Circuit_And_Or => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Short_Circuit_And_Or := True; + ------------------- -- Share_Generic -- ------------------- @@ -10650,6 +11299,18 @@ package body Sem_Prag is Set_Is_Shared_Passive (Cunit_Ent); end Shared_Passive; + ----------------------- + -- Short_Descriptors -- + ----------------------- + + -- pragma Short_Descriptors; + + when Pragma_Short_Descriptors => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Short_Descriptors := True; + ---------------------- -- Source_File_Name -- ---------------------- @@ -11022,7 +11683,11 @@ package body Sem_Prag is elsif Nkind (A) = N_Identifier then if Chars (A) = Name_All_Checks then - Set_Default_Style_Check_Options; + if GNAT_Mode then + Set_GNAT_Style_Check_Options; + else + Set_Default_Style_Check_Options; + end if; elsif Chars (A) = Name_On then Style_Check := True; @@ -11044,7 +11709,8 @@ package body Sem_Prag is GNAT_Pragma; Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Subtitle); - Check_Arg_Is_String_Literal (Arg1); + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Store_Note (N); -------------- -- Suppress -- @@ -11247,9 +11913,11 @@ package body Sem_Prag is Arg := Expression (Arg1); -- The expression is used in the call to Create_Task, and must be - -- expanded there, not in the context of the current spec. + -- expanded there, not in the context of the current spec. It must + -- however be analyzed to capture global references, in case it + -- appears in a generic context. - Preanalyze_And_Resolve (New_Copy_Tree (Arg), Standard_String); + Preanalyze_And_Resolve (Arg, Standard_String); if Nkind (P) /= N_Task_Definition then Pragma_Misplaced; @@ -11420,10 +12088,11 @@ package body Sem_Prag is begin GNAT_Pragma; Gather_Associations (Names, Args); + Store_Note (N); for J in 1 .. 2 loop if Present (Args (J)) then - Check_Arg_Is_String_Literal (Args (J)); + Check_Arg_Is_Static_Expression (Args (J), Standard_String); end if; end loop; end Title; @@ -11508,7 +12177,7 @@ package body Sem_Prag is Comp := First (Component_Items (Clist)); while Present (Comp) loop - Check_Component (Comp); + Check_Component (Comp, Typ); Next (Comp); end loop; @@ -11523,7 +12192,7 @@ package body Sem_Prag is Variant := First (Variants (Vpart)); while Present (Variant) loop - Check_Variant (Variant); + Check_Variant (Variant, Typ); Next (Variant); end loop; end if; @@ -11914,6 +12583,14 @@ package body Sem_Prag is Check_At_Least_N_Arguments (1); Check_No_Identifiers; + -- If debug flag -gnatd.i is set, pragma is ignored + + if Debug_Flag_Dot_I then + return; + end if; + + -- Process various forms of the pragma + declare Argx : constant Node_Id := Get_Pragma_Arg (Arg1); @@ -11937,7 +12614,7 @@ package body Sem_Prag is elsif not Is_Static_String_Expression (Arg1) then Error_Pragma_Arg ("argument of pragma% must be On/Off or " & - "static string expression", Arg2); + "static string expression", Arg1); -- One argument string expression case @@ -12157,6 +12834,11 @@ package body Sem_Prag is raise Program_Error; end case; + -- AI05-0144: detect dangerous order dependence. Disabled for now, + -- until AI is formally approved. + + -- Check_Order_Dependence; + exception when Pragma_Exit => null; end Analyze_Pragma; @@ -12316,14 +12998,13 @@ package body Sem_Prag is ----------------------------------------- -- This function makes use of the following static table which indicates - -- whether a given pragma is significant. A value of -1 in this table - -- indicates that the reference is significant. A value of zero indicates - -- than appearance as any argument is insignificant, a positive value - -- indicates that appearance in that parameter position is significant. + -- whether a given pragma is significant. - -- A value of 99 flags a special case requiring a special check (this is - -- used for cases not covered by this standard encoding, e.g. pragma Check - -- where the first argument is not significant, but the others are). + -- -1 indicates that references in any argument position are significant + -- 0 indicates that appearence in any argument is not significant + -- +n indicates that appearence as argument n is significant, but all + -- other arguments are not significant + -- 99 special processing required (e.g. for pragma Check) Sig_Flags : constant array (Pragma_Id) of Int := (Pragma_AST_Entry => -1, @@ -12332,6 +13013,8 @@ package body Sem_Prag is Pragma_Ada_95 => -1, Pragma_Ada_05 => -1, Pragma_Ada_2005 => -1, + Pragma_Ada_12 => -1, + Pragma_Ada_2012 => -1, Pragma_All_Calls_Remote => -1, Pragma_Annotate => -1, Pragma_Assert => -1, @@ -12364,6 +13047,7 @@ package body Sem_Prag is Pragma_Debug => -1, Pragma_Debug_Policy => 0, Pragma_Detect_Blocking => -1, + Pragma_Dimension => -1, Pragma_Discard_Names => 0, Pragma_Elaborate => -1, Pragma_Elaborate_All => -1, @@ -12386,7 +13070,7 @@ package body Sem_Prag is Pragma_Finalize_Storage_Only => 0, Pragma_Float_Representation => 0, Pragma_Ident => -1, - Pragma_Implemented_By_Entry => -1, + Pragma_Implemented => -1, Pragma_Implicit_Packing => 0, Pragma_Import => +2, Pragma_Import_Exception => 0, @@ -12394,6 +13078,8 @@ package body Sem_Prag is Pragma_Import_Object => 0, Pragma_Import_Procedure => 0, Pragma_Import_Valued_Procedure => 0, + Pragma_Independent => 0, + Pragma_Independent_Components => 0, Pragma_Initialize_Scalars => -1, Pragma_Inline => 0, Pragma_Inline_Always => 0, @@ -12429,6 +13115,7 @@ package body Sem_Prag is Pragma_Obsolescent => 0, Pragma_Optimize => -1, Pragma_Optimize_Alignment => -1, + Pragma_Ordered => 0, Pragma_Pack => 0, Pragma_Page => -1, Pragma_Passive => -1, @@ -12457,9 +13144,11 @@ package body Sem_Prag is Pragma_Restriction_Warnings => -1, Pragma_Restrictions => -1, Pragma_Reviewable => -1, + Pragma_Short_Circuit_And_Or => -1, Pragma_Share_Generic => -1, Pragma_Shared => -1, Pragma_Shared_Passive => -1, + Pragma_Short_Descriptors => 0, Pragma_Source_File_Name => -1, Pragma_Source_File_Name_Project => -1, Pragma_Source_Reference => -1,