Skip to content

R
riscv-gcc-1
Commit 7415029d by Arnaud Charlet
Options

[multiple changes] 

2010-06-14  Gary Dismukes  <dismukes@adacore.com>

	* gnat_ugn.texi: Minor typo fixes and wording changes

2010-06-14  Ed Schonberg  <schonberg@adacore.com>

	* 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  <rupp@adacore.com>

	* 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
parent 45c9edf6
Showing with 1178 additions and 25 deletions
gcc/ada/ChangeLog
2010-06-14 Gary Dismukes <dismukes@adacore.com>
* gnat_ugn.texi: Minor typo fixes and wording changes
2010-06-14 Ed Schonberg <schonberg@adacore.com>
* 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 <rupp@adacore.com>
* 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 <hainque@adacore.com> 2010-06-14 Olivier Hainque <hainque@adacore.com>
* initialize.c (VxWorks section): Update comments. * initialize.c (VxWorks section): Update comments.
......
gcc/ada/gcc-interface/Makefile.in
...@@ -391,6 +391,26 @@ DUMMY_SOCKETS_TARGET_PAIRS = \ ...@@ -391,6 +391,26 @@ DUMMY_SOCKETS_TARGET_PAIRS = \
g-sothco.ads<g-sothco-dummy.ads \ g-sothco.ads<g-sothco-dummy.ads \
g-sttsne.ads<g-sttsne-dummy.ads g-sttsne.ads<g-sttsne-dummy.ads
# On platform where atomic increment/decrement operations are supported
# special version of Ada.Strings.Unbounded package can be used.
ATOMICS_TARGET_PAIRS += \
a-stunau.adb<a-stunau-shared.adb \
a-suteio.adb<a-suteio-shared.adb \
a-strunb.ads<a-strunb-shared.ads \
a-strunb.adb<a-strunb-shared.adb \
a-stwiun.adb<a-stwiun-shared.adb \
a-stwiun.ads<a-stwiun-shared.ads \
a-swunau.adb<a-swunau-shared.adb \
a-swuwti.adb<a-swuwti-shared.adb \
a-stzunb.adb<a-stzunb-shared.adb \
a-stzunb.ads<a-stzunb-shared.ads \
a-szunau.adb<a-szunau-shared.adb \
a-szuzti.adb<a-szuzti-shared.adb
# Reset setting for now
ATOMICS_TARGET_PAIRS =
LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)ada/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/')) LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)ada/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/'))
# $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT. # $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT.
...@@ -468,7 +488,8 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) ...@@ -468,7 +488,8 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
g-sttsne.adb<g-sttsne-vxworks.adb \ g-sttsne.adb<g-sttsne-vxworks.adb \
g-sttsne.ads<g-sttsne-locking.ads \ g-sttsne.ads<g-sttsne-locking.ads \
g-trasym.ads<g-trasym-unimplemented.ads \ g-trasym.ads<g-trasym-unimplemented.ads \
g-trasym.adb<g-trasym-unimplemented.adb g-trasym.adb<g-trasym-unimplemented.adb \
$(ATOMICS_TARGET_PAIRS)
TOOLS_TARGET_PAIRS=\ TOOLS_TARGET_PAIRS=\
mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \ mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \
...@@ -563,7 +584,8 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),) ...@@ -563,7 +584,8 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),)
s-vxwork.ads<s-vxwork-ppc.ads \ s-vxwork.ads<s-vxwork-ppc.ads \
g-trasym.ads<g-trasym-unimplemented.ads \ g-trasym.ads<g-trasym-unimplemented.ads \
g-trasym.adb<g-trasym-unimplemented.adb \ g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-vxworks-ppc-vthread.ads system.ads<system-vxworks-ppc-vthread.ads \
$(ATOMICS_TARGET_PAIRS)
TOOLS_TARGET_PAIRS=\ TOOLS_TARGET_PAIRS=\
mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \ mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \
...@@ -627,6 +649,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksmils,$(targ))),) ...@@ -627,6 +649,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksmils,$(targ))),)
g-trasym.ads<g-trasym-unimplemented.ads \ g-trasym.ads<g-trasym-unimplemented.ads \
g-trasym.adb<g-trasym-unimplemented.adb \ g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-vxworks-ppc.ads \ system.ads<system-vxworks-ppc.ads \
$(ATOMICS_TARGET_PAIRS) \
$(DUMMY_SOCKETS_TARGET_PAIRS) $(DUMMY_SOCKETS_TARGET_PAIRS)
TOOLS_TARGET_PAIRS=\ TOOLS_TARGET_PAIRS=\
...@@ -949,7 +972,8 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(targ))),) ...@@ -949,7 +972,8 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(targ))),)
system.ads<system-solaris-sparc.ads system.ads<system-solaris-sparc.ads
LIBGNAT_TARGET_PAIRS_64 = \ LIBGNAT_TARGET_PAIRS_64 = \
system.ads<system-solaris-sparcv9.ads system.ads<system-solaris-sparcv9.ads \
$(ATOMICS_TARGET_PAIRS)
ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),) ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),)
ifeq ($(strip $(MULTISUBDIR)),/sparcv9) ifeq ($(strip $(MULTISUBDIR)),/sparcv9)
...@@ -1334,7 +1358,8 @@ ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),) ...@@ -1334,7 +1358,8 @@ ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),)
s-osprim.adb<s-osprim-posix.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<s-taprop-posix.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<s-taspri-posix.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<s-tpopsp-posix.adb s-tpopsp.adb<s-tpopsp-posix.adb \
$(ATOMICS_TARGET_PAIRS)
LIBGNAT_TARGET_PAIRS_32 = \ LIBGNAT_TARGET_PAIRS_32 = \
system.ads<system-aix.ads system.ads<system-aix.ads
...@@ -1440,7 +1465,8 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),) ...@@ -1440,7 +1465,8 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
s-taspri.ads<s-taspri-tru64.ads \ s-taspri.ads<s-taspri-tru64.ads \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
s-traceb.adb<s-traceb-mastop.adb \ s-traceb.adb<s-traceb-mastop.adb \
system.ads<system-tru64.ads system.ads<system-tru64.ads \
$(ATOMICS_TARGET_PAIRS)
TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-tru64.adb TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-tru64.adb
...@@ -1478,12 +1504,14 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ))) ...@@ -1478,12 +1504,14 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ)))
system.ads<system-vms-ia64.ads system.ads<system-vms-ia64.ads
LIBGNAT_TARGET_PAIRS_AUX2 = \ LIBGNAT_TARGET_PAIRS_AUX2 = \
s-parame.ads<s-parame-vms-ia64.ads s-parame.ads<s-parame-vms-ia64.ads \
$(ATOMICS_TARGET_PAIRS)
else else
ifeq ($(strip $(filter-out alpha64 dec vms% openvms% alphavms%,$(targ))),) ifeq ($(strip $(filter-out alpha64 dec vms% openvms% alphavms%,$(targ))),)
LIBGNAT_TARGET_PAIRS_AUX1 = \ LIBGNAT_TARGET_PAIRS_AUX1 = \
g-enblsp.adb<g-enblsp-vms-alpha.adb \ g-enblsp.adb<g-enblsp-vms-alpha.adb \
g-trasym.adb<g-trasym-vms-alpha.adb \ g-trasym.adb<g-trasym-vms-alpha.adb \
s-auxdec.adb<s-auxdec-vms-alpha.adb \
s-traent.adb<s-traent-vms.adb \ s-traent.adb<s-traent-vms.adb \
s-traent.ads<s-traent-vms.ads \ s-traent.ads<s-traent-vms.ads \
s-asthan.adb<s-asthan-vms-alpha.adb \ s-asthan.adb<s-asthan-vms-alpha.adb \
...@@ -1497,7 +1525,8 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ))) ...@@ -1497,7 +1525,8 @@ ifeq ($(strip $(filter-out alpha64 ia64 dec hp vms% openvms% alphavms%,$(targ)))
s-parame.ads<s-parame-vms-restrict.ads s-parame.ads<s-parame-vms-restrict.ads
else else
LIBGNAT_TARGET_PAIRS_AUX2 = \ LIBGNAT_TARGET_PAIRS_AUX2 = \
s-parame.ads<s-parame-vms-alpha.ads s-parame.ads<s-parame-vms-alpha.ads \
$(ATOMICS_TARGET_PAIRS)
endif endif
endif endif
endif endif
...@@ -1797,7 +1826,8 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(arch) $(osys))),) ...@@ -1797,7 +1826,8 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(arch) $(osys))),)
s-tasinf.adb<s-tasinf-linux.adb \ s-tasinf.adb<s-tasinf-linux.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \ s-taspri.ads<s-taspri-posix-noaltstack.ads \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
g-sercom.adb<g-sercom-linux.adb g-sercom.adb<g-sercom-linux.adb \
$(ATOMICS_TARGET_PAIRS)
LIBGNAT_TARGET_PAIRS_32 = \ LIBGNAT_TARGET_PAIRS_32 = \
system.ads<system-linux-ppc.ads system.ads<system-linux-ppc.ads
...@@ -1996,7 +2026,8 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),) ...@@ -1996,7 +2026,8 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \ s-taspri.ads<s-taspri-posix-noaltstack.ads \
g-sercom.adb<g-sercom-linux.adb \ g-sercom.adb<g-sercom-linux.adb \
system.ads<system-linux-ia64.ads system.ads<system-linux-ia64.ads \
$(ATOMICS_TARGET_PAIRS)
TOOLS_TARGET_PAIRS = \ TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \ mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
...@@ -2022,7 +2053,8 @@ ifeq ($(strip $(filter-out ia64% hp hpux%,$(targ))),) ...@@ -2022,7 +2053,8 @@ ifeq ($(strip $(filter-out ia64% hp hpux%,$(targ))),)
s-taprop.adb<s-taprop-posix.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \ s-taspri.ads<s-taspri-posix-noaltstack.ads \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
system.ads<system-hpux-ia64.ads system.ads<system-hpux-ia64.ads \
$(ATOMICS_TARGET_PAIRS)
TOOLS_TARGET_PAIRS = \ TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-ia64-hpux.adb mlib-tgt-specific.adb<mlib-tgt-specific-ia64-hpux.adb
...@@ -2052,7 +2084,8 @@ ifeq ($(strip $(filter-out alpha% linux%,$(arch) $(osys))),) ...@@ -2052,7 +2084,8 @@ ifeq ($(strip $(filter-out alpha% linux%,$(arch) $(osys))),)
s-taspri.ads<s-taspri-posix-noaltstack.ads \ s-taspri.ads<s-taspri-posix-noaltstack.ads \
g-trasym.ads<g-trasym-unimplemented.ads \ g-trasym.ads<g-trasym-unimplemented.ads \
g-trasym.adb<g-trasym-unimplemented.adb \ g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-linux-alpha.ads system.ads<system-linux-alpha.ads \
$(ATOMICS_TARGET_PAIRS)
TOOLS_TARGET_PAIRS = \ TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \ mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
...@@ -2083,7 +2116,8 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) ...@@ -2083,7 +2116,8 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
s-taspri.ads<s-taspri-posix.ads \ s-taspri.ads<s-taspri-posix.ads \
g-sercom.adb<g-sercom-linux.adb \ g-sercom.adb<g-sercom-linux.adb \
system.ads<system-linux-x86_64.ads system.ads<system-linux-x86_64.ads \
$(ATOMICS_TARGET_PAIRS)
TOOLS_TARGET_PAIRS = \ TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \ mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
...@@ -2138,7 +2172,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) ...@@ -2138,7 +2172,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),)
a-numaux.adb<a-numaux-x86.adb \ a-numaux.adb<a-numaux-x86.adb \
g-trasym.ads<g-trasym-unimplemented.ads \ g-trasym.ads<g-trasym-unimplemented.ads \
g-trasym.adb<g-trasym-unimplemented.adb \ g-trasym.adb<g-trasym-unimplemented.adb \
system.ads<system-darwin-x86_64.ads system.ads<system-darwin-x86_64.ads \
$(ATOMICS_TARGET_PAIRS)
endif endif
ifeq ($(strip $(filter-out powerpc%,$(arch))),) ifeq ($(strip $(filter-out powerpc%,$(arch))),)
......
gcc/ada/gnat_ugn.texi
...@@ -16675,9 +16675,9 @@ The additional @command{gnatpp} switches are defined in this subsection. ...@@ -16675,9 +16675,9 @@ The additional @command{gnatpp} switches are defined in this subsection.
@item ^-files @var{filename}^/FILES=@var{output_file}^ @item ^-files @var{filename}^/FILES=@var{output_file}^
@cindex @option{^-files^/FILES^} (@code{gnatpp}) @cindex @option{^-files^/FILES^} (@code{gnatpp})
Take the argument source files from the specified file. This file should be an Take the argument source files from the specified file. This file should be an
ordinary textual file containing file names separated by spaces or ordinary text file containing file names separated by spaces or
line breaks. You can use this switch more then once in the same call to line breaks. You can use this switch more than once in the same call to
@command{gnatpp}. You also can combine this switch with explicit list of @command{gnatpp}. You also can combine this switch with an explicit list of
files. files.
@item ^-v^/VERBOSE^ @item ^-v^/VERBOSE^
...@@ -17358,7 +17358,7 @@ Do not generate the output in text form (implies @option{^-x^/XML^}) ...@@ -17358,7 +17358,7 @@ Do not generate the output in text form (implies @option{^-x^/XML^})
@cindex @option{^-d^/DIRECTORY^} (@command{gnatmetric}) @cindex @option{^-d^/DIRECTORY^} (@command{gnatmetric})
@item ^-d @var{output_dir}^/DIRECTORY=@var{output_dir}^ @item ^-d @var{output_dir}^/DIRECTORY=@var{output_dir}^
Put textual files with detailed metrics into @var{output_dir} Put text files with detailed metrics into @var{output_dir}
@cindex @option{^-o^/SUFFIX_DETAILS^} (@command{gnatmetric}) @cindex @option{^-o^/SUFFIX_DETAILS^} (@command{gnatmetric})
@item ^-o @var{file_suffix}^/SUFFIX_DETAILS=@var{file_suffix}^ @item ^-o @var{file_suffix}^/SUFFIX_DETAILS=@var{file_suffix}^
...@@ -17935,7 +17935,7 @@ Additional @command{gnatmetric} switches are as follows: ...@@ -17935,7 +17935,7 @@ Additional @command{gnatmetric} switches are as follows:
@cindex @option{^-files^/FILES^} (@code{gnatmetric}) @cindex @option{^-files^/FILES^} (@code{gnatmetric})
Take the argument source files from the specified file. This file should be an Take the argument source files from the specified file. This file should be an
ordinary text file containing file names separated by spaces or ordinary text file containing file names separated by spaces or
line breaks. You can use this switch more then once in the same call to line breaks. You can use this switch more than once in the same call to
@command{gnatmetric}. You also can combine this switch with @command{gnatmetric}. You also can combine this switch with
an explicit list of files. an explicit list of files.
gcc/ada/s-auxdec-vms-alpha.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A U X _ D E C --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2010, 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. --
-- --
------------------------------------------------------------------------------
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;
gcc/ada/s-auxdec-vms_64.ads
...@@ -578,6 +578,13 @@ private ...@@ -578,6 +578,13 @@ private
Mechanism => (Reference, Value, Value, Reference, Reference)); Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Inline_Always (Or_Atomic); 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 -- Provide proper unchecked conversion definitions for transfer
-- functions. Note that we need this level of indirection because -- functions. Note that we need this level of indirection because
-- the formal parameter name is X and not Source (and this is indeed -- the formal parameter name is X and not Source (and this is indeed
......
gcc/ada/s-stoele.adb
...@@ -37,6 +37,10 @@ package body System.Storage_Elements is ...@@ -37,6 +37,10 @@ package body System.Storage_Elements is
pragma Suppress (All_Checks); pragma Suppress (All_Checks);
-- Conversion to/from address
-- Note full qualification below of To_Address to avoid ambiguities on VMS.
function To_Address is function To_Address is
new Ada.Unchecked_Conversion (Storage_Offset, Address); new Ada.Unchecked_Conversion (Storage_Offset, Address);
function To_Offset is function To_Offset is
...@@ -61,22 +65,26 @@ package body System.Storage_Elements is ...@@ -61,22 +65,26 @@ package body System.Storage_Elements is
function "+" (Left : Address; Right : Storage_Offset) return Address is function "+" (Left : Address; Right : Storage_Offset) return Address is
begin 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 "+"; end "+";
function "+" (Left : Storage_Offset; Right : Address) return Address is function "+" (Left : Storage_Offset; Right : Address) return Address is
begin 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 "+"; end "+";
function "-" (Left : Address; Right : Storage_Offset) return Address is function "-" (Left : Address; Right : Storage_Offset) return Address is
begin 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 "-"; end "-";
function "-" (Left, Right : Address) return Storage_Offset is function "-" (Left, Right : Address) return Storage_Offset is
begin 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 "-"; end "-";
function "mod" function "mod"
......
gcc/ada/sem_ch4.adb
...@@ -923,7 +923,21 @@ package body Sem_Ch4 is ...@@ -923,7 +923,21 @@ package body Sem_Ch4 is
end if; end if;
end if; end if;
-- 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); Analyze_One_Call (N, Nam_Ent, False, Success);
end if;
-- If the interpretation succeeds, mark the proper type of the -- If the interpretation succeeds, mark the proper type of the
-- prefix (any valid candidate will do). If not, remove the -- prefix (any valid candidate will do). If not, remove the
...@@ -6080,7 +6094,7 @@ package body Sem_Ch4 is ...@@ -6080,7 +6094,7 @@ package body Sem_Ch4 is
First_Actual : Node_Id; First_Actual : Node_Id;
begin begin
-- Place the name of the operation, with its interpretations, -- Place the name of the operation, with its innterpretations,
-- on the rewritten call. -- on the rewritten call.
Set_Name (Call_Node, Subprog); Set_Name (Call_Node, Subprog);
...@@ -6180,6 +6194,7 @@ package body Sem_Ch4 is ...@@ -6180,6 +6194,7 @@ package body Sem_Ch4 is
if Is_Overloaded (Subprog) then if Is_Overloaded (Subprog) then
Save_Interps (Subprog, Node_To_Replace); Save_Interps (Subprog, Node_To_Replace);
else else
Analyze (Node_To_Replace); Analyze (Node_To_Replace);
......
gcc/ada/sem_ch6.adb
...@@ -1074,9 +1074,13 @@ package body Sem_Ch6 is ...@@ -1074,9 +1074,13 @@ package body Sem_Ch6 is
return; return;
end if; 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); Set_Etype (N, Any_Type);
return; return;
end if; end if;
......
gcc/ada/sem_res.adb
...@@ -1669,6 +1669,10 @@ package body Sem_Res is ...@@ -1669,6 +1669,10 @@ package body Sem_Res is
-- Try and fix up a literal so that it matches its expected type. New -- Try and fix up a literal so that it matches its expected type. New
-- literals are manufactured if necessary to avoid cascaded errors. -- 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; procedure Resolution_Failed;
-- Called when attempt at resolving current expression fails -- Called when attempt at resolving current expression fails
...@@ -1733,6 +1737,38 @@ package body Sem_Res is ...@@ -1733,6 +1737,38 @@ package body Sem_Res is
end if; end if;
end Patch_Up_Value; 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 -- -- Resolution_Failed --
----------------------- -----------------------
...@@ -2037,6 +2073,13 @@ package body Sem_Res is ...@@ -2037,6 +2073,13 @@ package body Sem_Res is
Error_Msg_N -- CODEFIX Error_Msg_N -- CODEFIX
("\\possible interpretation#!", N); ("\\possible interpretation#!", N);
end if; 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; end if;
Error_Msg_Sloc := Sloc (It.Nam); Error_Msg_Sloc := Sloc (It.Nam);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment