2011-08-29 Tristan Gingold <gingold@adacore.com>
+ * a-exstat.adb (String_To_EO): Do no set Cleanup_Flag.
+ * a-exexda.adb (Set_Exception_C_Msg): Ditto.
+ (Set_Exception_Msg): Ditto.
+ * a-exexpr-gcc.adb (Setup_Current_Excep): Ditto. Do not set
+ Private_Data.
+ * a-except.adb, a-except-2005.adb (Save_Occurrence_No_Private): Remove.
+ Use Save_Occurrence instead of Save_Occurrence_No_Private.
+ (Raise_With_Msg): Remove Cleanup_Flag.
+ * a-except.ads, a-except-2005.ads (Exception_Occurrence): Remove
+ Clean_Flag and Private_Data components.
+
+2011-08-29 Yannick Moy <moy@adacore.com>
+
+ * freeze.adb (Freeze_Record_Type): Ignore packing in Alfa mode, like
+ in CodePeer mode.
+ * sem_ch3.adb (Signed_Integer_Type_Declaration): Correct the generation
+ of an explicitly declared type, so that the base types of the original
+ type and this generated type are the same, and a "type" (not a subtype
+ like previously).
+ * errout.adb (Special_Msg_Delete): Do not issue messages "Size too
+ small" in Alfa mode, like in CodePeer mode.
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Ignore rep
+ clauses in Alfa mode.
+
+2011-08-29 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.ads, exp_ch6.adb (Is_Null_Procedure): Move the spec of this
+ function to the package spec.
+ * sem_ch6.adb (Find_Corresponding_Spec, New_Overloaded_Entity): For
+ internally generated bodies of null procedures locate the internally
+ generated spec enforcing mode conformance.
+ (Is_Interface_Conformant): Ensure that the controlling formal of the
+ primitives match.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma, case Inline): In an instance, do not
+ reject the pragma if it appears to apply to a formal subprogram.
+
+2011-08-29 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb (Expand_Allocator_Expression): Use consistent name for
+ inner expression, to prevent double evaluation.
+
+2011-08-29 Tristan Gingold <gingold@adacore.com>
+
* a-exexpr.adb (Propagate_Exception): Remove all the parameters as
they were unused.
* a-exexpr-gcc.adb (Propagate_Exception): Ditto.
-- the TSD (all fields of this exception occurrence are set). Abort
-- is deferred before the reraise operation.
- -- Save_Occurrence variations: As the management of the private data
- -- attached to occurrences is delicate, whether or not pointers to such
- -- data has to be copied in various situations is better made explicit.
- -- The following procedures provide an internal interface to help making
- -- this explicit.
-
- procedure Save_Occurrence_No_Private
- (Target : out Exception_Occurrence;
- Source : Exception_Occurrence);
- -- Copy all the components of Source to Target, except the
- -- Private_Data pointer.
-
procedure Transfer_Occurrence
(Target : Exception_Occurrence_Access;
Source : Exception_Occurrence);
Excep.Exception_Raised := False;
Excep.Id := E;
Excep.Num_Tracebacks := 0;
- Excep.Cleanup_Flag := False;
Excep.Pid := Local_Partition_ID;
-- The following is a common pattern, should be abstracted
Abort_Defer.all;
end if;
- Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
+ Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end if;
end Reraise_Occurrence;
Abort_Defer.all;
end if;
- Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
+ Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end Reraise_Occurrence_Always;
procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
begin
- Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
+ Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end Reraise_Occurrence_No_Defer;
Source : Exception_Occurrence)
is
begin
- Save_Occurrence_No_Private (Target, Source);
- end Save_Occurrence;
-
- function Save_Occurrence (Source : Exception_Occurrence) return EOA is
- Target : constant EOA := new Exception_Occurrence;
- begin
- Save_Occurrence (Target.all, Source);
- return Target;
- end Save_Occurrence;
-
- --------------------------------
- -- Save_Occurrence_No_Private --
- --------------------------------
-
- procedure Save_Occurrence_No_Private
- (Target : out Exception_Occurrence;
- Source : Exception_Occurrence)
- is
- begin
Target.Id := Source.Id;
Target.Msg_Length := Source.Msg_Length;
Target.Num_Tracebacks := Source.Num_Tracebacks;
Target.Pid := Source.Pid;
- Target.Cleanup_Flag := Source.Cleanup_Flag;
Target.Msg (1 .. Target.Msg_Length) :=
Source.Msg (1 .. Target.Msg_Length);
Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
Source.Tracebacks (1 .. Target.Num_Tracebacks);
- end Save_Occurrence_No_Private;
+ end Save_Occurrence;
+
+ function Save_Occurrence (Source : Exception_Occurrence) return EOA is
+ Target : constant EOA := new Exception_Occurrence;
+ begin
+ Save_Occurrence (Target.all, Source);
+ return Target;
+ end Save_Occurrence;
-------------------------
-- Transfer_Occurrence --
Source : Exception_Occurrence)
is
begin
- Save_Occurrence_No_Private (Target.all, Source);
+ Save_Occurrence (Target.all, Source);
end Transfer_Occurrence;
-------------------
Msg : String (1 .. Exception_Msg_Max_Length);
-- Characters of message
- Cleanup_Flag : Boolean := False;
- -- The cleanup flag is normally False, it is set True for an exception
- -- occurrence passed to a cleanup routine, and will still be set True
- -- when the cleanup routine does a Reraise_Occurrence call using this
- -- exception occurrence. This is used to avoid recording a bogus trace
- -- back entry from this reraise call.
-
Exception_Raised : Boolean := False;
-- Set to true to indicate that this exception occurrence has actually
-- been raised. When an exception occurrence is first created, this is
Tracebacks : Tracebacks_Array;
-- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks))
-
- Private_Data : System.Address := System.Null_Address;
- -- Field used by low level exception mechanism to store specific data.
- -- Currently used by the GCC exception mechanism to store a pointer to
- -- a GNAT_GCC_Exception.
end record;
function "=" (Left, Right : Exception_Occurrence) return Boolean
Id => null,
Msg_Length => 0,
Msg => (others => ' '),
- Cleanup_Flag => False,
Exception_Raised => False,
Pid => 0,
Num_Tracebacks => 0,
- Tracebacks => (others => TBE.Null_TB_Entry),
- Private_Data => System.Null_Address);
+ Tracebacks => (others => TBE.Null_TB_Entry));
end Ada.Exceptions;
-- (all fields of this exception occurrence are set). Abort is deferred
-- before the reraise operation.
- -- Save_Occurrence variations: As the management of the private data
- -- attached to occurrences is delicate, whether or not pointers to such
- -- data has to be copied in various situations is better made explicit.
- -- The following procedures provide an internal interface to help making
- -- this explicit.
-
- procedure Save_Occurrence_No_Private
- (Target : out Exception_Occurrence;
- Source : Exception_Occurrence);
- -- Copy all the components of Source to Target, except the
- -- Private_Data pointer.
-
procedure Transfer_Occurrence
(Target : Exception_Occurrence_Access;
Source : Exception_Occurrence);
Excep.Exception_Raised := False;
Excep.Id := E;
Excep.Num_Tracebacks := 0;
- Excep.Cleanup_Flag := False;
Excep.Pid := Local_Partition_ID;
Abort_Defer.all;
Raise_Current_Excep (E);
begin
if X.Id /= null then
Abort_Defer.all;
- Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
+ Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end if;
end Reraise_Occurrence;
procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is
begin
Abort_Defer.all;
- Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
+ Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end Reraise_Occurrence_Always;
procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is
begin
- Save_Occurrence_No_Private (Get_Current_Excep.all.all, X);
+ Save_Occurrence (Get_Current_Excep.all.all, X);
Raise_Current_Excep (X.Id);
end Reraise_Occurrence_No_Defer;
Source : Exception_Occurrence)
is
begin
- Save_Occurrence_No_Private (Target, Source);
- end Save_Occurrence;
-
- function Save_Occurrence (Source : Exception_Occurrence) return EOA is
- Target : constant EOA := new Exception_Occurrence;
- begin
- Save_Occurrence (Target.all, Source);
- return Target;
- end Save_Occurrence;
-
- --------------------------------
- -- Save_Occurrence_No_Private --
- --------------------------------
-
- procedure Save_Occurrence_No_Private
- (Target : out Exception_Occurrence;
- Source : Exception_Occurrence)
- is
- begin
Target.Id := Source.Id;
Target.Msg_Length := Source.Msg_Length;
Target.Num_Tracebacks := Source.Num_Tracebacks;
Target.Pid := Source.Pid;
- Target.Cleanup_Flag := Source.Cleanup_Flag;
Target.Msg (1 .. Target.Msg_Length) :=
Source.Msg (1 .. Target.Msg_Length);
Target.Tracebacks (1 .. Target.Num_Tracebacks) :=
Source.Tracebacks (1 .. Target.Num_Tracebacks);
- end Save_Occurrence_No_Private;
+ end Save_Occurrence;
+
+ function Save_Occurrence (Source : Exception_Occurrence) return EOA is
+ Target : constant EOA := new Exception_Occurrence;
+ begin
+ Save_Occurrence (Target.all, Source);
+ return Target;
+ end Save_Occurrence;
-------------------------
-- Transfer_Occurrence --
Source : Exception_Occurrence)
is
begin
- -- Setup Target as an exception to be propagated in the calling task
- -- (rendezvous-wise), taking care not to clobber the associated private
- -- data. Target is expected to be a pointer to the calling task's fixed
- -- TSD occurrence, which is very different from Get_Current_Excep here
- -- because this subprogram is called from the called task.
-
- Save_Occurrence_No_Private (Target.all, Source);
+ Save_Occurrence (Target.all, Source);
end Transfer_Occurrence;
-------------------
Msg : String (1 .. Exception_Msg_Max_Length);
-- Characters of message
- Cleanup_Flag : Boolean := False;
- -- The cleanup flag is normally False, it is set True for an exception
- -- occurrence passed to a cleanup routine, and will still be set True
- -- when the cleanup routine does a Reraise_Occurrence call using this
- -- exception occurrence. This is used to avoid recording a bogus trace
- -- back entry from this reraise call.
-
Exception_Raised : Boolean := False;
-- Set to true to indicate that this exception occurrence has actually
-- been raised. When an exception occurrence is first created, this is
Tracebacks : Tracebacks_Array;
-- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks))
-
- Private_Data : System.Address := System.Null_Address;
- -- Field used by low level exception mechanism to store specific data.
- -- Currently used by the GCC exception mechanism to store a pointer to
- -- a GNAT_GCC_Exception.
end record;
function "=" (Left, Right : Exception_Occurrence) return Boolean
Id => null,
Msg_Length => 0,
Msg => (others => ' '),
- Cleanup_Flag => False,
Exception_Raised => False,
Pid => 0,
Num_Tracebacks => 0,
- Tracebacks => (others => TBE.Null_TB_Entry),
- Private_Data => System.Null_Address);
+ Tracebacks => (others => TBE.Null_TB_Entry));
end Ada.Exceptions;
Excep.Num_Tracebacks := 0;
Excep.Pid := Local_Partition_ID;
Excep.Msg_Length := 0;
- Excep.Cleanup_Flag := False;
while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL
and then Excep.Msg_Length < Exception_Msg_Max_Length
Excep.Id := Id;
Excep.Num_Tracebacks := 0;
Excep.Pid := Local_Partition_ID;
- Excep.Cleanup_Flag := False;
end Set_Exception_Msg;
Excep.Id := Foreign_Exception'Access;
Excep.Msg_Length := 0;
- Excep.Cleanup_Flag := False;
Excep.Exception_Raised := True;
Excep.Pid := Local_Partition_ID;
Excep.Num_Tracebacks := 0;
- Excep.Private_Data := System.Null_Address;
end if;
end Setup_Current_Excep;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
return Null_Occurrence;
else
- X.Cleanup_Flag := False;
-
To := S'First - 2;
Next_String;
elsif Msg = "size for& too small, minimum allowed is ^" then
- -- Suppress "size too small" errors in CodePeer mode, since pragma
- -- Pack is also ignored in this configuration.
+ -- Suppress "size too small" errors in CodePeer mode and ALFA mode,
+ -- since pragma Pack is also ignored in this configuration.
- if CodePeer_Mode then
+ if CodePeer_Mode or ALFA_Mode then
return True;
-- When a size is wrong for a frozen type there is no explicit size
Insert_Action (Exp,
Make_Subtype_Declaration (Loc,
Defining_Identifier => ConstrT,
- Subtype_Indication => Make_Subtype_From_Expr (Exp, T)));
+ Subtype_Indication =>
+ Make_Subtype_From_Expr (Internal_Exp, T)));
Freeze_Itype (ConstrT, Exp);
Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
end;
-- reference to the object itself, and the call becomes a call to the
-- corresponding protected subprogram.
- function Is_Null_Procedure (Subp : Entity_Id) return Boolean;
- -- Predicate to recognize stubbed procedures and null procedures, which
- -- can be inlined unconditionally in all cases.
-
procedure Expand_Simple_Function_Return (N : Node_Id);
-- Expand simple return from function. In the case where we are returning
-- from a function body this is called by Expand_N_Simple_Return_Statement.
-- that requires handling as a build-in-place call or is a qualified
-- expression applied to such a call; otherwise returns False.
+ function Is_Null_Procedure (Subp : Entity_Id) return Boolean;
+ -- Predicate to recognize stubbed procedures and null procedures, which
+ -- can be inlined unconditionally in all cases.
+
procedure Make_Build_In_Place_Call_In_Allocator
(Allocator : Node_Id;
Function_Call : Node_Id);
and then RM_Size (Rec) >= Scalar_Component_Total_RM_Size
- -- Never do implicit packing in CodePeer mode since we don't do
- -- any packing in this mode, since this generates over-complex
- -- code that confuses CodePeer, and in general, CodePeer does not
- -- care about the internal representation of objects.
+ -- Never do implicit packing in CodePeer or ALFA modes since
+ -- we don't do any packing in this mode, since this generates
+ -- over-complex code that confuses static analysis, and in
+ -- general, neither CodePeer not GNATprove care about the
+ -- internal representation of objects.
and then not CodePeer_Mode
+ and then not ALFA_Mode
then
-- If implicit packing enabled, do it
and then not Is_Packed (Root_Type (E))
and then not Has_Component_Size_Clause (Root_Type (E))
and then not CodePeer_Mode
+ and then not ALFA_Mode
then
Get_Index_Bounds (First_Index (E), Lo, Hi);
end if;
-- Process Ignore_Rep_Clauses option (we also ignore rep clauses in
- -- CodePeer mode, since they are not relevant in that context).
+ -- CodePeer mode or ALFA mode, since they are not relevant in these
+ -- contexts).
- if Ignore_Rep_Clauses or CodePeer_Mode then
+ if Ignore_Rep_Clauses or CodePeer_Mode or ALFA_Mode then
case Id is
-- The following should be ignored. They do not affect legality
Rewrite (N, Make_Null_Statement (Sloc (N)));
return;
- -- We do not want too ignore 'Small in CodePeer_Mode, since it
- -- has an impact on the exact computations performed.
+ -- We do not want too ignore 'Small in CodePeer_Mode or ALFA_Mode,
+ -- since it has an impact on the exact computations performed.
-- Perhaps 'Small should also not be ignored by
-- Ignore_Rep_Clauses ???
if ALFA_Mode then
-- If the range of the type is already symmetric with a possible
- -- extra negative value, just make the type its own base type.
+ -- extra negative value, leave it this way.
if UI_Le (Lo_Val, Hi_Val)
and then (UI_Eq (Lo_Val, UI_Negate (Hi_Val))
or else
UI_Eq (Lo_Val, UI_Sub (UI_Negate (Hi_Val), Uint_1)))
then
- Set_Etype (T, T);
+ null;
else
declare
High_Bound => Ubound));
Analyze (Decl);
- Set_Etype (Implicit_Base, Implicit_Base);
+ Set_Etype (Implicit_Base, Base_Type (Implicit_Base));
+ Set_Etype (T, Base_Type (Implicit_Base));
Insert_Before (Parent (Def), Decl);
end;
end if;
end if;
end if;
- if not Has_Completion (E) then
+ -- Ada 2012 (AI05-0165): For internally generated bodies of
+ -- null procedures locate the internally generated spec. We
+ -- enforce mode conformance since a tagged type may inherit
+ -- from interfaces several null primitives which differ only
+ -- in the mode of the formals.
+
+ if not (Comes_From_Source (E))
+ and then Is_Null_Procedure (E)
+ and then not Mode_Conformant (Designator, E)
+ then
+ null;
+
+ elsif not Has_Completion (E) then
if Nkind (N) /= N_Subprogram_Body_Stub then
Set_Corresponding_Spec (N, E);
end if;
Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim);
Typ : constant Entity_Id := Find_Dispatching_Type (Prim);
+ function Controlling_Formal (Prim : Entity_Id) return Entity_Id;
+ -- Return the controlling formal of Prim
+
+ function Controlling_Formal (Prim : Entity_Id) return Entity_Id is
+ E : Entity_Id := First_Entity (Prim);
+ begin
+ while Present (E) loop
+ if Is_Formal (E) and then Is_Controlling_Formal (E) then
+ return E;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ return Empty;
+ end Controlling_Formal;
+
+ -- Local variables
+
+ Iface_Ctrl_F : constant Entity_Id := Controlling_Formal (Iface_Prim);
+ Prim_Ctrl_F : constant Entity_Id := Controlling_Formal (Prim);
+
+ -- Start of processing for Is_Interface_Conformant
+
begin
pragma Assert (Is_Subprogram (Iface_Prim)
and then Is_Subprogram (Prim)
then
return False;
- -- Case of a procedure, or a function that does not have a controlling
- -- result (I or access I).
+ -- The mode of the controlling formals must match
+
+ elsif Present (Iface_Ctrl_F)
+ and then Present (Prim_Ctrl_F)
+ and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F)
+ then
+ return False;
+
+ -- Case of a procedure, or a function whose result type matches the
+ -- result type of the interface primitive, or a function that has no
+ -- controlling result (I or access I).
elsif Ekind (Iface_Prim) = E_Procedure
or else Etype (Prim) = Etype (Iface_Prim)
if Scope (E) /= Current_Scope then
null;
+ -- Ada 2012 (AI05-0165): For internally generated bodies of
+ -- null procedures locate the internally generated spec. We
+ -- enforce mode conformance since a tagged type may inherit
+ -- from interfaces several null primitives which differ only
+ -- in the mode of the formals.
+
+ elsif not Comes_From_Source (S)
+ and then Is_Null_Procedure (S)
+ and then not Mode_Conformant (E, S)
+ then
+ null;
+
-- Check if we have type conformance
elsif Type_Conformant (E, S) then
-- Inline is a program unit pragma (RM 10.1.5) and cannot
-- appear in a formal part to apply to a formal subprogram.
+ -- Do not apply check within an instance or a formal package
+ -- the test will have been applied to the original generic.
elsif Nkind (Decl) in N_Formal_Subprogram_Declaration
and then List_Containing (Decl) = List_Containing (N)
+ and then not In_Instance
then
Error_Msg_N
("Inline cannot apply to a formal subprogram", N);
projects / platform / upstream / gcc.git / commitdiff