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 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;
(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;
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);
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",
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;
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;
-- 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,
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;
OSDN Git Service
