-- --
-- 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- --
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
-- no enclosing package to retrieve. In this case, it is the body of
-- the function that will have to be loaded.
- Level := Must_Inline;
-
- if Level /= Dont_Inline then
- declare
- Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
-
- begin
- -- Ensure that Analyze_Inlined_Bodies will be invoked after
- -- completing the analysis of the current unit.
+ declare
+ Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
- Inline_Processing_Required := True;
+ begin
+ if Pack = E then
+ Set_Is_Called (E);
+ Inlined_Bodies.Increment_Last;
+ Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
- if Pack = E then
+ elsif Ekind (Pack) = E_Package then
+ Set_Is_Called (E);
- -- Library-level inlined function. Add function itself to
- -- list of needed units.
+ if Is_Generic_Instance (Pack) then
+ null;
- Set_Is_Called (E);
+ -- 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.
+
+ 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_Is_Inlined (Pack);
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;
+ 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)))
- then
- Set_Needs_Debug_Info (E, False);
- end if;
- end;
- 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;
----------------------------
-- 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
-- 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
-------------------------------------
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.
----------------------------------
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);
---------------------------------
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;
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
("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
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);
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
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.
-- 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
-- of visibility for the expression analysis. Thus, we just insert
-- the pragma after the node N.
- begin
pragma Assert (Present (L));
-- Loop through aspects
-- 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
-- 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.
+
+ 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 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;
- declare
- A : Node_Id;
+ -- Otherwise Convention appears by itself
- begin
- A := First (L);
- while Present (A) loop
- exit when Nam_In (Chars (Identifier (A)), Name_Export,
- Name_Import);
- Next (A);
- end loop;
+ 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 --
+ ---------------------------------------
- if No (A) then
+ 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 --
-- 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;
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;
-- Convention
- when Aspect_Convention =>
-
- -- 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.
-
- 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);
+ when Aspect_Convention =>
+ Analyze_Aspect_Convention;
+ goto Continue;
- -- Store the generated pragma Import in the related
- -- subprogram.
+ -- External_Name, Link_Name
- 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
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;
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 =>
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
-- 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
-- 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;
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 --
-------------------------------------------
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 --
-------------------------------------
projects / thirdparty / gcc.git / commitdiff
