Commit c269a1f5 by Arnaud Charlet

[multiple changes]

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.

From-SVN: r181660
parent f947ee34
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> 2011-11-23 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb (Expand_Iterator_Loop): Wrap the expanded loop * exp_ch5.adb (Expand_Iterator_Loop): Wrap the expanded loop
......
...@@ -75,7 +75,9 @@ GNATRTL_TASKING_OBJS= \ ...@@ -75,7 +75,9 @@ GNATRTL_TASKING_OBJS= \
s-tpoben$(objext) \ s-tpoben$(objext) \
s-tpobop$(objext) \ s-tpobop$(objext) \
s-tposen$(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. # Objects needed for non-tasking.
GNATRTL_NONTASKING_OBJS= \ GNATRTL_NONTASKING_OBJS= \
......
...@@ -41,7 +41,6 @@ package body Ada.Containers.Bounded_Hashed_Maps is ...@@ -41,7 +41,6 @@ package body Ada.Containers.Bounded_Hashed_Maps is
type Iterator is new type Iterator is new
Map_Iterator_Interfaces.Forward_Iterator with record Map_Iterator_Interfaces.Forward_Iterator with record
Container : Map_Access; Container : Map_Access;
Node : Count_Type;
end record; end record;
overriding function First (Object : Iterator) return Cursor; overriding function First (Object : Iterator) return Cursor;
...@@ -424,14 +423,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is ...@@ -424,14 +423,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is
end First; end First;
function First (Object : Iterator) return Cursor is function First (Object : Iterator) return Cursor is
M : constant Map_Access := Object.Container;
N : constant Count_Type := HT_Ops.First (M.all);
begin begin
if N = 0 then return Object.Container.First;
return No_Element;
else
return Cursor'(Object.Container.all'Unchecked_Access, N);
end if;
end First; end First;
----------------- -----------------
...@@ -675,12 +668,10 @@ package body Ada.Containers.Bounded_Hashed_Maps is ...@@ -675,12 +668,10 @@ package body Ada.Containers.Bounded_Hashed_Maps is
end Iterate; end Iterate;
function Iterate function Iterate
(Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is is
Node : constant Count_Type := HT_Ops.First (Container);
It : constant Iterator := (Container'Unrestricted_Access, Node);
begin begin
return It; return Iterator'(Container => Container'Unrestricted_Access);
end Iterate; end Iterate;
--------- ---------
...@@ -770,11 +761,16 @@ package body Ada.Containers.Bounded_Hashed_Maps is ...@@ -770,11 +761,16 @@ package body Ada.Containers.Bounded_Hashed_Maps is
Position : Cursor) return Cursor Position : Cursor) return Cursor
is is
begin begin
if Position.Node = 0 then if Position.Container = null then
return No_Element; return No_Element;
else
return (Object.Container, Next (Position).Node);
end if; 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; end Next;
------------------- -------------------
......
...@@ -45,10 +45,9 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ...@@ -45,10 +45,9 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
procedure Free_Element is procedure Free_Element is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access); new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
type Iterator is new type Iterator is limited new
Map_Iterator_Interfaces.Forward_Iterator with record Map_Iterator_Interfaces.Forward_Iterator with record
Container : Map_Access; Container : Map_Access;
Node : Node_Access;
end record; end record;
overriding function First (Object : Iterator) return Cursor; overriding function First (Object : Iterator) return Cursor;
...@@ -476,14 +475,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ...@@ -476,14 +475,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
end First; end First;
function First (Object : Iterator) return Cursor is function First (Object : Iterator) return Cursor is
M : constant Map_Access := Object.Container;
N : constant Node_Access := HT_Ops.First (M.HT);
begin begin
if N = null then return Object.Container.First;
return No_Element;
else
return Cursor'(Object.Container.all'Unchecked_Access, N);
end if;
end First; end First;
---------- ----------
...@@ -715,13 +708,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ...@@ -715,13 +708,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
B := B - 1; B := B - 1;
end Iterate; end Iterate;
function Iterate (Container : Map) function Iterate
return Map_Iterator_Interfaces.Forward_Iterator'class (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is is
Node : constant Node_Access := HT_Ops.First (Container.HT);
It : constant Iterator := (Container'Unrestricted_Access, Node);
begin begin
return It; return Iterator'(Container => Container'Unrestricted_Access);
end Iterate; end Iterate;
--------- ---------
...@@ -809,11 +800,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ...@@ -809,11 +800,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
function Next (Object : Iterator; Position : Cursor) return Cursor is function Next (Object : Iterator; Position : Cursor) return Cursor is
begin begin
if Position.Node = null then if Position.Container = null then
return No_Element; return No_Element;
else
return (Object.Container, Next (Position).Node);
end if; 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; end Next;
------------------- -------------------
......
...@@ -39,10 +39,9 @@ with System; use type System.Address; ...@@ -39,10 +39,9 @@ with System; use type System.Address;
package body Ada.Containers.Hashed_Maps is package body Ada.Containers.Hashed_Maps is
type Iterator is new type Iterator is limited new
Map_Iterator_Interfaces.Forward_Iterator with record Map_Iterator_Interfaces.Forward_Iterator with record
Container : Map_Access; Container : Map_Access;
Node : Node_Access;
end record; end record;
overriding function First (Object : Iterator) return Cursor; overriding function First (Object : Iterator) return Cursor;
...@@ -440,14 +439,8 @@ package body Ada.Containers.Hashed_Maps is ...@@ -440,14 +439,8 @@ package body Ada.Containers.Hashed_Maps is
end First; end First;
function First (Object : Iterator) return Cursor is function First (Object : Iterator) return Cursor is
M : constant Map_Access := Object.Container;
N : constant Node_Access := HT_Ops.First (M.HT);
begin begin
if N = null then return Object.Container.First;
return No_Element;
end if;
return Cursor'(Object.Container.all'Unchecked_Access, N);
end First; end First;
---------- ----------
...@@ -667,12 +660,10 @@ package body Ada.Containers.Hashed_Maps is ...@@ -667,12 +660,10 @@ package body Ada.Containers.Hashed_Maps is
end Iterate; end Iterate;
function Iterate function Iterate
(Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
is is
Node : constant Node_Access := HT_Ops.First (Container.HT);
It : constant Iterator := (Container'Unrestricted_Access, Node);
begin begin
return It; return Iterator'(Container => Container'Unrestricted_Access);
end Iterate; end Iterate;
--------- ---------
...@@ -752,11 +743,16 @@ package body Ada.Containers.Hashed_Maps is ...@@ -752,11 +743,16 @@ package body Ada.Containers.Hashed_Maps is
Position : Cursor) return Cursor Position : Cursor) return Cursor
is is
begin begin
if Position.Node = null then if Position.Container = null then
return No_Element; return No_Element;
else
return (Object.Container, Next (Position).Node);
end if; 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; end Next;
------------------- -------------------
......
...@@ -34,6 +34,7 @@ ...@@ -34,6 +34,7 @@
with Ada.Task_Identification; use Ada.Task_Identification; with Ada.Task_Identification; use Ada.Task_Identification;
with Ada.Unchecked_Conversion; with Ada.Unchecked_Conversion;
with System.OS_Constants; use System.OS_Constants;
with System.OS_Interface; use System.OS_Interface; with System.OS_Interface; use System.OS_Interface;
with Interfaces.C; use Interfaces.C; with Interfaces.C; use Interfaces.C;
...@@ -112,9 +113,6 @@ package body Ada.Execution_Time is ...@@ -112,9 +113,6 @@ package body Ada.Execution_Time is
pragma Import (C, clock_gettime, "clock_gettime"); pragma Import (C, clock_gettime, "clock_gettime");
-- Function from the POSIX.1b Realtime Extensions library -- Function from the POSIX.1b Realtime Extensions library
CLOCK_THREAD_CPUTIME_ID : constant := 3;
-- Identifier for the clock returning per-task CPU time
begin begin
if T = Ada.Task_Identification.Null_Task_Id then if T = Ada.Task_Identification.Null_Task_Id then
raise Program_Error; raise Program_Error;
......
...@@ -6420,19 +6420,9 @@ package body Exp_Util is ...@@ -6420,19 +6420,9 @@ package body Exp_Util is
-- Start of processing for Remove_Side_Effects -- Start of processing for Remove_Side_Effects
begin begin
-- We only need to do removal of side effects if we are generating -- Handle cases in which there is nothing to do
-- 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 if not Expander_Active then
-- 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
return; return;
end if; end if;
...@@ -6633,6 +6623,15 @@ package body Exp_Util is ...@@ -6633,6 +6623,15 @@ package body Exp_Util is
-- Otherwise we generate a reference to the value -- Otherwise we generate a reference to the value
else 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. -- Special processing for function calls that return a limited type.
-- We need to build a declaration that will enable build-in-place -- 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 -- expansion of the call. This is not done if the context is already
...@@ -6667,25 +6666,39 @@ package body Exp_Util is ...@@ -6667,25 +6666,39 @@ package body Exp_Util is
Def_Id := Make_Temporary (Loc, 'R', Exp); Def_Id := Make_Temporary (Loc, 'R', Exp);
Set_Etype (Def_Id, Exp_Type); Set_Etype (Def_Id, Exp_Type);
Res := -- The regular expansion of functions with side effects involves the
Make_Explicit_Dereference (Loc, -- generation of an access type to capture the return value found on
Prefix => New_Reference_To (Def_Id, Loc)); -- 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: if Alfa_Mode then
-- type Ann is access all <Exp_Type>; 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 := -- Generate:
Make_Full_Type_Declaration (Loc, -- type Ann is access all <Exp_Type>;
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); 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; E := Exp;
if Nkind (E) = N_Explicit_Dereference then if Nkind (E) = N_Explicit_Dereference then
......
...@@ -968,4 +968,15 @@ package body Prj.PP is ...@@ -968,4 +968,15 @@ package body Prj.PP is
Output.Write_Eol; Output.Write_Eol;
end Output_Statistics; 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; end Prj.PP;
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -91,4 +91,9 @@ private ...@@ -91,4 +91,9 @@ private
-- display what Project_Node_Kinds have not been exercised by the call(s) -- display what Project_Node_Kinds have not been exercised by the call(s)
-- to Pretty_Print. It is used only for testing purposes. -- 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; end Prj.PP;
...@@ -97,6 +97,7 @@ pragma Style_Checks ("M32766"); ...@@ -97,6 +97,7 @@ pragma Style_Checks ("M32766");
#include <string.h> #include <string.h>
#include <limits.h> #include <limits.h>
#include <fcntl.h> #include <fcntl.h>
#include <time.h>
#if defined (__alpha__) && defined (__osf__) #if defined (__alpha__) && defined (__osf__)
/** Tru64 is unable to do vector IO operations with default value of IOV_MAX, /** Tru64 is unable to do vector IO operations with default value of IOV_MAX,
...@@ -1207,6 +1208,55 @@ CND(IP_DROP_MEMBERSHIP, "Leave a multicast group") ...@@ -1207,6 +1208,55 @@ CND(IP_DROP_MEMBERSHIP, "Leave a multicast group")
#endif #endif
CND(IP_PKTINFO, "Get datagram info") 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")
/* /*
---------------------- ----------------------
......
...@@ -197,10 +197,7 @@ package System.OS_Interface is ...@@ -197,10 +197,7 @@ package System.OS_Interface is
type timespec is private; type timespec is private;
type clockid_t is private; type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -547,10 +544,6 @@ private ...@@ -547,10 +544,6 @@ private
end record; end record;
pragma Convention (C, timespec); 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; type pthread_attr_t is new System.Address;
pragma Convention (C, pthread_attr_t); pragma Convention (C, pthread_attr_t);
-- typedef struct __pt_attr *pthread_attr_t; -- typedef struct __pt_attr *pthread_attr_t;
......
...@@ -183,10 +183,7 @@ package System.OS_Interface is ...@@ -183,10 +183,7 @@ package System.OS_Interface is
type timespec is private; type timespec is private;
type clockid_t is private; type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -524,10 +521,6 @@ private ...@@ -524,10 +521,6 @@ private
end record; end record;
pragma Convention (C, timespec); 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 -- Darwin specific signal implementation
-- --
......
...@@ -200,10 +200,7 @@ package System.OS_Interface is ...@@ -200,10 +200,7 @@ package System.OS_Interface is
function nanosleep (rqtp, rmtp : access timespec) return int; function nanosleep (rqtp, rmtp : access timespec) return int;
pragma Import (C, nanosleep, "nanosleep"); pragma Import (C, nanosleep, "nanosleep");
type clockid_t is private; type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -643,13 +640,6 @@ private ...@@ -643,13 +640,6 @@ private
end record; end record;
pragma Convention (C, timespec); 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_t is new System.Address;
type pthread_attr_t is new System.Address; type pthread_attr_t is new System.Address;
type pthread_mutex_t is new System.Address; type pthread_mutex_t is new System.Address;
......
...@@ -180,10 +180,7 @@ package System.OS_Interface is ...@@ -180,10 +180,7 @@ package System.OS_Interface is
type timespec is private; type timespec is private;
type clockid_t is private; type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -529,10 +526,6 @@ private ...@@ -529,10 +526,6 @@ private
end record; end record;
pragma Convention (C, timespec); 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_attr_t is new int;
type pthread_condattr_t is new int; type pthread_condattr_t is new int;
type pthread_mutexattr_t is new int; type pthread_mutexattr_t is new int;
......
...@@ -172,11 +172,7 @@ package System.OS_Interface is ...@@ -172,11 +172,7 @@ package System.OS_Interface is
type timespec is private; type timespec is private;
type timespec_ptr is access all timespec; type timespec_ptr is access all timespec;
type clockid_t is private; type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t;
CLOCK_SGI_FAST : constant clockid_t;
CLOCK_SGI_CYCLE : constant clockid_t;
SGI_CYCLECNTR_SIZE : constant := 165; SGI_CYCLECNTR_SIZE : constant := 165;
...@@ -486,11 +482,6 @@ private ...@@ -486,11 +482,6 @@ private
end record; end record;
pragma Convention (C, timespec); 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 array_type_9 is array (Integer range 0 .. 4) of long;
type pthread_attr_t is record type pthread_attr_t is record
X_X_D : array_type_9; X_X_D : array_type_9;
......
...@@ -177,9 +177,7 @@ package System.OS_Interface is ...@@ -177,9 +177,7 @@ package System.OS_Interface is
type timespec is private; type timespec is private;
type clockid_t is private; type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -516,9 +514,6 @@ private ...@@ -516,9 +514,6 @@ private
end record; end record;
pragma Convention (C, timespec); pragma Convention (C, timespec);
type clockid_t is new unsigned_char;
CLOCK_REALTIME : constant clockid_t := 0;
type st_t is record type st_t is record
stksize : int; stksize : int;
prio : int; prio : int;
......
...@@ -197,10 +197,7 @@ package System.OS_Interface is ...@@ -197,10 +197,7 @@ package System.OS_Interface is
type timespec is private; type timespec is private;
type clockid_t is private; type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -517,10 +514,6 @@ private ...@@ -517,10 +514,6 @@ private
end record; end record;
pragma Convention (C, timespec); 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 type st_attr_t is record
stksize : int; stksize : int;
prio : int; prio : int;
......
...@@ -187,10 +187,7 @@ package System.OS_Interface is ...@@ -187,10 +187,7 @@ package System.OS_Interface is
type timespec is private; type timespec is private;
type clockid_t is private; type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t;
CLOCK_MONOTONIC : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -520,10 +517,6 @@ private ...@@ -520,10 +517,6 @@ private
end record; end record;
pragma Convention (C, timespec); 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 type pthread_attr_t is record
pthread_attrp : System.Address; pthread_attrp : System.Address;
end record; end record;
......
...@@ -243,9 +243,7 @@ package System.OS_Interface is ...@@ -243,9 +243,7 @@ package System.OS_Interface is
type timespec is private; type timespec is private;
type clockid_t is private; type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; tp : access timespec) return int; (clock_id : clockid_t; tp : access timespec) return int;
...@@ -531,9 +529,6 @@ private ...@@ -531,9 +529,6 @@ private
end record; end record;
pragma Convention (C, timespec); 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 array_type_9 is array (0 .. 3) of unsigned_char;
type record_type_3 is record type record_type_3 is record
flag : array_type_9; flag : array_type_9;
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1991-1994, Florida State University -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -191,9 +191,7 @@ package System.OS_Interface is ...@@ -191,9 +191,7 @@ package System.OS_Interface is
function nanosleep (rqtp, rmtp : access timespec) return int; function nanosleep (rqtp, rmtp : access timespec) return int;
pragma Import (C, nanosleep); pragma Import (C, nanosleep);
type clockid_t is private; type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t;
function clock_gettime function clock_gettime
(clock_id : clockid_t; (clock_id : clockid_t;
...@@ -506,9 +504,6 @@ private ...@@ -506,9 +504,6 @@ private
end record; end record;
pragma Convention (C, timespec); 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 unsigned_long_array is array (Natural range <>) of unsigned_long;
type pthread_t is new System.Address; type pthread_t is new System.Address;
......
...@@ -243,9 +243,7 @@ package System.OS_Interface is ...@@ -243,9 +243,7 @@ package System.OS_Interface is
end record; end record;
pragma Convention (C, timespec); pragma Convention (C, timespec);
type clockid_t is private; type clockid_t is new int;
CLOCK_REALTIME : constant clockid_t; -- System wide realtime clock
function To_Duration (TS : timespec) return Duration; function To_Duration (TS : timespec) return Duration;
pragma Inline (To_Duration); pragma Inline (To_Duration);
...@@ -511,8 +509,5 @@ private ...@@ -511,8 +509,5 @@ private
ERROR_PID : constant pid_t := -1; 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; type sigset_t is new System.VxWorks.Ext.sigset_t;
end System.OS_Interface; end System.OS_Interface;
...@@ -555,7 +555,7 @@ package body System.Task_Primitives.Operations is ...@@ -555,7 +555,7 @@ package body System.Task_Primitives.Operations is
TS : aliased timespec; TS : aliased timespec;
Result : Interfaces.C.int; Result : Interfaces.C.int;
begin begin
Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access); Result := Clock_Gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
pragma Assert (Result = 0); pragma Assert (Result = 0);
return To_Duration (TS); return To_Duration (TS);
end Monotonic_Clock; end Monotonic_Clock;
......
...@@ -89,8 +89,6 @@ package body System.Task_Primitives.Operations is ...@@ -89,8 +89,6 @@ package body System.Task_Primitives.Operations is
Dispatching_Policy : Character; Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME;
Unblocked_Signal_Mask : aliased sigset_t; Unblocked_Signal_Mask : aliased sigset_t;
Foreign_Task_Elaborated : aliased Boolean := True; Foreign_Task_Elaborated : aliased Boolean := True;
...@@ -572,7 +570,7 @@ package body System.Task_Primitives.Operations is ...@@ -572,7 +570,7 @@ package body System.Task_Primitives.Operations is
TS : aliased timespec; TS : aliased timespec;
Result : Interfaces.C.int; Result : Interfaces.C.int;
begin 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); pragma Assert (Result = 0);
return To_Duration (TS); return To_Duration (TS);
end Monotonic_Clock; end Monotonic_Clock;
...@@ -583,7 +581,7 @@ package body System.Task_Primitives.Operations is ...@@ -583,7 +581,7 @@ package body System.Task_Primitives.Operations is
function RT_Resolution return Duration is function RT_Resolution return Duration is
begin 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 -- the interrupt resolution of the realtime clock and not the actual
-- resolution of reading the clock. Even though this last value is -- resolution of reading the clock. Even though this last value is
-- only guaranteed to be 100 Hz, at least the Origin 200 appears to -- only guaranteed to be 100 Hz, at least the Origin 200 appears to
......
...@@ -171,6 +171,11 @@ package body System.Task_Primitives.Operations is ...@@ -171,6 +171,11 @@ package body System.Task_Primitives.Operations is
function To_Address is function To_Address is
new Ada.Unchecked_Conversion (Task_Id, System.Address); 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 -- -- Abort_Handler --
------------------- -------------------
...@@ -666,7 +671,7 @@ package body System.Task_Primitives.Operations is ...@@ -666,7 +671,7 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int; Result : Interfaces.C.int;
begin begin
Result := clock_gettime 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); pragma Assert (Result = 0);
return To_Duration (TS); return To_Duration (TS);
end Monotonic_Clock; end Monotonic_Clock;
...@@ -869,6 +874,9 @@ package body System.Task_Primitives.Operations is ...@@ -869,6 +874,9 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0 or else Result = ENOMEM); pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then if Result = 0 then
Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
pragma Assert (Result = 0);
Result := Result :=
pthread_cond_init pthread_cond_init
(Self_ID.Common.LL.CV'Access, Cond_Attr'Access); (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
...@@ -1099,6 +1107,10 @@ package body System.Task_Primitives.Operations is ...@@ -1099,6 +1107,10 @@ package body System.Task_Primitives.Operations is
-- underlying OS entities fails. -- underlying OS entities fails.
raise Storage_Error; raise Storage_Error;
else
Result := GNAT_pthread_condattr_setup (Cond_Attr'Access);
pragma Assert (Result = 0);
end if; end if;
Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access);
......
...@@ -773,7 +773,7 @@ package body System.Task_Primitives.Operations is ...@@ -773,7 +773,7 @@ package body System.Task_Primitives.Operations is
TS : aliased timespec; TS : aliased timespec;
Result : Interfaces.C.int; Result : Interfaces.C.int;
begin begin
Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
pragma Assert (Result = 0); pragma Assert (Result = 0);
return To_Duration (TS); return To_Duration (TS);
end Monotonic_Clock; end Monotonic_Clock;
......
...@@ -589,7 +589,7 @@ package body System.Task_Primitives.Operations is ...@@ -589,7 +589,7 @@ package body System.Task_Primitives.Operations is
TS : aliased timespec; TS : aliased timespec;
Result : Interfaces.C.int; Result : Interfaces.C.int;
begin begin
Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
pragma Assert (Result = 0); pragma Assert (Result = 0);
return To_Duration (TS); return To_Duration (TS);
end Monotonic_Clock; end Monotonic_Clock;
......
...@@ -718,7 +718,7 @@ package body System.Task_Primitives.Operations is ...@@ -718,7 +718,7 @@ package body System.Task_Primitives.Operations is
TS : aliased timespec; TS : aliased timespec;
Result : int; Result : int;
begin begin
Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
pragma Assert (Result = 0); pragma Assert (Result = 0);
return To_Duration (TS); return To_Duration (TS);
end Monotonic_Clock; end Monotonic_Clock;
......
...@@ -34,12 +34,14 @@ ...@@ -34,12 +34,14 @@
with System.Parameters; with System.Parameters;
with System.Tasking; with System.Tasking;
with System.OS_Constants;
with System.OS_Interface; with System.OS_Interface;
package System.Task_Primitives.Operations is package System.Task_Primitives.Operations is
pragma Preelaborate; pragma Preelaborate;
package ST renames System.Tasking; package ST renames System.Tasking;
package OSC renames System.OS_Constants;
package OSI renames System.OS_Interface; package OSI renames System.OS_Interface;
procedure Initialize (Environment_Task : ST.Task_Id); procedure Initialize (Environment_Task : ST.Task_Id);
......
...@@ -11786,7 +11786,7 @@ package body Sem_Ch3 is ...@@ -11786,7 +11786,7 @@ package body Sem_Ch3 is
-- needed, since checks may cause duplication of the expressions -- needed, since checks may cause duplication of the expressions
-- which must not be reevaluated. -- which must not be reevaluated.
if Full_Expander_Active then if Expander_Active then
Force_Evaluation (Low_Bound (R)); Force_Evaluation (Low_Bound (R));
Force_Evaluation (High_Bound (R)); Force_Evaluation (High_Bound (R));
end if; end if;
...@@ -18326,7 +18326,7 @@ package body Sem_Ch3 is ...@@ -18326,7 +18326,7 @@ package body Sem_Ch3 is
-- if needed, before applying checks, since checks may cause -- if needed, before applying checks, since checks may cause
-- duplication of the expression without forcing evaluation. -- duplication of the expression without forcing evaluation.
if Full_Expander_Active then if Expander_Active then
Force_Evaluation (Lo); Force_Evaluation (Lo);
Force_Evaluation (Hi); Force_Evaluation (Hi);
end if; end if;
...@@ -18436,7 +18436,7 @@ package body Sem_Ch3 is ...@@ -18436,7 +18436,7 @@ package body Sem_Ch3 is
-- Case of other than an explicit N_Range node -- Case of other than an explicit N_Range node
elsif Full_Expander_Active then elsif Expander_Active then
Get_Index_Bounds (R, Lo, Hi); Get_Index_Bounds (R, Lo, Hi);
Force_Evaluation (Lo); Force_Evaluation (Lo);
Force_Evaluation (Hi); Force_Evaluation (Hi);
......
...@@ -905,6 +905,60 @@ package body Sem_Ch9 is ...@@ -905,6 +905,60 @@ package body Sem_Ch9 is
Bad_Predicated_Subtype_Use Bad_Predicated_Subtype_Use
("subtype& has predicate, not allowed in entry family", ("subtype& has predicate, not allowed in entry family",
D_Sdef, Etype (D_Sdef)); 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; end if;
-- Decorate Def_Id -- Decorate Def_Id
......
/****************************************************************************
* *
* 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
}
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment