+2014-10-10 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch7.adb, einfo.adb, einfo.ads, sem_prag.adb, sem_ch12.adb,
+ freeze.adb, sem_util.adb, sem_res.adb, exp_ch6.adb, exp_ch13.adb,
+ sem_ch6.adb, sem_cat.adb, sem_disp.adb
+ (Is_Subprogram_Or_Generic_Subprogram): New primitive. Use this primitive
+ throughout where appropriate.
+
+2014-10-10 Bob Duff <duff@adacore.com>
+
+ * a-coinho-shared.ads: Minor reformatting.
+ * s-traceb.adb: Minor clean up.
+
+2014-10-10 Robert Dewar <dewar@adacore.com>
+
+ * ali.adb (Scan_ALI): Read and process new GP flag on ALI P line.
+ * ali.ads (GNATprove_Mode): New component in ALI table.
+ (GNATprove_Mode_Specified): New global.
+ * gnatbind.adb (Gnatbind): Give fatal error if any file compiled
+ in GNATProve mode.
+ * lib-writ.ads, lib-writ.adb (GP): New flag on P line for
+ GNATProve_Mode.
+
+2014-10-10 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch3.adb (Build_Init_Procedure): Adding assertion.
+ (Build_Init_Statement): Ensure that statements
+ associated with the parent components are located at the beginning
+ of the returned list of statements.
+
+2014-10-10 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Inherit_Aspects_At_Freeze_Node): If the full
+ view of a private type T that has a type invariant is a scalar
+ or constrained array type, the base type created for the full
+ view has the same type invariant.
+
2014-10-10 Robert Dewar <dewar@adacore.com>
* exp_util.ads, sem_ch12.adb, exp_util.adb, i-fortra.ads: Minor code
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--- Missing documentation: what is this unit all about??? From its name it
--- is some variation of a-coinho.ads/adb, but documentation needs to be
--- HERE explaining that ???
+-- This is an optimized version of Indefinite_Holders using copy-on-write.
+-- It is used on platforms that support atomic built-ins.
private with Ada.Finalization;
private with Ada.Streams;
+
private with System.Atomic_Counters;
generic
Locking_Policy_Specified := ' ';
No_Normalize_Scalars_Specified := False;
No_Object_Specified := False;
+ GNATprove_Mode_Specified := False;
Normalize_Scalars_Specified := False;
Partition_Elaboration_Policy_Specified := ' ';
Queuing_Policy_Specified := ' ';
First_Sdep => No_Sdep_Id,
First_Specific_Dispatching => Specific_Dispatching.Last + 1,
First_Unit => No_Unit_Id,
+ GNATprove_Mode => False,
Last_Interrupt_State => Interrupt_States.Last,
Last_Sdep => No_Sdep_Id,
Last_Specific_Dispatching => Specific_Dispatching.Last,
ALIs.Table (Id).Partition_Elaboration_Policy :=
Partition_Elaboration_Policy_Specified;
+ -- Processing for GP
+
+ elsif C = 'G' then
+ Checkc ('P');
+ GNATprove_Mode_Specified := True;
+ ALIs.Table (Id).GNATprove_Mode := True;
+
-- Processing for Lx
elsif C = 'L' then
-- always be set as well in this case. Not set if 'P' appears in
-- Ignore_Lines.
+ GNATprove_Mode : Boolean;
+ -- Set to True if ALI and object file produced in GNATprove_Mode as
+ -- signalled by GP appearing on the P line. Not set if 'P' appears in
+ -- Ignore_Lines.
+
No_Object : Boolean;
-- Set to True if no object file generated. Not set if 'P' appears in
-- Ignore_Lines.
-- Set to False by Initialize_ALI. Set to True if Scan_ALI reads
-- a unit for which dynamic elaboration checking is enabled.
+ GNATprove_Mode_Specified : Boolean := False;
+ -- Set to True if an ali file was produced in GNATprove mode.
+
Initialize_Scalars_Used : Boolean := False;
-- Set True if an ali file contains the Initialize_Scalars flag
E_Package_Body,
E_Subprogram_Body,
E_Variable)
- or else Is_Generic_Subprogram (Id)
- or else Is_Subprogram (Id));
+ or else Is_Subprogram_Or_Generic_Subprogram (Id));
return Node34 (Id);
end Contract;
return Ekind (Id) in Subprogram_Kind;
end Is_Subprogram;
+ function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B is
+ begin
+ return Ekind (Id) in Subprogram_Kind
+ or else
+ Ekind (Id) in Generic_Subprogram_Kind;
+ end Is_Subprogram_Or_Generic_Subprogram;
+
function Is_Task_Type (Id : E) return B is
begin
return Ekind (Id) in Task_Kind;
begin
pragma Assert
(Ekind_In (Id, E_Entry,
- E_Entry_Family,
- E_Generic_Package,
- E_Package,
- E_Package_Body,
- E_Subprogram_Body,
- E_Variable,
- E_Void)
- or else Is_Generic_Subprogram (Id)
- or else Is_Subprogram (Id));
+ E_Entry_Family,
+ E_Generic_Package,
+ E_Package,
+ E_Package_Body,
+ E_Subprogram_Body,
+ E_Variable,
+ E_Void)
+ or else Is_Subprogram_Or_Generic_Subprogram (Id));
Set_Node34 (Id, V);
end Set_Contract;
-- Applies to all entities, true for function, procedure and operator
-- entities.
+-- Is_Subprogram_Or_Generic_Subprogram
+-- Applies to all entities, true for function procedure and operator
+-- entities, and also for the corresponding generic entities.
+
-- Is_Synchronized_Interface (synthesized)
-- Defined in types that are interfaces. True if interface is declared
-- synchronized, task, or protected, or is derived from a synchronized
function Is_Scalar_Type (Id : E) return B;
function Is_Signed_Integer_Type (Id : E) return B;
function Is_Subprogram (Id : E) return B;
+ function Is_Subprogram_Or_Generic_Subprogram (Id : E) return B;
function Is_Task_Type (Id : E) return B;
function Is_Type (Id : E) return B;
pragma Inline (Is_Base_Type);
pragma Inline (Is_Package_Or_Generic_Package);
pragma Inline (Is_Packed_Array);
+ pragma Inline (Is_Subprogram_Or_Generic_Subprogram);
pragma Inline (Is_Volatile);
pragma Inline (Is_Wrapper_Package);
pragma Inline (Known_RM_Size);
and then
(Is_Entry (E_Scope)
or else (Is_Subprogram (E_Scope)
- and then Is_Protected_Type (Scope (E_Scope)))
+ and then Is_Protected_Type (Scope (E_Scope)))
or else Is_Task_Type (E_Scope))
then
null;
-- generated.
if not Is_Interface (Etype (Rec_Ent)) then
- Prepend_To (Body_Stmts, Remove_Head (Stmts));
+ declare
+ First_Stmt : constant Node_Id := Remove_Head (Stmts);
+ begin
+ pragma Assert
+ (Nkind (First_Stmt) = N_Procedure_Call_Statement
+ and then
+ Is_Init_Proc (Name (First_Stmt)));
+ Prepend_To (Body_Stmts, First_Stmt);
+ end;
end if;
Append_List_To (Body_Stmts, Stmts);
---------------------------
function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
- Checks : constant List_Id := New_List;
- Actions : List_Id := No_List;
- Comp_Loc : Source_Ptr;
- Counter_Id : Entity_Id := Empty;
- Decl : Node_Id;
- Has_POC : Boolean;
- Id : Entity_Id;
- Stmts : List_Id;
- Typ : Entity_Id;
+ Checks : constant List_Id := New_List;
+ Actions : List_Id := No_List;
+ Comp_Loc : Source_Ptr;
+ Counter_Id : Entity_Id := Empty;
+ Decl : Node_Id;
+ Has_POC : Boolean;
+ Id : Entity_Id;
+ Parent_Stmts : List_Id;
+ Stmts : List_Id;
+ Typ : Entity_Id;
procedure Increment_Counter (Loc : Source_Ptr);
-- Generate an "increment by one" statement for the current counter
return New_List (Make_Null_Statement (Loc));
end if;
+ Parent_Stmts := New_List;
Stmts := New_List;
-- Loop through visible declarations of task types and protected
end if;
if Present (Checks) then
- Append_List_To (Stmts, Checks);
+ if Chars (Id) = Name_uParent then
+ Append_List_To (Parent_Stmts, Checks);
+ else
+ Append_List_To (Stmts, Checks);
+ end if;
end if;
if Present (Actions) then
- Append_List_To (Stmts, Actions);
+ if Chars (Id) = Name_uParent then
+ Append_List_To (Parent_Stmts, Actions);
- -- Preserve the initialization state in the current counter
+ else
+ Append_List_To (Stmts, Actions);
- if Chars (Id) /= Name_uParent
- and then Needs_Finalization (Typ)
- then
- if No (Counter_Id) then
- Make_Counter (Comp_Loc);
- end if;
+ -- Preserve the initialization state in the current
+ -- counter
- Increment_Counter (Comp_Loc);
+ if Needs_Finalization (Typ) then
+ if No (Counter_Id) then
+ Make_Counter (Comp_Loc);
+ end if;
+
+ Increment_Counter (Comp_Loc);
+ end if;
end if;
end if;
end if;
Next_Non_Pragma (Decl);
end loop;
+ -- The parent field must be initialized first because variable
+ -- size components of the parent affect the location of all the
+ -- new components.
+
+ Prepend_List_To (Stmts, Parent_Stmts);
+
-- Set up tasks and protected object support. This needs to be done
-- before any component with a per-object access discriminant
-- constraint, or any variant part (which may contain such
Defining_Identifier
(First (Parameter_Specifications (Parent (Corr))));
- if Is_Subprogram (Proc)
- and then Proc /= Corr
- then
+ if Is_Subprogram (Proc) and then Proc /= Corr then
+
-- Protected function or procedure
Set_Entity (Rec, Param);
E := From;
while Present (E) loop
if Is_Subprogram (E) then
-
if not Default_Expressions_Processed (E) then
Process_Default_Expressions (E, After);
end if;
raise Unrecoverable_Error;
end if;
+ -- Quit with message if we had a GNATprove file
+
+ if GNATprove_Mode_Specified then
+ Error_Msg ("one or more files compiled in GNATprove mode");
+ raise Unrecoverable_Error;
+ end if;
+
-- Output list of ALI files in closure
if Output_ALI_List then
end if;
end if;
+ if GNATprove_Mode then
+ Write_Info_Str (" GP");
+ end if;
+
if Partition_Elaboration_Policy /= ' ' then
Write_Info_Str (" E");
Write_Info_Char (Partition_Elaboration_Policy);
-- the units in this file, where x is the first character
-- (upper case) of the policy name (e.g. 'C' for Concurrent).
+ -- GP Set if this compilation was done in GNATprove mode, either
+ -- from direct use of GNATprove, or from use of -gnatdF.
+
-- Lx A valid Locking_Policy pragma applies to all the units in
-- this file, where x is the first character (upper case) of
-- the policy name (e.g. 'C' for Ceiling_Locking).
-- were not compiled to produce an object. This can occur as a
-- result of the use of -gnatc, or if no object can be produced
-- (e.g. when a package spec is compiled instead of the body,
- -- or a subunit on its own).
+ -- or a subunit on its own). Note that in GNATprove mode, we
+ -- do produce an object. The object is not suitable for binding
+ -- and linking, but we do not set NO, instead we set GP.
-- NR No_Run_Time. Indicates that a pragma No_Run_Time applies
-- to all units in the file.
package body System.Traceback is
--- procedure Call_Chain
--- (Traceback : System.Address;
--- Max_Len : Natural;
--- Len : out Natural;
--- Exclude_Min : System.Address := System.Null_Address;
--- Exclude_Max : System.Address := System.Null_Address;
--- Skip_Frames : Natural := 1);
--- -- Same as the exported version, but takes Traceback as an Address
--- ???See declaration in the spec for why this is temporarily commented out.
-
------------------
-- C_Call_Chain --
------------------
E := Current_Scope;
loop
- if Is_Subprogram (E)
- or else
- Is_Generic_Subprogram (E)
+ if Is_Subprogram_Or_Generic_Subprogram (E)
or else
Is_Concurrent_Type (E)
then
else
E := First_Entity (Gen_Unit);
while Present (E) loop
- if Is_Subprogram (E)
- and then Is_Inlined (E)
- then
+ if Is_Subprogram (E) and then Is_Inlined (E) then
return True;
end if;
if Ekind (Scop) = E_Generic_Package
or else (Is_Subprogram (Scop)
- and then Nkind (Unit_Declaration_Node (Scop)) =
+ and then Nkind (Unit_Declaration_Node (Scop)) =
N_Generic_Subprogram_Declaration)
then
Elmt := First_Elmt (Inner_Instances (Inner));
if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then
Set_Has_Inheritable_Invariants (Typ);
end if;
+
+ -- If the full view of the type is a scalar type or array type, the
+ -- implicit base type created for it has the same invariant.
+
+ elsif Has_Invariants (Typ) and then Base_Type (Typ) /= Typ
+ and then not Has_Invariants (Base_Type (Typ))
+ then
+ Set_Has_Invariants (Base_Type (Typ));
+ Set_Invariant_Procedure (Base_Type (Typ), Invariant_Procedure (Typ));
end if;
-- Volatile
procedure List_Inherited_Pre_Post_Aspects (E : Entity_Id) is
begin
if Opt.List_Inherited_Aspects
- and then (Is_Subprogram (E) or else Is_Generic_Subprogram (E))
+ and then Is_Subprogram_Or_Generic_Subprogram (E)
then
declare
Inherited : constant Subprogram_List := Inherited_Subprograms (E);
-- Body required if subprogram
- elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
+ elsif Is_Subprogram_Or_Generic_Subprogram (P) then
return True;
-- Treat a block as requiring a body
-- Body required if subprogram
- elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
+ elsif Is_Subprogram_Or_Generic_Subprogram (P) then
Error_Msg_N ("info: & requires body (subprogram case)?Y?", P);
-- Body required if generic parent has Elaborate_Body
and then
Is_Interface (Find_Dispatching_Type (Parent_Op)));
- if Is_Subprogram (Parent_Op)
- or else
- Is_Generic_Subprogram (Parent_Op)
- then
+ if Is_Subprogram_Or_Generic_Subprogram (Parent_Op) then
Store_IS (Parent_Op);
end if;
end loop;
-- The following test eliminates some odd cases in which
-- Ekind (Prim) is Void, to be investigated further ???
- if not (Is_Subprogram (Prim)
- or else
- Is_Generic_Subprogram (Prim))
- then
+ if not Is_Subprogram_Or_Generic_Subprogram (Prim) then
null;
-- For [generic] subprogram, look at interface alias
("dispatching subprogram# cannot use Stdcall convention!",
Arg1);
- -- Subprogram is allowed, but not a generic subprogram
+ -- Subprograms are not allowed
- elsif not Is_Subprogram (E)
- and then not Is_Generic_Subprogram (E)
+ elsif not Is_Subprogram_Or_Generic_Subprogram (E)
-- A variable is OK
-- For Intrinsic, a subprogram is required
if C = Convention_Intrinsic
- and then not Is_Subprogram (E)
- and then not Is_Generic_Subprogram (E)
+ and then not Is_Subprogram_Or_Generic_Subprogram (E)
then
Error_Pragma_Arg
("second argument of pragma% must be a subprogram", Arg2);
-- Deal with non-subprogram cases
- if not Is_Subprogram (E)
- and then not Is_Generic_Subprogram (E)
- then
+ if not Is_Subprogram_Or_Generic_Subprogram (E) then
Set_Convention_From_Pragma (E);
if Is_Type (E) then
end if;
end if;
- elsif Is_Subprogram (Def_Id)
- or else Is_Generic_Subprogram (Def_Id)
- then
+ elsif Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
+
-- If the name is overloaded, pragma applies to all of the denoted
-- entities in the same declarative part, unless the pragma comes
-- from an aspect specification or was generated by the compiler
-- If it is not a subprogram, it must be in an outer scope and
-- pragma does not apply.
- elsif not Is_Subprogram (Def_Id)
- and then not Is_Generic_Subprogram (Def_Id)
- then
+ elsif not Is_Subprogram_Or_Generic_Subprogram (Def_Id) then
null;
-- The pragma does not apply to primitives of interfaces
then
Error_Msg_N ("class-wide argument not allowed here!", A);
- if Is_Subprogram (Nam)
- and then Comes_From_Source (Nam)
- then
+ if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then
Error_Msg_Node_2 := F_Typ;
Error_Msg_NE
("& is not a dispatching operation of &!", A, Nam);
function Current_Subprogram return Entity_Id is
Scop : constant Entity_Id := Current_Scope;
begin
- if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
+ if Is_Subprogram_Or_Generic_Subprogram (Scop) then
return Scop;
else
return Enclosing_Subprogram (Scop);
while not Comes_From_Source (Val_Actual)
and then Nkind (Val_Actual) in N_Entity
and then (Ekind (Val_Actual) = E_Enumeration_Literal
- or else Is_Subprogram (Val_Actual)
- or else Is_Generic_Subprogram (Val_Actual))
+ or else Is_Subprogram_Or_Generic_Subprogram (Val_Actual))
and then Present (Alias (Val_Actual))
loop
Val_Actual := Alias (Val_Actual);
projects / gcc.git / commitdiff