diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8971b75a27a..cbbc3b28942 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2016-04-27 Hristian Kirtchev + + * aspects.ads Aspects Export and Import do not require delay. They + were classified as delayed aspects, but treated as non-delayed + by the analysis of aspects. + * freeze.adb (Copy_Import_Pragma): New routine. + (Wrap_Imported_Subprogram): Copy the import pragma by first + resetting all semantic fields to avoid an infinite loop when + performing the copy. + * sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Add + comment on the processing of aspects Export and Import + at the freeze point. + (Analyze_Aspect_Convention: New routine. + (Analyze_Aspect_Export_Import): New routine. + (Analyze_Aspect_External_Link_Name): New routine. + (Analyze_Aspect_External_Or_Link_Name): Removed. + (Analyze_Aspect_Specifications): Factor out the analysis of + aspects Convention, Export, External_Name, Import, and Link_Name + in their respective routines. Aspects Export and Import should + not generate a Boolean pragma because their corresponding pragmas + have a very different syntax. + (Build_Export_Import_Pragma): New routine. + (Get_Interfacing_Aspects): New routine. + +2016-04-27 Eric Botcazou + + * inline.adb (Add_Inlined_Body): Overhaul implementation, + robustify handling of -gnatn1, add special treatment for + expression functions. + +2016-04-27 Doug Rupp + + * g-traceb.ads: Update comment. + * exp_ch2.adb: minor style fix in object declaration + 2016-04-27 Hristian Kirtchev * sem_elab.adb (Check_Internal_Call): Do not diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 5e042ada03e..fe13b304369 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2010-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2016, 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- -- @@ -652,12 +652,10 @@ package Aspects is Aspect_Dispatching_Domain => Always_Delay, Aspect_Dynamic_Predicate => Always_Delay, Aspect_Elaborate_Body => Always_Delay, - Aspect_Export => Always_Delay, Aspect_External_Name => Always_Delay, Aspect_External_Tag => Always_Delay, Aspect_Favor_Top_Level => Always_Delay, Aspect_Implicit_Dereference => Always_Delay, - Aspect_Import => Always_Delay, Aspect_Independent => Always_Delay, Aspect_Independent_Components => Always_Delay, Aspect_Inline => Always_Delay, @@ -726,9 +724,11 @@ package Aspects is Aspect_Disable_Controlled => Never_Delay, Aspect_Effective_Reads => Never_Delay, Aspect_Effective_Writes => Never_Delay, + Aspect_Export => Never_Delay, Aspect_Extensions_Visible => Never_Delay, Aspect_Ghost => Never_Delay, Aspect_Global => Never_Delay, + Aspect_Import => Never_Delay, Aspect_Initial_Condition => Never_Delay, Aspect_Initializes => Never_Delay, Aspect_No_Elaboration_Code_All => Never_Delay, diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index 88dc82440af..65b2212ac42 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -413,7 +413,7 @@ package body Exp_Ch2 is and then (Is_Atomic (E) or else Is_Atomic (Etype (E))) then declare - Set : Boolean; + Set : Boolean; begin -- If variable is atomic, but type is not, setting depends on diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index ba95f269c59..796d9ca5994 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4676,14 +4676,65 @@ package body Freeze is -- for the subprogram body that calls the inner procedure. procedure Wrap_Imported_Subprogram (E : Entity_Id) is + function Copy_Import_Pragma return Node_Id; + -- Obtain a copy of the Import_Pragma which belongs to subprogram E + + ------------------------ + -- Copy_Import_Pragma -- + ------------------------ + + function Copy_Import_Pragma return Node_Id is + + -- The subprogram should have an import pragma, otherwise it does + -- need a wrapper. + + Prag : constant Node_Id := Import_Pragma (E); + pragma Assert (Present (Prag)); + + -- Save all semantic fields of the pragma + + Save_Asp : constant Node_Id := Corresponding_Aspect (Prag); + Save_From : constant Boolean := From_Aspect_Specification (Prag); + Save_Prag : constant Node_Id := Next_Pragma (Prag); + Save_Rep : constant Node_Id := Next_Rep_Item (Prag); + + Result : Node_Id; + + begin + -- Reset all semantic fields. This avoids a potential infinite + -- loop when the pragma comes from an aspect as the duplication + -- will copy the aspect, then copy the corresponding pragma and + -- so on. + + Set_Corresponding_Aspect (Prag, Empty); + Set_From_Aspect_Specification (Prag, False); + Set_Next_Pragma (Prag, Empty); + Set_Next_Rep_Item (Prag, Empty); + + Result := Copy_Separate_Tree (Prag); + + -- Restore the original semantic fields + + Set_Corresponding_Aspect (Prag, Save_Asp); + Set_From_Aspect_Specification (Prag, Save_From); + Set_Next_Pragma (Prag, Save_Prag); + Set_Next_Rep_Item (Prag, Save_Rep); + + return Result; + end Copy_Import_Pragma; + + -- Local variables + Loc : constant Source_Ptr := Sloc (E); CE : constant Name_Id := Chars (E); - Spec : Node_Id; - Parms : List_Id; - Stmt : Node_Id; - Iprag : Node_Id; Bod : Node_Id; Forml : Entity_Id; + Parms : List_Id; + Prag : Node_Id; + Spec : Node_Id; + Stmt : Node_Id; + + -- Start of processing for Wrap_Imported_Subprogram begin -- Nothing to do if not imported @@ -4706,18 +4757,14 @@ package body Freeze is -- generates the right visibility, and that is exactly what the -- calls to Copy_Separate_Tree give us. - -- Acquire copy of Inline pragma, and indicate that it does not - -- come from an aspect, as it applies to an internal entity. - - Iprag := Copy_Separate_Tree (Import_Pragma (E)); - Set_From_Aspect_Specification (Iprag, False); + Prag := Copy_Import_Pragma; -- Fix up spec to be not imported any more - Set_Is_Imported (E, False); - Set_Interface_Name (E, Empty); Set_Has_Completion (E, False); Set_Import_Pragma (E, Empty); + Set_Interface_Name (E, Empty); + Set_Is_Imported (E, False); -- Grab the subprogram declaration and specification @@ -4757,13 +4804,12 @@ package body Freeze is Copy_Separate_Tree (Spec), Declarations => New_List ( Make_Subprogram_Declaration (Loc, - Specification => - Copy_Separate_Tree (Spec)), - Iprag), + Specification => Copy_Separate_Tree (Spec)), + Prag), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Stmt), - End_Label => Make_Identifier (Loc, CE))); + Statements => New_List (Stmt), + End_Label => Make_Identifier (Loc, CE))); -- Append the body to freeze result diff --git a/gcc/ada/g-traceb.ads b/gcc/ada/g-traceb.ads index 13f5d734799..6c0e7a34036 100644 --- a/gcc/ada/g-traceb.ads +++ b/gcc/ada/g-traceb.ads @@ -62,6 +62,7 @@ -- GNU/Linux PowerPC -- LynxOS x86 -- LynxOS 178 xcoff PowerPC +-- LynxOS 178 elf PowerPC -- Solaris x86 -- Solaris sparc -- VxWorks PowerPC diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 7944604ae61..4a04e11b54a 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, 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- -- @@ -390,6 +390,40 @@ package body Inline is return; end if; + -- Find out whether the call must be inlined. Unless the result is + -- Dont_Inline, Must_Inline also creates an edge for the call in the + -- callgraph; however, it will not be activated until after Is_Called + -- is set on the subprogram. + + Level := Must_Inline; + + if Level = Dont_Inline then + return; + end if; + + -- If the call was generated by the compiler and is to a subprogram in + -- a run-time unit, we need to suppress debugging information for it, + -- so that the code that is eventually inlined will not affect the + -- debugging of the program. We do not do it if the call comes from + -- source because, even if the call is inlined, the user may expect it + -- to be present in the debugging information. + + if not Comes_From_Source (N) + and then In_Extended_Main_Source_Unit (N) + and then + Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (E))) + then + Set_Needs_Debug_Info (E, False); + end if; + + -- If the subprogram is an expression function, then there is no need to + -- load any package body since the body of the function is in the spec. + + if Is_Expression_Function (E) then + Set_Is_Called (E); + return; + end if; + -- Find unit containing E, and add to list of inlined bodies if needed. -- If the body is already present, no need to load any other unit. This -- is the case for an initialization procedure, which appears in the @@ -403,77 +437,48 @@ package body Inline is -- no enclosing package to retrieve. In this case, it is the body of -- the function that will have to be loaded. - Level := Must_Inline; + declare + Pack : constant Entity_Id := Get_Code_Unit_Entity (E); - if Level /= Dont_Inline then - declare - Pack : constant Entity_Id := Get_Code_Unit_Entity (E); + begin + if Pack = E then + Set_Is_Called (E); + Inlined_Bodies.Increment_Last; + Inlined_Bodies.Table (Inlined_Bodies.Last) := E; - begin - -- Ensure that Analyze_Inlined_Bodies will be invoked after - -- completing the analysis of the current unit. + elsif Ekind (Pack) = E_Package then + Set_Is_Called (E); - Inline_Processing_Required := True; + if Is_Generic_Instance (Pack) then + null; - if Pack = E then + -- Do not inline the package if the subprogram is an init proc + -- or other internally generated subprogram, because in that + -- case the subprogram body appears in the same unit that + -- declares the type, and that body is visible to the back end. + -- Do not inline it either if it is in the main unit. + -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always + -- calls if the back-end takes care of inlining the call. - -- Library-level inlined function. Add function itself to - -- list of needed units. - - Set_Is_Called (E); - Inlined_Bodies.Increment_Last; - Inlined_Bodies.Table (Inlined_Bodies.Last) := E; - - elsif Ekind (Pack) = E_Package then - Set_Is_Called (E); - - if Is_Generic_Instance (Pack) then - null; - - -- Do not inline the package if the subprogram is an init proc - -- or other internally generated subprogram, because in that - -- case the subprogram body appears in the same unit that - -- declares the type, and that body is visible to the back end. - -- Do not inline it either if it is in the main unit. - - elsif Level = Inline_Package - and then not Is_Inlined (Pack) - and then not Is_Internal (E) - and then not In_Main_Unit_Or_Subunit (Pack) - then - Set_Is_Inlined (Pack); - Inlined_Bodies.Increment_Last; - Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack; - - -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always - -- calls if the back-end takes care of inlining the call. - - elsif Level = Inline_Call - and then Has_Pragma_Inline_Always (E) - and then Back_End_Inlining - then - Set_Is_Inlined (Pack); - Inlined_Bodies.Increment_Last; - Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack; - end if; - end if; - - -- If the call was generated by the compiler and is to a function - -- in a run-time unit, we need to suppress debugging information - -- for it, so that the code that is eventually inlined will not - -- affect debugging of the program. We do not do it if the call - -- comes from source because, even if the call is inlined, the - -- user may expect it to be present in the debugging information. - - if not Comes_From_Source (N) - and then In_Extended_Main_Source_Unit (N) - and then - Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (E))) + elsif (Level = Inline_Package + or else (Level = Inline_Call + and then Has_Pragma_Inline_Always (E) + and then Back_End_Inlining)) + and then not Is_Inlined (Pack) + and then not Is_Internal (E) + and then not In_Main_Unit_Or_Subunit (Pack) then - Set_Needs_Debug_Info (E, False); + Set_Is_Inlined (Pack); + Inlined_Bodies.Increment_Last; + Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack; end if; - end; - end if; + end if; + + -- Ensure that Analyze_Inlined_Bodies will be invoked after + -- completing the analysis of the current unit. + + Inline_Processing_Required := True; + end; end Add_Inlined_Body; ---------------------------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 7a28bef3b35..5e4368e563c 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -101,6 +101,13 @@ package body Sem_Ch13 is -- list is stored in Static_Discrete_Predicate (Typ), and the Expr is -- rewritten as a canonicalized membership operation. + function Build_Export_Import_Pragma + (Asp : Node_Id; + Id : Entity_Id) return Node_Id; + -- Create the corresponding pragma for aspect Export or Import denoted by + -- Asp. Id is the related entity subject to the aspect. Return Empty when + -- the expression of aspect Asp evaluates to False or is erroneous. + function Build_Predicate_Function_Declaration (Typ : Entity_Id) return Node_Id; -- Build the declaration for a predicate function. The declaration is built @@ -136,6 +143,27 @@ package body Sem_Ch13 is -- Uint value. If the value is inappropriate, then error messages are -- posted as required, and a value of No_Uint is returned. + procedure Get_Interfacing_Aspects + (Iface_Asp : Node_Id; + Conv_Asp : out Node_Id; + EN_Asp : out Node_Id; + Expo_Asp : out Node_Id; + Imp_Asp : out Node_Id; + LN_Asp : out Node_Id; + Do_Checks : Boolean := False); + -- Given a single interfacing aspect Iface_Asp, retrieve other interfacing + -- aspects that apply to the same related entity. The aspects considered by + -- this routine are as follows: + -- + -- Conv_Asp - aspect Convention + -- EN_Asp - aspect External_Name + -- Expo_Asp - aspect Export + -- Imp_Asp - aspect Import + -- LN_Asp - aspect Link_Name + -- + -- When flag Do_Checks is set, this routine will flag duplicate uses of + -- aspects. + function Is_Operational_Item (N : Node_Id) return Boolean; -- A specification for a stream attribute is allowed before the full type -- is declared, as explained in AI-00137 and the corrigendum. Attributes @@ -730,10 +758,6 @@ package body Sem_Ch13 is ------------------------------------- procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is - ASN : Node_Id; - A_Id : Aspect_Id; - Ritem : Node_Id; - procedure Analyze_Aspect_Default_Value (ASN : Node_Id); -- This routine analyzes an Aspect_Default_[Component_]Value denoted by -- the aspect specification node ASN. @@ -771,6 +795,7 @@ package body Sem_Ch13 is ---------------------------------- procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is + A_Id : constant Aspect_Id := Get_Aspect_Id (ASN); Ent : constant Entity_Id := Entity (ASN); Expr : constant Node_Id := Expression (ASN); Id : constant Node_Id := Identifier (ASN); @@ -817,7 +842,8 @@ package body Sem_Ch13 is --------------------------------- procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is - P : constant Entity_Id := Entity (ASN); + A_Id : constant Aspect_Id := Get_Aspect_Id (ASN); + P : constant Entity_Id := Entity (ASN); -- Entithy for parent type N : Node_Id; @@ -1013,8 +1039,6 @@ package body Sem_Ch13 is Expr : constant Node_Id := Expression (ASN); Loc : constant Source_Ptr := Sloc (ASN); - Prag : Node_Id; - procedure Check_False_Aspect_For_Derived_Type; -- This procedure checks for the case of a false aspect for a derived -- type, which improperly tries to cancel an aspect inherited from @@ -1088,6 +1112,10 @@ package body Sem_Ch13 is ("derived type& inherits aspect%, cannot cancel", Expr, E); end Check_False_Aspect_For_Derived_Type; + -- Local variables + + Prag : Node_Id; + -- Start of processing for Make_Pragma_From_Boolean_Aspect begin @@ -1101,12 +1129,11 @@ package body Sem_Ch13 is else Prag := Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Sloc (Ident), Chars (Ident)), Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ident), - Expression => New_Occurrence_Of (Ent, Sloc (Ident)))), - - Pragma_Identifier => - Make_Identifier (Sloc (Ident), Chars (Ident))); + Expression => New_Occurrence_Of (Ent, Sloc (Ident))))); Set_From_Aspect_Specification (Prag, True); Set_Corresponding_Aspect (Prag, ASN); @@ -1116,6 +1143,12 @@ package body Sem_Ch13 is end if; end Make_Pragma_From_Boolean_Aspect; + -- Local variables + + A_Id : Aspect_Id; + ASN : Node_Id; + Ritem : Node_Id; + -- Start of processing for Analyze_Aspects_At_Freeze_Point begin @@ -1142,7 +1175,25 @@ package body Sem_Ch13 is when Boolean_Aspects | Library_Unit_Aspects => - Make_Pragma_From_Boolean_Aspect (ASN); + + -- Aspects Export and Import require special handling. + -- Both are by definition Boolean and may benefit from + -- forward references, however their expressions are + -- treated as static. In addition, the syntax of their + -- corresponding pragmas requires extra "pieces" which + -- may also contain forward references. To account for + -- all of this, the corresponding pragma is created by + -- Analyze_Aspect_Export_Import, but is not analyzed as + -- the complete analysis must happen now. + + if A_Id = Aspect_Export or else A_Id = Aspect_Import then + null; + + -- Otherwise create a corresponding pragma + + else + Make_Pragma_From_Boolean_Aspect (ASN); + end if; -- Special handling for aspects that don't correspond to -- pragmas/attributes. @@ -1435,8 +1486,9 @@ package body Sem_Ch13 is -- Insert pragmas/attribute definition clause after this node when no -- delayed analysis is required. - -- Start of processing for Analyze_Aspect_Specifications + -- Start of processing for Analyze_Aspect_Specifications + begin -- The general processing involves building an attribute definition -- clause or a pragma node that corresponds to the aspect. Then in order -- to delay the evaluation of this aspect to the freeze point, we attach @@ -1456,7 +1508,6 @@ package body Sem_Ch13 is -- of visibility for the expression analysis. Thus, we just insert -- the pragma after the node N. - begin pragma Assert (Present (L)); -- Loop through aspects @@ -1478,8 +1529,14 @@ package body Sem_Ch13 is -- Source location of expression, modified when we split PPC's. It -- is set below when Expr is present. - procedure Analyze_Aspect_External_Or_Link_Name; - -- Perform analysis of the External_Name or Link_Name aspects + procedure Analyze_Aspect_Convention; + -- Perform analysis of aspect Convention + + procedure Analyze_Aspect_Export_Import; + -- Perform analysis of aspects Export or Import + + procedure Analyze_Aspect_External_Link_Name; + -- Perform analysis of aspects External_Name or Link_Name procedure Analyze_Aspect_Implicit_Dereference; -- Perform analysis of the Implicit_Dereference aspects @@ -1496,35 +1553,193 @@ package body Sem_Ch13 is -- True, and sets Corresponding_Aspect to point to the aspect. -- The resulting pragma is assigned to Aitem. - ------------------------------------------ - -- Analyze_Aspect_External_Or_Link_Name -- - ------------------------------------------ + ------------------------------- + -- Analyze_Aspect_Convention -- + ------------------------------- + + procedure Analyze_Aspect_Convention is + Conv : Node_Id; + Dummy_1 : Node_Id; + Dummy_2 : Node_Id; + Dummy_3 : Node_Id; + Expo : Node_Id; + Imp : Node_Id; - procedure Analyze_Aspect_External_Or_Link_Name is begin - -- Verify that there is an Import/Export aspect defined for the - -- entity. The processing of that aspect in turn checks that - -- there is a Convention aspect declared. The pragma is - -- constructed when processing the Convention aspect. + -- Obtain all interfacing aspects that apply to the related + -- entity. - declare - A : Node_Id; + Get_Interfacing_Aspects + (Iface_Asp => Aspect, + Conv_Asp => Dummy_1, + EN_Asp => Dummy_2, + Expo_Asp => Expo, + Imp_Asp => Imp, + LN_Asp => Dummy_3, + Do_Checks => True); - begin - A := First (L); - while Present (A) loop - exit when Nam_In (Chars (Identifier (A)), Name_Export, - Name_Import); - Next (A); - end loop; + -- The related entity is subject to aspect Export or Import. + -- Do not process Convention now because it must be analysed + -- as part of Export or Import. - if No (A) then - Error_Msg_N - ("missing Import/Export for Link/External name", - Aspect); + if Present (Expo) or else Present (Imp) then + return; + + -- Otherwise Convention appears by itself + + else + -- The aspect specifies a particular convention + + if Present (Expr) then + Conv := New_Copy_Tree (Expr); + + -- Otherwise assume convention Ada + + else + Conv := Make_Identifier (Loc, Name_Ada); end if; - end; - end Analyze_Aspect_External_Or_Link_Name; + + -- Generate: + -- pragma Convention (, ); + + Make_Aitem_Pragma + (Pragma_Name => Name_Convention, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Conv), + Make_Pragma_Argument_Association (Loc, + Expression => New_Occurrence_Of (E, Loc)))); + + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + end if; + end Analyze_Aspect_Convention; + + ---------------------------------- + -- Analyze_Aspect_Export_Import -- + ---------------------------------- + + procedure Analyze_Aspect_Export_Import is + Dummy_1 : Node_Id; + Dummy_2 : Node_Id; + Dummy_3 : Node_Id; + Expo : Node_Id; + Imp : Node_Id; + + begin + -- Obtain all interfacing aspects that apply to the related + -- entity. + + Get_Interfacing_Aspects + (Iface_Asp => Aspect, + Conv_Asp => Dummy_1, + EN_Asp => Dummy_2, + Expo_Asp => Expo, + Imp_Asp => Imp, + LN_Asp => Dummy_3, + Do_Checks => True); + + -- The related entity cannot be subject to both aspects Export + -- and Import. + + if Present (Expo) and then Present (Imp) then + Error_Msg_N + ("incompatible interfacing aspects given for &", E); + Error_Msg_Sloc := Sloc (Expo); + Error_Msg_N ("\aspect `Export` #", E); + Error_Msg_Sloc := Sloc (Imp); + Error_Msg_N ("\aspect `Import` #", E); + end if; + + -- A variable is most likely modified from the outside. Take + -- Take the optimistic approach to avoid spurious errors. + + if Ekind (E) = E_Variable then + Set_Never_Set_In_Source (E, False); + end if; + + -- Resolve the expression of an Import or Export here, and + -- require it to be of type Boolean and static. This is not + -- quite right, because in general this should be delayed, + -- but that seems tricky for these, because normally Boolean + -- aspects are replaced with pragmas at the freeze point in + -- Make_Pragma_From_Boolean_Aspect. + + if not Present (Expr) + or else Is_True (Static_Boolean (Expr)) + then + if A_Id = Aspect_Import then + Set_Has_Completion (E); + Set_Is_Imported (E); + + -- An imported object cannot be explicitly initialized + + if Nkind (N) = N_Object_Declaration + and then Present (Expression (N)) + then + Error_Msg_N + ("imported entities cannot be initialized " + & "(RM B.1(24))", Expression (N)); + end if; + + else + pragma Assert (A_Id = Aspect_Export); + Set_Is_Exported (E); + end if; + + -- Create the proper form of pragma Export or Import taking + -- into account Conversion, External_Name, and Link_Name. + + Aitem := Build_Export_Import_Pragma (Aspect, E); + end if; + end Analyze_Aspect_Export_Import; + + --------------------------------------- + -- Analyze_Aspect_External_Link_Name -- + --------------------------------------- + + procedure Analyze_Aspect_External_Link_Name is + Dummy_1 : Node_Id; + Dummy_2 : Node_Id; + Dummy_3 : Node_Id; + Expo : Node_Id; + Imp : Node_Id; + + begin + -- Obtain all interfacing aspects that apply to the related + -- entity. + + Get_Interfacing_Aspects + (Iface_Asp => Aspect, + Conv_Asp => Dummy_1, + EN_Asp => Dummy_2, + Expo_Asp => Expo, + Imp_Asp => Imp, + LN_Asp => Dummy_3, + Do_Checks => True); + + -- Ensure that aspect External_Name applies to aspect Export or + -- Import. + + if A_Id = Aspect_External_Name then + if No (Expo) and then No (Imp) then + Error_Msg_N + ("aspect `External_Name` requires aspect `Import` or " + & "`Export`", Aspect); + end if; + + -- Otherwise ensure that aspect Link_Name applies to aspect + -- Export or Import. + + else + pragma Assert (A_Id = Aspect_Link_Name); + if No (Expo) and then No (Imp) then + Error_Msg_N + ("aspect `Link_Name` requires aspect `Import` or " + & "`Export`", Aspect); + end if; + end if; + end Analyze_Aspect_External_Link_Name; ----------------------------------------- -- Analyze_Aspect_Implicit_Dereference -- @@ -1561,8 +1776,7 @@ package body Sem_Ch13 is -- Error if no proper access discriminant if No (Disc) then - Error_Msg_NE - ("not an access discriminant of&", Expr, E); + Error_Msg_NE ("not an access discriminant of&", Expr, E); return; end if; end if; @@ -1578,8 +1792,9 @@ package body Sem_Ch13 is if Present (Parent_Disc) and then Corresponding_Discriminant (Disc) /= Parent_Disc then - Error_Msg_N ("reference discriminant does not match " & - "discriminant of parent type", Expr); + Error_Msg_N + ("reference discriminant does not match discriminant " + & "of parent type", Expr); end if; end if; end Analyze_Aspect_Implicit_Dereference; @@ -2040,101 +2255,16 @@ package body Sem_Ch13 is -- Convention - when Aspect_Convention => + when Aspect_Convention => + Analyze_Aspect_Convention; + goto Continue; - -- The aspect may be part of the specification of an import - -- or export pragma. Scan the aspect list to gather the - -- other components, if any. The name of the generated - -- pragma is one of Convention/Import/Export. + -- External_Name, Link_Name - declare - Args : constant List_Id := New_List ( - Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr)), - Make_Pragma_Argument_Association (Sloc (Ent), - Expression => Ent)); - - Imp_Exp_Seen : Boolean := False; - -- Flag set when aspect Import or Export has been seen - - Imp_Seen : Boolean := False; - -- Flag set when aspect Import has been seen - - Asp : Node_Id; - Asp_Nam : Name_Id; - Extern_Arg : Node_Id; - Link_Arg : Node_Id; - Prag_Nam : Name_Id; - - begin - Extern_Arg := Empty; - Link_Arg := Empty; - Prag_Nam := Chars (Id); - - Asp := First (L); - while Present (Asp) loop - Asp_Nam := Chars (Identifier (Asp)); - - -- Aspects Import and Export take precedence over - -- aspect Convention. As a result the generated pragma - -- must carry the proper interfacing aspect's name. - - if Nam_In (Asp_Nam, Name_Import, Name_Export) then - if Imp_Exp_Seen then - Error_Msg_N ("conflicting", Asp); - else - Imp_Exp_Seen := True; - - if Asp_Nam = Name_Import then - Imp_Seen := True; - end if; - end if; - - Prag_Nam := Asp_Nam; - - -- Aspect External_Name adds an extra argument to the - -- generated pragma. - - elsif Asp_Nam = Name_External_Name then - Extern_Arg := - Make_Pragma_Argument_Association (Loc, - Chars => Asp_Nam, - Expression => Relocate_Node (Expression (Asp))); - - -- Aspect Link_Name adds an extra argument to the - -- generated pragma. - - elsif Asp_Nam = Name_Link_Name then - Link_Arg := - Make_Pragma_Argument_Association (Loc, - Chars => Asp_Nam, - Expression => Relocate_Node (Expression (Asp))); - end if; - - Next (Asp); - end loop; - - -- Assemble the full argument list - - if Present (Extern_Arg) then - Append_To (Args, Extern_Arg); - end if; - - if Present (Link_Arg) then - Append_To (Args, Link_Arg); - end if; - - Make_Aitem_Pragma - (Pragma_Argument_Associations => Args, - Pragma_Name => Prag_Nam); - - -- Store the generated pragma Import in the related - -- subprogram. - - if Imp_Seen and then Is_Subprogram (E) then - Set_Import_Pragma (E, Aitem); - end if; - end; + when Aspect_External_Name | + Aspect_Link_Name => + Analyze_Aspect_External_Link_Name; + goto Continue; -- CPU, Interrupt_Priority, Priority @@ -2937,8 +3067,9 @@ package body Sem_Ch13 is if not (Is_Array_Type (E) and then Is_Scalar_Type (Component_Type (E))) then - Error_Msg_N ("aspect Default_Component_Value can only " - & "apply to an array of scalar components", N); + Error_Msg_N + ("aspect Default_Component_Value can only apply to an " + & "array of scalar components", N); end if; Aitem := Empty; @@ -2956,13 +3087,6 @@ package body Sem_Ch13 is Analyze_Aspect_Implicit_Dereference; goto Continue; - -- External_Name, Link_Name - - when Aspect_External_Name | - Aspect_Link_Name => - Analyze_Aspect_External_Or_Link_Name; - goto Continue; - -- Dimension when Aspect_Dimension => @@ -3187,61 +3311,8 @@ package body Sem_Ch13 is goto Continue; - elsif A_Id = Aspect_Import or else A_Id = Aspect_Export then - - -- For the case of aspects Import and Export, we don't - -- consider that we know the entity is never set in the - -- source, since it is is likely modified outside the - -- program. - - -- Note: one might think that the analysis of the - -- resulting pragma would take care of that, but - -- that's not the case since it won't be from source. - - if Ekind (E) = E_Variable then - Set_Never_Set_In_Source (E, False); - end if; - - -- In older versions of Ada the corresponding pragmas - -- specified a Convention. In Ada 2012 the convention is - -- specified as a separate aspect, and it is optional, - -- given that it defaults to Convention_Ada. The code - -- that verifed that there was a matching convention - -- is now obsolete. - - -- Resolve the expression of an Import or Export here, - -- and require it to be of type Boolean and static. This - -- is not quite right, because in general this should be - -- delayed, but that seems tricky for these, because - -- normally Boolean aspects are replaced with pragmas at - -- the freeze point (in Make_Pragma_From_Boolean_Aspect), - -- but in the case of these aspects we can't generate - -- a simple pragma with just the entity name. ??? - - if not Present (Expr) - or else Is_True (Static_Boolean (Expr)) - then - if A_Id = Aspect_Import then - Set_Is_Imported (E); - Set_Has_Completion (E); - - -- An imported entity cannot have an explicit - -- initialization. - - if Nkind (N) = N_Object_Declaration - and then Present (Expression (N)) - then - Error_Msg_N - ("imported entities cannot be initialized " - & "(RM B.1(24))", Expression (N)); - end if; - - elsif A_Id = Aspect_Export then - Set_Is_Exported (E); - end if; - end if; - - goto Continue; + elsif A_Id = Aspect_Export or else A_Id = Aspect_Import then + Analyze_Aspect_Export_Import; -- Disable_Controlled @@ -3302,11 +3373,20 @@ package body Sem_Ch13 is -- expression is missing other than the above cases. if not Delay_Required or else No (Expr) then - Make_Aitem_Pragma - (Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Sloc (Ent), - Expression => Ent)), - Pragma_Name => Chars (Id)); + + -- Exclude aspects Export and Import because their pragma + -- syntax does not map directly to a Boolean aspect. + + if A_Id /= Aspect_Export + and then A_Id /= Aspect_Import + then + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent)), + Pragma_Name => Chars (Id)); + end if; + Delay_Required := False; -- In general cases, the corresponding pragma/attribute @@ -3506,7 +3586,7 @@ package body Sem_Ch13 is -- unit, we simply insert the pragma/attribute definition clause -- in sequence. - else + elsif Present (Aitem) then Insert_After (Ins_Node, Aitem); Ins_Node := Aitem; end if; @@ -7814,6 +7894,133 @@ package body Sem_Ch13 is return; end Build_Discrete_Static_Predicate; + -------------------------------- + -- Build_Export_Import_Pragma -- + -------------------------------- + + function Build_Export_Import_Pragma + (Asp : Node_Id; + Id : Entity_Id) return Node_Id + is + Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp); + Expr : constant Node_Id := Expression (Asp); + Loc : constant Source_Ptr := Sloc (Asp); + + Args : List_Id; + Conv : Node_Id; + Conv_Arg : Node_Id; + Dummy_1 : Node_Id; + Dummy_2 : Node_Id; + EN : Node_Id; + LN : Node_Id; + Prag : Node_Id; + + Create_Pragma : Boolean := False; + -- This flag is set when the aspect form is such that it warrants the + -- creation of a corresponding pragma. + + begin + if Present (Expr) then + if Error_Posted (Expr) then + null; + + elsif Is_True (Expr_Value (Expr)) then + Create_Pragma := True; + end if; + + -- Otherwise the aspect defaults to True + + else + Create_Pragma := True; + end if; + + -- Nothing to do when the expression is False or is erroneous + + if not Create_Pragma then + return Empty; + end if; + + -- Obtain all interfacing aspects that apply to the related entity + + Get_Interfacing_Aspects + (Iface_Asp => Asp, + Conv_Asp => Conv, + EN_Asp => EN, + Expo_Asp => Dummy_1, + Imp_Asp => Dummy_2, + LN_Asp => LN); + + Args := New_List; + + -- Handle the convention argument + + if Present (Conv) then + Conv_Arg := New_Copy_Tree (Expression (Conv)); + + -- Assume convention "Ada' when aspect Convention is missing + + else + Conv_Arg := Make_Identifier (Loc, Name_Ada); + end if; + + Append_To (Args, + Make_Pragma_Argument_Association (Loc, + Chars => Name_Convention, + Expression => Conv_Arg)); + + -- Handle the entity argument + + Append_To (Args, + Make_Pragma_Argument_Association (Loc, + Chars => Name_Entity, + Expression => New_Occurrence_Of (Id, Loc))); + + -- Handle the External_Name argument + + if Present (EN) then + Append_To (Args, + Make_Pragma_Argument_Association (Loc, + Chars => Name_External_Name, + Expression => New_Copy_Tree (Expression (EN)))); + end if; + + -- Handle the Link_Name argument + + if Present (LN) then + Append_To (Args, + Make_Pragma_Argument_Association (Loc, + Chars => Name_Link_Name, + Expression => New_Copy_Tree (Expression (LN)))); + end if; + + -- Generate: + -- pragma Export/Import + -- (Convention => /Ada, + -- Entity => , + -- [External_Name => ,] + -- [Link_Name => ]); + + Prag := + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Loc, Chars (Identifier (Asp))), + Pragma_Argument_Associations => Args); + + -- Decorate the relevant aspect and the pragma + + Set_Aspect_Rep_Item (Asp, Prag); + + Set_Corresponding_Aspect (Prag, Asp); + Set_From_Aspect_Specification (Prag); + Set_Parent (Prag, Asp); + + if Asp_Id = Aspect_Import and then Is_Subprogram (Id) then + Set_Import_Pragma (Id, Prag); + end if; + + return Prag; + end Build_Export_Import_Pragma; + ------------------------------------------- -- Build_Invariant_Procedure_Declaration -- ------------------------------------------- @@ -11298,6 +11505,106 @@ package body Sem_Ch13 is end if; end Get_Alignment_Value; + ----------------------------- + -- Get_Interfacing_Aspects -- + ----------------------------- + + procedure Get_Interfacing_Aspects + (Iface_Asp : Node_Id; + Conv_Asp : out Node_Id; + EN_Asp : out Node_Id; + Expo_Asp : out Node_Id; + Imp_Asp : out Node_Id; + LN_Asp : out Node_Id; + Do_Checks : Boolean := False) + is + procedure Save_Or_Duplication_Error + (Asp : Node_Id; + To : in out Node_Id); + -- Save the value of aspect Asp in node To. If To already has a value, + -- then this is considered a duplicate use of aspect. Emit an error if + -- flag Do_Checks is set. + + ------------------------------- + -- Save_Or_Duplication_Error -- + ------------------------------- + + procedure Save_Or_Duplication_Error + (Asp : Node_Id; + To : in out Node_Id) + is + begin + -- Detect an extra aspect and issue an error + + if Present (To) then + if Do_Checks then + Error_Msg_Name_1 := Chars (Identifier (Asp)); + Error_Msg_Sloc := Sloc (To); + Error_Msg_N ("aspect % previously given #", Asp); + end if; + + -- Otherwise capture the aspect + + else + To := Asp; + end if; + end Save_Or_Duplication_Error; + + -- Local variables + + Asp : Node_Id; + Asp_Id : Aspect_Id; + + -- The following variables capture each individual aspect + + Conv : Node_Id := Empty; + EN : Node_Id := Empty; + Expo : Node_Id := Empty; + Imp : Node_Id := Empty; + LN : Node_Id := Empty; + + -- Start of processing for Get_Interfacing_Aspects + + begin + -- The input interfacing aspect should reside in an aspect specification + -- list. + + pragma Assert (Is_List_Member (Iface_Asp)); + + -- Examine the aspect specifications of the related entity. Find and + -- capture all interfacing aspects. Detect duplicates and emit errors + -- if applicable. + + Asp := First (List_Containing (Iface_Asp)); + while Present (Asp) loop + Asp_Id := Get_Aspect_Id (Asp); + + if Asp_Id = Aspect_Convention then + Save_Or_Duplication_Error (Asp, Conv); + + elsif Asp_Id = Aspect_External_Name then + Save_Or_Duplication_Error (Asp, EN); + + elsif Asp_Id = Aspect_Export then + Save_Or_Duplication_Error (Asp, Expo); + + elsif Asp_Id = Aspect_Import then + Save_Or_Duplication_Error (Asp, Imp); + + elsif Asp_Id = Aspect_Link_Name then + Save_Or_Duplication_Error (Asp, LN); + end if; + + Next (Asp); + end loop; + + Conv_Asp := Conv; + EN_Asp := EN; + Expo_Asp := Expo; + Imp_Asp := Imp; + LN_Asp := LN; + end Get_Interfacing_Aspects; + ------------------------------------- -- Inherit_Aspects_At_Freeze_Point -- -------------------------------------