* [Ada] Reimplementation of interfacing aspects
@ 2016-04-27 11:10 Arnaud Charlet
0 siblings, 0 replies; only message in thread
From: Arnaud Charlet @ 2016-04-27 11:10 UTC (permalink / raw)
To: gcc-patches; +Cc: Hristian Kirtchev
[-- Attachment #1: Type: text/plain, Size: 5429 bytes --]
This patch reimplements the handling of Convention, Export, External_Name,
Import, and Link_Name to generate a proper corresponding pragma depends on
which of these aspects are present.
As a result, an exported or imported subprogram with preconditions and/or
postconditions will not cause a crash when the compiler is building the
interfacing wrapper tasked with verifying the assumptions.
------------
-- Source --
------------
-- sorters.ads
pragma SPARK_Mode (On);
package Sorters is
type Array_Type is array (Positive range <>) of Integer;
function Perm (A : in Array_Type;
B : in Array_Type) return Boolean
with Global => null,
Ghost => True,
Import => True;
procedure Selection_Sort (Values : in out Array_Type)
with Depends => (Values => Values),
Pre => Values'Length >= 1 and then
Values'Last <= Positive'Last,
Post => (for all J in Values'First .. Values'Last - 1 =>
Values (J) <= Values (J + 1)) and then
Perm (Values'Old, Values);
end Sorters;
-- sorters.adb
pragma SPARK_Mode (On);
package body Sorters is
function Perm_Transitive (A, B, C : Array_Type) return Boolean
with Global => null,
Post => (if Perm_Transitive'Result
and then Perm (A, B)
and then Perm (B, C)
then Perm (A, C)),
Ghost => True,
Import => True;
procedure Swap (Values : in out Array_Type;
X : in Positive;
Y : in Positive)
with Depends => (Values => (Values, X, Y)),
Pre => (X in Values'Range and then
Y in Values'Range and then
X /= Y),
Post => Perm (Values'Old, Values) and then
(Values (X) = Values'Old (Y) and then
Values (Y) = Values'Old (X) and then
(for all J in Values'Range =>
(if J /= X and J /= Y then Values (J) = Values'Old (J))))
is
Values_Old : constant Array_Type := Values
with Ghost => True;
Temp : Integer;
begin
Temp := Values (X);
Values (X) := Values (Y);
Values (Y) := Temp;
pragma Assume (Perm (Values_Old, Values));
end Swap;
function Index_Of_Minimum (Unsorted : in Array_Type) return Positive
with Pre => Unsorted'First <= Unsorted'Last,
Post => Index_Of_Minimum'Result in Unsorted'Range and then
(for all J in Unsorted'Range =>
Unsorted (Index_Of_Minimum'Result) <= Unsorted (J))
is
Min : Positive;
begin
Min := Unsorted'First;
for Index in Unsorted'First .. Unsorted'Last loop
pragma Loop_Invariant
(Min in Unsorted'Range and then
(for all J in Unsorted'First .. Index - 1 =>
Unsorted (Min) <= Unsorted (J)));
if Unsorted (Index) < Unsorted (Min) then
Min := Index;
end if;
end loop;
return Min;
end Index_Of_Minimum;
procedure Selection_Sort (Values : in out Array_Type) is
Values_Last : Array_Type (Values'Range)
with Ghost => True;
Smallest : Positive;
begin
pragma Assume (Perm (Values, Values));
for Current in Values'First .. Values'Last - 1 loop
Values_Last := Values;
Smallest := Index_Of_Minimum (Values (Current .. Values'Last));
if Smallest /= Current then
Swap (Values => Values,
X => Current,
Y => Smallest);
end if;
pragma Assume
(Perm_Transitive (Values'Loop_Entry, Values_Last, Values));
pragma Loop_Invariant (Perm (Values'Loop_Entry, Values));
pragma Loop_Invariant
((for all J in Current .. Values'Last =>
Values (Current) <= Values (J)));
pragma Loop_Invariant
((for all J in Values'First .. Current =>
Values (J) <= Values (J + 1)));
end loop;
end Selection_Sort;
end Sorters;
-----------------
-- Compilation --
-----------------
$ gcc -c -gnata sorters.adb
Tested on x86_64-pc-linux-gnu, committed on trunk
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.
[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 40883 bytes --]
Index: freeze.adb
===================================================================
--- freeze.adb (revision 235481)
+++ freeze.adb (working copy)
@@ -4676,15 +4676,66 @@
-- 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);
+ Bod : Node_Id;
+ Forml : Entity_Id;
+ Parms : List_Id;
+ Prag : Node_Id;
Spec : Node_Id;
- Parms : List_Id;
Stmt : Node_Id;
- Iprag : Node_Id;
- Bod : Node_Id;
- Forml : Entity_Id;
+ -- Start of processing for Wrap_Imported_Subprogram
+
begin
-- Nothing to do if not imported
@@ -4706,18 +4757,14 @@
-- 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.
+ Prag := Copy_Import_Pragma;
- Iprag := Copy_Separate_Tree (Import_Pragma (E));
- Set_From_Aspect_Specification (Iprag, False);
-
-- 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 @@
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
Index: aspects.ads
===================================================================
--- aspects.ads (revision 235481)
+++ aspects.ads (working copy)
@@ -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 @@
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 @@
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,
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 235481)
+++ sem_ch13.adb (working copy)
@@ -101,6 +101,13 @@
-- 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 @@
-- 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 @@
-------------------------------------
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 @@
----------------------------------
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 @@
---------------------------------
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 @@
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 @@
("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,13 +1129,12 @@
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)))),
+ Expression => New_Occurrence_Of (Ent, Sloc (Ident)))));
- Pragma_Identifier =>
- Make_Identifier (Sloc (Ident), Chars (Ident)));
-
Set_From_Aspect_Specification (Prag, True);
Set_Corresponding_Aspect (Prag, ASN);
Set_Aspect_Rep_Item (ASN, Prag);
@@ -1116,6 +1143,12 @@
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,8 +1175,26 @@
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 @@
-- 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 @@
-- 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,9 +1529,15 @@
-- 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,36 +1553,194 @@
-- 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_External_Or_Link_Name is
+ 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;
+
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
+ 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
+ -- 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
- ("missing Import/Export for Link/External name",
- Aspect);
+ ("aspect `External_Name` requires aspect `Import` or "
+ & "`Export`", Aspect);
end if;
- end;
- end Analyze_Aspect_External_Or_Link_Name;
+ -- 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 @@
-- 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 @@
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,102 +2255,17 @@
-- 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));
+ when Aspect_External_Name |
+ Aspect_Link_Name =>
+ Analyze_Aspect_External_Link_Name;
+ goto Continue;
- 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;
-
-- CPU, Interrupt_Priority, Priority
-- These three aspects can be specified for a subprogram spec
@@ -2937,8 +3067,9 @@
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 @@
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,62 +3311,9 @@
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
elsif A_Id = Aspect_Disable_Controlled then
@@ -3302,11 +3373,20 @@
-- 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 @@
-- 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 @@
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 => <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 --
-------------------------------------------
@@ -11298,6 +11505,106 @@
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 --
-------------------------------------
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2016-04-27 11:10 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2016-04-27 11:10 [Ada] Reimplementation of interfacing aspects Arnaud Charlet
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).