diff options
author | Arnaud Charlet <charlet@gcc.gnu.org> | 2011-11-23 12:24:48 +0100 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2011-11-23 12:24:48 +0100 |
commit | c269a1f5c9c3904c35ed2ac320e6620c7f47ea57 (patch) | |
tree | 3801b3b0ce11d58d1c4a23076336e38db3baa05d /gcc | |
parent | f947ee3467dee8ca1b681c459804b02657113e9d (diff) | |
download | gcc-c269a1f5c9c3904c35ed2ac320e6620c7f47ea57.zip gcc-c269a1f5c9c3904c35ed2ac320e6620c7f47ea57.tar.gz gcc-c269a1f5c9c3904c35ed2ac320e6620c7f47ea57.tar.bz2 |
[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
Diffstat (limited to 'gcc')
31 files changed, 336 insertions, 179 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 30486c1..ecf8e6a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 73ef0e7..5c3e307 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -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= \ diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb index d7c75d4..a87db6a 100644 --- a/gcc/ada/a-cbhama.adb +++ b/gcc/ada/a-cbhama.adb @@ -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; ------------------- diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index b90c542..84bbdfd 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -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; ------------------- diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index 351030d..634ccc0 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -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; ------------------- diff --git a/gcc/ada/a-exetim-posix.adb b/gcc/ada/a-exetim-posix.adb index 65b21d6..094f2aa 100644 --- a/gcc/ada/a-exetim-posix.adb +++ b/gcc/ada/a-exetim-posix.adb @@ -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; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c0396b4..c67d011 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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. - - -- 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; @@ -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; + + -- 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 diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb index cf0ae4a..6e9e61b 100644 --- a/gcc/ada/prj-pp.adb +++ b/gcc/ada/prj-pp.adb @@ -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; diff --git a/gcc/ada/prj-pp.ads b/gcc/ada/prj-pp.ads index f47e058..771b4c3 100644 --- a/gcc/ada/prj-pp.ads +++ b/gcc/ada/prj-pp.ads @@ -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; diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c index ad3d065..d8a6477 100644 --- a/gcc/ada/s-oscons-tmplt.c +++ b/gcc/ada/s-oscons-tmplt.c @@ -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") + /* ---------------------- diff --git a/gcc/ada/s-osinte-aix.ads b/gcc/ada/s-osinte-aix.ads index c8e6608..c89e729 100644 --- a/gcc/ada/s-osinte-aix.ads +++ b/gcc/ada/s-osinte-aix.ads @@ -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; diff --git a/gcc/ada/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads index fe2a10a..ff04803 100644 --- a/gcc/ada/s-osinte-darwin.ads +++ b/gcc/ada/s-osinte-darwin.ads @@ -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 -- diff --git a/gcc/ada/s-osinte-freebsd.ads b/gcc/ada/s-osinte-freebsd.ads index cbd2a2d..b581dae 100644 --- a/gcc/ada/s-osinte-freebsd.ads +++ b/gcc/ada/s-osinte-freebsd.ads @@ -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; diff --git a/gcc/ada/s-osinte-hpux.ads b/gcc/ada/s-osinte-hpux.ads index bc9a709..55729f8 100644 --- a/gcc/ada/s-osinte-hpux.ads +++ b/gcc/ada/s-osinte-hpux.ads @@ -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; diff --git a/gcc/ada/s-osinte-irix.ads b/gcc/ada/s-osinte-irix.ads index ddeadcb..365a3de 100644 --- a/gcc/ada/s-osinte-irix.ads +++ b/gcc/ada/s-osinte-irix.ads @@ -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; diff --git a/gcc/ada/s-osinte-lynxos-3.ads b/gcc/ada/s-osinte-lynxos-3.ads index 3d912ee..e8288d9 100644 --- a/gcc/ada/s-osinte-lynxos-3.ads +++ b/gcc/ada/s-osinte-lynxos-3.ads @@ -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; diff --git a/gcc/ada/s-osinte-lynxos.ads b/gcc/ada/s-osinte-lynxos.ads index 8b998bc..7bcbab6 100644 --- a/gcc/ada/s-osinte-lynxos.ads +++ b/gcc/ada/s-osinte-lynxos.ads @@ -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; diff --git a/gcc/ada/s-osinte-solaris-posix.ads b/gcc/ada/s-osinte-solaris-posix.ads index 8781a12..eb17bd4 100644 --- a/gcc/ada/s-osinte-solaris-posix.ads +++ b/gcc/ada/s-osinte-solaris-posix.ads @@ -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; diff --git a/gcc/ada/s-osinte-solaris.ads b/gcc/ada/s-osinte-solaris.ads index 03a0c4a..b4baa6d 100644 --- a/gcc/ada/s-osinte-solaris.ads +++ b/gcc/ada/s-osinte-solaris.ads @@ -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; diff --git a/gcc/ada/s-osinte-tru64.ads b/gcc/ada/s-osinte-tru64.ads index 8347172..0fcd422 100644 --- a/gcc/ada/s-osinte-tru64.ads +++ b/gcc/ada/s-osinte-tru64.ads @@ -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; diff --git a/gcc/ada/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads index f5013ea..1997674 100644 --- a/gcc/ada/s-osinte-vxworks.ads +++ b/gcc/ada/s-osinte-vxworks.ads @@ -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; diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 346de43..cae17c1 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -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; diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index 62cb4f7..dc9f9a8 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -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 diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 44015cf..4014381 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -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); diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index c98da19..ef0e391 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -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; diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index b0b727d..e4ef466 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -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; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index be76162..3c3e22b 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -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; diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads index 12fbd71..66b0b5d 100644 --- a/gcc/ada/s-taprop.ads +++ b/gcc/ada/s-taprop.ads @@ -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); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1614771..92e1b9d 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 4b284cd..057f0b7 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -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 diff --git a/gcc/ada/thread.c b/gcc/ada/thread.c new file mode 100644 index 0000000..da67f7b --- /dev/null +++ b/gcc/ada/thread.c @@ -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 +} |