* sem_ch9.adb (Analyze_Entry_Declaration): Check for entry
family bounds out of range.
2011-11-23 Matthew Heaney <heaney@adacore.com>
* a-cohama.adb, a-cihama.adb, a-cbhama.adb (Iterator): Declare
type as limited, and remove node component.
(First, Next): Forward call to corresponding cursor-based operation.
(Iterate): Representation of iterator no longer has node component.
2011-11-23 Yannick Moy <moy@adacore.com>
* exp_util.adb: Revert previous change to remove side-effects in Alfa
mode, which is not the correct thing to do for renamings.
2011-11-23 Thomas Quinot <quinot@adacore.com>
* s-osinte-hpux.ads, s-taprop-vxworks.adb, s-taprop-tru64.adb,
s-osinte-vxworks.ads, s-osinte-aix.ads, s-osinte-lynxos.ads,
s-osinte-solaris-posix.ads, s-taprop-solaris.adb, a-exetim-posix.adb,
s-osinte-irix.ads, s-osinte-solaris.ads, s-oscons-tmplt.c,
s-taprop-irix.adb, s-osinte-hpux-dce.ads, Makefile.rtl,
s-osinte-tru64.ads, s-osinte-darwin.ads, s-taprop.ads,
s-osinte-freebsd.ads, s-osinte-lynxos-3.ads, s-taprop-hpux-dce.adb,
s-taprop-posix.adb: Remove hard-coded clock ids;
instead, generate them in System.OS_Constants.
(System.OS_Constants.CLOCK_RT_Ada): New constant denoting the
id of the clock providing Ada.Real_Time.Monotonic_Clock.
* thread.c: New file.
(__gnat_pthread_condattr_setup): New function. For platforms where
CLOCK_RT_Ada is not CLOCK_REALTIME, set appropriate condition
variable attribute.
2011-11-23 Yannick Moy <moy@adacore.com>
* sem_ch3.adb: Restore the use of Expander_Active instead of
Full_Expander_Active, so that the evaluation is forced in Alfa
mode too. Otherwise, we end up with an unexpected insertion in a
place where it is not supposed to happen, on default parameters
of a call.
2011-11-23 Thomas Quinot <quinot@adacore.com>
* prj-pp.adb, prj-pp.ads: Minor new addition: wrapper procedure "wpr"
for Pretty_Print, for use from within gdb.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@181660
138bc75d-0d04-0410-961f-
82ee72b054a4
+2011-11-23 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch9.adb (Analyze_Entry_Declaration): Check for entry
+ family bounds out of range.
+
+2011-11-23 Matthew Heaney <heaney@adacore.com>
+
+ * a-cohama.adb, a-cihama.adb, a-cbhama.adb (Iterator): Declare
+ type as limited, and remove node component.
+ (First, Next): Forward call to corresponding cursor-based operation.
+ (Iterate): Representation of iterator no longer has node component.
+
+2011-11-23 Yannick Moy <moy@adacore.com>
+
+ * exp_util.adb: Revert previous change to remove side-effects in Alfa
+ mode, which is not the correct thing to do for renamings.
+
+2011-11-23 Thomas Quinot <quinot@adacore.com>
+
+ * s-osinte-hpux.ads, s-taprop-vxworks.adb, s-taprop-tru64.adb,
+ s-osinte-vxworks.ads, s-osinte-aix.ads, s-osinte-lynxos.ads,
+ s-osinte-solaris-posix.ads, s-taprop-solaris.adb, a-exetim-posix.adb,
+ s-osinte-irix.ads, s-osinte-solaris.ads, s-oscons-tmplt.c,
+ s-taprop-irix.adb, s-osinte-hpux-dce.ads, Makefile.rtl,
+ s-osinte-tru64.ads, s-osinte-darwin.ads, s-taprop.ads,
+ s-osinte-freebsd.ads, s-osinte-lynxos-3.ads, s-taprop-hpux-dce.adb,
+ s-taprop-posix.adb: Remove hard-coded clock ids;
+ instead, generate them in System.OS_Constants.
+ (System.OS_Constants.CLOCK_RT_Ada): New constant denoting the
+ id of the clock providing Ada.Real_Time.Monotonic_Clock.
+ * thread.c: New file.
+ (__gnat_pthread_condattr_setup): New function. For platforms where
+ CLOCK_RT_Ada is not CLOCK_REALTIME, set appropriate condition
+ variable attribute.
+
+2011-11-23 Yannick Moy <moy@adacore.com>
+
+ * sem_ch3.adb: Restore the use of Expander_Active instead of
+ Full_Expander_Active, so that the evaluation is forced in Alfa
+ mode too. Otherwise, we end up with an unexpected insertion in a
+ place where it is not supposed to happen, on default parameters
+ of a call.
+
+2011-11-23 Thomas Quinot <quinot@adacore.com>
+
+ * prj-pp.adb, prj-pp.ads: Minor new addition: wrapper procedure "wpr"
+ for Pretty_Print, for use from within gdb.
+
2011-11-23 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Expand_Iterator_Loop): Wrap the expanded loop
s-tpoben$(objext) \
s-tpobop$(objext) \
s-tposen$(objext) \
- s-tratas$(objext) $(EXTRA_GNATRTL_TASKING_OBJS)
+ s-tratas$(objext) \
+ thread$(objext) \
+ $(EXTRA_GNATRTL_TASKING_OBJS)
# Objects needed for non-tasking.
GNATRTL_NONTASKING_OBJS= \
type Iterator is new
Map_Iterator_Interfaces.Forward_Iterator with record
Container : Map_Access;
- Node : Count_Type;
end record;
overriding function First (Object : Iterator) return Cursor;
end First;
function First (Object : Iterator) return Cursor is
- M : constant Map_Access := Object.Container;
- N : constant Count_Type := HT_Ops.First (M.all);
begin
- if N = 0 then
- return No_Element;
- else
- return Cursor'(Object.Container.all'Unchecked_Access, N);
- end if;
+ return Object.Container.First;
end First;
-----------------
end Iterate;
function Iterate
- (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class
+ (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is
- Node : constant Count_Type := HT_Ops.First (Container);
- It : constant Iterator := (Container'Unrestricted_Access, Node);
begin
- return It;
+ return Iterator'(Container => Container'Unrestricted_Access);
end Iterate;
---------
Position : Cursor) return Cursor
is
begin
- if Position.Node = 0 then
+ if Position.Container = null then
return No_Element;
- else
- return (Object.Container, Next (Position).Node);
end if;
+
+ if Position.Container /= Object.Container then
+ raise Program_Error with
+ "Position cursor of Next designates wrong map";
+ end if;
+
+ return Next (Position);
end Next;
-------------------
procedure Free_Element is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
- type Iterator is new
+ type Iterator is limited new
Map_Iterator_Interfaces.Forward_Iterator with record
Container : Map_Access;
- Node : Node_Access;
end record;
overriding function First (Object : Iterator) return Cursor;
end First;
function First (Object : Iterator) return Cursor is
- M : constant Map_Access := Object.Container;
- N : constant Node_Access := HT_Ops.First (M.HT);
begin
- if N = null then
- return No_Element;
- else
- return Cursor'(Object.Container.all'Unchecked_Access, N);
- end if;
+ return Object.Container.First;
end First;
----------
B := B - 1;
end Iterate;
- function Iterate (Container : Map)
- return Map_Iterator_Interfaces.Forward_Iterator'class
+ function Iterate
+ (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is
- Node : constant Node_Access := HT_Ops.First (Container.HT);
- It : constant Iterator := (Container'Unrestricted_Access, Node);
begin
- return It;
+ return Iterator'(Container => Container'Unrestricted_Access);
end Iterate;
---------
function Next (Object : Iterator; Position : Cursor) return Cursor is
begin
- if Position.Node = null then
+ if Position.Container = null then
return No_Element;
- else
- return (Object.Container, Next (Position).Node);
end if;
+
+ if Position.Container /= Object.Container then
+ raise Program_Error with
+ "Position cursor of Next designates wrong map";
+ end if;
+
+ return Next (Position);
end Next;
-------------------
package body Ada.Containers.Hashed_Maps is
- type Iterator is new
+ type Iterator is limited new
Map_Iterator_Interfaces.Forward_Iterator with record
Container : Map_Access;
- Node : Node_Access;
end record;
overriding function First (Object : Iterator) return Cursor;
end First;
function First (Object : Iterator) return Cursor is
- M : constant Map_Access := Object.Container;
- N : constant Node_Access := HT_Ops.First (M.HT);
begin
- if N = null then
- return No_Element;
- end if;
-
- return Cursor'(Object.Container.all'Unchecked_Access, N);
+ return Object.Container.First;
end First;
----------
end Iterate;
function Iterate
- (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class
+ (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is
- Node : constant Node_Access := HT_Ops.First (Container.HT);
- It : constant Iterator := (Container'Unrestricted_Access, Node);
begin
- return It;
+ return Iterator'(Container => Container'Unrestricted_Access);
end Iterate;
---------
Position : Cursor) return Cursor
is
begin
- if Position.Node = null then
+ if Position.Container = null then
return No_Element;
- else
- return (Object.Container, Next (Position).Node);
end if;
+
+ if Position.Container /= Object.Container then
+ raise Program_Error with
+ "Position cursor of Next designates wrong map";
+ end if;
+
+ return Next (Position);
end Next;
-------------------
with Ada.Task_Identification; use Ada.Task_Identification;
with Ada.Unchecked_Conversion;
+with System.OS_Constants; use System.OS_Constants;
with System.OS_Interface; use System.OS_Interface;
with Interfaces.C; use Interfaces.C;
pragma Import (C, clock_gettime, "clock_gettime");
-- Function from the POSIX.1b Realtime Extensions library
- CLOCK_THREAD_CPUTIME_ID : constant := 3;
- -- Identifier for the clock returning per-task CPU time
-
begin
if T = Ada.Task_Identification.Null_Task_Id then
raise Program_Error;
-- Start of processing for Remove_Side_Effects
begin
- -- We only need to do removal of side effects if we are generating
- -- actual code. That's because the whole issue of side effects is purely
- -- a run-time issue, and the removal is required only to get proper
- -- behavior at run-time.
-
- -- In the Alfa case, we don't need to remove side effects because formal
- -- verification is performed only on expressions that are provably
- -- side-effect free. If we tried to remove side effects in the Alfa
- -- case, we would get into a mess since in the case of limited types in
- -- particular, removal of side effects involves the use of access types
- -- or references which are not permitted in Alfa mode.
-
- if not Full_Expander_Active then
+ -- Handle cases in which there is nothing to do
+
+ if not Expander_Active then
return;
end if;
-- Otherwise we generate a reference to the value
else
+ -- An expression which is in Alfa mode is considered side effect free
+ -- if the resulting value is captured by a variable or a constant.
+
+ if Alfa_Mode
+ and then Nkind (Parent (Exp)) = N_Object_Declaration
+ then
+ return;
+ end if;
+
-- Special processing for function calls that return a limited type.
-- We need to build a declaration that will enable build-in-place
-- expansion of the call. This is not done if the context is already
Def_Id := Make_Temporary (Loc, 'R', Exp);
Set_Etype (Def_Id, Exp_Type);
- Res :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Def_Id, Loc));
+ -- The regular expansion of functions with side effects involves the
+ -- generation of an access type to capture the return value found on
+ -- the secondary stack. Since Alfa (and why) cannot process access
+ -- types, use a different approach which ignores the secondary stack
+ -- and "copies" the returned object.
- -- Generate:
- -- type Ann is access all <Exp_Type>;
+ if Alfa_Mode then
+ Res := New_Reference_To (Def_Id, Loc);
+ Ref_Type := Exp_Type;
+
+ -- Regular expansion utilizing an access type and 'reference
- Ref_Type := Make_Temporary (Loc, 'A');
+ else
+ Res :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Reference_To (Def_Id, Loc));
- Ptr_Typ_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ref_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication =>
- New_Reference_To (Exp_Type, Loc)));
+ -- Generate:
+ -- type Ann is access all <Exp_Type>;
- Insert_Action (Exp, Ptr_Typ_Decl);
+ Ref_Type := Make_Temporary (Loc, 'A');
+
+ Ptr_Typ_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ref_Type,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Reference_To (Exp_Type, Loc)));
+
+ Insert_Action (Exp, Ptr_Typ_Decl);
+ end if;
E := Exp;
if Nkind (E) = N_Explicit_Dereference then
Output.Write_Eol;
end Output_Statistics;
+ ---------
+ -- wpr --
+ ---------
+
+ procedure wpr
+ (Project : Prj.Tree.Project_Node_Id;
+ In_Tree : Prj.Tree.Project_Node_Tree_Ref) is
+ begin
+ Pretty_Print (Project, In_Tree, Backward_Compatibility => False);
+ end wpr;
+
end Prj.PP;
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
-- display what Project_Node_Kinds have not been exercised by the call(s)
-- to Pretty_Print. It is used only for testing purposes.
+ procedure wpr
+ (Project : Prj.Tree.Project_Node_Id;
+ In_Tree : Prj.Tree.Project_Node_Tree_Ref);
+ -- Wrapper for use from gdb: call Pretty_Print with default parameters
+
end Prj.PP;
#include <string.h>
#include <limits.h>
#include <fcntl.h>
+#include <time.h>
#if defined (__alpha__) && defined (__osf__)
/** Tru64 is unable to do vector IO operations with default value of IOV_MAX,
#endif
CND(IP_PKTINFO, "Get datagram info")
+#endif /* HAVE_SOCKETS */
+
+/*
+
+ ------------
+ -- Clocks --
+ ------------
+
+*/
+
+#ifdef CLOCK_REALTIME
+CND(CLOCK_REALTIME, "System realtime clock")
+#endif
+
+#ifdef CLOCK_MONOTONIC
+CND(CLOCK_MONOTONIC, "System monotonic clock")
+#endif
+
+#ifdef CLOCK_FASTEST
+CND(CLOCK_FASTEST, "Fastest clock")
+#endif
+
+#if defined (__sgi)
+CND(CLOCK_SGI_FAST, "SGI fast clock")
+CND(CLOCK_SGI_CYCLE, "SGI CPU clock")
+#endif
+
+#if defined(__APPLE__)
+/* There's no clock_gettime or clock_id's on Darwin */
+# define CLOCK_RT_Ada "-1"
+
+#elif defined(FreeBSD) || defined(_AIX)
+/* On these platforms use system provided monotonic clock */
+# define CLOCK_RT_Ada "CLOCK_MONOTONIC"
+
+#elif defined(CLOCK_REALTIME)
+/* By default use CLOCK_REALTIME */
+# define CLOCK_RT_Ada "CLOCK_REALTIME"
+#endif
+
+#ifdef CLOCK_RT_Ada
+CNS(CLOCK_RT_Ada, "Ada realtime clock")
+#endif
+
+#ifndef CLOCK_THREAD_CPUTIME_ID
+# define CLOCK_THREAD_CPUTIME_ID -1
+#endif
+CND(CLOCK_THREAD_CPUTIME_ID, "Thread CPU clock")
+
/*
----------------------
type timespec is private;
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
- CLOCK_MONOTONIC : constant clockid_t;
+ type clockid_t is new int;
function clock_gettime
(clock_id : clockid_t;
end record;
pragma Convention (C, timespec);
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 9;
- CLOCK_MONOTONIC : constant clockid_t := 10;
-
type pthread_attr_t is new System.Address;
pragma Convention (C, pthread_attr_t);
-- typedef struct __pt_attr *pthread_attr_t;
type timespec is private;
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
- CLOCK_MONOTONIC : constant clockid_t;
+ type clockid_t is new int;
function clock_gettime
(clock_id : clockid_t;
end record;
pragma Convention (C, timespec);
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 0;
- CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME;
-
--
-- Darwin specific signal implementation
--
function nanosleep (rqtp, rmtp : access timespec) return int;
pragma Import (C, nanosleep, "nanosleep");
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
- CLOCK_MONOTONIC : constant clockid_t;
+ type clockid_t is new int;
function clock_gettime
(clock_id : clockid_t;
end record;
pragma Convention (C, timespec);
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 0;
- CLOCK_MONOTONIC : constant clockid_t := 0;
- -- On FreeBSD, pthread_cond_timedwait assumes a CLOCK_REALTIME time by
- -- default (unless pthread_condattr_setclock is used to set an alternate
- -- clock).
-
type pthread_t is new System.Address;
type pthread_attr_t is new System.Address;
type pthread_mutex_t is new System.Address;
type timespec is private;
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
- CLOCK_MONOTONIC : constant clockid_t;
+ type clockid_t is new int;
function clock_gettime
(clock_id : clockid_t;
end record;
pragma Convention (C, timespec);
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 1;
- CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME;
-
type pthread_attr_t is new int;
type pthread_condattr_t is new int;
type pthread_mutexattr_t is new int;
type timespec is private;
type timespec_ptr is access all timespec;
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
- CLOCK_SGI_FAST : constant clockid_t;
- CLOCK_SGI_CYCLE : constant clockid_t;
+ type clockid_t is new int;
SGI_CYCLECNTR_SIZE : constant := 165;
end record;
pragma Convention (C, timespec);
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 1;
- CLOCK_SGI_CYCLE : constant clockid_t := 2;
- CLOCK_SGI_FAST : constant clockid_t := 3;
-
type array_type_9 is array (Integer range 0 .. 4) of long;
type pthread_attr_t is record
X_X_D : array_type_9;
type timespec is private;
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
+ type clockid_t is new int;
function clock_gettime
(clock_id : clockid_t;
end record;
pragma Convention (C, timespec);
- type clockid_t is new unsigned_char;
- CLOCK_REALTIME : constant clockid_t := 0;
-
type st_t is record
stksize : int;
prio : int;
type timespec is private;
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
- CLOCK_MONOTONIC : constant clockid_t;
+ type clockid_t is new int;
function clock_gettime
(clock_id : clockid_t;
end record;
pragma Convention (C, timespec);
- type clockid_t is new unsigned_char;
- CLOCK_REALTIME : constant clockid_t := 1;
- CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME;
-
type st_attr_t is record
stksize : int;
prio : int;
type timespec is private;
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
- CLOCK_MONOTONIC : constant clockid_t;
+ type clockid_t is new int;
function clock_gettime
(clock_id : clockid_t;
end record;
pragma Convention (C, timespec);
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 3;
- CLOCK_MONOTONIC : constant clockid_t := CLOCK_REALTIME;
-
type pthread_attr_t is record
pthread_attrp : System.Address;
end record;
type timespec is private;
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
+ type clockid_t is new int;
function clock_gettime
(clock_id : clockid_t; tp : access timespec) return int;
end record;
pragma Convention (C, timespec);
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 0;
-
type array_type_9 is array (0 .. 3) of unsigned_char;
type record_type_3 is record
flag : array_type_9;
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-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- --
function nanosleep (rqtp, rmtp : access timespec) return int;
pragma Import (C, nanosleep);
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
+ type clockid_t is new int;
function clock_gettime
(clock_id : clockid_t;
end record;
pragma Convention (C, timespec);
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 1;
-
type unsigned_long_array is array (Natural range <>) of unsigned_long;
type pthread_t is new System.Address;
end record;
pragma Convention (C, timespec);
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t; -- System wide realtime clock
+ type clockid_t is new int;
function To_Duration (TS : timespec) return Duration;
pragma Inline (To_Duration);
ERROR_PID : constant pid_t := -1;
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 0;
-
type sigset_t is new System.VxWorks.Ext.sigset_t;
end System.OS_Interface;
TS : aliased timespec;
Result : Interfaces.C.int;
begin
- Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access);
+ Result := Clock_Gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
pragma Assert (Result = 0);
return To_Duration (TS);
end Monotonic_Clock;
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
- Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME;
-
Unblocked_Signal_Mask : aliased sigset_t;
Foreign_Task_Elaborated : aliased Boolean := True;
TS : aliased timespec;
Result : Interfaces.C.int;
begin
- Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access);
+ Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
pragma Assert (Result = 0);
return To_Duration (TS);
end Monotonic_Clock;
function RT_Resolution return Duration is
begin
- -- The clock_getres (Real_Time_Clock_Id) function appears to return
+ -- The clock_getres (OSC.CLOCK_RT_Ada) function appears to return
-- the interrupt resolution of the realtime clock and not the actual
-- resolution of reading the clock. Even though this last value is
-- only guaranteed to be 100 Hz, at least the Origin 200 appears to
function To_Address is
new Ada.Unchecked_Conversion (Task_Id, System.Address);
+ function GNAT_pthread_condattr_setup
+ (attr : access pthread_condattr_t) return int;
+ pragma Import (C,
+ GNAT_pthread_condattr_setup, "__gnat_pthread_condattr_setup");
+
-------------------
-- Abort_Handler --
-------------------
Result : Interfaces.C.int;
begin
Result := clock_gettime
- (clock_id => CLOCK_MONOTONIC, tp => TS'Unchecked_Access);
+ (clock_id => OSC.CLOCK_RT_Ada, tp => TS'Unchecked_Access);
pragma Assert (Result = 0);
return To_Duration (TS);
end Monotonic_Clock;
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
+ Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+
Result :=
pthread_cond_init
(Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
-- underlying OS entities fails.
raise Storage_Error;
+
+ else
+ Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
+ pragma Assert (Result = 0);
end if;
Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
TS : aliased timespec;
Result : Interfaces.C.int;
begin
- Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
+ Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
pragma Assert (Result = 0);
return To_Duration (TS);
end Monotonic_Clock;
TS : aliased timespec;
Result : Interfaces.C.int;
begin
- Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
+ Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
pragma Assert (Result = 0);
return To_Duration (TS);
end Monotonic_Clock;
TS : aliased timespec;
Result : int;
begin
- Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
+ Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
pragma Assert (Result = 0);
return To_Duration (TS);
end Monotonic_Clock;
with System.Parameters;
with System.Tasking;
+with System.OS_Constants;
with System.OS_Interface;
package System.Task_Primitives.Operations is
pragma Preelaborate;
package ST renames System.Tasking;
+ package OSC renames System.OS_Constants;
package OSI renames System.OS_Interface;
procedure Initialize (Environment_Task : ST.Task_Id);
-- needed, since checks may cause duplication of the expressions
-- which must not be reevaluated.
- if Full_Expander_Active then
+ if Expander_Active then
Force_Evaluation (Low_Bound (R));
Force_Evaluation (High_Bound (R));
end if;
-- if needed, before applying checks, since checks may cause
-- duplication of the expression without forcing evaluation.
- if Full_Expander_Active then
+ if Expander_Active then
Force_Evaluation (Lo);
Force_Evaluation (Hi);
end if;
-- Case of other than an explicit N_Range node
- elsif Full_Expander_Active then
+ elsif Expander_Active then
Get_Index_Bounds (R, Lo, Hi);
Force_Evaluation (Lo);
Force_Evaluation (Hi);
Bad_Predicated_Subtype_Use
("subtype& has predicate, not allowed in entry family",
D_Sdef, Etype (D_Sdef));
+
+ -- Check entry family static bounds outside allowed limits
+
+ -- Note: originally this check was not performed here, but in that
+ -- case the check happens deep in the expander, and the message is
+ -- posted at the wrong location, and omitted in -gnatc mode.
+
+ declare
+ PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index);
+ LB : constant Uint := Expr_Value (Type_Low_Bound (PEI));
+ UB : constant Uint := Expr_Value (Type_High_Bound (PEI));
+
+ LBR : Node_Id;
+ UBR : Node_Id;
+
+ begin
+ if Nkind (D_Sdef) = N_Range then
+ LBR := Low_Bound (D_Sdef);
+ elsif Is_Entity_Name (D_Sdef)
+ and then Is_Type (Entity (D_Sdef))
+ then
+ LBR := Type_Low_Bound (Entity (D_Sdef));
+ else
+ goto Skip_LB;
+ end if;
+
+ if Is_Static_Expression (LBR)
+ and then Expr_Value (LBR) < LB
+ then
+ Error_Msg_Uint_1 := LB;
+ Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef);
+ end if;
+
+ <<Skip_LB>>
+ if Nkind (D_Sdef) = N_Range then
+ UBR := High_Bound (D_Sdef);
+ elsif Is_Entity_Name (D_Sdef)
+ and then Is_Type (Entity (D_Sdef))
+ then
+ UBR := Type_High_Bound (Entity (D_Sdef));
+ else
+ goto Skip_UB;
+ end if;
+
+ if Is_Static_Expression (UBR)
+ and then Expr_Value (UBR) > UB
+ then
+ Error_Msg_Uint_1 := UB;
+ Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef);
+ end if;
+
+ <<Skip_UB>>
+ null;
+ end;
end if;
-- Decorate Def_Id
--- /dev/null
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * T H R E A D *
+ * *
+ * C Implementation File *
+ * *
+ * Copyright (C) 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- *
+ * ware Foundation; either version 3, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. *
+ * *
+ * As a special exception under Section 7 of GPL version 3, you are granted *
+ * additional permissions described in the GCC Runtime Library Exception, *
+ * version 3.1, as published by the Free Software Foundation. *
+ * *
+ * You should have received a copy of the GNU General Public License and *
+ * a copy of the GCC Runtime Library Exception along with this program; *
+ * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
+ * <http://www.gnu.org/licenses/>. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * Extensive contributions were provided by Ada Core Technologies Inc. *
+ * *
+ ****************************************************************************/
+
+/* This file provides utility functions to access the threads API */
+
+#include <pthread.h>
+#include <time.h>
+#include "s-oscons.h"
+
+int
+__gnat_pthread_condattr_setup(pthread_condattr_t *attr) {
+/*
+ * If using a clock other than CLOCK_REALTIME for the Ada Monotonic_Clock,
+ * the corresponding clock id must be set for condition variables.
+ * There are no clock_id's on Darwin.
+ */
+#if defined(__APPLE__) || ((CLOCK_RT_Ada) == (CLOCK_REALTIME))
+ return 0;
+#else
+ return pthread_condattr_setclock (attr, CLOCK_RT_Ada);
+#endif
+}
OSDN Git Service
