Skip to content

R
riscv-gcc-1
Commit 2e885a6f by Arnaud Charlet
Options

[multiple changes] 

2016-04-27  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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  <ebotcazou@adacore.com>

	* inline.adb (Add_Inlined_Body): Overhaul implementation,
	robustify handling of -gnatn1, add special treatment for
	expression functions.

2016-04-27  Doug Rupp  <rupp@adacore.com>

	* g-traceb.ads: Update comment.
	* exp_ch2.adb: minor style fix in object declaration

From-SVN: r235483
parent 2a253c5b
Showing with 645 additions and 251 deletions
gcc/ada/ChangeLog
2016-04-27 Hristian Kirtchev <kirtchev@adacore.com> 2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* 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 <ebotcazou@adacore.com>
* inline.adb (Add_Inlined_Body): Overhaul implementation,
robustify handling of -gnatn1, add special treatment for
expression functions.
2016-04-27 Doug Rupp <rupp@adacore.com>
* g-traceb.ads: Update comment.
* exp_ch2.adb: minor style fix in object declaration
2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* sem_elab.adb (Check_Internal_Call): Do not * sem_elab.adb (Check_Internal_Call): Do not
consider a call when it appears within pragma Initial_Condition consider a call when it appears within pragma Initial_Condition
since the pragma is part of the elaboration statements of a since the pragma is part of the elaboration statements of a
......
gcc/ada/aspects.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -652,12 +652,10 @@ package Aspects is ...@@ -652,12 +652,10 @@ package Aspects is
Aspect_Dispatching_Domain => Always_Delay, Aspect_Dispatching_Domain => Always_Delay,
Aspect_Dynamic_Predicate => Always_Delay, Aspect_Dynamic_Predicate => Always_Delay,
Aspect_Elaborate_Body => Always_Delay, Aspect_Elaborate_Body => Always_Delay,
Aspect_Export => Always_Delay,
Aspect_External_Name => Always_Delay, Aspect_External_Name => Always_Delay,
Aspect_External_Tag => Always_Delay, Aspect_External_Tag => Always_Delay,
Aspect_Favor_Top_Level => Always_Delay, Aspect_Favor_Top_Level => Always_Delay,
Aspect_Implicit_Dereference => Always_Delay, Aspect_Implicit_Dereference => Always_Delay,
Aspect_Import => Always_Delay,
Aspect_Independent => Always_Delay, Aspect_Independent => Always_Delay,
Aspect_Independent_Components => Always_Delay, Aspect_Independent_Components => Always_Delay,
Aspect_Inline => Always_Delay, Aspect_Inline => Always_Delay,
...@@ -726,9 +724,11 @@ package Aspects is ...@@ -726,9 +724,11 @@ package Aspects is
Aspect_Disable_Controlled => Never_Delay, Aspect_Disable_Controlled => Never_Delay,
Aspect_Effective_Reads => Never_Delay, Aspect_Effective_Reads => Never_Delay,
Aspect_Effective_Writes => Never_Delay, Aspect_Effective_Writes => Never_Delay,
Aspect_Export => Never_Delay,
Aspect_Extensions_Visible => Never_Delay, Aspect_Extensions_Visible => Never_Delay,
Aspect_Ghost => Never_Delay, Aspect_Ghost => Never_Delay,
Aspect_Global => Never_Delay, Aspect_Global => Never_Delay,
Aspect_Import => Never_Delay,
Aspect_Initial_Condition => Never_Delay, Aspect_Initial_Condition => Never_Delay,
Aspect_Initializes => Never_Delay, Aspect_Initializes => Never_Delay,
Aspect_No_Elaboration_Code_All => Never_Delay, Aspect_No_Elaboration_Code_All => Never_Delay,
......
gcc/ada/freeze.adb
...@@ -4676,14 +4676,65 @@ package body Freeze is ...@@ -4676,14 +4676,65 @@ package body Freeze is
-- for the subprogram body that calls the inner procedure. -- for the subprogram body that calls the inner procedure.
procedure Wrap_Imported_Subprogram (E : Entity_Id) is 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); Loc : constant Source_Ptr := Sloc (E);
CE : constant Name_Id := Chars (E); CE : constant Name_Id := Chars (E);
Spec : Node_Id;
Parms : List_Id;
Stmt : Node_Id;
Iprag : Node_Id;
Bod : Node_Id; Bod : Node_Id;
Forml : Entity_Id; Forml : Entity_Id;
Parms : List_Id;
Prag : Node_Id;
Spec : Node_Id;
Stmt : Node_Id;
-- Start of processing for Wrap_Imported_Subprogram
begin begin
-- Nothing to do if not imported -- Nothing to do if not imported
...@@ -4706,18 +4757,14 @@ package body Freeze is ...@@ -4706,18 +4757,14 @@ package body Freeze is
-- generates the right visibility, and that is exactly what the -- generates the right visibility, and that is exactly what the
-- calls to Copy_Separate_Tree give us. -- calls to Copy_Separate_Tree give us.
-- Acquire copy of Inline pragma, and indicate that it does not Prag := Copy_Import_Pragma;
-- come from an aspect, as it applies to an internal entity.
Iprag := Copy_Separate_Tree (Import_Pragma (E));
Set_From_Aspect_Specification (Iprag, False);
-- Fix up spec to be not imported any more -- 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_Has_Completion (E, False);
Set_Import_Pragma (E, Empty); Set_Import_Pragma (E, Empty);
Set_Interface_Name (E, Empty);
Set_Is_Imported (E, False);
-- Grab the subprogram declaration and specification -- Grab the subprogram declaration and specification
...@@ -4757,9 +4804,8 @@ package body Freeze is ...@@ -4757,9 +4804,8 @@ package body Freeze is
Copy_Separate_Tree (Spec), Copy_Separate_Tree (Spec),
Declarations => New_List ( Declarations => New_List (
Make_Subprogram_Declaration (Loc, Make_Subprogram_Declaration (Loc,
Specification => Specification => Copy_Separate_Tree (Spec)),
Copy_Separate_Tree (Spec)), Prag),
Iprag),
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Stmt), Statements => New_List (Stmt),
......
gcc/ada/g-traceb.ads
...@@ -62,6 +62,7 @@ ...@@ -62,6 +62,7 @@
-- GNU/Linux PowerPC -- GNU/Linux PowerPC
-- LynxOS x86 -- LynxOS x86
-- LynxOS 178 xcoff PowerPC -- LynxOS 178 xcoff PowerPC
-- LynxOS 178 elf PowerPC
-- Solaris x86 -- Solaris x86
-- Solaris sparc -- Solaris sparc
-- VxWorks PowerPC -- VxWorks PowerPC
......
gcc/ada/inline.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -390,6 +390,40 @@ package body Inline is ...@@ -390,6 +390,40 @@ package body Inline is
return; return;
end if; 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. -- 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 -- 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 -- is the case for an initialization procedure, which appears in the
...@@ -403,23 +437,11 @@ package body Inline is ...@@ -403,23 +437,11 @@ package body Inline is
-- no enclosing package to retrieve. In this case, it is the body of -- no enclosing package to retrieve. In this case, it is the body of
-- the function that will have to be loaded. -- the function that will have to be loaded.
Level := Must_Inline;
if Level /= Dont_Inline then
declare declare
Pack : constant Entity_Id := Get_Code_Unit_Entity (E); Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
begin begin
-- Ensure that Analyze_Inlined_Bodies will be invoked after
-- completing the analysis of the current unit.
Inline_Processing_Required := True;
if Pack = E then if Pack = E then
-- Library-level inlined function. Add function itself to
-- list of needed units.
Set_Is_Called (E); Set_Is_Called (E);
Inlined_Bodies.Increment_Last; Inlined_Bodies.Increment_Last;
Inlined_Bodies.Table (Inlined_Bodies.Last) := E; Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
...@@ -435,22 +457,16 @@ package body Inline is ...@@ -435,22 +457,16 @@ package body Inline is
-- case the subprogram body appears in the same unit that -- case the subprogram body appears in the same unit that
-- declares the type, and that body is visible to the back end. -- declares the type, and that body is visible to the back end.
-- Do not inline it either if it is in the main unit. -- 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 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
-- calls if the back-end takes care of inlining the call. -- calls if the back-end takes care of inlining the call.
elsif Level = Inline_Call elsif (Level = Inline_Package
or else (Level = Inline_Call
and then Has_Pragma_Inline_Always (E) and then Has_Pragma_Inline_Always (E)
and then Back_End_Inlining 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 then
Set_Is_Inlined (Pack); Set_Is_Inlined (Pack);
Inlined_Bodies.Increment_Last; Inlined_Bodies.Increment_Last;
...@@ -458,22 +474,11 @@ package body Inline is ...@@ -458,22 +474,11 @@ package body Inline is
end if; end if;
end if; end if;
-- If the call was generated by the compiler and is to a function -- Ensure that Analyze_Inlined_Bodies will be invoked after
-- in a run-time unit, we need to suppress debugging information -- completing the analysis of the current unit.
-- 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) Inline_Processing_Required := True;
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;
end; end;
end if;
end Add_Inlined_Body; end Add_Inlined_Body;
---------------------------- ----------------------------
......
gcc/ada/sem_ch13.adb
...@@ -101,6 +101,13 @@ package body Sem_Ch13 is ...@@ -101,6 +101,13 @@ package body Sem_Ch13 is
-- list is stored in Static_Discrete_Predicate (Typ), and the Expr is -- list is stored in Static_Discrete_Predicate (Typ), and the Expr is
-- rewritten as a canonicalized membership operation. -- 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 function Build_Predicate_Function_Declaration
(Typ : Entity_Id) return Node_Id; (Typ : Entity_Id) return Node_Id;
-- Build the declaration for a predicate function. The declaration is built -- Build the declaration for a predicate function. The declaration is built
...@@ -136,6 +143,27 @@ package body Sem_Ch13 is ...@@ -136,6 +143,27 @@ package body Sem_Ch13 is
-- Uint value. If the value is inappropriate, then error messages are -- Uint value. If the value is inappropriate, then error messages are
-- posted as required, and a value of No_Uint is returned. -- 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; function Is_Operational_Item (N : Node_Id) return Boolean;
-- A specification for a stream attribute is allowed before the full type -- A specification for a stream attribute is allowed before the full type
-- is declared, as explained in AI-00137 and the corrigendum. Attributes -- is declared, as explained in AI-00137 and the corrigendum. Attributes
...@@ -730,10 +758,6 @@ package body Sem_Ch13 is ...@@ -730,10 +758,6 @@ package body Sem_Ch13 is
------------------------------------- -------------------------------------
procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) 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); procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
-- This routine analyzes an Aspect_Default_[Component_]Value denoted by -- This routine analyzes an Aspect_Default_[Component_]Value denoted by
-- the aspect specification node ASN. -- the aspect specification node ASN.
...@@ -771,6 +795,7 @@ package body Sem_Ch13 is ...@@ -771,6 +795,7 @@ package body Sem_Ch13 is
---------------------------------- ----------------------------------
procedure Analyze_Aspect_Default_Value (ASN : Node_Id) 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); Ent : constant Entity_Id := Entity (ASN);
Expr : constant Node_Id := Expression (ASN); Expr : constant Node_Id := Expression (ASN);
Id : constant Node_Id := Identifier (ASN); Id : constant Node_Id := Identifier (ASN);
...@@ -817,6 +842,7 @@ package body Sem_Ch13 is ...@@ -817,6 +842,7 @@ package body Sem_Ch13 is
--------------------------------- ---------------------------------
procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is
A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
P : constant Entity_Id := Entity (ASN); P : constant Entity_Id := Entity (ASN);
-- Entithy for parent type -- Entithy for parent type
...@@ -1013,8 +1039,6 @@ package body Sem_Ch13 is ...@@ -1013,8 +1039,6 @@ package body Sem_Ch13 is
Expr : constant Node_Id := Expression (ASN); Expr : constant Node_Id := Expression (ASN);
Loc : constant Source_Ptr := Sloc (ASN); Loc : constant Source_Ptr := Sloc (ASN);
Prag : Node_Id;
procedure Check_False_Aspect_For_Derived_Type; procedure Check_False_Aspect_For_Derived_Type;
-- This procedure checks for the case of a false aspect for a derived -- This procedure checks for the case of a false aspect for a derived
-- type, which improperly tries to cancel an aspect inherited from -- type, which improperly tries to cancel an aspect inherited from
...@@ -1088,6 +1112,10 @@ package body Sem_Ch13 is ...@@ -1088,6 +1112,10 @@ package body Sem_Ch13 is
("derived type& inherits aspect%, cannot cancel", Expr, E); ("derived type& inherits aspect%, cannot cancel", Expr, E);
end Check_False_Aspect_For_Derived_Type; end Check_False_Aspect_For_Derived_Type;
-- Local variables
Prag : Node_Id;
-- Start of processing for Make_Pragma_From_Boolean_Aspect -- Start of processing for Make_Pragma_From_Boolean_Aspect
begin begin
...@@ -1101,12 +1129,11 @@ package body Sem_Ch13 is ...@@ -1101,12 +1129,11 @@ package body Sem_Ch13 is
else else
Prag := Prag :=
Make_Pragma (Loc, Make_Pragma (Loc,
Pragma_Identifier =>
Make_Identifier (Sloc (Ident), Chars (Ident)),
Pragma_Argument_Associations => New_List ( Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ident), Make_Pragma_Argument_Association (Sloc (Ident),
Expression => New_Occurrence_Of (Ent, Sloc (Ident)))), Expression => New_Occurrence_Of (Ent, Sloc (Ident)))));
Pragma_Identifier =>
Make_Identifier (Sloc (Ident), Chars (Ident)));
Set_From_Aspect_Specification (Prag, True); Set_From_Aspect_Specification (Prag, True);
Set_Corresponding_Aspect (Prag, ASN); Set_Corresponding_Aspect (Prag, ASN);
...@@ -1116,6 +1143,12 @@ package body Sem_Ch13 is ...@@ -1116,6 +1143,12 @@ package body Sem_Ch13 is
end if; end if;
end Make_Pragma_From_Boolean_Aspect; 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 -- Start of processing for Analyze_Aspects_At_Freeze_Point
begin begin
...@@ -1142,7 +1175,25 @@ package body Sem_Ch13 is ...@@ -1142,7 +1175,25 @@ package body Sem_Ch13 is
when Boolean_Aspects | when Boolean_Aspects |
Library_Unit_Aspects => Library_Unit_Aspects =>
-- 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); Make_Pragma_From_Boolean_Aspect (ASN);
end if;
-- Special handling for aspects that don't correspond to -- Special handling for aspects that don't correspond to
-- pragmas/attributes. -- pragmas/attributes.
...@@ -1437,6 +1488,7 @@ package body Sem_Ch13 is ...@@ -1437,6 +1488,7 @@ package body Sem_Ch13 is
-- Start of processing for Analyze_Aspect_Specifications -- Start of processing for Analyze_Aspect_Specifications
begin
-- The general processing involves building an attribute definition -- The general processing involves building an attribute definition
-- clause or a pragma node that corresponds to the aspect. Then in order -- 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 -- to delay the evaluation of this aspect to the freeze point, we attach
...@@ -1456,7 +1508,6 @@ package body Sem_Ch13 is ...@@ -1456,7 +1508,6 @@ package body Sem_Ch13 is
-- of visibility for the expression analysis. Thus, we just insert -- of visibility for the expression analysis. Thus, we just insert
-- the pragma after the node N. -- the pragma after the node N.
begin
pragma Assert (Present (L)); pragma Assert (Present (L));
-- Loop through aspects -- Loop through aspects
...@@ -1478,8 +1529,14 @@ package body Sem_Ch13 is ...@@ -1478,8 +1529,14 @@ package body Sem_Ch13 is
-- Source location of expression, modified when we split PPC's. It -- Source location of expression, modified when we split PPC's. It
-- is set below when Expr is present. -- is set below when Expr is present.
procedure Analyze_Aspect_External_Or_Link_Name; procedure Analyze_Aspect_Convention;
-- Perform analysis of the External_Name or Link_Name aspects -- 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; procedure Analyze_Aspect_Implicit_Dereference;
-- Perform analysis of the Implicit_Dereference aspects -- Perform analysis of the Implicit_Dereference aspects
...@@ -1496,35 +1553,193 @@ package body Sem_Ch13 is ...@@ -1496,35 +1553,193 @@ package body Sem_Ch13 is
-- True, and sets Corresponding_Aspect to point to the aspect. -- True, and sets Corresponding_Aspect to point to the aspect.
-- The resulting pragma is assigned to Aitem. -- 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 begin
-- Verify that there is an Import/Export aspect defined for the -- Obtain all interfacing aspects that apply to the related
-- entity. The processing of that aspect in turn checks that -- entity.
-- there is a Convention aspect declared. The pragma is
-- constructed when processing the Convention aspect.
declare Get_Interfacing_Aspects
A : Node_Id; (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 is subject to aspect Export or Import.
-- Do not process Convention now because it must be analysed
-- as part of Export or Import.
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;
-- Generate:
-- pragma Convention (<Conv>, <E>);
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 begin
A := First (L); -- Obtain all interfacing aspects that apply to the related
while Present (A) loop -- entity.
exit when Nam_In (Chars (Identifier (A)), Name_Export,
Name_Import); Get_Interfacing_Aspects
Next (A); (Iface_Asp => Aspect,
end loop; 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 No (A) then if Present (Expo) and then Present (Imp) then
Error_Msg_N Error_Msg_N
("missing Import/Export for Link/External name", ("incompatible interfacing aspects given for &", E);
Aspect); Error_Msg_Sloc := Sloc (Expo);
Error_Msg_N ("\aspect `Export` #", E);
Error_Msg_Sloc := Sloc (Imp);
Error_Msg_N ("\aspect `Import` #", E);
end if; end if;
end;
end Analyze_Aspect_External_Or_Link_Name; -- 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 -- -- Analyze_Aspect_Implicit_Dereference --
...@@ -1561,8 +1776,7 @@ package body Sem_Ch13 is ...@@ -1561,8 +1776,7 @@ package body Sem_Ch13 is
-- Error if no proper access discriminant -- Error if no proper access discriminant
if No (Disc) then if No (Disc) then
Error_Msg_NE Error_Msg_NE ("not an access discriminant of&", Expr, E);
("not an access discriminant of&", Expr, E);
return; return;
end if; end if;
end if; end if;
...@@ -1578,8 +1792,9 @@ package body Sem_Ch13 is ...@@ -1578,8 +1792,9 @@ package body Sem_Ch13 is
if Present (Parent_Disc) if Present (Parent_Disc)
and then Corresponding_Discriminant (Disc) /= Parent_Disc and then Corresponding_Discriminant (Disc) /= Parent_Disc
then then
Error_Msg_N ("reference discriminant does not match " & Error_Msg_N
"discriminant of parent type", Expr); ("reference discriminant does not match discriminant "
& "of parent type", Expr);
end if; end if;
end if; end if;
end Analyze_Aspect_Implicit_Dereference; end Analyze_Aspect_Implicit_Dereference;
...@@ -2041,100 +2256,15 @@ package body Sem_Ch13 is ...@@ -2041,100 +2256,15 @@ package body Sem_Ch13 is
-- Convention -- Convention
when Aspect_Convention => when Aspect_Convention =>
Analyze_Aspect_Convention;
goto Continue;
-- The aspect may be part of the specification of an import -- External_Name, Link_Name
-- 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.
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 when Aspect_External_Name |
Set_Import_Pragma (E, Aitem); Aspect_Link_Name =>
end if; Analyze_Aspect_External_Link_Name;
end; goto Continue;
-- CPU, Interrupt_Priority, Priority -- CPU, Interrupt_Priority, Priority
...@@ -2937,8 +3067,9 @@ package body Sem_Ch13 is ...@@ -2937,8 +3067,9 @@ package body Sem_Ch13 is
if not (Is_Array_Type (E) if not (Is_Array_Type (E)
and then Is_Scalar_Type (Component_Type (E))) and then Is_Scalar_Type (Component_Type (E)))
then then
Error_Msg_N ("aspect Default_Component_Value can only " Error_Msg_N
& "apply to an array of scalar components", N); ("aspect Default_Component_Value can only apply to an "
& "array of scalar components", N);
end if; end if;
Aitem := Empty; Aitem := Empty;
...@@ -2956,13 +3087,6 @@ package body Sem_Ch13 is ...@@ -2956,13 +3087,6 @@ package body Sem_Ch13 is
Analyze_Aspect_Implicit_Dereference; Analyze_Aspect_Implicit_Dereference;
goto Continue; goto Continue;
-- External_Name, Link_Name
when Aspect_External_Name |
Aspect_Link_Name =>
Analyze_Aspect_External_Or_Link_Name;
goto Continue;
-- Dimension -- Dimension
when Aspect_Dimension => when Aspect_Dimension =>
...@@ -3187,61 +3311,8 @@ package body Sem_Ch13 is ...@@ -3187,61 +3311,8 @@ package body Sem_Ch13 is
goto Continue; goto Continue;
elsif A_Id = Aspect_Import or else A_Id = Aspect_Export then elsif A_Id = Aspect_Export or else A_Id = Aspect_Import then
Analyze_Aspect_Export_Import;
-- 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;
-- Disable_Controlled -- Disable_Controlled
...@@ -3302,11 +3373,20 @@ package body Sem_Ch13 is ...@@ -3302,11 +3373,20 @@ package body Sem_Ch13 is
-- expression is missing other than the above cases. -- expression is missing other than the above cases.
if not Delay_Required or else No (Expr) then if not Delay_Required or else No (Expr) then
-- 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 Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List ( (Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ent), Make_Pragma_Argument_Association (Sloc (Ent),
Expression => Ent)), Expression => Ent)),
Pragma_Name => Chars (Id)); Pragma_Name => Chars (Id));
end if;
Delay_Required := False; Delay_Required := False;
-- In general cases, the corresponding pragma/attribute -- In general cases, the corresponding pragma/attribute
...@@ -3506,7 +3586,7 @@ package body Sem_Ch13 is ...@@ -3506,7 +3586,7 @@ package body Sem_Ch13 is
-- unit, we simply insert the pragma/attribute definition clause -- unit, we simply insert the pragma/attribute definition clause
-- in sequence. -- in sequence.
else elsif Present (Aitem) then
Insert_After (Ins_Node, Aitem); Insert_After (Ins_Node, Aitem);
Ins_Node := Aitem; Ins_Node := Aitem;
end if; end if;
...@@ -7814,6 +7894,133 @@ package body Sem_Ch13 is ...@@ -7814,6 +7894,133 @@ package body Sem_Ch13 is
return; return;
end Build_Discrete_Static_Predicate; 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 => <Conv>/Ada,
-- Entity => <Id>,
-- [External_Name => <EN>,]
-- [Link_Name => <LN>]);
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 -- -- Build_Invariant_Procedure_Declaration --
------------------------------------------- -------------------------------------------
...@@ -11298,6 +11505,106 @@ package body Sem_Ch13 is ...@@ -11298,6 +11505,106 @@ package body Sem_Ch13 is
end if; end if;
end Get_Alignment_Value; 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 -- -- Inherit_Aspects_At_Freeze_Point --
------------------------------------- -------------------------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment