From 7415029d47f49954c09bd16c1b7d948dfc67c127 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 14 Jun 2010 11:08:47 +0200 Subject: [PATCH] [multiple changes] 2010-06-14 Gary Dismukes * gnat_ugn.texi: Minor typo fixes and wording changes 2010-06-14 Ed Schonberg * sem_ch4.adb (Analyze_One_Call): If the call has been rewritten from a prefixed form, do not re-analyze first actual, which may need an implicit dereference. * sem_ch6.adb (Analyze_Procedure_Call): If the call is given in prefixed notation, the analysis will rewrite the node, and possible errors appear in the rewritten name of the node. * sem_res.adb: If a call is ambiguous because its first parameter is an overloaded call, report list of candidates, to clarify ambiguity of enclosing call. 2010-06-14 Doug Rupp * s-auxdec-vms-alpha.adb: New package body implementing legacy VAX instructions with Asm insertions. * s-auxdec-vms_64.ads: Inline VAX queue functions * s-stoele.adb: Resolve some ambiguities in To_Addresss with s-suxdec that show up only on VMS. * gcc-interface/Makefile.in: Provide translation for s-auxdec-vms-alpha.adb. From-SVN: r160713 --- gcc/ada/ChangeLog | 26 + gcc/ada/gcc-interface/Makefile.in | 61 +- gcc/ada/gnat_ugn.texi | 10 +- gcc/ada/s-auxdec-vms-alpha.adb | 1015 +++++++++++++++++++++++++++++ gcc/ada/s-auxdec-vms_64.ads | 7 + gcc/ada/s-stoele.adb | 16 +- gcc/ada/sem_ch4.adb | 21 +- gcc/ada/sem_ch6.adb | 8 +- gcc/ada/sem_res.adb | 43 ++ 9 files changed, 1180 insertions(+), 27 deletions(-) create mode 100644 gcc/ada/s-auxdec-vms-alpha.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b34f0848f8d..6f7d87c6030 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2010-06-14 Gary Dismukes + + * gnat_ugn.texi: Minor typo fixes and wording changes + +2010-06-14 Ed Schonberg + + * sem_ch4.adb (Analyze_One_Call): If the call has been rewritten from a + prefixed form, do not re-analyze first actual, which may need an + implicit dereference. + * sem_ch6.adb (Analyze_Procedure_Call): If the call is given in + prefixed notation, the analysis will rewrite the node, and possible + errors appear in the rewritten name of the node. + * sem_res.adb: If a call is ambiguous because its first parameter is + an overloaded call, report list of candidates, to clarify ambiguity of + enclosing call. + +2010-06-14 Doug Rupp + + * s-auxdec-vms-alpha.adb: New package body implementing legacy + VAX instructions with Asm insertions. + * s-auxdec-vms_64.ads: Inline VAX queue functions + * s-stoele.adb: Resolve some ambiguities in To_Addresss with s-suxdec + that show up only on VMS. + * gcc-interface/Makefile.in: Provide translation for + s-auxdec-vms-alpha.adb. + 2010-06-14 Olivier Hainque * initialize.c (VxWorks section): Update comments. diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 8a3254fb438..0e5692ee0b2 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -391,6 +391,26 @@ DUMMY_SOCKETS_TARGET_PAIRS = \ g-sothco.ads. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off alpha ordering check on subprograms, this unit is laid +-- out to correspond to the declarations in the DEC 83 System unit. + +with System.Machine_Code; use System.Machine_Code; +package body System.Aux_DEC is + + ----------------------------------- + -- Operations on Largest_Integer -- + ----------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type LIU is mod 2 ** Largest_Integer'Size; + -- Unsigned type of same length as Largest_Integer + + function To_LI is new Ada.Unchecked_Conversion (LIU, Largest_Integer); + function From_LI is new Ada.Unchecked_Conversion (Largest_Integer, LIU); + + function "not" (Left : Largest_Integer) return Largest_Integer is + begin + return To_LI (not From_LI (Left)); + end "not"; + + function "and" (Left, Right : Largest_Integer) return Largest_Integer is + begin + return To_LI (From_LI (Left) and From_LI (Right)); + end "and"; + + function "or" (Left, Right : Largest_Integer) return Largest_Integer is + begin + return To_LI (From_LI (Left) or From_LI (Right)); + end "or"; + + function "xor" (Left, Right : Largest_Integer) return Largest_Integer is + begin + return To_LI (From_LI (Left) xor From_LI (Right)); + end "xor"; + + -------------------------------------- + -- Arithmetic Operations on Address -- + -------------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + Asiz : constant Integer := Integer (Address'Size) - 1; + + type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1; + -- Signed type of same size as Address + + function To_A is new Ada.Unchecked_Conversion (SA, Address); + function From_A is new Ada.Unchecked_Conversion (Address, SA); + + function "+" (Left : Address; Right : Integer) return Address is + begin + return To_A (From_A (Left) + SA (Right)); + end "+"; + + function "+" (Left : Integer; Right : Address) return Address is + begin + return To_A (SA (Left) + From_A (Right)); + end "+"; + + function "-" (Left : Address; Right : Address) return Integer is + pragma Unsuppress (All_Checks); + -- Because this can raise Constraint_Error for 64-bit addresses + begin + return Integer (From_A (Left) - From_A (Right)); + end "-"; + + function "-" (Left : Address; Right : Integer) return Address is + begin + return To_A (From_A (Left) - SA (Right)); + end "-"; + + ------------------------ + -- Fetch_From_Address -- + ------------------------ + + function Fetch_From_Address (A : Address) return Target is + type T_Ptr is access all Target; + function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); + Ptr : constant T_Ptr := To_T_Ptr (A); + begin + return Ptr.all; + end Fetch_From_Address; + + ----------------------- + -- Assign_To_Address -- + ----------------------- + + procedure Assign_To_Address (A : Address; T : Target) is + type T_Ptr is access all Target; + function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); + Ptr : constant T_Ptr := To_T_Ptr (A); + begin + Ptr.all := T; + end Assign_To_Address; + + --------------------------------- + -- Operations on Unsigned_Byte -- + --------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type BU is mod 2 ** Unsigned_Byte'Size; + -- Unsigned type of same length as Unsigned_Byte + + function To_B is new Ada.Unchecked_Conversion (BU, Unsigned_Byte); + function From_B is new Ada.Unchecked_Conversion (Unsigned_Byte, BU); + + function "not" (Left : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (not From_B (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (From_B (Left) and From_B (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (From_B (Left) or From_B (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (From_B (Left) xor From_B (Right)); + end "xor"; + + --------------------------------- + -- Operations on Unsigned_Word -- + --------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type WU is mod 2 ** Unsigned_Word'Size; + -- Unsigned type of same length as Unsigned_Word + + function To_W is new Ada.Unchecked_Conversion (WU, Unsigned_Word); + function From_W is new Ada.Unchecked_Conversion (Unsigned_Word, WU); + + function "not" (Left : Unsigned_Word) return Unsigned_Word is + begin + return To_W (not From_W (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is + begin + return To_W (From_W (Left) and From_W (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is + begin + return To_W (From_W (Left) or From_W (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is + begin + return To_W (From_W (Left) xor From_W (Right)); + end "xor"; + + ------------------------------------- + -- Operations on Unsigned_Longword -- + ------------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type LWU is mod 2 ** Unsigned_Longword'Size; + -- Unsigned type of same length as Unsigned_Longword + + function To_LW is new Ada.Unchecked_Conversion (LWU, Unsigned_Longword); + function From_LW is new Ada.Unchecked_Conversion (Unsigned_Longword, LWU); + + function "not" (Left : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (not From_LW (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (From_LW (Left) and From_LW (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (From_LW (Left) or From_LW (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (From_LW (Left) xor From_LW (Right)); + end "xor"; + + ------------------------------- + -- Operations on Unsigned_32 -- + ------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type U32 is mod 2 ** Unsigned_32'Size; + -- Unsigned type of same length as Unsigned_32 + + function To_U32 is new Ada.Unchecked_Conversion (U32, Unsigned_32); + function From_U32 is new Ada.Unchecked_Conversion (Unsigned_32, U32); + + function "not" (Left : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (not From_U32 (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (From_U32 (Left) and From_U32 (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (From_U32 (Left) or From_U32 (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (From_U32 (Left) xor From_U32 (Right)); + end "xor"; + + ------------------------------------- + -- Operations on Unsigned_Quadword -- + ------------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size + -- Unsigned type of same length as Unsigned_Quadword + + function To_QW is new Ada.Unchecked_Conversion (QWU, Unsigned_Quadword); + function From_QW is new Ada.Unchecked_Conversion (Unsigned_Quadword, QWU); + + function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (not From_QW (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (From_QW (Left) and From_QW (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (From_QW (Left) or From_QW (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (From_QW (Left) xor From_QW (Right)); + end "xor"; + + ----------------------- + -- Clear_Interlocked -- + ----------------------- + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + use ASCII; + Clr_Bit : Boolean := Bit; + Old_Bit : Boolean; + begin + System.Machine_Code.Asm + ( + "lda $16, %2" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $17 " & LF & HT & + "bis $31, 1, $1" & LF & HT & + "and $17, 63, $18" & LF & HT & + "bic $17, 63, $17" & LF & HT & + "sra $17, 3, $17" & LF & HT & + "bis $31, 1, %1" & LF & HT & + "sll %1, $18, $18" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, 0($17)" & LF & HT & + "and $1, $18, %1" & LF & HT & + "bic $1, $18, $1" & LF & HT & + "stq_c $1, 0($17)" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "beq $1, 1b" & LF & HT & + "mb" & LF & HT & + "xor %1, 1, %1" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), + Boolean'Asm_Output ("=r", Old_Bit)), + Inputs => Boolean'Asm_Input ("m", Clr_Bit), + Clobber => "$1, $16, $17, $18", + Volatile => True); + + Bit := Clr_Bit; + Old_Value := Old_Bit; + end Clear_Interlocked; + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean) + is + use ASCII; + Clr_Bit : Boolean := Bit; + Succ, Old_Bit : Boolean; + begin + System.Machine_Code.Asm + ( + "lda $16, %3" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $18 " & LF & HT & + "bis $31, 1, %1" & LF & HT & + "and $18, 63, $19" & LF & HT & + "bic $18, 63, $18" & LF & HT & + "sra $18, 3, $18" & LF & HT & + "bis $31, %4, $17" & LF & HT & + "sll %1, $19, $19" & LF & HT & + "1:" & LF & HT & + "ldq_l %2, 0($18)" & LF & HT & + "and %2, $19, %1" & LF & HT & + "bic %2, $19, %2" & LF & HT & + "stq_c %2, 0($18)" & LF & HT & + "beq %2, 2f" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "br 3f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "xor %1, 1, %1" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), + Boolean'Asm_Output ("=r", Old_Bit), + Boolean'Asm_Output ("=r", Succ)), + Inputs => (Boolean'Asm_Input ("m", Clr_Bit), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$16, $17, $18, $19", + Volatile => True); + + Bit := Clr_Bit; + Old_Value := Old_Bit; + Success_Flag := Succ; + end Clear_Interlocked; + + --------------------- + -- Set_Interlocked -- + --------------------- + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + use ASCII; + Set_Bit : Boolean := Bit; + Old_Bit : Boolean; + begin + System.Machine_Code.Asm + ( + "lda $16, %2" & LF & HT & + "sll $16, 3, $17 " & LF & HT & + "bis $31, 1, $1" & LF & HT & + "and $17, 63, $18" & LF & HT & + "mb" & LF & HT & + "bic $17, 63, $17" & LF & HT & + "sra $17, 3, $17" & LF & HT & + "bis $31, 1, %1" & LF & HT & + "sll %1, $18, $18" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, 0($17)" & LF & HT & + "and $1, $18, %1" & LF & HT & + "bis $1, $18, $1" & LF & HT & + "stq_c $1, 0($17)" & LF & HT & + "cmovne %1, 1, %1" & LF & HT & + "beq $1, 1b" & LF & HT & + "mb" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Set_Bit), + Boolean'Asm_Output ("=r", Old_Bit)), + Inputs => Boolean'Asm_Input ("m", Set_Bit), + Clobber => "$1, $16, $17, $18", + Volatile => True); + + Bit := Set_Bit; + Old_Value := Old_Bit; + end Set_Interlocked; + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean) + is + use ASCII; + Set_Bit : Boolean := Bit; + Succ, Old_Bit : Boolean; + begin + System.Machine_Code.Asm + ( + "lda $16, %3" & LF & HT & + "mb" & LF & HT & + "sll $16, 3, $18 " & LF & HT & + "bis $31, 1, %1" & LF & HT & + "and $18, 63, $19" & LF & HT & + "bic $18, 63, $18" & LF & HT & + "sra $18, 3, $18" & LF & HT & + "bis $31, %4, $17" & LF & HT & + "sll %1, $19, $19" & LF & HT & + "1:" & LF & HT & + "ldq_l %2, 0($18)" & LF & HT & + "and %2, $19, %1" & LF & HT & + "bis %2, $19, %2" & LF & HT & + "stq_c %2, 0($18)" & LF & HT & + "beq %2, 2f" & LF & HT & + "cmovne %1, 1, %1" & LF & HT & + "br 3f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "trapb", + Outputs => (Boolean'Asm_Output ("=m", Set_Bit), + Boolean'Asm_Output ("=r", Old_Bit), + Boolean'Asm_Output ("=r", Succ)), + Inputs => (Boolean'Asm_Input ("m", Set_Bit), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$16, $17, $18, $19", + Volatile => True); + + Bit := Set_Bit; + Old_Value := Old_Bit; + Success_Flag := Succ; + end Set_Interlocked; + + --------------------- + -- Add_Interlocked -- + --------------------- + + procedure Add_Interlocked + (Addend : Short_Integer; + Augend : in out Aligned_Word; + Sign : out Integer) + is + use ASCII; + Overflowed : Boolean := False; + begin + System.Machine_Code.Asm + ( + "lda $18, %0" & LF & HT & + "bic $18, 6, $21" & LF & HT & + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $0, 0($21)" & LF & HT & + "extwl $0, $18, $19" & LF & HT & + "mskwl $0, $18, $0" & LF & HT & + "addq $19, %3, $20" & LF & HT & + "inswl $20, $18, $17" & LF & HT & + "xor $19, %3, $19" & LF & HT & + "bis $17, $0, $0" & LF & HT & + "stq_c $0, 0($21)" & LF & HT & + "beq $0, 1b" & LF & HT & + "srl $20, 16, $0" & LF & HT & + "mb" & LF & HT & + "srl $20, 12, $21" & LF & HT & + "zapnot $20, 3, $20" & LF & HT & + "and $0, 1, $0" & LF & HT & + "and $21, 8, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "cmpeq $20, 0, $21" & LF & HT & + "xor $20, 2, $20" & LF & HT & + "sll $21, 2, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "bic $20, $19, $21" & LF & HT & + "srl $21, 14, $21" & LF & HT & + "and $21, 2, $21" & LF & HT & + "bis $21, $0, $0" & LF & HT & + "and $0, 2, %2" & LF & HT & + "bne %2, 2f" & LF & HT & + "and $0, 4, %1" & LF & HT & + "cmpeq %1, 0, %1" & LF & HT & + "and $0, 8, $0" & LF & HT & + "lda $16, -1" & LF & HT & + "cmovne $0, $16, %1" & LF & HT & + "2:", + Outputs => (Aligned_Word'Asm_Output ("=m", Augend), + Integer'Asm_Output ("=r", Sign), + Boolean'Asm_Output ("=r", Overflowed)), + Inputs => (Short_Integer'Asm_Input ("r", Addend), + Aligned_Word'Asm_Input ("m", Augend)), + Clobber => "$0, $1, $16, $17, $18, $19, $20, $21", + Volatile => True); + + if Overflowed then + raise Constraint_Error; + end if; + end Add_Interlocked; + + ---------------- + -- Add_Atomic -- + ---------------- + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : Integer) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "addl $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", Amount)), + Clobber => "$0, $1", + Volatile => True); + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "addl $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", Amount), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : Long_Integer) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "addq $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", Amount)), + Clobber => "$0, $1", + Volatile => True); + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "addq $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", Amount), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Add_Atomic; + + ---------------- + -- And_Atomic -- + ---------------- + + procedure And_Atomic + (To : in out Aligned_Integer; + From : Integer) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "and $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Integer; + From : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "and $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "and $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "and $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end And_Atomic; + + --------------- + -- Or_Atomic -- + --------------- + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : Integer) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "bis $1, %2, $0" & LF & HT & + "stl_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldl_l $1, %0" & LF & HT & + "bis $1, %4, $0" & LF & HT & + "stl_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stl $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Integer'Asm_Output ("=m", To), + Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Integer'Asm_Input ("m", To), + Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "bis $1, %2, $0" & LF & HT & + "stq_c $0, %1" & LF & HT & + "beq $0, 1b" & LF & HT & + "mb", + Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From)), + Clobber => "$0, $1", + Volatile => True); + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "mb" & LF & HT & + "bis $31, %5, $17" & LF & HT & + "1:" & LF & HT & + "ldq_l $1, %0" & LF & HT & + "bis $1, %4, $0" & LF & HT & + "stq_c $0, %3" & LF & HT & + "beq $0, 2f" & LF & HT & + "3:" & LF & HT & + "mb" & LF & HT & + "stq $0, %2" & LF & HT & + "stq $1, %1" & LF & HT & + "br 4f" & LF & HT & + "2:" & LF & HT & + "subq $17, 1, $17" & LF & HT & + "bgt $17, 1b" & LF & HT & + "br 3b" & LF & HT & + "4:", + Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), + Long_Integer'Asm_Output ("=m", Old_Value), + Boolean'Asm_Output ("=m", Success_Flag)), + Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), + Long_Integer'Asm_Input ("rJ", From), + Natural'Asm_Input ("rJ", Retry_Count)), + Clobber => "$0, $1, $17", + Volatile => True); + end Or_Atomic; + + ------------ + -- Insqhi -- + ------------ + + procedure Insqhi + (Item : Address; + Header : Address; + Status : out Insq_Status) is + + use ASCII; + begin + System.Machine_Code.Asm + ( + "bis $31, %1, $17" & LF & HT & + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x87" & LF & HT & + "mb", + Outputs => Insq_Status'Asm_Output ("=v", Status), + Inputs => (Address'Asm_Input ("rJ", Item), + Address'Asm_Input ("rJ", Header)), + Clobber => "$16, $17", + Volatile => True); + end Insqhi; + + ------------ + -- Remqhi -- + ------------ + + procedure Remqhi + (Header : Address; + Item : out Address; + Status : out Remq_Status) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x93" & LF & HT & + "mb" & LF & HT & + "bis $31, $1, %1", + Outputs => (Remq_Status'Asm_Output ("=v", Status), + Address'Asm_Output ("=r", Item)), + Inputs => Address'Asm_Input ("rJ", Header), + Clobber => "$1, $16", + Volatile => True); + end Remqhi; + + ------------ + -- Insqti -- + ------------ + + procedure Insqti + (Item : Address; + Header : Address; + Status : out Insq_Status) is + + use ASCII; + begin + System.Machine_Code.Asm + ( + "bis $31, %1, $17" & LF & HT & + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x88" & LF & HT & + "mb", + Outputs => Insq_Status'Asm_Output ("=v", Status), + Inputs => (Address'Asm_Input ("rJ", Item), + Address'Asm_Input ("rJ", Header)), + Clobber => "$16, $17", + Volatile => True); + end Insqti; + + ------------ + -- Remqti -- + ------------ + + procedure Remqti + (Header : Address; + Item : out Address; + Status : out Remq_Status) + is + use ASCII; + begin + System.Machine_Code.Asm + ( + "bis $31, %2, $16" & LF & HT & + "mb" & LF & HT & + "call_pal 0x94" & LF & HT & + "mb" & LF & HT & + "bis $31, $1, %1", + Outputs => (Remq_Status'Asm_Output ("=v", Status), + Address'Asm_Output ("=r", Item)), + Inputs => Address'Asm_Input ("rJ", Header), + Clobber => "$1, $16", + Volatile => True); + end Remqti; + +end System.Aux_DEC; diff --git a/gcc/ada/s-auxdec-vms_64.ads b/gcc/ada/s-auxdec-vms_64.ads index 3213e18a642..a54f44f8e3f 100644 --- a/gcc/ada/s-auxdec-vms_64.ads +++ b/gcc/ada/s-auxdec-vms_64.ads @@ -578,6 +578,13 @@ private Mechanism => (Reference, Value, Value, Reference, Reference)); pragma Inline_Always (Or_Atomic); + -- Inline the VAX Queue Funtions + + pragma Inline_Always (Insqhi); + pragma Inline_Always (Remqhi); + pragma Inline_Always (Insqti); + pragma Inline_Always (Remqti); + -- Provide proper unchecked conversion definitions for transfer -- functions. Note that we need this level of indirection because -- the formal parameter name is X and not Source (and this is indeed diff --git a/gcc/ada/s-stoele.adb b/gcc/ada/s-stoele.adb index 0bab843c138..dfd78101232 100644 --- a/gcc/ada/s-stoele.adb +++ b/gcc/ada/s-stoele.adb @@ -37,6 +37,10 @@ package body System.Storage_Elements is pragma Suppress (All_Checks); + -- Conversion to/from address + + -- Note full qualification below of To_Address to avoid ambiguities on VMS. + function To_Address is new Ada.Unchecked_Conversion (Storage_Offset, Address); function To_Offset is @@ -61,22 +65,26 @@ package body System.Storage_Elements is function "+" (Left : Address; Right : Storage_Offset) return Address is begin - return To_Address (To_Integer (Left) + To_Integer (To_Address (Right))); + return System.Storage_Elements.To_Address + (To_Integer (Left) + To_Integer (To_Address (Right))); end "+"; function "+" (Left : Storage_Offset; Right : Address) return Address is begin - return To_Address (To_Integer (To_Address (Left)) + To_Integer (Right)); + return System.Storage_Elements.To_Address + (To_Integer (To_Address (Left)) + To_Integer (Right)); end "+"; function "-" (Left : Address; Right : Storage_Offset) return Address is begin - return To_Address (To_Integer (Left) - To_Integer (To_Address (Right))); + return System.Storage_Elements.To_Address + (To_Integer (Left) - To_Integer (To_Address (Right))); end "-"; function "-" (Left, Right : Address) return Storage_Offset is begin - return To_Offset (To_Address (To_Integer (Left) - To_Integer (Right))); + return To_Offset (System.Storage_Elements.To_Address + (To_Integer (Left) - To_Integer (Right))); end "-"; function "mod" diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index c29b783f5ea..3010183e44d 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -923,7 +923,21 @@ package body Sem_Ch4 is end if; end if; - Analyze_One_Call (N, Nam_Ent, False, Success); + -- If the call has been rewritten from a prefixed call, the first + -- parameter has been analyzed, but may need a subsequent + -- dereference, so skip its analysis now. + + if N /= Original_Node (N) + and then Nkind (Original_Node (N)) = Nkind (N) + and then Nkind (Name (N)) /= Nkind (Name (Original_Node (N))) + and then Present (Parameter_Associations (N)) + and then Present (Etype (First (Parameter_Associations (N)))) + then + Analyze_One_Call + (N, Nam_Ent, False, Success, Skip_First => True); + else + Analyze_One_Call (N, Nam_Ent, False, Success); + end if; -- If the interpretation succeeds, mark the proper type of the -- prefix (any valid candidate will do). If not, remove the @@ -6080,7 +6094,7 @@ package body Sem_Ch4 is First_Actual : Node_Id; begin - -- Place the name of the operation, with its interpretations, + -- Place the name of the operation, with its innterpretations, -- on the rewritten call. Set_Name (Call_Node, Subprog); @@ -6180,6 +6194,7 @@ package body Sem_Ch4 is if Is_Overloaded (Subprog) then Save_Interps (Subprog, Node_To_Replace); + else Analyze (Node_To_Replace); @@ -6788,7 +6803,7 @@ package body Sem_Ch4 is and then Present (First_Formal (Prim_Op)) and then Valid_First_Argument_Of (Prim_Op) and then - (Nkind (Call_Node) = N_Function_Call) + (Nkind (Call_Node) = N_Function_Call) = (Ekind (Prim_Op) = E_Function) then -- Ada 2005 (AI-251): If this primitive operation corresponds diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d1bbf53adf6..97e38230fa5 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1074,9 +1074,13 @@ package body Sem_Ch6 is return; end if; - -- If error analyzing prefix, then set Any_Type as result and return + -- If there is an error analyzing the name (which may have been + -- rewritten if the original call was in prefix notation) then error + -- has been emitted already, mark node and return. - if Etype (P) = Any_Type then + if Error_Posted (N) + or else Etype (Name (N)) = Any_Type + then Set_Etype (N, Any_Type); return; end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 96a295cd218..4dbd22aa5e0 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1669,6 +1669,10 @@ package body Sem_Res is -- Try and fix up a literal so that it matches its expected type. New -- literals are manufactured if necessary to avoid cascaded errors. + procedure Report_Ambiguous_Argument; + -- Additional diagnostics when an ambiguous call has an ambiguous + -- argument (typically a controlling actual). + procedure Resolution_Failed; -- Called when attempt at resolving current expression fails @@ -1733,6 +1737,38 @@ package body Sem_Res is end if; end Patch_Up_Value; + ------------------------------- + -- Report_Ambiguous_Argument -- + ------------------------------- + + procedure Report_Ambiguous_Argument is + Arg : constant Node_Id := First (Parameter_Associations (N)); + I : Interp_Index; + It : Interp; + + begin + if Nkind (Arg) = N_Function_Call + and then Is_Entity_Name (Name (Arg)) + and then Is_Overloaded (Name (Arg)) + then + Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg)); + + Get_First_Interp (Name (Arg), I, It); + while Present (It.Nam) loop + Error_Msg_Sloc := Sloc (It.Nam); + + if Nkind (Parent (It.Nam)) = N_Full_Type_Declaration then + Error_Msg_N ("interpretation (inherited) #!", Arg); + + else + Error_Msg_N ("interpretation #!", Arg); + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + end Report_Ambiguous_Argument; + ----------------------- -- Resolution_Failed -- ----------------------- @@ -2037,6 +2073,13 @@ package body Sem_Res is Error_Msg_N -- CODEFIX ("\\possible interpretation#!", N); end if; + + if Nkind_In + (N, N_Procedure_Call_Statement, N_Function_Call) + and then Present (Parameter_Associations (N)) + then + Report_Ambiguous_Argument; + end if; end if; Error_Msg_Sloc := Sloc (It.Nam); -- 2.30.2