git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[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
This commit is contained in:
Arnaud Charlet 2011-11-23 12:24:48 +01:00
parent f947ee3467
commit c269a1f5c9
31 changed files with 335 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
gcc/ada/ChangeLog
View File

@ -1,3 +1,51 @@
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

4
gcc/ada/Makefile.rtl
View File

@ -75,7 +75,9 @@ GNATRTL_TASKING_OBJS= \
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= \

26
gcc/ada/a-cbhama.adb
View File

@ -41,7 +41,6 @@ package body Ada.Containers.Bounded_Hashed_Maps is
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;
@ -424,14 +423,8 @@ package body Ada.Containers.Bounded_Hashed_Maps is
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;
-----------------
@ -675,12 +668,10 @@ package body Ada.Containers.Bounded_Hashed_Maps is
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;
---------
@ -770,11 +761,16 @@ package body Ada.Containers.Bounded_Hashed_Maps is
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;
-------------------

30
gcc/ada/a-cihama.adb
View File

@ -45,10 +45,9 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
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;
@ -476,14 +475,8 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
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;
----------
@ -715,13 +708,11 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
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;
---------
@ -809,11 +800,16 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
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;
-------------------

28
gcc/ada/a-cohama.adb
View File

@ -39,10 +39,9 @@ with System; use type System.Address;
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;
@ -440,14 +439,8 @@ package body Ada.Containers.Hashed_Maps is
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;
----------
@ -667,12 +660,10 @@ package body Ada.Containers.Hashed_Maps is
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;
---------
@ -752,11 +743,16 @@ package body Ada.Containers.Hashed_Maps is
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;
-------------------

4
gcc/ada/a-exetim-posix.adb
View File

@ -34,6 +34,7 @@
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;
@ -112,9 +113,6 @@ package body Ada.Execution_Time is
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;

67
gcc/ada/exp_util.adb
View File

@ -6420,19 +6420,9 @@ package body Exp_Util is
-- 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.
-- Handle cases in which there is nothing to do
-- 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
if not Expander_Active then
return;
end if;
@ -6633,6 +6623,15 @@ package body Exp_Util is
-- 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
@ -6667,25 +6666,39 @@ package body Exp_Util is
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;
Ref_Type := Make_Temporary (Loc, 'A');
-- Regular expansion utilizing an access type and 'reference
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)));
else
Res :=
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Def_Id, Loc));
Insert_Action (Exp, Ptr_Typ_Decl);
-- Generate:
-- type Ann is access all <Exp_Type>;
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

11
gcc/ada/prj-pp.adb
View File

@ -968,4 +968,15 @@ package body Prj.PP is
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;

7
gcc/ada/prj-pp.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -91,4 +91,9 @@ private
-- 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;

50
gcc/ada/s-oscons-tmplt.c
View File

@ -97,6 +97,7 @@ pragma Style_Checks ("M32766");
#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,
@ -1207,6 +1208,55 @@ CND(IP_DROP_MEMBERSHIP, "Leave a multicast group")
#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")
/*
----------------------

9
gcc/ada/s-osinte-aix.ads
View File

@ -197,10 +197,7 @@ package System.OS_Interface is
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;
@ -547,10 +544,6 @@ private
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;

9
gcc/ada/s-osinte-darwin.ads
View File

@ -183,10 +183,7 @@ package System.OS_Interface is
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;
@ -524,10 +521,6 @@ private
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
--

12
gcc/ada/s-osinte-freebsd.ads
View File

@ -200,10 +200,7 @@ package System.OS_Interface is
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;
@ -643,13 +640,6 @@ private
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;

9
gcc/ada/s-osinte-hpux.ads
View File

@ -180,10 +180,7 @@ package System.OS_Interface is
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;
@ -529,10 +526,6 @@ private
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;

11
gcc/ada/s-osinte-irix.ads
View File

@ -172,11 +172,7 @@ package System.OS_Interface is
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;
@ -486,11 +482,6 @@ private
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;

7
gcc/ada/s-osinte-lynxos-3.ads
View File

@ -177,9 +177,7 @@ package System.OS_Interface is
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;
@ -516,9 +514,6 @@ private
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;

9
gcc/ada/s-osinte-lynxos.ads
View File

@ -197,10 +197,7 @@ package System.OS_Interface is
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;
@ -517,10 +514,6 @@ private
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;

9
gcc/ada/s-osinte-solaris-posix.ads
View File

@ -187,10 +187,7 @@ package System.OS_Interface is
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;
@ -520,10 +517,6 @@ private
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;

7
gcc/ada/s-osinte-solaris.ads
View File

@ -243,9 +243,7 @@ package System.OS_Interface is
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;
@ -531,9 +529,6 @@ private
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;

9
gcc/ada/s-osinte-tru64.ads
View File

@ -7,7 +7,7 @@
-- 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- --
@ -191,9 +191,7 @@ package System.OS_Interface is
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;
@ -506,9 +504,6 @@ private
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;

7
gcc/ada/s-osinte-vxworks.ads
View File

@ -243,9 +243,7 @@ package System.OS_Interface is
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);
@ -511,8 +509,5 @@ private
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;

2
gcc/ada/s-taprop-hpux-dce.adb
View File

@ -555,7 +555,7 @@ package body System.Task_Primitives.Operations is
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;

6
gcc/ada/s-taprop-irix.adb
View File

@ -89,8 +89,6 @@ package body System.Task_Primitives.Operations is
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;
@ -572,7 +570,7 @@ package body System.Task_Primitives.Operations is
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;
@ -583,7 +581,7 @@ package body System.Task_Primitives.Operations is
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

14
gcc/ada/s-taprop-posix.adb
View File

@ -171,6 +171,11 @@ package body System.Task_Primitives.Operations is
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 --
-------------------
@ -666,7 +671,7 @@ package body System.Task_Primitives.Operations is
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;
@ -869,6 +874,9 @@ package body System.Task_Primitives.Operations is
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);
@ -1099,6 +1107,10 @@ package body System.Task_Primitives.Operations is
-- 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);

2
gcc/ada/s-taprop-solaris.adb
View File

@ -773,7 +773,7 @@ package body System.Task_Primitives.Operations is
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;

2
gcc/ada/s-taprop-tru64.adb
View File

@ -589,7 +589,7 @@ package body System.Task_Primitives.Operations is
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;

2
gcc/ada/s-taprop-vxworks.adb
View File

@ -718,7 +718,7 @@ package body System.Task_Primitives.Operations is
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;

2
gcc/ada/s-taprop.ads
View File

@ -34,12 +34,14 @@
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);

6
gcc/ada/sem_ch3.adb
View File

@ -11786,7 +11786,7 @@ package body Sem_Ch3 is
-- 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;
@ -18326,7 +18326,7 @@ package body Sem_Ch3 is
-- 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;
@ -18436,7 +18436,7 @@ package body Sem_Ch3 is
-- 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);

54
gcc/ada/sem_ch9.adb
View File

@ -905,6 +905,60 @@ package body Sem_Ch9 is
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

50
gcc/ada/thread.c Normal file
View File

@ -0,0 +1,50 @@
/****************************************************************************
* *
* 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
}