-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
+with Elists; use Elists;
with Errout; use Errout;
+with Exp_Ch7; use Exp_Ch7;
with Exp_Dist; use Exp_Dist;
with Lib; use Lib;
with Lib.Writ; use Lib.Writ;
with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
+with Par_SCO; use Par_SCO;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
procedure Ada_2005_Pragma;
-- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
-- Ada 95 mode, these are implementation defined pragmas, so should be
- -- caught by the No_Implementation_Pragmas restriction
+ -- caught by the No_Implementation_Pragmas restriction.
+
+ procedure Ada_2012_Pragma;
+ -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
+ -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
+ -- should be caught by the No_Implementation_Pragmas restriction.
procedure Check_Ada_83_Warning;
-- Issues a warning message for the current pragma if operating in Ada
procedure Check_Arg_Is_Static_Expression
(Arg : Node_Id;
- Typ : Entity_Id);
+ Typ : Entity_Id := Empty);
-- Check the specified argument Arg to make sure that it is a static
-- expression of the given type (i.e. it will be analyzed and resolved
-- using this type, which can be any valid argument to Resolve, e.g.
- -- Any_Integer is OK). If not, given error and raise Pragma_Exit.
-
- procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
- -- Check the specified argument Arg to make sure that it is a string
- -- literal. If not give error and raise Pragma_Exit
+ -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
+ -- Typ is left Empty, then any static expression is allowed.
procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
-- Check the specified argument Arg to make sure that it is a valid task
procedure Check_At_Most_N_Arguments (N : Nat);
-- Check there are no more than N arguments present
- procedure Check_Component (Comp : Node_Id);
- -- Examine Unchecked_Union component for correct use of per-object
+ procedure Check_Component
+ (Comp : Node_Id;
+ UU_Typ : Entity_Id;
+ In_Variant_Part : Boolean := False);
+ -- Examine an Unchecked_Union component for correct use of per-object
-- constrained subtypes, and for restrictions on finalizable components.
+ -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
+ -- should be set when Comp comes from a record variant.
procedure Check_Duplicated_Export_Name (Nam : Node_Id);
-- Nam is an N_String_Literal node containing the external name set by
-- and to library level instantiations), and they are simply ignored,
-- which is implemented by rewriting them as null statements.
- procedure Check_Variant (Variant : Node_Id);
- -- Check Unchecked_Union variant for lack of nested variants and
- -- presence of at least one component.
+ procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
+ -- Check an Unchecked_Union variant for lack of nested variants and
+ -- presence of at least one component. UU_Typ is the related Unchecked_
+ -- Union type.
procedure Error_Pragma (Msg : String);
pragma No_Return (Error_Pragma);
procedure Process_Compile_Time_Warning_Or_Error;
-- Common processing for Compile_Time_Error and Compile_Time_Warning
- procedure Process_Convention (C : out Convention_Id; E : out Entity_Id);
+ procedure Process_Convention
+ (C : out Convention_Id;
+ Ent : out Entity_Id);
-- Common processing for Convention, Interface, Import and Export.
-- Checks first two arguments of pragma, and sets the appropriate
-- convention value in the specified entity or entities. On return
- -- C is the convention, E is the referenced entity.
+ -- C is the convention, Ent is the referenced entity.
procedure Process_Extended_Import_Export_Exception_Pragma
(Arg_Internal : Node_Id;
end if;
end Ada_2005_Pragma;
+ ---------------------
+ -- Ada_2012_Pragma --
+ ---------------------
+
+ procedure Ada_2012_Pragma is
+ begin
+ if Ada_Version <= Ada_05 then
+ Check_Restriction (No_Implementation_Pragmas, N);
+ end if;
+ end Ada_2012_Pragma;
+
--------------------------
-- Check_Ada_83_Warning --
--------------------------
procedure Check_Arg_Is_Static_Expression
(Arg : Node_Id;
- Typ : Entity_Id)
+ Typ : Entity_Id := Empty)
is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
begin
- Analyze_And_Resolve (Argx, Typ);
+ if Present (Typ) then
+ Analyze_And_Resolve (Argx, Typ);
+ else
+ Analyze_And_Resolve (Argx);
+ end if;
if Is_OK_Static_Expression (Argx) then
return;
end if;
end Check_Arg_Is_Static_Expression;
- ---------------------------------
- -- Check_Arg_Is_String_Literal --
- ---------------------------------
-
- procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
- Argx : constant Node_Id := Get_Pragma_Arg (Arg);
- begin
- if Nkind (Argx) /= N_String_Literal then
- Error_Pragma_Arg
- ("argument for pragma% must be string literal", Argx);
- end if;
- end Check_Arg_Is_String_Literal;
-
------------------------------------------
-- Check_Arg_Is_Task_Dispatching_Policy --
------------------------------------------
-- Check_Component --
---------------------
- procedure Check_Component (Comp : Node_Id) is
- begin
- if Nkind (Comp) = N_Component_Declaration then
- declare
- Sindic : constant Node_Id :=
- Subtype_Indication (Component_Definition (Comp));
- Typ : constant Entity_Id :=
- Etype (Defining_Identifier (Comp));
- begin
- if Nkind (Sindic) = N_Subtype_Indication then
+ procedure Check_Component
+ (Comp : Node_Id;
+ UU_Typ : Entity_Id;
+ In_Variant_Part : Boolean := False)
+ is
+ Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
+ Sindic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (Comp));
+ Typ : constant Entity_Id := Etype (Comp_Id);
- -- Ada 2005 (AI-216): If a component subtype is subject to
- -- a per-object constraint, then the component type shall
- -- be an Unchecked_Union.
+ function Inside_Generic_Body (Id : Entity_Id) return Boolean;
+ -- Determine whether entity Id appears inside a generic body
- if Has_Per_Object_Constraint (Defining_Identifier (Comp))
- and then
- not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
- then
- Error_Msg_N ("component subtype subject to per-object" &
- " constraint must be an Unchecked_Union", Comp);
- end if;
- end if;
+ -------------------------
+ -- Inside_Generic_Body --
+ -------------------------
- if Is_Controlled (Typ) then
- Error_Msg_N
- ("component of unchecked union cannot be controlled", Comp);
+ function Inside_Generic_Body (Id : Entity_Id) return Boolean is
+ S : Entity_Id := Id;
- elsif Has_Task (Typ) then
- Error_Msg_N
- ("component of unchecked union cannot have tasks", Comp);
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Ekind (S) = E_Generic_Package
+ and then In_Package_Body (S)
+ then
+ return True;
end if;
- end;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end Inside_Generic_Body;
+
+ -- Start of processing for Check_Component
+
+ begin
+ -- Ada 2005 (AI-216): If a component subtype is subject to a per-
+ -- object constraint, then the component type shall be an Unchecked_
+ -- Union.
+
+ if Nkind (Sindic) = N_Subtype_Indication
+ and then Has_Per_Object_Constraint (Comp_Id)
+ and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
+ then
+ Error_Msg_N
+ ("component subtype subject to per-object constraint " &
+ "must be an Unchecked_Union", Comp);
+
+ -- Ada 2012 (AI05-0026): For an unchecked union type declared within
+ -- the body of a generic unit, or within the body of any of its
+ -- descendant library units, no part of the type of a component
+ -- declared in a variant_part of the unchecked union type shall be of
+ -- a formal private type or formal private extension declared within
+ -- the formal part of the generic unit.
+
+ elsif Ada_Version >= Ada_2012
+ and then Inside_Generic_Body (UU_Typ)
+ and then In_Variant_Part
+ and then Is_Private_Type (Typ)
+ and then Is_Generic_Type (Typ)
+ then
+ Error_Msg_N
+ ("component of Unchecked_Union cannot be of generic type", Comp);
+
+ elsif Needs_Finalization (Typ) then
+ Error_Msg_N
+ ("component of Unchecked_Union cannot be controlled", Comp);
+
+ elsif Has_Task (Typ) then
+ Error_Msg_N
+ ("component of Unchecked_Union cannot have tasks", Comp);
end if;
end Check_Component;
Pragma_Misplaced;
end if;
- -- Record whether pragma is enabled
+ -- Record if pragma is enabled
- Set_PPC_Enabled (N, Check_Enabled (Pname));
+ if Check_Enabled (Pname) then
+ Set_Pragma_Enabled (N);
+ Set_SCO_Pragma_Enabled (Loc);
+ end if;
-- If we are within an inlined body, the legality of the pragma
-- has been checked already.
-- Check_Variant --
-------------------
- procedure Check_Variant (Variant : Node_Id) is
+ procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
Clist : constant Node_Id := Component_List (Variant);
Comp : Node_Id;
Comp := First (Component_Items (Clist));
while Present (Comp) loop
- Check_Component (Comp);
+ Check_Component (Comp, UU_Typ, In_Variant_Part => True);
Next (Comp);
end loop;
end Check_Variant;
Proc := Entity (Name);
if Ekind (Proc) /= E_Procedure
- or else Present (First_Formal (Proc)) then
+ or else Present (First_Formal (Proc))
+ then
Error_Pragma_Arg
("argument of pragma% must be parameterless procedure", Arg);
end if;
------------------------
procedure Process_Convention
- (C : out Convention_Id;
- E : out Entity_Id)
+ (C : out Convention_Id;
+ Ent : out Entity_Id)
is
Id : Node_Id;
+ E : Entity_Id;
E1 : Entity_Id;
Cname : Name_Id;
Comp_Unit : Unit_Number_Type;
+ procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
+ -- Called if we have more than one Export/Import/Convention pragma.
+ -- This is generally illegal, but we have a special case of allowing
+ -- Import and Interface to coexist if they specify the convention in
+ -- a consistent manner. We are allowed to do this, since Interface is
+ -- an implementation defined pragma, and we choose to do it since we
+ -- know Rational allows this combination. S is the entity id of the
+ -- subprogram in question. This procedure also sets the special flag
+ -- Import_Interface_Present in both pragmas in the case where we do
+ -- have matching Import and Interface pragmas.
+
procedure Set_Convention_From_Pragma (E : Entity_Id);
-- Set convention in entity E, and also flag that the entity has a
-- convention pragma. If entity is for a private or incomplete type,
-- also set convention and flag on underlying type. This procedure
-- also deals with the special case of C_Pass_By_Copy convention.
+ -------------------------------
+ -- Diagnose_Multiple_Pragmas --
+ -------------------------------
+
+ procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
+ Pdec : constant Node_Id := Declaration_Node (S);
+ Decl : Node_Id;
+ Err : Boolean;
+
+ function Same_Convention (Decl : Node_Id) return Boolean;
+ -- Decl is a pragma node. This function returns True if this
+ -- pragma has a first argument that is an identifier with a
+ -- Chars field corresponding to the Convention_Id C.
+
+ function Same_Name (Decl : Node_Id) return Boolean;
+ -- Decl is a pragma node. This function returns True if this
+ -- pragma has a second argument that is an identifier with a
+ -- Chars field that matches the Chars of the current subprogram.
+
+ ---------------------
+ -- Same_Convention --
+ ---------------------
+
+ function Same_Convention (Decl : Node_Id) return Boolean is
+ Arg1 : constant Node_Id :=
+ First (Pragma_Argument_Associations (Decl));
+
+ begin
+ if Present (Arg1) then
+ declare
+ Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
+ begin
+ if Nkind (Arg) = N_Identifier
+ and then Is_Convention_Name (Chars (Arg))
+ and then Get_Convention_Id (Chars (Arg)) = C
+ then
+ return True;
+ end if;
+ end;
+ end if;
+
+ return False;
+ end Same_Convention;
+
+ ---------------
+ -- Same_Name --
+ ---------------
+
+ function Same_Name (Decl : Node_Id) return Boolean is
+ Arg1 : constant Node_Id :=
+ First (Pragma_Argument_Associations (Decl));
+ Arg2 : Node_Id;
+
+ begin
+ if No (Arg1) then
+ return False;
+ end if;
+
+ Arg2 := Next (Arg1);
+
+ if No (Arg2) then
+ return False;
+ end if;
+
+ declare
+ Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
+ begin
+ if Nkind (Arg) = N_Identifier
+ and then Chars (Arg) = Chars (S)
+ then
+ return True;
+ end if;
+ end;
+
+ return False;
+ end Same_Name;
+
+ -- Start of processing for Diagnose_Multiple_Pragmas
+
+ begin
+ Err := True;
+
+ -- Definitely give message if we have Convention/Export here
+
+ if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
+ null;
+
+ -- If we have an Import or Export, scan back from pragma to
+ -- find any previous pragma applying to the same procedure.
+ -- The scan will be terminated by the start of the list, or
+ -- hitting the subprogram declaration. This won't allow one
+ -- pragma to appear in the public part and one in the private
+ -- part, but that seems very unlikely in practice.
+
+ else
+ Decl := Prev (N);
+ while Present (Decl) and then Decl /= Pdec loop
+
+ -- Look for pragma with same name as us
+
+ if Nkind (Decl) = N_Pragma
+ and then Same_Name (Decl)
+ then
+ -- Give error if same as our pragma or Export/Convention
+
+ if Pragma_Name (Decl) = Name_Export
+ or else
+ Pragma_Name (Decl) = Name_Convention
+ or else
+ Pragma_Name (Decl) = Pragma_Name (N)
+ then
+ exit;
+
+ -- Case of Import/Interface or the other way round
+
+ elsif Pragma_Name (Decl) = Name_Interface
+ or else
+ Pragma_Name (Decl) = Name_Import
+ then
+ -- Here we know that we have Import and Interface. It
+ -- doesn't matter which way round they are. See if
+ -- they specify the same convention. If so, all OK,
+ -- and set special flags to stop other messages
+
+ if Same_Convention (Decl) then
+ Set_Import_Interface_Present (N);
+ Set_Import_Interface_Present (Decl);
+ Err := False;
+
+ -- If different conventions, special message
+
+ else
+ Error_Msg_Sloc := Sloc (Decl);
+ Error_Pragma_Arg
+ ("convention differs from that given#", Arg1);
+ return;
+ end if;
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end if;
+
+ -- Give message if needed if we fall through those tests
+
+ if Err then
+ Error_Pragma_Arg
+ ("at most one Convention/Export/Import pragma is allowed",
+ Arg2);
+ end if;
+ end Diagnose_Multiple_Pragmas;
+
--------------------------------
-- Set_Convention_From_Pragma --
--------------------------------
E := Entity (Id);
+ -- Set entity to return
+
+ Ent := E;
+
-- Go to renamed subprogram if present, since convention applies to
-- the actual renamed entity, not to the renaming entity. If the
-- subprogram is inherited, go to parent subprogram.
and then Scope (E) = Scope (Alias (E))
then
E := Alias (E);
+
+ -- Return the parent subprogram the entity was inherited from
+
+ Ent := E;
end if;
end if;
-- Check that we are not applying this to a named constant
- if Ekind (E) = E_Named_Integer
- or else
- Ekind (E) = E_Named_Real
- then
+ if Ekind_In (E, E_Named_Integer, E_Named_Real) then
Error_Msg_Name_1 := Pname;
Error_Msg_N
("cannot apply pragma% to named constant!",
end if;
if Has_Convention_Pragma (E) then
- Error_Pragma_Arg
- ("at most one Convention/Export/Import pragma is allowed", Arg2);
+ Diagnose_Multiple_Pragmas (E);
elsif Convention (E) = Convention_Protected
or else Ekind (Scope (E)) = E_Protected_Type
and then Ekind (E) /= E_Variable
and then not
(Is_Access_Type (E)
- and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
then
Error_Pragma_Arg
("second argument of pragma% must be subprogram (type)",
Set_Convention_From_Pragma (E);
if Is_Type (E) then
-
Check_First_Subtype (Arg2);
Set_Convention_From_Pragma (Base_Type (E));
Generate_Reference (E, Id, 'b');
end if;
- E1 := E;
+ -- Loop through the homonyms of the pragma argument's entity
+
+ E1 := Ent;
loop
E1 := Homonym (E1);
exit when No (E1) or else Scope (E1) /= Current_Scope;
Set_Convention_From_Pragma (E1);
if Prag_Id = Pragma_Import then
- Generate_Reference (E, Id, 'b');
+ Generate_Reference (E1, Id, 'b');
end if;
end if;
end loop;
Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
Def_Id := Entity (Arg_Internal);
- if Ekind (Def_Id) /= E_Constant
- and then Ekind (Def_Id) /= E_Variable
- then
+ if not Ekind_In (Def_Id, E_Constant, E_Variable) then
Error_Pragma_Arg
("pragma% must designate an object", Arg_Internal);
end if;
end if;
if Warn_On_Export_Import and then Is_Exported (Def_Id) then
- Error_Msg_N
- ("?duplicate Export_Object pragma", N);
+ Error_Msg_N ("?duplicate Export_Object pragma", N);
else
Set_Exported (Def_Id, Arg_Internal);
end if;
("?duplicate Import_Object pragma", N);
-- Check for explicit initialization present. Note that an
- -- initialization that generated by the code generator, e.g.
- -- for an access type, does not count here.
+ -- initialization generated by the code generator, e.g. for an
+ -- access type, does not count here.
elsif Present (Expression (Parent (Def_Id)))
and then
Formal := First_Formal (Ent);
if No (Formal) then
- Error_Pragma
- ("at least one parameter required for pragma%");
+ Error_Pragma ("at least one parameter required for pragma%");
elsif Ekind (Formal) /= E_Out_Parameter then
- Error_Pragma
- ("first parameter must have mode out for pragma%");
+ Error_Pragma ("first parameter must have mode out for pragma%");
else
Set_Is_Valued_Procedure (Ent);
Kill_Size_Check_Code (Def_Id);
Note_Possible_Modification (Expression (Arg2), Sure => False);
- if Ekind (Def_Id) = E_Variable
- or else
- Ekind (Def_Id) = E_Constant
- then
+ if Ekind_In (Def_Id, E_Variable, E_Constant) then
+
-- We do not permit Import to apply to a renaming declaration
if Present (Renamed_Object (Def_Id)) then
else
Set_Imported (Def_Id);
+ -- Reject an Import applied to an abstract subprogram
+
+ if Is_Subprogram (Def_Id)
+ and then Is_Abstract_Subprogram (Def_Id)
+ then
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Msg_NE
+ ("cannot import abstract subprogram& declared#",
+ Arg2, Def_Id);
+ end if;
+
-- Special processing for Convention_Intrinsic
if C = Convention_Intrinsic then
elsif Is_Record_Type (Def_Id)
and then C = Convention_CPP
then
- if not Is_Tagged_Type (Def_Id) then
- Error_Msg_Sloc := Sloc (Def_Id);
- Error_Pragma_Arg ("imported 'C'P'P type must be tagged", Arg2);
-
- else
- -- Types treated as CPP classes are treated as limited, but we
- -- don't require them to be declared this way. A warning is
- -- issued to encourage the user to declare them as limited.
- -- This is not an error, for compatibility reasons, because
- -- these types have been supported this way for some time.
+ -- Types treated as CPP classes are treated as limited, but we
+ -- don't require them to be declared this way. A warning is
+ -- issued to encourage the user to declare them as limited.
+ -- This is not an error, for compatibility reasons, because
+ -- these types have been supported this way for some time.
- if not Is_Limited_Type (Def_Id) then
- Error_Msg_N
- ("imported 'C'P'P type should be " &
- "explicitly declared limited?",
- Get_Pragma_Arg (Arg2));
- Error_Msg_N
- ("\type will be considered limited",
- Get_Pragma_Arg (Arg2));
- end if;
+ if not Is_Limited_Type (Def_Id) then
+ Error_Msg_N
+ ("imported 'C'P'P type should be " &
+ "explicitly declared limited?",
+ Get_Pragma_Arg (Arg2));
+ Error_Msg_N
+ ("\type will be considered limited",
+ Get_Pragma_Arg (Arg2));
+ end if;
- Set_Is_CPP_Class (Def_Id);
- Set_Is_Limited_Record (Def_Id);
+ Set_Is_CPP_Class (Def_Id);
+ Set_Is_Limited_Record (Def_Id);
- -- Imported CPP types must not have discriminants (because C++
- -- classes do not have discriminants).
+ -- Imported CPP types must not have discriminants (because C++
+ -- classes do not have discriminants).
- if Has_Discriminants (Def_Id) then
- Error_Msg_N
- ("imported 'C'P'P type cannot have discriminants",
- First (Discriminant_Specifications
- (Declaration_Node (Def_Id))));
- end if;
+ if Has_Discriminants (Def_Id) then
+ Error_Msg_N
+ ("imported 'C'P'P type cannot have discriminants",
+ First (Discriminant_Specifications
+ (Declaration_Node (Def_Id))));
+ end if;
- -- Components of imported CPP types must not have default
- -- expressions because the constructor (if any) is in the
- -- C++ side.
+ -- Components of imported CPP types must not have default
+ -- expressions because the constructor (if any) is on the
+ -- C++ side.
- declare
- Tdef : constant Node_Id :=
- Type_Definition (Declaration_Node (Def_Id));
- Clist : Node_Id;
- Comp : Node_Id;
+ declare
+ Tdef : constant Node_Id :=
+ Type_Definition (Declaration_Node (Def_Id));
+ Clist : Node_Id;
+ Comp : Node_Id;
- begin
- if Nkind (Tdef) = N_Record_Definition then
- Clist := Component_List (Tdef);
+ begin
+ if Nkind (Tdef) = N_Record_Definition then
+ Clist := Component_List (Tdef);
- else
- pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
- Clist := Component_List (Record_Extension_Part (Tdef));
- end if;
+ else
+ pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
+ Clist := Component_List (Record_Extension_Part (Tdef));
+ end if;
- if Present (Clist) then
- Comp := First (Component_Items (Clist));
- while Present (Comp) loop
- if Present (Expression (Comp)) then
- Error_Msg_N
- ("component of imported 'C'P'P type cannot have" &
- " default expression", Expression (Comp));
- end if;
+ if Present (Clist) then
+ Comp := First (Component_Items (Clist));
+ while Present (Comp) loop
+ if Present (Expression (Comp)) then
+ Error_Msg_N
+ ("component of imported 'C'P'P type cannot have" &
+ " default expression", Expression (Comp));
+ end if;
- Next (Comp);
- end loop;
- end if;
- end;
- end if;
+ Next (Comp);
+ end loop;
+ end if;
+ end;
else
Error_Pragma_Arg
-- entity (if declared in the same unit) is inlined.
if Is_Subprogram (Subp) then
- while Present (Alias (Inner_Subp)) loop
- Inner_Subp := Alias (Inner_Subp);
- end loop;
+ Inner_Subp := Ultimate_Alias (Inner_Subp);
if In_Same_Source_Unit (Subp, Inner_Subp) then
Set_Inline_Flags (Inner_Subp);
Set_Encoded_Interface_Name
(Get_Base_Subprogram (Subprogram_Def), Link_Nam);
- Check_Duplicated_Export_Name (Link_Nam);
+
+ -- We allow duplicated export names in CIL, as they are always
+ -- enclosed in a namespace that differentiates them, and overloaded
+ -- entities are supported by the VM.
+
+ if Convention (Subprogram_Def) /= Convention_CIL then
+ Check_Duplicated_Export_Name (Link_Nam);
+ end if;
end Process_Interface_Name;
-----------------------------------------
Restriction_Warnings (R_Id) := False;
end if;
+ -- Check for obsolescent restrictions in Ada 2005 mode
+
+ if not Warn
+ and then Ada_Version >= Ada_2005
+ and then (R_Id = No_Asynchronous_Control
+ or else
+ R_Id = No_Unchecked_Deallocation
+ or else
+ R_Id = No_Unchecked_Conversion)
+ then
+ Check_Restriction (No_Obsolescent_Features, N);
+ end if;
+
-- A very special case that must be processed here: pragma
-- Restrictions (No_Exceptions) turns off all run-time
-- checking. This is a bit dubious in terms of the formal
-- a specified entity (given as the second argument of the pragma)
else
+ -- This is obsolescent in Ada 2005 mode
+
+ if Ada_Version >= Ada_2005 then
+ Check_Restriction (No_Obsolescent_Features, Arg2);
+ end if;
+
Check_Optional_Identifier (Arg2, Name_On);
E_Id := Expression (Arg2);
Analyze (E_Id);
end if;
if Warn_On_Export_Import and then Is_Type (E) then
- Error_Msg_NE
- ("exporting a type has no effect?", Arg, E);
+ Error_Msg_NE ("exporting a type has no effect?", Arg, E);
end if;
if Warn_On_Export_Import and Inside_A_Generic then
-- Error message if already imported or exported
if Is_Exported (E) or else Is_Imported (E) then
+
+ -- Error if being set Exported twice
+
if Is_Exported (E) then
Error_Msg_NE ("entity& was previously exported", N, E);
+
+ -- OK if Import/Interface case
+
+ elsif Import_Interface_Present (N) then
+ goto OK;
+
+ -- Error if being set Imported twice
+
else
Error_Msg_NE ("entity& was previously imported", N, E);
end if;
Set_Is_Statically_Allocated (E);
end if;
end if;
+
+ <<OK>> null;
end Set_Imported;
-------------------------
-- form created by the parser.
procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
- Class : Node_Id;
- Param : Node_Id;
+ Class : Node_Id;
+ Param : Node_Id;
Mech_Name_Id : Name_Id;
procedure Bad_Class;
elsif Chars (Mech_Name) = Name_Descriptor then
Check_VMS (Mech_Name);
- Set_Mechanism (Ent, By_Descriptor);
+
+ -- Descriptor => Short_Descriptor if pragma was given
+
+ if Short_Descriptors then
+ Set_Mechanism (Ent, By_Short_Descriptor);
+ else
+ Set_Mechanism (Ent, By_Descriptor);
+ end if;
+
return;
elsif Chars (Mech_Name) = Name_Short_Descriptor then
-- Note: this form is parsed as an indexed component
elsif Nkind (Mech_Name) = N_Indexed_Component then
-
Class := First (Expressions (Mech_Name));
if Nkind (Prefix (Mech_Name)) /= N_Identifier
Bad_Mechanism;
else
Mech_Name_Id := Chars (Prefix (Mech_Name));
+
+ -- Change Descriptor => Short_Descriptor if pragma was given
+
+ if Mech_Name_Id = Name_Descriptor
+ and then Short_Descriptors
+ then
+ Mech_Name_Id := Name_Short_Descriptor;
+ end if;
end if;
-- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
-- Note: this form is parsed as a function call
elsif Nkind (Mech_Name) = N_Function_Call then
-
Param := First (Parameter_Associations (Mech_Name));
if Nkind (Name (Mech_Name)) /= N_Identifier
Bad_Class;
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_UBS
+ and then Chars (Class) = Name_UBS
then
Set_Mechanism (Ent, By_Descriptor_UBS);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_UBSB
+ and then Chars (Class) = Name_UBSB
then
Set_Mechanism (Ent, By_Descriptor_UBSB);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_UBA
+ and then Chars (Class) = Name_UBA
then
Set_Mechanism (Ent, By_Descriptor_UBA);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_S
+ and then Chars (Class) = Name_S
then
Set_Mechanism (Ent, By_Descriptor_S);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_SB
+ and then Chars (Class) = Name_SB
then
Set_Mechanism (Ent, By_Descriptor_SB);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_A
+ and then Chars (Class) = Name_A
then
Set_Mechanism (Ent, By_Descriptor_A);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_NCA
+ and then Chars (Class) = Name_NCA
then
Set_Mechanism (Ent, By_Descriptor_NCA);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_UBS
+ and then Chars (Class) = Name_UBS
then
Set_Mechanism (Ent, By_Short_Descriptor_UBS);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_UBSB
+ and then Chars (Class) = Name_UBSB
then
Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_UBA
+ and then Chars (Class) = Name_UBA
then
Set_Mechanism (Ent, By_Short_Descriptor_UBA);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_S
+ and then Chars (Class) = Name_S
then
Set_Mechanism (Ent, By_Short_Descriptor_S);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_SB
+ and then Chars (Class) = Name_SB
then
Set_Mechanism (Ent, By_Short_Descriptor_SB);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_A
+ and then Chars (Class) = Name_A
then
Set_Mechanism (Ent, By_Short_Descriptor_A);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_NCA
+ and then Chars (Class) = Name_NCA
then
Set_Mechanism (Ent, By_Short_Descriptor_NCA);
-- said this was a configuration pragma, but we did not check and
-- are hesitant to add the check now.
- -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
- -- or Ada 95, so we must check if we are in Ada 2005 mode.
+ -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
+ -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
+ -- or Ada 2012 mode.
if Ada_Version >= Ada_05 then
Check_Valid_Configuration_Pragma;
-- pragma Ada_2005;
-- pragma Ada_2005 (LOCAL_NAME):
- -- Note: these pragma also have some specific processing in Par.Prag
+ -- Note: these pragmas also have some specific processing in Par.Prag
-- because we want to set the Ada 2005 version mode during parsing.
when Pragma_Ada_05 | Pragma_Ada_2005 => declare
end if;
end;
+ ---------------------
+ -- Ada_12/Ada_2012 --
+ ---------------------
+
+ -- pragma Ada_12;
+ -- pragma Ada_12 (LOCAL_NAME);
+
+ -- pragma Ada_2012;
+ -- pragma Ada_2012 (LOCAL_NAME):
+
+ -- Note: these pragmas also have some specific processing in Par.Prag
+ -- because we want to set the Ada 2012 version mode during parsing.
+
+ when Pragma_Ada_12 | Pragma_Ada_2012 => declare
+ E_Id : Node_Id;
+
+ begin
+ GNAT_Pragma;
+
+ if Arg_Count = 1 then
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ Set_Is_Ada_2012_Only (Entity (E_Id));
+
+ else
+ Check_Arg_Count (0);
+
+ -- For Ada_2012 we unconditionally enforce the documented
+ -- configuration pragma placement, since we do not want to
+ -- tolerate mixed modes in a unit involving Ada 2012. That
+ -- would cause real difficulties for those cases where there
+ -- are incompatibilities between Ada 95 and Ada 2012. We could
+ -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
+
+ Check_Valid_Configuration_Pragma;
+
+ -- Now set Ada 2012 mode
+
+ Ada_Version := Ada_12;
+ Ada_Version_Explicit := Ada_12;
+ end if;
+ end;
+
----------------------
-- All_Calls_Remote --
----------------------
-- Annotate --
--------------
- -- pragma Annotate (IDENTIFIER {, ARG});
+ -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
-- ARG ::= NAME | EXPRESSION
+ -- The first two arguments are by convention intended to refer to an
+ -- external tool and a tool-specific function. These arguments are
+ -- not analyzed.
+
when Pragma_Annotate => Annotate : begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Check_Arg_Is_Identifier (Arg1);
+ Check_No_Identifiers;
+ Store_Note (N);
declare
Arg : Node_Id;
Exp : Node_Id;
begin
- Arg := Arg2;
- while Present (Arg) loop
- Exp := Expression (Arg);
- Analyze (Exp);
+ -- Second unanalyzed parameter is optional
- if Is_Entity_Name (Exp) then
- null;
+ if No (Arg2) then
+ null;
+ else
+ Arg := Next (Arg2);
+ while Present (Arg) loop
+ Exp := Expression (Arg);
+ Analyze (Exp);
- elsif Nkind (Exp) = N_String_Literal then
- Resolve (Exp, Standard_String);
+ if Is_Entity_Name (Exp) then
+ null;
- elsif Is_Overloaded (Exp) then
- Error_Pragma_Arg ("ambiguous argument for pragma%", Exp);
+ -- For string literals, we assume Standard_String as the
+ -- type, unless the string contains wide or wide_wide
+ -- characters.
- else
- Resolve (Exp);
- end if;
+ elsif Nkind (Exp) = N_String_Literal then
+ if Has_Wide_Wide_Character (Exp) then
+ Resolve (Exp, Standard_Wide_Wide_String);
+ elsif Has_Wide_Character (Exp) then
+ Resolve (Exp, Standard_Wide_String);
+ else
+ Resolve (Exp, Standard_String);
+ end if;
- Next (Arg);
- end loop;
+ elsif Is_Overloaded (Exp) then
+ Error_Pragma_Arg
+ ("ambiguous argument for pragma%", Exp);
+
+ else
+ Resolve (Exp);
+ end if;
+
+ Next (Arg);
+ end loop;
+ end if;
end;
end Annotate;
if Prag_Id = Pragma_Atomic_Components then
Set_Has_Atomic_Components (E);
-
- if Is_Packed (E) then
- Set_Is_Packed (E, False);
-
- Error_Pragma_Arg
- ("?Pack canceled, cannot pack atomic components",
- Arg1);
- end if;
end if;
else
end if;
Check_Arg_Is_Identifier (Arg1);
+
+ -- Indicate if pragma is enabled. The Original_Node reference here
+ -- is to deal with pragma Assert rewritten as a Check pragma.
+
Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
+ if Check_On then
+ Set_Pragma_Enabled (N);
+ Set_Pragma_Enabled (Original_Node (N));
+ Set_SCO_Pragma_Enabled (Loc);
+ end if;
+
-- If expansion is active and the check is not enabled then we
-- rewrite the Check as:
-- [, [Link_Name =>] static_string_EXPRESSION ]);
when Pragma_CPP_Constructor => CPP_Constructor : declare
- Id : Entity_Id;
- Def_Id : Entity_Id;
+ Elmt : Elmt_Id;
+ Id : Entity_Id;
+ Def_Id : Entity_Id;
+ Tag_Typ : Entity_Id;
begin
GNAT_Pragma;
Def_Id := Entity (Id);
+ -- Check if already defined as constructor
+
+ if Is_Constructor (Def_Id) then
+ Error_Msg_N
+ ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
+ return;
+ end if;
+
if Ekind (Def_Id) = E_Function
- and then Is_Class_Wide_Type (Etype (Def_Id))
- and then Is_CPP_Class (Etype (Etype (Def_Id)))
+ and then (Is_CPP_Class (Etype (Def_Id))
+ or else (Is_Class_Wide_Type (Etype (Def_Id))
+ and then
+ Is_CPP_Class (Root_Type (Etype (Def_Id)))))
then
if Arg_Count >= 2 then
Set_Imported (Def_Id);
Set_Has_Completion (Def_Id);
Set_Is_Constructor (Def_Id);
+ -- Imported C++ constructors are not dispatching primitives
+ -- because in C++ they don't have a dispatch table slot.
+ -- However, in Ada the constructor has the profile of a
+ -- function that returns a tagged type and therefore it has
+ -- been treated as a primitive operation during semantic
+ -- analysis. We now remove it from the list of primitive
+ -- operations of the type.
+
+ if Is_Tagged_Type (Etype (Def_Id))
+ and then not Is_Class_Wide_Type (Etype (Def_Id))
+ then
+ pragma Assert (Is_Dispatching_Operation (Def_Id));
+ Tag_Typ := Etype (Def_Id);
+
+ Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+ while Present (Elmt) and then Node (Elmt) /= Def_Id loop
+ Next_Elmt (Elmt);
+ end loop;
+
+ Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
+ Set_Is_Dispatching_Operation (Def_Id, False);
+ end if;
+
+ -- For backward compatibility, if the constructor returns a
+ -- class wide type, and we internally change the return type to
+ -- the corresponding root type.
+
+ if Is_Class_Wide_Type (Etype (Def_Id)) then
+ Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
+ end if;
else
Error_Pragma_Arg
("pragma% requires function returning a 'C'P'P_Class type",
Check_Valid_Configuration_Pragma;
Detect_Blocking := True;
+ ---------------
+ -- Dimension --
+ ---------------
+
+ when Pragma_Dimension =>
+ GNAT_Pragma;
+ Check_Arg_Count (4);
+ Check_No_Identifiers;
+ Check_Arg_Is_Local_Name (Arg1);
+
+ if not Is_Type (Arg1) then
+ Error_Pragma ("first argument for pragma% must be subtype");
+ end if;
+
+ Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
+ Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
+ Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
+
-------------------
-- Discard_Names --
-------------------
if Chars (Expression (Arg1)) = Name_On then
Extensions_Allowed := True;
+ Ada_Version := Ada_Version_Type'Last;
+
else
Extensions_Allowed := False;
+ Ada_Version := Ada_Version_Explicit;
end if;
--------------
Check_Arg_Count (1);
Check_No_Identifiers;
Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Store_Note (N);
-- For pragma Ident, preserve DEC compatibility by requiring the
-- pragma to appear in a declarative part or package spec.
else
-- In VMS, the effect of IDENT is achieved by passing
- -- IDENTIFICATION=name as a --for-linker switch.
+ -- --identification=name as a --for-linker switch.
if OpenVMS_On_Target then
Start_String;
Store_String_Chars
- ("--for-linker=IDENTIFICATION=");
+ ("--for-linker=--identification=");
String_To_Name_Buffer (Strval (Str));
Store_String_Chars (Name_Buffer (1 .. Name_Len));
-- associated with a with'd package.
Replace_Linker_Option_String
- (End_String, "--for-linker=IDENTIFICATION=");
+ (End_String, "--for-linker=--identification=");
end if;
Set_Ident_String (Current_Sem_Unit, Str);
end;
end Ident;
- --------------------------
- -- Implemented_By_Entry --
- --------------------------
+ -----------------
+ -- Implemented --
+ -----------------
- -- pragma Implemented_By_Entry (DIRECT_NAME);
+ -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
+ -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
- when Pragma_Implemented_By_Entry => Implemented_By_Entry : declare
- Ent : Entity_Id;
+ when Pragma_Implemented => Implemented : declare
+ Proc_Id : Entity_Id;
+ Typ : Entity_Id;
begin
- Ada_2005_Pragma;
- Check_Arg_Count (1);
+ Ada_2012_Pragma;
+ Check_Arg_Count (2);
Check_No_Identifiers;
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Local_Name (Arg1);
- Ent := Entity (Expression (Arg1));
+ Check_Arg_Is_One_Of
+ (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
+
+ -- Extract the name of the local procedure
- -- Pragma Implemented_By_Entry must be applied only to protected
- -- synchronized or task interface primitives.
+ Proc_Id := Entity (Expression (Arg1));
- if (Ekind (Ent) /= E_Function
- and then Ekind (Ent) /= E_Procedure)
- or else not Present (First_Formal (Ent))
- or else not Is_Concurrent_Interface (Etype (First_Formal (Ent)))
+ -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
+ -- primitive procedure of a synchronized tagged type.
+
+ if Ekind (Proc_Id) = E_Procedure
+ and then Is_Primitive (Proc_Id)
+ and then Present (First_Formal (Proc_Id))
then
- Error_Pragma_Arg
- ("pragma % must be applied to a concurrent interface " &
- "primitive", Arg1);
+ Typ := Etype (First_Formal (Proc_Id));
- else
- if Einfo.Implemented_By_Entry (Ent)
- and then Warn_On_Redundant_Constructs
+ if Is_Tagged_Type (Typ)
+ and then
+
+ -- Check for a protected, a synchronized or a task interface
+
+ ((Is_Interface (Typ)
+ and then Is_Synchronized_Interface (Typ))
+
+ -- Check for a protected type or a task type that implements
+ -- an interface.
+
+ or else
+ (Is_Concurrent_Record_Type (Typ)
+ and then Present (Interfaces (Typ)))
+
+ -- Check for a private record extension with keyword
+ -- "synchronized".
+
+ or else
+ (Ekind_In (Typ, E_Record_Type_With_Private,
+ E_Record_Subtype_With_Private)
+ and then Synchronized_Present (Parent (Typ))))
then
- Error_Pragma ("?duplicate pragma%!");
+ null;
else
- Set_Implemented_By_Entry (Ent);
+ Error_Pragma_Arg
+ ("controlling formal must be of synchronized " &
+ "tagged type", Arg1);
+ return;
end if;
+
+ -- Procedures declared inside a protected type must be accepted
+
+ elsif Ekind (Proc_Id) = E_Procedure
+ and then Is_Protected_Type (Scope (Proc_Id))
+ then
+ null;
+
+ -- The first argument is not a primitive procedure
+
+ else
+ Error_Pragma_Arg
+ ("pragma % must be applied to a primitive procedure", Arg1);
+ return;
end if;
- end Implemented_By_Entry;
- -----------------------
+ -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
+ -- By_Protected_Procedure to the primitive procedure of a task
+ -- interface.
+
+ if Chars (Arg2) = Name_By_Protected_Procedure
+ and then Is_Interface (Typ)
+ and then Is_Task_Interface (Typ)
+ then
+ Error_Pragma_Arg
+ ("implementation kind By_Protected_Procedure cannot be " &
+ "applied to a task interface primitive", Arg2);
+ return;
+ end if;
+
+ Record_Rep_Item (Proc_Id, N);
+ end Implemented;
+
+ ----------------------
-- Implicit_Packing --
- -----------------------
+ ----------------------
-- pragma Implicit_Packing;
Arg_First_Optional_Parameter => First_Optional_Parameter);
end Import_Valued_Procedure;
+ -----------------
+ -- Independent --
+ -----------------
+
+ -- pragma Independent (LOCAL_NAME);
+
+ when Pragma_Independent => Independent : declare
+ E_Id : Node_Id;
+ E : Entity_Id;
+ D : Node_Id;
+ K : Node_Kind;
+
+ begin
+ Check_Ada_83_Warning;
+ Ada_2012_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ E := Entity (E_Id);
+ D := Declaration_Node (E);
+ K := Nkind (D);
+
+ if Is_Type (E) then
+ if Rep_Item_Too_Early (E, N)
+ or else
+ Rep_Item_Too_Late (E, N)
+ then
+ return;
+ else
+ Check_First_Subtype (Arg1);
+ end if;
+
+ elsif K = N_Object_Declaration
+ or else (K = N_Component_Declaration
+ and then Original_Record_Component (E) = E)
+ then
+ if Rep_Item_Too_Late (E, N) then
+ return;
+ end if;
+
+ else
+ Error_Pragma_Arg
+ ("inappropriate entity for pragma%", Arg1);
+ end if;
+
+ Independence_Checks.Append ((N, E));
+ end Independent;
+
+ ----------------------------
+ -- Independent_Components --
+ ----------------------------
+
+ -- pragma Atomic_Components (array_LOCAL_NAME);
+
+ -- This processing is shared by Volatile_Components
+
+ when Pragma_Independent_Components => Independent_Components : declare
+ E_Id : Node_Id;
+ E : Entity_Id;
+ D : Node_Id;
+ K : Node_Kind;
+
+ begin
+ Check_Ada_83_Warning;
+ Ada_2012_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ E := Entity (E_Id);
+
+ if Rep_Item_Too_Early (E, N)
+ or else
+ Rep_Item_Too_Late (E, N)
+ then
+ return;
+ end if;
+
+ D := Declaration_Node (E);
+ K := Nkind (D);
+
+ if (K = N_Full_Type_Declaration
+ and then (Is_Array_Type (E) or else Is_Record_Type (E)))
+ or else
+ ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
+ and then Nkind (D) = N_Object_Declaration
+ and then Nkind (Object_Definition (D)) =
+ N_Constrained_Array_Definition)
+ then
+ Independence_Checks.Append ((N, E));
+
+ else
+ Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
+ end if;
+ end Independent_Components;
+
------------------------
-- Initialize_Scalars --
------------------------
Check_Valid_Configuration_Pragma;
Check_Restriction (No_Initialize_Scalars, N);
- if not Restriction_Active (No_Initialize_Scalars) then
+ -- Initialize_Scalars creates false positives in CodePeer,
+ -- so ignore this pragma in this mode.
+
+ if not Restriction_Active (No_Initialize_Scalars)
+ and then not CodePeer_Mode
+ then
Init_Or_Norm_Scalars := True;
Initialize_Scalars := True;
end if;
when Pragma_Inline_Always =>
GNAT_Pragma;
- Process_Inline (True);
+
+ -- Pragma always active unless in CodePeer mode, since this causes
+ -- walk order issues.
+
+ if not CodePeer_Mode then
+ Process_Inline (True);
+ end if;
--------------------
-- Inline_Generic --
Check_At_Most_N_Arguments (4);
Process_Import_Or_Interface;
+ -- In Ada 2005, the permission to use Interface (a reserved word)
+ -- as a pragma name is considered an obsolescent feature.
+
+ if Ada_Version >= Ada_2005 then
+ Check_Restriction
+ (No_Obsolescent_Features, Pragma_Identifier (N));
+ end if;
+
--------------------
-- Interface_Name --
--------------------
-- pragma Machine_Attribute (
-- [Entity =>] LOCAL_NAME,
-- [Attribute_Name =>] static_string_EXPRESSION
- -- [, [Info =>] static_string_EXPRESSION] );
+ -- [, [Info =>] static_EXPRESSION] );
when Pragma_Machine_Attribute => Machine_Attribute : declare
Def_Id : Entity_Id;
if Arg_Count = 3 then
Check_Optional_Identifier (Arg3, Name_Info);
- Check_Arg_Is_Static_Expression (Arg3, Standard_String);
+ Check_Arg_Is_Static_Expression (Arg3);
else
Check_Arg_Count (2);
end if;
Arg : Node_Id;
begin
- GNAT_Pragma;
+ Ada_2005_Pragma;
Check_At_Least_N_Arguments (1);
-- Loop through arguments of pragma
while Present (E)
and then Scope (E) = Current_Scope
loop
- if Ekind (E) = E_Procedure
- or else Ekind (E) = E_Generic_Procedure
- then
+ if Ekind_In (E, E_Procedure, E_Generic_Procedure) then
Set_No_Return (E);
-- Set flag on any alias as well
Check_Ada_83_Warning;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
- Normalize_Scalars := True;
- Init_Or_Norm_Scalars := True;
+
+ -- Normalize_Scalars creates false positives in CodePeer, so
+ -- ignore this pragma in this mode.
+
+ if not CodePeer_Mode then
+ Normalize_Scalars := True;
+ Init_Or_Norm_Scalars := True;
+ end if;
-----------------
-- Obsolescent --
-- pragma Optimize_Alignment (Time | Space | Off);
- when Pragma_Optimize_Alignment =>
+ when Pragma_Optimize_Alignment => Optimize_Alignment : begin
GNAT_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
-- switch will get reset anyway at the start of each unit.
Optimize_Alignment_Local := True;
+ end Optimize_Alignment;
+
+ -------------
+ -- Ordered --
+ -------------
+
+ -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
+
+ when Pragma_Ordered => Ordered : declare
+ Assoc : constant Node_Id := Arg1;
+ Type_Id : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Type_Id := Expression (Assoc);
+ Find_Type (Type_Id);
+ Typ := Entity (Type_Id);
+
+ if Typ = Any_Type then
+ return;
+ else
+ Typ := Underlying_Type (Typ);
+ end if;
+
+ if not Is_Enumeration_Type (Typ) then
+ Error_Pragma ("pragma% must specify enumeration type");
+ end if;
+
+ Check_First_Subtype (Arg1);
+ Set_Has_Pragma_Ordered (Base_Type (Typ));
+ end Ordered;
----------
-- Pack --
Assoc : constant Node_Id := Arg1;
Type_Id : Node_Id;
Typ : Entity_Id;
+ Ctyp : Entity_Id;
+ Ignore : Boolean := False;
begin
Check_No_Identifiers;
-- Array type
elsif Is_Array_Type (Typ) then
+ Ctyp := Component_Type (Typ);
- -- Pack not allowed for aliased or atomic components
+ -- Ignore pack that does nothing
- if Has_Aliased_Components (Base_Type (Typ)) then
- Error_Pragma
- ("pragma% ignored, cannot pack aliased components?");
-
- elsif Has_Atomic_Components (Typ)
- or else Is_Atomic (Component_Type (Typ))
+ if Known_Static_Esize (Ctyp)
+ and then Known_Static_RM_Size (Ctyp)
+ and then Esize (Ctyp) = RM_Size (Ctyp)
+ and then Addressable (Esize (Ctyp))
then
- Error_Pragma
- ("?pragma% ignored, cannot pack atomic components");
+ Ignore := True;
end if;
- -- If we had an explicit component size given, then we do not
- -- let Pack override this given size. We also give a warning
- -- that Pack is being ignored unless we can tell for sure that
- -- the Pack would not have had any effect anyway.
+ -- Process OK pragma Pack. Note that if there is a separate
+ -- component clause present, the Pack will be cancelled. This
+ -- processing is in Freeze.
- if Has_Component_Size_Clause (Typ) then
- if Known_Static_RM_Size (Component_Type (Typ))
- and then
- RM_Size (Component_Type (Typ)) = Component_Size (Typ)
- then
+ if not Rep_Item_Too_Late (Typ, N) then
+
+ -- In the context of static code analysis, we do not need
+ -- complex front-end expansions related to pragma Pack,
+ -- so disable handling of pragma Pack in this case.
+
+ if CodePeer_Mode then
null;
- else
- Error_Pragma
- ("?pragma% ignored, explicit component size given");
- end if;
- -- If no prior array component size given, Pack is effective
+ -- For normal non-VM target, do the packing
- else
- if not Rep_Item_Too_Late (Typ, N) then
- if VM_Target = No_VM then
+ elsif VM_Target = No_VM then
+ if not Ignore then
Set_Is_Packed (Base_Type (Typ));
- Set_Has_Pragma_Pack (Base_Type (Typ));
Set_Has_Non_Standard_Rep (Base_Type (Typ));
-
- elsif not GNAT_Mode then
- Error_Pragma
- ("?pragma% ignored in this configuration");
end if;
+
+ Set_Has_Pragma_Pack (Base_Type (Typ));
+
+ -- If we ignore the pack for VM_Targets, then warn about
+ -- this, except suppress the warning in GNAT mode.
+
+ elsif not GNAT_Mode then
+ Error_Pragma
+ ("?pragma% ignored in this configuration");
end if;
end if;
-- If in spec, nothing more to do. If in body, then we convert the
-- pragma to pragma Check (Precondition, cond [, msg]). Note we do
-- this whether or not precondition checks are enabled. That works
- -- fine since pragma Check will do this check.
+ -- fine since pragma Check will do this check, and will also
+ -- analyze the condition itself in the proper context.
if In_Body then
if Arg_Count = 2 then
Analyze_And_Resolve (Get_Pragma_Arg (Arg2), Standard_String);
end if;
- Analyze_And_Resolve (Get_Pragma_Arg (Arg1), Standard_Boolean);
-
Rewrite (N,
Make_Pragma (Loc,
Chars => Name_Check,
-- This is one of the few cases where we need to test the value of
-- Ada_Version_Explicit rather than Ada_Version (which is always
- -- set to Ada_05 in a predefined unit), we need to know the
+ -- set to Ada_12 in a predefined unit), we need to know the
-- explicit version set to know if this pragma is active.
if Ada_Version_Explicit >= Ada_05 then
Def_Id := Entity (Internal);
- if Ekind (Def_Id) /= E_Constant
- and then Ekind (Def_Id) /= E_Variable
- then
+ if not Ekind_In (Def_Id, E_Constant, E_Variable) then
Error_Pragma_Arg
("pragma% must designate an object", Internal);
end if;
-- This is one of the few cases where we need to test the value of
-- Ada_Version_Explicit rather than Ada_Version (which is always
- -- set to Ada_05 in a predefined unit), we need to know the
+ -- set to Ada_12 in a predefined unit), we need to know the
-- explicit version set to know if this pragma is active.
if Ada_Version_Explicit >= Ada_05 then
loop
Def_Id := Get_Base_Subprogram (E);
- if Ekind (Def_Id) /= E_Function
- and then Ekind (Def_Id) /= E_Generic_Function
- and then Ekind (Def_Id) /= E_Operator
+ if not Ekind_In (Def_Id, E_Function,
+ E_Generic_Function,
+ E_Operator)
then
Error_Pragma_Arg
("pragma% requires a function name", Arg1);
if not Effective
and then Warn_On_Redundant_Constructs
then
- Error_Msg_NE ("pragma Pure_Function on& is redundant?",
- N, Entity (E_Id));
+ Error_Msg_NE
+ ("pragma Pure_Function on& is redundant?",
+ N, Entity (E_Id));
end if;
end if;
end Pure_Function;
Set_Ravenscar_Profile (N);
if Warn_On_Obsolescent_Feature then
- Error_Msg_N
- ("pragma Ravenscar is an obsolescent feature?", N);
- Error_Msg_N
- ("|use pragma Profile (Ravenscar) instead", N);
+ Error_Msg_N ("pragma Ravenscar is an obsolescent feature?", N);
+ Error_Msg_N ("|use pragma Profile (Ravenscar) instead", N);
end if;
-------------------------
if Warn_On_Obsolescent_Feature then
Error_Msg_N
("pragma Restricted_Run_Time is an obsolescent feature?", N);
- Error_Msg_N
- ("|use pragma Profile (Restricted) instead", N);
+ Error_Msg_N ("|use pragma Profile (Restricted) instead", N);
end if;
------------------
when Pragma_Reviewable =>
Check_Ada_83_Warning;
Check_Arg_Count (0);
+
+ -- Call dummy debugging function rv. This is done to assist front
+ -- end debugging. By placing a Reviewable pragma in the source
+ -- program, a breakpoint on rv catches this place in the source,
+ -- allowing convenient stepping to the point of interest.
+
rv;
+ --------------------------
+ -- Short_Circuit_And_Or --
+ --------------------------
+
+ when Pragma_Short_Circuit_And_Or =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Short_Circuit_And_Or := True;
+
-------------------
-- Share_Generic --
-------------------
Set_Is_Shared_Passive (Cunit_Ent);
end Shared_Passive;
+ -----------------------
+ -- Short_Descriptors --
+ -----------------------
+
+ -- pragma Short_Descriptors;
+
+ when Pragma_Short_Descriptors =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Short_Descriptors := True;
+
----------------------
-- Source_File_Name --
----------------------
elsif Nkind (A) = N_Identifier then
if Chars (A) = Name_All_Checks then
- Set_Default_Style_Check_Options;
+ if GNAT_Mode then
+ Set_GNAT_Style_Check_Options;
+ else
+ Set_Default_Style_Check_Options;
+ end if;
elsif Chars (A) = Name_On then
Style_Check := True;
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Subtitle);
- Check_Arg_Is_String_Literal (Arg1);
+ Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Store_Note (N);
--------------
-- Suppress --
Arg := Expression (Arg1);
-- The expression is used in the call to Create_Task, and must be
- -- expanded there, not in the context of the current spec.
+ -- expanded there, not in the context of the current spec. It must
+ -- however be analyzed to capture global references, in case it
+ -- appears in a generic context.
- Preanalyze_And_Resolve (New_Copy_Tree (Arg), Standard_String);
+ Preanalyze_And_Resolve (Arg, Standard_String);
if Nkind (P) /= N_Task_Definition then
Pragma_Misplaced;
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
+ Store_Note (N);
for J in 1 .. 2 loop
if Present (Args (J)) then
- Check_Arg_Is_String_Literal (Args (J));
+ Check_Arg_Is_Static_Expression (Args (J), Standard_String);
end if;
end loop;
end Title;
Comp := First (Component_Items (Clist));
while Present (Comp) loop
- Check_Component (Comp);
+ Check_Component (Comp, Typ);
Next (Comp);
end loop;
Variant := First (Variants (Vpart));
while Present (Variant) loop
- Check_Variant (Variant);
+ Check_Variant (Variant, Typ);
Next (Variant);
end loop;
end if;
Check_At_Least_N_Arguments (1);
Check_No_Identifiers;
+ -- If debug flag -gnatd.i is set, pragma is ignored
+
+ if Debug_Flag_Dot_I then
+ return;
+ end if;
+
+ -- Process various forms of the pragma
+
declare
Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
elsif not Is_Static_String_Expression (Arg1) then
Error_Pragma_Arg
("argument of pragma% must be On/Off or " &
- "static string expression", Arg2);
+ "static string expression", Arg1);
-- One argument string expression case
raise Program_Error;
end case;
+ -- AI05-0144: detect dangerous order dependence. Disabled for now,
+ -- until AI is formally approved.
+
+ -- Check_Order_Dependence;
+
exception
when Pragma_Exit => null;
end Analyze_Pragma;
-----------------------------------------
-- This function makes use of the following static table which indicates
- -- whether a given pragma is significant. A value of -1 in this table
- -- indicates that the reference is significant. A value of zero indicates
- -- than appearance as any argument is insignificant, a positive value
- -- indicates that appearance in that parameter position is significant.
+ -- whether a given pragma is significant.
- -- A value of 99 flags a special case requiring a special check (this is
- -- used for cases not covered by this standard encoding, e.g. pragma Check
- -- where the first argument is not significant, but the others are).
+ -- -1 indicates that references in any argument position are significant
+ -- 0 indicates that appearence in any argument is not significant
+ -- +n indicates that appearence as argument n is significant, but all
+ -- other arguments are not significant
+ -- 99 special processing required (e.g. for pragma Check)
Sig_Flags : constant array (Pragma_Id) of Int :=
(Pragma_AST_Entry => -1,
Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1,
Pragma_Ada_2005 => -1,
+ Pragma_Ada_12 => -1,
+ Pragma_Ada_2012 => -1,
Pragma_All_Calls_Remote => -1,
Pragma_Annotate => -1,
Pragma_Assert => -1,
Pragma_Debug => -1,
Pragma_Debug_Policy => 0,
Pragma_Detect_Blocking => -1,
+ Pragma_Dimension => -1,
Pragma_Discard_Names => 0,
Pragma_Elaborate => -1,
Pragma_Elaborate_All => -1,
Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0,
Pragma_Ident => -1,
- Pragma_Implemented_By_Entry => -1,
+ Pragma_Implemented => -1,
Pragma_Implicit_Packing => 0,
Pragma_Import => +2,
Pragma_Import_Exception => 0,
Pragma_Import_Object => 0,
Pragma_Import_Procedure => 0,
Pragma_Import_Valued_Procedure => 0,
+ Pragma_Independent => 0,
+ Pragma_Independent_Components => 0,
Pragma_Initialize_Scalars => -1,
Pragma_Inline => 0,
Pragma_Inline_Always => 0,
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
Pragma_Optimize_Alignment => -1,
+ Pragma_Ordered => 0,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
Pragma_Restriction_Warnings => -1,
Pragma_Restrictions => -1,
Pragma_Reviewable => -1,
+ Pragma_Short_Circuit_And_Or => -1,
Pragma_Share_Generic => -1,
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
+ Pragma_Short_Descriptors => 0,
Pragma_Source_File_Name => -1,
Pragma_Source_File_Name_Project => -1,
Pragma_Source_Reference => -1,
OSDN Git Service
