with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
+with Elists; use Elists;
with Errout; use Errout;
with Exp_Dist; use Exp_Dist;
with Lib; use Lib;
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.
+ -- 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_String_Literal (Arg : Node_Id);
-- Check the specified argument Arg to make sure that it is a string
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;
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;
String_Val : constant String_Id := Strval (Nam);
begin
+ -- 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 VM_Target = CLI_Target then
+ return;
+ end if;
+
-- We are only interested in the export case, and in the case of
-- generics, it is the instance, not the template, that is the
-- problem (the template will generate a warning in any case).
-- Record whether pragma is enabled
- Set_PPC_Enabled (N, Check_Enabled (Pname));
+ Set_Pragma_Enabled (N, Check_Enabled (Pname));
-- If we are within an inlined body, the legality of the pragma
-- has been checked already.
(Chars (Arg), Names (Index1))
then
Error_Msg_Name_1 := Names (Index1);
- Error_Msg_N ("\possible misspelling of%", Arg);
+ Error_Msg_N -- CODEFIX
+ ("\possible misspelling of%", Arg);
exit;
end if;
end loop;
------------------------
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;
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;
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;
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
Prag_Id = Pragma_Import_Valued_Procedure
then
if not Is_Imported (Ent) then
- Error_Pragma
+ Error_Pragma -- CODEFIX???
("pragma Import or Interface must precede pragma%");
end if;
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);
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
end loop;
-- When the convention is Java or CIL, we also allow Import to be
- -- given for packages, generic packages, exceptions, and record
- -- components.
+ -- given for packages, generic packages, exceptions, record
+ -- components, and access to subprograms.
elsif (C = Convention_Java or else C = Convention_CIL)
and then
(Is_Package_Or_Generic_Package (Def_Id)
or else Ekind (Def_Id) = E_Exception
+ or else Ekind (Def_Id) = E_Access_Subprogram_Type
or else Nkind (Parent (Def_Id)) = N_Component_Declaration)
then
Set_Imported (Def_Id);
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);
+ -- 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.
- 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.
+ 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).
+
+ 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 on the
+ -- C++ side.
+
+ 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);
+
+ 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;
+
+ Next (Comp);
+ end loop;
+ end if;
+ end;
+
else
Error_Pragma_Arg
("second argument of pragma% must be object or subprogram",
if not In_Character_Range (C)
- -- For all cases except external names on CLI target,
+ -- For all cases except CLI target,
-- commas, spaces and slashes are dubious (in CLI, we use
- -- spaces and commas in external names to specify assembly
- -- version and public key).
+ -- commas and backslashes in external names to specify
+ -- assembly version and public key, while slashes and spaces
+ -- can be used in names to mark nested classes and
+ -- valuetypes).
or else ((not Ext_Name_Case or else VM_Target /= CLI_Target)
- and then (Get_Character (C) = ' '
- or else
- Get_Character (C) = ','
- or else
- Get_Character (C) = '/'
+ and then (Get_Character (C) = ','
or else
Get_Character (C) = '\'))
+ or else (VM_Target /= CLI_Target
+ and then (Get_Character (C) = ' '
+ or else
+ Get_Character (C) = '/'))
then
Error_Msg
("?interface name contains illegal character",
Error_Msg_String (1 .. Rnm'Length) :=
Name_Buffer (1 .. Name_Len);
Error_Msg_Strlen := Rnm'Length;
- Error_Msg_N
+ Error_Msg_N -- CODEFIX
("\possible misspelling of ""~""",
Get_Pragma_Arg (Arg));
exit;
for PN in First_Pragma_Name .. Last_Pragma_Name loop
if Is_Bad_Spelling_Of (Pname, PN) then
Error_Msg_Name_1 := PN;
- Error_Msg_N
+ Error_Msg_N -- CODEFIX
("\?possible misspelling of %!", Pragma_Identifier (N));
exit;
end if;
-- 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);
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);
+
+ if Is_Entity_Name (Exp) then
+ null;
- elsif Nkind (Exp) = N_String_Literal then
- Resolve (Exp, Standard_String);
+ -- For string literals, we assume Standard_String as the
+ -- type, unless the string contains wide or wide_wide
+ -- characters.
- elsif Is_Overloaded (Exp) then
- Error_Pragma_Arg ("ambiguous argument for pragma%", Exp);
+ 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;
- else
- Resolve (Exp);
- end if;
+ elsif Is_Overloaded (Exp) then
+ Error_Pragma_Arg
+ ("ambiguous argument for pragma%", Exp);
- Next (Arg);
- end loop;
+ else
+ Resolve (Exp);
+ end if;
+
+ Next (Arg);
+ end loop;
+ end if;
end;
end Annotate;
Check_Arg_Is_Identifier (Arg1);
Check_On := Check_Enabled (Chars (Get_Pragma_Arg (Arg1)));
+ Set_Pragma_Enabled (N, Check_On);
-- If expansion is active and the check is not enabled then we
-- rewrite the Check as:
Set_Is_CPP_Class (Typ);
Set_Is_Limited_Record (Typ);
Set_Convention (Typ, Convention_CPP);
+
+ -- Imported CPP types must not have discriminants (because C++
+ -- classes do not have discriminants).
+
+ if Has_Discriminants (Typ) then
+ Error_Msg_N
+ ("imported 'C'P'P type cannot have discriminants",
+ First (Discriminant_Specifications
+ (Declaration_Node (Typ))));
+ end if;
+
+ -- Components of imported CPP types must not have default
+ -- expressions because the constructor (if any) is in the
+ -- C++ side.
+
+ if Is_Incomplete_Or_Private_Type (Typ)
+ and then No (Underlying_Type (Typ))
+ then
+ -- It should be an error to apply pragma CPP to a private
+ -- type if the underlying type is not visible (as it is
+ -- for any representation item). For now, for backward
+ -- compatibility we do nothing but we cannot check components
+ -- because they are not available at this stage. All this code
+ -- will be removed when we cleanup this obsolete GNAT pragma???
+
+ null;
+
+ else
+ declare
+ Tdef : constant Node_Id :=
+ Type_Definition (Declaration_Node (Typ));
+ Clist : Node_Id;
+ Comp : Node_Id;
+
+ 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;
+
+ 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;
end CPP_Class;
---------------------
-- [, [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);
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);
Process_Interface_Name (Def_Id, Arg2, Arg3);
end if;
- if No (Parameter_Specifications (Parent (Def_Id))) then
- Set_Has_Completion (Def_Id);
- Set_Is_Constructor (Def_Id);
- else
- Error_Pragma_Arg
- ("non-default constructors not implemented", Arg1);
+ 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;
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;
and then
(Is_Value_Type (Etype (Def_Id))
or else
+ (Ekind (Etype (Def_Id)) = E_Access_Subprogram_Type
+ and then
+ Atree.Convention (Etype (Def_Id)) = Convention)
+ or else
(Ekind (Etype (Def_Id)) in Access_Kind
and then
(Atree.Convention
pragma Assert (Convention = Convention_CIL);
Error_Pragma_Arg
("pragma% requires function returning a " &
- "'CIL access type", Arg1);
+ "'C'I'L access type", Arg1);
end if;
end if;
-- 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
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 --
else
if not Rep_Item_Too_Late (Typ, N) then
- if VM_Target = No_VM 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;
+
+ -- For normal non-VM target, do the packing
+
+ elsif VM_Target = No_VM then
Set_Is_Packed (Base_Type (Typ));
Set_Has_Pragma_Pack (Base_Type (Typ));
- Set_Has_Non_Standard_Rep (Base_Type (Typ));
+ Set_Has_Non_Standard_Rep (Base_Type (Typ));
+
+ -- If we ignore the pack, then warn about this, except
+ -- that we suppress the warning in GNAT mode.
elsif not GNAT_Mode then
Error_Pragma
-- 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,
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 --
-------------------
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;
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);
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,
OSDN Git Service
