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;
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);
+ 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
-- 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;
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);
+ elsif Nkind (Exp) = N_String_Literal then
+ Resolve (Exp, Standard_String);
- elsif Is_Overloaded (Exp) then
- Error_Pragma_Arg ("ambiguous argument for pragma%", Exp);
+ elsif Is_Overloaded (Exp) then
+ Error_Pragma_Arg
+ ("ambiguous argument for pragma%", Exp);
- else
- Resolve (Exp);
- end if;
+ else
+ Resolve (Exp);
+ end if;
- Next (Arg);
- end loop;
+ Next (Arg);
+ end loop;
+ end if;
end;
end Annotate;
-- [, [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);
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,
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;
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
