+2017-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Fully_Conformant_Expressions): Two entity
+ references are fully conformant if they are both expansions
+ of the discriminant of a protected type, within one of the
+ protected operations. One occurrence may be expanded into a
+ constant declaration while the other is an input parameter to
+ the corresponding generated subprogram.
+
+2017-05-02 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch3.adb (Check_For_Null_Excluding_Components): Created for
+ recursivly searching composite-types for null-excluding access
+ types and verifying them.
+ (Analyze_Object_Declaration): Add a
+ call to Check_Null_Excluding_Components for static verification
+ of non-initialized objects.
+ * checks.adb, checks.ads (Null_Exclusion_Static_Checks): Added
+ a parameter for a composite-type's component and an extra case
+ for printing component information.
+
+2017-05-02 Yannick Moy <moy@adacore.com>
+
+ * sem_ch10.adb (Analyze_Subunit): Take
+ configuration pragma into account when restoring appropriate
+ pragma for analysis of subunit.
+
+2017-05-02 Justin Squirek <squirek@adacore.com>
+
+ * s-tasren.adb, s-tasini.adb, s-taprop-linux.adb,
+ s-mudido-affinity.adb,, a-exetim-posix.adb, a-direio.adb,
+ g-socket.adb, s-taenca.adb, s-fileio.adb: Remove unused use-type
+ clauses from the runtime.
+
2017-05-02 Eric Botcazou <ebotcazou@adacore.com>
* freeze.adb (Check_Component_Storage_Order): Do not treat bit-packed
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
with System.CRTL;
with System.File_Control_Block;
with System.File_IO;
-with System.Direct_IO;
with System.Storage_Elements;
with Ada.Unchecked_Conversion;
-use type System.Direct_IO.Count;
-
package body Ada.Direct_IO is
Zeroes : constant System.Storage_Elements.Storage_Array :=
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2017, 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- --
SC : out Ada.Real_Time.Seconds_Count;
TS : out Ada.Real_Time.Time_Span)
is
- use type Ada.Real_Time.Time;
+
begin
Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
end Split;
-- Null_Exclusion_Static_Checks --
----------------------------------
- procedure Null_Exclusion_Static_Checks (N : Node_Id) is
+ procedure Null_Exclusion_Static_Checks
+ (N : Node_Id;
+ Comp : Node_Id := Empty)
+ is
Error_Node : Node_Id;
Expr : Node_Id;
Has_Null : constant Boolean := Has_Null_Exclusion (N);
Set_Expression (N, Make_Null (Sloc (N)));
Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
- Apply_Compile_Time_Constraint_Error
- (N => Expression (N),
- Msg =>
- "(Ada 2005) null-excluding objects must be initialized??",
- Reason => CE_Null_Not_Allowed);
+ if Present (Comp) then
+
+ -- Specialize the error message to indicate that we are dealing
+ -- with an uninitialized composite object that has a defaulted
+ -- null-excluding component.
+
+ Error_Msg_Name_1 := Chars (Defining_Identifier (Comp));
+ Error_Msg_Name_2 := Chars (Defining_Identifier (N));
+
+ Apply_Compile_Time_Constraint_Error
+ (N => Expression (N),
+ Msg => "(Ada 2005) null-excluding component % of object % " &
+ "must be initialized??",
+ Reason => CE_Null_Not_Allowed);
+ else
+ Apply_Compile_Time_Constraint_Error
+ (N => Expression (N),
+ Msg =>
+ "(Ada 2005) null-excluding objects must be initialized??",
+ Reason => CE_Null_Not_Allowed);
+ end if;
end if;
-- Check that a null-excluding component, formal or object is not being
-- Chars (Related_Id)_FIRST/_LAST. For suggested use of these parameters
-- see the warning in the body of Sem_Ch3.Process_Range_Expr_In_Decl.
- procedure Null_Exclusion_Static_Checks (N : Node_Id);
+ procedure Null_Exclusion_Static_Checks
+ (N : Node_Id;
+ Comp : Node_Id := Empty);
-- Ada 2005 (AI-231): Check bad usages of the null-exclusion issue
+ --
+ -- When a value for Comp is supplied (as in the case of an uninitialized
+ -- null-excluding component within a composite object), a reported error
+ -- will indicate the offending component instead of the object itself.
procedure Remove_Checks (Expr : Node_Id);
-- Remove all checks from Expr except those that are only executed
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2016, AdaCore --
+-- Copyright (C) 2001-2017, AdaCore --
-- --
-- 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- --
----------------------
function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is
- use type C.size_t;
-
Aliases_Count : Natural;
begin
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;
-with Interfaces.C;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System.Case_Util; use System.Case_Util;
package SSL renames System.Soft_Links;
use type CRTL.size_t;
- use type Interfaces.C.int;
----------------------
-- Global Variables --
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2017, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
is
Target : constant ST.Task_Id := Convert_Ids (T);
- use type ST.Dispatching_Domain_Access;
-
begin
-- The exception Dispatching_Domain_Error is propagated if T is already
-- assigned to a Dispatching_Domain other than
use type ST.Dispatching_Domain;
use type ST.Dispatching_Domain_Access;
- use type ST.Array_Allocated_Tasks;
use type ST.Task_Id;
T : ST.Task_Id;
is
Target : constant ST.Task_Id := Convert_Ids (T);
- use type ST.Dispatching_Domain_Access;
-
begin
-- The exception Dispatching_Domain_Error is propagated if CPU is not
-- one of the processors of the Dispatching_Domain on which T is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
Self_Id : constant Task_Id := Entry_Call.Self;
Timedout : Boolean := False;
- use type Ada.Exceptions.Exception_Id;
-
begin
-- This procedure waits for the entry call to be served, with a timeout.
-- It tries to cancel the call if the timeout expires before the call is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
- use type System.Multiprocessors.CPU_Range;
-
begin
Environment_Task_Id := Environment_Task;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- routines in this package, and more to the point, if we try to poll it can
-- cause infinite loops.
-with Ada.Exceptions;
-
with System.Task_Primitives;
with System.Task_Primitives.Operations;
with System.Soft_Links;
-- Call only when holding no locks
procedure Do_Pending_Action (Self_ID : Task_Id) is
- use type Ada.Exceptions.Exception_Id;
begin
pragma Assert (Self_ID = Self and then Self_ID.Deferral_Level = 0);
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
Source : Ada.Exceptions.Exception_Occurrence);
pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
- use type STPE.Protection_Entries_Access;
-
begin
-- The deferral level is critical here, since we want to raise an
-- exception or allow abort to take place, if there is an exception or
Pop_Scope;
end Remove_Scope;
- Saved_SM : constant SPARK_Mode_Type := SPARK_Mode;
- Saved_SMP : constant Node_Id := SPARK_Mode_Pragma;
+ Saved_SM : SPARK_Mode_Type := SPARK_Mode;
+ Saved_SMP : Node_Id := SPARK_Mode_Pragma;
-- Save the SPARK mode-related data to restore on exit. Removing
- -- eclosing scopes and contexts to provide a clean environment for the
+ -- enclosing scopes and contexts to provide a clean environment for the
-- context of the subunit will eliminate any previously set SPARK_Mode.
-- Start of processing for Analyze_Subunit
Analyze_Subunit_Context;
+ -- Take into account the effect of any SPARK_Mode configuration
+ -- pragma, which takes precedence over a different value of
+ -- SPARK_Mode inherited from the context of the stub.
+
+ if SPARK_Mode /= None then
+ Saved_SM := SPARK_Mode;
+ Saved_SMP := SPARK_Mode_Pragma;
+ end if;
+
Re_Install_Parents (Lib_Unit, Par_Unit);
Set_Is_Immediately_Visible (Par_Unit);
Generate_Parent_References (Unit (N), Par_Unit);
-- Reinstall the SPARK_Mode which was in effect prior to any scope and
- -- context manipulations.
+ -- context manipulations, taking into account a possible SPARK_Mode
+ -- configuration pragma if present.
Install_SPARK_Mode (Saved_SM, Saved_SMP);
Prev_Entity : Entity_Id := Empty;
+ procedure Check_For_Null_Excluding_Components
+ (Obj_Typ : Entity_Id;
+ Obj_Decl : Node_Id);
+ -- Recursively verify that each null-excluding component of an object
+ -- declaration's type has explicit initialization, and generate
+ -- compile-time warnings for each one that does not.
+
function Count_Tasks (T : Entity_Id) return Uint;
-- This function is called when a non-generic library level object of a
-- task type is declared. Its function is to count the static number of
-- Any other relevant delayed aspects on object declarations ???
+ -----------------------------------------
+ -- Check_For_Null_Excluding_Components --
+ -----------------------------------------
+
+ procedure Check_For_Null_Excluding_Components
+ (Obj_Typ : Entity_Id;
+ Obj_Decl : Node_Id)
+ is
+
+ procedure Check_Component
+ (Comp_Typ : Entity_Id;
+ Comp_Decl : Node_Id := Empty);
+ -- Perform compile-time null-exclusion checks on a given component
+ -- and all of its subcomponents, if any.
+
+ ---------------------
+ -- Check_Component --
+ ---------------------
+
+ procedure Check_Component
+ (Comp_Typ : Entity_Id;
+ Comp_Decl : Node_Id := Empty)
+ is
+ Comp : Entity_Id;
+ T : Entity_Id;
+
+ begin
+ -- Return without further checking if the component has explicit
+ -- initialization or does not come from source.
+
+ if Present (Comp_Decl) then
+ if not Comes_From_Source (Comp_Decl)
+ or else Present (Expression (Comp_Decl))
+ then
+ return;
+ end if;
+ end if;
+
+ if Is_Incomplete_Or_Private_Type (Comp_Typ)
+ and then Present (Full_View (Comp_Typ))
+ then
+ T := Full_View (Comp_Typ);
+ else
+ T := Comp_Typ;
+ end if;
+
+ -- Verify a component of a null-excluding access type
+
+ if Is_Access_Type (T)
+ and then Can_Never_Be_Null (T)
+ then
+ Null_Exclusion_Static_Checks (Obj_Decl, Comp_Decl);
+
+ -- Check array type components
+
+ elsif Is_Array_Type (T) then
+ -- There is no suitable component when the object is of an
+ -- array type. However, a namable component may appear at some
+ -- point during the recursive inspection, but not at the top
+ -- level.
+
+ if Comp_Decl = Obj_Decl then
+ Check_Component (Component_Type (T));
+ else
+ Check_Component (Component_Type (T), Comp_Decl);
+ end if;
+
+ -- If T allows named components, then iterate through them,
+ -- recursively verifying all subcomponents.
+
+ -- NOTE: Due to the complexities involved with checking components
+ -- of nontrivial types with discriminants (variant records and
+ -- the like), no static checking is performed on them. ???
+
+ elsif (Is_Concurrent_Type (T)
+ or else Is_Incomplete_Or_Private_Type (T)
+ or else Is_Record_Type (T))
+ and then not Has_Discriminants (T)
+ then
+ Comp := First_Component (T);
+ while Present (Comp) loop
+ Check_Component (Etype (Comp), Parent (Comp));
+
+ Comp := Next_Component (Comp);
+ end loop;
+ end if;
+ end Check_Component;
+
+ -- Start processing for Check_For_Null_Excluding_Components
+
+ begin
+ Check_Component (Obj_Typ, Obj_Decl);
+ end Check_For_Null_Excluding_Components;
+
-----------------
-- Count_Tasks --
-----------------
-- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
-- out some static checks.
- if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then
-
+ if Ada_Version >= Ada_2005 then
-- In case of aggregates we must also take care of the correct
-- initialization of nested aggregates bug this is done at the
-- point of the analysis of the aggregate (see sem_aggr.adb) ???
- if Present (Expression (N))
- and then Nkind (Expression (N)) = N_Aggregate
- then
- null;
+ if Can_Never_Be_Null (T) then
+
+ if Present (Expression (N))
+ and then Nkind (Expression (N)) = N_Aggregate
+ then
+ null;
+
+ else
+ declare
+ Save_Typ : constant Entity_Id := Etype (Id);
+ begin
+ Set_Etype (Id, T); -- Temp. decoration for static checks
+ Null_Exclusion_Static_Checks (N);
+ Set_Etype (Id, Save_Typ);
+ end;
+ end if;
+
+ -- We might be dealing with an object of a composite type containing
+ -- null-excluding components without an aggregate, so we must verify
+ -- that such components have default initialization.
else
- declare
- Save_Typ : constant Entity_Id := Etype (Id);
- begin
- Set_Etype (Id, T); -- Temp. decoration for static checks
- Null_Exclusion_Static_Checks (N);
- Set_Etype (Id, Save_Typ);
- end;
+ Check_For_Null_Excluding_Components (T, N);
end if;
end if;
and then Ekind (Entity (E1)) = E_Discriminant
and then Ekind (Entity (E2)) = E_In_Parameter)
+ -- The discriminant of a protected type is transformed into
+ -- a local constant and then into a parameter of a protected
+ -- operation.
+
+ or else (Ekind (Entity (E1)) = E_Constant
+ and then Ekind (Entity (E2)) = E_In_Parameter
+ and then Present (Discriminal_Link (Entity (E1)))
+ and then Discriminal_Link (Entity (E1)) =
+ Discriminal_Link (Entity (E2)))
+
-- AI12-050: The loop variables of quantified expressions
-- match if they have the same identifier, even though they
-- are different entities.
projects / gcc.git / commitdiff