From 001c7783c467b58d6107b6cf5e4d9b101c4d80dc Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 14 Jun 2010 14:51:24 +0200 Subject: [PATCH] [multiple changes] 2010-06-14 Ed Schonberg * sem_util (Is_VMS_Operator): New predicate to determine whether an operator is an intrinsic operator declared in the DEC system extension. * sem_res.adb (Resolve_Logical_Op): operation is legal on signed types if the operator is a VMS intrinsic. * sem_eval.adb (Eval_Logical_Op): Operation is legal and be constant-folded if the operands are signed and the operator is a VMS intrinsic. 2010-06-14 Robert Dewar * g-socket.adb, gnatcmd.adb: Minor reformatting From-SVN: r160734 --- gcc/ada/ChangeLog | 14 ++++++++++++++ gcc/ada/g-socket.adb | 4 ++++ gcc/ada/gnatcmd.adb | 1 - gcc/ada/sem_eval.adb | 7 ++++++- gcc/ada/sem_res.adb | 17 ++++++++++++++--- gcc/ada/sem_util.adb | 11 +++++++++++ gcc/ada/sem_util.ads | 4 ++++ 7 files changed, 53 insertions(+), 5 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 434bdb79178..0b6bcc3a135 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2010-06-14 Ed Schonberg + + * sem_util (Is_VMS_Operator): New predicate to determine whether an + operator is an intrinsic operator declared in the DEC system extension. + * sem_res.adb (Resolve_Logical_Op): operation is legal on signed types + if the operator is a VMS intrinsic. + * sem_eval.adb (Eval_Logical_Op): Operation is legal and be + constant-folded if the operands are signed and the operator is a VMS + intrinsic. + +2010-06-14 Robert Dewar + + * g-socket.adb, gnatcmd.adb: Minor reformatting + 2010-06-14 Pascal Obry * s-finimp.adb: Fix typo. diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 0122c5a7e8c..a364cb2b95e 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -900,6 +900,7 @@ package body GNAT.Sockets is begin Netdb_Lock; + if C_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 then @@ -935,6 +936,7 @@ package body GNAT.Sockets is begin Netdb_Lock; + if C_Gethostbyname (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 then @@ -986,6 +988,7 @@ package body GNAT.Sockets is begin Netdb_Lock; + if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then Netdb_Unlock; raise Service_Error with "Service not found"; @@ -1015,6 +1018,7 @@ package body GNAT.Sockets is begin Netdb_Lock; + if C_Getservbyport (C.int (Short_To_Network (C.unsigned_short (Port))), SP, Res'Access, Buf'Address, Buflen) /= 0 diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 10cf3458ebf..041c82aee7f 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -900,7 +900,6 @@ procedure GNATCmd is function Mapping_File return Path_Name_Type is Result : Path_Name_Type; - begin Prj.Env.Create_Mapping_File (Project => Project, diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index c9054f387a8..13751d21d75 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -2069,7 +2069,12 @@ package body Sem_Eval is Right_Int : constant Uint := Expr_Value (Right); begin - if Is_Modular_Integer_Type (Etype (N)) then + + -- VMS includes bitwise operations on signed types. + + if Is_Modular_Integer_Type (Etype (N)) + or else Is_VMS_Operator (Entity (N)) + then declare Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 14c02100e93..feee853d3ec 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4769,12 +4769,15 @@ package body Sem_Res is -- Returns True if the subprogram entity S is the same as E or else -- S is an alias of E. + --------------------------------- + -- Same_Or_Aliased_Subprograms -- + --------------------------------- + function Same_Or_Aliased_Subprograms (S : Entity_Id; E : Entity_Id) return Boolean is Subp_Alias : constant Entity_Id := Alias (S); - begin return S = E or else (Present (Subp_Alias) and then Subp_Alias = E); @@ -6762,13 +6765,18 @@ package body Sem_Res is B_Typ := Base_Type (Typ); end if; + -- OK if this is a VMS-specific intrinsic operation + + if Is_VMS_Operator (Entity (N)) then + null; + -- The following test is required because the operands of the operation -- may be literals, in which case the resulting type appears to be -- compatible with a signed integer type, when in fact it is compatible -- only with modular types. If the context itself is universal, the -- operation is illegal. - if not Valid_Boolean_Arg (Typ) then + elsif not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid context for logical operation", N); Set_Etype (N, Any_Type); return; @@ -7312,9 +7320,12 @@ package body Sem_Res is B_Typ := Base_Type (Typ); end if; + if Is_VMS_Operator (Entity (N)) then + null; + -- Straightforward case of incorrect arguments - if not Valid_Boolean_Arg (Typ) then + elsif not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid operand type for operator&", N); Set_Etype (N, Any_Type); return; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ffcc28e6eac..1cfa423eadd 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -7045,6 +7045,17 @@ package body Sem_Util is and then Get_Name_String (Chars (T)) = "valuetype"; end Is_Value_Type; + --------------------- + -- Is_VMS_Operator -- + --------------------- + + function Is_VMS_Operator (Op : Entity_Id) return Boolean is + begin + return Ekind (Op) = E_Function + and then Is_Intrinsic_Subprogram (Op) + and then Scope (Op) = System_Aux_Id; + end Is_VMS_Operator; + ----------------- -- Is_Delegate -- ----------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index ed36cf8f3d7..9e743578829 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -800,6 +800,10 @@ package Sem_Util is -- object that is accessed directly, as opposed to the other CIL objects -- that are accessed through managed pointers. + function Is_VMS_Operator (Op : Entity_Id) return Boolean; + -- Determine whether an operator is one of the intrinsics defined + -- in the DEC system extension. + function Is_Delegate (T : Entity_Id) return Boolean; -- Returns true if type T represents a delegate. A Delegate is the CIL -- object used to represent access-to-subprogram types. This is only