+2017-05-02 Tristan Gingold <gingold@adacore.com>
+
+ * s-trasym.ads: Add comment.
+
+2017-05-02 Bob Duff <duff@adacore.com>
+
+ * sem_elab.adb, sem_elab.ads: Minor comment fixes.
+ * sem_ch4.adb: Minor reformatting.
+ * s-taprop-linux.adb, s-taspri-posix.ads: Code refactoring.
+ * s-taspri-posix-noaltstack.ads: Minor refactoring.
+ * sinput.ads: Minor typo fix.
+
+2017-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch9.adb (Discriminated_Size): Moved to sem_util.
+ * sem_util.ads, sem_util.adb (Discriminated_Size): Predicate moved
+ here from exp_ch9, to recognize objects whose creation requires
+ dynamic allocation, so that the proper warning can be emitted
+ when restriction No_Implicit_Heap_Allocation is in effect.
+ * sem_ch3.adb (Analyze_Object_Declaration): Use Discriminated_Size
+ to emit proper warning when an object that requires dynamic
+ allocation is declared.
+
2017-05-02 Tristan Gingold <gingold@adacore.com>
* s-trasym.ads, s-trasym.adb (Enable_Cache): New.
-- to the internal body, for possible inlining later on. The source
-- operation is invisible to the back-end and is never actually called.
- function Discriminated_Size (Comp : Entity_Id) return Boolean;
- -- If a component size is not static then a warning will be emitted
- -- in Ravenscar or other restricted contexts. When a component is non-
- -- static because of a discriminant constraint we can specialize the
- -- warning by mentioning discriminants explicitly.
-
procedure Expand_Entry_Declaration (Decl : Node_Id);
-- Create the entry barrier and the procedure body for entry declaration
-- Decl. All generated subprograms are added to Entry_Bodies_Array.
end if;
end Check_Inlining;
- ------------------------
- -- Discriminated_Size --
- ------------------------
-
- function Discriminated_Size (Comp : Entity_Id) return Boolean is
- Typ : constant Entity_Id := Etype (Comp);
- Index : Node_Id;
-
- function Non_Static_Bound (Bound : Node_Id) return Boolean;
- -- Check whether the bound of an index is non-static and does denote
- -- a discriminant, in which case any protected object of the type
- -- will have a non-static size.
-
- ----------------------
- -- Non_Static_Bound --
- ----------------------
-
- function Non_Static_Bound (Bound : Node_Id) return Boolean is
- begin
- if Is_OK_Static_Expression (Bound) then
- return False;
-
- elsif Is_Entity_Name (Bound)
- and then Present (Discriminal_Link (Entity (Bound)))
- then
- return False;
-
- else
- return True;
- end if;
- end Non_Static_Bound;
-
- -- Start of processing for Discriminated_Size
-
- begin
- if not Is_Array_Type (Typ) then
- return False;
- end if;
-
- if Ekind (Typ) = E_Array_Subtype then
- Index := First_Index (Typ);
- while Present (Index) loop
- if Non_Static_Bound (Low_Bound (Index))
- or else Non_Static_Bound (High_Bound (Index))
- then
- return False;
- end if;
-
- Next_Index (Index);
- end loop;
-
- return True;
- end if;
-
- return False;
- end Discriminated_Size;
-
---------------------------
-- Static_Component_Size --
---------------------------
pragma Import (C,
GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
+ type RTS_Lock_Ptr is not null access all RTS_Lock;
+
+ function Init_Mutex
+ (L : RTS_Lock_Ptr; Prio : Any_Priority)
+ return Interfaces.C.int;
+ -- Initialize the mutex L. If the locking policy is Ceiling_Locking, then
+ -- set the ceiling to Prio.
+
-------------------
-- Abort_Handler --
-------------------
function Self return Task_Id renames Specific.Self;
+ ----------------
+ -- Init_Mutex --
+ ----------------
+
+ function Init_Mutex
+ (L : RTS_Lock_Ptr; Prio : Any_Priority)
+ return Interfaces.C.int
+ is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+ begin
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ return ENOMEM;
+ end if;
+
+ if Locking_Policy = 'C' then
+ if Superuser then
+ Result := pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Mutex_Attr'Access, Interfaces.C.int (Prio));
+ pragma Assert (Result = 0);
+ end if;
+
+ elsif Locking_Policy = 'I' then
+ Result := pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_mutex_init (L, Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ return ENOMEM;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+ return 0;
+ end Init_Mutex;
+
---------------------
-- Initialize_Lock --
---------------------
end;
else
- declare
- Attributes : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
-
- begin
- Result := pthread_mutexattr_init (Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- if Locking_Policy = 'C' then
- if Superuser then
- Result := pthread_mutexattr_setprotocol
- (Attributes'Access, PTHREAD_PRIO_PROTECT);
- pragma Assert (Result = 0);
-
- Result := pthread_mutexattr_setprioceiling
- (Attributes'Access, Interfaces.C.int (Prio));
- pragma Assert (Result = 0);
- end if;
-
- elsif Locking_Policy = 'I' then
- Result := pthread_mutexattr_setprotocol
- (Attributes'Access, PTHREAD_PRIO_INHERIT);
- pragma Assert (Result = 0);
- end if;
-
- Result := pthread_mutex_init (L.WO'Access, Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- Result := pthread_mutexattr_destroy (Attributes'Access);
- raise Storage_Error with "Failed to allocate a lock";
- end if;
-
- Result := pthread_mutexattr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
- end;
+ if Init_Mutex (L.WO'Access, Prio) = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
+ end if;
end if;
end Initialize_Lock;
(L : not null access RTS_Lock; Level : Lock_Level)
is
pragma Unreferenced (Level);
-
- Attributes : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
-
begin
- Result := pthread_mutexattr_init (Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- raise Storage_Error;
- end if;
-
- if Locking_Policy = 'C' then
- if Superuser then
- Result := pthread_mutexattr_setprotocol
- (Attributes'Access, PTHREAD_PRIO_PROTECT);
- pragma Assert (Result = 0);
-
- Result := pthread_mutexattr_setprioceiling
- (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last));
- pragma Assert (Result = 0);
- end if;
-
- elsif Locking_Policy = 'I' then
- Result := pthread_mutexattr_setprotocol
- (Attributes'Access, PTHREAD_PRIO_INHERIT);
- pragma Assert (Result = 0);
+ if Init_Mutex (L.all'Access, Any_Priority'Last) = ENOMEM then
+ raise Storage_Error with "Failed to allocate a lock";
end if;
-
- Result := pthread_mutex_init (L, Attributes'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = ENOMEM then
- Result := pthread_mutexattr_destroy (Attributes'Access);
- raise Storage_Error;
- end if;
-
- Result := pthread_mutexattr_destroy (Attributes'Access);
- pragma Assert (Result = 0);
end Initialize_Lock;
-------------------
--------------------
procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is
- Mutex_Attr : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
Cond_Attr : aliased pthread_condattr_t;
Self_ID.Common.LL.Thread := Null_Thread_Id;
if not Single_Lock then
- Result := pthread_mutexattr_init (Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
-
- if Result = 0 then
- if Locking_Policy = 'C' then
- if Superuser then
- Result :=
- pthread_mutexattr_setprotocol
- (Mutex_Attr'Access,
- PTHREAD_PRIO_PROTECT);
- pragma Assert (Result = 0);
-
- Result :=
- pthread_mutexattr_setprioceiling
- (Mutex_Attr'Access,
- Interfaces.C.int (System.Any_Priority'Last));
- pragma Assert (Result = 0);
- end if;
-
- elsif Locking_Policy = 'I' then
- Result :=
- pthread_mutexattr_setprotocol
- (Mutex_Attr'Access,
- PTHREAD_PRIO_INHERIT);
- pragma Assert (Result = 0);
- end if;
-
- Result :=
- pthread_mutex_init
- (Self_ID.Common.LL.L'Access,
- Mutex_Attr'Access);
- pragma Assert (Result = 0 or else Result = ENOMEM);
- end if;
-
- if Result /= 0 then
+ if Init_Mutex
+ (Self_ID.Common.LL.L'Access, System.Any_Priority'Last) /= 0
+ then
Succeeded := False;
return;
end if;
-
- Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
- pragma Assert (Result = 0);
end if;
Result := pthread_condattr_init (Cond_Attr'Access);
Priority : System.Any_Priority;
Succeeded : out Boolean)
is
- Attributes : aliased pthread_attr_t;
+ Thread_Attr : aliased pthread_attr_t;
Adjusted_Stack_Size : Interfaces.C.size_t;
Result : Interfaces.C.int;
Adjusted_Stack_Size :=
Interfaces.C.size_t (Stack_Size + Alternate_Stack_Size);
- Result := pthread_attr_init (Attributes'Access);
+ Result := pthread_attr_init (Thread_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result /= 0 then
end if;
Result :=
- pthread_attr_setstacksize (Attributes'Access, Adjusted_Stack_Size);
+ pthread_attr_setstacksize (Thread_Attr'Access, Adjusted_Stack_Size);
pragma Assert (Result = 0);
Result :=
pthread_attr_setdetachstate
- (Attributes'Access, PTHREAD_CREATE_DETACHED);
+ (Thread_Attr'Access, PTHREAD_CREATE_DETACHED);
pragma Assert (Result = 0);
-- Set the required attributes for the creation of the thread
System.OS_Interface.CPU_SET
(int (T.Common.Base_CPU), Size, CPU_Set);
Result :=
- pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set);
+ pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set);
pragma Assert (Result = 0);
CPU_FREE (CPU_Set);
elsif T.Common.Task_Info /= null then
Result :=
pthread_attr_setaffinity_np
- (Attributes'Access,
+ (Thread_Attr'Access,
CPU_SETSIZE / 8,
T.Common.Task_Info.CPU_Affinity'Access);
pragma Assert (Result = 0);
end loop;
Result :=
- pthread_attr_setaffinity_np (Attributes'Access, Size, CPU_Set);
+ pthread_attr_setaffinity_np (Thread_Attr'Access, Size, CPU_Set);
pragma Assert (Result = 0);
CPU_FREE (CPU_Set);
Result := pthread_create
(T.Common.LL.Thread'Unrestricted_Access,
- Attributes'Access,
+ Thread_Attr'Access,
Thread_Body_Access (Wrapper),
To_Address (T));
if Result /= 0 then
Succeeded := False;
- Result := pthread_attr_destroy (Attributes'Access);
+ Result := pthread_attr_destroy (Thread_Attr'Access);
pragma Assert (Result = 0);
return;
end if;
Succeeded := True;
- Result := pthread_attr_destroy (Attributes'Access);
+ Result := pthread_attr_destroy (Thread_Attr'Access);
pragma Assert (Result = 0);
Set_Priority (T, Priority);
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2014, AdaCore --
+-- Copyright (C) 1995-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- --
private
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+
type Lock is record
- WO : aliased System.OS_Interface.pthread_mutex_t;
+ WO : aliased RTS_Lock;
RW : aliased System.OS_Interface.pthread_rwlock_t;
end record;
- type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
type Suspension_Object is record
State : Boolean;
pragma Atomic (State);
Waiting : Boolean;
-- Flag showing if there is a task already suspended on this object
- L : aliased System.OS_Interface.pthread_mutex_t;
+ L : aliased RTS_Lock;
-- Protection for ensuring mutual exclusion on the Suspension_Object
CV : aliased System.OS_Interface.pthread_cond_t;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2014, AdaCore --
+-- Copyright (C) 1995-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- --
private
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
+
type Lock is record
RW : aliased System.OS_Interface.pthread_rwlock_t;
- WO : aliased System.OS_Interface.pthread_mutex_t;
+ WO : aliased RTS_Lock;
end record;
- type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
-
type Suspension_Object is record
State : Boolean;
pragma Atomic (State);
Waiting : Boolean;
-- Flag showing if there is a task already suspended on this object
- L : aliased System.OS_Interface.pthread_mutex_t;
+ L : aliased RTS_Lock;
-- Protection for ensuring mutual exclusion on the Suspension_Object
CV : aliased System.OS_Interface.pthread_cond_t;
-- Read symbolic information from binary files and cache them in memory.
-- This will speed up the above functions but will require more memory.
-- If Include_Modules is true, shared modules (or DLL) will also be cached.
- -- This procedure may do nothing if not supported.
+ -- This procedure may do nothing if not supported. The profile of this
+ -- subprogram may change in the future (new parameters can be added with
+ -- default value), but backward compatibility for direct calls is
+ -- supported.
end System.Traceback.Symbolic;
when N_Derived_Type_Definition =>
Derived_Type_Declaration (T, N, T /= Def_Id);
+ if Ekind (T) /= E_Void and then Has_Predicates (T) then -- ????
+ Set_Has_Predicates (Def_Id);
+ end if;
when N_Enumeration_Type_Definition =>
Enumeration_Type_Declaration (T, Def);
Prev_Entity : Entity_Id := Empty;
+ procedure Check_Dynamic_Object (Typ : Entity_Id);
+ -- A library-level object with non-static discriminant constraints may
+ -- require dynamic allocation. The declaration is illegal if the
+ -- profile includes the restriction No_Implicit_Heap_Allocations.
+
procedure Check_For_Null_Excluding_Components
(Obj_Typ : Entity_Id;
Obj_Decl : Node_Id);
-- Any other relevant delayed aspects on object declarations ???
+ procedure Check_Dynamic_Object (Typ : Entity_Id) is
+ Comp : Entity_Id;
+ Obj_Type : Entity_Id;
+
+ begin
+ Obj_Type := Typ;
+ if Is_Private_Type (Obj_Type)
+ and then Present (Full_View (Obj_Type))
+ then
+ Obj_Type := Full_View (Obj_Type);
+ end if;
+
+ if Known_Static_Esize (Obj_Type) then
+ return;
+ end if;
+
+ if Restriction_Active (No_Implicit_Heap_Allocations)
+ and then Expander_Active
+ and then Has_Discriminants (Obj_Type)
+ then
+ Comp := First_Component (Obj_Type);
+ while Present (Comp) loop
+ if Known_Static_Esize (Etype (Comp)) then
+ null;
+
+ elsif not Discriminated_Size (Comp)
+ and then Comes_From_Source (Comp)
+ then
+ Error_Msg_NE ("component& of non-static size will violate "
+ & "restriction No_Implicit_Heap_Allocation?", N, Comp);
+
+ elsif Is_Record_Type (Etype (Comp)) then
+ Check_Dynamic_Object (Etype (Comp));
+ end if;
+ Next_Component (Comp);
+ end loop;
+ end if;
+ end Check_Dynamic_Object;
+
-----------------------------------------
-- Check_For_Null_Excluding_Components --
-----------------------------------------
Object_Definition (N));
end if;
+ if Is_Library_Level_Entity (Id) then
+ Check_Dynamic_Object (T);
+ end if;
+
-- There are no aliased objects in SPARK
if Aliased_Present (N) then
and then Has_Non_Trivial_Precondition (Parent_Subp)
and then Present (Interfaces (Derived_Type))
then
+
+ -- Add useful attributes of subprogram before the freeze point,
+ -- in case freezing is delayed or there are previous errors.
+
Set_Is_Dispatching_Operation (New_Subp);
declare
if Comp = First_Private_Entity (Type_To_Use) then
if Etype (Sel) /= Any_Type then
- -- We have a candiate.
+ -- We have a candiate
+
exit;
else
then
if Present (Hidden_Comp) then
Error_Msg_NE
- ("invalid reference to private component of object "
- & "of type &", N, Type_To_Use);
+ ("invalid reference to private component of object of type "
+ & "&", N, Type_To_Use);
else
Error_Msg_NE
-- Either the types are compatible, or one operand is universal
-- (numeric or null).
- or else ((In_Instance or else In_Inlined_Body)
- and then
- (First_Subtype (T1) = First_Subtype (Etype (R))
- or else Nkind (R) = N_Null
- or else
- (Is_Numeric_Type (T1)
- and then Is_Universal_Numeric_Type (Etype (R)))))
+ or else
+ ((In_Instance or else In_Inlined_Body)
+ and then
+ (First_Subtype (T1) = First_Subtype (Etype (R))
+ or else Nkind (R) = N_Null
+ or else
+ (Is_Numeric_Type (T1)
+ and then Is_Universal_Numeric_Type (Etype (R)))))
-- In Ada 2005, the equality on anonymous access types is declared
-- in Standard, and is always visible.
-- Indirect call case, info message only in static elaboration
-- case, because the attribute reference itself cannot raise an
- -- exception. Note that SPARK does not permit indirect calls.
+ -- exception. Note that SPARK does not permit indirect calls.
elsif Access_Case then
Elab_Warning ("", "info: access to & during elaboration?$?", Ent);
-- not be generated (see detailed description in body).
procedure Check_Task_Activation (N : Node_Id);
- -- Tt the point at which tasks are activated in a package body, check
+ -- At the point at which tasks are activated in a package body, check
-- that the bodies of the tasks are elaborated.
end Sem_Elab;
return Make_Level_Literal (Type_Access_Level (Etype (Expr)));
end Dynamic_Accessibility_Level;
+ ------------------------
+ -- Discriminated_Size --
+ ------------------------
+
+ function Discriminated_Size (Comp : Entity_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (Comp);
+ Index : Node_Id;
+
+ function Non_Static_Bound (Bound : Node_Id) return Boolean;
+ -- Check whether the bound of an index is non-static and does denote
+ -- a discriminant, in which case any object of the type (protected
+ -- or otherwise) will have a non-static size.
+
+ ----------------------
+ -- Non_Static_Bound --
+ ----------------------
+
+ function Non_Static_Bound (Bound : Node_Id) return Boolean is
+ begin
+ if Is_OK_Static_Expression (Bound) then
+ return False;
+
+ -- If the bound is given by a discriminant it is non-static
+ -- (A static constraint replaces the reference with the value).
+ -- In an protected object the discriminant has been replaced by
+ -- the corresponding discriminal within the protected operation.
+
+ elsif Is_Entity_Name (Bound)
+ and then
+ (Ekind (Entity (Bound)) = E_Discriminant
+ or else Present (Discriminal_Link (Entity (Bound))))
+ then
+ return False;
+
+ else
+ return True;
+ end if;
+ end Non_Static_Bound;
+
+ -- Start of processing for Discriminated_Size
+
+ begin
+ if not Is_Array_Type (Typ) then
+ return False;
+ end if;
+
+ if Ekind (Typ) = E_Array_Subtype then
+ Index := First_Index (Typ);
+ while Present (Index) loop
+ if Non_Static_Bound (Low_Bound (Index))
+ or else Non_Static_Bound (High_Bound (Index))
+ then
+ return False;
+ end if;
+
+ Next_Index (Index);
+ end loop;
+
+ return True;
+ end if;
+
+ return False;
+ end Discriminated_Size;
+
-----------------------------------
-- Effective_Extra_Accessibility --
-----------------------------------
-- accessibility levels are tracked at runtime (access parameters and Ada
-- 2012 stand-alone objects).
+ function Discriminated_Size (Comp : Entity_Id) return Boolean;
+ -- If a component size is not static then a warning will be emitted
+ -- in Ravenscar or other restricted contexts. When a component is non-
+ -- static because of a discriminant constraint we can specialize the
+ -- warning by mentioning discriminants explicitly. This was created for
+ -- private components of protected objects, but is generally useful when
+ -- retriction (No_Implicit_Heap_Allocation) is active.
+
function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id;
-- Same as Einfo.Extra_Accessibility except thtat object renames
-- are looked through.
-- NEL code. Now such programs can of course be compiled in UTF-8 mode,
-- but in practice they also compile fine in standard 8-bit mode without
-- specifying a character encoding. Since this is common practice, it would
- -- be a signficant upwards incompatibility to recognize NEL in 8-bit mode.
+ -- be a significant upwards incompatibility to recognize NEL in 8-bit mode.
-----------------
-- Subprograms --
projects / gcc.git / commitdiff