diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 24 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/g-socket.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/g-socket.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/init.c | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 60 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 4 |
8 files changed, 130 insertions, 21 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 164c690..b5d5e82 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,29 @@ 2013-04-23 Yannick Moy <moy@adacore.com> + * einfo.ads: Minor typo fix. + * sem_ch13.adb (Build_Predicate_Functions): Reject cases where + Static_Predicate is applied to a non-scalar or non-static type. + * sem_prag.adb: Minor typo fix. + +2013-04-23 Doug Rupp <rupp@adacore.com> + + * init.c (GNAT$STOP) [VMS]: New function. + +2013-04-23 Ed Schonberg <schonberg@adacore.com> + + * sem_ch3.adb: Add exp_pakd to context. + (Constrain_Component_Type): If the component of the parent is + packed, and the record subtype being built is already frozen, + as is the case for an itype, the component type itself will not + be frozen, and the packed array type for it must be constructed + explicitly. + +2013-04-23 Thomas Quinot <quinot@adacore.com> + + * g-socket.adb, g-socket.ads (Set_Close_On_Exec): New subprogram. + +2013-04-23 Yannick Moy <moy@adacore.com> + * err_vars.ads (Error_Msg_Qual_Level): Set variable to zero at declaration. * opt.ads (Multiple_Unit_Index): Set variable to zero at declaration. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 8d7981b..16624d2 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2544,7 +2544,7 @@ package Einfo is -- entirely synthesized, by looking at the bounds, and the immediate -- subtype parent. However, this method does not work for some Itypes -- that have no parent set (and the only way to find the immediate --- subtype parent is to go through the tree). For now, this flay is set +-- subtype parent is to go through the tree). For now, this flag is set -- conservatively, i.e. if it is set then for sure the subtype is non- -- static, but if it is not set, then the type may or may not be static. -- Thus the test for a static subtype is that this flag is clear AND that diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index e186258..04a4b86 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -2211,6 +2211,24 @@ package body GNAT.Sockets is Insert_Socket_In_Set (Item.Set'Access, C.int (Socket)); end Set; + ----------------------- + -- Set_Close_On_Exec -- + ----------------------- + + procedure Set_Close_On_Exec + (Socket : Socket_Type; + Close_On_Exec : Boolean; + Status : out Boolean) + is + function C_Set_Close_On_Exec + (Socket : Socket_Type; Close_On_Exec : C.int) + return C.int; + pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); + + begin + Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0; + end Set_Close_On_Exec; + ---------------------- -- Set_Forced_Flags -- ---------------------- diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 4761f3a..c543707 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -979,6 +979,17 @@ package GNAT.Sockets is -- socket. Count is set to the count of transmitted stream elements. Flags -- allow control over transmission. + procedure Set_Close_On_Exec + (Socket : Socket_Type; + Close_On_Exec : Boolean; + Status : out Boolean); + -- When Close_On_Exec is True, mark Socket to be closed automatically when + -- a new program is executed by the calling process (i.e. prevent Socket + -- from being inherited by child processes). When Close_On_Exec is False, + -- mark Socket to not be closed on exec (i.e. allow it to be inherited). + -- Status is False if the operation could not be performed, or is not + -- supported on the target platform. + procedure Set_Socket_Option (Socket : Socket_Type; Level : Level_Type := Socket_Level; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index f6f5b2a..68b4035 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1286,6 +1286,22 @@ __gnat_handle_vms_condition (int *sigargs, void *mechargs) Raise_From_Signal_Handler (exception, msg); } +#if defined (IN_RTS) && defined (__IA64) +/* Called only from adasigio.b32. This is a band aid to avoid going + through the VMS signal handling code which results in a 0x8000 per + handled exception memory leak in P2 space (see VMS source listing + sys/lis/exception.lis) due to the allocation of working space that + is expected to be deallocated upon return from the condition handler, + which doesn't return in GNAT compiled code. */ +void +GNAT$STOP (int *sigargs) +{ + /* Note that there are no mechargs. We rely on the fact that condtions + raised from DEClib I/O do not require an "adjust". */ + __gnat_handle_vms_condition (sigargs, 0); +} +#endif + void __gnat_install_handler (void) { diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 24970f1..f5c03f2 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -980,7 +980,7 @@ package body Sem_Ch13 is -- Perform analysis of the External_Name or Link_Name aspects procedure Analyze_Aspect_Implicit_Dereference; - -- Perform analysis of the Implicit_Dereference aspects + -- Perform analysis of the Implicit_Dereference aspects procedure Make_Aitem_Pragma (Pragma_Argument_Associations : List_Id; @@ -1082,8 +1082,8 @@ package body Sem_Ch13 is Pragma_Argument_Associations, Pragma_Identifier => Make_Identifier (Sloc (Id), Pragma_Name), - Class_Present => Class_Present (Aspect), - Split_PPC => Split_PPC (Aspect)); + Class_Present => Class_Present (Aspect), + Split_PPC => Split_PPC (Aspect)); -- Set additional semantic fields @@ -5707,7 +5707,7 @@ package body Sem_Ch13 is -- Build_Predicate_Functions -- ------------------------------- - -- The procedures that are constructed here has the form: + -- The procedures that are constructed here have the form: -- function typPredicate (Ixxx : typ) return Boolean is -- begin @@ -5725,8 +5725,8 @@ package body Sem_Ch13 is -- use this function even if checks are off, e.g. for membership tests. -- If the expression has at least one Raise_Expression, then we also build - -- the typPredicateM version of the function, in which any occurence of a - -- Raise_Expressioon is converted to "return False". + -- the typPredicateM version of the function, in which any occurrence of a + -- Raise_Expression is converted to "return False". procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is Loc : constant Source_Ptr := Sloc (Typ); @@ -6216,22 +6216,48 @@ package body Sem_Ch13 is -- Deal with static predicate case - if Ekind_In (Typ, E_Enumeration_Subtype, - E_Modular_Integer_Subtype, - E_Signed_Integer_Subtype) + -- ??? We don't currently deal with real types + -- ??? Why requiring that Typ is static? + + if Ekind (Typ) in Discrete_Kind and then Is_Static_Subtype (Typ) and then not Dynamic_Predicate_Present then - Build_Static_Predicate (Typ, Expr, Object_Name); + -- Only build the predicate for subtypes - if Present (Static_Predicate_Present) - and No (Static_Predicate (Typ)) + if Ekind_In (Typ, E_Enumeration_Subtype, + E_Modular_Integer_Subtype, + E_Signed_Integer_Subtype) then - Error_Msg_F - ("expression does not have required form for " - & "static predicate", - Next (First (Pragma_Argument_Associations - (Static_Predicate_Present)))); + Build_Static_Predicate (Typ, Expr, Object_Name); + + if Present (Static_Predicate_Present) + and No (Static_Predicate (Typ)) + then + Error_Msg_F + ("expression does not have required form for " + & "static predicate", + Next (First (Pragma_Argument_Associations + (Static_Predicate_Present)))); + end if; + end if; + + -- If a Static_Predicate applies on other types, that's an error: + -- either the type is scalar but non-static, or it's not even a + -- scalar type. We do not issue an error on generated types, as these + -- would be duplicates of the same error on a source type. + + elsif Present (Static_Predicate_Present) + and then Comes_From_Source (Typ) + then + if Is_Scalar_Type (Typ) then + Error_Msg_FE + ("static predicate not allowed for non-static type&", + Typ, Typ); + else + Error_Msg_FE + ("static predicate not allowed for non-scalar type&", + Typ, Typ); end if; end if; end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 9a687db..0e8e213 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -35,6 +35,7 @@ with Exp_Ch3; use Exp_Ch3; with Exp_Ch9; use Exp_Ch9; with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; +with Exp_Pakd; use Exp_Pakd; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; @@ -11113,6 +11114,7 @@ package body Sem_Ch3 is is Loc : constant Source_Ptr := Sloc (Constrained_Typ); Compon_Type : constant Entity_Id := Etype (Comp); + Array_Comp : Node_Id; function Build_Constrained_Array_Type (Old_Type : Entity_Id) return Entity_Id; @@ -11510,7 +11512,19 @@ package body Sem_Ch3 is return Compon_Type; elsif Is_Array_Type (Compon_Type) then - return Build_Constrained_Array_Type (Compon_Type); + Array_Comp := Build_Constrained_Array_Type (Compon_Type); + + -- If the component of the parent is packed, and the record type is + -- already frozen, as is the case for an itype, the component type + -- itself will not be frozen, and the packed array type for it must + -- be constructed explicitly. + + if Is_Packed (Compon_Type) + and then Is_Frozen (Current_Scope) + then + Create_Packed_Array_Type (Array_Comp); + end if; + return Array_Comp; elsif Has_Discriminants (Compon_Type) then return Build_Constrained_Discriminated_Type (Compon_Type); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9ffc7b0..6a6d342 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -8121,8 +8121,8 @@ package body Sem_Prag is -- Set Check_On to indicate check status -- If this comes from an aspect, we have already taken care of - -- the policy active when the aspect was analyzed, and Is_Ignore - -- is set appriately already. + -- the policy active when the aspect was analyzed, and Is_Ignored + -- is set appropriately already. if From_Aspect_Specification (N) then Check_On := not Is_Ignored (N); |