+2017-09-11 Yannick Moy <moy@adacore.com>
+
+ * lib-xref-spark_specific.adb: Minor rewrite.
+
+2017-09-11 Jerome Lambourg <lambourg@adacore.com>
+
+ * libgnat: Rename ?-[a-z]*-* into ?-[a-z]*__*
+ * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Take this
+ renaming into account.
+
2017-09-11 Jerome Lambourg <lambourg@adacore.com>
* libgnarl: Rename ?-[a-z]*-* into ?-[a-z]*__*
ada/libgnat/s-excmac.o: ada/libgnat/s-excmac.ads ada/libgnat/s-excmac.adb
-ada/libgnat/s-excmac.ads: $(srcdir)/ada/libgnat/s-excmac-$(EH_MECHANISM).ads
+ada/libgnat/s-excmac.ads: $(srcdir)/ada/libgnat/s-excmac__$(EH_MECHANISM).ads
mkdir -p ada/libgnat
$(CP) $< $@
-ada/libgnat/s-excmac.adb: $(srcdir)/ada/libgnat/s-excmac-$(EH_MECHANISM).adb
+ada/libgnat/s-excmac.adb: $(srcdir)/ada/libgnat/s-excmac__$(EH_MECHANISM).adb
mkdir -p ada/libgnat
$(CP) $< $@
s-inmaop.adb<libgnarl/s-inmaop__dummy.adb \
s-intman.adb<libgnarl/s-intman__dummy.adb \
s-osinte.ads<libgnarl/s-osinte__dummy.ads \
-s-osprim.adb<libgnat/s-osprim-posix.adb \
+s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__dummy.adb \
s-taspri.ads<libgnarl/s-taspri__dummy.ads
g-soliop$(objext) g-sothco$(objext)
DUMMY_SOCKETS_TARGET_PAIRS = \
- g-socket.adb<libgnat/g-socket-dummy.adb \
- g-socket.ads<libgnat/g-socket-dummy.ads \
- g-socthi.adb<libgnat/g-socthi-dummy.adb \
- g-socthi.ads<libgnat/g-socthi-dummy.ads \
- g-sothco.adb<libgnat/g-sothco-dummy.adb \
- g-sothco.ads<libgnat/g-sothco-dummy.ads
+ g-socket.adb<libgnat/g-socket__dummy.adb \
+ g-socket.ads<libgnat/g-socket__dummy.ads \
+ g-socthi.adb<libgnat/g-socthi__dummy.adb \
+ g-socthi.ads<libgnat/g-socthi__dummy.ads \
+ g-sothco.adb<libgnat/g-sothco__dummy.adb \
+ g-sothco.ads<libgnat/g-sothco__dummy.ads
# On platforms where atomic increment/decrement operations are supported,
# special version of Ada.Strings.Unbounded package can be used.
ATOMICS_TARGET_PAIRS = \
- a-coinho.adb<libgnat/a-coinho-shared.adb \
- a-coinho.ads<libgnat/a-coinho-shared.ads \
- a-stunau.adb<libgnat/a-stunau-shared.adb \
- a-suteio.adb<libgnat/a-suteio-shared.adb \
- a-strunb.ads<libgnat/a-strunb-shared.ads \
- a-strunb.adb<libgnat/a-strunb-shared.adb \
- a-stwiun.adb<libgnat/a-stwiun-shared.adb \
- a-stwiun.ads<libgnat/a-stwiun-shared.ads \
- a-swunau.adb<libgnat/a-swunau-shared.adb \
- a-swuwti.adb<libgnat/a-swuwti-shared.adb \
- a-stzunb.adb<libgnat/a-stzunb-shared.adb \
- a-stzunb.ads<libgnat/a-stzunb-shared.ads \
- a-szunau.adb<libgnat/a-szunau-shared.adb \
- a-szuzti.adb<libgnat/a-szuzti-shared.adb
+ a-coinho.adb<libgnat/a-coinho__shared.adb \
+ a-coinho.ads<libgnat/a-coinho__shared.ads \
+ a-stunau.adb<libgnat/a-stunau__shared.adb \
+ a-suteio.adb<libgnat/a-suteio__shared.adb \
+ a-strunb.ads<libgnat/a-strunb__shared.ads \
+ a-strunb.adb<libgnat/a-strunb__shared.adb \
+ a-stwiun.adb<libgnat/a-stwiun__shared.adb \
+ a-stwiun.ads<libgnat/a-stwiun__shared.ads \
+ a-swunau.adb<libgnat/a-swunau__shared.adb \
+ a-swuwti.adb<libgnat/a-swuwti__shared.adb \
+ a-stzunb.adb<libgnat/a-stzunb__shared.adb \
+ a-stzunb.ads<libgnat/a-stzunb__shared.ads \
+ a-szunau.adb<libgnat/a-szunau__shared.adb \
+ a-szuzti.adb<libgnat/a-szuzti__shared.adb
ATOMICS_BUILTINS_TARGET_PAIRS = \
- s-atocou.adb<libgnat/s-atocou-builtin.adb
+ s-atocou.adb<libgnat/s-atocou__builtin.adb
# Special version of units for x86 and x86-64 platforms.
X86_TARGET_PAIRS = \
- a-numaux.ads<libgnat/a-numaux-x86.ads \
- a-numaux.adb<libgnat/a-numaux-x86.adb \
- s-atocou.adb<libgnat/s-atocou-x86.adb
+ a-numaux.ads<libgnat/a-numaux__x86.ads \
+ a-numaux.adb<libgnat/a-numaux__x86.adb \
+ s-atocou.adb<libgnat/s-atocou__x86.adb
X86_64_TARGET_PAIRS = \
- a-numaux.ads<libgnat/a-numaux-x86.ads \
- a-numaux.adb<libgnat/a-numaux-x86.adb \
- s-atocou.adb<libgnat/s-atocou-builtin.adb
+ a-numaux.ads<libgnat/a-numaux__x86.ads \
+ a-numaux.adb<libgnat/a-numaux__x86.adb \
+ s-atocou.adb<libgnat/s-atocou__builtin.adb
# Implementation of symbolic traceback based on dwarf
TRASYM_DWARF_UNIX_PAIRS = \
- s-trasym.adb<libgnat/s-trasym-dwarf.adb \
- s-mmosin.ads<libgnat/s-mmosin-unix.ads \
- s-mmosin.adb<libgnat/s-mmosin-unix.adb \
- s-mmauni.ads<libgnat/s-mmauni-long.ads
+ s-trasym.adb<libgnat/s-trasym__dwarf.adb \
+ s-mmosin.ads<libgnat/s-mmosin__unix.ads \
+ s-mmosin.adb<libgnat/s-mmosin__unix.adb \
+ s-mmauni.ads<libgnat/s-mmauni__long.ads
TRASYM_DWARF_MINGW_PAIRS = \
- s-trasym.adb<libgnat/s-trasym-dwarf.adb \
- s-mmosin.ads<libgnat/s-mmosin-mingw.ads \
- s-mmosin.adb<libgnat/s-mmosin-mingw.adb
+ s-trasym.adb<libgnat/s-trasym__dwarf.adb \
+ s-mmosin.ads<libgnat/s-mmosin__mingw.ads \
+ s-mmosin.adb<libgnat/s-mmosin__mingw.adb
TRASYM_DWARF_COMMON_OBJS = s-objrea$(objext) s-dwalin$(objext) s-mmap$(objext) \
s-mmosin$(objext)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<libgnarl/a-intnam__vxworks.ads \
- a-numaux.ads<libgnat/a-numaux-vxworks.ads \
+ a-numaux.ads<libgnat/a-numaux__vxworks.ads \
s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \
s-intman.ads<libgnarl/s-intman__vxworks.ads \
s-intman.adb<libgnarl/s-intman__vxworks.adb \
s-osinte.ads<libgnarl/s-osinte__vxworks.ads \
s-osinte.adb<libgnarl/s-osinte__vxworks.adb \
- s-osprim.adb<libgnat/s-osprim-vxworks.adb \
- s-parame.ads<libgnat/s-parame-vxworks.ads \
- s-parame.adb<libgnat/s-parame-vxworks.adb \
+ s-osprim.adb<libgnat/s-osprim__vxworks.adb \
+ s-parame.ads<libgnat/s-parame__vxworks.ads \
+ s-parame.adb<libgnat/s-parame__vxworks.adb \
s-taprop.adb<libgnarl/s-taprop__vxworks.adb \
s-tasinf.ads<libgnarl/s-tasinf__vxworks.ads \
s-taspri.ads<libgnarl/s-taspri__vxworks.ads \
s-vxwork.ads<libgnarl/s-vxwork__ppc.ads \
- g-socthi.ads<libgnat/g-socthi-vxworks.ads \
- g-socthi.adb<libgnat/g-socthi-vxworks.adb \
- g-stsifd.adb<libgnat/g-stsifd-sockets.adb \
+ g-socthi.ads<libgnat/g-socthi__vxworks.ads \
+ g-socthi.adb<libgnat/g-socthi__vxworks.adb \
+ g-stsifd.adb<libgnat/g-stsifd__sockets.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
ifeq ($(strip $(filter-out default,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
- s-stchop.ads<libgnat/s-stchop-limit.ads \
- s-stchop.adb<libgnat/s-stchop-vxworks.adb
+ s-stchop.ads<libgnat/s-stchop__limit.ads \
+ s-stchop.adb<libgnat/s-stchop__vxworks.adb
EXTRA_GNATRTL_NONTASKING_OBJS+=s-stchop.o
endif
ifeq ($(strip $(filter-out x86_64, $(target_cpu))),)
X86CPU=x86_64
- LIBGNAT_TARGET_PAIRS=s-atocou.adb<libgnat/s-atocou-builtin.adb
+ LIBGNAT_TARGET_PAIRS=s-atocou.adb<libgnat/s-atocou__builtin.adb
else
X86CPU=x86
- LIBGNAT_TARGET_PAIRS=s-atocou.adb<libgnat/s-atocou-x86.adb
+ LIBGNAT_TARGET_PAIRS=s-atocou.adb<libgnat/s-atocou__x86.adb
endif
LIBGNAT_TARGET_PAIRS+= \
a-intnam.ads<libgnarl/a-intnam__vxworks.ads \
- i-vxwork.ads<libgnat/i-vxwork-x86.ads \
+ i-vxwork.ads<libgnat/i-vxwork__x86.ads \
s-osinte.adb<libgnarl/s-osinte__vxworks.adb \
s-osinte.ads<libgnarl/s-osinte__vxworks.ads \
s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \
s-intman.ads<libgnarl/s-intman__vxworks.ads \
s-intman.adb<libgnarl/s-intman__vxworks.adb \
- s-osprim.adb<libgnat/s-osprim-vxworks.adb \
- s-parame.ads<libgnat/s-parame-vxworks.ads \
- s-parame.adb<libgnat/s-parame-vxworks.adb \
- s-stchop.ads<libgnat/s-stchop-limit.ads \
- s-stchop.adb<libgnat/s-stchop-vxworks.adb \
+ s-osprim.adb<libgnat/s-osprim__vxworks.adb \
+ s-parame.ads<libgnat/s-parame__vxworks.ads \
+ s-parame.adb<libgnat/s-parame__vxworks.adb \
+ s-stchop.ads<libgnat/s-stchop__limit.ads \
+ s-stchop.adb<libgnat/s-stchop__vxworks.adb \
s-taprop.adb<libgnarl/s-taprop__vxworks.adb \
s-tasinf.ads<libgnarl/s-tasinf__vxworks.ads \
s-taspri.ads<libgnarl/s-taspri__vxworks.ads \
s-vxwork.ads<libgnarl/s-vxwork__x86.ads \
- g-socthi.ads<libgnat/g-socthi-vxworks.ads \
- g-socthi.adb<libgnat/g-socthi-vxworks.adb \
- g-stsifd.adb<libgnat/g-stsifd-sockets.adb \
+ g-socthi.ads<libgnat/g-socthi__vxworks.ads \
+ g-socthi.adb<libgnat/g-socthi__vxworks.adb \
+ g-stsifd.adb<libgnat/g-stsifd__sockets.adb \
$(ATOMICS_TARGET_PAIRS) \
$(CERTMATH_TARGET_PAIRS) \
$(CERTMATH_TARGET_PAIRS_SQRT_FPU) \
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<libgnarl/a-intnam__vxworks.ads \
- a-numaux.ads<libgnat/a-numaux-vxworks.ads \
+ a-numaux.ads<libgnat/a-numaux__vxworks.ads \
s-inmaop.adb<libgnarl/s-inmaop__vxworks.adb \
s-interr.adb<libgnarl/s-interr__vxworks.adb \
s-intman.ads<libgnarl/s-intman__vxworks.ads \
s-intman.adb<libgnarl/s-intman__vxworks.adb \
s-osinte.adb<libgnarl/s-osinte__vxworks.adb \
s-osinte.ads<libgnarl/s-osinte__vxworks.ads \
- s-osprim.adb<libgnat/s-osprim-vxworks.adb \
- s-parame.ads<libgnat/s-parame-vxworks.ads \
- s-parame.adb<libgnat/s-parame-vxworks.adb \
- s-stchop.ads<libgnat/s-stchop-limit.ads \
- s-stchop.adb<libgnat/s-stchop-vxworks.adb \
+ s-osprim.adb<libgnat/s-osprim__vxworks.adb \
+ s-parame.ads<libgnat/s-parame__vxworks.ads \
+ s-parame.adb<libgnat/s-parame__vxworks.adb \
+ s-stchop.ads<libgnat/s-stchop__limit.ads \
+ s-stchop.adb<libgnat/s-stchop__vxworks.adb \
s-taprop.adb<libgnarl/s-taprop__vxworks.adb \
s-tasinf.ads<libgnarl/s-tasinf__vxworks.ads \
s-taspri.ads<libgnarl/s-taspri__vxworks.ads \
s-vxwork.ads<libgnarl/s-vxwork__arm.ads \
- g-socthi.ads<libgnat/g-socthi-vxworks.ads \
- g-socthi.adb<libgnat/g-socthi-vxworks.adb \
- g-stsifd.adb<libgnat/g-stsifd-sockets.adb
+ g-socthi.ads<libgnat/g-socthi__vxworks.ads \
+ g-socthi.adb<libgnat/g-socthi__vxworks.adb \
+ g-stsifd.adb<libgnat/g-stsifd__sockets.adb
TOOLS_TARGET_PAIRS=indepsw.adb<indepsw-gnu.adb
s-linux.ads<libgnarl/s-linux__android.ads \
s-osinte.adb<libgnarl/s-osinte__android.adb \
s-osinte.ads<libgnarl/s-osinte__android.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.adb<libgnarl/s-osinte__solaris.adb \
s-osinte.ads<libgnarl/s-osinte__solaris.ads \
- s-osprim.adb<libgnat/s-osprim-solaris.adb \
+ s-osprim.adb<libgnat/s-osprim__solaris.adb \
s-taprop.adb<libgnarl/s-taprop__solaris.adb \
s-tasinf.adb<libgnarl/s-tasinf__solaris.adb \
s-tasinf.ads<libgnarl/s-tasinf__solaris.ads \
s-taspri.ads<libgnarl/s-taspri__solaris.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__solaris.adb \
- g-soliop.ads<libgnat/g-soliop-solaris.ads \
+ g-soliop.ads<libgnat/g-soliop__solaris.ads \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<libgnat/system-solaris-sparc.ads
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.adb<libgnarl/s-osinte__solaris.adb \
s-osinte.ads<libgnarl/s-osinte__solaris.ads \
- s-osprim.adb<libgnat/s-osprim-solaris.adb \
+ s-osprim.adb<libgnat/s-osprim__solaris.adb \
s-taprop.adb<libgnarl/s-taprop__solaris.adb \
s-tasinf.adb<libgnarl/s-tasinf__solaris.adb \
s-tasinf.ads<libgnarl/s-tasinf__solaris.ads \
s-taspri.ads<libgnarl/s-taspri__solaris.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__solaris.adb \
- g-soliop.ads<libgnat/g-soliop-solaris.ads \
+ g-soliop.ads<libgnat/g-soliop__solaris.ads \
$(ATOMICS_TARGET_PAIRS) \
system.ads<libgnat/system-solaris-x86.ads
s-intman.adb<libgnarl/s-intman__posix.adb \
s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \
$(TRASYM_DWARF_UNIX_PAIRS) \
- g-sercom.adb<libgnat/g-sercom-linux.adb \
- s-tsmona.adb<libgnat/s-tsmona-linux.adb \
+ g-sercom.adb<libgnat/g-sercom__linux.adb \
+ s-tsmona.adb<libgnat/s-tsmona__linux.adb \
a-exetim.adb<libgnarl/a-exetim__posix.adb \
a-exetim.ads<libgnarl/a-exetim__default.ads \
s-linux.ads<libgnarl/s-linux.ads \
LIBGNAT_TARGET_PAIRS += \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__kfreebsd-gnu.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-osinte.adb<libgnarl/s-osinte__gnu.adb \
s-osinte.ads<libgnarl/s-osinte__gnu.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \
ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<libgnarl/a-intnam__freebsd.ads \
- a-numaux.adb<libgnat/a-numaux-x86.adb \
- a-numaux.ads<libgnat/a-numaux-x86.ads \
+ a-numaux.adb<libgnat/a-numaux__x86.adb \
+ a-numaux.ads<libgnat/a-numaux__x86.ads \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__kfreebsd-gnu.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.adb<libgnarl/s-osinte__freebsd.adb \
s-osinte.ads<libgnarl/s-osinte__freebsd.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix.adb \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.adb<libgnarl/s-osinte__freebsd.adb \
s-osinte.ads<libgnarl/s-osinte__freebsd.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix.adb \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.adb<libgnarl/s-osinte__freebsd.adb \
s-osinte.ads<libgnarl/s-osinte__freebsd.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix.adb \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.adb<libgnarl/s-osinte__dragonfly.adb \
s-osinte.ads<libgnarl/s-osinte__dragonfly.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix.adb \
s-linux.ads<libgnarl/s-linux.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
# HP/PA HP-UX 10
ifeq ($(strip $(filter-out hppa% hp hpux10%,$(target_cpu) $(target_vendor) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
- a-excpol.adb<libgnat/a-excpol-abort.adb \
+ a-excpol.adb<libgnat/a-excpol__abort.adb \
a-intnam.ads<libgnarl/a-intnam__hpux.ads \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-interr.adb<libgnarl/s-interr__sigaction.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-osinte.adb<libgnarl/s-osinte__hpux-dce.adb \
s-osinte.ads<libgnarl/s-osinte__hpux-dce.ads \
- s-parame.ads<libgnat/s-parame-hpux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-parame.ads<libgnat/s-parame__hpux.ads \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__hpux-dce.adb \
s-taspri.ads<libgnarl/s-taspri__hpux-dce.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__hpux.ads \
- s-parame.ads<libgnat/s-parame-hpux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
- s-traceb.adb<libgnat/s-traceb-hpux.adb \
+ s-parame.ads<libgnat/s-parame__hpux.ads \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
+ s-traceb.adb<libgnat/s-traceb__hpux.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-osinte.adb<libgnarl/s-osinte__aix.adb \
s-osinte.ads<libgnarl/s-osinte__aix.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix.adb \
s-intman.adb<libgnarl/s-intman__posix.adb \
s-osinte.adb<libgnarl/s-osinte__rtems.adb \
s-osinte.ads<libgnarl/s-osinte__rtems.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
- s-parame.adb<libgnat/s-parame-rtems.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
+ s-parame.adb<libgnat/s-parame__rtems.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \
s-inmaop.adb<libgnarl/s-inmaop__dummy.adb \
s-intman.adb<libgnarl/s-intman__dummy.adb \
s-osinte.ads<libgnarl/s-osinte__dummy.ads \
- s-osprim.adb<libgnat/s-osprim-unix.adb \
+ s-osprim.adb<libgnat/s-osprim__unix.adb \
s-taprop.adb<libgnarl/s-taprop__dummy.adb \
s-taspri.ads<libgnarl/s-taspri__dummy.ads \
system.ads<libgnat/system-djgpp.ads \
g-socthi.adb<libgnat/g-socthi.adb
else
LIBGNAT_TARGET_PAIRS = \
- s-memory.adb<libgnat/s-memory-mingw.adb \
- g-socthi.ads<libgnat/g-socthi-mingw.ads \
- g-socthi.adb<libgnat/g-socthi-mingw.adb
+ s-memory.adb<libgnat/s-memory__mingw.adb \
+ g-socthi.ads<libgnat/g-socthi__mingw.ads \
+ g-socthi.adb<libgnat/g-socthi__mingw.adb
endif
LIBGNAT_TARGET_PAIRS += \
- a-dirval.adb<libgnat/a-dirval-mingw.adb \
- a-excpol.adb<libgnat/a-excpol-abort.adb \
- s-gloloc.adb<libgnat/s-gloloc-mingw.adb \
+ a-dirval.adb<libgnat/a-dirval__mingw.adb \
+ a-excpol.adb<libgnat/a-excpol__abort.adb \
+ s-gloloc.adb<libgnat/s-gloloc__mingw.adb \
s-inmaop.adb<libgnarl/s-inmaop__dummy.adb \
s-taspri.ads<libgnarl/s-taspri__mingw.ads \
s-tasinf.adb<libgnarl/s-tasinf__mingw.adb \
s-tasinf.ads<libgnarl/s-tasinf__mingw.ads \
- g-stsifd.adb<libgnat/g-stsifd-sockets.adb \
- g-soliop.ads<libgnat/g-soliop-mingw.ads \
+ g-stsifd.adb<libgnat/g-stsifd__sockets.adb \
+ g-soliop.ads<libgnat/g-soliop__mingw.ads \
$(ATOMICS_TARGET_PAIRS) \
system.ads<libgnat/system-mingw.ads
a-exetim.adb<libgnarl/a-exetim__mingw.adb \
a-exetim.ads<libgnarl/a-exetim__mingw.ads \
a-intnam.ads<libgnarl/a-intnam__mingw.ads \
- g-sercom.adb<libgnat/g-sercom-mingw.adb \
- s-tsmona.adb<libgnat/s-tsmona-mingw.adb \
+ g-sercom.adb<libgnat/g-sercom__mingw.adb \
+ s-tsmona.adb<libgnat/s-tsmona__mingw.adb \
s-interr.adb<libgnarl/s-interr__sigaction.adb \
s-intman.adb<libgnarl/s-intman__mingw.adb \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.ads<libgnarl/s-osinte__mingw.ads \
- s-osprim.adb<libgnat/s-osprim-mingw.adb \
+ s-osprim.adb<libgnat/s-osprim__mingw.adb \
s-taprop.adb<libgnarl/s-taprop__mingw.adb
ifeq ($(strip $(filter-out x86_64%,$(target_cpu))),)
s-linux.ads<libgnarl/s-linux__mips.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-taspri.ads<libgnarl/s-taspri__posix-noaltstack.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \
- g-sercom.adb<libgnat/g-sercom-linux.adb \
+ g-sercom.adb<libgnat/g-sercom__linux.adb \
system.ads<libgnat/system-linux-mips.ads
TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
s-linux.ads<libgnarl/s-linux.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \
- g-sercom.adb<libgnat/g-sercom-linux.adb \
+ g-sercom.adb<libgnat/g-sercom__linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<libgnat/system-linux-ppc.ads
$(LIBGNAT_TARGET_PAIRS_COMMON) \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-linux.ads<libgnarl/s-linux.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
- g-sercom.adb<libgnat/g-sercom-linux.adb \
+ g-sercom.adb<libgnat/g-sercom__linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<libgnat/system-linux-arm.ads
s-linux.ads<libgnarl/s-linux__sparc.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-linux.ads<libgnarl/s-linux__hppa.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-linux.ads<libgnat/s-linux.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-linux.ads<libgnarl/s-linux.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
a-exetim.adb<libgnarl/a-exetim__posix.adb \
a-exetim.ads<libgnarl/a-exetim__default.ads \
a-intnam.ads<libgnarl/a-intnam__linux.ads \
- a-numaux.ads<libgnat/a-numaux-libc-x86.ads \
+ a-numaux.ads<libgnat/a-numaux__libc-x86.ads \
a-synbar.adb<libgnarl/a-synbar__posix.adb \
a-synbar.ads<libgnarl/a-synbar__posix.ads \
s-inmaop.adb<libgnarl/s-inmaop__posix.adb \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \
s-taspri.ads<libgnarl/s-taspri__posix-noaltstack.ads \
- g-sercom.adb<libgnat/g-sercom-linux.adb \
+ g-sercom.adb<libgnat/g-sercom__linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<libgnat/system-linux-ia64.ads
s-intman.adb<libgnarl/s-intman__posix.adb \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
s-osinte.ads<libgnarl/s-osinte__hpux.ads \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb \
s-linux.ads<libgnarl/s-linux__alpha.ads \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
s-osinte.adb<libgnarl/s-osinte__posix.adb \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
- g-sercom.adb<libgnat/g-sercom-linux.adb \
+ g-sercom.adb<libgnat/g-sercom__linux.adb \
$(TRASYM_DWARF_UNIX_PAIRS) \
- s-tsmona.adb<libgnat/s-tsmona-linux.adb \
+ s-tsmona.adb<libgnat/s-tsmona__linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_64_TARGET_PAIRS) \
system.ads<libgnat/system-linux-x86.ads
s-mudido.adb<libgnarl/s-mudido__affinity.adb \
s-osinte.ads<libgnarl/s-osinte__linux.ads \
s-osinte.adb<libgnarl/s-osinte__x32.adb \
- s-osprim.adb<libgnat/s-osprim-x32.adb \
+ s-osprim.adb<libgnat/s-osprim__x32.adb \
s-taprop.adb<libgnarl/s-taprop__linux.adb \
s-tasinf.ads<libgnarl/s-tasinf__linux.ads \
s-tasinf.adb<libgnarl/s-tasinf__linux.adb \
s-tpopsp.adb<libgnarl/s-tpopsp__tls.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
- g-sercom.adb<libgnat/g-sercom-linux.adb \
+ g-sercom.adb<libgnat/g-sercom__linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_64_TARGET_PAIRS) \
system.ads<libgnat/system-linux-x86.ads
s-osinte.ads<libgnarl/s-osinte__darwin.ads \
s-taprop.adb<libgnarl/s-taprop__posix.adb \
s-taspri.ads<libgnarl/s-taspri__posix.ads \
- g-sercom.adb<libgnat/g-sercom-linux.adb \
+ g-sercom.adb<libgnat/g-sercom__linux.adb \
s-tpopsp.adb<libgnarl/s-tpopsp__posix-foreign.adb
ifeq ($(strip $(filter-out %86,$(target_cpu))),)
LIBGNAT_TARGET_PAIRS += \
s-intman.adb<libgnarl/s-intman__susv3.adb \
- s-osprim.adb<libgnat/s-osprim-darwin.adb \
+ s-osprim.adb<libgnat/s-osprim__darwin.adb \
$(ATOMICS_TARGET_PAIRS) \
system.ads<libgnat/system-darwin-x86.ads
ifeq ($(strip $(filter-out %x86_64,$(target_cpu))),)
LIBGNAT_TARGET_PAIRS += \
s-intman.adb<libgnarl/s-intman__susv3.adb \
- s-osprim.adb<libgnat/s-osprim-darwin.adb \
+ s-osprim.adb<libgnat/s-osprim__darwin.adb \
a-exetim.ads<libgnarl/a-exetim__default.ads \
a-exetim.adb<libgnarl/a-exetim__darwin.adb \
$(ATOMICS_TARGET_PAIRS) \
ifeq ($(strip $(filter-out powerpc%,$(target_cpu))),)
LIBGNAT_TARGET_PAIRS += \
s-intman.adb<libgnarl/s-intman__posix.adb \
- s-osprim.adb<libgnat/s-osprim-posix.adb \
- a-numaux.ads<libgnat/a-numaux-darwin.ads \
- a-numaux.adb<libgnat/a-numaux-darwin.adb \
+ s-osprim.adb<libgnat/s-osprim__posix.adb \
+ a-numaux.ads<libgnat/a-numaux__darwin.ads \
+ a-numaux.adb<libgnat/a-numaux__darwin.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<libgnat/system-darwin-ppc.ads
ifeq ($(strip $(filter-out arm,$(target_cpu))),)
LIBGNAT_TARGET_PAIRS += \
s-intman.adb<libgnarl/s-intman__susv3.adb \
- s-osprim.adb<libgnat/s-osprim-darwin.adb \
+ s-osprim.adb<libgnat/s-osprim__darwin.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
ifeq ($(strip $(filter-out arm64 aarch64,$(target_cpu))),)
LIBGNAT_TARGET_PAIRS += \
s-intman.adb<libgnarl/s-intman__susv3.adb \
- s-osprim.adb<libgnat/s-osprim-darwin.adb \
+ s-osprim.adb<libgnat/s-osprim__darwin.adb \
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
ifeq ($(EH_MECHANISM),-gcc)
LIBGNAT_TARGET_PAIRS += \
- s-excmac.ads<libgnat/s-excmac-gcc.ads \
- s-excmac.adb<libgnat/s-excmac-gcc.adb
+ s-excmac.ads<libgnat/s-excmac__gcc.ads \
+ s-excmac.adb<libgnat/s-excmac__gcc.adb
EXTRA_LIBGNAT_OBJS+=raise-gcc.o
EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o
endif
ifeq ($(EH_MECHANISM),-arm)
LIBGNAT_TARGET_PAIRS += \
- s-excmac.ads<libgnat/s-excmac-arm.ads \
- s-excmac.adb<libgnat/s-excmac-arm.adb
+ s-excmac.ads<libgnat/s-excmac__arm.ads \
+ s-excmac.adb<libgnat/s-excmac__arm.adb
EXTRA_LIBGNAT_OBJS+=raise-gcc.o
EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o
endif
# Remove files to be replaced by target dependent sources
$(RM) $(foreach PAIR,$(LIBGNAT_TARGET_PAIRS), \
$(RTSDIR)/$(word 1,$(subst <, ,$(PAIR))))
- for f in $(RTSDIR)/*-*-*.ads $(RTSDIR)/*-*-*.adb; do \
+ for f in $(RTSDIR)/*-*__*.ads $(RTSDIR)/*-*__*.adb; do \
case "$$f" in \
- $(RTSDIR)/s-stratt-*) ;; \
+ $(RTSDIR)/s-stratt__*) ;; \
*) $(RM) $$f ;; \
esac; \
done
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2013-2017, 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/>. --
-------------------------------------------------------------------------------
-
--- Note: special attention must be paid to the case of simultaneous access
--- to internal shared objects and elements by different tasks. The Reference
--- counter of internal shared object is the only component protected using
--- atomic operations; other components and elements can be modified only when
--- reference counter is equal to one (so there are no other references to this
--- internal shared object and element).
-
-with Ada.Unchecked_Deallocation;
-
-package body Ada.Containers.Indefinite_Holders is
-
- procedure Free is
- new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
-
- procedure Detach (Container : Holder);
- -- Detach data from shared copy if necessary. This is necessary to prepare
- -- container to be modified.
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left, Right : Holder) return Boolean is
- begin
- if Left.Reference = Right.Reference then
-
- -- Covers both null and not null but the same shared object cases
-
- return True;
-
- elsif Left.Reference /= null and Right.Reference /= null then
- return Left.Reference.Element.all = Right.Reference.Element.all;
-
- else
- return False;
- end if;
- end "=";
-
- ------------
- -- Adjust --
- ------------
-
- overriding procedure Adjust (Container : in out Holder) is
- begin
- if Container.Reference /= null then
- if Container.Busy = 0 then
-
- -- Container is not locked, reuse existing internal shared object
-
- Reference (Container.Reference);
- else
- -- Otherwise, create copy of both internal shared object and
- -- element.
-
- Container.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element =>
- new Element_Type'(Container.Reference.Element.all));
- end if;
- end if;
-
- Container.Busy := 0;
- end Adjust;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- Reference (Control.Container.Reference);
- Control.Container.Busy := Control.Container.Busy + 1;
- end if;
- end Adjust;
-
- ------------
- -- Assign --
- ------------
-
- procedure Assign (Target : in out Holder; Source : Holder) is
- begin
- if Target.Busy /= 0 then
- raise Program_Error with "attempt to tamper with elements";
- end if;
-
- if Target.Reference /= Source.Reference then
- if Target.Reference /= null then
- Unreference (Target.Reference);
- end if;
-
- Target.Reference := Source.Reference;
-
- if Source.Reference /= null then
- Reference (Target.Reference);
- end if;
- end if;
- end Assign;
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Container : in out Holder) is
- begin
- if Container.Busy /= 0 then
- raise Program_Error with "attempt to tamper with elements";
- end if;
-
- if Container.Reference /= null then
- Unreference (Container.Reference);
- Container.Reference := null;
- end if;
- end Clear;
-
- ------------------------
- -- Constant_Reference --
- ------------------------
-
- function Constant_Reference
- (Container : aliased Holder) return Constant_Reference_Type is
- begin
- if Container.Reference = null then
- raise Constraint_Error with "container is empty";
- end if;
-
- Detach (Container);
-
- declare
- Ref : constant Constant_Reference_Type :=
- (Element => Container.Reference.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access));
- begin
- Reference (Ref.Control.Container.Reference);
- Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1;
- return Ref;
- end;
- end Constant_Reference;
-
- ----------
- -- Copy --
- ----------
-
- function Copy (Source : Holder) return Holder is
- begin
- if Source.Reference = null then
- return (Controlled with null, 0);
-
- elsif Source.Busy = 0 then
-
- -- Container is not locked, reuse internal shared object
-
- Reference (Source.Reference);
-
- return (Controlled with Source.Reference, 0);
-
- else
- -- Otherwise, create copy of both internal shared object and element
-
- return
- (Controlled with
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(Source.Reference.Element.all)),
- 0);
- end if;
- end Copy;
-
- ------------
- -- Detach --
- ------------
-
- procedure Detach (Container : Holder) is
- begin
- if Container.Busy = 0
- and then not System.Atomic_Counters.Is_One
- (Container.Reference.Counter)
- then
- -- Container is not locked and internal shared object is used by
- -- other container, create copy of both internal shared object and
- -- element.
-
- declare
- Old : constant Shared_Holder_Access := Container.Reference;
-
- begin
- Container'Unrestricted_Access.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element =>
- new Element_Type'(Container.Reference.Element.all));
- Unreference (Old);
- end;
- end if;
- end Detach;
-
- -------------
- -- Element --
- -------------
-
- function Element (Container : Holder) return Element_Type is
- begin
- if Container.Reference = null then
- raise Constraint_Error with "container is empty";
- else
- return Container.Reference.Element.all;
- end if;
- end Element;
-
- --------------
- -- Finalize --
- --------------
-
- overriding procedure Finalize (Container : in out Holder) is
- begin
- if Container.Busy /= 0 then
- raise Program_Error with "attempt to tamper with elements";
- end if;
-
- if Container.Reference /= null then
- Unreference (Container.Reference);
- Container.Reference := null;
- end if;
- end Finalize;
-
- overriding procedure Finalize (Control : in out Reference_Control_Type) is
- begin
- if Control.Container /= null then
- Unreference (Control.Container.Reference);
- Control.Container.Busy := Control.Container.Busy - 1;
- Control.Container := null;
- end if;
- end Finalize;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty (Container : Holder) return Boolean is
- begin
- return Container.Reference = null;
- end Is_Empty;
-
- ----------
- -- Move --
- ----------
-
- procedure Move (Target : in out Holder; Source : in out Holder) is
- begin
- if Target.Busy /= 0 then
- raise Program_Error with "attempt to tamper with elements";
- end if;
-
- if Source.Busy /= 0 then
- raise Program_Error with "attempt to tamper with elements";
- end if;
-
- if Target.Reference /= Source.Reference then
- if Target.Reference /= null then
- Unreference (Target.Reference);
- end if;
-
- Target.Reference := Source.Reference;
- Source.Reference := null;
- end if;
- end Move;
-
- -------------------
- -- Query_Element --
- -------------------
-
- procedure Query_Element
- (Container : Holder;
- Process : not null access procedure (Element : Element_Type))
- is
- B : Natural renames Container'Unrestricted_Access.Busy;
-
- begin
- if Container.Reference = null then
- raise Constraint_Error with "container is empty";
- end if;
-
- Detach (Container);
-
- B := B + 1;
-
- begin
- Process (Container.Reference.Element.all);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
- end Query_Element;
-
- ----------
- -- Read --
- ----------
-
- procedure Read
- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- Container : out Holder)
- is
- begin
- Clear (Container);
-
- if not Boolean'Input (Stream) then
- Container.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(Element_Type'Input (Stream)));
- end if;
- end Read;
-
- procedure Read
- (Stream : not null access Root_Stream_Type'Class;
- Item : out Constant_Reference_Type)
- is
- begin
- raise Program_Error with "attempt to stream reference";
- end Read;
-
- procedure Read
- (Stream : not null access Root_Stream_Type'Class;
- Item : out Reference_Type)
- is
- begin
- raise Program_Error with "attempt to stream reference";
- end Read;
-
- ---------------
- -- Reference --
- ---------------
-
- procedure Reference (Item : not null Shared_Holder_Access) is
- begin
- System.Atomic_Counters.Increment (Item.Counter);
- end Reference;
-
- function Reference
- (Container : aliased in out Holder) return Reference_Type
- is
- begin
- if Container.Reference = null then
- raise Constraint_Error with "container is empty";
- end if;
-
- Detach (Container);
-
- declare
- Ref : constant Reference_Type :=
- (Element => Container.Reference.Element.all'Access,
- Control => (Controlled with Container'Unrestricted_Access));
- begin
- Reference (Ref.Control.Container.Reference);
- Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1;
- return Ref;
- end;
- end Reference;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Container : in out Holder;
- New_Item : Element_Type)
- is
- -- Element allocator may need an accessibility check in case actual type
- -- is class-wide or has access discriminants (RM 4.8(10.1) and
- -- AI12-0035).
-
- pragma Unsuppress (Accessibility_Check);
-
- begin
- if Container.Busy /= 0 then
- raise Program_Error with "attempt to tamper with elements";
- end if;
-
- if Container.Reference = null then
- -- Holder is empty, allocate new Shared_Holder.
-
- Container.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(New_Item));
-
- elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then
- -- Shared_Holder can be reused.
-
- Free (Container.Reference.Element);
- Container.Reference.Element := new Element_Type'(New_Item);
-
- else
- Unreference (Container.Reference);
- Container.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(New_Item));
- end if;
- end Replace_Element;
-
- ---------------
- -- To_Holder --
- ---------------
-
- function To_Holder (New_Item : Element_Type) return Holder is
- -- The element allocator may need an accessibility check in the case the
- -- actual type is class-wide or has access discriminants (RM 4.8(10.1)
- -- and AI12-0035).
-
- pragma Unsuppress (Accessibility_Check);
-
- begin
- return
- (Controlled with
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(New_Item)), 0);
- end To_Holder;
-
- -----------------
- -- Unreference --
- -----------------
-
- procedure Unreference (Item : not null Shared_Holder_Access) is
-
- procedure Free is
- new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access);
-
- Aux : Shared_Holder_Access := Item;
-
- begin
- if System.Atomic_Counters.Decrement (Aux.Counter) then
- Free (Aux.Element);
- Free (Aux);
- end if;
- end Unreference;
-
- --------------------
- -- Update_Element --
- --------------------
-
- procedure Update_Element
- (Container : in out Holder;
- Process : not null access procedure (Element : in out Element_Type))
- is
- B : Natural renames Container.Busy;
-
- begin
- if Container.Reference = null then
- raise Constraint_Error with "container is empty";
- end if;
-
- Detach (Container);
-
- B := B + 1;
-
- begin
- Process (Container.Reference.Element.all);
- exception
- when others =>
- B := B - 1;
- raise;
- end;
-
- B := B - 1;
- end Update_Element;
-
- -----------
- -- Write --
- -----------
-
- procedure Write
- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- Container : Holder)
- is
- begin
- Boolean'Output (Stream, Container.Reference = null);
-
- if Container.Reference /= null then
- Element_Type'Output (Stream, Container.Reference.Element.all);
- end if;
- end Write;
-
- procedure Write
- (Stream : not null access Root_Stream_Type'Class;
- Item : Reference_Type)
- is
- begin
- raise Program_Error with "attempt to stream reference";
- end Write;
-
- procedure Write
- (Stream : not null access Root_Stream_Type'Class;
- Item : Constant_Reference_Type)
- is
- begin
- raise Program_Error with "attempt to stream reference";
- end Write;
-
-end Ada.Containers.Indefinite_Holders;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2013-2017, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- 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/>. --
-------------------------------------------------------------------------------
-
--- This is an optimized version of Indefinite_Holders using copy-on-write.
--- It is used on platforms that support atomic built-ins.
-
-private with Ada.Finalization;
-private with Ada.Streams;
-
-private with System.Atomic_Counters;
-
-generic
- type Element_Type (<>) is private;
- with function "=" (Left, Right : Element_Type) return Boolean is <>;
-
-package Ada.Containers.Indefinite_Holders is
- pragma Annotate (CodePeer, Skip_Analysis);
- pragma Preelaborate (Indefinite_Holders);
- pragma Remote_Types (Indefinite_Holders);
-
- type Holder is tagged private;
- pragma Preelaborable_Initialization (Holder);
-
- Empty_Holder : constant Holder;
-
- function "=" (Left, Right : Holder) return Boolean;
-
- function To_Holder (New_Item : Element_Type) return Holder;
-
- function Is_Empty (Container : Holder) return Boolean;
-
- procedure Clear (Container : in out Holder);
-
- function Element (Container : Holder) return Element_Type;
-
- procedure Replace_Element
- (Container : in out Holder;
- New_Item : Element_Type);
-
- procedure Query_Element
- (Container : Holder;
- Process : not null access procedure (Element : Element_Type));
- procedure Update_Element
- (Container : in out Holder;
- Process : not null access procedure (Element : in out Element_Type));
-
- type Constant_Reference_Type
- (Element : not null access constant Element_Type) is private
- with
- Implicit_Dereference => Element;
-
- type Reference_Type
- (Element : not null access Element_Type) is private
- with
- Implicit_Dereference => Element;
-
- function Constant_Reference
- (Container : aliased Holder) return Constant_Reference_Type;
- pragma Inline (Constant_Reference);
-
- function Reference
- (Container : aliased in out Holder) return Reference_Type;
- pragma Inline (Reference);
-
- procedure Assign (Target : in out Holder; Source : Holder);
-
- function Copy (Source : Holder) return Holder;
-
- procedure Move (Target : in out Holder; Source : in out Holder);
-
-private
-
- use Ada.Finalization;
- use Ada.Streams;
-
- type Element_Access is access all Element_Type;
- type Holder_Access is access all Holder;
-
- type Shared_Holder is record
- Counter : System.Atomic_Counters.Atomic_Counter;
- Element : Element_Access;
- end record;
-
- type Shared_Holder_Access is access all Shared_Holder;
-
- procedure Reference (Item : not null Shared_Holder_Access);
- -- Increment reference counter
-
- procedure Unreference (Item : not null Shared_Holder_Access);
- -- Decrement reference counter, deallocate Item when counter goes to zero
-
- procedure Read
- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- Container : out Holder);
-
- procedure Write
- (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
- Container : Holder);
-
- type Holder is new Ada.Finalization.Controlled with record
- Reference : Shared_Holder_Access;
- Busy : Natural := 0;
- end record;
- for Holder'Read use Read;
- for Holder'Write use Write;
-
- overriding procedure Adjust (Container : in out Holder);
- overriding procedure Finalize (Container : in out Holder);
-
- type Reference_Control_Type is new Controlled with record
- Container : Holder_Access;
- end record;
-
- overriding procedure Adjust (Control : in out Reference_Control_Type);
- pragma Inline (Adjust);
-
- overriding procedure Finalize (Control : in out Reference_Control_Type);
- pragma Inline (Finalize);
-
- type Constant_Reference_Type
- (Element : not null access constant Element_Type) is
- record
- Control : Reference_Control_Type :=
- raise Program_Error with "uninitialized reference";
- -- The RM says, "The default initialization of an object of
- -- type Constant_Reference_Type or Reference_Type propagates
- -- Program_Error."
- end record;
-
- procedure Write
- (Stream : not null access Root_Stream_Type'Class;
- Item : Constant_Reference_Type);
-
- for Constant_Reference_Type'Write use Write;
-
- procedure Read
- (Stream : not null access Root_Stream_Type'Class;
- Item : out Constant_Reference_Type);
-
- for Constant_Reference_Type'Read use Read;
-
- type Reference_Type (Element : not null access Element_Type) is record
- Control : Reference_Control_Type :=
- raise Program_Error with "uninitialized reference";
- -- The RM says, "The default initialization of an object of
- -- type Constant_Reference_Type or Reference_Type propagates
- -- Program_Error."
- end record;
-
- procedure Write
- (Stream : not null access Root_Stream_Type'Class;
- Item : Reference_Type);
-
- for Reference_Type'Write use Write;
-
- procedure Read
- (Stream : not null access Root_Stream_Type'Class;
- Item : out Reference_Type);
-
- for Reference_Type'Read use Read;
-
- Empty_Holder : constant Holder := (Controlled with null, 0);
-
-end Ada.Containers.Indefinite_Holders;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2013-2017, 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/>. --
+------------------------------------------------------------------------------
+
+-- Note: special attention must be paid to the case of simultaneous access
+-- to internal shared objects and elements by different tasks. The Reference
+-- counter of internal shared object is the only component protected using
+-- atomic operations; other components and elements can be modified only when
+-- reference counter is equal to one (so there are no other references to this
+-- internal shared object and element).
+
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Containers.Indefinite_Holders is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+
+ procedure Detach (Container : Holder);
+ -- Detach data from shared copy if necessary. This is necessary to prepare
+ -- container to be modified.
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "=" (Left, Right : Holder) return Boolean is
+ begin
+ if Left.Reference = Right.Reference then
+
+ -- Covers both null and not null but the same shared object cases
+
+ return True;
+
+ elsif Left.Reference /= null and Right.Reference /= null then
+ return Left.Reference.Element.all = Right.Reference.Element.all;
+
+ else
+ return False;
+ end if;
+ end "=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ overriding procedure Adjust (Container : in out Holder) is
+ begin
+ if Container.Reference /= null then
+ if Container.Busy = 0 then
+
+ -- Container is not locked, reuse existing internal shared object
+
+ Reference (Container.Reference);
+ else
+ -- Otherwise, create copy of both internal shared object and
+ -- element.
+
+ Container.Reference :=
+ new Shared_Holder'
+ (Counter => <>,
+ Element =>
+ new Element_Type'(Container.Reference.Element.all));
+ end if;
+ end if;
+
+ Container.Busy := 0;
+ end Adjust;
+
+ overriding procedure Adjust (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ Reference (Control.Container.Reference);
+ Control.Container.Busy := Control.Container.Busy + 1;
+ end if;
+ end Adjust;
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (Target : in out Holder; Source : Holder) is
+ begin
+ if Target.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Target.Reference /= Source.Reference then
+ if Target.Reference /= null then
+ Unreference (Target.Reference);
+ end if;
+
+ Target.Reference := Source.Reference;
+
+ if Source.Reference /= null then
+ Reference (Target.Reference);
+ end if;
+ end if;
+ end Assign;
+
+ -----------
+ -- Clear --
+ -----------
+
+ procedure Clear (Container : in out Holder) is
+ begin
+ if Container.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Container.Reference /= null then
+ Unreference (Container.Reference);
+ Container.Reference := null;
+ end if;
+ end Clear;
+
+ ------------------------
+ -- Constant_Reference --
+ ------------------------
+
+ function Constant_Reference
+ (Container : aliased Holder) return Constant_Reference_Type is
+ begin
+ if Container.Reference = null then
+ raise Constraint_Error with "container is empty";
+ end if;
+
+ Detach (Container);
+
+ declare
+ Ref : constant Constant_Reference_Type :=
+ (Element => Container.Reference.Element.all'Access,
+ Control => (Controlled with Container'Unrestricted_Access));
+ begin
+ Reference (Ref.Control.Container.Reference);
+ Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1;
+ return Ref;
+ end;
+ end Constant_Reference;
+
+ ----------
+ -- Copy --
+ ----------
+
+ function Copy (Source : Holder) return Holder is
+ begin
+ if Source.Reference = null then
+ return (Controlled with null, 0);
+
+ elsif Source.Busy = 0 then
+
+ -- Container is not locked, reuse internal shared object
+
+ Reference (Source.Reference);
+
+ return (Controlled with Source.Reference, 0);
+
+ else
+ -- Otherwise, create copy of both internal shared object and element
+
+ return
+ (Controlled with
+ new Shared_Holder'
+ (Counter => <>,
+ Element => new Element_Type'(Source.Reference.Element.all)),
+ 0);
+ end if;
+ end Copy;
+
+ ------------
+ -- Detach --
+ ------------
+
+ procedure Detach (Container : Holder) is
+ begin
+ if Container.Busy = 0
+ and then not System.Atomic_Counters.Is_One
+ (Container.Reference.Counter)
+ then
+ -- Container is not locked and internal shared object is used by
+ -- other container, create copy of both internal shared object and
+ -- element.
+
+ declare
+ Old : constant Shared_Holder_Access := Container.Reference;
+
+ begin
+ Container'Unrestricted_Access.Reference :=
+ new Shared_Holder'
+ (Counter => <>,
+ Element =>
+ new Element_Type'(Container.Reference.Element.all));
+ Unreference (Old);
+ end;
+ end if;
+ end Detach;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element (Container : Holder) return Element_Type is
+ begin
+ if Container.Reference = null then
+ raise Constraint_Error with "container is empty";
+ else
+ return Container.Reference.Element.all;
+ end if;
+ end Element;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ overriding procedure Finalize (Container : in out Holder) is
+ begin
+ if Container.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Container.Reference /= null then
+ Unreference (Container.Reference);
+ Container.Reference := null;
+ end if;
+ end Finalize;
+
+ overriding procedure Finalize (Control : in out Reference_Control_Type) is
+ begin
+ if Control.Container /= null then
+ Unreference (Control.Container.Reference);
+ Control.Container.Busy := Control.Container.Busy - 1;
+ Control.Container := null;
+ end if;
+ end Finalize;
+
+ --------------
+ -- Is_Empty --
+ --------------
+
+ function Is_Empty (Container : Holder) return Boolean is
+ begin
+ return Container.Reference = null;
+ end Is_Empty;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (Target : in out Holder; Source : in out Holder) is
+ begin
+ if Target.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Source.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Target.Reference /= Source.Reference then
+ if Target.Reference /= null then
+ Unreference (Target.Reference);
+ end if;
+
+ Target.Reference := Source.Reference;
+ Source.Reference := null;
+ end if;
+ end Move;
+
+ -------------------
+ -- Query_Element --
+ -------------------
+
+ procedure Query_Element
+ (Container : Holder;
+ Process : not null access procedure (Element : Element_Type))
+ is
+ B : Natural renames Container'Unrestricted_Access.Busy;
+
+ begin
+ if Container.Reference = null then
+ raise Constraint_Error with "container is empty";
+ end if;
+
+ Detach (Container);
+
+ B := B + 1;
+
+ begin
+ Process (Container.Reference.Element.all);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Query_Element;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
+ Container : out Holder)
+ is
+ begin
+ Clear (Container);
+
+ if not Boolean'Input (Stream) then
+ Container.Reference :=
+ new Shared_Holder'
+ (Counter => <>,
+ Element => new Element_Type'(Element_Type'Input (Stream)));
+ end if;
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Read;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ procedure Reference (Item : not null Shared_Holder_Access) is
+ begin
+ System.Atomic_Counters.Increment (Item.Counter);
+ end Reference;
+
+ function Reference
+ (Container : aliased in out Holder) return Reference_Type
+ is
+ begin
+ if Container.Reference = null then
+ raise Constraint_Error with "container is empty";
+ end if;
+
+ Detach (Container);
+
+ declare
+ Ref : constant Reference_Type :=
+ (Element => Container.Reference.Element.all'Access,
+ Control => (Controlled with Container'Unrestricted_Access));
+ begin
+ Reference (Ref.Control.Container.Reference);
+ Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1;
+ return Ref;
+ end;
+ end Reference;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Container : in out Holder;
+ New_Item : Element_Type)
+ is
+ -- Element allocator may need an accessibility check in case actual type
+ -- is class-wide or has access discriminants (RM 4.8(10.1) and
+ -- AI12-0035).
+
+ pragma Unsuppress (Accessibility_Check);
+
+ begin
+ if Container.Busy /= 0 then
+ raise Program_Error with "attempt to tamper with elements";
+ end if;
+
+ if Container.Reference = null then
+ -- Holder is empty, allocate new Shared_Holder.
+
+ Container.Reference :=
+ new Shared_Holder'
+ (Counter => <>,
+ Element => new Element_Type'(New_Item));
+
+ elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then
+ -- Shared_Holder can be reused.
+
+ Free (Container.Reference.Element);
+ Container.Reference.Element := new Element_Type'(New_Item);
+
+ else
+ Unreference (Container.Reference);
+ Container.Reference :=
+ new Shared_Holder'
+ (Counter => <>,
+ Element => new Element_Type'(New_Item));
+ end if;
+ end Replace_Element;
+
+ ---------------
+ -- To_Holder --
+ ---------------
+
+ function To_Holder (New_Item : Element_Type) return Holder is
+ -- The element allocator may need an accessibility check in the case the
+ -- actual type is class-wide or has access discriminants (RM 4.8(10.1)
+ -- and AI12-0035).
+
+ pragma Unsuppress (Accessibility_Check);
+
+ begin
+ return
+ (Controlled with
+ new Shared_Holder'
+ (Counter => <>,
+ Element => new Element_Type'(New_Item)), 0);
+ end To_Holder;
+
+ -----------------
+ -- Unreference --
+ -----------------
+
+ procedure Unreference (Item : not null Shared_Holder_Access) is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access);
+
+ Aux : Shared_Holder_Access := Item;
+
+ begin
+ if System.Atomic_Counters.Decrement (Aux.Counter) then
+ Free (Aux.Element);
+ Free (Aux);
+ end if;
+ end Unreference;
+
+ --------------------
+ -- Update_Element --
+ --------------------
+
+ procedure Update_Element
+ (Container : in out Holder;
+ Process : not null access procedure (Element : in out Element_Type))
+ is
+ B : Natural renames Container.Busy;
+
+ begin
+ if Container.Reference = null then
+ raise Constraint_Error with "container is empty";
+ end if;
+
+ Detach (Container);
+
+ B := B + 1;
+
+ begin
+ Process (Container.Reference.Element.all);
+ exception
+ when others =>
+ B := B - 1;
+ raise;
+ end;
+
+ B := B - 1;
+ end Update_Element;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
+ Container : Holder)
+ is
+ begin
+ Boolean'Output (Stream, Container.Reference = null);
+
+ if Container.Reference /= null then
+ Element_Type'Output (Stream, Container.Reference.Element.all);
+ end if;
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type)
+ is
+ begin
+ raise Program_Error with "attempt to stream reference";
+ end Write;
+
+end Ada.Containers.Indefinite_Holders;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2013-2017, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- 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/>. --
+------------------------------------------------------------------------------
+
+-- This is an optimized version of Indefinite_Holders using copy-on-write.
+-- It is used on platforms that support atomic built-ins.
+
+private with Ada.Finalization;
+private with Ada.Streams;
+
+private with System.Atomic_Counters;
+
+generic
+ type Element_Type (<>) is private;
+ with function "=" (Left, Right : Element_Type) return Boolean is <>;
+
+package Ada.Containers.Indefinite_Holders is
+ pragma Annotate (CodePeer, Skip_Analysis);
+ pragma Preelaborate (Indefinite_Holders);
+ pragma Remote_Types (Indefinite_Holders);
+
+ type Holder is tagged private;
+ pragma Preelaborable_Initialization (Holder);
+
+ Empty_Holder : constant Holder;
+
+ function "=" (Left, Right : Holder) return Boolean;
+
+ function To_Holder (New_Item : Element_Type) return Holder;
+
+ function Is_Empty (Container : Holder) return Boolean;
+
+ procedure Clear (Container : in out Holder);
+
+ function Element (Container : Holder) return Element_Type;
+
+ procedure Replace_Element
+ (Container : in out Holder;
+ New_Item : Element_Type);
+
+ procedure Query_Element
+ (Container : Holder;
+ Process : not null access procedure (Element : Element_Type));
+ procedure Update_Element
+ (Container : in out Holder;
+ Process : not null access procedure (Element : in out Element_Type));
+
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ type Reference_Type
+ (Element : not null access Element_Type) is private
+ with
+ Implicit_Dereference => Element;
+
+ function Constant_Reference
+ (Container : aliased Holder) return Constant_Reference_Type;
+ pragma Inline (Constant_Reference);
+
+ function Reference
+ (Container : aliased in out Holder) return Reference_Type;
+ pragma Inline (Reference);
+
+ procedure Assign (Target : in out Holder; Source : Holder);
+
+ function Copy (Source : Holder) return Holder;
+
+ procedure Move (Target : in out Holder; Source : in out Holder);
+
+private
+
+ use Ada.Finalization;
+ use Ada.Streams;
+
+ type Element_Access is access all Element_Type;
+ type Holder_Access is access all Holder;
+
+ type Shared_Holder is record
+ Counter : System.Atomic_Counters.Atomic_Counter;
+ Element : Element_Access;
+ end record;
+
+ type Shared_Holder_Access is access all Shared_Holder;
+
+ procedure Reference (Item : not null Shared_Holder_Access);
+ -- Increment reference counter
+
+ procedure Unreference (Item : not null Shared_Holder_Access);
+ -- Decrement reference counter, deallocate Item when counter goes to zero
+
+ procedure Read
+ (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
+ Container : out Holder);
+
+ procedure Write
+ (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
+ Container : Holder);
+
+ type Holder is new Ada.Finalization.Controlled with record
+ Reference : Shared_Holder_Access;
+ Busy : Natural := 0;
+ end record;
+ for Holder'Read use Read;
+ for Holder'Write use Write;
+
+ overriding procedure Adjust (Container : in out Holder);
+ overriding procedure Finalize (Container : in out Holder);
+
+ type Reference_Control_Type is new Controlled with record
+ Container : Holder_Access;
+ end record;
+
+ overriding procedure Adjust (Control : in out Reference_Control_Type);
+ pragma Inline (Adjust);
+
+ overriding procedure Finalize (Control : in out Reference_Control_Type);
+ pragma Inline (Finalize);
+
+ type Constant_Reference_Type
+ (Element : not null access constant Element_Type) is
+ record
+ Control : Reference_Control_Type :=
+ raise Program_Error with "uninitialized reference";
+ -- The RM says, "The default initialization of an object of
+ -- type Constant_Reference_Type or Reference_Type propagates
+ -- Program_Error."
+ end record;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Constant_Reference_Type);
+
+ for Constant_Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Constant_Reference_Type);
+
+ for Constant_Reference_Type'Read use Read;
+
+ type Reference_Type (Element : not null access Element_Type) is record
+ Control : Reference_Control_Type :=
+ raise Program_Error with "uninitialized reference";
+ -- The RM says, "The default initialization of an object of
+ -- type Constant_Reference_Type or Reference_Type propagates
+ -- Program_Error."
+ end record;
+
+ procedure Write
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : Reference_Type);
+
+ for Reference_Type'Write use Write;
+
+ procedure Read
+ (Stream : not null access Root_Stream_Type'Class;
+ Item : out Reference_Type);
+
+ for Reference_Type'Read use Read;
+
+ Empty_Holder : constant Holder := (Controlled with null, 0);
+
+end Ada.Containers.Indefinite_Holders;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . D I R E C T O R I E S . V A L I D I T Y --
--- --
--- B o d y --
--- (Windows Version) --
--- --
--- Copyright (C) 2004-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Windows version of this package
-
-with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
-
-package body Ada.Directories.Validity is
-
- Invalid_Character : constant array (Character) of Boolean :=
- (NUL .. US | '\' => True,
- '/' | ':' | '*' | '?' => True,
- '"' | '<' | '>' | '|' => True,
- DEL => True,
- others => False);
- -- Note that a valid file-name or path-name is implementation defined.
- -- To support UTF-8 file and directory names, we do not want to be too
- -- restrictive here.
-
- ---------------------------------
- -- Is_Path_Name_Case_Sensitive --
- ---------------------------------
-
- function Is_Path_Name_Case_Sensitive return Boolean is
- begin
- return False;
- end Is_Path_Name_Case_Sensitive;
-
- ------------------------
- -- Is_Valid_Path_Name --
- ------------------------
-
- function Is_Valid_Path_Name (Name : String) return Boolean is
- Start : Positive := Name'First;
- Last : Natural;
-
- begin
- -- A path name cannot be empty, cannot contain more than 256 characters,
- -- cannot contain invalid characters and each directory/file name need
- -- to be valid.
-
- if Name'Length = 0 or else Name'Length > 256 then
- return False;
-
- else
- -- A drive letter may be specified at the beginning
-
- if Name'Length >= 2
- and then Name (Start + 1) = ':'
- and then
- (Name (Start) in 'A' .. 'Z' or else Name (Start) in 'a' .. 'z')
- then
- Start := Start + 2;
-
- -- A drive letter followed by a colon and followed by nothing or
- -- by a relative path is an ambiguous path name on Windows, so we
- -- don't accept it.
-
- if Start > Name'Last
- or else (Name (Start) /= '/' and then Name (Start) /= '\')
- then
- return False;
- end if;
- end if;
-
- loop
- -- Look for the start of the next directory or file name
-
- while Start <= Name'Last
- and then (Name (Start) = '\' or Name (Start) = '/')
- loop
- Start := Start + 1;
- end loop;
-
- -- If all directories/file names are OK, return True
-
- exit when Start > Name'Last;
-
- Last := Start;
-
- -- Look for the end of the directory/file name
-
- while Last < Name'Last loop
- exit when Name (Last + 1) = '\' or Name (Last + 1) = '/';
- Last := Last + 1;
- end loop;
-
- -- Check if the directory/file name is valid
-
- if not Is_Valid_Simple_Name (Name (Start .. Last)) then
- return False;
- end if;
-
- -- Move to the next name
-
- Start := Last + 1;
- end loop;
- end if;
-
- -- If Name follows the rules, it is valid
-
- return True;
- end Is_Valid_Path_Name;
-
- --------------------------
- -- Is_Valid_Simple_Name --
- --------------------------
-
- function Is_Valid_Simple_Name (Name : String) return Boolean is
- Only_Spaces : Boolean;
-
- begin
- -- A file name cannot be empty, cannot contain more than 256 characters,
- -- and cannot contain invalid characters.
-
- if Name'Length = 0 or else Name'Length > 256 then
- return False;
-
- -- Name length is OK
-
- else
- Only_Spaces := True;
- for J in Name'Range loop
- if Invalid_Character (Name (J)) then
- return False;
- elsif Name (J) /= ' ' then
- Only_Spaces := False;
- end if;
- end loop;
-
- -- If no invalid chars, and not all spaces, file name is valid
-
- return not Only_Spaces;
- end if;
- end Is_Valid_Simple_Name;
-
- -------------
- -- Windows --
- -------------
-
- function Windows return Boolean is
- begin
- return True;
- end Windows;
-
-end Ada.Directories.Validity;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . D I R E C T O R I E S . V A L I D I T Y --
+-- --
+-- B o d y --
+-- (Windows Version) --
+-- --
+-- Copyright (C) 2004-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows version of this package
+
+with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
+
+package body Ada.Directories.Validity is
+
+ Invalid_Character : constant array (Character) of Boolean :=
+ (NUL .. US | '\' => True,
+ '/' | ':' | '*' | '?' => True,
+ '"' | '<' | '>' | '|' => True,
+ DEL => True,
+ others => False);
+ -- Note that a valid file-name or path-name is implementation defined.
+ -- To support UTF-8 file and directory names, we do not want to be too
+ -- restrictive here.
+
+ ---------------------------------
+ -- Is_Path_Name_Case_Sensitive --
+ ---------------------------------
+
+ function Is_Path_Name_Case_Sensitive return Boolean is
+ begin
+ return False;
+ end Is_Path_Name_Case_Sensitive;
+
+ ------------------------
+ -- Is_Valid_Path_Name --
+ ------------------------
+
+ function Is_Valid_Path_Name (Name : String) return Boolean is
+ Start : Positive := Name'First;
+ Last : Natural;
+
+ begin
+ -- A path name cannot be empty, cannot contain more than 256 characters,
+ -- cannot contain invalid characters and each directory/file name need
+ -- to be valid.
+
+ if Name'Length = 0 or else Name'Length > 256 then
+ return False;
+
+ else
+ -- A drive letter may be specified at the beginning
+
+ if Name'Length >= 2
+ and then Name (Start + 1) = ':'
+ and then
+ (Name (Start) in 'A' .. 'Z' or else Name (Start) in 'a' .. 'z')
+ then
+ Start := Start + 2;
+
+ -- A drive letter followed by a colon and followed by nothing or
+ -- by a relative path is an ambiguous path name on Windows, so we
+ -- don't accept it.
+
+ if Start > Name'Last
+ or else (Name (Start) /= '/' and then Name (Start) /= '\')
+ then
+ return False;
+ end if;
+ end if;
+
+ loop
+ -- Look for the start of the next directory or file name
+
+ while Start <= Name'Last
+ and then (Name (Start) = '\' or Name (Start) = '/')
+ loop
+ Start := Start + 1;
+ end loop;
+
+ -- If all directories/file names are OK, return True
+
+ exit when Start > Name'Last;
+
+ Last := Start;
+
+ -- Look for the end of the directory/file name
+
+ while Last < Name'Last loop
+ exit when Name (Last + 1) = '\' or Name (Last + 1) = '/';
+ Last := Last + 1;
+ end loop;
+
+ -- Check if the directory/file name is valid
+
+ if not Is_Valid_Simple_Name (Name (Start .. Last)) then
+ return False;
+ end if;
+
+ -- Move to the next name
+
+ Start := Last + 1;
+ end loop;
+ end if;
+
+ -- If Name follows the rules, it is valid
+
+ return True;
+ end Is_Valid_Path_Name;
+
+ --------------------------
+ -- Is_Valid_Simple_Name --
+ --------------------------
+
+ function Is_Valid_Simple_Name (Name : String) return Boolean is
+ Only_Spaces : Boolean;
+
+ begin
+ -- A file name cannot be empty, cannot contain more than 256 characters,
+ -- and cannot contain invalid characters.
+
+ if Name'Length = 0 or else Name'Length > 256 then
+ return False;
+
+ -- Name length is OK
+
+ else
+ Only_Spaces := True;
+ for J in Name'Range loop
+ if Invalid_Character (Name (J)) then
+ return False;
+ elsif Name (J) /= ' ' then
+ Only_Spaces := False;
+ end if;
+ end loop;
+
+ -- If no invalid chars, and not all spaces, file name is valid
+
+ return not Only_Spaces;
+ end if;
+ end Is_Valid_Simple_Name;
+
+ -------------
+ -- Windows --
+ -------------
+
+ function Windows return Boolean is
+ begin
+ return True;
+ end Windows;
+
+end Ada.Directories.Validity;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R --
--- --
--- B o d y --
--- --
--- Copyright (C) 2003-2017, 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 Warnings (Off);
-with System.Standard_Library;
-pragma Warnings (On);
-
-with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
-with GNAT.IO; use GNAT.IO;
-
--- Default last chance handler for use with the full VxWorks 653 partition OS
--- Ada run-time library.
-
--- Logs error with health monitor, and dumps exception identity and argument
--- string for vxaddr2line for generation of a symbolic stack backtrace.
-
-procedure Ada.Exceptions.Last_Chance_Handler (Except : Exception_Occurrence) is
-
- ----------------------
- -- APEX definitions --
- ----------------------
-
- pragma Warnings (Off);
- type Error_Code_Type is (
- Deadline_Missed,
- Application_Error,
- Numeric_Error,
- Illegal_Request,
- Stack_Overflow,
- Memory_Violation,
- Hardware_Fault,
- Power_Fail);
- pragma Warnings (On);
- pragma Convention (C, Error_Code_Type);
- -- APEX Health Management error codes
-
- type Message_Addr_Type is new System.Address;
-
- type Apex_Integer is range -(2 ** 31) .. (2 ** 31) - 1;
- pragma Convention (C, Apex_Integer);
-
- Max_Error_Message_Size : constant := 64;
-
- type Error_Message_Size_Type is new Apex_Integer range
- 1 .. Max_Error_Message_Size;
-
- pragma Warnings (Off);
- type Return_Code_Type is (
- No_Error, -- request valid and operation performed
- No_Action, -- status of system unaffected by request
- Not_Available, -- resource required by request unavailable
- Invalid_Param, -- invalid parameter specified in request
- Invalid_Config, -- parameter incompatible with configuration
- Invalid_Mode, -- request incompatible with current mode
- Timed_Out); -- time-out tied up with request has expired
- pragma Warnings (On);
- pragma Convention (C, Return_Code_Type);
- -- APEX return codes
-
- procedure Raise_Application_Error
- (Error_Code : Error_Code_Type;
- Message_Addr : Message_Addr_Type;
- Length : Error_Message_Size_Type;
- Return_Code : out Return_Code_Type);
- pragma Import (C, Raise_Application_Error, "RAISE_APPLICATION_ERROR");
-
- procedure Unhandled_Terminate;
- pragma No_Return (Unhandled_Terminate);
- pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
- -- Perform system dependent shutdown code
-
- procedure Adainit;
- pragma Import (Ada, Adainit, "adainit");
-
- Adainit_Addr : constant System.Address := Adainit'Code_Address;
- -- Part of arguments to vxaddr2line
-
- Result : Return_Code_Type;
-
- Message : String :=
- Exception_Name (Except) & ": " & ASCII.LF &
- Exception_Message (Except) & ASCII.NUL;
-
- Message_Length : Error_Message_Size_Type;
-
-begin
- New_Line;
- Put_Line ("In last chance handler");
- Put_Line (Message (1 .. Message'Length - 1));
- New_Line;
-
- Put_Line ("adainit and traceback addresses for vxaddr2line:");
-
- Put (Image_C (Adainit_Addr)); Put (" ");
-
- for J in 1 .. Except.Num_Tracebacks loop
- Put (Image_C (Except.Tracebacks (J)));
- Put (" ");
- end loop;
-
- New_Line;
-
- if Message'Length > Error_Message_Size_Type'Last then
- Message_Length := Error_Message_Size_Type'Last;
- else
- Message_Length := Message'Length;
- end if;
-
- Raise_Application_Error
- (Error_Code => Application_Error,
- Message_Addr => Message_Addr_Type (Message (1)'Address),
- Length => Message_Length,
- Return_Code => Result);
-
- -- Shutdown the run-time library now. The rest of the procedure needs to be
- -- careful not to use anything that would require runtime support. In
- -- particular, functions returning strings are banned since the sec stack
- -- is no longer functional.
-
- System.Standard_Library.Adafinal;
- Unhandled_Terminate;
-end Ada.Exceptions.Last_Chance_Handler;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003-2017, 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 Warnings (Off);
+with System.Standard_Library;
+pragma Warnings (On);
+
+with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
+with GNAT.IO; use GNAT.IO;
+
+-- Default last chance handler for use with the full VxWorks 653 partition OS
+-- Ada run-time library.
+
+-- Logs error with health monitor, and dumps exception identity and argument
+-- string for vxaddr2line for generation of a symbolic stack backtrace.
+
+procedure Ada.Exceptions.Last_Chance_Handler (Except : Exception_Occurrence) is
+
+ ----------------------
+ -- APEX definitions --
+ ----------------------
+
+ pragma Warnings (Off);
+ type Error_Code_Type is (
+ Deadline_Missed,
+ Application_Error,
+ Numeric_Error,
+ Illegal_Request,
+ Stack_Overflow,
+ Memory_Violation,
+ Hardware_Fault,
+ Power_Fail);
+ pragma Warnings (On);
+ pragma Convention (C, Error_Code_Type);
+ -- APEX Health Management error codes
+
+ type Message_Addr_Type is new System.Address;
+
+ type Apex_Integer is range -(2 ** 31) .. (2 ** 31) - 1;
+ pragma Convention (C, Apex_Integer);
+
+ Max_Error_Message_Size : constant := 64;
+
+ type Error_Message_Size_Type is new Apex_Integer range
+ 1 .. Max_Error_Message_Size;
+
+ pragma Warnings (Off);
+ type Return_Code_Type is (
+ No_Error, -- request valid and operation performed
+ No_Action, -- status of system unaffected by request
+ Not_Available, -- resource required by request unavailable
+ Invalid_Param, -- invalid parameter specified in request
+ Invalid_Config, -- parameter incompatible with configuration
+ Invalid_Mode, -- request incompatible with current mode
+ Timed_Out); -- time-out tied up with request has expired
+ pragma Warnings (On);
+ pragma Convention (C, Return_Code_Type);
+ -- APEX return codes
+
+ procedure Raise_Application_Error
+ (Error_Code : Error_Code_Type;
+ Message_Addr : Message_Addr_Type;
+ Length : Error_Message_Size_Type;
+ Return_Code : out Return_Code_Type);
+ pragma Import (C, Raise_Application_Error, "RAISE_APPLICATION_ERROR");
+
+ procedure Unhandled_Terminate;
+ pragma No_Return (Unhandled_Terminate);
+ pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
+ -- Perform system dependent shutdown code
+
+ procedure Adainit;
+ pragma Import (Ada, Adainit, "adainit");
+
+ Adainit_Addr : constant System.Address := Adainit'Code_Address;
+ -- Part of arguments to vxaddr2line
+
+ Result : Return_Code_Type;
+
+ Message : String :=
+ Exception_Name (Except) & ": " & ASCII.LF &
+ Exception_Message (Except) & ASCII.NUL;
+
+ Message_Length : Error_Message_Size_Type;
+
+begin
+ New_Line;
+ Put_Line ("In last chance handler");
+ Put_Line (Message (1 .. Message'Length - 1));
+ New_Line;
+
+ Put_Line ("adainit and traceback addresses for vxaddr2line:");
+
+ Put (Image_C (Adainit_Addr)); Put (" ");
+
+ for J in 1 .. Except.Num_Tracebacks loop
+ Put (Image_C (Except.Tracebacks (J)));
+ Put (" ");
+ end loop;
+
+ New_Line;
+
+ if Message'Length > Error_Message_Size_Type'Last then
+ Message_Length := Error_Message_Size_Type'Last;
+ else
+ Message_Length := Message'Length;
+ end if;
+
+ Raise_Application_Error
+ (Error_Code => Application_Error,
+ Message_Addr => Message_Addr_Type (Message (1)'Address),
+ Length => Message_Length,
+ Return_Code => Result);
+
+ -- Shutdown the run-time library now. The rest of the procedure needs to be
+ -- careful not to use anything that would require runtime support. In
+ -- particular, functions returning strings are banned since the sec stack
+ -- is no longer functional.
+
+ System.Standard_Library.Adafinal;
+ Unhandled_Terminate;
+end Ada.Exceptions.Last_Chance_Handler;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . E X C E P T I O N S . P O L L --
--- (version supporting asynchronous abort test) --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for targets that do not support per-thread asynchronous
--- signals. On such targets, we require compilation with the -gnatP switch
--- that activates periodic polling. Then in the body of the polling routine
--- we test for asynchronous abort.
-
--- Windows and HPUX 10 currently use this file
-
-pragma Warnings (Off);
--- Allow withing of non-Preelaborated units in Ada 2005 mode where this
--- package will be categorized as Preelaborate. See AI-362 for details.
--- It is safe in the context of the run-time to violate the rules.
-
-with System.Soft_Links;
-
-pragma Warnings (On);
-
-separate (Ada.Exceptions)
-
-----------
--- Poll --
-----------
-
-procedure Poll is
-begin
- -- Test for asynchronous abort on each poll
-
- if System.Soft_Links.Check_Abort_Status.all /= 0 then
- raise Standard'Abort_Signal;
- end if;
-end Poll;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- A D A . E X C E P T I O N S . P O L L --
+-- (version supporting asynchronous abort test) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for targets that do not support per-thread asynchronous
+-- signals. On such targets, we require compilation with the -gnatP switch
+-- that activates periodic polling. Then in the body of the polling routine
+-- we test for asynchronous abort.
+
+-- Windows and HPUX 10 currently use this file
+
+pragma Warnings (Off);
+-- Allow withing of non-Preelaborated units in Ada 2005 mode where this
+-- package will be categorized as Preelaborate. See AI-362 for details.
+-- It is safe in the context of the run-time to violate the rules.
+
+with System.Soft_Links;
+
+pragma Warnings (On);
+
+separate (Ada.Exceptions)
+
+----------
+-- Poll --
+----------
+
+procedure Poll is
+begin
+ -- Test for asynchronous abort on each poll
+
+ if System.Soft_Links.Check_Abort_Status.all /= 0 then
+ raise Standard'Abort_Signal;
+ end if;
+end Poll;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . N U M E R I C S . A U X --
--- --
--- B o d y --
--- (Apple OS X Version) --
--- --
--- Copyright (C) 1998-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-package body Ada.Numerics.Aux is
-
- -----------------------
- -- Local subprograms --
- -----------------------
-
- function Is_Nan (X : Double) return Boolean;
- -- Return True iff X is a IEEE NaN value
-
- procedure Reduce (X : in out Double; Q : out Natural);
- -- Implement reduction of X by Pi/2. Q is the quadrant of the final
- -- result in the range 0..3. The absolute value of X is at most Pi/4.
- -- It is needed to avoid a loss of accuracy for sin near Pi and cos
- -- near Pi/2 due to the use of an insufficiently precise value of Pi
- -- in the range reduction.
-
- -- The following two functions implement Chebishev approximations
- -- of the trigonometric functions in their reduced domain.
- -- These approximations have been computed using Maple.
-
- function Sine_Approx (X : Double) return Double;
- function Cosine_Approx (X : Double) return Double;
-
- pragma Inline (Reduce);
- pragma Inline (Sine_Approx);
- pragma Inline (Cosine_Approx);
-
- -------------------
- -- Cosine_Approx --
- -------------------
-
- function Cosine_Approx (X : Double) return Double is
- XX : constant Double := X * X;
- begin
- return (((((16#8.DC57FBD05F640#E-08 * XX
- - 16#4.9F7D00BF25D80#E-06) * XX
- + 16#1.A019F7FDEFCC2#E-04) * XX
- - 16#5.B05B058F18B20#E-03) * XX
- + 16#A.AAAAAAAA73FA8#E-02) * XX
- - 16#7.FFFFFFFFFFDE4#E-01) * XX
- - 16#3.655E64869ECCE#E-14 + 1.0;
- end Cosine_Approx;
-
- -----------------
- -- Sine_Approx --
- -----------------
-
- function Sine_Approx (X : Double) return Double is
- XX : constant Double := X * X;
- begin
- return (((((16#A.EA2D4ABE41808#E-09 * XX
- - 16#6.B974C10F9D078#E-07) * XX
- + 16#2.E3BC673425B0E#E-05) * XX
- - 16#D.00D00CCA7AF00#E-04) * XX
- + 16#2.222222221B190#E-02) * XX
- - 16#2.AAAAAAAAAAA44#E-01) * (XX * X) + X;
- end Sine_Approx;
-
- ------------
- -- Is_Nan --
- ------------
-
- function Is_Nan (X : Double) return Boolean is
- begin
- -- The IEEE NaN values are the only ones that do not equal themselves
-
- return X /= X;
- end Is_Nan;
-
- ------------
- -- Reduce --
- ------------
-
- procedure Reduce (X : in out Double; Q : out Natural) is
- Half_Pi : constant := Pi / 2.0;
- Two_Over_Pi : constant := 2.0 / Pi;
-
- HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size);
- M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant
- P1 : constant Double := Double'Leading_Part (Half_Pi, HM);
- P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM);
- P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM);
- P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM);
- P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3
- - P4, HM);
- P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5);
- K : Double;
- R : Integer;
-
- begin
- -- For X < 2.0**HM, all products below are computed exactly.
- -- Due to cancellation effects all subtractions are exact as well.
- -- As no double extended floating-point number has more than 75
- -- zeros after the binary point, the result will be the correctly
- -- rounded result of X - K * (Pi / 2.0).
-
- K := X * Two_Over_Pi;
- while abs K >= 2.0**HM loop
- K := K * M - (K * M - K);
- X :=
- (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6;
- K := X * Two_Over_Pi;
- end loop;
-
- -- If K is not a number (because X was not finite) raise exception
-
- if Is_Nan (K) then
- raise Constraint_Error;
- end if;
-
- -- Go through an integer temporary so as to use machine instructions
-
- R := Integer (Double'Rounding (K));
- Q := R mod 4;
- K := Double (R);
- X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6;
- end Reduce;
-
- ---------
- -- Cos --
- ---------
-
- function Cos (X : Double) return Double is
- Reduced_X : Double := abs X;
- Quadrant : Natural range 0 .. 3;
-
- begin
- if Reduced_X > Pi / 4.0 then
- Reduce (Reduced_X, Quadrant);
-
- case Quadrant is
- when 0 =>
- return Cosine_Approx (Reduced_X);
-
- when 1 =>
- return Sine_Approx (-Reduced_X);
-
- when 2 =>
- return -Cosine_Approx (Reduced_X);
-
- when 3 =>
- return Sine_Approx (Reduced_X);
- end case;
- end if;
-
- return Cosine_Approx (Reduced_X);
- end Cos;
-
- ---------
- -- Sin --
- ---------
-
- function Sin (X : Double) return Double is
- Reduced_X : Double := X;
- Quadrant : Natural range 0 .. 3;
-
- begin
- if abs X > Pi / 4.0 then
- Reduce (Reduced_X, Quadrant);
-
- case Quadrant is
- when 0 =>
- return Sine_Approx (Reduced_X);
-
- when 1 =>
- return Cosine_Approx (Reduced_X);
-
- when 2 =>
- return Sine_Approx (-Reduced_X);
-
- when 3 =>
- return -Cosine_Approx (Reduced_X);
- end case;
- end if;
-
- return Sine_Approx (Reduced_X);
- end Sin;
-
-end Ada.Numerics.Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . N U M E R I C S . A U X --
--- --
--- S p e c --
--- (Apple OS X Version) --
--- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for use on OS X. It uses the normal Unix math functions,
--- except for sine/cosine which have been implemented directly in Ada to get
--- the required accuracy.
-
-package Ada.Numerics.Aux is
- pragma Pure;
-
- pragma Linker_Options ("-lm");
-
- type Double is new Long_Float;
- -- Type Double is the type used to call the C routines
-
- -- The following functions have been implemented in Ada, since
- -- the OS X math library didn't meet accuracy requirements for
- -- argument reduction. The implementation here has been tailored
- -- to match Ada strict mode Numerics requirements while maintaining
- -- maximum efficiency.
- function Sin (X : Double) return Double;
- pragma Inline (Sin);
-
- function Cos (X : Double) return Double;
- pragma Inline (Cos);
-
- -- We import these functions directly from C. Note that we label them
- -- all as pure functions, because indeed all of them are in fact pure.
-
- function Tan (X : Double) return Double;
- pragma Import (C, Tan, "tan");
- pragma Pure_Function (Tan);
-
- function Exp (X : Double) return Double;
- pragma Import (C, Exp, "exp");
- pragma Pure_Function (Exp);
-
- function Sqrt (X : Double) return Double;
- pragma Import (C, Sqrt, "sqrt");
- pragma Pure_Function (Sqrt);
-
- function Log (X : Double) return Double;
- pragma Import (C, Log, "log");
- pragma Pure_Function (Log);
-
- function Acos (X : Double) return Double;
- pragma Import (C, Acos, "acos");
- pragma Pure_Function (Acos);
-
- function Asin (X : Double) return Double;
- pragma Import (C, Asin, "asin");
- pragma Pure_Function (Asin);
-
- function Atan (X : Double) return Double;
- pragma Import (C, Atan, "atan");
- pragma Pure_Function (Atan);
-
- function Sinh (X : Double) return Double;
- pragma Import (C, Sinh, "sinh");
- pragma Pure_Function (Sinh);
-
- function Cosh (X : Double) return Double;
- pragma Import (C, Cosh, "cosh");
- pragma Pure_Function (Cosh);
-
- function Tanh (X : Double) return Double;
- pragma Import (C, Tanh, "tanh");
- pragma Pure_Function (Tanh);
-
- function Pow (X, Y : Double) return Double;
- pragma Import (C, Pow, "pow");
- pragma Pure_Function (Pow);
-
-end Ada.Numerics.Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . N U M E R I C S . A U X --
--- --
--- S p e c --
--- (C Library Version for x86) --
--- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for the x86 using the 80-bit x86 long double format
-
-package Ada.Numerics.Aux is
- pragma Pure;
-
- pragma Linker_Options ("-lm");
-
- type Double is new Long_Long_Float;
-
- -- We import these functions directly from C. Note that we label them
- -- all as pure functions, because indeed all of them are in fact pure.
-
- function Sin (X : Double) return Double;
- pragma Import (C, Sin, "sinl");
- pragma Pure_Function (Sin);
-
- function Cos (X : Double) return Double;
- pragma Import (C, Cos, "cosl");
- pragma Pure_Function (Cos);
-
- function Tan (X : Double) return Double;
- pragma Import (C, Tan, "tanl");
- pragma Pure_Function (Tan);
-
- function Exp (X : Double) return Double;
- pragma Import (C, Exp, "expl");
- pragma Pure_Function (Exp);
-
- function Sqrt (X : Double) return Double;
- pragma Import (C, Sqrt, "sqrtl");
- pragma Pure_Function (Sqrt);
-
- function Log (X : Double) return Double;
- pragma Import (C, Log, "logl");
- pragma Pure_Function (Log);
-
- function Acos (X : Double) return Double;
- pragma Import (C, Acos, "acosl");
- pragma Pure_Function (Acos);
-
- function Asin (X : Double) return Double;
- pragma Import (C, Asin, "asinl");
- pragma Pure_Function (Asin);
-
- function Atan (X : Double) return Double;
- pragma Import (C, Atan, "atanl");
- pragma Pure_Function (Atan);
-
- function Sinh (X : Double) return Double;
- pragma Import (C, Sinh, "sinhl");
- pragma Pure_Function (Sinh);
-
- function Cosh (X : Double) return Double;
- pragma Import (C, Cosh, "coshl");
- pragma Pure_Function (Cosh);
-
- function Tanh (X : Double) return Double;
- pragma Import (C, Tanh, "tanhl");
- pragma Pure_Function (Tanh);
-
- function Pow (X, Y : Double) return Double;
- pragma Import (C, Pow, "powl");
- pragma Pure_Function (Pow);
-
-end Ada.Numerics.Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . N U M E R I C S . A U X --
--- --
--- S p e c --
--- (C Library Version, VxWorks) --
--- --
--- Copyright (C) 1992-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
--- Version for use on VxWorks (where we have no libm.a library), so the pragma
--- Linker_Options ("-lm") is omitted in this version.
-
-package Ada.Numerics.Aux is
- pragma Pure;
-
- type Double is new Long_Float;
- -- Type Double is the type used to call the C routines
-
- -- We import these functions directly from C. Note that we label them
- -- all as pure functions, because indeed all of them are in fact pure.
-
- function Sin (X : Double) return Double;
- pragma Import (C, Sin, "sin");
- pragma Pure_Function (Sin);
-
- function Cos (X : Double) return Double;
- pragma Import (C, Cos, "cos");
- pragma Pure_Function (Cos);
-
- function Tan (X : Double) return Double;
- pragma Import (C, Tan, "tan");
- pragma Pure_Function (Tan);
-
- function Exp (X : Double) return Double;
- pragma Import (C, Exp, "exp");
- pragma Pure_Function (Exp);
-
- function Sqrt (X : Double) return Double;
- pragma Import (C, Sqrt, "sqrt");
- pragma Pure_Function (Sqrt);
-
- function Log (X : Double) return Double;
- pragma Import (C, Log, "log");
- pragma Pure_Function (Log);
-
- function Acos (X : Double) return Double;
- pragma Import (C, Acos, "acos");
- pragma Pure_Function (Acos);
-
- function Asin (X : Double) return Double;
- pragma Import (C, Asin, "asin");
- pragma Pure_Function (Asin);
-
- function Atan (X : Double) return Double;
- pragma Import (C, Atan, "atan");
- pragma Pure_Function (Atan);
-
- function Sinh (X : Double) return Double;
- pragma Import (C, Sinh, "sinh");
- pragma Pure_Function (Sinh);
-
- function Cosh (X : Double) return Double;
- pragma Import (C, Cosh, "cosh");
- pragma Pure_Function (Cosh);
-
- function Tanh (X : Double) return Double;
- pragma Import (C, Tanh, "tanh");
- pragma Pure_Function (Tanh);
-
- function Pow (X, Y : Double) return Double;
- pragma Import (C, Pow, "pow");
- pragma Pure_Function (Pow);
-
-end Ada.Numerics.Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . N U M E R I C S . A U X --
--- --
--- B o d y --
--- (Machine Version for x86) --
--- --
--- Copyright (C) 1998-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-with System.Machine_Code; use System.Machine_Code;
-
-package body Ada.Numerics.Aux is
-
- NL : constant String := ASCII.LF & ASCII.HT;
-
- -----------------------
- -- Local subprograms --
- -----------------------
-
- function Is_Nan (X : Double) return Boolean;
- -- Return True iff X is a IEEE NaN value
-
- function Logarithmic_Pow (X, Y : Double) return Double;
- -- Implementation of X**Y using Exp and Log functions (binary base)
- -- to calculate the exponentiation. This is used by Pow for values
- -- for values of Y in the open interval (-0.25, 0.25)
-
- procedure Reduce (X : in out Double; Q : out Natural);
- -- Implement reduction of X by Pi/2. Q is the quadrant of the final
- -- result in the range 0..3. The absolute value of X is at most Pi/4.
- -- It is needed to avoid a loss of accuracy for sin near Pi and cos
- -- near Pi/2 due to the use of an insufficiently precise value of Pi
- -- in the range reduction.
-
- pragma Inline (Is_Nan);
- pragma Inline (Reduce);
-
- --------------------------------
- -- Basic Elementary Functions --
- --------------------------------
-
- -- This section implements a few elementary functions that are used to
- -- build the more complex ones. This ordering enables better inlining.
-
- ----------
- -- Atan --
- ----------
-
- function Atan (X : Double) return Double is
- Result : Double;
-
- begin
- Asm (Template =>
- "fld1" & NL
- & "fpatan",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", X));
-
- -- The result value is NaN iff input was invalid
-
- if not (Result = Result) then
- raise Argument_Error;
- end if;
-
- return Result;
- end Atan;
-
- ---------
- -- Exp --
- ---------
-
- function Exp (X : Double) return Double is
- Result : Double;
- begin
- Asm (Template =>
- "fldl2e " & NL
- & "fmulp %%st, %%st(1)" & NL -- X * log2 (E)
- & "fld %%st(0) " & NL
- & "frndint " & NL -- Integer (X * Log2 (E))
- & "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E))
- & "fxch " & NL
- & "f2xm1 " & NL -- 2**(...) - 1
- & "fld1 " & NL
- & "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E)))
- & "fscale " & NL -- E ** X
- & "fstp %%st(1) ",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", X));
- return Result;
- end Exp;
-
- ------------
- -- Is_Nan --
- ------------
-
- function Is_Nan (X : Double) return Boolean is
- begin
- -- The IEEE NaN values are the only ones that do not equal themselves
-
- return X /= X;
- end Is_Nan;
-
- ---------
- -- Log --
- ---------
-
- function Log (X : Double) return Double is
- Result : Double;
-
- begin
- Asm (Template =>
- "fldln2 " & NL
- & "fxch " & NL
- & "fyl2x " & NL,
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", X));
- return Result;
- end Log;
-
- ------------
- -- Reduce --
- ------------
-
- procedure Reduce (X : in out Double; Q : out Natural) is
- Half_Pi : constant := Pi / 2.0;
- Two_Over_Pi : constant := 2.0 / Pi;
-
- HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size);
- M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant
- P1 : constant Double := Double'Leading_Part (Half_Pi, HM);
- P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM);
- P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM);
- P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM);
- P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3
- - P4, HM);
- P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5);
- K : Double;
- R : Integer;
-
- begin
- -- For X < 2.0**HM, all products below are computed exactly.
- -- Due to cancellation effects all subtractions are exact as well.
- -- As no double extended floating-point number has more than 75
- -- zeros after the binary point, the result will be the correctly
- -- rounded result of X - K * (Pi / 2.0).
-
- K := X * Two_Over_Pi;
- while abs K >= 2.0**HM loop
- K := K * M - (K * M - K);
- X :=
- (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6;
- K := X * Two_Over_Pi;
- end loop;
-
- -- If K is not a number (because X was not finite) raise exception
-
- if Is_Nan (K) then
- raise Constraint_Error;
- end if;
-
- -- Go through an integer temporary so as to use machine instructions
-
- R := Integer (Double'Rounding (K));
- Q := R mod 4;
- K := Double (R);
- X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6;
- end Reduce;
-
- ----------
- -- Sqrt --
- ----------
-
- function Sqrt (X : Double) return Double is
- Result : Double;
-
- begin
- if X < 0.0 then
- raise Argument_Error;
- end if;
-
- Asm (Template => "fsqrt",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", X));
-
- return Result;
- end Sqrt;
-
- --------------------------------
- -- Other Elementary Functions --
- --------------------------------
-
- -- These are built using the previously implemented basic functions
-
- ----------
- -- Acos --
- ----------
-
- function Acos (X : Double) return Double is
- Result : Double;
-
- begin
- Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X)));
-
- -- The result value is NaN iff input was invalid
-
- if Is_Nan (Result) then
- raise Argument_Error;
- end if;
-
- return Result;
- end Acos;
-
- ----------
- -- Asin --
- ----------
-
- function Asin (X : Double) return Double is
- Result : Double;
-
- begin
- Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X)));
-
- -- The result value is NaN iff input was invalid
-
- if Is_Nan (Result) then
- raise Argument_Error;
- end if;
-
- return Result;
- end Asin;
-
- ---------
- -- Cos --
- ---------
-
- function Cos (X : Double) return Double is
- Reduced_X : Double := abs X;
- Result : Double;
- Quadrant : Natural range 0 .. 3;
-
- begin
- if Reduced_X > Pi / 4.0 then
- Reduce (Reduced_X, Quadrant);
-
- case Quadrant is
- when 0 =>
- Asm (Template => "fcos",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
-
- when 1 =>
- Asm (Template => "fsin",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", -Reduced_X));
-
- when 2 =>
- Asm (Template => "fcos ; fchs",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
-
- when 3 =>
- Asm (Template => "fsin",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end case;
-
- else
- Asm (Template => "fcos",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end if;
-
- return Result;
- end Cos;
-
- ---------------------
- -- Logarithmic_Pow --
- ---------------------
-
- function Logarithmic_Pow (X, Y : Double) return Double is
- Result : Double;
- begin
- Asm (Template => "" -- X : Y
- & "fyl2x " & NL -- Y * Log2 (X)
- & "fld %%st(0) " & NL -- Y * Log2 (X) : Y * Log2 (X)
- & "frndint " & NL -- Int (...) : Y * Log2 (X)
- & "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...)
- & "fxch " & NL -- Fract (...) : Int (...)
- & "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...)
- & "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...)
- & "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...)
- & "fscale ", -- 2**(Fract (...) + Int (...))
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs =>
- (Double'Asm_Input ("0", X),
- Double'Asm_Input ("u", Y)));
- return Result;
- end Logarithmic_Pow;
-
- ---------
- -- Pow --
- ---------
-
- function Pow (X, Y : Double) return Double is
- type Mantissa_Type is mod 2**Double'Machine_Mantissa;
- -- Modular type that can hold all bits of the mantissa of Double
-
- -- For negative exponents, do divide at the end of the processing
-
- Negative_Y : constant Boolean := Y < 0.0;
- Abs_Y : constant Double := abs Y;
-
- -- During this function the following invariant is kept:
- -- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor
-
- Base : Double := X;
-
- Exp_High : Double := Double'Floor (Abs_Y);
- Exp_Mid : Double;
- Exp_Low : Double;
- Exp_Int : Mantissa_Type;
-
- Factor : Double := 1.0;
-
- begin
- -- Select algorithm for calculating Pow (integer cases fall through)
-
- if Exp_High >= 2.0**Double'Machine_Mantissa then
-
- -- In case of Y that is IEEE infinity, just raise constraint error
-
- if Exp_High > Double'Safe_Last then
- raise Constraint_Error;
- end if;
-
- -- Large values of Y are even integers and will stay integer
- -- after division by two.
-
- loop
- -- Exp_Mid and Exp_Low are zero, so
- -- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2)
-
- Exp_High := Exp_High / 2.0;
- Base := Base * Base;
- exit when Exp_High < 2.0**Double'Machine_Mantissa;
- end loop;
-
- elsif Exp_High /= Abs_Y then
- Exp_Low := Abs_Y - Exp_High;
- Factor := 1.0;
-
- if Exp_Low /= 0.0 then
-
- -- Exp_Low now is in interval (0.0, 1.0)
- -- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0;
-
- Exp_Mid := 0.0;
- Exp_Low := Exp_Low - Exp_Mid;
-
- if Exp_Low >= 0.5 then
- Factor := Sqrt (X);
- Exp_Low := Exp_Low - 0.5; -- exact
-
- if Exp_Low >= 0.25 then
- Factor := Factor * Sqrt (Factor);
- Exp_Low := Exp_Low - 0.25; -- exact
- end if;
-
- elsif Exp_Low >= 0.25 then
- Factor := Sqrt (Sqrt (X));
- Exp_Low := Exp_Low - 0.25; -- exact
- end if;
-
- -- Exp_Low now is in interval (0.0, 0.25)
-
- -- This means it is safe to call Logarithmic_Pow
- -- for the remaining part.
-
- Factor := Factor * Logarithmic_Pow (X, Exp_Low);
- end if;
-
- elsif X = 0.0 then
- return 0.0;
- end if;
-
- -- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa
-
- Exp_Int := Mantissa_Type (Exp_High);
-
- -- Standard way for processing integer powers > 0
-
- while Exp_Int > 1 loop
- if (Exp_Int and 1) = 1 then
-
- -- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0
-
- Factor := Factor * Base;
- end if;
-
- -- Exp_Int is even and Exp_Int > 0, so
- -- Base**Y = (Base**2)**(Exp_Int / 2)
-
- Base := Base * Base;
- Exp_Int := Exp_Int / 2;
- end loop;
-
- -- Exp_Int = 1 or Exp_Int = 0
-
- if Exp_Int = 1 then
- Factor := Base * Factor;
- end if;
-
- if Negative_Y then
- Factor := 1.0 / Factor;
- end if;
-
- return Factor;
- end Pow;
-
- ---------
- -- Sin --
- ---------
-
- function Sin (X : Double) return Double is
- Reduced_X : Double := X;
- Result : Double;
- Quadrant : Natural range 0 .. 3;
-
- begin
- if abs X > Pi / 4.0 then
- Reduce (Reduced_X, Quadrant);
-
- case Quadrant is
- when 0 =>
- Asm (Template => "fsin",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
-
- when 1 =>
- Asm (Template => "fcos",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
-
- when 2 =>
- Asm (Template => "fsin",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", -Reduced_X));
-
- when 3 =>
- Asm (Template => "fcos ; fchs",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end case;
-
- else
- Asm (Template => "fsin",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end if;
-
- return Result;
- end Sin;
-
- ---------
- -- Tan --
- ---------
-
- function Tan (X : Double) return Double is
- Reduced_X : Double := X;
- Result : Double;
- Quadrant : Natural range 0 .. 3;
-
- begin
- if abs X > Pi / 4.0 then
- Reduce (Reduced_X, Quadrant);
-
- if Quadrant mod 2 = 0 then
- Asm (Template => "fptan" & NL
- & "ffree %%st(0)" & NL
- & "fincstp",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- else
- Asm (Template => "fsincos" & NL
- & "fdivp %%st, %%st(1)" & NL
- & "fchs",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end if;
-
- else
- Asm (Template =>
- "fptan " & NL
- & "ffree %%st(0) " & NL
- & "fincstp ",
- Outputs => Double'Asm_Output ("=t", Result),
- Inputs => Double'Asm_Input ("0", Reduced_X));
- end if;
-
- return Result;
- end Tan;
-
- ----------
- -- Sinh --
- ----------
-
- function Sinh (X : Double) return Double is
- begin
- -- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0
-
- if abs X < 25.0 then
- return (Exp (X) - Exp (-X)) / 2.0;
- else
- return Exp (X) / 2.0;
- end if;
- end Sinh;
-
- ----------
- -- Cosh --
- ----------
-
- function Cosh (X : Double) return Double is
- begin
- -- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0
-
- if abs X < 22.0 then
- return (Exp (X) + Exp (-X)) / 2.0;
- else
- return Exp (X) / 2.0;
- end if;
- end Cosh;
-
- ----------
- -- Tanh --
- ----------
-
- function Tanh (X : Double) return Double is
- begin
- -- Return the Hyperbolic Tangent of x
-
- -- x -x
- -- e - e Sinh (X)
- -- Tanh (X) is defined to be ----------- = --------
- -- x -x Cosh (X)
- -- e + e
-
- if abs X > 23.0 then
- return Double'Copy_Sign (1.0, X);
- end if;
-
- return 1.0 / (1.0 + Exp (-(2.0 * X))) - 1.0 / (1.0 + Exp (2.0 * X));
- end Tanh;
-
-end Ada.Numerics.Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . N U M E R I C S . A U X --
--- --
--- S p e c --
--- (Machine Version for x86) --
--- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for the x86 using the 80-bit x86 long double format with
--- inline asm statements.
-
-package Ada.Numerics.Aux is
- pragma Pure;
-
- type Double is new Long_Long_Float;
-
- function Sin (X : Double) return Double;
-
- function Cos (X : Double) return Double;
-
- function Tan (X : Double) return Double;
-
- function Exp (X : Double) return Double;
-
- function Sqrt (X : Double) return Double;
-
- function Log (X : Double) return Double;
-
- function Atan (X : Double) return Double;
-
- function Acos (X : Double) return Double;
-
- function Asin (X : Double) return Double;
-
- function Sinh (X : Double) return Double;
-
- function Cosh (X : Double) return Double;
-
- function Tanh (X : Double) return Double;
-
- function Pow (X, Y : Double) return Double;
-
-private
- pragma Inline (Atan);
- pragma Inline (Cos);
- pragma Inline (Tan);
- pragma Inline (Exp);
- pragma Inline (Log);
- pragma Inline (Sin);
- pragma Inline (Sqrt);
-
-end Ada.Numerics.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- B o d y --
+-- (Apple OS X Version) --
+-- --
+-- Copyright (C) 1998-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Numerics.Aux is
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ function Is_Nan (X : Double) return Boolean;
+ -- Return True iff X is a IEEE NaN value
+
+ procedure Reduce (X : in out Double; Q : out Natural);
+ -- Implement reduction of X by Pi/2. Q is the quadrant of the final
+ -- result in the range 0..3. The absolute value of X is at most Pi/4.
+ -- It is needed to avoid a loss of accuracy for sin near Pi and cos
+ -- near Pi/2 due to the use of an insufficiently precise value of Pi
+ -- in the range reduction.
+
+ -- The following two functions implement Chebishev approximations
+ -- of the trigonometric functions in their reduced domain.
+ -- These approximations have been computed using Maple.
+
+ function Sine_Approx (X : Double) return Double;
+ function Cosine_Approx (X : Double) return Double;
+
+ pragma Inline (Reduce);
+ pragma Inline (Sine_Approx);
+ pragma Inline (Cosine_Approx);
+
+ -------------------
+ -- Cosine_Approx --
+ -------------------
+
+ function Cosine_Approx (X : Double) return Double is
+ XX : constant Double := X * X;
+ begin
+ return (((((16#8.DC57FBD05F640#E-08 * XX
+ - 16#4.9F7D00BF25D80#E-06) * XX
+ + 16#1.A019F7FDEFCC2#E-04) * XX
+ - 16#5.B05B058F18B20#E-03) * XX
+ + 16#A.AAAAAAAA73FA8#E-02) * XX
+ - 16#7.FFFFFFFFFFDE4#E-01) * XX
+ - 16#3.655E64869ECCE#E-14 + 1.0;
+ end Cosine_Approx;
+
+ -----------------
+ -- Sine_Approx --
+ -----------------
+
+ function Sine_Approx (X : Double) return Double is
+ XX : constant Double := X * X;
+ begin
+ return (((((16#A.EA2D4ABE41808#E-09 * XX
+ - 16#6.B974C10F9D078#E-07) * XX
+ + 16#2.E3BC673425B0E#E-05) * XX
+ - 16#D.00D00CCA7AF00#E-04) * XX
+ + 16#2.222222221B190#E-02) * XX
+ - 16#2.AAAAAAAAAAA44#E-01) * (XX * X) + X;
+ end Sine_Approx;
+
+ ------------
+ -- Is_Nan --
+ ------------
+
+ function Is_Nan (X : Double) return Boolean is
+ begin
+ -- The IEEE NaN values are the only ones that do not equal themselves
+
+ return X /= X;
+ end Is_Nan;
+
+ ------------
+ -- Reduce --
+ ------------
+
+ procedure Reduce (X : in out Double; Q : out Natural) is
+ Half_Pi : constant := Pi / 2.0;
+ Two_Over_Pi : constant := 2.0 / Pi;
+
+ HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size);
+ M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant
+ P1 : constant Double := Double'Leading_Part (Half_Pi, HM);
+ P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM);
+ P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM);
+ P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM);
+ P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3
+ - P4, HM);
+ P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5);
+ K : Double;
+ R : Integer;
+
+ begin
+ -- For X < 2.0**HM, all products below are computed exactly.
+ -- Due to cancellation effects all subtractions are exact as well.
+ -- As no double extended floating-point number has more than 75
+ -- zeros after the binary point, the result will be the correctly
+ -- rounded result of X - K * (Pi / 2.0).
+
+ K := X * Two_Over_Pi;
+ while abs K >= 2.0**HM loop
+ K := K * M - (K * M - K);
+ X :=
+ (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6;
+ K := X * Two_Over_Pi;
+ end loop;
+
+ -- If K is not a number (because X was not finite) raise exception
+
+ if Is_Nan (K) then
+ raise Constraint_Error;
+ end if;
+
+ -- Go through an integer temporary so as to use machine instructions
+
+ R := Integer (Double'Rounding (K));
+ Q := R mod 4;
+ K := Double (R);
+ X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6;
+ end Reduce;
+
+ ---------
+ -- Cos --
+ ---------
+
+ function Cos (X : Double) return Double is
+ Reduced_X : Double := abs X;
+ Quadrant : Natural range 0 .. 3;
+
+ begin
+ if Reduced_X > Pi / 4.0 then
+ Reduce (Reduced_X, Quadrant);
+
+ case Quadrant is
+ when 0 =>
+ return Cosine_Approx (Reduced_X);
+
+ when 1 =>
+ return Sine_Approx (-Reduced_X);
+
+ when 2 =>
+ return -Cosine_Approx (Reduced_X);
+
+ when 3 =>
+ return Sine_Approx (Reduced_X);
+ end case;
+ end if;
+
+ return Cosine_Approx (Reduced_X);
+ end Cos;
+
+ ---------
+ -- Sin --
+ ---------
+
+ function Sin (X : Double) return Double is
+ Reduced_X : Double := X;
+ Quadrant : Natural range 0 .. 3;
+
+ begin
+ if abs X > Pi / 4.0 then
+ Reduce (Reduced_X, Quadrant);
+
+ case Quadrant is
+ when 0 =>
+ return Sine_Approx (Reduced_X);
+
+ when 1 =>
+ return Cosine_Approx (Reduced_X);
+
+ when 2 =>
+ return Sine_Approx (-Reduced_X);
+
+ when 3 =>
+ return -Cosine_Approx (Reduced_X);
+ end case;
+ end if;
+
+ return Sine_Approx (Reduced_X);
+ end Sin;
+
+end Ada.Numerics.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- S p e c --
+-- (Apple OS X Version) --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for use on OS X. It uses the normal Unix math functions,
+-- except for sine/cosine which have been implemented directly in Ada to get
+-- the required accuracy.
+
+package Ada.Numerics.Aux is
+ pragma Pure;
+
+ pragma Linker_Options ("-lm");
+
+ type Double is new Long_Float;
+ -- Type Double is the type used to call the C routines
+
+ -- The following functions have been implemented in Ada, since
+ -- the OS X math library didn't meet accuracy requirements for
+ -- argument reduction. The implementation here has been tailored
+ -- to match Ada strict mode Numerics requirements while maintaining
+ -- maximum efficiency.
+ function Sin (X : Double) return Double;
+ pragma Inline (Sin);
+
+ function Cos (X : Double) return Double;
+ pragma Inline (Cos);
+
+ -- We import these functions directly from C. Note that we label them
+ -- all as pure functions, because indeed all of them are in fact pure.
+
+ function Tan (X : Double) return Double;
+ pragma Import (C, Tan, "tan");
+ pragma Pure_Function (Tan);
+
+ function Exp (X : Double) return Double;
+ pragma Import (C, Exp, "exp");
+ pragma Pure_Function (Exp);
+
+ function Sqrt (X : Double) return Double;
+ pragma Import (C, Sqrt, "sqrt");
+ pragma Pure_Function (Sqrt);
+
+ function Log (X : Double) return Double;
+ pragma Import (C, Log, "log");
+ pragma Pure_Function (Log);
+
+ function Acos (X : Double) return Double;
+ pragma Import (C, Acos, "acos");
+ pragma Pure_Function (Acos);
+
+ function Asin (X : Double) return Double;
+ pragma Import (C, Asin, "asin");
+ pragma Pure_Function (Asin);
+
+ function Atan (X : Double) return Double;
+ pragma Import (C, Atan, "atan");
+ pragma Pure_Function (Atan);
+
+ function Sinh (X : Double) return Double;
+ pragma Import (C, Sinh, "sinh");
+ pragma Pure_Function (Sinh);
+
+ function Cosh (X : Double) return Double;
+ pragma Import (C, Cosh, "cosh");
+ pragma Pure_Function (Cosh);
+
+ function Tanh (X : Double) return Double;
+ pragma Import (C, Tanh, "tanh");
+ pragma Pure_Function (Tanh);
+
+ function Pow (X, Y : Double) return Double;
+ pragma Import (C, Pow, "pow");
+ pragma Pure_Function (Pow);
+
+end Ada.Numerics.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- S p e c --
+-- (C Library Version for x86) --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for the x86 using the 80-bit x86 long double format
+
+package Ada.Numerics.Aux is
+ pragma Pure;
+
+ pragma Linker_Options ("-lm");
+
+ type Double is new Long_Long_Float;
+
+ -- We import these functions directly from C. Note that we label them
+ -- all as pure functions, because indeed all of them are in fact pure.
+
+ function Sin (X : Double) return Double;
+ pragma Import (C, Sin, "sinl");
+ pragma Pure_Function (Sin);
+
+ function Cos (X : Double) return Double;
+ pragma Import (C, Cos, "cosl");
+ pragma Pure_Function (Cos);
+
+ function Tan (X : Double) return Double;
+ pragma Import (C, Tan, "tanl");
+ pragma Pure_Function (Tan);
+
+ function Exp (X : Double) return Double;
+ pragma Import (C, Exp, "expl");
+ pragma Pure_Function (Exp);
+
+ function Sqrt (X : Double) return Double;
+ pragma Import (C, Sqrt, "sqrtl");
+ pragma Pure_Function (Sqrt);
+
+ function Log (X : Double) return Double;
+ pragma Import (C, Log, "logl");
+ pragma Pure_Function (Log);
+
+ function Acos (X : Double) return Double;
+ pragma Import (C, Acos, "acosl");
+ pragma Pure_Function (Acos);
+
+ function Asin (X : Double) return Double;
+ pragma Import (C, Asin, "asinl");
+ pragma Pure_Function (Asin);
+
+ function Atan (X : Double) return Double;
+ pragma Import (C, Atan, "atanl");
+ pragma Pure_Function (Atan);
+
+ function Sinh (X : Double) return Double;
+ pragma Import (C, Sinh, "sinhl");
+ pragma Pure_Function (Sinh);
+
+ function Cosh (X : Double) return Double;
+ pragma Import (C, Cosh, "coshl");
+ pragma Pure_Function (Cosh);
+
+ function Tanh (X : Double) return Double;
+ pragma Import (C, Tanh, "tanhl");
+ pragma Pure_Function (Tanh);
+
+ function Pow (X, Y : Double) return Double;
+ pragma Import (C, Pow, "powl");
+ pragma Pure_Function (Pow);
+
+end Ada.Numerics.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- S p e c --
+-- (C Library Version, VxWorks) --
+-- --
+-- Copyright (C) 1992-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Version for use on VxWorks (where we have no libm.a library), so the pragma
+-- Linker_Options ("-lm") is omitted in this version.
+
+package Ada.Numerics.Aux is
+ pragma Pure;
+
+ type Double is new Long_Float;
+ -- Type Double is the type used to call the C routines
+
+ -- We import these functions directly from C. Note that we label them
+ -- all as pure functions, because indeed all of them are in fact pure.
+
+ function Sin (X : Double) return Double;
+ pragma Import (C, Sin, "sin");
+ pragma Pure_Function (Sin);
+
+ function Cos (X : Double) return Double;
+ pragma Import (C, Cos, "cos");
+ pragma Pure_Function (Cos);
+
+ function Tan (X : Double) return Double;
+ pragma Import (C, Tan, "tan");
+ pragma Pure_Function (Tan);
+
+ function Exp (X : Double) return Double;
+ pragma Import (C, Exp, "exp");
+ pragma Pure_Function (Exp);
+
+ function Sqrt (X : Double) return Double;
+ pragma Import (C, Sqrt, "sqrt");
+ pragma Pure_Function (Sqrt);
+
+ function Log (X : Double) return Double;
+ pragma Import (C, Log, "log");
+ pragma Pure_Function (Log);
+
+ function Acos (X : Double) return Double;
+ pragma Import (C, Acos, "acos");
+ pragma Pure_Function (Acos);
+
+ function Asin (X : Double) return Double;
+ pragma Import (C, Asin, "asin");
+ pragma Pure_Function (Asin);
+
+ function Atan (X : Double) return Double;
+ pragma Import (C, Atan, "atan");
+ pragma Pure_Function (Atan);
+
+ function Sinh (X : Double) return Double;
+ pragma Import (C, Sinh, "sinh");
+ pragma Pure_Function (Sinh);
+
+ function Cosh (X : Double) return Double;
+ pragma Import (C, Cosh, "cosh");
+ pragma Pure_Function (Cosh);
+
+ function Tanh (X : Double) return Double;
+ pragma Import (C, Tanh, "tanh");
+ pragma Pure_Function (Tanh);
+
+ function Pow (X, Y : Double) return Double;
+ pragma Import (C, Pow, "pow");
+ pragma Pure_Function (Pow);
+
+end Ada.Numerics.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- B o d y --
+-- (Machine Version for x86) --
+-- --
+-- Copyright (C) 1998-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Machine_Code; use System.Machine_Code;
+
+package body Ada.Numerics.Aux is
+
+ NL : constant String := ASCII.LF & ASCII.HT;
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ function Is_Nan (X : Double) return Boolean;
+ -- Return True iff X is a IEEE NaN value
+
+ function Logarithmic_Pow (X, Y : Double) return Double;
+ -- Implementation of X**Y using Exp and Log functions (binary base)
+ -- to calculate the exponentiation. This is used by Pow for values
+ -- for values of Y in the open interval (-0.25, 0.25)
+
+ procedure Reduce (X : in out Double; Q : out Natural);
+ -- Implement reduction of X by Pi/2. Q is the quadrant of the final
+ -- result in the range 0..3. The absolute value of X is at most Pi/4.
+ -- It is needed to avoid a loss of accuracy for sin near Pi and cos
+ -- near Pi/2 due to the use of an insufficiently precise value of Pi
+ -- in the range reduction.
+
+ pragma Inline (Is_Nan);
+ pragma Inline (Reduce);
+
+ --------------------------------
+ -- Basic Elementary Functions --
+ --------------------------------
+
+ -- This section implements a few elementary functions that are used to
+ -- build the more complex ones. This ordering enables better inlining.
+
+ ----------
+ -- Atan --
+ ----------
+
+ function Atan (X : Double) return Double is
+ Result : Double;
+
+ begin
+ Asm (Template =>
+ "fld1" & NL
+ & "fpatan",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", X));
+
+ -- The result value is NaN iff input was invalid
+
+ if not (Result = Result) then
+ raise Argument_Error;
+ end if;
+
+ return Result;
+ end Atan;
+
+ ---------
+ -- Exp --
+ ---------
+
+ function Exp (X : Double) return Double is
+ Result : Double;
+ begin
+ Asm (Template =>
+ "fldl2e " & NL
+ & "fmulp %%st, %%st(1)" & NL -- X * log2 (E)
+ & "fld %%st(0) " & NL
+ & "frndint " & NL -- Integer (X * Log2 (E))
+ & "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E))
+ & "fxch " & NL
+ & "f2xm1 " & NL -- 2**(...) - 1
+ & "fld1 " & NL
+ & "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E)))
+ & "fscale " & NL -- E ** X
+ & "fstp %%st(1) ",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", X));
+ return Result;
+ end Exp;
+
+ ------------
+ -- Is_Nan --
+ ------------
+
+ function Is_Nan (X : Double) return Boolean is
+ begin
+ -- The IEEE NaN values are the only ones that do not equal themselves
+
+ return X /= X;
+ end Is_Nan;
+
+ ---------
+ -- Log --
+ ---------
+
+ function Log (X : Double) return Double is
+ Result : Double;
+
+ begin
+ Asm (Template =>
+ "fldln2 " & NL
+ & "fxch " & NL
+ & "fyl2x " & NL,
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", X));
+ return Result;
+ end Log;
+
+ ------------
+ -- Reduce --
+ ------------
+
+ procedure Reduce (X : in out Double; Q : out Natural) is
+ Half_Pi : constant := Pi / 2.0;
+ Two_Over_Pi : constant := 2.0 / Pi;
+
+ HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size);
+ M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant
+ P1 : constant Double := Double'Leading_Part (Half_Pi, HM);
+ P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM);
+ P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM);
+ P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM);
+ P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3
+ - P4, HM);
+ P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5);
+ K : Double;
+ R : Integer;
+
+ begin
+ -- For X < 2.0**HM, all products below are computed exactly.
+ -- Due to cancellation effects all subtractions are exact as well.
+ -- As no double extended floating-point number has more than 75
+ -- zeros after the binary point, the result will be the correctly
+ -- rounded result of X - K * (Pi / 2.0).
+
+ K := X * Two_Over_Pi;
+ while abs K >= 2.0**HM loop
+ K := K * M - (K * M - K);
+ X :=
+ (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6;
+ K := X * Two_Over_Pi;
+ end loop;
+
+ -- If K is not a number (because X was not finite) raise exception
+
+ if Is_Nan (K) then
+ raise Constraint_Error;
+ end if;
+
+ -- Go through an integer temporary so as to use machine instructions
+
+ R := Integer (Double'Rounding (K));
+ Q := R mod 4;
+ K := Double (R);
+ X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6;
+ end Reduce;
+
+ ----------
+ -- Sqrt --
+ ----------
+
+ function Sqrt (X : Double) return Double is
+ Result : Double;
+
+ begin
+ if X < 0.0 then
+ raise Argument_Error;
+ end if;
+
+ Asm (Template => "fsqrt",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", X));
+
+ return Result;
+ end Sqrt;
+
+ --------------------------------
+ -- Other Elementary Functions --
+ --------------------------------
+
+ -- These are built using the previously implemented basic functions
+
+ ----------
+ -- Acos --
+ ----------
+
+ function Acos (X : Double) return Double is
+ Result : Double;
+
+ begin
+ Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X)));
+
+ -- The result value is NaN iff input was invalid
+
+ if Is_Nan (Result) then
+ raise Argument_Error;
+ end if;
+
+ return Result;
+ end Acos;
+
+ ----------
+ -- Asin --
+ ----------
+
+ function Asin (X : Double) return Double is
+ Result : Double;
+
+ begin
+ Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X)));
+
+ -- The result value is NaN iff input was invalid
+
+ if Is_Nan (Result) then
+ raise Argument_Error;
+ end if;
+
+ return Result;
+ end Asin;
+
+ ---------
+ -- Cos --
+ ---------
+
+ function Cos (X : Double) return Double is
+ Reduced_X : Double := abs X;
+ Result : Double;
+ Quadrant : Natural range 0 .. 3;
+
+ begin
+ if Reduced_X > Pi / 4.0 then
+ Reduce (Reduced_X, Quadrant);
+
+ case Quadrant is
+ when 0 =>
+ Asm (Template => "fcos",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+
+ when 1 =>
+ Asm (Template => "fsin",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", -Reduced_X));
+
+ when 2 =>
+ Asm (Template => "fcos ; fchs",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+
+ when 3 =>
+ Asm (Template => "fsin",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+ end case;
+
+ else
+ Asm (Template => "fcos",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+ end if;
+
+ return Result;
+ end Cos;
+
+ ---------------------
+ -- Logarithmic_Pow --
+ ---------------------
+
+ function Logarithmic_Pow (X, Y : Double) return Double is
+ Result : Double;
+ begin
+ Asm (Template => "" -- X : Y
+ & "fyl2x " & NL -- Y * Log2 (X)
+ & "fld %%st(0) " & NL -- Y * Log2 (X) : Y * Log2 (X)
+ & "frndint " & NL -- Int (...) : Y * Log2 (X)
+ & "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...)
+ & "fxch " & NL -- Fract (...) : Int (...)
+ & "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...)
+ & "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...)
+ & "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...)
+ & "fscale ", -- 2**(Fract (...) + Int (...))
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs =>
+ (Double'Asm_Input ("0", X),
+ Double'Asm_Input ("u", Y)));
+ return Result;
+ end Logarithmic_Pow;
+
+ ---------
+ -- Pow --
+ ---------
+
+ function Pow (X, Y : Double) return Double is
+ type Mantissa_Type is mod 2**Double'Machine_Mantissa;
+ -- Modular type that can hold all bits of the mantissa of Double
+
+ -- For negative exponents, do divide at the end of the processing
+
+ Negative_Y : constant Boolean := Y < 0.0;
+ Abs_Y : constant Double := abs Y;
+
+ -- During this function the following invariant is kept:
+ -- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor
+
+ Base : Double := X;
+
+ Exp_High : Double := Double'Floor (Abs_Y);
+ Exp_Mid : Double;
+ Exp_Low : Double;
+ Exp_Int : Mantissa_Type;
+
+ Factor : Double := 1.0;
+
+ begin
+ -- Select algorithm for calculating Pow (integer cases fall through)
+
+ if Exp_High >= 2.0**Double'Machine_Mantissa then
+
+ -- In case of Y that is IEEE infinity, just raise constraint error
+
+ if Exp_High > Double'Safe_Last then
+ raise Constraint_Error;
+ end if;
+
+ -- Large values of Y are even integers and will stay integer
+ -- after division by two.
+
+ loop
+ -- Exp_Mid and Exp_Low are zero, so
+ -- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2)
+
+ Exp_High := Exp_High / 2.0;
+ Base := Base * Base;
+ exit when Exp_High < 2.0**Double'Machine_Mantissa;
+ end loop;
+
+ elsif Exp_High /= Abs_Y then
+ Exp_Low := Abs_Y - Exp_High;
+ Factor := 1.0;
+
+ if Exp_Low /= 0.0 then
+
+ -- Exp_Low now is in interval (0.0, 1.0)
+ -- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0;
+
+ Exp_Mid := 0.0;
+ Exp_Low := Exp_Low - Exp_Mid;
+
+ if Exp_Low >= 0.5 then
+ Factor := Sqrt (X);
+ Exp_Low := Exp_Low - 0.5; -- exact
+
+ if Exp_Low >= 0.25 then
+ Factor := Factor * Sqrt (Factor);
+ Exp_Low := Exp_Low - 0.25; -- exact
+ end if;
+
+ elsif Exp_Low >= 0.25 then
+ Factor := Sqrt (Sqrt (X));
+ Exp_Low := Exp_Low - 0.25; -- exact
+ end if;
+
+ -- Exp_Low now is in interval (0.0, 0.25)
+
+ -- This means it is safe to call Logarithmic_Pow
+ -- for the remaining part.
+
+ Factor := Factor * Logarithmic_Pow (X, Exp_Low);
+ end if;
+
+ elsif X = 0.0 then
+ return 0.0;
+ end if;
+
+ -- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa
+
+ Exp_Int := Mantissa_Type (Exp_High);
+
+ -- Standard way for processing integer powers > 0
+
+ while Exp_Int > 1 loop
+ if (Exp_Int and 1) = 1 then
+
+ -- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0
+
+ Factor := Factor * Base;
+ end if;
+
+ -- Exp_Int is even and Exp_Int > 0, so
+ -- Base**Y = (Base**2)**(Exp_Int / 2)
+
+ Base := Base * Base;
+ Exp_Int := Exp_Int / 2;
+ end loop;
+
+ -- Exp_Int = 1 or Exp_Int = 0
+
+ if Exp_Int = 1 then
+ Factor := Base * Factor;
+ end if;
+
+ if Negative_Y then
+ Factor := 1.0 / Factor;
+ end if;
+
+ return Factor;
+ end Pow;
+
+ ---------
+ -- Sin --
+ ---------
+
+ function Sin (X : Double) return Double is
+ Reduced_X : Double := X;
+ Result : Double;
+ Quadrant : Natural range 0 .. 3;
+
+ begin
+ if abs X > Pi / 4.0 then
+ Reduce (Reduced_X, Quadrant);
+
+ case Quadrant is
+ when 0 =>
+ Asm (Template => "fsin",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+
+ when 1 =>
+ Asm (Template => "fcos",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+
+ when 2 =>
+ Asm (Template => "fsin",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", -Reduced_X));
+
+ when 3 =>
+ Asm (Template => "fcos ; fchs",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+ end case;
+
+ else
+ Asm (Template => "fsin",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+ end if;
+
+ return Result;
+ end Sin;
+
+ ---------
+ -- Tan --
+ ---------
+
+ function Tan (X : Double) return Double is
+ Reduced_X : Double := X;
+ Result : Double;
+ Quadrant : Natural range 0 .. 3;
+
+ begin
+ if abs X > Pi / 4.0 then
+ Reduce (Reduced_X, Quadrant);
+
+ if Quadrant mod 2 = 0 then
+ Asm (Template => "fptan" & NL
+ & "ffree %%st(0)" & NL
+ & "fincstp",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+ else
+ Asm (Template => "fsincos" & NL
+ & "fdivp %%st, %%st(1)" & NL
+ & "fchs",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+ end if;
+
+ else
+ Asm (Template =>
+ "fptan " & NL
+ & "ffree %%st(0) " & NL
+ & "fincstp ",
+ Outputs => Double'Asm_Output ("=t", Result),
+ Inputs => Double'Asm_Input ("0", Reduced_X));
+ end if;
+
+ return Result;
+ end Tan;
+
+ ----------
+ -- Sinh --
+ ----------
+
+ function Sinh (X : Double) return Double is
+ begin
+ -- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0
+
+ if abs X < 25.0 then
+ return (Exp (X) - Exp (-X)) / 2.0;
+ else
+ return Exp (X) / 2.0;
+ end if;
+ end Sinh;
+
+ ----------
+ -- Cosh --
+ ----------
+
+ function Cosh (X : Double) return Double is
+ begin
+ -- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0
+
+ if abs X < 22.0 then
+ return (Exp (X) + Exp (-X)) / 2.0;
+ else
+ return Exp (X) / 2.0;
+ end if;
+ end Cosh;
+
+ ----------
+ -- Tanh --
+ ----------
+
+ function Tanh (X : Double) return Double is
+ begin
+ -- Return the Hyperbolic Tangent of x
+
+ -- x -x
+ -- e - e Sinh (X)
+ -- Tanh (X) is defined to be ----------- = --------
+ -- x -x Cosh (X)
+ -- e + e
+
+ if abs X > 23.0 then
+ return Double'Copy_Sign (1.0, X);
+ end if;
+
+ return 1.0 / (1.0 + Exp (-(2.0 * X))) - 1.0 / (1.0 + Exp (2.0 * X));
+ end Tanh;
+
+end Ada.Numerics.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . N U M E R I C S . A U X --
+-- --
+-- S p e c --
+-- (Machine Version for x86) --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for the x86 using the 80-bit x86 long double format with
+-- inline asm statements.
+
+package Ada.Numerics.Aux is
+ pragma Pure;
+
+ type Double is new Long_Long_Float;
+
+ function Sin (X : Double) return Double;
+
+ function Cos (X : Double) return Double;
+
+ function Tan (X : Double) return Double;
+
+ function Exp (X : Double) return Double;
+
+ function Sqrt (X : Double) return Double;
+
+ function Log (X : Double) return Double;
+
+ function Atan (X : Double) return Double;
+
+ function Acos (X : Double) return Double;
+
+ function Asin (X : Double) return Double;
+
+ function Sinh (X : Double) return Double;
+
+ function Cosh (X : Double) return Double;
+
+ function Tanh (X : Double) return Double;
+
+ function Pow (X, Y : Double) return Double;
+
+private
+ pragma Inline (Atan);
+ pragma Inline (Cos);
+ pragma Inline (Tan);
+ pragma Inline (Exp);
+ pragma Inline (Log);
+ pragma Inline (Sin);
+ pragma Inline (Sqrt);
+
+end Ada.Numerics.Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S T R I N G S . U N B O U N D E D --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Strings.Search;
-with Ada.Unchecked_Deallocation;
-
-package body Ada.Strings.Unbounded is
-
- use Ada.Strings.Maps;
-
- Growth_Factor : constant := 32;
- -- The growth factor controls how much extra space is allocated when
- -- we have to increase the size of an allocated unbounded string. By
- -- allocating extra space, we avoid the need to reallocate on every
- -- append, particularly important when a string is built up by repeated
- -- append operations of small pieces. This is expressed as a factor so
- -- 32 means add 1/32 of the length of the string as growth space.
-
- Min_Mul_Alloc : constant := Standard'Maximum_Alignment;
- -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes
- -- no memory loss as most (all?) malloc implementations are obliged to
- -- align the returned memory on the maximum alignment as malloc does not
- -- know the target alignment.
-
- function Aligned_Max_Length (Max_Length : Natural) return Natural;
- -- Returns recommended length of the shared string which is greater or
- -- equal to specified length. Calculation take in sense alignment of the
- -- allocated memory segments to use memory effectively by Append/Insert/etc
- -- operations.
-
- ---------
- -- "&" --
- ---------
-
- function "&"
- (Left : Unbounded_String;
- Right : Unbounded_String) return Unbounded_String
- is
- LR : constant Shared_String_Access := Left.Reference;
- RR : constant Shared_String_Access := Right.Reference;
- DL : constant Natural := LR.Last + RR.Last;
- DR : Shared_String_Access;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Left string is empty, return Right string
-
- elsif LR.Last = 0 then
- Reference (RR);
- DR := RR;
-
- -- Right string is empty, return Left string
-
- elsif RR.Last = 0 then
- Reference (LR);
- DR := LR;
-
- -- Otherwise, allocate new shared string and fill data
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
- DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : Unbounded_String;
- Right : String) return Unbounded_String
- is
- LR : constant Shared_String_Access := Left.Reference;
- DL : constant Natural := LR.Last + Right'Length;
- DR : Shared_String_Access;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Right is an empty string, return Left string
-
- elsif Right'Length = 0 then
- Reference (LR);
- DR := LR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
- DR.Data (LR.Last + 1 .. DL) := Right;
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : String;
- Right : Unbounded_String) return Unbounded_String
- is
- RR : constant Shared_String_Access := Right.Reference;
- DL : constant Natural := Left'Length + RR.Last;
- DR : Shared_String_Access;
-
- begin
- -- Result is an empty string, reuse shared one
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Left is empty string, return Right string
-
- elsif Left'Length = 0 then
- Reference (RR);
- DR := RR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Left'Length) := Left;
- DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : Unbounded_String;
- Right : Character) return Unbounded_String
- is
- LR : constant Shared_String_Access := Left.Reference;
- DL : constant Natural := LR.Last + 1;
- DR : Shared_String_Access;
-
- begin
- DR := Allocate (DL);
- DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
- DR.Data (DL) := Right;
- DR.Last := DL;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : Character;
- Right : Unbounded_String) return Unbounded_String
- is
- RR : constant Shared_String_Access := Right.Reference;
- DL : constant Natural := 1 + RR.Last;
- DR : Shared_String_Access;
-
- begin
- DR := Allocate (DL);
- DR.Data (1) := Left;
- DR.Data (2 .. DL) := RR.Data (1 .. RR.Last);
- DR.Last := DL;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- ---------
- -- "*" --
- ---------
-
- function "*"
- (Left : Natural;
- Right : Character) return Unbounded_String
- is
- DR : Shared_String_Access;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if Left = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (Left);
-
- for J in 1 .. Left loop
- DR.Data (J) := Right;
- end loop;
-
- DR.Last := Left;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "*";
-
- function "*"
- (Left : Natural;
- Right : String) return Unbounded_String
- is
- DL : constant Natural := Left * Right'Length;
- DR : Shared_String_Access;
- K : Positive;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- K := 1;
-
- for J in 1 .. Left loop
- DR.Data (K .. K + Right'Length - 1) := Right;
- K := K + Right'Length;
- end loop;
-
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "*";
-
- function "*"
- (Left : Natural;
- Right : Unbounded_String) return Unbounded_String
- is
- RR : constant Shared_String_Access := Right.Reference;
- DL : constant Natural := Left * RR.Last;
- DR : Shared_String_Access;
- K : Positive;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Coefficient is one, just return string itself
-
- elsif Left = 1 then
- Reference (RR);
- DR := RR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- K := 1;
-
- for J in 1 .. Left loop
- DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last);
- K := K + RR.Last;
- end loop;
-
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "*";
-
- ---------
- -- "<" --
- ---------
-
- function "<"
- (Left : Unbounded_String;
- Right : Unbounded_String) return Boolean
- is
- LR : constant Shared_String_Access := Left.Reference;
- RR : constant Shared_String_Access := Right.Reference;
- begin
- return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last);
- end "<";
-
- function "<"
- (Left : Unbounded_String;
- Right : String) return Boolean
- is
- LR : constant Shared_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) < Right;
- end "<";
-
- function "<"
- (Left : String;
- Right : Unbounded_String) return Boolean
- is
- RR : constant Shared_String_Access := Right.Reference;
- begin
- return Left < RR.Data (1 .. RR.Last);
- end "<";
-
- ----------
- -- "<=" --
- ----------
-
- function "<="
- (Left : Unbounded_String;
- Right : Unbounded_String) return Boolean
- is
- LR : constant Shared_String_Access := Left.Reference;
- RR : constant Shared_String_Access := Right.Reference;
-
- begin
- -- LR = RR means two strings shares shared string, thus they are equal
-
- return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last);
- end "<=";
-
- function "<="
- (Left : Unbounded_String;
- Right : String) return Boolean
- is
- LR : constant Shared_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) <= Right;
- end "<=";
-
- function "<="
- (Left : String;
- Right : Unbounded_String) return Boolean
- is
- RR : constant Shared_String_Access := Right.Reference;
- begin
- return Left <= RR.Data (1 .. RR.Last);
- end "<=";
-
- ---------
- -- "=" --
- ---------
-
- function "="
- (Left : Unbounded_String;
- Right : Unbounded_String) return Boolean
- is
- LR : constant Shared_String_Access := Left.Reference;
- RR : constant Shared_String_Access := Right.Reference;
-
- begin
- return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last);
- -- LR = RR means two strings shares shared string, thus they are equal
- end "=";
-
- function "="
- (Left : Unbounded_String;
- Right : String) return Boolean
- is
- LR : constant Shared_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) = Right;
- end "=";
-
- function "="
- (Left : String;
- Right : Unbounded_String) return Boolean
- is
- RR : constant Shared_String_Access := Right.Reference;
- begin
- return Left = RR.Data (1 .. RR.Last);
- end "=";
-
- ---------
- -- ">" --
- ---------
-
- function ">"
- (Left : Unbounded_String;
- Right : Unbounded_String) return Boolean
- is
- LR : constant Shared_String_Access := Left.Reference;
- RR : constant Shared_String_Access := Right.Reference;
- begin
- return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last);
- end ">";
-
- function ">"
- (Left : Unbounded_String;
- Right : String) return Boolean
- is
- LR : constant Shared_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) > Right;
- end ">";
-
- function ">"
- (Left : String;
- Right : Unbounded_String) return Boolean
- is
- RR : constant Shared_String_Access := Right.Reference;
- begin
- return Left > RR.Data (1 .. RR.Last);
- end ">";
-
- ----------
- -- ">=" --
- ----------
-
- function ">="
- (Left : Unbounded_String;
- Right : Unbounded_String) return Boolean
- is
- LR : constant Shared_String_Access := Left.Reference;
- RR : constant Shared_String_Access := Right.Reference;
-
- begin
- -- LR = RR means two strings shares shared string, thus they are equal
-
- return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last);
- end ">=";
-
- function ">="
- (Left : Unbounded_String;
- Right : String) return Boolean
- is
- LR : constant Shared_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) >= Right;
- end ">=";
-
- function ">="
- (Left : String;
- Right : Unbounded_String) return Boolean
- is
- RR : constant Shared_String_Access := Right.Reference;
- begin
- return Left >= RR.Data (1 .. RR.Last);
- end ">=";
-
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Object : in out Unbounded_String) is
- begin
- Reference (Object.Reference);
- end Adjust;
-
- ------------------------
- -- Aligned_Max_Length --
- ------------------------
-
- function Aligned_Max_Length (Max_Length : Natural) return Natural is
- Static_Size : constant Natural :=
- Empty_Shared_String'Size / Standard'Storage_Unit;
- -- Total size of all static components
-
- begin
- return
- ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc
- - Static_Size;
- end Aligned_Max_Length;
-
- --------------
- -- Allocate --
- --------------
-
- function Allocate
- (Max_Length : Natural) return not null Shared_String_Access
- is
- begin
- -- Empty string requested, return shared empty string
-
- if Max_Length = 0 then
- Reference (Empty_Shared_String'Access);
- return Empty_Shared_String'Access;
-
- -- Otherwise, allocate requested space (and probably some more room)
-
- else
- return new Shared_String (Aligned_Max_Length (Max_Length));
- end if;
- end Allocate;
-
- ------------
- -- Append --
- ------------
-
- procedure Append
- (Source : in out Unbounded_String;
- New_Item : Unbounded_String)
- is
- SR : constant Shared_String_Access := Source.Reference;
- NR : constant Shared_String_Access := New_Item.Reference;
- DL : constant Natural := SR.Last + NR.Last;
- DR : Shared_String_Access;
-
- begin
- -- Source is an empty string, reuse New_Item data
-
- if SR.Last = 0 then
- Reference (NR);
- Source.Reference := NR;
- Unreference (SR);
-
- -- New_Item is empty string, nothing to do
-
- elsif NR.Last = 0 then
- null;
-
- -- Try to reuse existing shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
- SR.Last := DL;
-
- -- Otherwise, allocate new one and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Append;
-
- procedure Append
- (Source : in out Unbounded_String;
- New_Item : String)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + New_Item'Length;
- DR : Shared_String_Access;
-
- begin
- -- New_Item is an empty string, nothing to do
-
- if New_Item'Length = 0 then
- null;
-
- -- Try to reuse existing shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (SR.Last + 1 .. DL) := New_Item;
- SR.Last := DL;
-
- -- Otherwise, allocate new one and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (SR.Last + 1 .. DL) := New_Item;
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Append;
-
- procedure Append
- (Source : in out Unbounded_String;
- New_Item : Character)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + 1;
- DR : Shared_String_Access;
-
- begin
- -- Try to reuse existing shared string
-
- if Can_Be_Reused (SR, SR.Last + 1) then
- SR.Data (SR.Last + 1) := New_Item;
- SR.Last := SR.Last + 1;
-
- -- Otherwise, allocate new one and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (DL) := New_Item;
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Append;
-
- -------------------
- -- Can_Be_Reused --
- -------------------
-
- function Can_Be_Reused
- (Item : not null Shared_String_Access;
- Length : Natural) return Boolean
- is
- begin
- return
- System.Atomic_Counters.Is_One (Item.Counter)
- and then Item.Max_Length >= Length
- and then Item.Max_Length <=
- Aligned_Max_Length (Length + Length / Growth_Factor);
- end Can_Be_Reused;
-
- -----------
- -- Count --
- -----------
-
- function Count
- (Source : Unbounded_String;
- Pattern : String;
- Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
- end Count;
-
- function Count
- (Source : Unbounded_String;
- Pattern : String;
- Mapping : Maps.Character_Mapping_Function) return Natural
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
- end Count;
-
- function Count
- (Source : Unbounded_String;
- Set : Maps.Character_Set) return Natural
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- return Search.Count (SR.Data (1 .. SR.Last), Set);
- end Count;
-
- ------------
- -- Delete --
- ------------
-
- function Delete
- (Source : Unbounded_String;
- From : Positive;
- Through : Natural) return Unbounded_String
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_String_Access;
-
- begin
- -- Empty slice is deleted, use the same shared string
-
- if From > Through then
- Reference (SR);
- DR := SR;
-
- -- Index is out of range
-
- elsif Through > SR.Last then
- raise Index_Error;
-
- -- Compute size of the result
-
- else
- DL := SR.Last - (Through - From + 1);
-
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
- DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
- DR.Last := DL;
- end if;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Delete;
-
- procedure Delete
- (Source : in out Unbounded_String;
- From : Positive;
- Through : Natural)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_String_Access;
-
- begin
- -- Nothing changed, return
-
- if From > Through then
- null;
-
- -- Through is outside of the range
-
- elsif Through > SR.Last then
- raise Index_Error;
-
- else
- DL := SR.Last - (Through - From + 1);
-
- -- Result is empty, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- Source.Reference := Empty_Shared_String'Access;
- Unreference (SR);
-
- -- Try to reuse existing shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
- DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end if;
- end Delete;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Source : Unbounded_String;
- Index : Positive) return Character
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- if Index <= SR.Last then
- return SR.Data (Index);
- else
- raise Index_Error;
- end if;
- end Element;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Object : in out Unbounded_String) is
- SR : constant not null Shared_String_Access := Object.Reference;
- begin
- if SR /= Null_Unbounded_String.Reference then
-
- -- The same controlled object can be finalized several times for
- -- some reason. As per 7.6.1(24) this should have no ill effect,
- -- so we need to add a guard for the case of finalizing the same
- -- object twice.
-
- -- We set the Object to the empty string so there will be no ill
- -- effects if a program references an already-finalized object.
-
- Object.Reference := Null_Unbounded_String.Reference;
- Reference (Object.Reference);
- Unreference (SR);
- end if;
- end Finalize;
-
- ----------------
- -- Find_Token --
- ----------------
-
- procedure Find_Token
- (Source : Unbounded_String;
- Set : Maps.Character_Set;
- From : Positive;
- Test : Strings.Membership;
- First : out Positive;
- Last : out Natural)
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- Search.Find_Token (SR.Data (From .. SR.Last), Set, Test, First, Last);
- end Find_Token;
-
- procedure Find_Token
- (Source : Unbounded_String;
- Set : Maps.Character_Set;
- Test : Strings.Membership;
- First : out Positive;
- Last : out Natural)
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last);
- end Find_Token;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (X : in out String_Access) is
- procedure Deallocate is
- new Ada.Unchecked_Deallocation (String, String_Access);
- begin
- Deallocate (X);
- end Free;
-
- ----------
- -- Head --
- ----------
-
- function Head
- (Source : Unbounded_String;
- Count : Natural;
- Pad : Character := Space) return Unbounded_String
- is
- SR : constant Shared_String_Access := Source.Reference;
- DR : Shared_String_Access;
-
- begin
- -- Result is empty, reuse shared empty string
-
- if Count = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Length of the string is the same as requested, reuse source shared
- -- string.
-
- elsif Count = SR.Last then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
-
- -- Length of the source string is more than requested, copy
- -- corresponding slice.
-
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (1 .. Count);
-
- -- Length of the source string is less than requested, copy all
- -- contents and fill others by Pad character.
-
- else
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
-
- for J in SR.Last + 1 .. Count loop
- DR.Data (J) := Pad;
- end loop;
- end if;
-
- DR.Last := Count;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Head;
-
- procedure Head
- (Source : in out Unbounded_String;
- Count : Natural;
- Pad : Character := Space)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DR : Shared_String_Access;
-
- begin
- -- Result is empty, reuse empty shared string
-
- if Count = 0 then
- Reference (Empty_Shared_String'Access);
- Source.Reference := Empty_Shared_String'Access;
- Unreference (SR);
-
- -- Result is same as source string, reuse source shared string
-
- elsif Count = SR.Last then
- null;
-
- -- Try to reuse existing shared string
-
- elsif Can_Be_Reused (SR, Count) then
- if Count > SR.Last then
- for J in SR.Last + 1 .. Count loop
- SR.Data (J) := Pad;
- end loop;
- end if;
-
- SR.Last := Count;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
-
- -- Length of the source string is greater than requested, copy
- -- corresponding slice.
-
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (1 .. Count);
-
- -- Length of the source string is less than requested, copy all
- -- existing data and fill remaining positions with Pad characters.
-
- else
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
-
- for J in SR.Last + 1 .. Count loop
- DR.Data (J) := Pad;
- end loop;
- end if;
-
- DR.Last := Count;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Head;
-
- -----------
- -- Index --
- -----------
-
- function Index
- (Source : Unbounded_String;
- Pattern : String;
- Going : Strings.Direction := Strings.Forward;
- Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_String;
- Pattern : String;
- Going : Direction := Forward;
- Mapping : Maps.Character_Mapping_Function) return Natural
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_String;
- Set : Maps.Character_Set;
- Test : Strings.Membership := Strings.Inside;
- Going : Strings.Direction := Strings.Forward) return Natural
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- return Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going);
- end Index;
-
- function Index
- (Source : Unbounded_String;
- Pattern : String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- return Search.Index
- (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_String;
- Pattern : String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Maps.Character_Mapping_Function) return Natural
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- return Search.Index
- (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_String;
- Set : Maps.Character_Set;
- From : Positive;
- Test : Membership := Inside;
- Going : Direction := Forward) return Natural
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- return Search.Index (SR.Data (1 .. SR.Last), Set, From, Test, Going);
- end Index;
-
- ---------------------
- -- Index_Non_Blank --
- ---------------------
-
- function Index_Non_Blank
- (Source : Unbounded_String;
- Going : Strings.Direction := Strings.Forward) return Natural
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going);
- end Index_Non_Blank;
-
- function Index_Non_Blank
- (Source : Unbounded_String;
- From : Positive;
- Going : Direction := Forward) return Natural
- is
- SR : constant Shared_String_Access := Source.Reference;
- begin
- return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), From, Going);
- end Index_Non_Blank;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Object : in out Unbounded_String) is
- begin
- Reference (Object.Reference);
- end Initialize;
-
- ------------
- -- Insert --
- ------------
-
- function Insert
- (Source : Unbounded_String;
- Before : Positive;
- New_Item : String) return Unbounded_String
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + New_Item'Length;
- DR : Shared_String_Access;
-
- begin
- -- Check index first
-
- if Before > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Result is empty, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Inserted string is empty, reuse source shared string
-
- elsif New_Item'Length = 0 then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
- DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
- DR.Data (Before + New_Item'Length .. DL) :=
- SR.Data (Before .. SR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Insert;
-
- procedure Insert
- (Source : in out Unbounded_String;
- Before : Positive;
- New_Item : String)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + New_Item'Length;
- DR : Shared_String_Access;
-
- begin
- -- Check bounds
-
- if Before > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- Source.Reference := Empty_Shared_String'Access;
- Unreference (SR);
-
- -- Inserted string is empty, nothing to do
-
- elsif New_Item'Length = 0 then
- null;
-
- -- Try to reuse existing shared string first
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (Before + New_Item'Length .. DL) :=
- SR.Data (Before .. SR.Last);
- SR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
- DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
- DR.Data (Before + New_Item'Length .. DL) :=
- SR.Data (Before .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Insert;
-
- ------------
- -- Length --
- ------------
-
- function Length (Source : Unbounded_String) return Natural is
- begin
- return Source.Reference.Last;
- end Length;
-
- ---------------
- -- Overwrite --
- ---------------
-
- function Overwrite
- (Source : Unbounded_String;
- Position : Positive;
- New_Item : String) return Unbounded_String
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_String_Access;
-
- begin
- -- Check bounds
-
- if Position > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Result is same as source string, reuse source shared string
-
- elsif New_Item'Length = 0 then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
- DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
- DR.Data (Position + New_Item'Length .. DL) :=
- SR.Data (Position + New_Item'Length .. SR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Overwrite;
-
- procedure Overwrite
- (Source : in out Unbounded_String;
- Position : Positive;
- New_Item : String)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_String_Access;
-
- begin
- -- Bounds check
-
- if Position > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- Source.Reference := Empty_Shared_String'Access;
- Unreference (SR);
-
- -- String unchanged, nothing to do
-
- elsif New_Item'Length = 0 then
- null;
-
- -- Try to reuse existing shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
- SR.Last := DL;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
- DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
- DR.Data (Position + New_Item'Length .. DL) :=
- SR.Data (Position + New_Item'Length .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Overwrite;
-
- ---------------
- -- Reference --
- ---------------
-
- procedure Reference (Item : not null Shared_String_Access) is
- begin
- System.Atomic_Counters.Increment (Item.Counter);
- end Reference;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Source : in out Unbounded_String;
- Index : Positive;
- By : Character)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DR : Shared_String_Access;
-
- begin
- -- Bounds check
-
- if Index <= SR.Last then
-
- -- Try to reuse existing shared string
-
- if Can_Be_Reused (SR, SR.Last) then
- SR.Data (Index) := By;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (Index) := By;
- DR.Last := SR.Last;
- Source.Reference := DR;
- Unreference (SR);
- end if;
-
- else
- raise Index_Error;
- end if;
- end Replace_Element;
-
- -------------------
- -- Replace_Slice --
- -------------------
-
- function Replace_Slice
- (Source : Unbounded_String;
- Low : Positive;
- High : Natural;
- By : String) return Unbounded_String
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_String_Access;
-
- begin
- -- Check bounds
-
- if Low > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Do replace operation when removed slice is not empty
-
- if High >= Low then
- DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
- -- This is the number of characters remaining in the string after
- -- replacing the slice.
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
- DR.Data (Low .. Low + By'Length - 1) := By;
- DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
-
- -- Otherwise just insert string
-
- else
- return Insert (Source, Low, By);
- end if;
- end Replace_Slice;
-
- procedure Replace_Slice
- (Source : in out Unbounded_String;
- Low : Positive;
- High : Natural;
- By : String)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_String_Access;
-
- begin
- -- Bounds check
-
- if Low > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Do replace operation only when replaced slice is not empty
-
- if High >= Low then
- DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
- -- This is the number of characters remaining in the string after
- -- replacing the slice.
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_String'Access);
- Source.Reference := Empty_Shared_String'Access;
- Unreference (SR);
-
- -- Try to reuse existing shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
- SR.Data (Low .. Low + By'Length - 1) := By;
- SR.Last := DL;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
- DR.Data (Low .. Low + By'Length - 1) := By;
- DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
-
- -- Otherwise just insert item
-
- else
- Insert (Source, Low, By);
- end if;
- end Replace_Slice;
-
- --------------------------
- -- Set_Unbounded_String --
- --------------------------
-
- procedure Set_Unbounded_String
- (Target : out Unbounded_String;
- Source : String)
- is
- TR : constant Shared_String_Access := Target.Reference;
- DR : Shared_String_Access;
-
- begin
- -- In case of empty string, reuse empty shared string
-
- if Source'Length = 0 then
- Reference (Empty_Shared_String'Access);
- Target.Reference := Empty_Shared_String'Access;
-
- else
- -- Try to reuse existing shared string
-
- if Can_Be_Reused (TR, Source'Length) then
- Reference (TR);
- DR := TR;
-
- -- Otherwise allocate new shared string
-
- else
- DR := Allocate (Source'Length);
- Target.Reference := DR;
- end if;
-
- DR.Data (1 .. Source'Length) := Source;
- DR.Last := Source'Length;
- end if;
-
- Unreference (TR);
- end Set_Unbounded_String;
-
- -----------
- -- Slice --
- -----------
-
- function Slice
- (Source : Unbounded_String;
- Low : Positive;
- High : Natural) return String
- is
- SR : constant Shared_String_Access := Source.Reference;
-
- begin
- -- Note: test of High > Length is in accordance with AI95-00128
-
- if Low > SR.Last + 1 or else High > SR.Last then
- raise Index_Error;
-
- else
- return SR.Data (Low .. High);
- end if;
- end Slice;
-
- ----------
- -- Tail --
- ----------
-
- function Tail
- (Source : Unbounded_String;
- Count : Natural;
- Pad : Character := Space) return Unbounded_String
- is
- SR : constant Shared_String_Access := Source.Reference;
- DR : Shared_String_Access;
-
- begin
- -- For empty result reuse empty shared string
-
- if Count = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Result is whole source string, reuse source shared string
-
- elsif Count = SR.Last then
- Reference (SR);
- DR := SR;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
-
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
-
- else
- for J in 1 .. Count - SR.Last loop
- DR.Data (J) := Pad;
- end loop;
-
- DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
- end if;
-
- DR.Last := Count;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Tail;
-
- procedure Tail
- (Source : in out Unbounded_String;
- Count : Natural;
- Pad : Character := Space)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DR : Shared_String_Access;
-
- procedure Common
- (SR : Shared_String_Access;
- DR : Shared_String_Access;
- Count : Natural);
- -- Common code of tail computation. SR/DR can point to the same object
-
- ------------
- -- Common --
- ------------
-
- procedure Common
- (SR : Shared_String_Access;
- DR : Shared_String_Access;
- Count : Natural) is
- begin
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
-
- else
- DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
-
- for J in 1 .. Count - SR.Last loop
- DR.Data (J) := Pad;
- end loop;
- end if;
-
- DR.Last := Count;
- end Common;
-
- begin
- -- Result is empty string, reuse empty shared string
-
- if Count = 0 then
- Reference (Empty_Shared_String'Access);
- Source.Reference := Empty_Shared_String'Access;
- Unreference (SR);
-
- -- Length of the result is the same as length of the source string,
- -- reuse source shared string.
-
- elsif Count = SR.Last then
- null;
-
- -- Try to reuse existing shared string
-
- elsif Can_Be_Reused (SR, Count) then
- Common (SR, SR, Count);
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
- Common (SR, DR, Count);
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Tail;
-
- ---------------
- -- To_String --
- ---------------
-
- function To_String (Source : Unbounded_String) return String is
- begin
- return Source.Reference.Data (1 .. Source.Reference.Last);
- end To_String;
-
- -------------------------
- -- To_Unbounded_String --
- -------------------------
-
- function To_Unbounded_String (Source : String) return Unbounded_String is
- DR : Shared_String_Access;
-
- begin
- if Source'Length = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- else
- DR := Allocate (Source'Length);
- DR.Data (1 .. Source'Length) := Source;
- DR.Last := Source'Length;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end To_Unbounded_String;
-
- function To_Unbounded_String (Length : Natural) return Unbounded_String is
- DR : Shared_String_Access;
-
- begin
- if Length = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- else
- DR := Allocate (Length);
- DR.Last := Length;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end To_Unbounded_String;
-
- ---------------
- -- Translate --
- ---------------
-
- function Translate
- (Source : Unbounded_String;
- Mapping : Maps.Character_Mapping) return Unbounded_String
- is
- SR : constant Shared_String_Access := Source.Reference;
- DR : Shared_String_Access;
-
- begin
- -- Nothing to translate, reuse empty shared string
-
- if SR.Last = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Value (Mapping, SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Translate;
-
- procedure Translate
- (Source : in out Unbounded_String;
- Mapping : Maps.Character_Mapping)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DR : Shared_String_Access;
-
- begin
- -- Nothing to translate
-
- if SR.Last = 0 then
- null;
-
- -- Try to reuse shared string
-
- elsif Can_Be_Reused (SR, SR.Last) then
- for J in 1 .. SR.Last loop
- SR.Data (J) := Value (Mapping, SR.Data (J));
- end loop;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Value (Mapping, SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Translate;
-
- function Translate
- (Source : Unbounded_String;
- Mapping : Maps.Character_Mapping_Function) return Unbounded_String
- is
- SR : constant Shared_String_Access := Source.Reference;
- DR : Shared_String_Access;
-
- begin
- -- Nothing to translate, reuse empty shared string
-
- if SR.Last = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Mapping.all (SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- end if;
-
- return (AF.Controlled with Reference => DR);
-
- exception
- when others =>
- Unreference (DR);
-
- raise;
- end Translate;
-
- procedure Translate
- (Source : in out Unbounded_String;
- Mapping : Maps.Character_Mapping_Function)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DR : Shared_String_Access;
-
- begin
- -- Nothing to translate
-
- if SR.Last = 0 then
- null;
-
- -- Try to reuse shared string
-
- elsif Can_Be_Reused (SR, SR.Last) then
- for J in 1 .. SR.Last loop
- SR.Data (J) := Mapping.all (SR.Data (J));
- end loop;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Mapping.all (SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- Source.Reference := DR;
- Unreference (SR);
- end if;
-
- exception
- when others =>
- if DR /= null then
- Unreference (DR);
- end if;
-
- raise;
- end Translate;
-
- ----------
- -- Trim --
- ----------
-
- function Trim
- (Source : Unbounded_String;
- Side : Trim_End) return Unbounded_String
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index_Non_Blank (Source, Forward);
-
- -- All blanks, reuse empty shared string
-
- if Low = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- else
- case Side is
- when Left =>
- High := SR.Last;
- DL := SR.Last - Low + 1;
-
- when Right =>
- Low := 1;
- High := Index_Non_Blank (Source, Backward);
- DL := High;
-
- when Both =>
- High := Index_Non_Blank (Source, Backward);
- DL := High - Low + 1;
- end case;
-
- -- Length of the result is the same as length of the source string,
- -- reuse source shared string.
-
- if DL = SR.Last then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- end if;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Trim;
-
- procedure Trim
- (Source : in out Unbounded_String;
- Side : Trim_End)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index_Non_Blank (Source, Forward);
-
- -- All blanks, reuse empty shared string
-
- if Low = 0 then
- Reference (Empty_Shared_String'Access);
- Source.Reference := Empty_Shared_String'Access;
- Unreference (SR);
-
- else
- case Side is
- when Left =>
- High := SR.Last;
- DL := SR.Last - Low + 1;
-
- when Right =>
- Low := 1;
- High := Index_Non_Blank (Source, Backward);
- DL := High;
-
- when Both =>
- High := Index_Non_Blank (Source, Backward);
- DL := High - Low + 1;
- end case;
-
- -- Length of the result is the same as length of the source string,
- -- nothing to do.
-
- if DL = SR.Last then
- null;
-
- -- Try to reuse existing shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (1 .. DL) := SR.Data (Low .. High);
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end if;
- end Trim;
-
- function Trim
- (Source : Unbounded_String;
- Left : Maps.Character_Set;
- Right : Maps.Character_Set) return Unbounded_String
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index (Source, Left, Outside, Forward);
-
- -- Source includes only characters from Left set, reuse empty shared
- -- string.
-
- if Low = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- else
- High := Index (Source, Right, Outside, Backward);
- DL := Integer'Max (0, High - Low + 1);
-
- -- Source includes only characters from Right set or result string
- -- is empty, reuse empty shared string.
-
- if High = 0 or else DL = 0 then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- end if;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Trim;
-
- procedure Trim
- (Source : in out Unbounded_String;
- Left : Maps.Character_Set;
- Right : Maps.Character_Set)
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index (Source, Left, Outside, Forward);
-
- -- Source includes only characters from Left set, reuse empty shared
- -- string.
-
- if Low = 0 then
- Reference (Empty_Shared_String'Access);
- Source.Reference := Empty_Shared_String'Access;
- Unreference (SR);
-
- else
- High := Index (Source, Right, Outside, Backward);
- DL := Integer'Max (0, High - Low + 1);
-
- -- Source includes only characters from Right set or result string
- -- is empty, reuse empty shared string.
-
- if High = 0 or else DL = 0 then
- Reference (Empty_Shared_String'Access);
- Source.Reference := Empty_Shared_String'Access;
- Unreference (SR);
-
- -- Try to reuse existing shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (1 .. DL) := SR.Data (Low .. High);
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end if;
- end Trim;
-
- ---------------------
- -- Unbounded_Slice --
- ---------------------
-
- function Unbounded_Slice
- (Source : Unbounded_String;
- Low : Positive;
- High : Natural) return Unbounded_String
- is
- SR : constant Shared_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_String_Access;
-
- begin
- -- Check bounds
-
- if Low > SR.Last + 1 or else High > SR.Last then
- raise Index_Error;
-
- -- Result is empty slice, reuse empty shared string
-
- elsif Low > High then
- Reference (Empty_Shared_String'Access);
- DR := Empty_Shared_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DL := High - Low + 1;
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Unbounded_Slice;
-
- procedure Unbounded_Slice
- (Source : Unbounded_String;
- Target : out Unbounded_String;
- Low : Positive;
- High : Natural)
- is
- SR : constant Shared_String_Access := Source.Reference;
- TR : constant Shared_String_Access := Target.Reference;
- DL : Natural;
- DR : Shared_String_Access;
-
- begin
- -- Check bounds
-
- if Low > SR.Last + 1 or else High > SR.Last then
- raise Index_Error;
-
- -- Result is empty slice, reuse empty shared string
-
- elsif Low > High then
- Reference (Empty_Shared_String'Access);
- Target.Reference := Empty_Shared_String'Access;
- Unreference (TR);
-
- else
- DL := High - Low + 1;
-
- -- Try to reuse existing shared string
-
- if Can_Be_Reused (TR, DL) then
- TR.Data (1 .. DL) := SR.Data (Low .. High);
- TR.Last := DL;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- Target.Reference := DR;
- Unreference (TR);
- end if;
- end if;
- end Unbounded_Slice;
-
- -----------------
- -- Unreference --
- -----------------
-
- procedure Unreference (Item : not null Shared_String_Access) is
-
- procedure Free is
- new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access);
-
- Aux : Shared_String_Access := Item;
-
- begin
- if System.Atomic_Counters.Decrement (Aux.Counter) then
-
- -- Reference counter of Empty_Shared_String should never reach
- -- zero. We check here in case it wraps around.
-
- if Aux /= Empty_Shared_String'Access then
- Free (Aux);
- end if;
- end if;
- end Unreference;
-
-end Ada.Strings.Unbounded;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S T R I N G S . U N B O U N D E D --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides an implementation of Ada.Strings.Unbounded that uses
--- reference counts to implement copy on modification (rather than copy on
--- assignment). This is significantly more efficient on many targets.
-
--- This version is supported on:
--- - all Alpha platforms
--- - all ia64 platforms
--- - all PowerPC platforms
--- - all SPARC V9 platforms
--- - all x86 platforms
--- - all x86_64 platforms
-
- -- This package uses several techniques to increase speed:
-
- -- - Implicit sharing or copy-on-write. An Unbounded_String contains only
- -- the reference to the data which is shared between several instances.
- -- The shared data is reallocated only when its value is changed and
- -- the object mutation can't be used or it is inefficient to use it.
-
- -- - Object mutation. Shared data object can be reused without memory
- -- reallocation when all of the following requirements are met:
- -- - the shared data object is no longer used by anyone else;
- -- - the size is sufficient to store the new value;
- -- - the gap after reuse is less than a defined threshold.
-
- -- - Memory preallocation. Most of used memory allocation algorithms
- -- align allocated segments on the some boundary, thus some amount of
- -- additional memory can be preallocated without any impact. Such
- -- preallocated memory can used later by Append/Insert operations
- -- without reallocation.
-
- -- Reference counting uses GCC builtin atomic operations, which allows safe
- -- sharing of internal data between Ada tasks. Nevertheless, this does not
- -- make objects of Unbounded_String thread-safe: an instance cannot be
- -- accessed by several tasks simultaneously.
-
-with Ada.Strings.Maps;
-private with Ada.Finalization;
-private with System.Atomic_Counters;
-
-package Ada.Strings.Unbounded is
- pragma Preelaborate;
-
- type Unbounded_String is private;
- pragma Preelaborable_Initialization (Unbounded_String);
-
- Null_Unbounded_String : constant Unbounded_String;
-
- function Length (Source : Unbounded_String) return Natural;
-
- type String_Access is access all String;
-
- procedure Free (X : in out String_Access);
-
- --------------------------------------------------------
- -- Conversion, Concatenation, and Selection Functions --
- --------------------------------------------------------
-
- function To_Unbounded_String
- (Source : String) return Unbounded_String;
-
- function To_Unbounded_String
- (Length : Natural) return Unbounded_String;
-
- function To_String (Source : Unbounded_String) return String;
-
- procedure Set_Unbounded_String
- (Target : out Unbounded_String;
- Source : String);
- pragma Ada_05 (Set_Unbounded_String);
-
- procedure Append
- (Source : in out Unbounded_String;
- New_Item : Unbounded_String);
-
- procedure Append
- (Source : in out Unbounded_String;
- New_Item : String);
-
- procedure Append
- (Source : in out Unbounded_String;
- New_Item : Character);
-
- function "&"
- (Left : Unbounded_String;
- Right : Unbounded_String) return Unbounded_String;
-
- function "&"
- (Left : Unbounded_String;
- Right : String) return Unbounded_String;
-
- function "&"
- (Left : String;
- Right : Unbounded_String) return Unbounded_String;
-
- function "&"
- (Left : Unbounded_String;
- Right : Character) return Unbounded_String;
-
- function "&"
- (Left : Character;
- Right : Unbounded_String) return Unbounded_String;
-
- function Element
- (Source : Unbounded_String;
- Index : Positive) return Character;
-
- procedure Replace_Element
- (Source : in out Unbounded_String;
- Index : Positive;
- By : Character);
-
- function Slice
- (Source : Unbounded_String;
- Low : Positive;
- High : Natural) return String;
-
- function Unbounded_Slice
- (Source : Unbounded_String;
- Low : Positive;
- High : Natural) return Unbounded_String;
- pragma Ada_05 (Unbounded_Slice);
-
- procedure Unbounded_Slice
- (Source : Unbounded_String;
- Target : out Unbounded_String;
- Low : Positive;
- High : Natural);
- pragma Ada_05 (Unbounded_Slice);
-
- function "="
- (Left : Unbounded_String;
- Right : Unbounded_String) return Boolean;
-
- function "="
- (Left : Unbounded_String;
- Right : String) return Boolean;
-
- function "="
- (Left : String;
- Right : Unbounded_String) return Boolean;
-
- function "<"
- (Left : Unbounded_String;
- Right : Unbounded_String) return Boolean;
-
- function "<"
- (Left : Unbounded_String;
- Right : String) return Boolean;
-
- function "<"
- (Left : String;
- Right : Unbounded_String) return Boolean;
-
- function "<="
- (Left : Unbounded_String;
- Right : Unbounded_String) return Boolean;
-
- function "<="
- (Left : Unbounded_String;
- Right : String) return Boolean;
-
- function "<="
- (Left : String;
- Right : Unbounded_String) return Boolean;
-
- function ">"
- (Left : Unbounded_String;
- Right : Unbounded_String) return Boolean;
-
- function ">"
- (Left : Unbounded_String;
- Right : String) return Boolean;
-
- function ">"
- (Left : String;
- Right : Unbounded_String) return Boolean;
-
- function ">="
- (Left : Unbounded_String;
- Right : Unbounded_String) return Boolean;
-
- function ">="
- (Left : Unbounded_String;
- Right : String) return Boolean;
-
- function ">="
- (Left : String;
- Right : Unbounded_String) return Boolean;
-
- ------------------------
- -- Search Subprograms --
- ------------------------
-
- function Index
- (Source : Unbounded_String;
- Pattern : String;
- Going : Direction := Forward;
- Mapping : Maps.Character_Mapping := Maps.Identity) return Natural;
-
- function Index
- (Source : Unbounded_String;
- Pattern : String;
- Going : Direction := Forward;
- Mapping : Maps.Character_Mapping_Function) return Natural;
-
- function Index
- (Source : Unbounded_String;
- Set : Maps.Character_Set;
- Test : Membership := Inside;
- Going : Direction := Forward) return Natural;
-
- function Index
- (Source : Unbounded_String;
- Pattern : String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Maps.Character_Mapping := Maps.Identity) return Natural;
- pragma Ada_05 (Index);
-
- function Index
- (Source : Unbounded_String;
- Pattern : String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Maps.Character_Mapping_Function) return Natural;
- pragma Ada_05 (Index);
-
- function Index
- (Source : Unbounded_String;
- Set : Maps.Character_Set;
- From : Positive;
- Test : Membership := Inside;
- Going : Direction := Forward) return Natural;
- pragma Ada_05 (Index);
-
- function Index_Non_Blank
- (Source : Unbounded_String;
- Going : Direction := Forward) return Natural;
-
- function Index_Non_Blank
- (Source : Unbounded_String;
- From : Positive;
- Going : Direction := Forward) return Natural;
- pragma Ada_05 (Index_Non_Blank);
-
- function Count
- (Source : Unbounded_String;
- Pattern : String;
- Mapping : Maps.Character_Mapping := Maps.Identity) return Natural;
-
- function Count
- (Source : Unbounded_String;
- Pattern : String;
- Mapping : Maps.Character_Mapping_Function) return Natural;
-
- function Count
- (Source : Unbounded_String;
- Set : Maps.Character_Set) return Natural;
-
- procedure Find_Token
- (Source : Unbounded_String;
- Set : Maps.Character_Set;
- From : Positive;
- Test : Membership;
- First : out Positive;
- Last : out Natural);
- pragma Ada_2012 (Find_Token);
-
- procedure Find_Token
- (Source : Unbounded_String;
- Set : Maps.Character_Set;
- Test : Membership;
- First : out Positive;
- Last : out Natural);
-
- ------------------------------------
- -- String Translation Subprograms --
- ------------------------------------
-
- function Translate
- (Source : Unbounded_String;
- Mapping : Maps.Character_Mapping) return Unbounded_String;
-
- procedure Translate
- (Source : in out Unbounded_String;
- Mapping : Maps.Character_Mapping);
-
- function Translate
- (Source : Unbounded_String;
- Mapping : Maps.Character_Mapping_Function) return Unbounded_String;
-
- procedure Translate
- (Source : in out Unbounded_String;
- Mapping : Maps.Character_Mapping_Function);
-
- ---------------------------------------
- -- String Transformation Subprograms --
- ---------------------------------------
-
- function Replace_Slice
- (Source : Unbounded_String;
- Low : Positive;
- High : Natural;
- By : String) return Unbounded_String;
-
- procedure Replace_Slice
- (Source : in out Unbounded_String;
- Low : Positive;
- High : Natural;
- By : String);
-
- function Insert
- (Source : Unbounded_String;
- Before : Positive;
- New_Item : String) return Unbounded_String;
-
- procedure Insert
- (Source : in out Unbounded_String;
- Before : Positive;
- New_Item : String);
-
- function Overwrite
- (Source : Unbounded_String;
- Position : Positive;
- New_Item : String) return Unbounded_String;
-
- procedure Overwrite
- (Source : in out Unbounded_String;
- Position : Positive;
- New_Item : String);
-
- function Delete
- (Source : Unbounded_String;
- From : Positive;
- Through : Natural) return Unbounded_String;
-
- procedure Delete
- (Source : in out Unbounded_String;
- From : Positive;
- Through : Natural);
-
- function Trim
- (Source : Unbounded_String;
- Side : Trim_End) return Unbounded_String;
-
- procedure Trim
- (Source : in out Unbounded_String;
- Side : Trim_End);
-
- function Trim
- (Source : Unbounded_String;
- Left : Maps.Character_Set;
- Right : Maps.Character_Set) return Unbounded_String;
-
- procedure Trim
- (Source : in out Unbounded_String;
- Left : Maps.Character_Set;
- Right : Maps.Character_Set);
-
- function Head
- (Source : Unbounded_String;
- Count : Natural;
- Pad : Character := Space) return Unbounded_String;
-
- procedure Head
- (Source : in out Unbounded_String;
- Count : Natural;
- Pad : Character := Space);
-
- function Tail
- (Source : Unbounded_String;
- Count : Natural;
- Pad : Character := Space) return Unbounded_String;
-
- procedure Tail
- (Source : in out Unbounded_String;
- Count : Natural;
- Pad : Character := Space);
-
- function "*"
- (Left : Natural;
- Right : Character) return Unbounded_String;
-
- function "*"
- (Left : Natural;
- Right : String) return Unbounded_String;
-
- function "*"
- (Left : Natural;
- Right : Unbounded_String) return Unbounded_String;
-
-private
- pragma Inline (Length);
-
- package AF renames Ada.Finalization;
-
- type Shared_String (Max_Length : Natural) is limited record
- Counter : System.Atomic_Counters.Atomic_Counter;
- -- Reference counter
-
- Last : Natural := 0;
- Data : String (1 .. Max_Length);
- -- Last is the index of last significant element of the Data. All
- -- elements with larger indexes are currently insignificant.
- end record;
-
- type Shared_String_Access is access all Shared_String;
-
- procedure Reference (Item : not null Shared_String_Access);
- -- Increment reference counter
-
- procedure Unreference (Item : not null Shared_String_Access);
- -- Decrement reference counter, deallocate Item when counter goes to zero
-
- function Can_Be_Reused
- (Item : not null Shared_String_Access;
- Length : Natural) return Boolean;
- -- Returns True if Shared_String can be reused. There are two criteria when
- -- Shared_String can be reused: its reference counter must be one (thus
- -- Shared_String is owned exclusively) and its size is sufficient to
- -- store string with specified length effectively.
-
- function Allocate
- (Max_Length : Natural) return not null Shared_String_Access;
- -- Allocates new Shared_String with at least specified maximum length.
- -- Actual maximum length of the allocated Shared_String can be slightly
- -- greater. Returns reference to Empty_Shared_String when requested length
- -- is zero.
-
- Empty_Shared_String : aliased Shared_String (0);
-
- function To_Unbounded (S : String) return Unbounded_String
- renames To_Unbounded_String;
- -- This renames are here only to be used in the pragma Stream_Convert
-
- type Unbounded_String is new AF.Controlled with record
- Reference : not null Shared_String_Access := Empty_Shared_String'Access;
- end record;
-
- pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String);
- -- Provide stream routines without dragging in Ada.Streams
-
- pragma Finalize_Storage_Only (Unbounded_String);
- -- Finalization is required only for freeing storage
-
- overriding procedure Initialize (Object : in out Unbounded_String);
- overriding procedure Adjust (Object : in out Unbounded_String);
- overriding procedure Finalize (Object : in out Unbounded_String);
-
- Null_Unbounded_String : constant Unbounded_String :=
- (AF.Controlled with
- Reference => Empty_Shared_String'Access);
-
-end Ada.Strings.Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . U N B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Search;
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Strings.Unbounded is
+
+ use Ada.Strings.Maps;
+
+ Growth_Factor : constant := 32;
+ -- The growth factor controls how much extra space is allocated when
+ -- we have to increase the size of an allocated unbounded string. By
+ -- allocating extra space, we avoid the need to reallocate on every
+ -- append, particularly important when a string is built up by repeated
+ -- append operations of small pieces. This is expressed as a factor so
+ -- 32 means add 1/32 of the length of the string as growth space.
+
+ Min_Mul_Alloc : constant := Standard'Maximum_Alignment;
+ -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes
+ -- no memory loss as most (all?) malloc implementations are obliged to
+ -- align the returned memory on the maximum alignment as malloc does not
+ -- know the target alignment.
+
+ function Aligned_Max_Length (Max_Length : Natural) return Natural;
+ -- Returns recommended length of the shared string which is greater or
+ -- equal to specified length. Calculation take in sense alignment of the
+ -- allocated memory segments to use memory effectively by Append/Insert/etc
+ -- operations.
+
+ ---------
+ -- "&" --
+ ---------
+
+ function "&"
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Unbounded_String
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ RR : constant Shared_String_Access := Right.Reference;
+ DL : constant Natural := LR.Last + RR.Last;
+ DR : Shared_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Left string is empty, return Right string
+
+ elsif LR.Last = 0 then
+ Reference (RR);
+ DR := RR;
+
+ -- Right string is empty, return Left string
+
+ elsif RR.Last = 0 then
+ Reference (LR);
+ DR := LR;
+
+ -- Otherwise, allocate new shared string and fill data
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
+ DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : Unbounded_String;
+ Right : String) return Unbounded_String
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ DL : constant Natural := LR.Last + Right'Length;
+ DR : Shared_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Right is an empty string, return Left string
+
+ elsif Right'Length = 0 then
+ Reference (LR);
+ DR := LR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
+ DR.Data (LR.Last + 1 .. DL) := Right;
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : String;
+ Right : Unbounded_String) return Unbounded_String
+ is
+ RR : constant Shared_String_Access := Right.Reference;
+ DL : constant Natural := Left'Length + RR.Last;
+ DR : Shared_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared one
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Left is empty string, return Right string
+
+ elsif Left'Length = 0 then
+ Reference (RR);
+ DR := RR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Left'Length) := Left;
+ DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : Unbounded_String;
+ Right : Character) return Unbounded_String
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ DL : constant Natural := LR.Last + 1;
+ DR : Shared_String_Access;
+
+ begin
+ DR := Allocate (DL);
+ DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
+ DR.Data (DL) := Right;
+ DR.Last := DL;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : Character;
+ Right : Unbounded_String) return Unbounded_String
+ is
+ RR : constant Shared_String_Access := Right.Reference;
+ DL : constant Natural := 1 + RR.Last;
+ DR : Shared_String_Access;
+
+ begin
+ DR := Allocate (DL);
+ DR.Data (1) := Left;
+ DR.Data (2 .. DL) := RR.Data (1 .. RR.Last);
+ DR.Last := DL;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : Natural;
+ Right : Character) return Unbounded_String
+ is
+ DR : Shared_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if Left = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (Left);
+
+ for J in 1 .. Left loop
+ DR.Data (J) := Right;
+ end loop;
+
+ DR.Last := Left;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : String) return Unbounded_String
+ is
+ DL : constant Natural := Left * Right'Length;
+ DR : Shared_String_Access;
+ K : Positive;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ K := 1;
+
+ for J in 1 .. Left loop
+ DR.Data (K .. K + Right'Length - 1) := Right;
+ K := K + Right'Length;
+ end loop;
+
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Unbounded_String) return Unbounded_String
+ is
+ RR : constant Shared_String_Access := Right.Reference;
+ DL : constant Natural := Left * RR.Last;
+ DR : Shared_String_Access;
+ K : Positive;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Coefficient is one, just return string itself
+
+ elsif Left = 1 then
+ Reference (RR);
+ DR := RR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ K := 1;
+
+ for J in 1 .. Left loop
+ DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last);
+ K := K + RR.Last;
+ end loop;
+
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "*";
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<"
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Boolean
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ RR : constant Shared_String_Access := Right.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last);
+ end "<";
+
+ function "<"
+ (Left : Unbounded_String;
+ Right : String) return Boolean
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) < Right;
+ end "<";
+
+ function "<"
+ (Left : String;
+ Right : Unbounded_String) return Boolean
+ is
+ RR : constant Shared_String_Access := Right.Reference;
+ begin
+ return Left < RR.Data (1 .. RR.Last);
+ end "<";
+
+ ----------
+ -- "<=" --
+ ----------
+
+ function "<="
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Boolean
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ RR : constant Shared_String_Access := Right.Reference;
+
+ begin
+ -- LR = RR means two strings shares shared string, thus they are equal
+
+ return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last);
+ end "<=";
+
+ function "<="
+ (Left : Unbounded_String;
+ Right : String) return Boolean
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) <= Right;
+ end "<=";
+
+ function "<="
+ (Left : String;
+ Right : Unbounded_String) return Boolean
+ is
+ RR : constant Shared_String_Access := Right.Reference;
+ begin
+ return Left <= RR.Data (1 .. RR.Last);
+ end "<=";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "="
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Boolean
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ RR : constant Shared_String_Access := Right.Reference;
+
+ begin
+ return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last);
+ -- LR = RR means two strings shares shared string, thus they are equal
+ end "=";
+
+ function "="
+ (Left : Unbounded_String;
+ Right : String) return Boolean
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) = Right;
+ end "=";
+
+ function "="
+ (Left : String;
+ Right : Unbounded_String) return Boolean
+ is
+ RR : constant Shared_String_Access := Right.Reference;
+ begin
+ return Left = RR.Data (1 .. RR.Last);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">"
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Boolean
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ RR : constant Shared_String_Access := Right.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last);
+ end ">";
+
+ function ">"
+ (Left : Unbounded_String;
+ Right : String) return Boolean
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) > Right;
+ end ">";
+
+ function ">"
+ (Left : String;
+ Right : Unbounded_String) return Boolean
+ is
+ RR : constant Shared_String_Access := Right.Reference;
+ begin
+ return Left > RR.Data (1 .. RR.Last);
+ end ">";
+
+ ----------
+ -- ">=" --
+ ----------
+
+ function ">="
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Boolean
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ RR : constant Shared_String_Access := Right.Reference;
+
+ begin
+ -- LR = RR means two strings shares shared string, thus they are equal
+
+ return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last);
+ end ">=";
+
+ function ">="
+ (Left : Unbounded_String;
+ Right : String) return Boolean
+ is
+ LR : constant Shared_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) >= Right;
+ end ">=";
+
+ function ">="
+ (Left : String;
+ Right : Unbounded_String) return Boolean
+ is
+ RR : constant Shared_String_Access := Right.Reference;
+ begin
+ return Left >= RR.Data (1 .. RR.Last);
+ end ">=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Object : in out Unbounded_String) is
+ begin
+ Reference (Object.Reference);
+ end Adjust;
+
+ ------------------------
+ -- Aligned_Max_Length --
+ ------------------------
+
+ function Aligned_Max_Length (Max_Length : Natural) return Natural is
+ Static_Size : constant Natural :=
+ Empty_Shared_String'Size / Standard'Storage_Unit;
+ -- Total size of all static components
+
+ begin
+ return
+ ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc
+ - Static_Size;
+ end Aligned_Max_Length;
+
+ --------------
+ -- Allocate --
+ --------------
+
+ function Allocate
+ (Max_Length : Natural) return not null Shared_String_Access
+ is
+ begin
+ -- Empty string requested, return shared empty string
+
+ if Max_Length = 0 then
+ Reference (Empty_Shared_String'Access);
+ return Empty_Shared_String'Access;
+
+ -- Otherwise, allocate requested space (and probably some more room)
+
+ else
+ return new Shared_String (Aligned_Max_Length (Max_Length));
+ end if;
+ end Allocate;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : Unbounded_String)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ NR : constant Shared_String_Access := New_Item.Reference;
+ DL : constant Natural := SR.Last + NR.Last;
+ DR : Shared_String_Access;
+
+ begin
+ -- Source is an empty string, reuse New_Item data
+
+ if SR.Last = 0 then
+ Reference (NR);
+ Source.Reference := NR;
+ Unreference (SR);
+
+ -- New_Item is empty string, nothing to do
+
+ elsif NR.Last = 0 then
+ null;
+
+ -- Try to reuse existing shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new one and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : String)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + New_Item'Length;
+ DR : Shared_String_Access;
+
+ begin
+ -- New_Item is an empty string, nothing to do
+
+ if New_Item'Length = 0 then
+ null;
+
+ -- Try to reuse existing shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (SR.Last + 1 .. DL) := New_Item;
+ SR.Last := DL;
+
+ -- Otherwise, allocate new one and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (SR.Last + 1 .. DL) := New_Item;
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : Character)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + 1;
+ DR : Shared_String_Access;
+
+ begin
+ -- Try to reuse existing shared string
+
+ if Can_Be_Reused (SR, SR.Last + 1) then
+ SR.Data (SR.Last + 1) := New_Item;
+ SR.Last := SR.Last + 1;
+
+ -- Otherwise, allocate new one and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (DL) := New_Item;
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Append;
+
+ -------------------
+ -- Can_Be_Reused --
+ -------------------
+
+ function Can_Be_Reused
+ (Item : not null Shared_String_Access;
+ Length : Natural) return Boolean
+ is
+ begin
+ return
+ System.Atomic_Counters.Is_One (Item.Counter)
+ and then Item.Max_Length >= Length
+ and then Item.Max_Length <=
+ Aligned_Max_Length (Length + Length / Growth_Factor);
+ end Can_Be_Reused;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : Unbounded_String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : Unbounded_String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping_Function) return Natural
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set) return Natural
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ return Search.Count (SR.Data (1 .. SR.Last), Set);
+ end Count;
+
+ ------------
+ -- Delete --
+ ------------
+
+ function Delete
+ (Source : Unbounded_String;
+ From : Positive;
+ Through : Natural) return Unbounded_String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+
+ begin
+ -- Empty slice is deleted, use the same shared string
+
+ if From > Through then
+ Reference (SR);
+ DR := SR;
+
+ -- Index is out of range
+
+ elsif Through > SR.Last then
+ raise Index_Error;
+
+ -- Compute size of the result
+
+ else
+ DL := SR.Last - (Through - From + 1);
+
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
+ DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
+ DR.Last := DL;
+ end if;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Delete;
+
+ procedure Delete
+ (Source : in out Unbounded_String;
+ From : Positive;
+ Through : Natural)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+
+ begin
+ -- Nothing changed, return
+
+ if From > Through then
+ null;
+
+ -- Through is outside of the range
+
+ elsif Through > SR.Last then
+ raise Index_Error;
+
+ else
+ DL := SR.Last - (Through - From + 1);
+
+ -- Result is empty, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ Source.Reference := Empty_Shared_String'Access;
+ Unreference (SR);
+
+ -- Try to reuse existing shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
+ DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end if;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element
+ (Source : Unbounded_String;
+ Index : Positive) return Character
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ if Index <= SR.Last then
+ return SR.Data (Index);
+ else
+ raise Index_Error;
+ end if;
+ end Element;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Unbounded_String) is
+ SR : constant not null Shared_String_Access := Object.Reference;
+ begin
+ if SR /= Null_Unbounded_String.Reference then
+
+ -- The same controlled object can be finalized several times for
+ -- some reason. As per 7.6.1(24) this should have no ill effect,
+ -- so we need to add a guard for the case of finalizing the same
+ -- object twice.
+
+ -- We set the Object to the empty string so there will be no ill
+ -- effects if a program references an already-finalized object.
+
+ Object.Reference := Null_Unbounded_String.Reference;
+ Reference (Object.Reference);
+ Unreference (SR);
+ end if;
+ end Finalize;
+
+ ----------------
+ -- Find_Token --
+ ----------------
+
+ procedure Find_Token
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set;
+ From : Positive;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ Search.Find_Token (SR.Data (From .. SR.Last), Set, Test, First, Last);
+ end Find_Token;
+
+ procedure Find_Token
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last);
+ end Find_Token;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out String_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (String, String_Access);
+ begin
+ Deallocate (X);
+ end Free;
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head
+ (Source : Unbounded_String;
+ Count : Natural;
+ Pad : Character := Space) return Unbounded_String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DR : Shared_String_Access;
+
+ begin
+ -- Result is empty, reuse shared empty string
+
+ if Count = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Length of the string is the same as requested, reuse source shared
+ -- string.
+
+ elsif Count = SR.Last then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+
+ -- Length of the source string is more than requested, copy
+ -- corresponding slice.
+
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (1 .. Count);
+
+ -- Length of the source string is less than requested, copy all
+ -- contents and fill others by Pad character.
+
+ else
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+
+ for J in SR.Last + 1 .. Count loop
+ DR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ DR.Last := Count;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Head;
+
+ procedure Head
+ (Source : in out Unbounded_String;
+ Count : Natural;
+ Pad : Character := Space)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DR : Shared_String_Access;
+
+ begin
+ -- Result is empty, reuse empty shared string
+
+ if Count = 0 then
+ Reference (Empty_Shared_String'Access);
+ Source.Reference := Empty_Shared_String'Access;
+ Unreference (SR);
+
+ -- Result is same as source string, reuse source shared string
+
+ elsif Count = SR.Last then
+ null;
+
+ -- Try to reuse existing shared string
+
+ elsif Can_Be_Reused (SR, Count) then
+ if Count > SR.Last then
+ for J in SR.Last + 1 .. Count loop
+ SR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ SR.Last := Count;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+
+ -- Length of the source string is greater than requested, copy
+ -- corresponding slice.
+
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (1 .. Count);
+
+ -- Length of the source string is less than requested, copy all
+ -- existing data and fill remaining positions with Pad characters.
+
+ else
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+
+ for J in SR.Last + 1 .. Count loop
+ DR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ DR.Last := Count;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Head;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : Unbounded_String;
+ Pattern : String;
+ Going : Strings.Direction := Strings.Forward;
+ Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_String;
+ Pattern : String;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping_Function) return Natural
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set;
+ Test : Strings.Membership := Strings.Inside;
+ Going : Strings.Direction := Strings.Forward) return Natural
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ return Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going);
+ end Index;
+
+ function Index
+ (Source : Unbounded_String;
+ Pattern : String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ return Search.Index
+ (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_String;
+ Pattern : String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping_Function) return Natural
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ return Search.Index
+ (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ return Search.Index (SR.Data (1 .. SR.Last), Set, From, Test, Going);
+ end Index;
+
+ ---------------------
+ -- Index_Non_Blank --
+ ---------------------
+
+ function Index_Non_Blank
+ (Source : Unbounded_String;
+ Going : Strings.Direction := Strings.Forward) return Natural
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going);
+ end Index_Non_Blank;
+
+ function Index_Non_Blank
+ (Source : Unbounded_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ begin
+ return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), From, Going);
+ end Index_Non_Blank;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Object : in out Unbounded_String) is
+ begin
+ Reference (Object.Reference);
+ end Initialize;
+
+ ------------
+ -- Insert --
+ ------------
+
+ function Insert
+ (Source : Unbounded_String;
+ Before : Positive;
+ New_Item : String) return Unbounded_String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + New_Item'Length;
+ DR : Shared_String_Access;
+
+ begin
+ -- Check index first
+
+ if Before > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Result is empty, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Inserted string is empty, reuse source shared string
+
+ elsif New_Item'Length = 0 then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
+ DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
+ DR.Data (Before + New_Item'Length .. DL) :=
+ SR.Data (Before .. SR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Insert;
+
+ procedure Insert
+ (Source : in out Unbounded_String;
+ Before : Positive;
+ New_Item : String)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + New_Item'Length;
+ DR : Shared_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Before > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ Source.Reference := Empty_Shared_String'Access;
+ Unreference (SR);
+
+ -- Inserted string is empty, nothing to do
+
+ elsif New_Item'Length = 0 then
+ null;
+
+ -- Try to reuse existing shared string first
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (Before + New_Item'Length .. DL) :=
+ SR.Data (Before .. SR.Last);
+ SR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
+ DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
+ DR.Data (Before + New_Item'Length .. DL) :=
+ SR.Data (Before .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Insert;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Source : Unbounded_String) return Natural is
+ begin
+ return Source.Reference.Last;
+ end Length;
+
+ ---------------
+ -- Overwrite --
+ ---------------
+
+ function Overwrite
+ (Source : Unbounded_String;
+ Position : Positive;
+ New_Item : String) return Unbounded_String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Position > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Result is same as source string, reuse source shared string
+
+ elsif New_Item'Length = 0 then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
+ DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
+ DR.Data (Position + New_Item'Length .. DL) :=
+ SR.Data (Position + New_Item'Length .. SR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Overwrite;
+
+ procedure Overwrite
+ (Source : in out Unbounded_String;
+ Position : Positive;
+ New_Item : String)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+
+ begin
+ -- Bounds check
+
+ if Position > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ Source.Reference := Empty_Shared_String'Access;
+ Unreference (SR);
+
+ -- String unchanged, nothing to do
+
+ elsif New_Item'Length = 0 then
+ null;
+
+ -- Try to reuse existing shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
+ SR.Last := DL;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
+ DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
+ DR.Data (Position + New_Item'Length .. DL) :=
+ SR.Data (Position + New_Item'Length .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Overwrite;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ procedure Reference (Item : not null Shared_String_Access) is
+ begin
+ System.Atomic_Counters.Increment (Item.Counter);
+ end Reference;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Source : in out Unbounded_String;
+ Index : Positive;
+ By : Character)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DR : Shared_String_Access;
+
+ begin
+ -- Bounds check
+
+ if Index <= SR.Last then
+
+ -- Try to reuse existing shared string
+
+ if Can_Be_Reused (SR, SR.Last) then
+ SR.Data (Index) := By;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (Index) := By;
+ DR.Last := SR.Last;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+
+ else
+ raise Index_Error;
+ end if;
+ end Replace_Element;
+
+ -------------------
+ -- Replace_Slice --
+ -------------------
+
+ function Replace_Slice
+ (Source : Unbounded_String;
+ Low : Positive;
+ High : Natural;
+ By : String) return Unbounded_String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Low > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Do replace operation when removed slice is not empty
+
+ if High >= Low then
+ DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
+ -- This is the number of characters remaining in the string after
+ -- replacing the slice.
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
+ DR.Data (Low .. Low + By'Length - 1) := By;
+ DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+
+ -- Otherwise just insert string
+
+ else
+ return Insert (Source, Low, By);
+ end if;
+ end Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_String;
+ Low : Positive;
+ High : Natural;
+ By : String)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+
+ begin
+ -- Bounds check
+
+ if Low > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Do replace operation only when replaced slice is not empty
+
+ if High >= Low then
+ DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
+ -- This is the number of characters remaining in the string after
+ -- replacing the slice.
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ Source.Reference := Empty_Shared_String'Access;
+ Unreference (SR);
+
+ -- Try to reuse existing shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
+ SR.Data (Low .. Low + By'Length - 1) := By;
+ SR.Last := DL;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
+ DR.Data (Low .. Low + By'Length - 1) := By;
+ DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+
+ -- Otherwise just insert item
+
+ else
+ Insert (Source, Low, By);
+ end if;
+ end Replace_Slice;
+
+ --------------------------
+ -- Set_Unbounded_String --
+ --------------------------
+
+ procedure Set_Unbounded_String
+ (Target : out Unbounded_String;
+ Source : String)
+ is
+ TR : constant Shared_String_Access := Target.Reference;
+ DR : Shared_String_Access;
+
+ begin
+ -- In case of empty string, reuse empty shared string
+
+ if Source'Length = 0 then
+ Reference (Empty_Shared_String'Access);
+ Target.Reference := Empty_Shared_String'Access;
+
+ else
+ -- Try to reuse existing shared string
+
+ if Can_Be_Reused (TR, Source'Length) then
+ Reference (TR);
+ DR := TR;
+
+ -- Otherwise allocate new shared string
+
+ else
+ DR := Allocate (Source'Length);
+ Target.Reference := DR;
+ end if;
+
+ DR.Data (1 .. Source'Length) := Source;
+ DR.Last := Source'Length;
+ end if;
+
+ Unreference (TR);
+ end Set_Unbounded_String;
+
+ -----------
+ -- Slice --
+ -----------
+
+ function Slice
+ (Source : Unbounded_String;
+ Low : Positive;
+ High : Natural) return String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+
+ begin
+ -- Note: test of High > Length is in accordance with AI95-00128
+
+ if Low > SR.Last + 1 or else High > SR.Last then
+ raise Index_Error;
+
+ else
+ return SR.Data (Low .. High);
+ end if;
+ end Slice;
+
+ ----------
+ -- Tail --
+ ----------
+
+ function Tail
+ (Source : Unbounded_String;
+ Count : Natural;
+ Pad : Character := Space) return Unbounded_String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DR : Shared_String_Access;
+
+ begin
+ -- For empty result reuse empty shared string
+
+ if Count = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Result is whole source string, reuse source shared string
+
+ elsif Count = SR.Last then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
+
+ else
+ for J in 1 .. Count - SR.Last loop
+ DR.Data (J) := Pad;
+ end loop;
+
+ DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
+ end if;
+
+ DR.Last := Count;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Tail;
+
+ procedure Tail
+ (Source : in out Unbounded_String;
+ Count : Natural;
+ Pad : Character := Space)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DR : Shared_String_Access;
+
+ procedure Common
+ (SR : Shared_String_Access;
+ DR : Shared_String_Access;
+ Count : Natural);
+ -- Common code of tail computation. SR/DR can point to the same object
+
+ ------------
+ -- Common --
+ ------------
+
+ procedure Common
+ (SR : Shared_String_Access;
+ DR : Shared_String_Access;
+ Count : Natural) is
+ begin
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
+
+ else
+ DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
+
+ for J in 1 .. Count - SR.Last loop
+ DR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ DR.Last := Count;
+ end Common;
+
+ begin
+ -- Result is empty string, reuse empty shared string
+
+ if Count = 0 then
+ Reference (Empty_Shared_String'Access);
+ Source.Reference := Empty_Shared_String'Access;
+ Unreference (SR);
+
+ -- Length of the result is the same as length of the source string,
+ -- reuse source shared string.
+
+ elsif Count = SR.Last then
+ null;
+
+ -- Try to reuse existing shared string
+
+ elsif Can_Be_Reused (SR, Count) then
+ Common (SR, SR, Count);
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+ Common (SR, DR, Count);
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Tail;
+
+ ---------------
+ -- To_String --
+ ---------------
+
+ function To_String (Source : Unbounded_String) return String is
+ begin
+ return Source.Reference.Data (1 .. Source.Reference.Last);
+ end To_String;
+
+ -------------------------
+ -- To_Unbounded_String --
+ -------------------------
+
+ function To_Unbounded_String (Source : String) return Unbounded_String is
+ DR : Shared_String_Access;
+
+ begin
+ if Source'Length = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ else
+ DR := Allocate (Source'Length);
+ DR.Data (1 .. Source'Length) := Source;
+ DR.Last := Source'Length;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end To_Unbounded_String;
+
+ function To_Unbounded_String (Length : Natural) return Unbounded_String is
+ DR : Shared_String_Access;
+
+ begin
+ if Length = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ else
+ DR := Allocate (Length);
+ DR.Last := Length;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end To_Unbounded_String;
+
+ ---------------
+ -- Translate --
+ ---------------
+
+ function Translate
+ (Source : Unbounded_String;
+ Mapping : Maps.Character_Mapping) return Unbounded_String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DR : Shared_String_Access;
+
+ begin
+ -- Nothing to translate, reuse empty shared string
+
+ if SR.Last = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Value (Mapping, SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_String;
+ Mapping : Maps.Character_Mapping)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DR : Shared_String_Access;
+
+ begin
+ -- Nothing to translate
+
+ if SR.Last = 0 then
+ null;
+
+ -- Try to reuse shared string
+
+ elsif Can_Be_Reused (SR, SR.Last) then
+ for J in 1 .. SR.Last loop
+ SR.Data (J) := Value (Mapping, SR.Data (J));
+ end loop;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Value (Mapping, SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Translate;
+
+ function Translate
+ (Source : Unbounded_String;
+ Mapping : Maps.Character_Mapping_Function) return Unbounded_String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DR : Shared_String_Access;
+
+ begin
+ -- Nothing to translate, reuse empty shared string
+
+ if SR.Last = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Mapping.all (SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+
+ exception
+ when others =>
+ Unreference (DR);
+
+ raise;
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_String;
+ Mapping : Maps.Character_Mapping_Function)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DR : Shared_String_Access;
+
+ begin
+ -- Nothing to translate
+
+ if SR.Last = 0 then
+ null;
+
+ -- Try to reuse shared string
+
+ elsif Can_Be_Reused (SR, SR.Last) then
+ for J in 1 .. SR.Last loop
+ SR.Data (J) := Mapping.all (SR.Data (J));
+ end loop;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Mapping.all (SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+
+ exception
+ when others =>
+ if DR /= null then
+ Unreference (DR);
+ end if;
+
+ raise;
+ end Translate;
+
+ ----------
+ -- Trim --
+ ----------
+
+ function Trim
+ (Source : Unbounded_String;
+ Side : Trim_End) return Unbounded_String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index_Non_Blank (Source, Forward);
+
+ -- All blanks, reuse empty shared string
+
+ if Low = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ else
+ case Side is
+ when Left =>
+ High := SR.Last;
+ DL := SR.Last - Low + 1;
+
+ when Right =>
+ Low := 1;
+ High := Index_Non_Blank (Source, Backward);
+ DL := High;
+
+ when Both =>
+ High := Index_Non_Blank (Source, Backward);
+ DL := High - Low + 1;
+ end case;
+
+ -- Length of the result is the same as length of the source string,
+ -- reuse source shared string.
+
+ if DL = SR.Last then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ end if;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_String;
+ Side : Trim_End)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index_Non_Blank (Source, Forward);
+
+ -- All blanks, reuse empty shared string
+
+ if Low = 0 then
+ Reference (Empty_Shared_String'Access);
+ Source.Reference := Empty_Shared_String'Access;
+ Unreference (SR);
+
+ else
+ case Side is
+ when Left =>
+ High := SR.Last;
+ DL := SR.Last - Low + 1;
+
+ when Right =>
+ Low := 1;
+ High := Index_Non_Blank (Source, Backward);
+ DL := High;
+
+ when Both =>
+ High := Index_Non_Blank (Source, Backward);
+ DL := High - Low + 1;
+ end case;
+
+ -- Length of the result is the same as length of the source string,
+ -- nothing to do.
+
+ if DL = SR.Last then
+ null;
+
+ -- Try to reuse existing shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (1 .. DL) := SR.Data (Low .. High);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end if;
+ end Trim;
+
+ function Trim
+ (Source : Unbounded_String;
+ Left : Maps.Character_Set;
+ Right : Maps.Character_Set) return Unbounded_String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index (Source, Left, Outside, Forward);
+
+ -- Source includes only characters from Left set, reuse empty shared
+ -- string.
+
+ if Low = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ else
+ High := Index (Source, Right, Outside, Backward);
+ DL := Integer'Max (0, High - Low + 1);
+
+ -- Source includes only characters from Right set or result string
+ -- is empty, reuse empty shared string.
+
+ if High = 0 or else DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ end if;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_String;
+ Left : Maps.Character_Set;
+ Right : Maps.Character_Set)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index (Source, Left, Outside, Forward);
+
+ -- Source includes only characters from Left set, reuse empty shared
+ -- string.
+
+ if Low = 0 then
+ Reference (Empty_Shared_String'Access);
+ Source.Reference := Empty_Shared_String'Access;
+ Unreference (SR);
+
+ else
+ High := Index (Source, Right, Outside, Backward);
+ DL := Integer'Max (0, High - Low + 1);
+
+ -- Source includes only characters from Right set or result string
+ -- is empty, reuse empty shared string.
+
+ if High = 0 or else DL = 0 then
+ Reference (Empty_Shared_String'Access);
+ Source.Reference := Empty_Shared_String'Access;
+ Unreference (SR);
+
+ -- Try to reuse existing shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (1 .. DL) := SR.Data (Low .. High);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end if;
+ end Trim;
+
+ ---------------------
+ -- Unbounded_Slice --
+ ---------------------
+
+ function Unbounded_Slice
+ (Source : Unbounded_String;
+ Low : Positive;
+ High : Natural) return Unbounded_String
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Low > SR.Last + 1 or else High > SR.Last then
+ raise Index_Error;
+
+ -- Result is empty slice, reuse empty shared string
+
+ elsif Low > High then
+ Reference (Empty_Shared_String'Access);
+ DR := Empty_Shared_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DL := High - Low + 1;
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Unbounded_Slice;
+
+ procedure Unbounded_Slice
+ (Source : Unbounded_String;
+ Target : out Unbounded_String;
+ Low : Positive;
+ High : Natural)
+ is
+ SR : constant Shared_String_Access := Source.Reference;
+ TR : constant Shared_String_Access := Target.Reference;
+ DL : Natural;
+ DR : Shared_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Low > SR.Last + 1 or else High > SR.Last then
+ raise Index_Error;
+
+ -- Result is empty slice, reuse empty shared string
+
+ elsif Low > High then
+ Reference (Empty_Shared_String'Access);
+ Target.Reference := Empty_Shared_String'Access;
+ Unreference (TR);
+
+ else
+ DL := High - Low + 1;
+
+ -- Try to reuse existing shared string
+
+ if Can_Be_Reused (TR, DL) then
+ TR.Data (1 .. DL) := SR.Data (Low .. High);
+ TR.Last := DL;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ Target.Reference := DR;
+ Unreference (TR);
+ end if;
+ end if;
+ end Unbounded_Slice;
+
+ -----------------
+ -- Unreference --
+ -----------------
+
+ procedure Unreference (Item : not null Shared_String_Access) is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access);
+
+ Aux : Shared_String_Access := Item;
+
+ begin
+ if System.Atomic_Counters.Decrement (Aux.Counter) then
+
+ -- Reference counter of Empty_Shared_String should never reach
+ -- zero. We check here in case it wraps around.
+
+ if Aux /= Empty_Shared_String'Access then
+ Free (Aux);
+ end if;
+ end if;
+ end Unreference;
+
+end Ada.Strings.Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . U N B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides an implementation of Ada.Strings.Unbounded that uses
+-- reference counts to implement copy on modification (rather than copy on
+-- assignment). This is significantly more efficient on many targets.
+
+-- This version is supported on:
+-- - all Alpha platforms
+-- - all ia64 platforms
+-- - all PowerPC platforms
+-- - all SPARC V9 platforms
+-- - all x86 platforms
+-- - all x86_64 platforms
+
+ -- This package uses several techniques to increase speed:
+
+ -- - Implicit sharing or copy-on-write. An Unbounded_String contains only
+ -- the reference to the data which is shared between several instances.
+ -- The shared data is reallocated only when its value is changed and
+ -- the object mutation can't be used or it is inefficient to use it.
+
+ -- - Object mutation. Shared data object can be reused without memory
+ -- reallocation when all of the following requirements are met:
+ -- - the shared data object is no longer used by anyone else;
+ -- - the size is sufficient to store the new value;
+ -- - the gap after reuse is less than a defined threshold.
+
+ -- - Memory preallocation. Most of used memory allocation algorithms
+ -- align allocated segments on the some boundary, thus some amount of
+ -- additional memory can be preallocated without any impact. Such
+ -- preallocated memory can used later by Append/Insert operations
+ -- without reallocation.
+
+ -- Reference counting uses GCC builtin atomic operations, which allows safe
+ -- sharing of internal data between Ada tasks. Nevertheless, this does not
+ -- make objects of Unbounded_String thread-safe: an instance cannot be
+ -- accessed by several tasks simultaneously.
+
+with Ada.Strings.Maps;
+private with Ada.Finalization;
+private with System.Atomic_Counters;
+
+package Ada.Strings.Unbounded is
+ pragma Preelaborate;
+
+ type Unbounded_String is private;
+ pragma Preelaborable_Initialization (Unbounded_String);
+
+ Null_Unbounded_String : constant Unbounded_String;
+
+ function Length (Source : Unbounded_String) return Natural;
+
+ type String_Access is access all String;
+
+ procedure Free (X : in out String_Access);
+
+ --------------------------------------------------------
+ -- Conversion, Concatenation, and Selection Functions --
+ --------------------------------------------------------
+
+ function To_Unbounded_String
+ (Source : String) return Unbounded_String;
+
+ function To_Unbounded_String
+ (Length : Natural) return Unbounded_String;
+
+ function To_String (Source : Unbounded_String) return String;
+
+ procedure Set_Unbounded_String
+ (Target : out Unbounded_String;
+ Source : String);
+ pragma Ada_05 (Set_Unbounded_String);
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : Unbounded_String);
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : String);
+
+ procedure Append
+ (Source : in out Unbounded_String;
+ New_Item : Character);
+
+ function "&"
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Unbounded_String;
+
+ function "&"
+ (Left : Unbounded_String;
+ Right : String) return Unbounded_String;
+
+ function "&"
+ (Left : String;
+ Right : Unbounded_String) return Unbounded_String;
+
+ function "&"
+ (Left : Unbounded_String;
+ Right : Character) return Unbounded_String;
+
+ function "&"
+ (Left : Character;
+ Right : Unbounded_String) return Unbounded_String;
+
+ function Element
+ (Source : Unbounded_String;
+ Index : Positive) return Character;
+
+ procedure Replace_Element
+ (Source : in out Unbounded_String;
+ Index : Positive;
+ By : Character);
+
+ function Slice
+ (Source : Unbounded_String;
+ Low : Positive;
+ High : Natural) return String;
+
+ function Unbounded_Slice
+ (Source : Unbounded_String;
+ Low : Positive;
+ High : Natural) return Unbounded_String;
+ pragma Ada_05 (Unbounded_Slice);
+
+ procedure Unbounded_Slice
+ (Source : Unbounded_String;
+ Target : out Unbounded_String;
+ Low : Positive;
+ High : Natural);
+ pragma Ada_05 (Unbounded_Slice);
+
+ function "="
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Boolean;
+
+ function "="
+ (Left : Unbounded_String;
+ Right : String) return Boolean;
+
+ function "="
+ (Left : String;
+ Right : Unbounded_String) return Boolean;
+
+ function "<"
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Boolean;
+
+ function "<"
+ (Left : Unbounded_String;
+ Right : String) return Boolean;
+
+ function "<"
+ (Left : String;
+ Right : Unbounded_String) return Boolean;
+
+ function "<="
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Boolean;
+
+ function "<="
+ (Left : Unbounded_String;
+ Right : String) return Boolean;
+
+ function "<="
+ (Left : String;
+ Right : Unbounded_String) return Boolean;
+
+ function ">"
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Boolean;
+
+ function ">"
+ (Left : Unbounded_String;
+ Right : String) return Boolean;
+
+ function ">"
+ (Left : String;
+ Right : Unbounded_String) return Boolean;
+
+ function ">="
+ (Left : Unbounded_String;
+ Right : Unbounded_String) return Boolean;
+
+ function ">="
+ (Left : Unbounded_String;
+ Right : String) return Boolean;
+
+ function ">="
+ (Left : String;
+ Right : Unbounded_String) return Boolean;
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : Unbounded_String;
+ Pattern : String;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping := Maps.Identity) return Natural;
+
+ function Index
+ (Source : Unbounded_String;
+ Pattern : String;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping_Function) return Natural;
+
+ function Index
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+
+ function Index
+ (Source : Unbounded_String;
+ Pattern : String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping := Maps.Identity) return Natural;
+ pragma Ada_05 (Index);
+
+ function Index
+ (Source : Unbounded_String;
+ Pattern : String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping_Function) return Natural;
+ pragma Ada_05 (Index);
+
+ function Index
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+ pragma Ada_05 (Index);
+
+ function Index_Non_Blank
+ (Source : Unbounded_String;
+ Going : Direction := Forward) return Natural;
+
+ function Index_Non_Blank
+ (Source : Unbounded_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural;
+ pragma Ada_05 (Index_Non_Blank);
+
+ function Count
+ (Source : Unbounded_String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping := Maps.Identity) return Natural;
+
+ function Count
+ (Source : Unbounded_String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping_Function) return Natural;
+
+ function Count
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set) return Natural;
+
+ procedure Find_Token
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set;
+ From : Positive;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+ pragma Ada_2012 (Find_Token);
+
+ procedure Find_Token
+ (Source : Unbounded_String;
+ Set : Maps.Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ------------------------------------
+ -- String Translation Subprograms --
+ ------------------------------------
+
+ function Translate
+ (Source : Unbounded_String;
+ Mapping : Maps.Character_Mapping) return Unbounded_String;
+
+ procedure Translate
+ (Source : in out Unbounded_String;
+ Mapping : Maps.Character_Mapping);
+
+ function Translate
+ (Source : Unbounded_String;
+ Mapping : Maps.Character_Mapping_Function) return Unbounded_String;
+
+ procedure Translate
+ (Source : in out Unbounded_String;
+ Mapping : Maps.Character_Mapping_Function);
+
+ ---------------------------------------
+ -- String Transformation Subprograms --
+ ---------------------------------------
+
+ function Replace_Slice
+ (Source : Unbounded_String;
+ Low : Positive;
+ High : Natural;
+ By : String) return Unbounded_String;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_String;
+ Low : Positive;
+ High : Natural;
+ By : String);
+
+ function Insert
+ (Source : Unbounded_String;
+ Before : Positive;
+ New_Item : String) return Unbounded_String;
+
+ procedure Insert
+ (Source : in out Unbounded_String;
+ Before : Positive;
+ New_Item : String);
+
+ function Overwrite
+ (Source : Unbounded_String;
+ Position : Positive;
+ New_Item : String) return Unbounded_String;
+
+ procedure Overwrite
+ (Source : in out Unbounded_String;
+ Position : Positive;
+ New_Item : String);
+
+ function Delete
+ (Source : Unbounded_String;
+ From : Positive;
+ Through : Natural) return Unbounded_String;
+
+ procedure Delete
+ (Source : in out Unbounded_String;
+ From : Positive;
+ Through : Natural);
+
+ function Trim
+ (Source : Unbounded_String;
+ Side : Trim_End) return Unbounded_String;
+
+ procedure Trim
+ (Source : in out Unbounded_String;
+ Side : Trim_End);
+
+ function Trim
+ (Source : Unbounded_String;
+ Left : Maps.Character_Set;
+ Right : Maps.Character_Set) return Unbounded_String;
+
+ procedure Trim
+ (Source : in out Unbounded_String;
+ Left : Maps.Character_Set;
+ Right : Maps.Character_Set);
+
+ function Head
+ (Source : Unbounded_String;
+ Count : Natural;
+ Pad : Character := Space) return Unbounded_String;
+
+ procedure Head
+ (Source : in out Unbounded_String;
+ Count : Natural;
+ Pad : Character := Space);
+
+ function Tail
+ (Source : Unbounded_String;
+ Count : Natural;
+ Pad : Character := Space) return Unbounded_String;
+
+ procedure Tail
+ (Source : in out Unbounded_String;
+ Count : Natural;
+ Pad : Character := Space);
+
+ function "*"
+ (Left : Natural;
+ Right : Character) return Unbounded_String;
+
+ function "*"
+ (Left : Natural;
+ Right : String) return Unbounded_String;
+
+ function "*"
+ (Left : Natural;
+ Right : Unbounded_String) return Unbounded_String;
+
+private
+ pragma Inline (Length);
+
+ package AF renames Ada.Finalization;
+
+ type Shared_String (Max_Length : Natural) is limited record
+ Counter : System.Atomic_Counters.Atomic_Counter;
+ -- Reference counter
+
+ Last : Natural := 0;
+ Data : String (1 .. Max_Length);
+ -- Last is the index of last significant element of the Data. All
+ -- elements with larger indexes are currently insignificant.
+ end record;
+
+ type Shared_String_Access is access all Shared_String;
+
+ procedure Reference (Item : not null Shared_String_Access);
+ -- Increment reference counter
+
+ procedure Unreference (Item : not null Shared_String_Access);
+ -- Decrement reference counter, deallocate Item when counter goes to zero
+
+ function Can_Be_Reused
+ (Item : not null Shared_String_Access;
+ Length : Natural) return Boolean;
+ -- Returns True if Shared_String can be reused. There are two criteria when
+ -- Shared_String can be reused: its reference counter must be one (thus
+ -- Shared_String is owned exclusively) and its size is sufficient to
+ -- store string with specified length effectively.
+
+ function Allocate
+ (Max_Length : Natural) return not null Shared_String_Access;
+ -- Allocates new Shared_String with at least specified maximum length.
+ -- Actual maximum length of the allocated Shared_String can be slightly
+ -- greater. Returns reference to Empty_Shared_String when requested length
+ -- is zero.
+
+ Empty_Shared_String : aliased Shared_String (0);
+
+ function To_Unbounded (S : String) return Unbounded_String
+ renames To_Unbounded_String;
+ -- This renames are here only to be used in the pragma Stream_Convert
+
+ type Unbounded_String is new AF.Controlled with record
+ Reference : not null Shared_String_Access := Empty_Shared_String'Access;
+ end record;
+
+ pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String);
+ -- Provide stream routines without dragging in Ada.Streams
+
+ pragma Finalize_Storage_Only (Unbounded_String);
+ -- Finalization is required only for freeing storage
+
+ overriding procedure Initialize (Object : in out Unbounded_String);
+ overriding procedure Adjust (Object : in out Unbounded_String);
+ overriding procedure Finalize (Object : in out Unbounded_String);
+
+ Null_Unbounded_String : constant Unbounded_String :=
+ (AF.Controlled with
+ Reference => Empty_Shared_String'Access);
+
+end Ada.Strings.Unbounded;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S T R I N G S . U N B O U N D E D . A U X --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-package body Ada.Strings.Unbounded.Aux is
-
- ----------------
- -- Get_String --
- ----------------
-
- procedure Get_String
- (U : Unbounded_String;
- S : out Big_String_Access;
- L : out Natural)
- is
- X : aliased Big_String;
- for X'Address use U.Reference.Data'Address;
- begin
- S := X'Unchecked_Access;
- L := U.Reference.Last;
- end Get_String;
-
- ----------------
- -- Set_String --
- ----------------
-
- procedure Set_String (UP : in out Unbounded_String; S : String_Access) is
- X : String_Access := S;
-
- begin
- Set_Unbounded_String (UP, S.all);
- Free (X);
- end Set_String;
-
-end Ada.Strings.Unbounded.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . U N B O U N D E D . A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Strings.Unbounded.Aux is
+
+ ----------------
+ -- Get_String --
+ ----------------
+
+ procedure Get_String
+ (U : Unbounded_String;
+ S : out Big_String_Access;
+ L : out Natural)
+ is
+ X : aliased Big_String;
+ for X'Address use U.Reference.Data'Address;
+ begin
+ S := X'Unchecked_Access;
+ L := U.Reference.Last;
+ end Get_String;
+
+ ----------------
+ -- Set_String --
+ ----------------
+
+ procedure Set_String (UP : in out Unbounded_String; S : String_Access) is
+ X : String_Access := S;
+
+ begin
+ Set_Unbounded_String (UP, S.all);
+ Free (X);
+ end Set_String;
+
+end Ada.Strings.Unbounded.Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S T R I N G S . W I D E _ U N B O U N D E D --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Strings.Wide_Search;
-with Ada.Unchecked_Deallocation;
-
-package body Ada.Strings.Wide_Unbounded is
-
- use Ada.Strings.Wide_Maps;
-
- Growth_Factor : constant := 32;
- -- The growth factor controls how much extra space is allocated when
- -- we have to increase the size of an allocated unbounded string. By
- -- allocating extra space, we avoid the need to reallocate on every
- -- append, particularly important when a string is built up by repeated
- -- append operations of small pieces. This is expressed as a factor so
- -- 32 means add 1/32 of the length of the string as growth space.
-
- Min_Mul_Alloc : constant := Standard'Maximum_Alignment;
- -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes
- -- no memory loss as most (all?) malloc implementations are obliged to
- -- align the returned memory on the maximum alignment as malloc does not
- -- know the target alignment.
-
- function Aligned_Max_Length (Max_Length : Natural) return Natural;
- -- Returns recommended length of the shared string which is greater or
- -- equal to specified length. Calculation take in sense alignment of
- -- the allocated memory segments to use memory effectively by
- -- Append/Insert/etc operations.
-
- ---------
- -- "&" --
- ---------
-
- function "&"
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Unbounded_Wide_String
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_String_Access := Right.Reference;
- DL : constant Natural := LR.Last + RR.Last;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Left string is empty, return Rigth string
-
- elsif LR.Last = 0 then
- Reference (RR);
- DR := RR;
-
- -- Right string is empty, return Left string
-
- elsif RR.Last = 0 then
- Reference (LR);
- DR := LR;
-
- -- Overwise, allocate new shared string and fill data
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
- DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Unbounded_Wide_String
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- DL : constant Natural := LR.Last + Right'Length;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Right is an empty string, return Left string
-
- elsif Right'Length = 0 then
- Reference (LR);
- DR := LR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
- DR.Data (LR.Last + 1 .. DL) := Right;
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Unbounded_Wide_String
- is
- RR : constant Shared_Wide_String_Access := Right.Reference;
- DL : constant Natural := Left'Length + RR.Last;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Result is an empty string, reuse shared one
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Left is empty string, return Right string
-
- elsif Left'Length = 0 then
- Reference (RR);
- DR := RR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Left'Length) := Left;
- DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : Unbounded_Wide_String;
- Right : Wide_Character) return Unbounded_Wide_String
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- DL : constant Natural := LR.Last + 1;
- DR : Shared_Wide_String_Access;
-
- begin
- DR := Allocate (DL);
- DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
- DR.Data (DL) := Right;
- DR.Last := DL;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : Wide_Character;
- Right : Unbounded_Wide_String) return Unbounded_Wide_String
- is
- RR : constant Shared_Wide_String_Access := Right.Reference;
- DL : constant Natural := 1 + RR.Last;
- DR : Shared_Wide_String_Access;
-
- begin
- DR := Allocate (DL);
- DR.Data (1) := Left;
- DR.Data (2 .. DL) := RR.Data (1 .. RR.Last);
- DR.Last := DL;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- ---------
- -- "*" --
- ---------
-
- function "*"
- (Left : Natural;
- Right : Wide_Character) return Unbounded_Wide_String
- is
- DR : Shared_Wide_String_Access;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if Left = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (Left);
-
- for J in 1 .. Left loop
- DR.Data (J) := Right;
- end loop;
-
- DR.Last := Left;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "*";
-
- function "*"
- (Left : Natural;
- Right : Wide_String) return Unbounded_Wide_String
- is
- DL : constant Natural := Left * Right'Length;
- DR : Shared_Wide_String_Access;
- K : Positive;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- K := 1;
-
- for J in 1 .. Left loop
- DR.Data (K .. K + Right'Length - 1) := Right;
- K := K + Right'Length;
- end loop;
-
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "*";
-
- function "*"
- (Left : Natural;
- Right : Unbounded_Wide_String) return Unbounded_Wide_String
- is
- RR : constant Shared_Wide_String_Access := Right.Reference;
- DL : constant Natural := Left * RR.Last;
- DR : Shared_Wide_String_Access;
- K : Positive;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Coefficient is one, just return string itself
-
- elsif Left = 1 then
- Reference (RR);
- DR := RR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- K := 1;
-
- for J in 1 .. Left loop
- DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last);
- K := K + RR.Last;
- end loop;
-
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "*";
-
- ---------
- -- "<" --
- ---------
-
- function "<"
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_String_Access := Right.Reference;
- begin
- return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last);
- end "<";
-
- function "<"
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Boolean
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) < Right;
- end "<";
-
- function "<"
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Boolean
- is
- RR : constant Shared_Wide_String_Access := Right.Reference;
- begin
- return Left < RR.Data (1 .. RR.Last);
- end "<";
-
- ----------
- -- "<=" --
- ----------
-
- function "<="
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_String_Access := Right.Reference;
-
- begin
- -- LR = RR means two strings shares shared string, thus they are equal
-
- return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last);
- end "<=";
-
- function "<="
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Boolean
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) <= Right;
- end "<=";
-
- function "<="
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Boolean
- is
- RR : constant Shared_Wide_String_Access := Right.Reference;
- begin
- return Left <= RR.Data (1 .. RR.Last);
- end "<=";
-
- ---------
- -- "=" --
- ---------
-
- function "="
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_String_Access := Right.Reference;
-
- begin
- return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last);
- -- LR = RR means two strings shares shared string, thus they are equal
- end "=";
-
- function "="
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Boolean
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) = Right;
- end "=";
-
- function "="
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Boolean
- is
- RR : constant Shared_Wide_String_Access := Right.Reference;
- begin
- return Left = RR.Data (1 .. RR.Last);
- end "=";
-
- ---------
- -- ">" --
- ---------
-
- function ">"
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_String_Access := Right.Reference;
- begin
- return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last);
- end ">";
-
- function ">"
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Boolean
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) > Right;
- end ">";
-
- function ">"
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Boolean
- is
- RR : constant Shared_Wide_String_Access := Right.Reference;
- begin
- return Left > RR.Data (1 .. RR.Last);
- end ">";
-
- ----------
- -- ">=" --
- ----------
-
- function ">="
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_String_Access := Right.Reference;
-
- begin
- -- LR = RR means two strings shares shared string, thus they are equal
-
- return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last);
- end ">=";
-
- function ">="
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Boolean
- is
- LR : constant Shared_Wide_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) >= Right;
- end ">=";
-
- function ">="
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Boolean
- is
- RR : constant Shared_Wide_String_Access := Right.Reference;
- begin
- return Left >= RR.Data (1 .. RR.Last);
- end ">=";
-
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Object : in out Unbounded_Wide_String) is
- begin
- Reference (Object.Reference);
- end Adjust;
-
- ------------------------
- -- Aligned_Max_Length --
- ------------------------
-
- function Aligned_Max_Length (Max_Length : Natural) return Natural is
- Static_Size : constant Natural :=
- Empty_Shared_Wide_String'Size / Standard'Storage_Unit;
- -- Total size of all static components
-
- Element_Size : constant Natural :=
- Wide_Character'Size / Standard'Storage_Unit;
-
- begin
- return
- (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2)
- * Min_Mul_Alloc - Static_Size) / Element_Size;
- end Aligned_Max_Length;
-
- --------------
- -- Allocate --
- --------------
-
- function Allocate (Max_Length : Natural) return Shared_Wide_String_Access is
- begin
- -- Empty string requested, return shared empty string
-
- if Max_Length = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- return Empty_Shared_Wide_String'Access;
-
- -- Otherwise, allocate requested space (and probably some more room)
-
- else
- return new Shared_Wide_String (Aligned_Max_Length (Max_Length));
- end if;
- end Allocate;
-
- ------------
- -- Append --
- ------------
-
- procedure Append
- (Source : in out Unbounded_Wide_String;
- New_Item : Unbounded_Wide_String)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- NR : constant Shared_Wide_String_Access := New_Item.Reference;
- DL : constant Natural := SR.Last + NR.Last;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Source is an empty string, reuse New_Item data
-
- if SR.Last = 0 then
- Reference (NR);
- Source.Reference := NR;
- Unreference (SR);
-
- -- New_Item is empty string, nothing to do
-
- elsif NR.Last = 0 then
- null;
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
- SR.Last := DL;
-
- -- Otherwise, allocate new one and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Append;
-
- procedure Append
- (Source : in out Unbounded_Wide_String;
- New_Item : Wide_String)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + New_Item'Length;
- DR : Shared_Wide_String_Access;
-
- begin
- -- New_Item is an empty string, nothing to do
-
- if New_Item'Length = 0 then
- null;
-
- -- Try to reuse existing shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (SR.Last + 1 .. DL) := New_Item;
- SR.Last := DL;
-
- -- Otherwise, allocate new one and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (SR.Last + 1 .. DL) := New_Item;
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Append;
-
- procedure Append
- (Source : in out Unbounded_Wide_String;
- New_Item : Wide_Character)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + 1;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Try to reuse existing shared string
-
- if Can_Be_Reused (SR, SR.Last + 1) then
- SR.Data (SR.Last + 1) := New_Item;
- SR.Last := SR.Last + 1;
-
- -- Otherwise, allocate new one and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (DL) := New_Item;
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Append;
-
- -------------------
- -- Can_Be_Reused --
- -------------------
-
- function Can_Be_Reused
- (Item : Shared_Wide_String_Access;
- Length : Natural) return Boolean is
- begin
- return
- System.Atomic_Counters.Is_One (Item.Counter)
- and then Item.Max_Length >= Length
- and then Item.Max_Length <=
- Aligned_Max_Length (Length + Length / Growth_Factor);
- end Can_Be_Reused;
-
- -----------
- -- Count --
- -----------
-
- function Count
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
- return Natural
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
- end Count;
-
- function Count
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
- end Count;
-
- function Count
- (Source : Unbounded_Wide_String;
- Set : Wide_Maps.Wide_Character_Set) return Natural
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- return Wide_Search.Count (SR.Data (1 .. SR.Last), Set);
- end Count;
-
- ------------
- -- Delete --
- ------------
-
- function Delete
- (Source : Unbounded_Wide_String;
- From : Positive;
- Through : Natural) return Unbounded_Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Empty slice is deleted, use the same shared string
-
- if From > Through then
- Reference (SR);
- DR := SR;
-
- -- Index is out of range
-
- elsif Through > SR.Last then
- raise Index_Error;
-
- -- Compute size of the result
-
- else
- DL := SR.Last - (Through - From + 1);
-
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
- DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
- DR.Last := DL;
- end if;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Delete;
-
- procedure Delete
- (Source : in out Unbounded_Wide_String;
- From : Positive;
- Through : Natural)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Nothing changed, return
-
- if From > Through then
- null;
-
- -- Through is outside of the range
-
- elsif Through > SR.Last then
- raise Index_Error;
-
- else
- DL := SR.Last - (Through - From + 1);
-
- -- Result is empty, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_String'Access;
- Unreference (SR);
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
- DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end if;
- end Delete;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Source : Unbounded_Wide_String;
- Index : Positive) return Wide_Character
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- if Index <= SR.Last then
- return SR.Data (Index);
- else
- raise Index_Error;
- end if;
- end Element;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Object : in out Unbounded_Wide_String) is
- SR : constant Shared_Wide_String_Access := Object.Reference;
-
- begin
- if SR /= null then
-
- -- The same controlled object can be finalized several times for
- -- some reason. As per 7.6.1(24) this should have no ill effect,
- -- so we need to add a guard for the case of finalizing the same
- -- object twice.
-
- Object.Reference := null;
- Unreference (SR);
- end if;
- end Finalize;
-
- ----------------
- -- Find_Token --
- ----------------
-
- procedure Find_Token
- (Source : Unbounded_Wide_String;
- Set : Wide_Maps.Wide_Character_Set;
- From : Positive;
- Test : Strings.Membership;
- First : out Positive;
- Last : out Natural)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- Wide_Search.Find_Token
- (SR.Data (From .. SR.Last), Set, Test, First, Last);
- end Find_Token;
-
- procedure Find_Token
- (Source : Unbounded_Wide_String;
- Set : Wide_Maps.Wide_Character_Set;
- Test : Strings.Membership;
- First : out Positive;
- Last : out Natural)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- Wide_Search.Find_Token
- (SR.Data (1 .. SR.Last), Set, Test, First, Last);
- end Find_Token;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (X : in out Wide_String_Access) is
- procedure Deallocate is
- new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access);
- begin
- Deallocate (X);
- end Free;
-
- ----------
- -- Head --
- ----------
-
- function Head
- (Source : Unbounded_Wide_String;
- Count : Natural;
- Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Result is empty, reuse shared empty string
-
- if Count = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Length of the string is the same as requested, reuse source shared
- -- string.
-
- elsif Count = SR.Last then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
-
- -- Length of the source string is more than requested, copy
- -- corresponding slice.
-
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (1 .. Count);
-
- -- Length of the source string is less than requested, copy all
- -- contents and fill others by Pad character.
-
- else
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
-
- for J in SR.Last + 1 .. Count loop
- DR.Data (J) := Pad;
- end loop;
- end if;
-
- DR.Last := Count;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Head;
-
- procedure Head
- (Source : in out Unbounded_Wide_String;
- Count : Natural;
- Pad : Wide_Character := Wide_Space)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Result is empty, reuse empty shared string
-
- if Count = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_String'Access;
- Unreference (SR);
-
- -- Result is same with source string, reuse source shared string
-
- elsif Count = SR.Last then
- null;
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, Count) then
- if Count > SR.Last then
- for J in SR.Last + 1 .. Count loop
- SR.Data (J) := Pad;
- end loop;
- end if;
-
- SR.Last := Count;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
-
- -- Length of the source string is greater than requested, copy
- -- corresponding slice.
-
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (1 .. Count);
-
- -- Length of the source string is less than requested, copy all
- -- exists data and fill others by Pad character.
-
- else
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
-
- for J in SR.Last + 1 .. Count loop
- DR.Data (J) := Pad;
- end loop;
- end if;
-
- DR.Last := Count;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Head;
-
- -----------
- -- Index --
- -----------
-
- function Index
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- Going : Strings.Direction := Strings.Forward;
- Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
- return Natural
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- return Wide_Search.Index
- (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- Going : Direction := Forward;
- Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- return Wide_Search.Index
- (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_Wide_String;
- Set : Wide_Maps.Wide_Character_Set;
- Test : Strings.Membership := Strings.Inside;
- Going : Strings.Direction := Strings.Forward) return Natural
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- return Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going);
- end Index;
-
- function Index
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
- return Natural
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- return Wide_Search.Index
- (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- return Wide_Search.Index
- (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_Wide_String;
- Set : Wide_Maps.Wide_Character_Set;
- From : Positive;
- Test : Membership := Inside;
- Going : Direction := Forward) return Natural
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- return Wide_Search.Index
- (SR.Data (1 .. SR.Last), Set, From, Test, Going);
- end Index;
-
- ---------------------
- -- Index_Non_Blank --
- ---------------------
-
- function Index_Non_Blank
- (Source : Unbounded_Wide_String;
- Going : Strings.Direction := Strings.Forward) return Natural
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- return Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going);
- end Index_Non_Blank;
-
- function Index_Non_Blank
- (Source : Unbounded_Wide_String;
- From : Positive;
- Going : Direction := Forward) return Natural
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- begin
- return Wide_Search.Index_Non_Blank
- (SR.Data (1 .. SR.Last), From, Going);
- end Index_Non_Blank;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Object : in out Unbounded_Wide_String) is
- begin
- Reference (Object.Reference);
- end Initialize;
-
- ------------
- -- Insert --
- ------------
-
- function Insert
- (Source : Unbounded_Wide_String;
- Before : Positive;
- New_Item : Wide_String) return Unbounded_Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + New_Item'Length;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Check index first
-
- if Before > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Result is empty, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Inserted string is empty, reuse source shared string
-
- elsif New_Item'Length = 0 then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
- DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
- DR.Data (Before + New_Item'Length .. DL) :=
- SR.Data (Before .. SR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Insert;
-
- procedure Insert
- (Source : in out Unbounded_Wide_String;
- Before : Positive;
- New_Item : Wide_String)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + New_Item'Length;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Check bounds
-
- if Before > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_String'Access;
- Unreference (SR);
-
- -- Inserted string is empty, nothing to do
-
- elsif New_Item'Length = 0 then
- null;
-
- -- Try to reuse existent shared string first
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (Before + New_Item'Length .. DL) :=
- SR.Data (Before .. SR.Last);
- SR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
- DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
- DR.Data (Before + New_Item'Length .. DL) :=
- SR.Data (Before .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Insert;
-
- ------------
- -- Length --
- ------------
-
- function Length (Source : Unbounded_Wide_String) return Natural is
- begin
- return Source.Reference.Last;
- end Length;
-
- ---------------
- -- Overwrite --
- ---------------
-
- function Overwrite
- (Source : Unbounded_Wide_String;
- Position : Positive;
- New_Item : Wide_String) return Unbounded_Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Check bounds
-
- if Position > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Result is same with source string, reuse source shared string
-
- elsif New_Item'Length = 0 then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
- DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
- DR.Data (Position + New_Item'Length .. DL) :=
- SR.Data (Position + New_Item'Length .. SR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Overwrite;
-
- procedure Overwrite
- (Source : in out Unbounded_Wide_String;
- Position : Positive;
- New_Item : Wide_String)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Bounds check
-
- if Position > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_String'Access;
- Unreference (SR);
-
- -- String unchanged, nothing to do
-
- elsif New_Item'Length = 0 then
- null;
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
- SR.Last := DL;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
- DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
- DR.Data (Position + New_Item'Length .. DL) :=
- SR.Data (Position + New_Item'Length .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Overwrite;
-
- ---------------
- -- Reference --
- ---------------
-
- procedure Reference (Item : not null Shared_Wide_String_Access) is
- begin
- System.Atomic_Counters.Increment (Item.Counter);
- end Reference;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Source : in out Unbounded_Wide_String;
- Index : Positive;
- By : Wide_Character)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Bounds check
-
- if Index <= SR.Last then
-
- -- Try to reuse existent shared string
-
- if Can_Be_Reused (SR, SR.Last) then
- SR.Data (Index) := By;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (Index) := By;
- DR.Last := SR.Last;
- Source.Reference := DR;
- Unreference (SR);
- end if;
-
- else
- raise Index_Error;
- end if;
- end Replace_Element;
-
- -------------------
- -- Replace_Slice --
- -------------------
-
- function Replace_Slice
- (Source : Unbounded_Wide_String;
- Low : Positive;
- High : Natural;
- By : Wide_String) return Unbounded_Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Check bounds
-
- if Low > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Do replace operation when removed slice is not empty
-
- if High >= Low then
- DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
- -- This is the number of characters remaining in the string after
- -- replacing the slice.
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
- DR.Data (Low .. Low + By'Length - 1) := By;
- DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
-
- -- Otherwise just insert string
-
- else
- return Insert (Source, Low, By);
- end if;
- end Replace_Slice;
-
- procedure Replace_Slice
- (Source : in out Unbounded_Wide_String;
- Low : Positive;
- High : Natural;
- By : Wide_String)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Bounds check
-
- if Low > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Do replace operation only when replaced slice is not empty
-
- if High >= Low then
- DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
- -- This is the number of characters remaining in the string after
- -- replacing the slice.
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_String'Access;
- Unreference (SR);
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
- SR.Data (Low .. Low + By'Length - 1) := By;
- SR.Last := DL;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
- DR.Data (Low .. Low + By'Length - 1) := By;
- DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
-
- -- Otherwise just insert item
-
- else
- Insert (Source, Low, By);
- end if;
- end Replace_Slice;
-
- -------------------------------
- -- Set_Unbounded_Wide_String --
- -------------------------------
-
- procedure Set_Unbounded_Wide_String
- (Target : out Unbounded_Wide_String;
- Source : Wide_String)
- is
- TR : constant Shared_Wide_String_Access := Target.Reference;
- DR : Shared_Wide_String_Access;
-
- begin
- -- In case of empty string, reuse empty shared string
-
- if Source'Length = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- Target.Reference := Empty_Shared_Wide_String'Access;
-
- else
- -- Try to reuse existent shared string
-
- if Can_Be_Reused (TR, Source'Length) then
- Reference (TR);
- DR := TR;
-
- -- Otherwise allocate new shared string
-
- else
- DR := Allocate (Source'Length);
- Target.Reference := DR;
- end if;
-
- DR.Data (1 .. Source'Length) := Source;
- DR.Last := Source'Length;
- end if;
-
- Unreference (TR);
- end Set_Unbounded_Wide_String;
-
- -----------
- -- Slice --
- -----------
-
- function Slice
- (Source : Unbounded_Wide_String;
- Low : Positive;
- High : Natural) return Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
-
- begin
- -- Note: test of High > Length is in accordance with AI95-00128
-
- if Low > SR.Last + 1 or else High > SR.Last then
- raise Index_Error;
-
- else
- return SR.Data (Low .. High);
- end if;
- end Slice;
-
- ----------
- -- Tail --
- ----------
-
- function Tail
- (Source : Unbounded_Wide_String;
- Count : Natural;
- Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_String_Access;
-
- begin
- -- For empty result reuse empty shared string
-
- if Count = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Result is hole source string, reuse source shared string
-
- elsif Count = SR.Last then
- Reference (SR);
- DR := SR;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
-
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
-
- else
- for J in 1 .. Count - SR.Last loop
- DR.Data (J) := Pad;
- end loop;
-
- DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
- end if;
-
- DR.Last := Count;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Tail;
-
- procedure Tail
- (Source : in out Unbounded_Wide_String;
- Count : Natural;
- Pad : Wide_Character := Wide_Space)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_String_Access;
-
- procedure Common
- (SR : Shared_Wide_String_Access;
- DR : Shared_Wide_String_Access;
- Count : Natural);
- -- Common code of tail computation. SR/DR can point to the same object
-
- ------------
- -- Common --
- ------------
-
- procedure Common
- (SR : Shared_Wide_String_Access;
- DR : Shared_Wide_String_Access;
- Count : Natural) is
- begin
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
-
- else
- DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
-
- for J in 1 .. Count - SR.Last loop
- DR.Data (J) := Pad;
- end loop;
- end if;
-
- DR.Last := Count;
- end Common;
-
- begin
- -- Result is empty string, reuse empty shared string
-
- if Count = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_String'Access;
- Unreference (SR);
-
- -- Length of the result is the same with length of the source string,
- -- reuse source shared string.
-
- elsif Count = SR.Last then
- null;
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, Count) then
- Common (SR, SR, Count);
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
- Common (SR, DR, Count);
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Tail;
-
- --------------------
- -- To_Wide_String --
- --------------------
-
- function To_Wide_String
- (Source : Unbounded_Wide_String) return Wide_String is
- begin
- return Source.Reference.Data (1 .. Source.Reference.Last);
- end To_Wide_String;
-
- ------------------------------
- -- To_Unbounded_Wide_String --
- ------------------------------
-
- function To_Unbounded_Wide_String
- (Source : Wide_String) return Unbounded_Wide_String
- is
- DR : Shared_Wide_String_Access;
-
- begin
- if Source'Length = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- else
- DR := Allocate (Source'Length);
- DR.Data (1 .. Source'Length) := Source;
- DR.Last := Source'Length;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end To_Unbounded_Wide_String;
-
- function To_Unbounded_Wide_String
- (Length : Natural) return Unbounded_Wide_String
- is
- DR : Shared_Wide_String_Access;
-
- begin
- if Length = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- else
- DR := Allocate (Length);
- DR.Last := Length;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end To_Unbounded_Wide_String;
-
- ---------------
- -- Translate --
- ---------------
-
- function Translate
- (Source : Unbounded_Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping) return Unbounded_Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Nothing to translate, reuse empty shared string
-
- if SR.Last = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Value (Mapping, SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Translate;
-
- procedure Translate
- (Source : in out Unbounded_Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Nothing to translate
-
- if SR.Last = 0 then
- null;
-
- -- Try to reuse shared string
-
- elsif Can_Be_Reused (SR, SR.Last) then
- for J in 1 .. SR.Last loop
- SR.Data (J) := Value (Mapping, SR.Data (J));
- end loop;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Value (Mapping, SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Translate;
-
- function Translate
- (Source : Unbounded_Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping_Function)
- return Unbounded_Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Nothing to translate, reuse empty shared string
-
- if SR.Last = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Mapping.all (SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- end if;
-
- return (AF.Controlled with Reference => DR);
-
- exception
- when others =>
- Unreference (DR);
-
- raise;
- end Translate;
-
- procedure Translate
- (Source : in out Unbounded_Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping_Function)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Nothing to translate
-
- if SR.Last = 0 then
- null;
-
- -- Try to reuse shared string
-
- elsif Can_Be_Reused (SR, SR.Last) then
- for J in 1 .. SR.Last loop
- SR.Data (J) := Mapping.all (SR.Data (J));
- end loop;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Mapping.all (SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- Source.Reference := DR;
- Unreference (SR);
- end if;
-
- exception
- when others =>
- if DR /= null then
- Unreference (DR);
- end if;
-
- raise;
- end Translate;
-
- ----------
- -- Trim --
- ----------
-
- function Trim
- (Source : Unbounded_Wide_String;
- Side : Trim_End) return Unbounded_Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index_Non_Blank (Source, Forward);
-
- -- All blanks, reuse empty shared string
-
- if Low = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- else
- case Side is
- when Left =>
- High := SR.Last;
- DL := SR.Last - Low + 1;
-
- when Right =>
- Low := 1;
- High := Index_Non_Blank (Source, Backward);
- DL := High;
-
- when Both =>
- High := Index_Non_Blank (Source, Backward);
- DL := High - Low + 1;
- end case;
-
- -- Length of the result is the same as length of the source string,
- -- reuse source shared string.
-
- if DL = SR.Last then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- end if;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Trim;
-
- procedure Trim
- (Source : in out Unbounded_Wide_String;
- Side : Trim_End)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index_Non_Blank (Source, Forward);
-
- -- All blanks, reuse empty shared string
-
- if Low = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_String'Access;
- Unreference (SR);
-
- else
- case Side is
- when Left =>
- High := SR.Last;
- DL := SR.Last - Low + 1;
-
- when Right =>
- Low := 1;
- High := Index_Non_Blank (Source, Backward);
- DL := High;
-
- when Both =>
- High := Index_Non_Blank (Source, Backward);
- DL := High - Low + 1;
- end case;
-
- -- Length of the result is the same as length of the source string,
- -- nothing to do.
-
- if DL = SR.Last then
- null;
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (1 .. DL) := SR.Data (Low .. High);
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end if;
- end Trim;
-
- function Trim
- (Source : Unbounded_Wide_String;
- Left : Wide_Maps.Wide_Character_Set;
- Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index (Source, Left, Outside, Forward);
-
- -- Source includes only characters from Left set, reuse empty shared
- -- string.
-
- if Low = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- else
- High := Index (Source, Right, Outside, Backward);
- DL := Integer'Max (0, High - Low + 1);
-
- -- Source includes only characters from Right set or result string
- -- is empty, reuse empty shared string.
-
- if High = 0 or else DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- end if;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Trim;
-
- procedure Trim
- (Source : in out Unbounded_Wide_String;
- Left : Wide_Maps.Wide_Character_Set;
- Right : Wide_Maps.Wide_Character_Set)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index (Source, Left, Outside, Forward);
-
- -- Source includes only characters from Left set, reuse empty shared
- -- string.
-
- if Low = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_String'Access;
- Unreference (SR);
-
- else
- High := Index (Source, Right, Outside, Backward);
- DL := Integer'Max (0, High - Low + 1);
-
- -- Source includes only characters from Right set or result string
- -- is empty, reuse empty shared string.
-
- if High = 0 or else DL = 0 then
- Reference (Empty_Shared_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_String'Access;
- Unreference (SR);
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (1 .. DL) := SR.Data (Low .. High);
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end if;
- end Trim;
-
- ---------------------
- -- Unbounded_Slice --
- ---------------------
-
- function Unbounded_Slice
- (Source : Unbounded_Wide_String;
- Low : Positive;
- High : Natural) return Unbounded_Wide_String
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Check bounds
-
- if Low > SR.Last + 1 or else High > SR.Last then
- raise Index_Error;
-
- -- Result is empty slice, reuse empty shared string
-
- elsif Low > High then
- Reference (Empty_Shared_Wide_String'Access);
- DR := Empty_Shared_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DL := High - Low + 1;
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Unbounded_Slice;
-
- procedure Unbounded_Slice
- (Source : Unbounded_Wide_String;
- Target : out Unbounded_Wide_String;
- Low : Positive;
- High : Natural)
- is
- SR : constant Shared_Wide_String_Access := Source.Reference;
- TR : constant Shared_Wide_String_Access := Target.Reference;
- DL : Natural;
- DR : Shared_Wide_String_Access;
-
- begin
- -- Check bounds
-
- if Low > SR.Last + 1 or else High > SR.Last then
- raise Index_Error;
-
- -- Result is empty slice, reuse empty shared string
-
- elsif Low > High then
- Reference (Empty_Shared_Wide_String'Access);
- Target.Reference := Empty_Shared_Wide_String'Access;
- Unreference (TR);
-
- else
- DL := High - Low + 1;
-
- -- Try to reuse existent shared string
-
- if Can_Be_Reused (TR, DL) then
- TR.Data (1 .. DL) := SR.Data (Low .. High);
- TR.Last := DL;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- Target.Reference := DR;
- Unreference (TR);
- end if;
- end if;
- end Unbounded_Slice;
-
- -----------------
- -- Unreference --
- -----------------
-
- procedure Unreference (Item : not null Shared_Wide_String_Access) is
-
- procedure Free is
- new Ada.Unchecked_Deallocation
- (Shared_Wide_String, Shared_Wide_String_Access);
-
- Aux : Shared_Wide_String_Access := Item;
-
- begin
- if System.Atomic_Counters.Decrement (Aux.Counter) then
-
- -- Reference counter of Empty_Shared_Wide_String must never reach
- -- zero.
-
- pragma Assert (Aux /= Empty_Shared_Wide_String'Access);
-
- Free (Aux);
- end if;
- end Unreference;
-
-end Ada.Strings.Wide_Unbounded;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S T R I N G S . W I D E _ U N B O U N D E D --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is supported on:
--- - all Alpha platforms
--- - all ia64 platforms
--- - all PowerPC platforms
--- - all SPARC V9 platforms
--- - all x86 platforms
--- - all x86_64 platforms
-
-with Ada.Strings.Wide_Maps;
-private with Ada.Finalization;
-private with System.Atomic_Counters;
-
-package Ada.Strings.Wide_Unbounded is
- pragma Preelaborate;
-
- type Unbounded_Wide_String is private;
- pragma Preelaborable_Initialization (Unbounded_Wide_String);
-
- Null_Unbounded_Wide_String : constant Unbounded_Wide_String;
-
- function Length (Source : Unbounded_Wide_String) return Natural;
-
- type Wide_String_Access is access all Wide_String;
-
- procedure Free (X : in out Wide_String_Access);
-
- --------------------------------------------------------
- -- Conversion, Concatenation, and Selection Functions --
- --------------------------------------------------------
-
- function To_Unbounded_Wide_String
- (Source : Wide_String) return Unbounded_Wide_String;
-
- function To_Unbounded_Wide_String
- (Length : Natural) return Unbounded_Wide_String;
-
- function To_Wide_String
- (Source : Unbounded_Wide_String) return Wide_String;
-
- procedure Set_Unbounded_Wide_String
- (Target : out Unbounded_Wide_String;
- Source : Wide_String);
- pragma Ada_05 (Set_Unbounded_Wide_String);
-
- procedure Append
- (Source : in out Unbounded_Wide_String;
- New_Item : Unbounded_Wide_String);
-
- procedure Append
- (Source : in out Unbounded_Wide_String;
- New_Item : Wide_String);
-
- procedure Append
- (Source : in out Unbounded_Wide_String;
- New_Item : Wide_Character);
-
- function "&"
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Unbounded_Wide_String;
-
- function "&"
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Unbounded_Wide_String;
-
- function "&"
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Unbounded_Wide_String;
-
- function "&"
- (Left : Unbounded_Wide_String;
- Right : Wide_Character) return Unbounded_Wide_String;
-
- function "&"
- (Left : Wide_Character;
- Right : Unbounded_Wide_String) return Unbounded_Wide_String;
-
- function Element
- (Source : Unbounded_Wide_String;
- Index : Positive) return Wide_Character;
-
- procedure Replace_Element
- (Source : in out Unbounded_Wide_String;
- Index : Positive;
- By : Wide_Character);
-
- function Slice
- (Source : Unbounded_Wide_String;
- Low : Positive;
- High : Natural) return Wide_String;
-
- function Unbounded_Slice
- (Source : Unbounded_Wide_String;
- Low : Positive;
- High : Natural) return Unbounded_Wide_String;
- pragma Ada_05 (Unbounded_Slice);
-
- procedure Unbounded_Slice
- (Source : Unbounded_Wide_String;
- Target : out Unbounded_Wide_String;
- Low : Positive;
- High : Natural);
- pragma Ada_05 (Unbounded_Slice);
-
- function "="
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Boolean;
-
- function "="
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Boolean;
-
- function "="
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Boolean;
-
- function "<"
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Boolean;
-
- function "<"
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Boolean;
-
- function "<"
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Boolean;
-
- function "<="
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Boolean;
-
- function "<="
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Boolean;
-
- function "<="
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Boolean;
-
- function ">"
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Boolean;
-
- function ">"
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Boolean;
-
- function ">"
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Boolean;
-
- function ">="
- (Left : Unbounded_Wide_String;
- Right : Unbounded_Wide_String) return Boolean;
-
- function ">="
- (Left : Unbounded_Wide_String;
- Right : Wide_String) return Boolean;
-
- function ">="
- (Left : Wide_String;
- Right : Unbounded_Wide_String) return Boolean;
-
- ------------------------
- -- Search Subprograms --
- ------------------------
-
- function Index
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- Going : Direction := Forward;
- Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
- return Natural;
-
- function Index
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- Going : Direction := Forward;
- Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural;
-
- function Index
- (Source : Unbounded_Wide_String;
- Set : Wide_Maps.Wide_Character_Set;
- Test : Membership := Inside;
- Going : Direction := Forward) return Natural;
-
- function Index
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
- return Natural;
- pragma Ada_05 (Index);
-
- function Index
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural;
- pragma Ada_05 (Index);
-
- function Index
- (Source : Unbounded_Wide_String;
- Set : Wide_Maps.Wide_Character_Set;
- From : Positive;
- Test : Membership := Inside;
- Going : Direction := Forward) return Natural;
- pragma Ada_05 (Index);
-
- function Index_Non_Blank
- (Source : Unbounded_Wide_String;
- Going : Direction := Forward) return Natural;
-
- function Index_Non_Blank
- (Source : Unbounded_Wide_String;
- From : Positive;
- Going : Direction := Forward) return Natural;
- pragma Ada_05 (Index_Non_Blank);
-
- function Count
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
- return Natural;
-
- function Count
- (Source : Unbounded_Wide_String;
- Pattern : Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural;
-
- function Count
- (Source : Unbounded_Wide_String;
- Set : Wide_Maps.Wide_Character_Set) return Natural;
-
- procedure Find_Token
- (Source : Unbounded_Wide_String;
- Set : Wide_Maps.Wide_Character_Set;
- From : Positive;
- Test : Membership;
- First : out Positive;
- Last : out Natural);
- pragma Ada_2012 (Find_Token);
-
- procedure Find_Token
- (Source : Unbounded_Wide_String;
- Set : Wide_Maps.Wide_Character_Set;
- Test : Membership;
- First : out Positive;
- Last : out Natural);
-
- ------------------------------------
- -- String Translation Subprograms --
- ------------------------------------
-
- function Translate
- (Source : Unbounded_Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping)
- return Unbounded_Wide_String;
-
- procedure Translate
- (Source : in out Unbounded_Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping);
-
- function Translate
- (Source : Unbounded_Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping_Function)
- return Unbounded_Wide_String;
-
- procedure Translate
- (Source : in out Unbounded_Wide_String;
- Mapping : Wide_Maps.Wide_Character_Mapping_Function);
-
- ---------------------------------------
- -- String Transformation Subprograms --
- ---------------------------------------
-
- function Replace_Slice
- (Source : Unbounded_Wide_String;
- Low : Positive;
- High : Natural;
- By : Wide_String) return Unbounded_Wide_String;
-
- procedure Replace_Slice
- (Source : in out Unbounded_Wide_String;
- Low : Positive;
- High : Natural;
- By : Wide_String);
-
- function Insert
- (Source : Unbounded_Wide_String;
- Before : Positive;
- New_Item : Wide_String) return Unbounded_Wide_String;
-
- procedure Insert
- (Source : in out Unbounded_Wide_String;
- Before : Positive;
- New_Item : Wide_String);
-
- function Overwrite
- (Source : Unbounded_Wide_String;
- Position : Positive;
- New_Item : Wide_String) return Unbounded_Wide_String;
-
- procedure Overwrite
- (Source : in out Unbounded_Wide_String;
- Position : Positive;
- New_Item : Wide_String);
-
- function Delete
- (Source : Unbounded_Wide_String;
- From : Positive;
- Through : Natural) return Unbounded_Wide_String;
-
- procedure Delete
- (Source : in out Unbounded_Wide_String;
- From : Positive;
- Through : Natural);
-
- function Trim
- (Source : Unbounded_Wide_String;
- Side : Trim_End) return Unbounded_Wide_String;
-
- procedure Trim
- (Source : in out Unbounded_Wide_String;
- Side : Trim_End);
-
- function Trim
- (Source : Unbounded_Wide_String;
- Left : Wide_Maps.Wide_Character_Set;
- Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String;
-
- procedure Trim
- (Source : in out Unbounded_Wide_String;
- Left : Wide_Maps.Wide_Character_Set;
- Right : Wide_Maps.Wide_Character_Set);
-
- function Head
- (Source : Unbounded_Wide_String;
- Count : Natural;
- Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String;
-
- procedure Head
- (Source : in out Unbounded_Wide_String;
- Count : Natural;
- Pad : Wide_Character := Wide_Space);
-
- function Tail
- (Source : Unbounded_Wide_String;
- Count : Natural;
- Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String;
-
- procedure Tail
- (Source : in out Unbounded_Wide_String;
- Count : Natural;
- Pad : Wide_Character := Wide_Space);
-
- function "*"
- (Left : Natural;
- Right : Wide_Character) return Unbounded_Wide_String;
-
- function "*"
- (Left : Natural;
- Right : Wide_String) return Unbounded_Wide_String;
-
- function "*"
- (Left : Natural;
- Right : Unbounded_Wide_String) return Unbounded_Wide_String;
-
-private
- pragma Inline (Length);
-
- package AF renames Ada.Finalization;
-
- type Shared_Wide_String (Max_Length : Natural) is limited record
- Counter : System.Atomic_Counters.Atomic_Counter;
- -- Reference counter
-
- Last : Natural := 0;
- Data : Wide_String (1 .. Max_Length);
- -- Last is the index of last significant element of the Data. All
- -- elements with larger indexes are just extra room for expansion.
- end record;
-
- type Shared_Wide_String_Access is access all Shared_Wide_String;
-
- procedure Reference (Item : not null Shared_Wide_String_Access);
- -- Increment reference counter.
-
- procedure Unreference (Item : not null Shared_Wide_String_Access);
- -- Decrement reference counter. Deallocate Item when ref counter is zero
-
- function Can_Be_Reused
- (Item : Shared_Wide_String_Access;
- Length : Natural) return Boolean;
- -- Returns True if Shared_Wide_String can be reused. There are two criteria
- -- when Shared_Wide_String can be reused: its reference counter must be one
- -- (thus Shared_Wide_String is owned exclusively) and its size is
- -- sufficient to store string with specified length effectively.
-
- function Allocate (Max_Length : Natural) return Shared_Wide_String_Access;
- -- Allocates new Shared_Wide_String with at least specified maximum length.
- -- Actual maximum length of the allocated Shared_Wide_String can be
- -- slightly greater. Returns reference to Empty_Shared_Wide_String when
- -- requested length is zero.
-
- Empty_Shared_Wide_String : aliased Shared_Wide_String (0);
-
- function To_Unbounded (S : Wide_String) return Unbounded_Wide_String
- renames To_Unbounded_Wide_String;
- -- This renames are here only to be used in the pragma Stream_Convert
-
- type Unbounded_Wide_String is new AF.Controlled with record
- Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access;
- end record;
-
- -- The Unbounded_Wide_String uses several techniques to increase speed of
- -- the application:
-
- -- - implicit sharing or copy-on-write. Unbounded_Wide_String contains
- -- only the reference to the data which is shared between several
- -- instances. The shared data is reallocated only when its value is
- -- changed and the object mutation can't be used or it is inefficient to
- -- use it;
-
- -- - object mutation. Shared data object can be reused without memory
- -- reallocation when all of the following requirements are meat:
- -- - shared data object don't used anywhere longer;
- -- - its size is sufficient to store new value;
- -- - the gap after reuse is less than some threshold.
-
- -- - memory preallocation. Most of used memory allocation algorithms
- -- aligns allocated segment on the some boundary, thus some amount of
- -- additional memory can be preallocated without any impact. Such
- -- preallocated memory can used later by Append/Insert operations
- -- without reallocation.
-
- -- Reference counting uses GCC builtin atomic operations, which allows safe
- -- sharing of internal data between Ada tasks. Nevertheless, this does not
- -- make objects of Unbounded_String thread-safe: an instance cannot be
- -- accessed by several tasks simultaneously.
-
- pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded, To_Wide_String);
- -- Provide stream routines without dragging in Ada.Streams
-
- pragma Finalize_Storage_Only (Unbounded_Wide_String);
- -- Finalization is required only for freeing storage
-
- overriding procedure Initialize (Object : in out Unbounded_Wide_String);
- overriding procedure Adjust (Object : in out Unbounded_Wide_String);
- overriding procedure Finalize (Object : in out Unbounded_Wide_String);
-
- Null_Unbounded_Wide_String : constant Unbounded_Wide_String :=
- (AF.Controlled with
- Reference =>
- Empty_Shared_Wide_String'Access);
-
-end Ada.Strings.Wide_Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Wide_Search;
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Strings.Wide_Unbounded is
+
+ use Ada.Strings.Wide_Maps;
+
+ Growth_Factor : constant := 32;
+ -- The growth factor controls how much extra space is allocated when
+ -- we have to increase the size of an allocated unbounded string. By
+ -- allocating extra space, we avoid the need to reallocate on every
+ -- append, particularly important when a string is built up by repeated
+ -- append operations of small pieces. This is expressed as a factor so
+ -- 32 means add 1/32 of the length of the string as growth space.
+
+ Min_Mul_Alloc : constant := Standard'Maximum_Alignment;
+ -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes
+ -- no memory loss as most (all?) malloc implementations are obliged to
+ -- align the returned memory on the maximum alignment as malloc does not
+ -- know the target alignment.
+
+ function Aligned_Max_Length (Max_Length : Natural) return Natural;
+ -- Returns recommended length of the shared string which is greater or
+ -- equal to specified length. Calculation take in sense alignment of
+ -- the allocated memory segments to use memory effectively by
+ -- Append/Insert/etc operations.
+
+ ---------
+ -- "&" --
+ ---------
+
+ function "&"
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Unbounded_Wide_String
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+ DL : constant Natural := LR.Last + RR.Last;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Left string is empty, return Rigth string
+
+ elsif LR.Last = 0 then
+ Reference (RR);
+ DR := RR;
+
+ -- Right string is empty, return Left string
+
+ elsif RR.Last = 0 then
+ Reference (LR);
+ DR := LR;
+
+ -- Overwise, allocate new shared string and fill data
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
+ DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Unbounded_Wide_String
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ DL : constant Natural := LR.Last + Right'Length;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Right is an empty string, return Left string
+
+ elsif Right'Length = 0 then
+ Reference (LR);
+ DR := LR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
+ DR.Data (LR.Last + 1 .. DL) := Right;
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Unbounded_Wide_String
+ is
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+ DL : constant Natural := Left'Length + RR.Last;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared one
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Left is empty string, return Right string
+
+ elsif Left'Length = 0 then
+ Reference (RR);
+ DR := RR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Left'Length) := Left;
+ DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : Unbounded_Wide_String;
+ Right : Wide_Character) return Unbounded_Wide_String
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ DL : constant Natural := LR.Last + 1;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ DR := Allocate (DL);
+ DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
+ DR.Data (DL) := Right;
+ DR.Last := DL;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : Wide_Character;
+ Right : Unbounded_Wide_String) return Unbounded_Wide_String
+ is
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+ DL : constant Natural := 1 + RR.Last;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ DR := Allocate (DL);
+ DR.Data (1) := Left;
+ DR.Data (2 .. DL) := RR.Data (1 .. RR.Last);
+ DR.Last := DL;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Character) return Unbounded_Wide_String
+ is
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if Left = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (Left);
+
+ for J in 1 .. Left loop
+ DR.Data (J) := Right;
+ end loop;
+
+ DR.Last := Left;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_String) return Unbounded_Wide_String
+ is
+ DL : constant Natural := Left * Right'Length;
+ DR : Shared_Wide_String_Access;
+ K : Positive;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ K := 1;
+
+ for J in 1 .. Left loop
+ DR.Data (K .. K + Right'Length - 1) := Right;
+ K := K + Right'Length;
+ end loop;
+
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Unbounded_Wide_String) return Unbounded_Wide_String
+ is
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+ DL : constant Natural := Left * RR.Last;
+ DR : Shared_Wide_String_Access;
+ K : Positive;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Coefficient is one, just return string itself
+
+ elsif Left = 1 then
+ Reference (RR);
+ DR := RR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ K := 1;
+
+ for J in 1 .. Left loop
+ DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last);
+ K := K + RR.Last;
+ end loop;
+
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "*";
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<"
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last);
+ end "<";
+
+ function "<"
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) < Right;
+ end "<";
+
+ function "<"
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Boolean
+ is
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+ begin
+ return Left < RR.Data (1 .. RR.Last);
+ end "<";
+
+ ----------
+ -- "<=" --
+ ----------
+
+ function "<="
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+
+ begin
+ -- LR = RR means two strings shares shared string, thus they are equal
+
+ return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last);
+ end "<=";
+
+ function "<="
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) <= Right;
+ end "<=";
+
+ function "<="
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Boolean
+ is
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+ begin
+ return Left <= RR.Data (1 .. RR.Last);
+ end "<=";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "="
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+
+ begin
+ return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last);
+ -- LR = RR means two strings shares shared string, thus they are equal
+ end "=";
+
+ function "="
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) = Right;
+ end "=";
+
+ function "="
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Boolean
+ is
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+ begin
+ return Left = RR.Data (1 .. RR.Last);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">"
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last);
+ end ">";
+
+ function ">"
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) > Right;
+ end ">";
+
+ function ">"
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Boolean
+ is
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+ begin
+ return Left > RR.Data (1 .. RR.Last);
+ end ">";
+
+ ----------
+ -- ">=" --
+ ----------
+
+ function ">="
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+
+ begin
+ -- LR = RR means two strings shares shared string, thus they are equal
+
+ return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last);
+ end ">=";
+
+ function ">="
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) >= Right;
+ end ">=";
+
+ function ">="
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Boolean
+ is
+ RR : constant Shared_Wide_String_Access := Right.Reference;
+ begin
+ return Left >= RR.Data (1 .. RR.Last);
+ end ">=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Object : in out Unbounded_Wide_String) is
+ begin
+ Reference (Object.Reference);
+ end Adjust;
+
+ ------------------------
+ -- Aligned_Max_Length --
+ ------------------------
+
+ function Aligned_Max_Length (Max_Length : Natural) return Natural is
+ Static_Size : constant Natural :=
+ Empty_Shared_Wide_String'Size / Standard'Storage_Unit;
+ -- Total size of all static components
+
+ Element_Size : constant Natural :=
+ Wide_Character'Size / Standard'Storage_Unit;
+
+ begin
+ return
+ (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2)
+ * Min_Mul_Alloc - Static_Size) / Element_Size;
+ end Aligned_Max_Length;
+
+ --------------
+ -- Allocate --
+ --------------
+
+ function Allocate (Max_Length : Natural) return Shared_Wide_String_Access is
+ begin
+ -- Empty string requested, return shared empty string
+
+ if Max_Length = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ return Empty_Shared_Wide_String'Access;
+
+ -- Otherwise, allocate requested space (and probably some more room)
+
+ else
+ return new Shared_Wide_String (Aligned_Max_Length (Max_Length));
+ end if;
+ end Allocate;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : Unbounded_Wide_String)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ NR : constant Shared_Wide_String_Access := New_Item.Reference;
+ DL : constant Natural := SR.Last + NR.Last;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Source is an empty string, reuse New_Item data
+
+ if SR.Last = 0 then
+ Reference (NR);
+ Source.Reference := NR;
+ Unreference (SR);
+
+ -- New_Item is empty string, nothing to do
+
+ elsif NR.Last = 0 then
+ null;
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new one and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : Wide_String)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + New_Item'Length;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- New_Item is an empty string, nothing to do
+
+ if New_Item'Length = 0 then
+ null;
+
+ -- Try to reuse existing shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (SR.Last + 1 .. DL) := New_Item;
+ SR.Last := DL;
+
+ -- Otherwise, allocate new one and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (SR.Last + 1 .. DL) := New_Item;
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : Wide_Character)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + 1;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Try to reuse existing shared string
+
+ if Can_Be_Reused (SR, SR.Last + 1) then
+ SR.Data (SR.Last + 1) := New_Item;
+ SR.Last := SR.Last + 1;
+
+ -- Otherwise, allocate new one and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (DL) := New_Item;
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Append;
+
+ -------------------
+ -- Can_Be_Reused --
+ -------------------
+
+ function Can_Be_Reused
+ (Item : Shared_Wide_String_Access;
+ Length : Natural) return Boolean is
+ begin
+ return
+ System.Atomic_Counters.Is_One (Item.Counter)
+ and then Item.Max_Length >= Length
+ and then Item.Max_Length <=
+ Aligned_Max_Length (Length + Length / Growth_Factor);
+ end Can_Be_Reused;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set) return Natural
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Search.Count (SR.Data (1 .. SR.Last), Set);
+ end Count;
+
+ ------------
+ -- Delete --
+ ------------
+
+ function Delete
+ (Source : Unbounded_Wide_String;
+ From : Positive;
+ Through : Natural) return Unbounded_Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Empty slice is deleted, use the same shared string
+
+ if From > Through then
+ Reference (SR);
+ DR := SR;
+
+ -- Index is out of range
+
+ elsif Through > SR.Last then
+ raise Index_Error;
+
+ -- Compute size of the result
+
+ else
+ DL := SR.Last - (Through - From + 1);
+
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
+ DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
+ DR.Last := DL;
+ end if;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Delete;
+
+ procedure Delete
+ (Source : in out Unbounded_Wide_String;
+ From : Positive;
+ Through : Natural)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Nothing changed, return
+
+ if From > Through then
+ null;
+
+ -- Through is outside of the range
+
+ elsif Through > SR.Last then
+ raise Index_Error;
+
+ else
+ DL := SR.Last - (Through - From + 1);
+
+ -- Result is empty, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_String'Access;
+ Unreference (SR);
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
+ DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end if;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element
+ (Source : Unbounded_Wide_String;
+ Index : Positive) return Wide_Character
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ if Index <= SR.Last then
+ return SR.Data (Index);
+ else
+ raise Index_Error;
+ end if;
+ end Element;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Unbounded_Wide_String) is
+ SR : constant Shared_Wide_String_Access := Object.Reference;
+
+ begin
+ if SR /= null then
+
+ -- The same controlled object can be finalized several times for
+ -- some reason. As per 7.6.1(24) this should have no ill effect,
+ -- so we need to add a guard for the case of finalizing the same
+ -- object twice.
+
+ Object.Reference := null;
+ Unreference (SR);
+ end if;
+ end Finalize;
+
+ ----------------
+ -- Find_Token --
+ ----------------
+
+ procedure Find_Token
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ From : Positive;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ Wide_Search.Find_Token
+ (SR.Data (From .. SR.Last), Set, Test, First, Last);
+ end Find_Token;
+
+ procedure Find_Token
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ Wide_Search.Find_Token
+ (SR.Data (1 .. SR.Last), Set, Test, First, Last);
+ end Find_Token;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Wide_String_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access);
+ begin
+ Deallocate (X);
+ end Free;
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head
+ (Source : Unbounded_Wide_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Result is empty, reuse shared empty string
+
+ if Count = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Length of the string is the same as requested, reuse source shared
+ -- string.
+
+ elsif Count = SR.Last then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+
+ -- Length of the source string is more than requested, copy
+ -- corresponding slice.
+
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (1 .. Count);
+
+ -- Length of the source string is less than requested, copy all
+ -- contents and fill others by Pad character.
+
+ else
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+
+ for J in SR.Last + 1 .. Count loop
+ DR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ DR.Last := Count;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Head;
+
+ procedure Head
+ (Source : in out Unbounded_Wide_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Result is empty, reuse empty shared string
+
+ if Count = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_String'Access;
+ Unreference (SR);
+
+ -- Result is same with source string, reuse source shared string
+
+ elsif Count = SR.Last then
+ null;
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, Count) then
+ if Count > SR.Last then
+ for J in SR.Last + 1 .. Count loop
+ SR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ SR.Last := Count;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+
+ -- Length of the source string is greater than requested, copy
+ -- corresponding slice.
+
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (1 .. Count);
+
+ -- Length of the source string is less than requested, copy all
+ -- exists data and fill others by Pad character.
+
+ else
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+
+ for J in SR.Last + 1 .. Count loop
+ DR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ DR.Last := Count;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Head;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Going : Strings.Direction := Strings.Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Search.Index
+ (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Search.Index
+ (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Strings.Membership := Strings.Inside;
+ Going : Strings.Direction := Strings.Forward) return Natural
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Search.Index
+ (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Search.Index
+ (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Search.Index
+ (SR.Data (1 .. SR.Last), Set, From, Test, Going);
+ end Index;
+
+ ---------------------
+ -- Index_Non_Blank --
+ ---------------------
+
+ function Index_Non_Blank
+ (Source : Unbounded_Wide_String;
+ Going : Strings.Direction := Strings.Forward) return Natural
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going);
+ end Index_Non_Blank;
+
+ function Index_Non_Blank
+ (Source : Unbounded_Wide_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Search.Index_Non_Blank
+ (SR.Data (1 .. SR.Last), From, Going);
+ end Index_Non_Blank;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Object : in out Unbounded_Wide_String) is
+ begin
+ Reference (Object.Reference);
+ end Initialize;
+
+ ------------
+ -- Insert --
+ ------------
+
+ function Insert
+ (Source : Unbounded_Wide_String;
+ Before : Positive;
+ New_Item : Wide_String) return Unbounded_Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + New_Item'Length;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Check index first
+
+ if Before > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Result is empty, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Inserted string is empty, reuse source shared string
+
+ elsif New_Item'Length = 0 then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
+ DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
+ DR.Data (Before + New_Item'Length .. DL) :=
+ SR.Data (Before .. SR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Insert;
+
+ procedure Insert
+ (Source : in out Unbounded_Wide_String;
+ Before : Positive;
+ New_Item : Wide_String)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + New_Item'Length;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Before > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_String'Access;
+ Unreference (SR);
+
+ -- Inserted string is empty, nothing to do
+
+ elsif New_Item'Length = 0 then
+ null;
+
+ -- Try to reuse existent shared string first
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (Before + New_Item'Length .. DL) :=
+ SR.Data (Before .. SR.Last);
+ SR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
+ DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
+ DR.Data (Before + New_Item'Length .. DL) :=
+ SR.Data (Before .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Insert;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Source : Unbounded_Wide_String) return Natural is
+ begin
+ return Source.Reference.Last;
+ end Length;
+
+ ---------------
+ -- Overwrite --
+ ---------------
+
+ function Overwrite
+ (Source : Unbounded_Wide_String;
+ Position : Positive;
+ New_Item : Wide_String) return Unbounded_Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Position > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Result is same with source string, reuse source shared string
+
+ elsif New_Item'Length = 0 then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
+ DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
+ DR.Data (Position + New_Item'Length .. DL) :=
+ SR.Data (Position + New_Item'Length .. SR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Overwrite;
+
+ procedure Overwrite
+ (Source : in out Unbounded_Wide_String;
+ Position : Positive;
+ New_Item : Wide_String)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Bounds check
+
+ if Position > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_String'Access;
+ Unreference (SR);
+
+ -- String unchanged, nothing to do
+
+ elsif New_Item'Length = 0 then
+ null;
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
+ SR.Last := DL;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
+ DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
+ DR.Data (Position + New_Item'Length .. DL) :=
+ SR.Data (Position + New_Item'Length .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Overwrite;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ procedure Reference (Item : not null Shared_Wide_String_Access) is
+ begin
+ System.Atomic_Counters.Increment (Item.Counter);
+ end Reference;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Source : in out Unbounded_Wide_String;
+ Index : Positive;
+ By : Wide_Character)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Bounds check
+
+ if Index <= SR.Last then
+
+ -- Try to reuse existent shared string
+
+ if Can_Be_Reused (SR, SR.Last) then
+ SR.Data (Index) := By;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (Index) := By;
+ DR.Last := SR.Last;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+
+ else
+ raise Index_Error;
+ end if;
+ end Replace_Element;
+
+ -------------------
+ -- Replace_Slice --
+ -------------------
+
+ function Replace_Slice
+ (Source : Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_String) return Unbounded_Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Low > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Do replace operation when removed slice is not empty
+
+ if High >= Low then
+ DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
+ -- This is the number of characters remaining in the string after
+ -- replacing the slice.
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
+ DR.Data (Low .. Low + By'Length - 1) := By;
+ DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+
+ -- Otherwise just insert string
+
+ else
+ return Insert (Source, Low, By);
+ end if;
+ end Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_String)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Bounds check
+
+ if Low > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Do replace operation only when replaced slice is not empty
+
+ if High >= Low then
+ DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
+ -- This is the number of characters remaining in the string after
+ -- replacing the slice.
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_String'Access;
+ Unreference (SR);
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
+ SR.Data (Low .. Low + By'Length - 1) := By;
+ SR.Last := DL;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
+ DR.Data (Low .. Low + By'Length - 1) := By;
+ DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+
+ -- Otherwise just insert item
+
+ else
+ Insert (Source, Low, By);
+ end if;
+ end Replace_Slice;
+
+ -------------------------------
+ -- Set_Unbounded_Wide_String --
+ -------------------------------
+
+ procedure Set_Unbounded_Wide_String
+ (Target : out Unbounded_Wide_String;
+ Source : Wide_String)
+ is
+ TR : constant Shared_Wide_String_Access := Target.Reference;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- In case of empty string, reuse empty shared string
+
+ if Source'Length = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ Target.Reference := Empty_Shared_Wide_String'Access;
+
+ else
+ -- Try to reuse existent shared string
+
+ if Can_Be_Reused (TR, Source'Length) then
+ Reference (TR);
+ DR := TR;
+
+ -- Otherwise allocate new shared string
+
+ else
+ DR := Allocate (Source'Length);
+ Target.Reference := DR;
+ end if;
+
+ DR.Data (1 .. Source'Length) := Source;
+ DR.Last := Source'Length;
+ end if;
+
+ Unreference (TR);
+ end Set_Unbounded_Wide_String;
+
+ -----------
+ -- Slice --
+ -----------
+
+ function Slice
+ (Source : Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural) return Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+
+ begin
+ -- Note: test of High > Length is in accordance with AI95-00128
+
+ if Low > SR.Last + 1 or else High > SR.Last then
+ raise Index_Error;
+
+ else
+ return SR.Data (Low .. High);
+ end if;
+ end Slice;
+
+ ----------
+ -- Tail --
+ ----------
+
+ function Tail
+ (Source : Unbounded_Wide_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- For empty result reuse empty shared string
+
+ if Count = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Result is hole source string, reuse source shared string
+
+ elsif Count = SR.Last then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
+
+ else
+ for J in 1 .. Count - SR.Last loop
+ DR.Data (J) := Pad;
+ end loop;
+
+ DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
+ end if;
+
+ DR.Last := Count;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Tail;
+
+ procedure Tail
+ (Source : in out Unbounded_Wide_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_String_Access;
+
+ procedure Common
+ (SR : Shared_Wide_String_Access;
+ DR : Shared_Wide_String_Access;
+ Count : Natural);
+ -- Common code of tail computation. SR/DR can point to the same object
+
+ ------------
+ -- Common --
+ ------------
+
+ procedure Common
+ (SR : Shared_Wide_String_Access;
+ DR : Shared_Wide_String_Access;
+ Count : Natural) is
+ begin
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
+
+ else
+ DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
+
+ for J in 1 .. Count - SR.Last loop
+ DR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ DR.Last := Count;
+ end Common;
+
+ begin
+ -- Result is empty string, reuse empty shared string
+
+ if Count = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_String'Access;
+ Unreference (SR);
+
+ -- Length of the result is the same with length of the source string,
+ -- reuse source shared string.
+
+ elsif Count = SR.Last then
+ null;
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, Count) then
+ Common (SR, SR, Count);
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+ Common (SR, DR, Count);
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Tail;
+
+ --------------------
+ -- To_Wide_String --
+ --------------------
+
+ function To_Wide_String
+ (Source : Unbounded_Wide_String) return Wide_String is
+ begin
+ return Source.Reference.Data (1 .. Source.Reference.Last);
+ end To_Wide_String;
+
+ ------------------------------
+ -- To_Unbounded_Wide_String --
+ ------------------------------
+
+ function To_Unbounded_Wide_String
+ (Source : Wide_String) return Unbounded_Wide_String
+ is
+ DR : Shared_Wide_String_Access;
+
+ begin
+ if Source'Length = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ else
+ DR := Allocate (Source'Length);
+ DR.Data (1 .. Source'Length) := Source;
+ DR.Last := Source'Length;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end To_Unbounded_Wide_String;
+
+ function To_Unbounded_Wide_String
+ (Length : Natural) return Unbounded_Wide_String
+ is
+ DR : Shared_Wide_String_Access;
+
+ begin
+ if Length = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ else
+ DR := Allocate (Length);
+ DR.Last := Length;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end To_Unbounded_Wide_String;
+
+ ---------------
+ -- Translate --
+ ---------------
+
+ function Translate
+ (Source : Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping) return Unbounded_Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Nothing to translate, reuse empty shared string
+
+ if SR.Last = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Value (Mapping, SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Nothing to translate
+
+ if SR.Last = 0 then
+ null;
+
+ -- Try to reuse shared string
+
+ elsif Can_Be_Reused (SR, SR.Last) then
+ for J in 1 .. SR.Last loop
+ SR.Data (J) := Value (Mapping, SR.Data (J));
+ end loop;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Value (Mapping, SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Translate;
+
+ function Translate
+ (Source : Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
+ return Unbounded_Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Nothing to translate, reuse empty shared string
+
+ if SR.Last = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Mapping.all (SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+
+ exception
+ when others =>
+ Unreference (DR);
+
+ raise;
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Nothing to translate
+
+ if SR.Last = 0 then
+ null;
+
+ -- Try to reuse shared string
+
+ elsif Can_Be_Reused (SR, SR.Last) then
+ for J in 1 .. SR.Last loop
+ SR.Data (J) := Mapping.all (SR.Data (J));
+ end loop;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Mapping.all (SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+
+ exception
+ when others =>
+ if DR /= null then
+ Unreference (DR);
+ end if;
+
+ raise;
+ end Translate;
+
+ ----------
+ -- Trim --
+ ----------
+
+ function Trim
+ (Source : Unbounded_Wide_String;
+ Side : Trim_End) return Unbounded_Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index_Non_Blank (Source, Forward);
+
+ -- All blanks, reuse empty shared string
+
+ if Low = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ else
+ case Side is
+ when Left =>
+ High := SR.Last;
+ DL := SR.Last - Low + 1;
+
+ when Right =>
+ Low := 1;
+ High := Index_Non_Blank (Source, Backward);
+ DL := High;
+
+ when Both =>
+ High := Index_Non_Blank (Source, Backward);
+ DL := High - Low + 1;
+ end case;
+
+ -- Length of the result is the same as length of the source string,
+ -- reuse source shared string.
+
+ if DL = SR.Last then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ end if;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_String;
+ Side : Trim_End)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index_Non_Blank (Source, Forward);
+
+ -- All blanks, reuse empty shared string
+
+ if Low = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_String'Access;
+ Unreference (SR);
+
+ else
+ case Side is
+ when Left =>
+ High := SR.Last;
+ DL := SR.Last - Low + 1;
+
+ when Right =>
+ Low := 1;
+ High := Index_Non_Blank (Source, Backward);
+ DL := High;
+
+ when Both =>
+ High := Index_Non_Blank (Source, Backward);
+ DL := High - Low + 1;
+ end case;
+
+ -- Length of the result is the same as length of the source string,
+ -- nothing to do.
+
+ if DL = SR.Last then
+ null;
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (1 .. DL) := SR.Data (Low .. High);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end if;
+ end Trim;
+
+ function Trim
+ (Source : Unbounded_Wide_String;
+ Left : Wide_Maps.Wide_Character_Set;
+ Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index (Source, Left, Outside, Forward);
+
+ -- Source includes only characters from Left set, reuse empty shared
+ -- string.
+
+ if Low = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ else
+ High := Index (Source, Right, Outside, Backward);
+ DL := Integer'Max (0, High - Low + 1);
+
+ -- Source includes only characters from Right set or result string
+ -- is empty, reuse empty shared string.
+
+ if High = 0 or else DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ end if;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_String;
+ Left : Wide_Maps.Wide_Character_Set;
+ Right : Wide_Maps.Wide_Character_Set)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index (Source, Left, Outside, Forward);
+
+ -- Source includes only characters from Left set, reuse empty shared
+ -- string.
+
+ if Low = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_String'Access;
+ Unreference (SR);
+
+ else
+ High := Index (Source, Right, Outside, Backward);
+ DL := Integer'Max (0, High - Low + 1);
+
+ -- Source includes only characters from Right set or result string
+ -- is empty, reuse empty shared string.
+
+ if High = 0 or else DL = 0 then
+ Reference (Empty_Shared_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_String'Access;
+ Unreference (SR);
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (1 .. DL) := SR.Data (Low .. High);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end if;
+ end Trim;
+
+ ---------------------
+ -- Unbounded_Slice --
+ ---------------------
+
+ function Unbounded_Slice
+ (Source : Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural) return Unbounded_Wide_String
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Low > SR.Last + 1 or else High > SR.Last then
+ raise Index_Error;
+
+ -- Result is empty slice, reuse empty shared string
+
+ elsif Low > High then
+ Reference (Empty_Shared_Wide_String'Access);
+ DR := Empty_Shared_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DL := High - Low + 1;
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Unbounded_Slice;
+
+ procedure Unbounded_Slice
+ (Source : Unbounded_Wide_String;
+ Target : out Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural)
+ is
+ SR : constant Shared_Wide_String_Access := Source.Reference;
+ TR : constant Shared_Wide_String_Access := Target.Reference;
+ DL : Natural;
+ DR : Shared_Wide_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Low > SR.Last + 1 or else High > SR.Last then
+ raise Index_Error;
+
+ -- Result is empty slice, reuse empty shared string
+
+ elsif Low > High then
+ Reference (Empty_Shared_Wide_String'Access);
+ Target.Reference := Empty_Shared_Wide_String'Access;
+ Unreference (TR);
+
+ else
+ DL := High - Low + 1;
+
+ -- Try to reuse existent shared string
+
+ if Can_Be_Reused (TR, DL) then
+ TR.Data (1 .. DL) := SR.Data (Low .. High);
+ TR.Last := DL;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ Target.Reference := DR;
+ Unreference (TR);
+ end if;
+ end if;
+ end Unbounded_Slice;
+
+ -----------------
+ -- Unreference --
+ -----------------
+
+ procedure Unreference (Item : not null Shared_Wide_String_Access) is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation
+ (Shared_Wide_String, Shared_Wide_String_Access);
+
+ Aux : Shared_Wide_String_Access := Item;
+
+ begin
+ if System.Atomic_Counters.Decrement (Aux.Counter) then
+
+ -- Reference counter of Empty_Shared_Wide_String must never reach
+ -- zero.
+
+ pragma Assert (Aux /= Empty_Shared_Wide_String'Access);
+
+ Free (Aux);
+ end if;
+ end Unreference;
+
+end Ada.Strings.Wide_Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is supported on:
+-- - all Alpha platforms
+-- - all ia64 platforms
+-- - all PowerPC platforms
+-- - all SPARC V9 platforms
+-- - all x86 platforms
+-- - all x86_64 platforms
+
+with Ada.Strings.Wide_Maps;
+private with Ada.Finalization;
+private with System.Atomic_Counters;
+
+package Ada.Strings.Wide_Unbounded is
+ pragma Preelaborate;
+
+ type Unbounded_Wide_String is private;
+ pragma Preelaborable_Initialization (Unbounded_Wide_String);
+
+ Null_Unbounded_Wide_String : constant Unbounded_Wide_String;
+
+ function Length (Source : Unbounded_Wide_String) return Natural;
+
+ type Wide_String_Access is access all Wide_String;
+
+ procedure Free (X : in out Wide_String_Access);
+
+ --------------------------------------------------------
+ -- Conversion, Concatenation, and Selection Functions --
+ --------------------------------------------------------
+
+ function To_Unbounded_Wide_String
+ (Source : Wide_String) return Unbounded_Wide_String;
+
+ function To_Unbounded_Wide_String
+ (Length : Natural) return Unbounded_Wide_String;
+
+ function To_Wide_String
+ (Source : Unbounded_Wide_String) return Wide_String;
+
+ procedure Set_Unbounded_Wide_String
+ (Target : out Unbounded_Wide_String;
+ Source : Wide_String);
+ pragma Ada_05 (Set_Unbounded_Wide_String);
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : Unbounded_Wide_String);
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : Wide_String);
+
+ procedure Append
+ (Source : in out Unbounded_Wide_String;
+ New_Item : Wide_Character);
+
+ function "&"
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Unbounded_Wide_String;
+
+ function "&"
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Unbounded_Wide_String;
+
+ function "&"
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Unbounded_Wide_String;
+
+ function "&"
+ (Left : Unbounded_Wide_String;
+ Right : Wide_Character) return Unbounded_Wide_String;
+
+ function "&"
+ (Left : Wide_Character;
+ Right : Unbounded_Wide_String) return Unbounded_Wide_String;
+
+ function Element
+ (Source : Unbounded_Wide_String;
+ Index : Positive) return Wide_Character;
+
+ procedure Replace_Element
+ (Source : in out Unbounded_Wide_String;
+ Index : Positive;
+ By : Wide_Character);
+
+ function Slice
+ (Source : Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural) return Wide_String;
+
+ function Unbounded_Slice
+ (Source : Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural) return Unbounded_Wide_String;
+ pragma Ada_05 (Unbounded_Slice);
+
+ procedure Unbounded_Slice
+ (Source : Unbounded_Wide_String;
+ Target : out Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural);
+ pragma Ada_05 (Unbounded_Slice);
+
+ function "="
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Boolean;
+
+ function "="
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Boolean;
+
+ function "="
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Boolean;
+
+ function "<"
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Boolean;
+
+ function "<"
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Boolean;
+
+ function "<"
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Boolean;
+
+ function "<="
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Boolean;
+
+ function "<="
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Boolean;
+
+ function "<="
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Boolean;
+
+ function ">"
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Boolean;
+
+ function ">"
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Boolean;
+
+ function ">"
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Boolean;
+
+ function ">="
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String) return Boolean;
+
+ function ">="
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String) return Boolean;
+
+ function ">="
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String) return Boolean;
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural;
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural;
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural;
+ pragma Ada_05 (Index);
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural;
+ pragma Ada_05 (Index);
+
+ function Index
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+ pragma Ada_05 (Index);
+
+ function Index_Non_Blank
+ (Source : Unbounded_Wide_String;
+ Going : Direction := Forward) return Natural;
+
+ function Index_Non_Blank
+ (Source : Unbounded_Wide_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural;
+ pragma Ada_05 (Index_Non_Blank);
+
+ function Count
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural;
+
+ function Count
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural;
+
+ function Count
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set) return Natural;
+
+ procedure Find_Token
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ From : Positive;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+ pragma Ada_2012 (Find_Token);
+
+ procedure Find_Token
+ (Source : Unbounded_Wide_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ------------------------------------
+ -- String Translation Subprograms --
+ ------------------------------------
+
+ function Translate
+ (Source : Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping)
+ return Unbounded_Wide_String;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping);
+
+ function Translate
+ (Source : Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
+ return Unbounded_Wide_String;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function);
+
+ ---------------------------------------
+ -- String Transformation Subprograms --
+ ---------------------------------------
+
+ function Replace_Slice
+ (Source : Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_String) return Unbounded_Wide_String;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_String);
+
+ function Insert
+ (Source : Unbounded_Wide_String;
+ Before : Positive;
+ New_Item : Wide_String) return Unbounded_Wide_String;
+
+ procedure Insert
+ (Source : in out Unbounded_Wide_String;
+ Before : Positive;
+ New_Item : Wide_String);
+
+ function Overwrite
+ (Source : Unbounded_Wide_String;
+ Position : Positive;
+ New_Item : Wide_String) return Unbounded_Wide_String;
+
+ procedure Overwrite
+ (Source : in out Unbounded_Wide_String;
+ Position : Positive;
+ New_Item : Wide_String);
+
+ function Delete
+ (Source : Unbounded_Wide_String;
+ From : Positive;
+ Through : Natural) return Unbounded_Wide_String;
+
+ procedure Delete
+ (Source : in out Unbounded_Wide_String;
+ From : Positive;
+ Through : Natural);
+
+ function Trim
+ (Source : Unbounded_Wide_String;
+ Side : Trim_End) return Unbounded_Wide_String;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_String;
+ Side : Trim_End);
+
+ function Trim
+ (Source : Unbounded_Wide_String;
+ Left : Wide_Maps.Wide_Character_Set;
+ Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_String;
+ Left : Wide_Maps.Wide_Character_Set;
+ Right : Wide_Maps.Wide_Character_Set);
+
+ function Head
+ (Source : Unbounded_Wide_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String;
+
+ procedure Head
+ (Source : in out Unbounded_Wide_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space);
+
+ function Tail
+ (Source : Unbounded_Wide_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String;
+
+ procedure Tail
+ (Source : in out Unbounded_Wide_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space);
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Character) return Unbounded_Wide_String;
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_String) return Unbounded_Wide_String;
+
+ function "*"
+ (Left : Natural;
+ Right : Unbounded_Wide_String) return Unbounded_Wide_String;
+
+private
+ pragma Inline (Length);
+
+ package AF renames Ada.Finalization;
+
+ type Shared_Wide_String (Max_Length : Natural) is limited record
+ Counter : System.Atomic_Counters.Atomic_Counter;
+ -- Reference counter
+
+ Last : Natural := 0;
+ Data : Wide_String (1 .. Max_Length);
+ -- Last is the index of last significant element of the Data. All
+ -- elements with larger indexes are just extra room for expansion.
+ end record;
+
+ type Shared_Wide_String_Access is access all Shared_Wide_String;
+
+ procedure Reference (Item : not null Shared_Wide_String_Access);
+ -- Increment reference counter.
+
+ procedure Unreference (Item : not null Shared_Wide_String_Access);
+ -- Decrement reference counter. Deallocate Item when ref counter is zero
+
+ function Can_Be_Reused
+ (Item : Shared_Wide_String_Access;
+ Length : Natural) return Boolean;
+ -- Returns True if Shared_Wide_String can be reused. There are two criteria
+ -- when Shared_Wide_String can be reused: its reference counter must be one
+ -- (thus Shared_Wide_String is owned exclusively) and its size is
+ -- sufficient to store string with specified length effectively.
+
+ function Allocate (Max_Length : Natural) return Shared_Wide_String_Access;
+ -- Allocates new Shared_Wide_String with at least specified maximum length.
+ -- Actual maximum length of the allocated Shared_Wide_String can be
+ -- slightly greater. Returns reference to Empty_Shared_Wide_String when
+ -- requested length is zero.
+
+ Empty_Shared_Wide_String : aliased Shared_Wide_String (0);
+
+ function To_Unbounded (S : Wide_String) return Unbounded_Wide_String
+ renames To_Unbounded_Wide_String;
+ -- This renames are here only to be used in the pragma Stream_Convert
+
+ type Unbounded_Wide_String is new AF.Controlled with record
+ Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access;
+ end record;
+
+ -- The Unbounded_Wide_String uses several techniques to increase speed of
+ -- the application:
+
+ -- - implicit sharing or copy-on-write. Unbounded_Wide_String contains
+ -- only the reference to the data which is shared between several
+ -- instances. The shared data is reallocated only when its value is
+ -- changed and the object mutation can't be used or it is inefficient to
+ -- use it;
+
+ -- - object mutation. Shared data object can be reused without memory
+ -- reallocation when all of the following requirements are meat:
+ -- - shared data object don't used anywhere longer;
+ -- - its size is sufficient to store new value;
+ -- - the gap after reuse is less than some threshold.
+
+ -- - memory preallocation. Most of used memory allocation algorithms
+ -- aligns allocated segment on the some boundary, thus some amount of
+ -- additional memory can be preallocated without any impact. Such
+ -- preallocated memory can used later by Append/Insert operations
+ -- without reallocation.
+
+ -- Reference counting uses GCC builtin atomic operations, which allows safe
+ -- sharing of internal data between Ada tasks. Nevertheless, this does not
+ -- make objects of Unbounded_String thread-safe: an instance cannot be
+ -- accessed by several tasks simultaneously.
+
+ pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded, To_Wide_String);
+ -- Provide stream routines without dragging in Ada.Streams
+
+ pragma Finalize_Storage_Only (Unbounded_Wide_String);
+ -- Finalization is required only for freeing storage
+
+ overriding procedure Initialize (Object : in out Unbounded_Wide_String);
+ overriding procedure Adjust (Object : in out Unbounded_Wide_String);
+ overriding procedure Finalize (Object : in out Unbounded_Wide_String);
+
+ Null_Unbounded_Wide_String : constant Unbounded_Wide_String :=
+ (AF.Controlled with
+ Reference =>
+ Empty_Shared_Wide_String'Access);
+
+end Ada.Strings.Wide_Unbounded;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Strings.Wide_Wide_Search;
-with Ada.Unchecked_Deallocation;
-
-package body Ada.Strings.Wide_Wide_Unbounded is
-
- use Ada.Strings.Wide_Wide_Maps;
-
- Growth_Factor : constant := 32;
- -- The growth factor controls how much extra space is allocated when
- -- we have to increase the size of an allocated unbounded string. By
- -- allocating extra space, we avoid the need to reallocate on every
- -- append, particularly important when a string is built up by repeated
- -- append operations of small pieces. This is expressed as a factor so
- -- 32 means add 1/32 of the length of the string as growth space.
-
- Min_Mul_Alloc : constant := Standard'Maximum_Alignment;
- -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes
- -- no memory loss as most (all?) malloc implementations are obliged to
- -- align the returned memory on the maximum alignment as malloc does not
- -- know the target alignment.
-
- function Aligned_Max_Length (Max_Length : Natural) return Natural;
- -- Returns recommended length of the shared string which is greater or
- -- equal to specified length. Calculation take in sense alignment of
- -- the allocated memory segments to use memory effectively by
- -- Append/Insert/etc operations.
-
- ---------
- -- "&" --
- ---------
-
- function "&"
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
- DL : constant Natural := LR.Last + RR.Last;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Left string is empty, return Rigth string
-
- elsif LR.Last = 0 then
- Reference (RR);
- DR := RR;
-
- -- Right string is empty, return Left string
-
- elsif RR.Last = 0 then
- Reference (LR);
- DR := LR;
-
- -- Overwise, allocate new shared string and fill data
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
- DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Unbounded_Wide_Wide_String
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- DL : constant Natural := LR.Last + Right'Length;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Right is an empty string, return Left string
-
- elsif Right'Length = 0 then
- Reference (LR);
- DR := LR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
- DR.Data (LR.Last + 1 .. DL) := Right;
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
- is
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
- DL : constant Natural := Left'Length + RR.Last;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Result is an empty string, reuse shared one
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Left is empty string, return Right string
-
- elsif Left'Length = 0 then
- Reference (RR);
- DR := RR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Left'Length) := Left;
- DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- DL : constant Natural := LR.Last + 1;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- DR := Allocate (DL);
- DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
- DR.Data (DL) := Right;
- DR.Last := DL;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- function "&"
- (Left : Wide_Wide_Character;
- Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
- is
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
- DL : constant Natural := 1 + RR.Last;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- DR := Allocate (DL);
- DR.Data (1) := Left;
- DR.Data (2 .. DL) := RR.Data (1 .. RR.Last);
- DR.Last := DL;
-
- return (AF.Controlled with Reference => DR);
- end "&";
-
- ---------
- -- "*" --
- ---------
-
- function "*"
- (Left : Natural;
- Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String
- is
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if Left = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (Left);
-
- for J in 1 .. Left loop
- DR.Data (J) := Right;
- end loop;
-
- DR.Last := Left;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "*";
-
- function "*"
- (Left : Natural;
- Right : Wide_Wide_String) return Unbounded_Wide_Wide_String
- is
- DL : constant Natural := Left * Right'Length;
- DR : Shared_Wide_Wide_String_Access;
- K : Positive;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- K := 1;
-
- for J in 1 .. Left loop
- DR.Data (K .. K + Right'Length - 1) := Right;
- K := K + Right'Length;
- end loop;
-
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "*";
-
- function "*"
- (Left : Natural;
- Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
- is
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
- DL : constant Natural := Left * RR.Last;
- DR : Shared_Wide_Wide_String_Access;
- K : Positive;
-
- begin
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Coefficient is one, just return string itself
-
- elsif Left = 1 then
- Reference (RR);
- DR := RR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- K := 1;
-
- for J in 1 .. Left loop
- DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last);
- K := K + RR.Last;
- end loop;
-
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end "*";
-
- ---------
- -- "<" --
- ---------
-
- function "<"
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
- begin
- return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last);
- end "<";
-
- function "<"
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) < Right;
- end "<";
-
- function "<"
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean
- is
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
- begin
- return Left < RR.Data (1 .. RR.Last);
- end "<";
-
- ----------
- -- "<=" --
- ----------
-
- function "<="
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
-
- begin
- -- LR = RR means two strings shares shared string, thus they are equal
-
- return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last);
- end "<=";
-
- function "<="
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) <= Right;
- end "<=";
-
- function "<="
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean
- is
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
- begin
- return Left <= RR.Data (1 .. RR.Last);
- end "<=";
-
- ---------
- -- "=" --
- ---------
-
- function "="
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
-
- begin
- return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last);
- -- LR = RR means two strings shares shared string, thus they are equal
- end "=";
-
- function "="
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) = Right;
- end "=";
-
- function "="
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean
- is
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
- begin
- return Left = RR.Data (1 .. RR.Last);
- end "=";
-
- ---------
- -- ">" --
- ---------
-
- function ">"
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
- begin
- return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last);
- end ">";
-
- function ">"
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) > Right;
- end ">";
-
- function ">"
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean
- is
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
- begin
- return Left > RR.Data (1 .. RR.Last);
- end ">";
-
- ----------
- -- ">=" --
- ----------
-
- function ">="
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
-
- begin
- -- LR = RR means two strings shares shared string, thus they are equal
-
- return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last);
- end ">=";
-
- function ">="
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Boolean
- is
- LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
- begin
- return LR.Data (1 .. LR.Last) >= Right;
- end ">=";
-
- function ">="
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean
- is
- RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
- begin
- return Left >= RR.Data (1 .. RR.Last);
- end ">=";
-
- ------------
- -- Adjust --
- ------------
-
- procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is
- begin
- Reference (Object.Reference);
- end Adjust;
-
- ------------------------
- -- Aligned_Max_Length --
- ------------------------
-
- function Aligned_Max_Length (Max_Length : Natural) return Natural is
- Static_Size : constant Natural :=
- Empty_Shared_Wide_Wide_String'Size / Standard'Storage_Unit;
- -- Total size of all static components
-
- Element_Size : constant Natural :=
- Wide_Wide_Character'Size / Standard'Storage_Unit;
-
- begin
- return
- (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2)
- * Min_Mul_Alloc - Static_Size) / Element_Size;
- end Aligned_Max_Length;
-
- --------------
- -- Allocate --
- --------------
-
- function Allocate
- (Max_Length : Natural) return Shared_Wide_Wide_String_Access is
- begin
- -- Empty string requested, return shared empty string
-
- if Max_Length = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- return Empty_Shared_Wide_Wide_String'Access;
-
- -- Otherwise, allocate requested space (and probably some more room)
-
- else
- return new Shared_Wide_Wide_String (Aligned_Max_Length (Max_Length));
- end if;
- end Allocate;
-
- ------------
- -- Append --
- ------------
-
- procedure Append
- (Source : in out Unbounded_Wide_Wide_String;
- New_Item : Unbounded_Wide_Wide_String)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- NR : constant Shared_Wide_Wide_String_Access := New_Item.Reference;
- DL : constant Natural := SR.Last + NR.Last;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Source is an empty string, reuse New_Item data
-
- if SR.Last = 0 then
- Reference (NR);
- Source.Reference := NR;
- Unreference (SR);
-
- -- New_Item is empty string, nothing to do
-
- elsif NR.Last = 0 then
- null;
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
- SR.Last := DL;
-
- -- Otherwise, allocate new one and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Append;
-
- procedure Append
- (Source : in out Unbounded_Wide_Wide_String;
- New_Item : Wide_Wide_String)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + New_Item'Length;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- New_Item is an empty string, nothing to do
-
- if New_Item'Length = 0 then
- null;
-
- -- Try to reuse existing shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (SR.Last + 1 .. DL) := New_Item;
- SR.Last := DL;
-
- -- Otherwise, allocate new one and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (SR.Last + 1 .. DL) := New_Item;
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Append;
-
- procedure Append
- (Source : in out Unbounded_Wide_Wide_String;
- New_Item : Wide_Wide_Character)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + 1;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Try to reuse existing shared string
-
- if Can_Be_Reused (SR, SR.Last + 1) then
- SR.Data (SR.Last + 1) := New_Item;
- SR.Last := SR.Last + 1;
-
- -- Otherwise, allocate new one and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (DL) := New_Item;
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Append;
-
- -------------------
- -- Can_Be_Reused --
- -------------------
-
- function Can_Be_Reused
- (Item : Shared_Wide_Wide_String_Access;
- Length : Natural) return Boolean is
- begin
- return
- System.Atomic_Counters.Is_One (Item.Counter)
- and then Item.Max_Length >= Length
- and then Item.Max_Length <=
- Aligned_Max_Length (Length + Length / Growth_Factor);
- end Can_Be_Reused;
-
- -----------
- -- Count --
- -----------
-
- function Count
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
- Wide_Wide_Maps.Identity) return Natural
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
- end Count;
-
- function Count
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
- return Natural
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
- end Count;
-
- function Count
- (Source : Unbounded_Wide_Wide_String;
- Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Set);
- end Count;
-
- ------------
- -- Delete --
- ------------
-
- function Delete
- (Source : Unbounded_Wide_Wide_String;
- From : Positive;
- Through : Natural) return Unbounded_Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Empty slice is deleted, use the same shared string
-
- if From > Through then
- Reference (SR);
- DR := SR;
-
- -- Index is out of range
-
- elsif Through > SR.Last then
- raise Index_Error;
-
- -- Compute size of the result
-
- else
- DL := SR.Last - (Through - From + 1);
-
- -- Result is an empty string, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
- DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
- DR.Last := DL;
- end if;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Delete;
-
- procedure Delete
- (Source : in out Unbounded_Wide_Wide_String;
- From : Positive;
- Through : Natural)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Nothing changed, return
-
- if From > Through then
- null;
-
- -- Through is outside of the range
-
- elsif Through > SR.Last then
- raise Index_Error;
-
- else
- DL := SR.Last - (Through - From + 1);
-
- -- Result is empty, reuse shared empty string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_Wide_String'Access;
- Unreference (SR);
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
- DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end if;
- end Delete;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Source : Unbounded_Wide_Wide_String;
- Index : Positive) return Wide_Wide_Character
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- if Index <= SR.Last then
- return SR.Data (Index);
- else
- raise Index_Error;
- end if;
- end Element;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is
- SR : constant Shared_Wide_Wide_String_Access := Object.Reference;
-
- begin
- if SR /= null then
-
- -- The same controlled object can be finalized several times for
- -- some reason. As per 7.6.1(24) this should have no ill effect,
- -- so we need to add a guard for the case of finalizing the same
- -- object twice.
-
- Object.Reference := null;
- Unreference (SR);
- end if;
- end Finalize;
-
- ----------------
- -- Find_Token --
- ----------------
-
- procedure Find_Token
- (Source : Unbounded_Wide_Wide_String;
- Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
- From : Positive;
- Test : Strings.Membership;
- First : out Positive;
- Last : out Natural)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- Wide_Wide_Search.Find_Token
- (SR.Data (From .. SR.Last), Set, Test, First, Last);
- end Find_Token;
-
- procedure Find_Token
- (Source : Unbounded_Wide_Wide_String;
- Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
- Test : Strings.Membership;
- First : out Positive;
- Last : out Natural)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- Wide_Wide_Search.Find_Token
- (SR.Data (1 .. SR.Last), Set, Test, First, Last);
- end Find_Token;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (X : in out Wide_Wide_String_Access) is
- procedure Deallocate is
- new Ada.Unchecked_Deallocation
- (Wide_Wide_String, Wide_Wide_String_Access);
- begin
- Deallocate (X);
- end Free;
-
- ----------
- -- Head --
- ----------
-
- function Head
- (Source : Unbounded_Wide_Wide_String;
- Count : Natural;
- Pad : Wide_Wide_Character := Wide_Wide_Space)
- return Unbounded_Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Result is empty, reuse shared empty string
-
- if Count = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Length of the string is the same as requested, reuse source shared
- -- string.
-
- elsif Count = SR.Last then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
-
- -- Length of the source string is more than requested, copy
- -- corresponding slice.
-
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (1 .. Count);
-
- -- Length of the source string is less than requested, copy all
- -- contents and fill others by Pad character.
-
- else
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
-
- for J in SR.Last + 1 .. Count loop
- DR.Data (J) := Pad;
- end loop;
- end if;
-
- DR.Last := Count;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Head;
-
- procedure Head
- (Source : in out Unbounded_Wide_Wide_String;
- Count : Natural;
- Pad : Wide_Wide_Character := Wide_Wide_Space)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Result is empty, reuse empty shared string
-
- if Count = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_Wide_String'Access;
- Unreference (SR);
-
- -- Result is same with source string, reuse source shared string
-
- elsif Count = SR.Last then
- null;
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, Count) then
- if Count > SR.Last then
- for J in SR.Last + 1 .. Count loop
- SR.Data (J) := Pad;
- end loop;
- end if;
-
- SR.Last := Count;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
-
- -- Length of the source string is greater than requested, copy
- -- corresponding slice.
-
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (1 .. Count);
-
- -- Length of the source string is less than requested, copy all
- -- exists data and fill others by Pad character.
-
- else
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
-
- for J in SR.Last + 1 .. Count loop
- DR.Data (J) := Pad;
- end loop;
- end if;
-
- DR.Last := Count;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Head;
-
- -----------
- -- Index --
- -----------
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- Going : Strings.Direction := Strings.Forward;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
- Wide_Wide_Maps.Identity) return Natural
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- return Wide_Wide_Search.Index
- (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- Going : Direction := Forward;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
- return Natural
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- return Wide_Wide_Search.Index
- (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
- Test : Strings.Membership := Strings.Inside;
- Going : Strings.Direction := Strings.Forward) return Natural
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- return Wide_Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going);
- end Index;
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
- Wide_Wide_Maps.Identity) return Natural
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- return Wide_Wide_Search.Index
- (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
- return Natural
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- return Wide_Wide_Search.Index
- (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
- end Index;
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
- From : Positive;
- Test : Membership := Inside;
- Going : Direction := Forward) return Natural
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- return Wide_Wide_Search.Index
- (SR.Data (1 .. SR.Last), Set, From, Test, Going);
- end Index;
-
- ---------------------
- -- Index_Non_Blank --
- ---------------------
-
- function Index_Non_Blank
- (Source : Unbounded_Wide_Wide_String;
- Going : Strings.Direction := Strings.Forward) return Natural
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- return Wide_Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going);
- end Index_Non_Blank;
-
- function Index_Non_Blank
- (Source : Unbounded_Wide_Wide_String;
- From : Positive;
- Going : Direction := Forward) return Natural
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- begin
- return Wide_Wide_Search.Index_Non_Blank
- (SR.Data (1 .. SR.Last), From, Going);
- end Index_Non_Blank;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is
- begin
- Reference (Object.Reference);
- end Initialize;
-
- ------------
- -- Insert --
- ------------
-
- function Insert
- (Source : Unbounded_Wide_Wide_String;
- Before : Positive;
- New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + New_Item'Length;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Check index first
-
- if Before > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Result is empty, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Inserted string is empty, reuse source shared string
-
- elsif New_Item'Length = 0 then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
- DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
- DR.Data (Before + New_Item'Length .. DL) :=
- SR.Data (Before .. SR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Insert;
-
- procedure Insert
- (Source : in out Unbounded_Wide_Wide_String;
- Before : Positive;
- New_Item : Wide_Wide_String)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : constant Natural := SR.Last + New_Item'Length;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Check bounds
-
- if Before > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_Wide_String'Access;
- Unreference (SR);
-
- -- Inserted string is empty, nothing to do
-
- elsif New_Item'Length = 0 then
- null;
-
- -- Try to reuse existent shared string first
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (Before + New_Item'Length .. DL) :=
- SR.Data (Before .. SR.Last);
- SR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL + DL / Growth_Factor);
- DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
- DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
- DR.Data (Before + New_Item'Length .. DL) :=
- SR.Data (Before .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Insert;
-
- ------------
- -- Length --
- ------------
-
- function Length (Source : Unbounded_Wide_Wide_String) return Natural is
- begin
- return Source.Reference.Last;
- end Length;
-
- ---------------
- -- Overwrite --
- ---------------
-
- function Overwrite
- (Source : Unbounded_Wide_Wide_String;
- Position : Positive;
- New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Check bounds
-
- if Position > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Result is same with source string, reuse source shared string
-
- elsif New_Item'Length = 0 then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
- DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
- DR.Data (Position + New_Item'Length .. DL) :=
- SR.Data (Position + New_Item'Length .. SR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Overwrite;
-
- procedure Overwrite
- (Source : in out Unbounded_Wide_Wide_String;
- Position : Positive;
- New_Item : Wide_Wide_String)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Bounds check
-
- if Position > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_Wide_String'Access;
- Unreference (SR);
-
- -- String unchanged, nothing to do
-
- elsif New_Item'Length = 0 then
- null;
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
- SR.Last := DL;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
- DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
- DR.Data (Position + New_Item'Length .. DL) :=
- SR.Data (Position + New_Item'Length .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Overwrite;
-
- ---------------
- -- Reference --
- ---------------
-
- procedure Reference (Item : not null Shared_Wide_Wide_String_Access) is
- begin
- System.Atomic_Counters.Increment (Item.Counter);
- end Reference;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Source : in out Unbounded_Wide_Wide_String;
- Index : Positive;
- By : Wide_Wide_Character)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Bounds check
-
- if Index <= SR.Last then
-
- -- Try to reuse existent shared string
-
- if Can_Be_Reused (SR, SR.Last) then
- SR.Data (Index) := By;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
- DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
- DR.Data (Index) := By;
- DR.Last := SR.Last;
- Source.Reference := DR;
- Unreference (SR);
- end if;
-
- else
- raise Index_Error;
- end if;
- end Replace_Element;
-
- -------------------
- -- Replace_Slice --
- -------------------
-
- function Replace_Slice
- (Source : Unbounded_Wide_Wide_String;
- Low : Positive;
- High : Natural;
- By : Wide_Wide_String) return Unbounded_Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Check bounds
-
- if Low > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Do replace operation when removed slice is not empty
-
- if High >= Low then
- DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
- -- This is the number of characters remaining in the string after
- -- replacing the slice.
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
- DR.Data (Low .. Low + By'Length - 1) := By;
- DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
-
- -- Otherwise just insert string
-
- else
- return Insert (Source, Low, By);
- end if;
- end Replace_Slice;
-
- procedure Replace_Slice
- (Source : in out Unbounded_Wide_Wide_String;
- Low : Positive;
- High : Natural;
- By : Wide_Wide_String)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Bounds check
-
- if Low > SR.Last + 1 then
- raise Index_Error;
- end if;
-
- -- Do replace operation only when replaced slice is not empty
-
- if High >= Low then
- DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
- -- This is the number of characters remaining in the string after
- -- replacing the slice.
-
- -- Result is empty string, reuse empty shared string
-
- if DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_Wide_String'Access;
- Unreference (SR);
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
- SR.Data (Low .. Low + By'Length - 1) := By;
- SR.Last := DL;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
- DR.Data (Low .. Low + By'Length - 1) := By;
- DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
-
- -- Otherwise just insert item
-
- else
- Insert (Source, Low, By);
- end if;
- end Replace_Slice;
-
- -------------------------------
- -- Set_Unbounded_Wide_Wide_String --
- -------------------------------
-
- procedure Set_Unbounded_Wide_Wide_String
- (Target : out Unbounded_Wide_Wide_String;
- Source : Wide_Wide_String)
- is
- TR : constant Shared_Wide_Wide_String_Access := Target.Reference;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- In case of empty string, reuse empty shared string
-
- if Source'Length = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- Target.Reference := Empty_Shared_Wide_Wide_String'Access;
-
- else
- -- Try to reuse existent shared string
-
- if Can_Be_Reused (TR, Source'Length) then
- Reference (TR);
- DR := TR;
-
- -- Otherwise allocate new shared string
-
- else
- DR := Allocate (Source'Length);
- Target.Reference := DR;
- end if;
-
- DR.Data (1 .. Source'Length) := Source;
- DR.Last := Source'Length;
- end if;
-
- Unreference (TR);
- end Set_Unbounded_Wide_Wide_String;
-
- -----------
- -- Slice --
- -----------
-
- function Slice
- (Source : Unbounded_Wide_Wide_String;
- Low : Positive;
- High : Natural) return Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
-
- begin
- -- Note: test of High > Length is in accordance with AI95-00128
-
- if Low > SR.Last + 1 or else High > SR.Last then
- raise Index_Error;
-
- else
- return SR.Data (Low .. High);
- end if;
- end Slice;
-
- ----------
- -- Tail --
- ----------
-
- function Tail
- (Source : Unbounded_Wide_Wide_String;
- Count : Natural;
- Pad : Wide_Wide_Character := Wide_Wide_Space)
- return Unbounded_Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- For empty result reuse empty shared string
-
- if Count = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Result is hole source string, reuse source shared string
-
- elsif Count = SR.Last then
- Reference (SR);
- DR := SR;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
-
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
-
- else
- for J in 1 .. Count - SR.Last loop
- DR.Data (J) := Pad;
- end loop;
-
- DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
- end if;
-
- DR.Last := Count;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Tail;
-
- procedure Tail
- (Source : in out Unbounded_Wide_Wide_String;
- Count : Natural;
- Pad : Wide_Wide_Character := Wide_Wide_Space)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_Wide_String_Access;
-
- procedure Common
- (SR : Shared_Wide_Wide_String_Access;
- DR : Shared_Wide_Wide_String_Access;
- Count : Natural);
- -- Common code of tail computation. SR/DR can point to the same object
-
- ------------
- -- Common --
- ------------
-
- procedure Common
- (SR : Shared_Wide_Wide_String_Access;
- DR : Shared_Wide_Wide_String_Access;
- Count : Natural) is
- begin
- if Count < SR.Last then
- DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
-
- else
- DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
-
- for J in 1 .. Count - SR.Last loop
- DR.Data (J) := Pad;
- end loop;
- end if;
-
- DR.Last := Count;
- end Common;
-
- begin
- -- Result is empty string, reuse empty shared string
-
- if Count = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_Wide_String'Access;
- Unreference (SR);
-
- -- Length of the result is the same with length of the source string,
- -- reuse source shared string.
-
- elsif Count = SR.Last then
- null;
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, Count) then
- Common (SR, SR, Count);
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (Count);
- Common (SR, DR, Count);
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Tail;
-
- -------------------------
- -- To_Wide_Wide_String --
- -------------------------
-
- function To_Wide_Wide_String
- (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String is
- begin
- return Source.Reference.Data (1 .. Source.Reference.Last);
- end To_Wide_Wide_String;
-
- -----------------------------------
- -- To_Unbounded_Wide_Wide_String --
- -----------------------------------
-
- function To_Unbounded_Wide_Wide_String
- (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String
- is
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- if Source'Length = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- else
- DR := Allocate (Source'Length);
- DR.Data (1 .. Source'Length) := Source;
- DR.Last := Source'Length;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end To_Unbounded_Wide_Wide_String;
-
- function To_Unbounded_Wide_Wide_String
- (Length : Natural) return Unbounded_Wide_Wide_String
- is
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- if Length = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- else
- DR := Allocate (Length);
- DR.Last := Length;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end To_Unbounded_Wide_Wide_String;
-
- ---------------
- -- Translate --
- ---------------
-
- function Translate
- (Source : Unbounded_Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
- return Unbounded_Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Nothing to translate, reuse empty shared string
-
- if SR.Last = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Value (Mapping, SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Translate;
-
- procedure Translate
- (Source : in out Unbounded_Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Nothing to translate
-
- if SR.Last = 0 then
- null;
-
- -- Try to reuse shared string
-
- elsif Can_Be_Reused (SR, SR.Last) then
- for J in 1 .. SR.Last loop
- SR.Data (J) := Value (Mapping, SR.Data (J));
- end loop;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Value (Mapping, SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end Translate;
-
- function Translate
- (Source : Unbounded_Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
- return Unbounded_Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Nothing to translate, reuse empty shared string
-
- if SR.Last = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Mapping.all (SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- end if;
-
- return (AF.Controlled with Reference => DR);
-
- exception
- when others =>
- Unreference (DR);
-
- raise;
- end Translate;
-
- procedure Translate
- (Source : in out Unbounded_Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Nothing to translate
-
- if SR.Last = 0 then
- null;
-
- -- Try to reuse shared string
-
- elsif Can_Be_Reused (SR, SR.Last) then
- for J in 1 .. SR.Last loop
- SR.Data (J) := Mapping.all (SR.Data (J));
- end loop;
-
- -- Otherwise allocate new shared string and fill it
-
- else
- DR := Allocate (SR.Last);
-
- for J in 1 .. SR.Last loop
- DR.Data (J) := Mapping.all (SR.Data (J));
- end loop;
-
- DR.Last := SR.Last;
- Source.Reference := DR;
- Unreference (SR);
- end if;
-
- exception
- when others =>
- if DR /= null then
- Unreference (DR);
- end if;
-
- raise;
- end Translate;
-
- ----------
- -- Trim --
- ----------
-
- function Trim
- (Source : Unbounded_Wide_Wide_String;
- Side : Trim_End) return Unbounded_Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index_Non_Blank (Source, Forward);
-
- -- All blanks, reuse empty shared string
-
- if Low = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- else
- case Side is
- when Left =>
- High := SR.Last;
- DL := SR.Last - Low + 1;
-
- when Right =>
- Low := 1;
- High := Index_Non_Blank (Source, Backward);
- DL := High;
-
- when Both =>
- High := Index_Non_Blank (Source, Backward);
- DL := High - Low + 1;
- end case;
-
- -- Length of the result is the same as length of the source string,
- -- reuse source shared string.
-
- if DL = SR.Last then
- Reference (SR);
- DR := SR;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- end if;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Trim;
-
- procedure Trim
- (Source : in out Unbounded_Wide_Wide_String;
- Side : Trim_End)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index_Non_Blank (Source, Forward);
-
- -- All blanks, reuse empty shared string
-
- if Low = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_Wide_String'Access;
- Unreference (SR);
-
- else
- case Side is
- when Left =>
- High := SR.Last;
- DL := SR.Last - Low + 1;
-
- when Right =>
- Low := 1;
- High := Index_Non_Blank (Source, Backward);
- DL := High;
-
- when Both =>
- High := Index_Non_Blank (Source, Backward);
- DL := High - Low + 1;
- end case;
-
- -- Length of the result is the same as length of the source string,
- -- nothing to do.
-
- if DL = SR.Last then
- null;
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (1 .. DL) := SR.Data (Low .. High);
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end if;
- end Trim;
-
- function Trim
- (Source : Unbounded_Wide_Wide_String;
- Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
- Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
- return Unbounded_Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index (Source, Left, Outside, Forward);
-
- -- Source includes only characters from Left set, reuse empty shared
- -- string.
-
- if Low = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- else
- High := Index (Source, Right, Outside, Backward);
- DL := Integer'Max (0, High - Low + 1);
-
- -- Source includes only characters from Right set or result string
- -- is empty, reuse empty shared string.
-
- if High = 0 or else DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- end if;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Trim;
-
- procedure Trim
- (Source : in out Unbounded_Wide_Wide_String;
- Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
- Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
- Low : Natural;
- High : Natural;
-
- begin
- Low := Index (Source, Left, Outside, Forward);
-
- -- Source includes only characters from Left set, reuse empty shared
- -- string.
-
- if Low = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_Wide_String'Access;
- Unreference (SR);
-
- else
- High := Index (Source, Right, Outside, Backward);
- DL := Integer'Max (0, High - Low + 1);
-
- -- Source includes only characters from Right set or result string
- -- is empty, reuse empty shared string.
-
- if High = 0 or else DL = 0 then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- Source.Reference := Empty_Shared_Wide_Wide_String'Access;
- Unreference (SR);
-
- -- Try to reuse existent shared string
-
- elsif Can_Be_Reused (SR, DL) then
- SR.Data (1 .. DL) := SR.Data (Low .. High);
- SR.Last := DL;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- Source.Reference := DR;
- Unreference (SR);
- end if;
- end if;
- end Trim;
-
- ---------------------
- -- Unbounded_Slice --
- ---------------------
-
- function Unbounded_Slice
- (Source : Unbounded_Wide_Wide_String;
- Low : Positive;
- High : Natural) return Unbounded_Wide_Wide_String
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Check bounds
-
- if Low > SR.Last + 1 or else High > SR.Last then
- raise Index_Error;
-
- -- Result is empty slice, reuse empty shared string
-
- elsif Low > High then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- DR := Empty_Shared_Wide_Wide_String'Access;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DL := High - Low + 1;
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- end if;
-
- return (AF.Controlled with Reference => DR);
- end Unbounded_Slice;
-
- procedure Unbounded_Slice
- (Source : Unbounded_Wide_Wide_String;
- Target : out Unbounded_Wide_Wide_String;
- Low : Positive;
- High : Natural)
- is
- SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
- TR : constant Shared_Wide_Wide_String_Access := Target.Reference;
- DL : Natural;
- DR : Shared_Wide_Wide_String_Access;
-
- begin
- -- Check bounds
-
- if Low > SR.Last + 1 or else High > SR.Last then
- raise Index_Error;
-
- -- Result is empty slice, reuse empty shared string
-
- elsif Low > High then
- Reference (Empty_Shared_Wide_Wide_String'Access);
- Target.Reference := Empty_Shared_Wide_Wide_String'Access;
- Unreference (TR);
-
- else
- DL := High - Low + 1;
-
- -- Try to reuse existent shared string
-
- if Can_Be_Reused (TR, DL) then
- TR.Data (1 .. DL) := SR.Data (Low .. High);
- TR.Last := DL;
-
- -- Otherwise, allocate new shared string and fill it
-
- else
- DR := Allocate (DL);
- DR.Data (1 .. DL) := SR.Data (Low .. High);
- DR.Last := DL;
- Target.Reference := DR;
- Unreference (TR);
- end if;
- end if;
- end Unbounded_Slice;
-
- -----------------
- -- Unreference --
- -----------------
-
- procedure Unreference (Item : not null Shared_Wide_Wide_String_Access) is
-
- procedure Free is
- new Ada.Unchecked_Deallocation
- (Shared_Wide_Wide_String, Shared_Wide_Wide_String_Access);
-
- Aux : Shared_Wide_Wide_String_Access := Item;
-
- begin
- if System.Atomic_Counters.Decrement (Aux.Counter) then
-
- -- Reference counter of Empty_Shared_Wide_Wide_String must never
- -- reach zero.
-
- pragma Assert (Aux /= Empty_Shared_Wide_Wide_String'Access);
-
- Free (Aux);
- end if;
- end Unreference;
-
-end Ada.Strings.Wide_Wide_Unbounded;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is supported on:
--- - all Alpha platforms
--- - all ia64 platforms
--- - all PowerPC platforms
--- - all SPARC V9 platforms
--- - all x86 platforms
--- - all x86_64 platforms
-
-with Ada.Strings.Wide_Wide_Maps;
-private with Ada.Finalization;
-private with System.Atomic_Counters;
-
-package Ada.Strings.Wide_Wide_Unbounded is
- pragma Preelaborate;
-
- type Unbounded_Wide_Wide_String is private;
- pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String);
-
- Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String;
-
- function Length (Source : Unbounded_Wide_Wide_String) return Natural;
-
- type Wide_Wide_String_Access is access all Wide_Wide_String;
-
- procedure Free (X : in out Wide_Wide_String_Access);
-
- --------------------------------------------------------
- -- Conversion, Concatenation, and Selection Functions --
- --------------------------------------------------------
-
- function To_Unbounded_Wide_Wide_String
- (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String;
-
- function To_Unbounded_Wide_Wide_String
- (Length : Natural) return Unbounded_Wide_Wide_String;
-
- function To_Wide_Wide_String
- (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String;
-
- procedure Set_Unbounded_Wide_Wide_String
- (Target : out Unbounded_Wide_Wide_String;
- Source : Wide_Wide_String);
- pragma Ada_05 (Set_Unbounded_Wide_Wide_String);
-
- procedure Append
- (Source : in out Unbounded_Wide_Wide_String;
- New_Item : Unbounded_Wide_Wide_String);
-
- procedure Append
- (Source : in out Unbounded_Wide_Wide_String;
- New_Item : Wide_Wide_String);
-
- procedure Append
- (Source : in out Unbounded_Wide_Wide_String;
- New_Item : Wide_Wide_Character);
-
- function "&"
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
-
- function "&"
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Unbounded_Wide_Wide_String;
-
- function "&"
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
-
- function "&"
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String;
-
- function "&"
- (Left : Wide_Wide_Character;
- Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
-
- function Element
- (Source : Unbounded_Wide_Wide_String;
- Index : Positive) return Wide_Wide_Character;
-
- procedure Replace_Element
- (Source : in out Unbounded_Wide_Wide_String;
- Index : Positive;
- By : Wide_Wide_Character);
-
- function Slice
- (Source : Unbounded_Wide_Wide_String;
- Low : Positive;
- High : Natural) return Wide_Wide_String;
-
- function Unbounded_Slice
- (Source : Unbounded_Wide_Wide_String;
- Low : Positive;
- High : Natural) return Unbounded_Wide_Wide_String;
- pragma Ada_05 (Unbounded_Slice);
-
- procedure Unbounded_Slice
- (Source : Unbounded_Wide_Wide_String;
- Target : out Unbounded_Wide_Wide_String;
- Low : Positive;
- High : Natural);
- pragma Ada_05 (Unbounded_Slice);
-
- function "="
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean;
-
- function "="
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Boolean;
-
- function "="
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean;
-
- function "<"
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean;
-
- function "<"
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Boolean;
-
- function "<"
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean;
-
- function "<="
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean;
-
- function "<="
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Boolean;
-
- function "<="
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean;
-
- function ">"
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean;
-
- function ">"
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Boolean;
-
- function ">"
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean;
-
- function ">="
- (Left : Unbounded_Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean;
-
- function ">="
- (Left : Unbounded_Wide_Wide_String;
- Right : Wide_Wide_String) return Boolean;
-
- function ">="
- (Left : Wide_Wide_String;
- Right : Unbounded_Wide_Wide_String) return Boolean;
-
- ------------------------
- -- Search Subprograms --
- ------------------------
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- Going : Direction := Forward;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
- Wide_Wide_Maps.Identity)
- return Natural;
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- Going : Direction := Forward;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
- return Natural;
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
- Test : Membership := Inside;
- Going : Direction := Forward) return Natural;
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
- Wide_Wide_Maps.Identity)
- return Natural;
- pragma Ada_05 (Index);
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- From : Positive;
- Going : Direction := Forward;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
- return Natural;
- pragma Ada_05 (Index);
-
- function Index
- (Source : Unbounded_Wide_Wide_String;
- Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
- From : Positive;
- Test : Membership := Inside;
- Going : Direction := Forward) return Natural;
- pragma Ada_05 (Index);
-
- function Index_Non_Blank
- (Source : Unbounded_Wide_Wide_String;
- Going : Direction := Forward) return Natural;
-
- function Index_Non_Blank
- (Source : Unbounded_Wide_Wide_String;
- From : Positive;
- Going : Direction := Forward) return Natural;
- pragma Ada_05 (Index_Non_Blank);
-
- function Count
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
- Wide_Wide_Maps.Identity)
- return Natural;
-
- function Count
- (Source : Unbounded_Wide_Wide_String;
- Pattern : Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
- return Natural;
-
- function Count
- (Source : Unbounded_Wide_Wide_String;
- Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural;
-
- procedure Find_Token
- (Source : Unbounded_Wide_Wide_String;
- Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
- From : Positive;
- Test : Membership;
- First : out Positive;
- Last : out Natural);
- pragma Ada_2012 (Find_Token);
-
- procedure Find_Token
- (Source : Unbounded_Wide_Wide_String;
- Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
- Test : Membership;
- First : out Positive;
- Last : out Natural);
-
- ------------------------------------
- -- String Translation Subprograms --
- ------------------------------------
-
- function Translate
- (Source : Unbounded_Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
- return Unbounded_Wide_Wide_String;
-
- procedure Translate
- (Source : in out Unbounded_Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping);
-
- function Translate
- (Source : Unbounded_Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
- return Unbounded_Wide_Wide_String;
-
- procedure Translate
- (Source : in out Unbounded_Wide_Wide_String;
- Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function);
-
- ---------------------------------------
- -- String Transformation Subprograms --
- ---------------------------------------
-
- function Replace_Slice
- (Source : Unbounded_Wide_Wide_String;
- Low : Positive;
- High : Natural;
- By : Wide_Wide_String) return Unbounded_Wide_Wide_String;
-
- procedure Replace_Slice
- (Source : in out Unbounded_Wide_Wide_String;
- Low : Positive;
- High : Natural;
- By : Wide_Wide_String);
-
- function Insert
- (Source : Unbounded_Wide_Wide_String;
- Before : Positive;
- New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String;
-
- procedure Insert
- (Source : in out Unbounded_Wide_Wide_String;
- Before : Positive;
- New_Item : Wide_Wide_String);
-
- function Overwrite
- (Source : Unbounded_Wide_Wide_String;
- Position : Positive;
- New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String;
-
- procedure Overwrite
- (Source : in out Unbounded_Wide_Wide_String;
- Position : Positive;
- New_Item : Wide_Wide_String);
-
- function Delete
- (Source : Unbounded_Wide_Wide_String;
- From : Positive;
- Through : Natural) return Unbounded_Wide_Wide_String;
-
- procedure Delete
- (Source : in out Unbounded_Wide_Wide_String;
- From : Positive;
- Through : Natural);
-
- function Trim
- (Source : Unbounded_Wide_Wide_String;
- Side : Trim_End) return Unbounded_Wide_Wide_String;
-
- procedure Trim
- (Source : in out Unbounded_Wide_Wide_String;
- Side : Trim_End);
-
- function Trim
- (Source : Unbounded_Wide_Wide_String;
- Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
- Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
- return Unbounded_Wide_Wide_String;
-
- procedure Trim
- (Source : in out Unbounded_Wide_Wide_String;
- Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
- Right : Wide_Wide_Maps.Wide_Wide_Character_Set);
-
- function Head
- (Source : Unbounded_Wide_Wide_String;
- Count : Natural;
- Pad : Wide_Wide_Character := Wide_Wide_Space)
- return Unbounded_Wide_Wide_String;
-
- procedure Head
- (Source : in out Unbounded_Wide_Wide_String;
- Count : Natural;
- Pad : Wide_Wide_Character := Wide_Wide_Space);
-
- function Tail
- (Source : Unbounded_Wide_Wide_String;
- Count : Natural;
- Pad : Wide_Wide_Character := Wide_Wide_Space)
- return Unbounded_Wide_Wide_String;
-
- procedure Tail
- (Source : in out Unbounded_Wide_Wide_String;
- Count : Natural;
- Pad : Wide_Wide_Character := Wide_Wide_Space);
-
- function "*"
- (Left : Natural;
- Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String;
-
- function "*"
- (Left : Natural;
- Right : Wide_Wide_String) return Unbounded_Wide_Wide_String;
-
- function "*"
- (Left : Natural;
- Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
-
-private
- pragma Inline (Length);
-
- package AF renames Ada.Finalization;
-
- type Shared_Wide_Wide_String (Max_Length : Natural) is limited record
- Counter : System.Atomic_Counters.Atomic_Counter;
- -- Reference counter
-
- Last : Natural := 0;
- Data : Wide_Wide_String (1 .. Max_Length);
- -- Last is the index of last significant element of the Data. All
- -- elements with larger indexes are just extra room for expansion.
- end record;
-
- type Shared_Wide_Wide_String_Access is access all Shared_Wide_Wide_String;
-
- procedure Reference (Item : not null Shared_Wide_Wide_String_Access);
- -- Increment reference counter.
-
- procedure Unreference (Item : not null Shared_Wide_Wide_String_Access);
- -- Decrement reference counter. Deallocate Item when reference counter is
- -- zero.
-
- function Can_Be_Reused
- (Item : Shared_Wide_Wide_String_Access;
- Length : Natural) return Boolean;
- -- Returns True if Shared_Wide_Wide_String can be reused. There are two
- -- criteria when Shared_Wide_Wide_String can be reused: its reference
- -- counter must be one (thus Shared_Wide_Wide_String is owned exclusively)
- -- and its size is sufficient to store string with specified length
- -- effectively.
-
- function Allocate
- (Max_Length : Natural) return Shared_Wide_Wide_String_Access;
- -- Allocates new Shared_Wide_Wide_String with at least specified maximum
- -- length. Actual maximum length of the allocated Shared_Wide_Wide_String
- -- can be slightly greater. Returns reference to
- -- Empty_Shared_Wide_Wide_String when requested length is zero.
-
- Empty_Shared_Wide_Wide_String : aliased Shared_Wide_Wide_String (0);
-
- function To_Unbounded
- (S : Wide_Wide_String) return Unbounded_Wide_Wide_String
- renames To_Unbounded_Wide_Wide_String;
- -- This renames are here only to be used in the pragma Stream_Convert.
-
- type Unbounded_Wide_Wide_String is new AF.Controlled with record
- Reference : Shared_Wide_Wide_String_Access :=
- Empty_Shared_Wide_Wide_String'Access;
- end record;
-
- -- The Unbounded_Wide_Wide_String uses several techniques to increase speed
- -- of the application:
-
- -- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String
- -- contains only the reference to the data which is shared between
- -- several instances. The shared data is reallocated only when its value
- -- is changed and the object mutation can't be used or it is inefficient
- -- to use it;
-
- -- - object mutation. Shared data object can be reused without memory
- -- reallocation when all of the following requirements are meat:
- -- - shared data object don't used anywhere longer;
- -- - its size is sufficient to store new value;
- -- - the gap after reuse is less than some threshold.
-
- -- - memory preallocation. Most of used memory allocation algorithms
- -- aligns allocated segment on the some boundary, thus some amount of
- -- additional memory can be preallocated without any impact. Such
- -- preallocated memory can used later by Append/Insert operations
- -- without reallocation.
-
- -- Reference counting uses GCC builtin atomic operations, which allows safe
- -- sharing of internal data between Ada tasks. Nevertheless, this does not
- -- make objects of Unbounded_String thread-safe: an instance cannot be
- -- accessed by several tasks simultaneously.
-
- pragma Stream_Convert
- (Unbounded_Wide_Wide_String, To_Unbounded, To_Wide_Wide_String);
- -- Provide stream routines without dragging in Ada.Streams
-
- pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String);
- -- Finalization is required only for freeing storage
-
- overriding procedure Initialize
- (Object : in out Unbounded_Wide_Wide_String);
- overriding procedure Adjust
- (Object : in out Unbounded_Wide_Wide_String);
- overriding procedure Finalize
- (Object : in out Unbounded_Wide_Wide_String);
-
- Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String :=
- (AF.Controlled with
- Reference =>
- Empty_Shared_Wide_Wide_String'
- Access);
-
-end Ada.Strings.Wide_Wide_Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Wide_Wide_Search;
+with Ada.Unchecked_Deallocation;
+
+package body Ada.Strings.Wide_Wide_Unbounded is
+
+ use Ada.Strings.Wide_Wide_Maps;
+
+ Growth_Factor : constant := 32;
+ -- The growth factor controls how much extra space is allocated when
+ -- we have to increase the size of an allocated unbounded string. By
+ -- allocating extra space, we avoid the need to reallocate on every
+ -- append, particularly important when a string is built up by repeated
+ -- append operations of small pieces. This is expressed as a factor so
+ -- 32 means add 1/32 of the length of the string as growth space.
+
+ Min_Mul_Alloc : constant := Standard'Maximum_Alignment;
+ -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes
+ -- no memory loss as most (all?) malloc implementations are obliged to
+ -- align the returned memory on the maximum alignment as malloc does not
+ -- know the target alignment.
+
+ function Aligned_Max_Length (Max_Length : Natural) return Natural;
+ -- Returns recommended length of the shared string which is greater or
+ -- equal to specified length. Calculation take in sense alignment of
+ -- the allocated memory segments to use memory effectively by
+ -- Append/Insert/etc operations.
+
+ ---------
+ -- "&" --
+ ---------
+
+ function "&"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+ DL : constant Natural := LR.Last + RR.Last;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Left string is empty, return Rigth string
+
+ elsif LR.Last = 0 then
+ Reference (RR);
+ DR := RR;
+
+ -- Right string is empty, return Left string
+
+ elsif RR.Last = 0 then
+ Reference (LR);
+ DR := LR;
+
+ -- Overwise, allocate new shared string and fill data
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
+ DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ DL : constant Natural := LR.Last + Right'Length;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Right is an empty string, return Left string
+
+ elsif Right'Length = 0 then
+ Reference (LR);
+ DR := LR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
+ DR.Data (LR.Last + 1 .. DL) := Right;
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+ DL : constant Natural := Left'Length + RR.Last;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared one
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Left is empty string, return Right string
+
+ elsif Left'Length = 0 then
+ Reference (RR);
+ DR := RR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Left'Length) := Left;
+ DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ DL : constant Natural := LR.Last + 1;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ DR := Allocate (DL);
+ DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last);
+ DR.Data (DL) := Right;
+ DR.Last := DL;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ function "&"
+ (Left : Wide_Wide_Character;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+ DL : constant Natural := 1 + RR.Last;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ DR := Allocate (DL);
+ DR.Data (1) := Left;
+ DR.Data (2 .. DL) := RR.Data (1 .. RR.Last);
+ DR.Last := DL;
+
+ return (AF.Controlled with Reference => DR);
+ end "&";
+
+ ---------
+ -- "*" --
+ ---------
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String
+ is
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if Left = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (Left);
+
+ for J in 1 .. Left loop
+ DR.Data (J) := Right;
+ end loop;
+
+ DR.Last := Left;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ DL : constant Natural := Left * Right'Length;
+ DR : Shared_Wide_Wide_String_Access;
+ K : Positive;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ K := 1;
+
+ for J in 1 .. Left loop
+ DR.Data (K .. K + Right'Length - 1) := Right;
+ K := K + Right'Length;
+ end loop;
+
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "*";
+
+ function "*"
+ (Left : Natural;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+ DL : constant Natural := Left * RR.Last;
+ DR : Shared_Wide_Wide_String_Access;
+ K : Positive;
+
+ begin
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Coefficient is one, just return string itself
+
+ elsif Left = 1 then
+ Reference (RR);
+ DR := RR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ K := 1;
+
+ for J in 1 .. Left loop
+ DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last);
+ K := K + RR.Last;
+ end loop;
+
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end "*";
+
+ ---------
+ -- "<" --
+ ---------
+
+ function "<"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last);
+ end "<";
+
+ function "<"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) < Right;
+ end "<";
+
+ function "<"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+ begin
+ return Left < RR.Data (1 .. RR.Last);
+ end "<";
+
+ ----------
+ -- "<=" --
+ ----------
+
+ function "<="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+
+ begin
+ -- LR = RR means two strings shares shared string, thus they are equal
+
+ return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last);
+ end "<=";
+
+ function "<="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) <= Right;
+ end "<=";
+
+ function "<="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+ begin
+ return Left <= RR.Data (1 .. RR.Last);
+ end "<=";
+
+ ---------
+ -- "=" --
+ ---------
+
+ function "="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+
+ begin
+ return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last);
+ -- LR = RR means two strings shares shared string, thus they are equal
+ end "=";
+
+ function "="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) = Right;
+ end "=";
+
+ function "="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+ begin
+ return Left = RR.Data (1 .. RR.Last);
+ end "=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last);
+ end ">";
+
+ function ">"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) > Right;
+ end ">";
+
+ function ">"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+ begin
+ return Left > RR.Data (1 .. RR.Last);
+ end ">";
+
+ ----------
+ -- ">=" --
+ ----------
+
+ function ">="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+
+ begin
+ -- LR = RR means two strings shares shared string, thus they are equal
+
+ return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last);
+ end ">=";
+
+ function ">="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean
+ is
+ LR : constant Shared_Wide_Wide_String_Access := Left.Reference;
+ begin
+ return LR.Data (1 .. LR.Last) >= Right;
+ end ">=";
+
+ function ">="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean
+ is
+ RR : constant Shared_Wide_Wide_String_Access := Right.Reference;
+ begin
+ return Left >= RR.Data (1 .. RR.Last);
+ end ">=";
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is
+ begin
+ Reference (Object.Reference);
+ end Adjust;
+
+ ------------------------
+ -- Aligned_Max_Length --
+ ------------------------
+
+ function Aligned_Max_Length (Max_Length : Natural) return Natural is
+ Static_Size : constant Natural :=
+ Empty_Shared_Wide_Wide_String'Size / Standard'Storage_Unit;
+ -- Total size of all static components
+
+ Element_Size : constant Natural :=
+ Wide_Wide_Character'Size / Standard'Storage_Unit;
+
+ begin
+ return
+ (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2)
+ * Min_Mul_Alloc - Static_Size) / Element_Size;
+ end Aligned_Max_Length;
+
+ --------------
+ -- Allocate --
+ --------------
+
+ function Allocate
+ (Max_Length : Natural) return Shared_Wide_Wide_String_Access is
+ begin
+ -- Empty string requested, return shared empty string
+
+ if Max_Length = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ return Empty_Shared_Wide_Wide_String'Access;
+
+ -- Otherwise, allocate requested space (and probably some more room)
+
+ else
+ return new Shared_Wide_Wide_String (Aligned_Max_Length (Max_Length));
+ end if;
+ end Allocate;
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Unbounded_Wide_Wide_String)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ NR : constant Shared_Wide_Wide_String_Access := New_Item.Reference;
+ DL : constant Natural := SR.Last + NR.Last;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Source is an empty string, reuse New_Item data
+
+ if SR.Last = 0 then
+ Reference (NR);
+ Source.Reference := NR;
+ Unreference (SR);
+
+ -- New_Item is empty string, nothing to do
+
+ elsif NR.Last = 0 then
+ null;
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new one and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Wide_Wide_String)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + New_Item'Length;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- New_Item is an empty string, nothing to do
+
+ if New_Item'Length = 0 then
+ null;
+
+ -- Try to reuse existing shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (SR.Last + 1 .. DL) := New_Item;
+ SR.Last := DL;
+
+ -- Otherwise, allocate new one and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (SR.Last + 1 .. DL) := New_Item;
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Append;
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Wide_Wide_Character)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + 1;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Try to reuse existing shared string
+
+ if Can_Be_Reused (SR, SR.Last + 1) then
+ SR.Data (SR.Last + 1) := New_Item;
+ SR.Last := SR.Last + 1;
+
+ -- Otherwise, allocate new one and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (DL) := New_Item;
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Append;
+
+ -------------------
+ -- Can_Be_Reused --
+ -------------------
+
+ function Can_Be_Reused
+ (Item : Shared_Wide_Wide_String_Access;
+ Length : Natural) return Boolean is
+ begin
+ return
+ System.Atomic_Counters.Is_One (Item.Counter)
+ and then Item.Max_Length >= Length
+ and then Item.Max_Length <=
+ Aligned_Max_Length (Length + Length / Growth_Factor);
+ end Can_Be_Reused;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity) return Natural
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping);
+ end Count;
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Set);
+ end Count;
+
+ ------------
+ -- Delete --
+ ------------
+
+ function Delete
+ (Source : Unbounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural) return Unbounded_Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Empty slice is deleted, use the same shared string
+
+ if From > Through then
+ Reference (SR);
+ DR := SR;
+
+ -- Index is out of range
+
+ elsif Through > SR.Last then
+ raise Index_Error;
+
+ -- Compute size of the result
+
+ else
+ DL := SR.Last - (Through - From + 1);
+
+ -- Result is an empty string, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
+ DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
+ DR.Last := DL;
+ end if;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Delete;
+
+ procedure Delete
+ (Source : in out Unbounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Nothing changed, return
+
+ if From > Through then
+ null;
+
+ -- Through is outside of the range
+
+ elsif Through > SR.Last then
+ raise Index_Error;
+
+ else
+ DL := SR.Last - (Through - From + 1);
+
+ -- Result is empty, reuse shared empty string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_Wide_String'Access;
+ Unreference (SR);
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1);
+ DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end if;
+ end Delete;
+
+ -------------
+ -- Element --
+ -------------
+
+ function Element
+ (Source : Unbounded_Wide_Wide_String;
+ Index : Positive) return Wide_Wide_Character
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ if Index <= SR.Last then
+ return SR.Data (Index);
+ else
+ raise Index_Error;
+ end if;
+ end Element;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is
+ SR : constant Shared_Wide_Wide_String_Access := Object.Reference;
+
+ begin
+ if SR /= null then
+
+ -- The same controlled object can be finalized several times for
+ -- some reason. As per 7.6.1(24) this should have no ill effect,
+ -- so we need to add a guard for the case of finalizing the same
+ -- object twice.
+
+ Object.Reference := null;
+ Unreference (SR);
+ end if;
+ end Finalize;
+
+ ----------------
+ -- Find_Token --
+ ----------------
+
+ procedure Find_Token
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ Wide_Wide_Search.Find_Token
+ (SR.Data (From .. SR.Last), Set, Test, First, Last);
+ end Find_Token;
+
+ procedure Find_Token
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ Wide_Wide_Search.Find_Token
+ (SR.Data (1 .. SR.Last), Set, Test, First, Last);
+ end Find_Token;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (X : in out Wide_Wide_String_Access) is
+ procedure Deallocate is
+ new Ada.Unchecked_Deallocation
+ (Wide_Wide_String, Wide_Wide_String_Access);
+ begin
+ Deallocate (X);
+ end Free;
+
+ ----------
+ -- Head --
+ ----------
+
+ function Head
+ (Source : Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ return Unbounded_Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Result is empty, reuse shared empty string
+
+ if Count = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Length of the string is the same as requested, reuse source shared
+ -- string.
+
+ elsif Count = SR.Last then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+
+ -- Length of the source string is more than requested, copy
+ -- corresponding slice.
+
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (1 .. Count);
+
+ -- Length of the source string is less than requested, copy all
+ -- contents and fill others by Pad character.
+
+ else
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+
+ for J in SR.Last + 1 .. Count loop
+ DR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ DR.Last := Count;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Head;
+
+ procedure Head
+ (Source : in out Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Result is empty, reuse empty shared string
+
+ if Count = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_Wide_String'Access;
+ Unreference (SR);
+
+ -- Result is same with source string, reuse source shared string
+
+ elsif Count = SR.Last then
+ null;
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, Count) then
+ if Count > SR.Last then
+ for J in SR.Last + 1 .. Count loop
+ SR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ SR.Last := Count;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+
+ -- Length of the source string is greater than requested, copy
+ -- corresponding slice.
+
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (1 .. Count);
+
+ -- Length of the source string is less than requested, copy all
+ -- exists data and fill others by Pad character.
+
+ else
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+
+ for J in SR.Last + 1 .. Count loop
+ DR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ DR.Last := Count;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Head;
+
+ -----------
+ -- Index --
+ -----------
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Strings.Direction := Strings.Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity) return Natural
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Wide_Search.Index
+ (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Wide_Search.Index
+ (SR.Data (1 .. SR.Last), Pattern, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Strings.Membership := Strings.Inside;
+ Going : Strings.Direction := Strings.Forward) return Natural
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity) return Natural
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Wide_Search.Index
+ (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Wide_Search.Index
+ (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping);
+ end Index;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Wide_Search.Index
+ (SR.Data (1 .. SR.Last), Set, From, Test, Going);
+ end Index;
+
+ ---------------------
+ -- Index_Non_Blank --
+ ---------------------
+
+ function Index_Non_Blank
+ (Source : Unbounded_Wide_Wide_String;
+ Going : Strings.Direction := Strings.Forward) return Natural
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going);
+ end Index_Non_Blank;
+
+ function Index_Non_Blank
+ (Source : Unbounded_Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ begin
+ return Wide_Wide_Search.Index_Non_Blank
+ (SR.Data (1 .. SR.Last), From, Going);
+ end Index_Non_Blank;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is
+ begin
+ Reference (Object.Reference);
+ end Initialize;
+
+ ------------
+ -- Insert --
+ ------------
+
+ function Insert
+ (Source : Unbounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + New_Item'Length;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Check index first
+
+ if Before > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Result is empty, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Inserted string is empty, reuse source shared string
+
+ elsif New_Item'Length = 0 then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
+ DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
+ DR.Data (Before + New_Item'Length .. DL) :=
+ SR.Data (Before .. SR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Insert;
+
+ procedure Insert
+ (Source : in out Unbounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : constant Natural := SR.Last + New_Item'Length;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Before > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_Wide_String'Access;
+ Unreference (SR);
+
+ -- Inserted string is empty, nothing to do
+
+ elsif New_Item'Length = 0 then
+ null;
+
+ -- Try to reuse existent shared string first
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (Before + New_Item'Length .. DL) :=
+ SR.Data (Before .. SR.Last);
+ SR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL + DL / Growth_Factor);
+ DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1);
+ DR.Data (Before .. Before + New_Item'Length - 1) := New_Item;
+ DR.Data (Before + New_Item'Length .. DL) :=
+ SR.Data (Before .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Insert;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (Source : Unbounded_Wide_Wide_String) return Natural is
+ begin
+ return Source.Reference.Last;
+ end Length;
+
+ ---------------
+ -- Overwrite --
+ ---------------
+
+ function Overwrite
+ (Source : Unbounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Position > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Result is same with source string, reuse source shared string
+
+ elsif New_Item'Length = 0 then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
+ DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
+ DR.Data (Position + New_Item'Length .. DL) :=
+ SR.Data (Position + New_Item'Length .. SR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Overwrite;
+
+ procedure Overwrite
+ (Source : in out Unbounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Bounds check
+
+ if Position > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_Wide_String'Access;
+ Unreference (SR);
+
+ -- String unchanged, nothing to do
+
+ elsif New_Item'Length = 0 then
+ null;
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
+ SR.Last := DL;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1);
+ DR.Data (Position .. Position + New_Item'Length - 1) := New_Item;
+ DR.Data (Position + New_Item'Length .. DL) :=
+ SR.Data (Position + New_Item'Length .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Overwrite;
+
+ ---------------
+ -- Reference --
+ ---------------
+
+ procedure Reference (Item : not null Shared_Wide_Wide_String_Access) is
+ begin
+ System.Atomic_Counters.Increment (Item.Counter);
+ end Reference;
+
+ ---------------------
+ -- Replace_Element --
+ ---------------------
+
+ procedure Replace_Element
+ (Source : in out Unbounded_Wide_Wide_String;
+ Index : Positive;
+ By : Wide_Wide_Character)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Bounds check
+
+ if Index <= SR.Last then
+
+ -- Try to reuse existent shared string
+
+ if Can_Be_Reused (SR, SR.Last) then
+ SR.Data (Index) := By;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+ DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
+ DR.Data (Index) := By;
+ DR.Last := SR.Last;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+
+ else
+ raise Index_Error;
+ end if;
+ end Replace_Element;
+
+ -------------------
+ -- Replace_Slice --
+ -------------------
+
+ function Replace_Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Low > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Do replace operation when removed slice is not empty
+
+ if High >= Low then
+ DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
+ -- This is the number of characters remaining in the string after
+ -- replacing the slice.
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
+ DR.Data (Low .. Low + By'Length - 1) := By;
+ DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+
+ -- Otherwise just insert string
+
+ else
+ return Insert (Source, Low, By);
+ end if;
+ end Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Bounds check
+
+ if Low > SR.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ -- Do replace operation only when replaced slice is not empty
+
+ if High >= Low then
+ DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1;
+ -- This is the number of characters remaining in the string after
+ -- replacing the slice.
+
+ -- Result is empty string, reuse empty shared string
+
+ if DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_Wide_String'Access;
+ Unreference (SR);
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
+ SR.Data (Low .. Low + By'Length - 1) := By;
+ SR.Last := DL;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1);
+ DR.Data (Low .. Low + By'Length - 1) := By;
+ DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+
+ -- Otherwise just insert item
+
+ else
+ Insert (Source, Low, By);
+ end if;
+ end Replace_Slice;
+
+ -------------------------------
+ -- Set_Unbounded_Wide_Wide_String --
+ -------------------------------
+
+ procedure Set_Unbounded_Wide_Wide_String
+ (Target : out Unbounded_Wide_Wide_String;
+ Source : Wide_Wide_String)
+ is
+ TR : constant Shared_Wide_Wide_String_Access := Target.Reference;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- In case of empty string, reuse empty shared string
+
+ if Source'Length = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ Target.Reference := Empty_Shared_Wide_Wide_String'Access;
+
+ else
+ -- Try to reuse existent shared string
+
+ if Can_Be_Reused (TR, Source'Length) then
+ Reference (TR);
+ DR := TR;
+
+ -- Otherwise allocate new shared string
+
+ else
+ DR := Allocate (Source'Length);
+ Target.Reference := DR;
+ end if;
+
+ DR.Data (1 .. Source'Length) := Source;
+ DR.Last := Source'Length;
+ end if;
+
+ Unreference (TR);
+ end Set_Unbounded_Wide_Wide_String;
+
+ -----------
+ -- Slice --
+ -----------
+
+ function Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural) return Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+
+ begin
+ -- Note: test of High > Length is in accordance with AI95-00128
+
+ if Low > SR.Last + 1 or else High > SR.Last then
+ raise Index_Error;
+
+ else
+ return SR.Data (Low .. High);
+ end if;
+ end Slice;
+
+ ----------
+ -- Tail --
+ ----------
+
+ function Tail
+ (Source : Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ return Unbounded_Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- For empty result reuse empty shared string
+
+ if Count = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Result is hole source string, reuse source shared string
+
+ elsif Count = SR.Last then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
+
+ else
+ for J in 1 .. Count - SR.Last loop
+ DR.Data (J) := Pad;
+ end loop;
+
+ DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
+ end if;
+
+ DR.Last := Count;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Tail;
+
+ procedure Tail
+ (Source : in out Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_Wide_String_Access;
+
+ procedure Common
+ (SR : Shared_Wide_Wide_String_Access;
+ DR : Shared_Wide_Wide_String_Access;
+ Count : Natural);
+ -- Common code of tail computation. SR/DR can point to the same object
+
+ ------------
+ -- Common --
+ ------------
+
+ procedure Common
+ (SR : Shared_Wide_Wide_String_Access;
+ DR : Shared_Wide_Wide_String_Access;
+ Count : Natural) is
+ begin
+ if Count < SR.Last then
+ DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last);
+
+ else
+ DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last);
+
+ for J in 1 .. Count - SR.Last loop
+ DR.Data (J) := Pad;
+ end loop;
+ end if;
+
+ DR.Last := Count;
+ end Common;
+
+ begin
+ -- Result is empty string, reuse empty shared string
+
+ if Count = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_Wide_String'Access;
+ Unreference (SR);
+
+ -- Length of the result is the same with length of the source string,
+ -- reuse source shared string.
+
+ elsif Count = SR.Last then
+ null;
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, Count) then
+ Common (SR, SR, Count);
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (Count);
+ Common (SR, DR, Count);
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Tail;
+
+ -------------------------
+ -- To_Wide_Wide_String --
+ -------------------------
+
+ function To_Wide_Wide_String
+ (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String is
+ begin
+ return Source.Reference.Data (1 .. Source.Reference.Last);
+ end To_Wide_Wide_String;
+
+ -----------------------------------
+ -- To_Unbounded_Wide_Wide_String --
+ -----------------------------------
+
+ function To_Unbounded_Wide_Wide_String
+ (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ is
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ if Source'Length = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ else
+ DR := Allocate (Source'Length);
+ DR.Data (1 .. Source'Length) := Source;
+ DR.Last := Source'Length;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end To_Unbounded_Wide_Wide_String;
+
+ function To_Unbounded_Wide_Wide_String
+ (Length : Natural) return Unbounded_Wide_Wide_String
+ is
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ if Length = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ else
+ DR := Allocate (Length);
+ DR.Last := Length;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end To_Unbounded_Wide_Wide_String;
+
+ ---------------
+ -- Translate --
+ ---------------
+
+ function Translate
+ (Source : Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ return Unbounded_Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Nothing to translate, reuse empty shared string
+
+ if SR.Last = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Value (Mapping, SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Nothing to translate
+
+ if SR.Last = 0 then
+ null;
+
+ -- Try to reuse shared string
+
+ elsif Can_Be_Reused (SR, SR.Last) then
+ for J in 1 .. SR.Last loop
+ SR.Data (J) := Value (Mapping, SR.Data (J));
+ end loop;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Value (Mapping, SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end Translate;
+
+ function Translate
+ (Source : Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Unbounded_Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Nothing to translate, reuse empty shared string
+
+ if SR.Last = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Mapping.all (SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+
+ exception
+ when others =>
+ Unreference (DR);
+
+ raise;
+ end Translate;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Nothing to translate
+
+ if SR.Last = 0 then
+ null;
+
+ -- Try to reuse shared string
+
+ elsif Can_Be_Reused (SR, SR.Last) then
+ for J in 1 .. SR.Last loop
+ SR.Data (J) := Mapping.all (SR.Data (J));
+ end loop;
+
+ -- Otherwise allocate new shared string and fill it
+
+ else
+ DR := Allocate (SR.Last);
+
+ for J in 1 .. SR.Last loop
+ DR.Data (J) := Mapping.all (SR.Data (J));
+ end loop;
+
+ DR.Last := SR.Last;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+
+ exception
+ when others =>
+ if DR /= null then
+ Unreference (DR);
+ end if;
+
+ raise;
+ end Translate;
+
+ ----------
+ -- Trim --
+ ----------
+
+ function Trim
+ (Source : Unbounded_Wide_Wide_String;
+ Side : Trim_End) return Unbounded_Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index_Non_Blank (Source, Forward);
+
+ -- All blanks, reuse empty shared string
+
+ if Low = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ else
+ case Side is
+ when Left =>
+ High := SR.Last;
+ DL := SR.Last - Low + 1;
+
+ when Right =>
+ Low := 1;
+ High := Index_Non_Blank (Source, Backward);
+ DL := High;
+
+ when Both =>
+ High := Index_Non_Blank (Source, Backward);
+ DL := High - Low + 1;
+ end case;
+
+ -- Length of the result is the same as length of the source string,
+ -- reuse source shared string.
+
+ if DL = SR.Last then
+ Reference (SR);
+ DR := SR;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ end if;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_Wide_String;
+ Side : Trim_End)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index_Non_Blank (Source, Forward);
+
+ -- All blanks, reuse empty shared string
+
+ if Low = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_Wide_String'Access;
+ Unreference (SR);
+
+ else
+ case Side is
+ when Left =>
+ High := SR.Last;
+ DL := SR.Last - Low + 1;
+
+ when Right =>
+ Low := 1;
+ High := Index_Non_Blank (Source, Backward);
+ DL := High;
+
+ when Both =>
+ High := Index_Non_Blank (Source, Backward);
+ DL := High - Low + 1;
+ end case;
+
+ -- Length of the result is the same as length of the source string,
+ -- nothing to do.
+
+ if DL = SR.Last then
+ null;
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (1 .. DL) := SR.Data (Low .. High);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end if;
+ end Trim;
+
+ function Trim
+ (Source : Unbounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
+ return Unbounded_Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index (Source, Left, Outside, Forward);
+
+ -- Source includes only characters from Left set, reuse empty shared
+ -- string.
+
+ if Low = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ else
+ High := Index (Source, Right, Outside, Backward);
+ DL := Integer'Max (0, High - Low + 1);
+
+ -- Source includes only characters from Right set or result string
+ -- is empty, reuse empty shared string.
+
+ if High = 0 or else DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ end if;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Trim;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+ Low : Natural;
+ High : Natural;
+
+ begin
+ Low := Index (Source, Left, Outside, Forward);
+
+ -- Source includes only characters from Left set, reuse empty shared
+ -- string.
+
+ if Low = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_Wide_String'Access;
+ Unreference (SR);
+
+ else
+ High := Index (Source, Right, Outside, Backward);
+ DL := Integer'Max (0, High - Low + 1);
+
+ -- Source includes only characters from Right set or result string
+ -- is empty, reuse empty shared string.
+
+ if High = 0 or else DL = 0 then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ Source.Reference := Empty_Shared_Wide_Wide_String'Access;
+ Unreference (SR);
+
+ -- Try to reuse existent shared string
+
+ elsif Can_Be_Reused (SR, DL) then
+ SR.Data (1 .. DL) := SR.Data (Low .. High);
+ SR.Last := DL;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ Source.Reference := DR;
+ Unreference (SR);
+ end if;
+ end if;
+ end Trim;
+
+ ---------------------
+ -- Unbounded_Slice --
+ ---------------------
+
+ function Unbounded_Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural) return Unbounded_Wide_Wide_String
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Low > SR.Last + 1 or else High > SR.Last then
+ raise Index_Error;
+
+ -- Result is empty slice, reuse empty shared string
+
+ elsif Low > High then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ DR := Empty_Shared_Wide_Wide_String'Access;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DL := High - Low + 1;
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ end if;
+
+ return (AF.Controlled with Reference => DR);
+ end Unbounded_Slice;
+
+ procedure Unbounded_Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Target : out Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural)
+ is
+ SR : constant Shared_Wide_Wide_String_Access := Source.Reference;
+ TR : constant Shared_Wide_Wide_String_Access := Target.Reference;
+ DL : Natural;
+ DR : Shared_Wide_Wide_String_Access;
+
+ begin
+ -- Check bounds
+
+ if Low > SR.Last + 1 or else High > SR.Last then
+ raise Index_Error;
+
+ -- Result is empty slice, reuse empty shared string
+
+ elsif Low > High then
+ Reference (Empty_Shared_Wide_Wide_String'Access);
+ Target.Reference := Empty_Shared_Wide_Wide_String'Access;
+ Unreference (TR);
+
+ else
+ DL := High - Low + 1;
+
+ -- Try to reuse existent shared string
+
+ if Can_Be_Reused (TR, DL) then
+ TR.Data (1 .. DL) := SR.Data (Low .. High);
+ TR.Last := DL;
+
+ -- Otherwise, allocate new shared string and fill it
+
+ else
+ DR := Allocate (DL);
+ DR.Data (1 .. DL) := SR.Data (Low .. High);
+ DR.Last := DL;
+ Target.Reference := DR;
+ Unreference (TR);
+ end if;
+ end if;
+ end Unbounded_Slice;
+
+ -----------------
+ -- Unreference --
+ -----------------
+
+ procedure Unreference (Item : not null Shared_Wide_Wide_String_Access) is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation
+ (Shared_Wide_Wide_String, Shared_Wide_Wide_String_Access);
+
+ Aux : Shared_Wide_Wide_String_Access := Item;
+
+ begin
+ if System.Atomic_Counters.Decrement (Aux.Counter) then
+
+ -- Reference counter of Empty_Shared_Wide_Wide_String must never
+ -- reach zero.
+
+ pragma Assert (Aux /= Empty_Shared_Wide_Wide_String'Access);
+
+ Free (Aux);
+ end if;
+ end Unreference;
+
+end Ada.Strings.Wide_Wide_Unbounded;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is supported on:
+-- - all Alpha platforms
+-- - all ia64 platforms
+-- - all PowerPC platforms
+-- - all SPARC V9 platforms
+-- - all x86 platforms
+-- - all x86_64 platforms
+
+with Ada.Strings.Wide_Wide_Maps;
+private with Ada.Finalization;
+private with System.Atomic_Counters;
+
+package Ada.Strings.Wide_Wide_Unbounded is
+ pragma Preelaborate;
+
+ type Unbounded_Wide_Wide_String is private;
+ pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String);
+
+ Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String;
+
+ function Length (Source : Unbounded_Wide_Wide_String) return Natural;
+
+ type Wide_Wide_String_Access is access all Wide_Wide_String;
+
+ procedure Free (X : in out Wide_Wide_String_Access);
+
+ --------------------------------------------------------
+ -- Conversion, Concatenation, and Selection Functions --
+ --------------------------------------------------------
+
+ function To_Unbounded_Wide_Wide_String
+ (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ function To_Unbounded_Wide_Wide_String
+ (Length : Natural) return Unbounded_Wide_Wide_String;
+
+ function To_Wide_Wide_String
+ (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String;
+
+ procedure Set_Unbounded_Wide_Wide_String
+ (Target : out Unbounded_Wide_Wide_String;
+ Source : Wide_Wide_String);
+ pragma Ada_05 (Set_Unbounded_Wide_Wide_String);
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Unbounded_Wide_Wide_String);
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Wide_Wide_String);
+
+ procedure Append
+ (Source : in out Unbounded_Wide_Wide_String;
+ New_Item : Wide_Wide_Character);
+
+ function "&"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String;
+
+ function "&"
+ (Left : Wide_Wide_Character;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ function Element
+ (Source : Unbounded_Wide_Wide_String;
+ Index : Positive) return Wide_Wide_Character;
+
+ procedure Replace_Element
+ (Source : in out Unbounded_Wide_Wide_String;
+ Index : Positive;
+ By : Wide_Wide_Character);
+
+ function Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural) return Wide_Wide_String;
+
+ function Unbounded_Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural) return Unbounded_Wide_Wide_String;
+ pragma Ada_05 (Unbounded_Slice);
+
+ procedure Unbounded_Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Target : out Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural);
+ pragma Ada_05 (Unbounded_Slice);
+
+ function "="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function "="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function "="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function "<"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function "<"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function "<"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function "<="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function "<="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function "<="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function ">"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function ">"
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function ">"
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function ">="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ function ">="
+ (Left : Unbounded_Wide_Wide_String;
+ Right : Wide_Wide_String) return Boolean;
+
+ function ">="
+ (Left : Wide_Wide_String;
+ Right : Unbounded_Wide_Wide_String) return Boolean;
+
+ ------------------------
+ -- Search Subprograms --
+ ------------------------
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+ pragma Ada_05 (Index);
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+ pragma Ada_05 (Index);
+
+ function Index
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Membership := Inside;
+ Going : Direction := Forward) return Natural;
+ pragma Ada_05 (Index);
+
+ function Index_Non_Blank
+ (Source : Unbounded_Wide_Wide_String;
+ Going : Direction := Forward) return Natural;
+
+ function Index_Non_Blank
+ (Source : Unbounded_Wide_Wide_String;
+ From : Positive;
+ Going : Direction := Forward) return Natural;
+ pragma Ada_05 (Index_Non_Blank);
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
+ Wide_Wide_Maps.Identity)
+ return Natural;
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Pattern : Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Count
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural;
+
+ procedure Find_Token
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ From : Positive;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+ pragma Ada_2012 (Find_Token);
+
+ procedure Find_Token
+ (Source : Unbounded_Wide_Wide_String;
+ Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ------------------------------------
+ -- String Translation Subprograms --
+ ------------------------------------
+
+ function Translate
+ (Source : Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
+ return Unbounded_Wide_Wide_String;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping);
+
+ function Translate
+ (Source : Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
+ return Unbounded_Wide_Wide_String;
+
+ procedure Translate
+ (Source : in out Unbounded_Wide_Wide_String;
+ Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function);
+
+ ---------------------------------------
+ -- String Transformation Subprograms --
+ ---------------------------------------
+
+ function Replace_Slice
+ (Source : Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ procedure Replace_Slice
+ (Source : in out Unbounded_Wide_Wide_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_Wide_String);
+
+ function Insert
+ (Source : Unbounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ procedure Insert
+ (Source : in out Unbounded_Wide_Wide_String;
+ Before : Positive;
+ New_Item : Wide_Wide_String);
+
+ function Overwrite
+ (Source : Unbounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ procedure Overwrite
+ (Source : in out Unbounded_Wide_Wide_String;
+ Position : Positive;
+ New_Item : Wide_Wide_String);
+
+ function Delete
+ (Source : Unbounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural) return Unbounded_Wide_Wide_String;
+
+ procedure Delete
+ (Source : in out Unbounded_Wide_Wide_String;
+ From : Positive;
+ Through : Natural);
+
+ function Trim
+ (Source : Unbounded_Wide_Wide_String;
+ Side : Trim_End) return Unbounded_Wide_Wide_String;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_Wide_String;
+ Side : Trim_End);
+
+ function Trim
+ (Source : Unbounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
+ return Unbounded_Wide_Wide_String;
+
+ procedure Trim
+ (Source : in out Unbounded_Wide_Wide_String;
+ Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
+ Right : Wide_Wide_Maps.Wide_Wide_Character_Set);
+
+ function Head
+ (Source : Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ return Unbounded_Wide_Wide_String;
+
+ procedure Head
+ (Source : in out Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space);
+
+ function Tail
+ (Source : Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space)
+ return Unbounded_Wide_Wide_String;
+
+ procedure Tail
+ (Source : in out Unbounded_Wide_Wide_String;
+ Count : Natural;
+ Pad : Wide_Wide_Character := Wide_Wide_Space);
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String;
+
+ function "*"
+ (Left : Natural;
+ Right : Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+ function "*"
+ (Left : Natural;
+ Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
+
+private
+ pragma Inline (Length);
+
+ package AF renames Ada.Finalization;
+
+ type Shared_Wide_Wide_String (Max_Length : Natural) is limited record
+ Counter : System.Atomic_Counters.Atomic_Counter;
+ -- Reference counter
+
+ Last : Natural := 0;
+ Data : Wide_Wide_String (1 .. Max_Length);
+ -- Last is the index of last significant element of the Data. All
+ -- elements with larger indexes are just extra room for expansion.
+ end record;
+
+ type Shared_Wide_Wide_String_Access is access all Shared_Wide_Wide_String;
+
+ procedure Reference (Item : not null Shared_Wide_Wide_String_Access);
+ -- Increment reference counter.
+
+ procedure Unreference (Item : not null Shared_Wide_Wide_String_Access);
+ -- Decrement reference counter. Deallocate Item when reference counter is
+ -- zero.
+
+ function Can_Be_Reused
+ (Item : Shared_Wide_Wide_String_Access;
+ Length : Natural) return Boolean;
+ -- Returns True if Shared_Wide_Wide_String can be reused. There are two
+ -- criteria when Shared_Wide_Wide_String can be reused: its reference
+ -- counter must be one (thus Shared_Wide_Wide_String is owned exclusively)
+ -- and its size is sufficient to store string with specified length
+ -- effectively.
+
+ function Allocate
+ (Max_Length : Natural) return Shared_Wide_Wide_String_Access;
+ -- Allocates new Shared_Wide_Wide_String with at least specified maximum
+ -- length. Actual maximum length of the allocated Shared_Wide_Wide_String
+ -- can be slightly greater. Returns reference to
+ -- Empty_Shared_Wide_Wide_String when requested length is zero.
+
+ Empty_Shared_Wide_Wide_String : aliased Shared_Wide_Wide_String (0);
+
+ function To_Unbounded
+ (S : Wide_Wide_String) return Unbounded_Wide_Wide_String
+ renames To_Unbounded_Wide_Wide_String;
+ -- This renames are here only to be used in the pragma Stream_Convert.
+
+ type Unbounded_Wide_Wide_String is new AF.Controlled with record
+ Reference : Shared_Wide_Wide_String_Access :=
+ Empty_Shared_Wide_Wide_String'Access;
+ end record;
+
+ -- The Unbounded_Wide_Wide_String uses several techniques to increase speed
+ -- of the application:
+
+ -- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String
+ -- contains only the reference to the data which is shared between
+ -- several instances. The shared data is reallocated only when its value
+ -- is changed and the object mutation can't be used or it is inefficient
+ -- to use it;
+
+ -- - object mutation. Shared data object can be reused without memory
+ -- reallocation when all of the following requirements are meat:
+ -- - shared data object don't used anywhere longer;
+ -- - its size is sufficient to store new value;
+ -- - the gap after reuse is less than some threshold.
+
+ -- - memory preallocation. Most of used memory allocation algorithms
+ -- aligns allocated segment on the some boundary, thus some amount of
+ -- additional memory can be preallocated without any impact. Such
+ -- preallocated memory can used later by Append/Insert operations
+ -- without reallocation.
+
+ -- Reference counting uses GCC builtin atomic operations, which allows safe
+ -- sharing of internal data between Ada tasks. Nevertheless, this does not
+ -- make objects of Unbounded_String thread-safe: an instance cannot be
+ -- accessed by several tasks simultaneously.
+
+ pragma Stream_Convert
+ (Unbounded_Wide_Wide_String, To_Unbounded, To_Wide_Wide_String);
+ -- Provide stream routines without dragging in Ada.Streams
+
+ pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String);
+ -- Finalization is required only for freeing storage
+
+ overriding procedure Initialize
+ (Object : in out Unbounded_Wide_Wide_String);
+ overriding procedure Adjust
+ (Object : in out Unbounded_Wide_Wide_String);
+ overriding procedure Finalize
+ (Object : in out Unbounded_Wide_Wide_String);
+
+ Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String :=
+ (AF.Controlled with
+ Reference =>
+ Empty_Shared_Wide_Wide_String'
+ Access);
+
+end Ada.Strings.Wide_Wide_Unbounded;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Text_IO; use Ada.Text_IO;
-
-package body Ada.Strings.Unbounded.Text_IO is
-
- --------------
- -- Get_Line --
- --------------
-
- function Get_Line return Unbounded_String is
- Buffer : String (1 .. 1000);
- Last : Natural;
- Result : Unbounded_String;
-
- begin
- Get_Line (Buffer, Last);
- Set_Unbounded_String (Result, Buffer (1 .. Last));
-
- while Last = Buffer'Last loop
- Get_Line (Buffer, Last);
- Append (Result, Buffer (1 .. Last));
- end loop;
-
- return Result;
- end Get_Line;
-
- function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String is
- Buffer : String (1 .. 1000);
- Last : Natural;
- Result : Unbounded_String;
-
- begin
- Get_Line (File, Buffer, Last);
- Set_Unbounded_String (Result, Buffer (1 .. Last));
-
- while Last = Buffer'Last loop
- Get_Line (File, Buffer, Last);
- Append (Result, Buffer (1 .. Last));
- end loop;
-
- return Result;
- end Get_Line;
-
- procedure Get_Line (Item : out Unbounded_String) is
- begin
- Get_Line (Current_Input, Item);
- end Get_Line;
-
- procedure Get_Line
- (File : Ada.Text_IO.File_Type;
- Item : out Unbounded_String)
- is
- Buffer : String (1 .. 1000);
- Last : Natural;
-
- begin
- Get_Line (File, Buffer, Last);
- Set_Unbounded_String (Item, Buffer (1 .. Last));
-
- while Last = Buffer'Last loop
- Get_Line (File, Buffer, Last);
- Append (Item, Buffer (1 .. Last));
- end loop;
- end Get_Line;
-
- ---------
- -- Put --
- ---------
-
- procedure Put (U : Unbounded_String) is
- UR : constant Shared_String_Access := U.Reference;
-
- begin
- Put (UR.Data (1 .. UR.Last));
- end Put;
-
- procedure Put (File : File_Type; U : Unbounded_String) is
- UR : constant Shared_String_Access := U.Reference;
-
- begin
- Put (File, UR.Data (1 .. UR.Last));
- end Put;
-
- --------------
- -- Put_Line --
- --------------
-
- procedure Put_Line (U : Unbounded_String) is
- UR : constant Shared_String_Access := U.Reference;
-
- begin
- Put_Line (UR.Data (1 .. UR.Last));
- end Put_Line;
-
- procedure Put_Line (File : File_Type; U : Unbounded_String) is
- UR : constant Shared_String_Access := U.Reference;
-
- begin
- Put_Line (File, UR.Data (1 .. UR.Last));
- end Put_Line;
-
-end Ada.Strings.Unbounded.Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1997-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+package body Ada.Strings.Unbounded.Text_IO is
+
+ --------------
+ -- Get_Line --
+ --------------
+
+ function Get_Line return Unbounded_String is
+ Buffer : String (1 .. 1000);
+ Last : Natural;
+ Result : Unbounded_String;
+
+ begin
+ Get_Line (Buffer, Last);
+ Set_Unbounded_String (Result, Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (Buffer, Last);
+ Append (Result, Buffer (1 .. Last));
+ end loop;
+
+ return Result;
+ end Get_Line;
+
+ function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String is
+ Buffer : String (1 .. 1000);
+ Last : Natural;
+ Result : Unbounded_String;
+
+ begin
+ Get_Line (File, Buffer, Last);
+ Set_Unbounded_String (Result, Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (File, Buffer, Last);
+ Append (Result, Buffer (1 .. Last));
+ end loop;
+
+ return Result;
+ end Get_Line;
+
+ procedure Get_Line (Item : out Unbounded_String) is
+ begin
+ Get_Line (Current_Input, Item);
+ end Get_Line;
+
+ procedure Get_Line
+ (File : Ada.Text_IO.File_Type;
+ Item : out Unbounded_String)
+ is
+ Buffer : String (1 .. 1000);
+ Last : Natural;
+
+ begin
+ Get_Line (File, Buffer, Last);
+ Set_Unbounded_String (Item, Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (File, Buffer, Last);
+ Append (Item, Buffer (1 .. Last));
+ end loop;
+ end Get_Line;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (U : Unbounded_String) is
+ UR : constant Shared_String_Access := U.Reference;
+
+ begin
+ Put (UR.Data (1 .. UR.Last));
+ end Put;
+
+ procedure Put (File : File_Type; U : Unbounded_String) is
+ UR : constant Shared_String_Access := U.Reference;
+
+ begin
+ Put (File, UR.Data (1 .. UR.Last));
+ end Put;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line (U : Unbounded_String) is
+ UR : constant Shared_String_Access := U.Reference;
+
+ begin
+ Put_Line (UR.Data (1 .. UR.Last));
+ end Put_Line;
+
+ procedure Put_Line (File : File_Type; U : Unbounded_String) is
+ UR : constant Shared_String_Access := U.Reference;
+
+ begin
+ Put_Line (File, UR.Data (1 .. UR.Last));
+ end Put_Line;
+
+end Ada.Strings.Unbounded.Text_IO;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-package body Ada.Strings.Wide_Unbounded.Aux is
-
- ---------------------
- -- Get_Wide_String --
- ---------------------
-
- procedure Get_Wide_String
- (U : Unbounded_Wide_String;
- S : out Big_Wide_String_Access;
- L : out Natural)
- is
- X : aliased Big_Wide_String;
- for X'Address use U.Reference.Data'Address;
- begin
- S := X'Unchecked_Access;
- L := U.Reference.Last;
- end Get_Wide_String;
-
- ---------------------
- -- Set_Wide_String --
- ---------------------
-
- procedure Set_Wide_String
- (UP : in out Unbounded_Wide_String;
- S : Wide_String_Access)
- is
- X : Wide_String_Access := S;
-
- begin
- Set_Unbounded_Wide_String (UP, S.all);
- Free (X);
- end Set_Wide_String;
-
-end Ada.Strings.Wide_Unbounded.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Strings.Wide_Unbounded.Aux is
+
+ ---------------------
+ -- Get_Wide_String --
+ ---------------------
+
+ procedure Get_Wide_String
+ (U : Unbounded_Wide_String;
+ S : out Big_Wide_String_Access;
+ L : out Natural)
+ is
+ X : aliased Big_Wide_String;
+ for X'Address use U.Reference.Data'Address;
+ begin
+ S := X'Unchecked_Access;
+ L := U.Reference.Last;
+ end Get_Wide_String;
+
+ ---------------------
+ -- Set_Wide_String --
+ ---------------------
+
+ procedure Set_Wide_String
+ (UP : in out Unbounded_Wide_String;
+ S : Wide_String_Access)
+ is
+ X : Wide_String_Access := S;
+
+ begin
+ Set_Unbounded_Wide_String (UP, S.all);
+ Free (X);
+ end Set_Wide_String;
+
+end Ada.Strings.Wide_Unbounded.Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Wide_Text_IO; use Ada.Wide_Text_IO;
-
-package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is
-
- --------------
- -- Get_Line --
- --------------
-
- function Get_Line return Unbounded_Wide_String is
- Buffer : Wide_String (1 .. 1000);
- Last : Natural;
- Result : Unbounded_Wide_String;
-
- begin
- Get_Line (Buffer, Last);
- Set_Unbounded_Wide_String (Result, Buffer (1 .. Last));
-
- while Last = Buffer'Last loop
- Get_Line (Buffer, Last);
- Append (Result, Buffer (1 .. Last));
- end loop;
-
- return Result;
- end Get_Line;
-
- function Get_Line
- (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String
- is
- Buffer : Wide_String (1 .. 1000);
- Last : Natural;
- Result : Unbounded_Wide_String;
-
- begin
- Get_Line (File, Buffer, Last);
- Set_Unbounded_Wide_String (Result, Buffer (1 .. Last));
-
- while Last = Buffer'Last loop
- Get_Line (File, Buffer, Last);
- Append (Result, Buffer (1 .. Last));
- end loop;
-
- return Result;
- end Get_Line;
-
- procedure Get_Line (Item : out Unbounded_Wide_String) is
- begin
- Get_Line (Current_Input, Item);
- end Get_Line;
-
- procedure Get_Line
- (File : Ada.Wide_Text_IO.File_Type;
- Item : out Unbounded_Wide_String)
- is
- Buffer : Wide_String (1 .. 1000);
- Last : Natural;
-
- begin
- Get_Line (File, Buffer, Last);
- Set_Unbounded_Wide_String (Item, Buffer (1 .. Last));
-
- while Last = Buffer'Last loop
- Get_Line (File, Buffer, Last);
- Append (Item, Buffer (1 .. Last));
- end loop;
- end Get_Line;
-
- ---------
- -- Put --
- ---------
-
- procedure Put (U : Unbounded_Wide_String) is
- UR : constant Shared_Wide_String_Access := U.Reference;
-
- begin
- Put (UR.Data (1 .. UR.Last));
- end Put;
-
- procedure Put (File : File_Type; U : Unbounded_Wide_String) is
- UR : constant Shared_Wide_String_Access := U.Reference;
-
- begin
- Put (File, UR.Data (1 .. UR.Last));
- end Put;
-
- --------------
- -- Put_Line --
- --------------
-
- procedure Put_Line (U : Unbounded_Wide_String) is
- UR : constant Shared_Wide_String_Access := U.Reference;
-
- begin
- Put_Line (UR.Data (1 .. UR.Last));
- end Put_Line;
-
- procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is
- UR : constant Shared_Wide_String_Access := U.Reference;
-
- begin
- Put_Line (File, UR.Data (1 .. UR.Last));
- end Put_Line;
-
-end Ada.Strings.Wide_Unbounded.Wide_Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1997-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Text_IO; use Ada.Wide_Text_IO;
+
+package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is
+
+ --------------
+ -- Get_Line --
+ --------------
+
+ function Get_Line return Unbounded_Wide_String is
+ Buffer : Wide_String (1 .. 1000);
+ Last : Natural;
+ Result : Unbounded_Wide_String;
+
+ begin
+ Get_Line (Buffer, Last);
+ Set_Unbounded_Wide_String (Result, Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (Buffer, Last);
+ Append (Result, Buffer (1 .. Last));
+ end loop;
+
+ return Result;
+ end Get_Line;
+
+ function Get_Line
+ (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String
+ is
+ Buffer : Wide_String (1 .. 1000);
+ Last : Natural;
+ Result : Unbounded_Wide_String;
+
+ begin
+ Get_Line (File, Buffer, Last);
+ Set_Unbounded_Wide_String (Result, Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (File, Buffer, Last);
+ Append (Result, Buffer (1 .. Last));
+ end loop;
+
+ return Result;
+ end Get_Line;
+
+ procedure Get_Line (Item : out Unbounded_Wide_String) is
+ begin
+ Get_Line (Current_Input, Item);
+ end Get_Line;
+
+ procedure Get_Line
+ (File : Ada.Wide_Text_IO.File_Type;
+ Item : out Unbounded_Wide_String)
+ is
+ Buffer : Wide_String (1 .. 1000);
+ Last : Natural;
+
+ begin
+ Get_Line (File, Buffer, Last);
+ Set_Unbounded_Wide_String (Item, Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (File, Buffer, Last);
+ Append (Item, Buffer (1 .. Last));
+ end loop;
+ end Get_Line;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (U : Unbounded_Wide_String) is
+ UR : constant Shared_Wide_String_Access := U.Reference;
+
+ begin
+ Put (UR.Data (1 .. UR.Last));
+ end Put;
+
+ procedure Put (File : File_Type; U : Unbounded_Wide_String) is
+ UR : constant Shared_Wide_String_Access := U.Reference;
+
+ begin
+ Put (File, UR.Data (1 .. UR.Last));
+ end Put;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line (U : Unbounded_Wide_String) is
+ UR : constant Shared_Wide_String_Access := U.Reference;
+
+ begin
+ Put_Line (UR.Data (1 .. UR.Last));
+ end Put_Line;
+
+ procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is
+ UR : constant Shared_Wide_String_Access := U.Reference;
+
+ begin
+ Put_Line (File, UR.Data (1 .. UR.Last));
+ end Put_Line;
+
+end Ada.Strings.Wide_Unbounded.Wide_Text_IO;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-package body Ada.Strings.Wide_Wide_Unbounded.Aux is
-
- --------------------------
- -- Get_Wide_Wide_String --
- --------------------------
-
- procedure Get_Wide_Wide_String
- (U : Unbounded_Wide_Wide_String;
- S : out Big_Wide_Wide_String_Access;
- L : out Natural)
- is
- X : aliased Big_Wide_Wide_String;
- for X'Address use U.Reference.Data'Address;
- begin
- S := X'Unchecked_Access;
- L := U.Reference.Last;
- end Get_Wide_Wide_String;
-
- --------------------------
- -- Set_Wide_Wide_String --
- --------------------------
-
- procedure Set_Wide_Wide_String
- (UP : in out Unbounded_Wide_Wide_String;
- S : Wide_Wide_String_Access)
- is
- X : Wide_Wide_String_Access := S;
-
- begin
- Set_Unbounded_Wide_Wide_String (UP, S.all);
- Free (X);
- end Set_Wide_Wide_String;
-
-end Ada.Strings.Wide_Wide_Unbounded.Aux;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body Ada.Strings.Wide_Wide_Unbounded.Aux is
+
+ --------------------------
+ -- Get_Wide_Wide_String --
+ --------------------------
+
+ procedure Get_Wide_Wide_String
+ (U : Unbounded_Wide_Wide_String;
+ S : out Big_Wide_Wide_String_Access;
+ L : out Natural)
+ is
+ X : aliased Big_Wide_Wide_String;
+ for X'Address use U.Reference.Data'Address;
+ begin
+ S := X'Unchecked_Access;
+ L := U.Reference.Last;
+ end Get_Wide_Wide_String;
+
+ --------------------------
+ -- Set_Wide_Wide_String --
+ --------------------------
+
+ procedure Set_Wide_Wide_String
+ (UP : in out Unbounded_Wide_Wide_String;
+ S : Wide_Wide_String_Access)
+ is
+ X : Wide_Wide_String_Access := S;
+
+ begin
+ Set_Unbounded_Wide_Wide_String (UP, S.all);
+ Free (X);
+ end Set_Wide_Wide_String;
+
+end Ada.Strings.Wide_Wide_Unbounded.Aux;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO;
-
-package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is
-
- --------------
- -- Get_Line --
- --------------
-
- function Get_Line return Unbounded_Wide_Wide_String is
- Buffer : Wide_Wide_String (1 .. 1000);
- Last : Natural;
- Result : Unbounded_Wide_Wide_String;
-
- begin
- Get_Line (Buffer, Last);
- Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last));
-
- while Last = Buffer'Last loop
- Get_Line (Buffer, Last);
- Append (Result, Buffer (1 .. Last));
- end loop;
-
- return Result;
- end Get_Line;
-
- function Get_Line
- (File : Ada.Wide_Wide_Text_IO.File_Type)
- return Unbounded_Wide_Wide_String
- is
- Buffer : Wide_Wide_String (1 .. 1000);
- Last : Natural;
- Result : Unbounded_Wide_Wide_String;
-
- begin
- Get_Line (File, Buffer, Last);
- Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last));
-
- while Last = Buffer'Last loop
- Get_Line (File, Buffer, Last);
- Append (Result, Buffer (1 .. Last));
- end loop;
-
- return Result;
- end Get_Line;
-
- procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is
- begin
- Get_Line (Current_Input, Item);
- end Get_Line;
-
- procedure Get_Line
- (File : Ada.Wide_Wide_Text_IO.File_Type;
- Item : out Unbounded_Wide_Wide_String)
- is
- Buffer : Wide_Wide_String (1 .. 1000);
- Last : Natural;
-
- begin
- Get_Line (File, Buffer, Last);
- Set_Unbounded_Wide_Wide_String (Item, Buffer (1 .. Last));
-
- while Last = Buffer'Last loop
- Get_Line (File, Buffer, Last);
- Append (Item, Buffer (1 .. Last));
- end loop;
- end Get_Line;
-
- ---------
- -- Put --
- ---------
-
- procedure Put (U : Unbounded_Wide_Wide_String) is
- UR : constant Shared_Wide_Wide_String_Access := U.Reference;
-
- begin
- Put (UR.Data (1 .. UR.Last));
- end Put;
-
- procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is
- UR : constant Shared_Wide_Wide_String_Access := U.Reference;
-
- begin
- Put (File, UR.Data (1 .. UR.Last));
- end Put;
-
- --------------
- -- Put_Line --
- --------------
-
- procedure Put_Line (U : Unbounded_Wide_Wide_String) is
- UR : constant Shared_Wide_Wide_String_Access := U.Reference;
-
- begin
- Put_Line (UR.Data (1 .. UR.Last));
- end Put_Line;
-
- procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is
- UR : constant Shared_Wide_Wide_String_Access := U.Reference;
-
- begin
- Put_Line (File, UR.Data (1 .. UR.Last));
- end Put_Line;
-
-end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1997-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO;
+
+package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is
+
+ --------------
+ -- Get_Line --
+ --------------
+
+ function Get_Line return Unbounded_Wide_Wide_String is
+ Buffer : Wide_Wide_String (1 .. 1000);
+ Last : Natural;
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Get_Line (Buffer, Last);
+ Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (Buffer, Last);
+ Append (Result, Buffer (1 .. Last));
+ end loop;
+
+ return Result;
+ end Get_Line;
+
+ function Get_Line
+ (File : Ada.Wide_Wide_Text_IO.File_Type)
+ return Unbounded_Wide_Wide_String
+ is
+ Buffer : Wide_Wide_String (1 .. 1000);
+ Last : Natural;
+ Result : Unbounded_Wide_Wide_String;
+
+ begin
+ Get_Line (File, Buffer, Last);
+ Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (File, Buffer, Last);
+ Append (Result, Buffer (1 .. Last));
+ end loop;
+
+ return Result;
+ end Get_Line;
+
+ procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is
+ begin
+ Get_Line (Current_Input, Item);
+ end Get_Line;
+
+ procedure Get_Line
+ (File : Ada.Wide_Wide_Text_IO.File_Type;
+ Item : out Unbounded_Wide_Wide_String)
+ is
+ Buffer : Wide_Wide_String (1 .. 1000);
+ Last : Natural;
+
+ begin
+ Get_Line (File, Buffer, Last);
+ Set_Unbounded_Wide_Wide_String (Item, Buffer (1 .. Last));
+
+ while Last = Buffer'Last loop
+ Get_Line (File, Buffer, Last);
+ Append (Item, Buffer (1 .. Last));
+ end loop;
+ end Get_Line;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (U : Unbounded_Wide_Wide_String) is
+ UR : constant Shared_Wide_Wide_String_Access := U.Reference;
+
+ begin
+ Put (UR.Data (1 .. UR.Last));
+ end Put;
+
+ procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is
+ UR : constant Shared_Wide_Wide_String_Access := U.Reference;
+
+ begin
+ Put (File, UR.Data (1 .. UR.Last));
+ end Put;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line (U : Unbounded_Wide_Wide_String) is
+ UR : constant Shared_Wide_Wide_String_Access := U.Reference;
+
+ begin
+ Put_Line (UR.Data (1 .. UR.Last));
+ end Put_Line;
+
+ procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is
+ UR : constant Shared_Wide_Wide_String_Access := U.Reference;
+
+ begin
+ Put_Line (File, UR.Data (1 .. UR.Last));
+ end Put_Line;
+
+end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S --
--- --
--- B o d y --
--- (Hard Binding Version) --
--- --
--- Copyright (C) 2004-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-package body GNAT.Altivec.Low_Level_Vectors is
-
-end GNAT.Altivec.Low_Level_Vectors;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S --
--- --
--- S p e c --
--- (Hard Binding Version) --
--- --
--- Copyright (C) 2004-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This unit exposes the low level vector support for the Hard binding,
--- intended for AltiVec capable targets. See Altivec.Design for a description
--- of what is expected to be exposed.
-
-package GNAT.Altivec.Low_Level_Vectors is
- pragma Elaborate_Body;
-
- ----------------------------------------
- -- Low-level Vector Type Declarations --
- ----------------------------------------
-
- type LL_VUC is private;
- type LL_VSC is private;
- type LL_VBC is private;
-
- type LL_VUS is private;
- type LL_VSS is private;
- type LL_VBS is private;
-
- type LL_VUI is private;
- type LL_VSI is private;
- type LL_VBI is private;
-
- type LL_VF is private;
- type LL_VP is private;
-
- ------------------------------------
- -- Low-level Functional Interface --
- ------------------------------------
-
- function abs_v16qi (A : LL_VSC) return LL_VSC;
- function abs_v8hi (A : LL_VSS) return LL_VSS;
- function abs_v4si (A : LL_VSI) return LL_VSI;
- function abs_v4sf (A : LL_VF) return LL_VF;
-
- function abss_v16qi (A : LL_VSC) return LL_VSC;
- function abss_v8hi (A : LL_VSS) return LL_VSS;
- function abss_v4si (A : LL_VSI) return LL_VSI;
-
- function vaddubm (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vadduhm (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vadduwm (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vaddfp (A : LL_VF; B : LL_VF) return LL_VF;
-
- function vaddcuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vaddubs (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vaddsbs (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vadduhs (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vaddshs (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vadduws (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vaddsws (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vand (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vandc (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vavgub (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vavgsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vavguh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vavgsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vavguw (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vavgsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vcmpbfp (A : LL_VF; B : LL_VF) return LL_VSI;
-
- function vcmpequb (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vcmpequh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vcmpequw (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vcmpeqfp (A : LL_VF; B : LL_VF) return LL_VF;
-
- function vcmpgefp (A : LL_VF; B : LL_VF) return LL_VF;
-
- function vcmpgtub (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vcmpgtsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vcmpgtuh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vcmpgtsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vcmpgtuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vcmpgtsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vcmpgtfp (A : LL_VF; B : LL_VF) return LL_VF;
-
- function vcfux (A : LL_VUI; B : c_int) return LL_VF;
- function vcfsx (A : LL_VSI; B : c_int) return LL_VF;
-
- function vctsxs (A : LL_VF; B : c_int) return LL_VSI;
- function vctuxs (A : LL_VF; B : c_int) return LL_VUI;
-
- procedure dss (A : c_int);
- procedure dssall;
-
- procedure dst (A : c_ptr; B : c_int; C : c_int);
- procedure dstst (A : c_ptr; B : c_int; C : c_int);
- procedure dststt (A : c_ptr; B : c_int; C : c_int);
- procedure dstt (A : c_ptr; B : c_int; C : c_int);
-
- function vexptefp (A : LL_VF) return LL_VF;
-
- function vrfim (A : LL_VF) return LL_VF;
-
- function lvx (A : c_long; B : c_ptr) return LL_VSI;
- function lvebx (A : c_long; B : c_ptr) return LL_VSC;
- function lvehx (A : c_long; B : c_ptr) return LL_VSS;
- function lvewx (A : c_long; B : c_ptr) return LL_VSI;
- function lvxl (A : c_long; B : c_ptr) return LL_VSI;
-
- function vlogefp (A : LL_VF) return LL_VF;
-
- function lvsl (A : c_long; B : c_ptr) return LL_VSC;
- function lvsr (A : c_long; B : c_ptr) return LL_VSC;
-
- function vmaddfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF;
-
- function vmhaddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS;
-
- function vmaxub (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vmaxsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vmaxuh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vmaxsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vmaxuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vmaxsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vmaxfp (A : LL_VF; B : LL_VF) return LL_VF;
-
- function vmrghb (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vmrghh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vmrghw (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vmrglb (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vmrglh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vmrglw (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function mfvscr return LL_VSS;
-
- function vminfp (A : LL_VF; B : LL_VF) return LL_VF;
- function vminsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vminsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vminsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vminub (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vminuh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vminuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vmladduhm (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS;
-
- function vmhraddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS;
-
- function vmsumubm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI;
- function vmsummbm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI;
- function vmsumuhm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
- function vmsumshm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
- function vmsumuhs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
- function vmsumshs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
-
- procedure mtvscr (A : LL_VSI);
-
- function vmuleub (A : LL_VSC; B : LL_VSC) return LL_VSS;
- function vmuleuh (A : LL_VSS; B : LL_VSS) return LL_VSI;
- function vmulesb (A : LL_VSC; B : LL_VSC) return LL_VSS;
- function vmulesh (A : LL_VSS; B : LL_VSS) return LL_VSI;
-
- function vmulosb (A : LL_VSC; B : LL_VSC) return LL_VSS;
- function vmulosh (A : LL_VSS; B : LL_VSS) return LL_VSI;
- function vmuloub (A : LL_VSC; B : LL_VSC) return LL_VSS;
- function vmulouh (A : LL_VSS; B : LL_VSS) return LL_VSI;
-
- function vnmsubfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF;
-
- function vxor (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vnor (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vor (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vpkuhum (A : LL_VSS; B : LL_VSS) return LL_VSC;
- function vpkuwum (A : LL_VSI; B : LL_VSI) return LL_VSS;
- function vpkpx (A : LL_VSI; B : LL_VSI) return LL_VSS;
- function vpkuhus (A : LL_VSS; B : LL_VSS) return LL_VSC;
- function vpkuwus (A : LL_VSI; B : LL_VSI) return LL_VSS;
- function vpkshss (A : LL_VSS; B : LL_VSS) return LL_VSC;
- function vpkswss (A : LL_VSI; B : LL_VSI) return LL_VSS;
- function vpkshus (A : LL_VSS; B : LL_VSS) return LL_VSC;
- function vpkswus (A : LL_VSI; B : LL_VSI) return LL_VSS;
-
- function vperm_4si (A : LL_VSI; B : LL_VSI; C : LL_VSC) return LL_VSI;
-
- function vrefp (A : LL_VF) return LL_VF;
-
- function vrlb (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vrlh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vrlw (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vrfin (A : LL_VF) return LL_VF;
- function vrfip (A : LL_VF) return LL_VF;
- function vrfiz (A : LL_VF) return LL_VF;
-
- function vrsqrtefp (A : LL_VF) return LL_VF;
-
- function vsel_4si (A : LL_VSI; B : LL_VSI; C : LL_VSI) return LL_VSI;
-
- function vslb (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vslh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vslw (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vsldoi_4si (A : LL_VSI; B : LL_VSI; C : c_int) return LL_VSI;
- function vsldoi_8hi (A : LL_VSS; B : LL_VSS; C : c_int) return LL_VSS;
- function vsldoi_16qi (A : LL_VSC; B : LL_VSC; C : c_int) return LL_VSC;
- function vsldoi_4sf (A : LL_VF; B : LL_VF; C : c_int) return LL_VF;
-
- function vsl (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vslo (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vspltb (A : LL_VSC; B : c_int) return LL_VSC;
- function vsplth (A : LL_VSS; B : c_int) return LL_VSS;
- function vspltw (A : LL_VSI; B : c_int) return LL_VSI;
-
- function vspltisb (A : c_int) return LL_VSC;
- function vspltish (A : c_int) return LL_VSS;
- function vspltisw (A : c_int) return LL_VSI;
-
- function vsrb (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vsrh (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vsrw (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vsrab (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vsrah (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vsraw (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vsr (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vsro (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- procedure stvx (A : LL_VSI; B : c_int; C : c_ptr);
- procedure stvebx (A : LL_VSC; B : c_int; C : c_ptr);
- procedure stvehx (A : LL_VSS; B : c_int; C : c_ptr);
- procedure stvewx (A : LL_VSI; B : c_int; C : c_ptr);
- procedure stvxl (A : LL_VSI; B : c_int; C : c_ptr);
-
- function vsububm (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vsubuhm (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vsubuwm (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vsubfp (A : LL_VF; B : LL_VF) return LL_VF;
-
- function vsubcuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vsububs (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vsubsbs (A : LL_VSC; B : LL_VSC) return LL_VSC;
- function vsubuhs (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vsubshs (A : LL_VSS; B : LL_VSS) return LL_VSS;
- function vsubuws (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vsubsws (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vsum4ubs (A : LL_VSC; B : LL_VSI) return LL_VSI;
- function vsum4sbs (A : LL_VSC; B : LL_VSI) return LL_VSI;
- function vsum4shs (A : LL_VSS; B : LL_VSI) return LL_VSI;
-
- function vsum2sws (A : LL_VSI; B : LL_VSI) return LL_VSI;
- function vsumsws (A : LL_VSI; B : LL_VSI) return LL_VSI;
-
- function vupkhsb (A : LL_VSC) return LL_VSS;
- function vupkhsh (A : LL_VSS) return LL_VSI;
- function vupkhpx (A : LL_VSS) return LL_VSI;
-
- function vupklsb (A : LL_VSC) return LL_VSS;
- function vupklsh (A : LL_VSS) return LL_VSI;
- function vupklpx (A : LL_VSS) return LL_VSI;
-
- function vcmpequb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int;
- function vcmpequh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int;
- function vcmpequw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int;
- function vcmpeqfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
-
- function vcmpgtub_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int;
- function vcmpgtuh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int;
- function vcmpgtuw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int;
- function vcmpgtsb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int;
- function vcmpgtsh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int;
- function vcmpgtsw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int;
- function vcmpgtfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
-
- function vcmpgefp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
- function vcmpbfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
-
-private
-
- ---------------------------------------
- -- Low-level Vector Type Definitions --
- ---------------------------------------
-
- -- [PIM-2.3.3 Alignment of aggregate and unions containing vector types]:
-
- -- "Aggregates (structures and arrays) and unions containing vector
- -- types must be aligned on 16-byte boundaries and their internal
- -- organization padded, if necessary, so that each internal vector
- -- type is aligned on a 16-byte boundary. This is an extension to
- -- all ABIs (AIX, Apple, SVR4, and EABI).
-
- --------------------------
- -- char Core Components --
- --------------------------
-
- type LL_VUC is array (1 .. 16) of unsigned_char;
- for LL_VUC'Alignment use VECTOR_ALIGNMENT;
- pragma Machine_Attribute (LL_VUC, "vector_type");
- pragma Suppress (All_Checks, LL_VUC);
-
- type LL_VSC is array (1 .. 16) of signed_char;
- for LL_VSC'Alignment use VECTOR_ALIGNMENT;
- pragma Machine_Attribute (LL_VSC, "vector_type");
- pragma Suppress (All_Checks, LL_VSC);
-
- type LL_VBC is array (1 .. 16) of unsigned_char;
- for LL_VBC'Alignment use VECTOR_ALIGNMENT;
- pragma Machine_Attribute (LL_VBC, "vector_type");
- pragma Suppress (All_Checks, LL_VBC);
-
- ---------------------------
- -- short Core Components --
- ---------------------------
-
- type LL_VUS is array (1 .. 8) of unsigned_short;
- for LL_VUS'Alignment use VECTOR_ALIGNMENT;
- pragma Machine_Attribute (LL_VUS, "vector_type");
- pragma Suppress (All_Checks, LL_VUS);
-
- type LL_VSS is array (1 .. 8) of signed_short;
- for LL_VSS'Alignment use VECTOR_ALIGNMENT;
- pragma Machine_Attribute (LL_VSS, "vector_type");
- pragma Suppress (All_Checks, LL_VSS);
-
- type LL_VBS is array (1 .. 8) of unsigned_short;
- for LL_VBS'Alignment use VECTOR_ALIGNMENT;
- pragma Machine_Attribute (LL_VBS, "vector_type");
- pragma Suppress (All_Checks, LL_VBS);
-
- -------------------------
- -- int Core Components --
- -------------------------
-
- type LL_VUI is array (1 .. 4) of unsigned_int;
- for LL_VUI'Alignment use VECTOR_ALIGNMENT;
- pragma Machine_Attribute (LL_VUI, "vector_type");
- pragma Suppress (All_Checks, LL_VUI);
-
- type LL_VSI is array (1 .. 4) of signed_int;
- for LL_VSI'Alignment use VECTOR_ALIGNMENT;
- pragma Machine_Attribute (LL_VSI, "vector_type");
- pragma Suppress (All_Checks, LL_VSI);
-
- type LL_VBI is array (1 .. 4) of unsigned_int;
- for LL_VBI'Alignment use VECTOR_ALIGNMENT;
- pragma Machine_Attribute (LL_VBI, "vector_type");
- pragma Suppress (All_Checks, LL_VBI);
-
- ---------------------------
- -- Float Core Components --
- ---------------------------
-
- type LL_VF is array (1 .. 4) of Float;
- for LL_VF'Alignment use VECTOR_ALIGNMENT;
- pragma Machine_Attribute (LL_VF, "vector_type");
- pragma Suppress (All_Checks, LL_VF);
-
- ---------------------------
- -- pixel Core Components --
- ---------------------------
-
- type LL_VP is array (1 .. 8) of pixel;
- for LL_VP'Alignment use VECTOR_ALIGNMENT;
- pragma Machine_Attribute (LL_VP, "vector_type");
- pragma Suppress (All_Checks, LL_VP);
-
- ------------------------------------
- -- Low-level Functional Interface --
- ------------------------------------
-
- -- The functions we have to expose here are exactly those for which
- -- GCC builtins are available. Calls to these functions will be turned
- -- into real AltiVec instructions by the GCC back-end.
-
- pragma Convention_Identifier (LL_Altivec, Intrinsic);
-
- pragma Import (LL_Altivec, dss, "__builtin_altivec_dss");
- pragma Import (LL_Altivec, dssall, "__builtin_altivec_dssall");
- pragma Import (LL_Altivec, dst, "__builtin_altivec_dst");
- pragma Import (LL_Altivec, dstst, "__builtin_altivec_dstst");
- pragma Import (LL_Altivec, dststt, "__builtin_altivec_dststt");
- pragma Import (LL_Altivec, dstt, "__builtin_altivec_dstt");
- pragma Import (LL_Altivec, mtvscr, "__builtin_altivec_mtvscr");
- pragma Import (LL_Altivec, mfvscr, "__builtin_altivec_mfvscr");
- pragma Import (LL_Altivec, stvebx, "__builtin_altivec_stvebx");
- pragma Import (LL_Altivec, stvehx, "__builtin_altivec_stvehx");
- pragma Import (LL_Altivec, stvewx, "__builtin_altivec_stvewx");
- pragma Import (LL_Altivec, stvx, "__builtin_altivec_stvx");
- pragma Import (LL_Altivec, stvxl, "__builtin_altivec_stvxl");
- pragma Import (LL_Altivec, lvebx, "__builtin_altivec_lvebx");
- pragma Import (LL_Altivec, lvehx, "__builtin_altivec_lvehx");
- pragma Import (LL_Altivec, lvewx, "__builtin_altivec_lvewx");
- pragma Import (LL_Altivec, lvx, "__builtin_altivec_lvx");
- pragma Import (LL_Altivec, lvxl, "__builtin_altivec_lvxl");
- pragma Import (LL_Altivec, lvsl, "__builtin_altivec_lvsl");
- pragma Import (LL_Altivec, lvsr, "__builtin_altivec_lvsr");
- pragma Import (LL_Altivec, abs_v16qi, "__builtin_altivec_abs_v16qi");
- pragma Import (LL_Altivec, abs_v8hi, "__builtin_altivec_abs_v8hi");
- pragma Import (LL_Altivec, abs_v4si, "__builtin_altivec_abs_v4si");
- pragma Import (LL_Altivec, abs_v4sf, "__builtin_altivec_abs_v4sf");
- pragma Import (LL_Altivec, abss_v16qi, "__builtin_altivec_abss_v16qi");
- pragma Import (LL_Altivec, abss_v8hi, "__builtin_altivec_abss_v8hi");
- pragma Import (LL_Altivec, abss_v4si, "__builtin_altivec_abss_v4si");
- pragma Import (LL_Altivec, vaddcuw, "__builtin_altivec_vaddcuw");
- pragma Import (LL_Altivec, vaddfp, "__builtin_altivec_vaddfp");
- pragma Import (LL_Altivec, vaddsbs, "__builtin_altivec_vaddsbs");
- pragma Import (LL_Altivec, vaddshs, "__builtin_altivec_vaddshs");
- pragma Import (LL_Altivec, vaddsws, "__builtin_altivec_vaddsws");
- pragma Import (LL_Altivec, vaddubm, "__builtin_altivec_vaddubm");
- pragma Import (LL_Altivec, vaddubs, "__builtin_altivec_vaddubs");
- pragma Import (LL_Altivec, vadduhm, "__builtin_altivec_vadduhm");
- pragma Import (LL_Altivec, vadduhs, "__builtin_altivec_vadduhs");
- pragma Import (LL_Altivec, vadduwm, "__builtin_altivec_vadduwm");
- pragma Import (LL_Altivec, vadduws, "__builtin_altivec_vadduws");
- pragma Import (LL_Altivec, vand, "__builtin_altivec_vand");
- pragma Import (LL_Altivec, vandc, "__builtin_altivec_vandc");
- pragma Import (LL_Altivec, vavgsb, "__builtin_altivec_vavgsb");
- pragma Import (LL_Altivec, vavgsh, "__builtin_altivec_vavgsh");
- pragma Import (LL_Altivec, vavgsw, "__builtin_altivec_vavgsw");
- pragma Import (LL_Altivec, vavgub, "__builtin_altivec_vavgub");
- pragma Import (LL_Altivec, vavguh, "__builtin_altivec_vavguh");
- pragma Import (LL_Altivec, vavguw, "__builtin_altivec_vavguw");
- pragma Import (LL_Altivec, vcfsx, "__builtin_altivec_vcfsx");
- pragma Import (LL_Altivec, vcfux, "__builtin_altivec_vcfux");
- pragma Import (LL_Altivec, vcmpbfp, "__builtin_altivec_vcmpbfp");
- pragma Import (LL_Altivec, vcmpeqfp, "__builtin_altivec_vcmpeqfp");
- pragma Import (LL_Altivec, vcmpequb, "__builtin_altivec_vcmpequb");
- pragma Import (LL_Altivec, vcmpequh, "__builtin_altivec_vcmpequh");
- pragma Import (LL_Altivec, vcmpequw, "__builtin_altivec_vcmpequw");
- pragma Import (LL_Altivec, vcmpgefp, "__builtin_altivec_vcmpgefp");
- pragma Import (LL_Altivec, vcmpgtfp, "__builtin_altivec_vcmpgtfp");
- pragma Import (LL_Altivec, vcmpgtsb, "__builtin_altivec_vcmpgtsb");
- pragma Import (LL_Altivec, vcmpgtsh, "__builtin_altivec_vcmpgtsh");
- pragma Import (LL_Altivec, vcmpgtsw, "__builtin_altivec_vcmpgtsw");
- pragma Import (LL_Altivec, vcmpgtub, "__builtin_altivec_vcmpgtub");
- pragma Import (LL_Altivec, vcmpgtuh, "__builtin_altivec_vcmpgtuh");
- pragma Import (LL_Altivec, vcmpgtuw, "__builtin_altivec_vcmpgtuw");
- pragma Import (LL_Altivec, vctsxs, "__builtin_altivec_vctsxs");
- pragma Import (LL_Altivec, vctuxs, "__builtin_altivec_vctuxs");
- pragma Import (LL_Altivec, vexptefp, "__builtin_altivec_vexptefp");
- pragma Import (LL_Altivec, vlogefp, "__builtin_altivec_vlogefp");
- pragma Import (LL_Altivec, vmaddfp, "__builtin_altivec_vmaddfp");
- pragma Import (LL_Altivec, vmaxfp, "__builtin_altivec_vmaxfp");
- pragma Import (LL_Altivec, vmaxsb, "__builtin_altivec_vmaxsb");
- pragma Import (LL_Altivec, vmaxsh, "__builtin_altivec_vmaxsh");
- pragma Import (LL_Altivec, vmaxsw, "__builtin_altivec_vmaxsw");
- pragma Import (LL_Altivec, vmaxub, "__builtin_altivec_vmaxub");
- pragma Import (LL_Altivec, vmaxuh, "__builtin_altivec_vmaxuh");
- pragma Import (LL_Altivec, vmaxuw, "__builtin_altivec_vmaxuw");
- pragma Import (LL_Altivec, vmhaddshs, "__builtin_altivec_vmhaddshs");
- pragma Import (LL_Altivec, vmhraddshs, "__builtin_altivec_vmhraddshs");
- pragma Import (LL_Altivec, vminfp, "__builtin_altivec_vminfp");
- pragma Import (LL_Altivec, vminsb, "__builtin_altivec_vminsb");
- pragma Import (LL_Altivec, vminsh, "__builtin_altivec_vminsh");
- pragma Import (LL_Altivec, vminsw, "__builtin_altivec_vminsw");
- pragma Import (LL_Altivec, vminub, "__builtin_altivec_vminub");
- pragma Import (LL_Altivec, vminuh, "__builtin_altivec_vminuh");
- pragma Import (LL_Altivec, vminuw, "__builtin_altivec_vminuw");
- pragma Import (LL_Altivec, vmladduhm, "__builtin_altivec_vmladduhm");
- pragma Import (LL_Altivec, vmrghb, "__builtin_altivec_vmrghb");
- pragma Import (LL_Altivec, vmrghh, "__builtin_altivec_vmrghh");
- pragma Import (LL_Altivec, vmrghw, "__builtin_altivec_vmrghw");
- pragma Import (LL_Altivec, vmrglb, "__builtin_altivec_vmrglb");
- pragma Import (LL_Altivec, vmrglh, "__builtin_altivec_vmrglh");
- pragma Import (LL_Altivec, vmrglw, "__builtin_altivec_vmrglw");
- pragma Import (LL_Altivec, vmsummbm, "__builtin_altivec_vmsummbm");
- pragma Import (LL_Altivec, vmsumshm, "__builtin_altivec_vmsumshm");
- pragma Import (LL_Altivec, vmsumshs, "__builtin_altivec_vmsumshs");
- pragma Import (LL_Altivec, vmsumubm, "__builtin_altivec_vmsumubm");
- pragma Import (LL_Altivec, vmsumuhm, "__builtin_altivec_vmsumuhm");
- pragma Import (LL_Altivec, vmsumuhs, "__builtin_altivec_vmsumuhs");
- pragma Import (LL_Altivec, vmulesb, "__builtin_altivec_vmulesb");
- pragma Import (LL_Altivec, vmulesh, "__builtin_altivec_vmulesh");
- pragma Import (LL_Altivec, vmuleub, "__builtin_altivec_vmuleub");
- pragma Import (LL_Altivec, vmuleuh, "__builtin_altivec_vmuleuh");
- pragma Import (LL_Altivec, vmulosb, "__builtin_altivec_vmulosb");
- pragma Import (LL_Altivec, vmulosh, "__builtin_altivec_vmulosh");
- pragma Import (LL_Altivec, vmuloub, "__builtin_altivec_vmuloub");
- pragma Import (LL_Altivec, vmulouh, "__builtin_altivec_vmulouh");
- pragma Import (LL_Altivec, vnmsubfp, "__builtin_altivec_vnmsubfp");
- pragma Import (LL_Altivec, vnor, "__builtin_altivec_vnor");
- pragma Import (LL_Altivec, vxor, "__builtin_altivec_vxor");
- pragma Import (LL_Altivec, vor, "__builtin_altivec_vor");
- pragma Import (LL_Altivec, vperm_4si, "__builtin_altivec_vperm_4si");
- pragma Import (LL_Altivec, vpkpx, "__builtin_altivec_vpkpx");
- pragma Import (LL_Altivec, vpkshss, "__builtin_altivec_vpkshss");
- pragma Import (LL_Altivec, vpkshus, "__builtin_altivec_vpkshus");
- pragma Import (LL_Altivec, vpkswss, "__builtin_altivec_vpkswss");
- pragma Import (LL_Altivec, vpkswus, "__builtin_altivec_vpkswus");
- pragma Import (LL_Altivec, vpkuhum, "__builtin_altivec_vpkuhum");
- pragma Import (LL_Altivec, vpkuhus, "__builtin_altivec_vpkuhus");
- pragma Import (LL_Altivec, vpkuwum, "__builtin_altivec_vpkuwum");
- pragma Import (LL_Altivec, vpkuwus, "__builtin_altivec_vpkuwus");
- pragma Import (LL_Altivec, vrefp, "__builtin_altivec_vrefp");
- pragma Import (LL_Altivec, vrfim, "__builtin_altivec_vrfim");
- pragma Import (LL_Altivec, vrfin, "__builtin_altivec_vrfin");
- pragma Import (LL_Altivec, vrfip, "__builtin_altivec_vrfip");
- pragma Import (LL_Altivec, vrfiz, "__builtin_altivec_vrfiz");
- pragma Import (LL_Altivec, vrlb, "__builtin_altivec_vrlb");
- pragma Import (LL_Altivec, vrlh, "__builtin_altivec_vrlh");
- pragma Import (LL_Altivec, vrlw, "__builtin_altivec_vrlw");
- pragma Import (LL_Altivec, vrsqrtefp, "__builtin_altivec_vrsqrtefp");
- pragma Import (LL_Altivec, vsel_4si, "__builtin_altivec_vsel_4si");
- pragma Import (LL_Altivec, vsldoi_4si, "__builtin_altivec_vsldoi_4si");
- pragma Import (LL_Altivec, vsldoi_8hi, "__builtin_altivec_vsldoi_8hi");
- pragma Import (LL_Altivec, vsldoi_16qi, "__builtin_altivec_vsldoi_16qi");
- pragma Import (LL_Altivec, vsldoi_4sf, "__builtin_altivec_vsldoi_4sf");
- pragma Import (LL_Altivec, vsl, "__builtin_altivec_vsl");
- pragma Import (LL_Altivec, vslb, "__builtin_altivec_vslb");
- pragma Import (LL_Altivec, vslh, "__builtin_altivec_vslh");
- pragma Import (LL_Altivec, vslo, "__builtin_altivec_vslo");
- pragma Import (LL_Altivec, vslw, "__builtin_altivec_vslw");
- pragma Import (LL_Altivec, vspltb, "__builtin_altivec_vspltb");
- pragma Import (LL_Altivec, vsplth, "__builtin_altivec_vsplth");
- pragma Import (LL_Altivec, vspltisb, "__builtin_altivec_vspltisb");
- pragma Import (LL_Altivec, vspltish, "__builtin_altivec_vspltish");
- pragma Import (LL_Altivec, vspltisw, "__builtin_altivec_vspltisw");
- pragma Import (LL_Altivec, vspltw, "__builtin_altivec_vspltw");
- pragma Import (LL_Altivec, vsr, "__builtin_altivec_vsr");
- pragma Import (LL_Altivec, vsrab, "__builtin_altivec_vsrab");
- pragma Import (LL_Altivec, vsrah, "__builtin_altivec_vsrah");
- pragma Import (LL_Altivec, vsraw, "__builtin_altivec_vsraw");
- pragma Import (LL_Altivec, vsrb, "__builtin_altivec_vsrb");
- pragma Import (LL_Altivec, vsrh, "__builtin_altivec_vsrh");
- pragma Import (LL_Altivec, vsro, "__builtin_altivec_vsro");
- pragma Import (LL_Altivec, vsrw, "__builtin_altivec_vsrw");
- pragma Import (LL_Altivec, vsubcuw, "__builtin_altivec_vsubcuw");
- pragma Import (LL_Altivec, vsubfp, "__builtin_altivec_vsubfp");
- pragma Import (LL_Altivec, vsubsbs, "__builtin_altivec_vsubsbs");
- pragma Import (LL_Altivec, vsubshs, "__builtin_altivec_vsubshs");
- pragma Import (LL_Altivec, vsubsws, "__builtin_altivec_vsubsws");
- pragma Import (LL_Altivec, vsububm, "__builtin_altivec_vsububm");
- pragma Import (LL_Altivec, vsububs, "__builtin_altivec_vsububs");
- pragma Import (LL_Altivec, vsubuhm, "__builtin_altivec_vsubuhm");
- pragma Import (LL_Altivec, vsubuhs, "__builtin_altivec_vsubuhs");
- pragma Import (LL_Altivec, vsubuwm, "__builtin_altivec_vsubuwm");
- pragma Import (LL_Altivec, vsubuws, "__builtin_altivec_vsubuws");
- pragma Import (LL_Altivec, vsum2sws, "__builtin_altivec_vsum2sws");
- pragma Import (LL_Altivec, vsum4sbs, "__builtin_altivec_vsum4sbs");
- pragma Import (LL_Altivec, vsum4shs, "__builtin_altivec_vsum4shs");
- pragma Import (LL_Altivec, vsum4ubs, "__builtin_altivec_vsum4ubs");
- pragma Import (LL_Altivec, vsumsws, "__builtin_altivec_vsumsws");
- pragma Import (LL_Altivec, vupkhpx, "__builtin_altivec_vupkhpx");
- pragma Import (LL_Altivec, vupkhsb, "__builtin_altivec_vupkhsb");
- pragma Import (LL_Altivec, vupkhsh, "__builtin_altivec_vupkhsh");
- pragma Import (LL_Altivec, vupklpx, "__builtin_altivec_vupklpx");
- pragma Import (LL_Altivec, vupklsb, "__builtin_altivec_vupklsb");
- pragma Import (LL_Altivec, vupklsh, "__builtin_altivec_vupklsh");
- pragma Import (LL_Altivec, vcmpbfp_p, "__builtin_altivec_vcmpbfp_p");
- pragma Import (LL_Altivec, vcmpeqfp_p, "__builtin_altivec_vcmpeqfp_p");
- pragma Import (LL_Altivec, vcmpgefp_p, "__builtin_altivec_vcmpgefp_p");
- pragma Import (LL_Altivec, vcmpgtfp_p, "__builtin_altivec_vcmpgtfp_p");
- pragma Import (LL_Altivec, vcmpequw_p, "__builtin_altivec_vcmpequw_p");
- pragma Import (LL_Altivec, vcmpgtsw_p, "__builtin_altivec_vcmpgtsw_p");
- pragma Import (LL_Altivec, vcmpgtuw_p, "__builtin_altivec_vcmpgtuw_p");
- pragma Import (LL_Altivec, vcmpgtuh_p, "__builtin_altivec_vcmpgtuh_p");
- pragma Import (LL_Altivec, vcmpgtsh_p, "__builtin_altivec_vcmpgtsh_p");
- pragma Import (LL_Altivec, vcmpequh_p, "__builtin_altivec_vcmpequh_p");
- pragma Import (LL_Altivec, vcmpequb_p, "__builtin_altivec_vcmpequb_p");
- pragma Import (LL_Altivec, vcmpgtsb_p, "__builtin_altivec_vcmpgtsb_p");
- pragma Import (LL_Altivec, vcmpgtub_p, "__builtin_altivec_vcmpgtub_p");
-
-end GNAT.Altivec.Low_Level_Vectors;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S --
+-- --
+-- B o d y --
+-- (Hard Binding Version) --
+-- --
+-- Copyright (C) 2004-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body GNAT.Altivec.Low_Level_Vectors is
+
+end GNAT.Altivec.Low_Level_Vectors;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S --
+-- --
+-- S p e c --
+-- (Hard Binding Version) --
+-- --
+-- Copyright (C) 2004-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This unit exposes the low level vector support for the Hard binding,
+-- intended for AltiVec capable targets. See Altivec.Design for a description
+-- of what is expected to be exposed.
+
+package GNAT.Altivec.Low_Level_Vectors is
+ pragma Elaborate_Body;
+
+ ----------------------------------------
+ -- Low-level Vector Type Declarations --
+ ----------------------------------------
+
+ type LL_VUC is private;
+ type LL_VSC is private;
+ type LL_VBC is private;
+
+ type LL_VUS is private;
+ type LL_VSS is private;
+ type LL_VBS is private;
+
+ type LL_VUI is private;
+ type LL_VSI is private;
+ type LL_VBI is private;
+
+ type LL_VF is private;
+ type LL_VP is private;
+
+ ------------------------------------
+ -- Low-level Functional Interface --
+ ------------------------------------
+
+ function abs_v16qi (A : LL_VSC) return LL_VSC;
+ function abs_v8hi (A : LL_VSS) return LL_VSS;
+ function abs_v4si (A : LL_VSI) return LL_VSI;
+ function abs_v4sf (A : LL_VF) return LL_VF;
+
+ function abss_v16qi (A : LL_VSC) return LL_VSC;
+ function abss_v8hi (A : LL_VSS) return LL_VSS;
+ function abss_v4si (A : LL_VSI) return LL_VSI;
+
+ function vaddubm (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vadduhm (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vadduwm (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vaddfp (A : LL_VF; B : LL_VF) return LL_VF;
+
+ function vaddcuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vaddubs (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vaddsbs (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vadduhs (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vaddshs (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vadduws (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vaddsws (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vand (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vandc (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vavgub (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vavgsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vavguh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vavgsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vavguw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vavgsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vcmpbfp (A : LL_VF; B : LL_VF) return LL_VSI;
+
+ function vcmpequb (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vcmpequh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vcmpequw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vcmpeqfp (A : LL_VF; B : LL_VF) return LL_VF;
+
+ function vcmpgefp (A : LL_VF; B : LL_VF) return LL_VF;
+
+ function vcmpgtub (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vcmpgtsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vcmpgtuh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vcmpgtsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vcmpgtuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vcmpgtsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vcmpgtfp (A : LL_VF; B : LL_VF) return LL_VF;
+
+ function vcfux (A : LL_VUI; B : c_int) return LL_VF;
+ function vcfsx (A : LL_VSI; B : c_int) return LL_VF;
+
+ function vctsxs (A : LL_VF; B : c_int) return LL_VSI;
+ function vctuxs (A : LL_VF; B : c_int) return LL_VUI;
+
+ procedure dss (A : c_int);
+ procedure dssall;
+
+ procedure dst (A : c_ptr; B : c_int; C : c_int);
+ procedure dstst (A : c_ptr; B : c_int; C : c_int);
+ procedure dststt (A : c_ptr; B : c_int; C : c_int);
+ procedure dstt (A : c_ptr; B : c_int; C : c_int);
+
+ function vexptefp (A : LL_VF) return LL_VF;
+
+ function vrfim (A : LL_VF) return LL_VF;
+
+ function lvx (A : c_long; B : c_ptr) return LL_VSI;
+ function lvebx (A : c_long; B : c_ptr) return LL_VSC;
+ function lvehx (A : c_long; B : c_ptr) return LL_VSS;
+ function lvewx (A : c_long; B : c_ptr) return LL_VSI;
+ function lvxl (A : c_long; B : c_ptr) return LL_VSI;
+
+ function vlogefp (A : LL_VF) return LL_VF;
+
+ function lvsl (A : c_long; B : c_ptr) return LL_VSC;
+ function lvsr (A : c_long; B : c_ptr) return LL_VSC;
+
+ function vmaddfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF;
+
+ function vmhaddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS;
+
+ function vmaxub (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vmaxsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vmaxuh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vmaxsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vmaxuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vmaxsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vmaxfp (A : LL_VF; B : LL_VF) return LL_VF;
+
+ function vmrghb (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vmrghh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vmrghw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vmrglb (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vmrglh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vmrglw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function mfvscr return LL_VSS;
+
+ function vminfp (A : LL_VF; B : LL_VF) return LL_VF;
+ function vminsb (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vminsh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vminsw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vminub (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vminuh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vminuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vmladduhm (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS;
+
+ function vmhraddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS;
+
+ function vmsumubm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI;
+ function vmsummbm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI;
+ function vmsumuhm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
+ function vmsumshm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
+ function vmsumuhs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
+ function vmsumshs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI;
+
+ procedure mtvscr (A : LL_VSI);
+
+ function vmuleub (A : LL_VSC; B : LL_VSC) return LL_VSS;
+ function vmuleuh (A : LL_VSS; B : LL_VSS) return LL_VSI;
+ function vmulesb (A : LL_VSC; B : LL_VSC) return LL_VSS;
+ function vmulesh (A : LL_VSS; B : LL_VSS) return LL_VSI;
+
+ function vmulosb (A : LL_VSC; B : LL_VSC) return LL_VSS;
+ function vmulosh (A : LL_VSS; B : LL_VSS) return LL_VSI;
+ function vmuloub (A : LL_VSC; B : LL_VSC) return LL_VSS;
+ function vmulouh (A : LL_VSS; B : LL_VSS) return LL_VSI;
+
+ function vnmsubfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF;
+
+ function vxor (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vnor (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vor (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vpkuhum (A : LL_VSS; B : LL_VSS) return LL_VSC;
+ function vpkuwum (A : LL_VSI; B : LL_VSI) return LL_VSS;
+ function vpkpx (A : LL_VSI; B : LL_VSI) return LL_VSS;
+ function vpkuhus (A : LL_VSS; B : LL_VSS) return LL_VSC;
+ function vpkuwus (A : LL_VSI; B : LL_VSI) return LL_VSS;
+ function vpkshss (A : LL_VSS; B : LL_VSS) return LL_VSC;
+ function vpkswss (A : LL_VSI; B : LL_VSI) return LL_VSS;
+ function vpkshus (A : LL_VSS; B : LL_VSS) return LL_VSC;
+ function vpkswus (A : LL_VSI; B : LL_VSI) return LL_VSS;
+
+ function vperm_4si (A : LL_VSI; B : LL_VSI; C : LL_VSC) return LL_VSI;
+
+ function vrefp (A : LL_VF) return LL_VF;
+
+ function vrlb (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vrlh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vrlw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vrfin (A : LL_VF) return LL_VF;
+ function vrfip (A : LL_VF) return LL_VF;
+ function vrfiz (A : LL_VF) return LL_VF;
+
+ function vrsqrtefp (A : LL_VF) return LL_VF;
+
+ function vsel_4si (A : LL_VSI; B : LL_VSI; C : LL_VSI) return LL_VSI;
+
+ function vslb (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vslh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vslw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vsldoi_4si (A : LL_VSI; B : LL_VSI; C : c_int) return LL_VSI;
+ function vsldoi_8hi (A : LL_VSS; B : LL_VSS; C : c_int) return LL_VSS;
+ function vsldoi_16qi (A : LL_VSC; B : LL_VSC; C : c_int) return LL_VSC;
+ function vsldoi_4sf (A : LL_VF; B : LL_VF; C : c_int) return LL_VF;
+
+ function vsl (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vslo (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vspltb (A : LL_VSC; B : c_int) return LL_VSC;
+ function vsplth (A : LL_VSS; B : c_int) return LL_VSS;
+ function vspltw (A : LL_VSI; B : c_int) return LL_VSI;
+
+ function vspltisb (A : c_int) return LL_VSC;
+ function vspltish (A : c_int) return LL_VSS;
+ function vspltisw (A : c_int) return LL_VSI;
+
+ function vsrb (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vsrh (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vsrw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vsrab (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vsrah (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vsraw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vsr (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vsro (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ procedure stvx (A : LL_VSI; B : c_int; C : c_ptr);
+ procedure stvebx (A : LL_VSC; B : c_int; C : c_ptr);
+ procedure stvehx (A : LL_VSS; B : c_int; C : c_ptr);
+ procedure stvewx (A : LL_VSI; B : c_int; C : c_ptr);
+ procedure stvxl (A : LL_VSI; B : c_int; C : c_ptr);
+
+ function vsububm (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vsubuhm (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vsubuwm (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vsubfp (A : LL_VF; B : LL_VF) return LL_VF;
+
+ function vsubcuw (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vsububs (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vsubsbs (A : LL_VSC; B : LL_VSC) return LL_VSC;
+ function vsubuhs (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vsubshs (A : LL_VSS; B : LL_VSS) return LL_VSS;
+ function vsubuws (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vsubsws (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vsum4ubs (A : LL_VSC; B : LL_VSI) return LL_VSI;
+ function vsum4sbs (A : LL_VSC; B : LL_VSI) return LL_VSI;
+ function vsum4shs (A : LL_VSS; B : LL_VSI) return LL_VSI;
+
+ function vsum2sws (A : LL_VSI; B : LL_VSI) return LL_VSI;
+ function vsumsws (A : LL_VSI; B : LL_VSI) return LL_VSI;
+
+ function vupkhsb (A : LL_VSC) return LL_VSS;
+ function vupkhsh (A : LL_VSS) return LL_VSI;
+ function vupkhpx (A : LL_VSS) return LL_VSI;
+
+ function vupklsb (A : LL_VSC) return LL_VSS;
+ function vupklsh (A : LL_VSS) return LL_VSI;
+ function vupklpx (A : LL_VSS) return LL_VSI;
+
+ function vcmpequb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int;
+ function vcmpequh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int;
+ function vcmpequw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int;
+ function vcmpeqfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
+
+ function vcmpgtub_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int;
+ function vcmpgtuh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int;
+ function vcmpgtuw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int;
+ function vcmpgtsb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int;
+ function vcmpgtsh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int;
+ function vcmpgtsw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int;
+ function vcmpgtfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
+
+ function vcmpgefp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
+ function vcmpbfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int;
+
+private
+
+ ---------------------------------------
+ -- Low-level Vector Type Definitions --
+ ---------------------------------------
+
+ -- [PIM-2.3.3 Alignment of aggregate and unions containing vector types]:
+
+ -- "Aggregates (structures and arrays) and unions containing vector
+ -- types must be aligned on 16-byte boundaries and their internal
+ -- organization padded, if necessary, so that each internal vector
+ -- type is aligned on a 16-byte boundary. This is an extension to
+ -- all ABIs (AIX, Apple, SVR4, and EABI).
+
+ --------------------------
+ -- char Core Components --
+ --------------------------
+
+ type LL_VUC is array (1 .. 16) of unsigned_char;
+ for LL_VUC'Alignment use VECTOR_ALIGNMENT;
+ pragma Machine_Attribute (LL_VUC, "vector_type");
+ pragma Suppress (All_Checks, LL_VUC);
+
+ type LL_VSC is array (1 .. 16) of signed_char;
+ for LL_VSC'Alignment use VECTOR_ALIGNMENT;
+ pragma Machine_Attribute (LL_VSC, "vector_type");
+ pragma Suppress (All_Checks, LL_VSC);
+
+ type LL_VBC is array (1 .. 16) of unsigned_char;
+ for LL_VBC'Alignment use VECTOR_ALIGNMENT;
+ pragma Machine_Attribute (LL_VBC, "vector_type");
+ pragma Suppress (All_Checks, LL_VBC);
+
+ ---------------------------
+ -- short Core Components --
+ ---------------------------
+
+ type LL_VUS is array (1 .. 8) of unsigned_short;
+ for LL_VUS'Alignment use VECTOR_ALIGNMENT;
+ pragma Machine_Attribute (LL_VUS, "vector_type");
+ pragma Suppress (All_Checks, LL_VUS);
+
+ type LL_VSS is array (1 .. 8) of signed_short;
+ for LL_VSS'Alignment use VECTOR_ALIGNMENT;
+ pragma Machine_Attribute (LL_VSS, "vector_type");
+ pragma Suppress (All_Checks, LL_VSS);
+
+ type LL_VBS is array (1 .. 8) of unsigned_short;
+ for LL_VBS'Alignment use VECTOR_ALIGNMENT;
+ pragma Machine_Attribute (LL_VBS, "vector_type");
+ pragma Suppress (All_Checks, LL_VBS);
+
+ -------------------------
+ -- int Core Components --
+ -------------------------
+
+ type LL_VUI is array (1 .. 4) of unsigned_int;
+ for LL_VUI'Alignment use VECTOR_ALIGNMENT;
+ pragma Machine_Attribute (LL_VUI, "vector_type");
+ pragma Suppress (All_Checks, LL_VUI);
+
+ type LL_VSI is array (1 .. 4) of signed_int;
+ for LL_VSI'Alignment use VECTOR_ALIGNMENT;
+ pragma Machine_Attribute (LL_VSI, "vector_type");
+ pragma Suppress (All_Checks, LL_VSI);
+
+ type LL_VBI is array (1 .. 4) of unsigned_int;
+ for LL_VBI'Alignment use VECTOR_ALIGNMENT;
+ pragma Machine_Attribute (LL_VBI, "vector_type");
+ pragma Suppress (All_Checks, LL_VBI);
+
+ ---------------------------
+ -- Float Core Components --
+ ---------------------------
+
+ type LL_VF is array (1 .. 4) of Float;
+ for LL_VF'Alignment use VECTOR_ALIGNMENT;
+ pragma Machine_Attribute (LL_VF, "vector_type");
+ pragma Suppress (All_Checks, LL_VF);
+
+ ---------------------------
+ -- pixel Core Components --
+ ---------------------------
+
+ type LL_VP is array (1 .. 8) of pixel;
+ for LL_VP'Alignment use VECTOR_ALIGNMENT;
+ pragma Machine_Attribute (LL_VP, "vector_type");
+ pragma Suppress (All_Checks, LL_VP);
+
+ ------------------------------------
+ -- Low-level Functional Interface --
+ ------------------------------------
+
+ -- The functions we have to expose here are exactly those for which
+ -- GCC builtins are available. Calls to these functions will be turned
+ -- into real AltiVec instructions by the GCC back-end.
+
+ pragma Convention_Identifier (LL_Altivec, Intrinsic);
+
+ pragma Import (LL_Altivec, dss, "__builtin_altivec_dss");
+ pragma Import (LL_Altivec, dssall, "__builtin_altivec_dssall");
+ pragma Import (LL_Altivec, dst, "__builtin_altivec_dst");
+ pragma Import (LL_Altivec, dstst, "__builtin_altivec_dstst");
+ pragma Import (LL_Altivec, dststt, "__builtin_altivec_dststt");
+ pragma Import (LL_Altivec, dstt, "__builtin_altivec_dstt");
+ pragma Import (LL_Altivec, mtvscr, "__builtin_altivec_mtvscr");
+ pragma Import (LL_Altivec, mfvscr, "__builtin_altivec_mfvscr");
+ pragma Import (LL_Altivec, stvebx, "__builtin_altivec_stvebx");
+ pragma Import (LL_Altivec, stvehx, "__builtin_altivec_stvehx");
+ pragma Import (LL_Altivec, stvewx, "__builtin_altivec_stvewx");
+ pragma Import (LL_Altivec, stvx, "__builtin_altivec_stvx");
+ pragma Import (LL_Altivec, stvxl, "__builtin_altivec_stvxl");
+ pragma Import (LL_Altivec, lvebx, "__builtin_altivec_lvebx");
+ pragma Import (LL_Altivec, lvehx, "__builtin_altivec_lvehx");
+ pragma Import (LL_Altivec, lvewx, "__builtin_altivec_lvewx");
+ pragma Import (LL_Altivec, lvx, "__builtin_altivec_lvx");
+ pragma Import (LL_Altivec, lvxl, "__builtin_altivec_lvxl");
+ pragma Import (LL_Altivec, lvsl, "__builtin_altivec_lvsl");
+ pragma Import (LL_Altivec, lvsr, "__builtin_altivec_lvsr");
+ pragma Import (LL_Altivec, abs_v16qi, "__builtin_altivec_abs_v16qi");
+ pragma Import (LL_Altivec, abs_v8hi, "__builtin_altivec_abs_v8hi");
+ pragma Import (LL_Altivec, abs_v4si, "__builtin_altivec_abs_v4si");
+ pragma Import (LL_Altivec, abs_v4sf, "__builtin_altivec_abs_v4sf");
+ pragma Import (LL_Altivec, abss_v16qi, "__builtin_altivec_abss_v16qi");
+ pragma Import (LL_Altivec, abss_v8hi, "__builtin_altivec_abss_v8hi");
+ pragma Import (LL_Altivec, abss_v4si, "__builtin_altivec_abss_v4si");
+ pragma Import (LL_Altivec, vaddcuw, "__builtin_altivec_vaddcuw");
+ pragma Import (LL_Altivec, vaddfp, "__builtin_altivec_vaddfp");
+ pragma Import (LL_Altivec, vaddsbs, "__builtin_altivec_vaddsbs");
+ pragma Import (LL_Altivec, vaddshs, "__builtin_altivec_vaddshs");
+ pragma Import (LL_Altivec, vaddsws, "__builtin_altivec_vaddsws");
+ pragma Import (LL_Altivec, vaddubm, "__builtin_altivec_vaddubm");
+ pragma Import (LL_Altivec, vaddubs, "__builtin_altivec_vaddubs");
+ pragma Import (LL_Altivec, vadduhm, "__builtin_altivec_vadduhm");
+ pragma Import (LL_Altivec, vadduhs, "__builtin_altivec_vadduhs");
+ pragma Import (LL_Altivec, vadduwm, "__builtin_altivec_vadduwm");
+ pragma Import (LL_Altivec, vadduws, "__builtin_altivec_vadduws");
+ pragma Import (LL_Altivec, vand, "__builtin_altivec_vand");
+ pragma Import (LL_Altivec, vandc, "__builtin_altivec_vandc");
+ pragma Import (LL_Altivec, vavgsb, "__builtin_altivec_vavgsb");
+ pragma Import (LL_Altivec, vavgsh, "__builtin_altivec_vavgsh");
+ pragma Import (LL_Altivec, vavgsw, "__builtin_altivec_vavgsw");
+ pragma Import (LL_Altivec, vavgub, "__builtin_altivec_vavgub");
+ pragma Import (LL_Altivec, vavguh, "__builtin_altivec_vavguh");
+ pragma Import (LL_Altivec, vavguw, "__builtin_altivec_vavguw");
+ pragma Import (LL_Altivec, vcfsx, "__builtin_altivec_vcfsx");
+ pragma Import (LL_Altivec, vcfux, "__builtin_altivec_vcfux");
+ pragma Import (LL_Altivec, vcmpbfp, "__builtin_altivec_vcmpbfp");
+ pragma Import (LL_Altivec, vcmpeqfp, "__builtin_altivec_vcmpeqfp");
+ pragma Import (LL_Altivec, vcmpequb, "__builtin_altivec_vcmpequb");
+ pragma Import (LL_Altivec, vcmpequh, "__builtin_altivec_vcmpequh");
+ pragma Import (LL_Altivec, vcmpequw, "__builtin_altivec_vcmpequw");
+ pragma Import (LL_Altivec, vcmpgefp, "__builtin_altivec_vcmpgefp");
+ pragma Import (LL_Altivec, vcmpgtfp, "__builtin_altivec_vcmpgtfp");
+ pragma Import (LL_Altivec, vcmpgtsb, "__builtin_altivec_vcmpgtsb");
+ pragma Import (LL_Altivec, vcmpgtsh, "__builtin_altivec_vcmpgtsh");
+ pragma Import (LL_Altivec, vcmpgtsw, "__builtin_altivec_vcmpgtsw");
+ pragma Import (LL_Altivec, vcmpgtub, "__builtin_altivec_vcmpgtub");
+ pragma Import (LL_Altivec, vcmpgtuh, "__builtin_altivec_vcmpgtuh");
+ pragma Import (LL_Altivec, vcmpgtuw, "__builtin_altivec_vcmpgtuw");
+ pragma Import (LL_Altivec, vctsxs, "__builtin_altivec_vctsxs");
+ pragma Import (LL_Altivec, vctuxs, "__builtin_altivec_vctuxs");
+ pragma Import (LL_Altivec, vexptefp, "__builtin_altivec_vexptefp");
+ pragma Import (LL_Altivec, vlogefp, "__builtin_altivec_vlogefp");
+ pragma Import (LL_Altivec, vmaddfp, "__builtin_altivec_vmaddfp");
+ pragma Import (LL_Altivec, vmaxfp, "__builtin_altivec_vmaxfp");
+ pragma Import (LL_Altivec, vmaxsb, "__builtin_altivec_vmaxsb");
+ pragma Import (LL_Altivec, vmaxsh, "__builtin_altivec_vmaxsh");
+ pragma Import (LL_Altivec, vmaxsw, "__builtin_altivec_vmaxsw");
+ pragma Import (LL_Altivec, vmaxub, "__builtin_altivec_vmaxub");
+ pragma Import (LL_Altivec, vmaxuh, "__builtin_altivec_vmaxuh");
+ pragma Import (LL_Altivec, vmaxuw, "__builtin_altivec_vmaxuw");
+ pragma Import (LL_Altivec, vmhaddshs, "__builtin_altivec_vmhaddshs");
+ pragma Import (LL_Altivec, vmhraddshs, "__builtin_altivec_vmhraddshs");
+ pragma Import (LL_Altivec, vminfp, "__builtin_altivec_vminfp");
+ pragma Import (LL_Altivec, vminsb, "__builtin_altivec_vminsb");
+ pragma Import (LL_Altivec, vminsh, "__builtin_altivec_vminsh");
+ pragma Import (LL_Altivec, vminsw, "__builtin_altivec_vminsw");
+ pragma Import (LL_Altivec, vminub, "__builtin_altivec_vminub");
+ pragma Import (LL_Altivec, vminuh, "__builtin_altivec_vminuh");
+ pragma Import (LL_Altivec, vminuw, "__builtin_altivec_vminuw");
+ pragma Import (LL_Altivec, vmladduhm, "__builtin_altivec_vmladduhm");
+ pragma Import (LL_Altivec, vmrghb, "__builtin_altivec_vmrghb");
+ pragma Import (LL_Altivec, vmrghh, "__builtin_altivec_vmrghh");
+ pragma Import (LL_Altivec, vmrghw, "__builtin_altivec_vmrghw");
+ pragma Import (LL_Altivec, vmrglb, "__builtin_altivec_vmrglb");
+ pragma Import (LL_Altivec, vmrglh, "__builtin_altivec_vmrglh");
+ pragma Import (LL_Altivec, vmrglw, "__builtin_altivec_vmrglw");
+ pragma Import (LL_Altivec, vmsummbm, "__builtin_altivec_vmsummbm");
+ pragma Import (LL_Altivec, vmsumshm, "__builtin_altivec_vmsumshm");
+ pragma Import (LL_Altivec, vmsumshs, "__builtin_altivec_vmsumshs");
+ pragma Import (LL_Altivec, vmsumubm, "__builtin_altivec_vmsumubm");
+ pragma Import (LL_Altivec, vmsumuhm, "__builtin_altivec_vmsumuhm");
+ pragma Import (LL_Altivec, vmsumuhs, "__builtin_altivec_vmsumuhs");
+ pragma Import (LL_Altivec, vmulesb, "__builtin_altivec_vmulesb");
+ pragma Import (LL_Altivec, vmulesh, "__builtin_altivec_vmulesh");
+ pragma Import (LL_Altivec, vmuleub, "__builtin_altivec_vmuleub");
+ pragma Import (LL_Altivec, vmuleuh, "__builtin_altivec_vmuleuh");
+ pragma Import (LL_Altivec, vmulosb, "__builtin_altivec_vmulosb");
+ pragma Import (LL_Altivec, vmulosh, "__builtin_altivec_vmulosh");
+ pragma Import (LL_Altivec, vmuloub, "__builtin_altivec_vmuloub");
+ pragma Import (LL_Altivec, vmulouh, "__builtin_altivec_vmulouh");
+ pragma Import (LL_Altivec, vnmsubfp, "__builtin_altivec_vnmsubfp");
+ pragma Import (LL_Altivec, vnor, "__builtin_altivec_vnor");
+ pragma Import (LL_Altivec, vxor, "__builtin_altivec_vxor");
+ pragma Import (LL_Altivec, vor, "__builtin_altivec_vor");
+ pragma Import (LL_Altivec, vperm_4si, "__builtin_altivec_vperm_4si");
+ pragma Import (LL_Altivec, vpkpx, "__builtin_altivec_vpkpx");
+ pragma Import (LL_Altivec, vpkshss, "__builtin_altivec_vpkshss");
+ pragma Import (LL_Altivec, vpkshus, "__builtin_altivec_vpkshus");
+ pragma Import (LL_Altivec, vpkswss, "__builtin_altivec_vpkswss");
+ pragma Import (LL_Altivec, vpkswus, "__builtin_altivec_vpkswus");
+ pragma Import (LL_Altivec, vpkuhum, "__builtin_altivec_vpkuhum");
+ pragma Import (LL_Altivec, vpkuhus, "__builtin_altivec_vpkuhus");
+ pragma Import (LL_Altivec, vpkuwum, "__builtin_altivec_vpkuwum");
+ pragma Import (LL_Altivec, vpkuwus, "__builtin_altivec_vpkuwus");
+ pragma Import (LL_Altivec, vrefp, "__builtin_altivec_vrefp");
+ pragma Import (LL_Altivec, vrfim, "__builtin_altivec_vrfim");
+ pragma Import (LL_Altivec, vrfin, "__builtin_altivec_vrfin");
+ pragma Import (LL_Altivec, vrfip, "__builtin_altivec_vrfip");
+ pragma Import (LL_Altivec, vrfiz, "__builtin_altivec_vrfiz");
+ pragma Import (LL_Altivec, vrlb, "__builtin_altivec_vrlb");
+ pragma Import (LL_Altivec, vrlh, "__builtin_altivec_vrlh");
+ pragma Import (LL_Altivec, vrlw, "__builtin_altivec_vrlw");
+ pragma Import (LL_Altivec, vrsqrtefp, "__builtin_altivec_vrsqrtefp");
+ pragma Import (LL_Altivec, vsel_4si, "__builtin_altivec_vsel_4si");
+ pragma Import (LL_Altivec, vsldoi_4si, "__builtin_altivec_vsldoi_4si");
+ pragma Import (LL_Altivec, vsldoi_8hi, "__builtin_altivec_vsldoi_8hi");
+ pragma Import (LL_Altivec, vsldoi_16qi, "__builtin_altivec_vsldoi_16qi");
+ pragma Import (LL_Altivec, vsldoi_4sf, "__builtin_altivec_vsldoi_4sf");
+ pragma Import (LL_Altivec, vsl, "__builtin_altivec_vsl");
+ pragma Import (LL_Altivec, vslb, "__builtin_altivec_vslb");
+ pragma Import (LL_Altivec, vslh, "__builtin_altivec_vslh");
+ pragma Import (LL_Altivec, vslo, "__builtin_altivec_vslo");
+ pragma Import (LL_Altivec, vslw, "__builtin_altivec_vslw");
+ pragma Import (LL_Altivec, vspltb, "__builtin_altivec_vspltb");
+ pragma Import (LL_Altivec, vsplth, "__builtin_altivec_vsplth");
+ pragma Import (LL_Altivec, vspltisb, "__builtin_altivec_vspltisb");
+ pragma Import (LL_Altivec, vspltish, "__builtin_altivec_vspltish");
+ pragma Import (LL_Altivec, vspltisw, "__builtin_altivec_vspltisw");
+ pragma Import (LL_Altivec, vspltw, "__builtin_altivec_vspltw");
+ pragma Import (LL_Altivec, vsr, "__builtin_altivec_vsr");
+ pragma Import (LL_Altivec, vsrab, "__builtin_altivec_vsrab");
+ pragma Import (LL_Altivec, vsrah, "__builtin_altivec_vsrah");
+ pragma Import (LL_Altivec, vsraw, "__builtin_altivec_vsraw");
+ pragma Import (LL_Altivec, vsrb, "__builtin_altivec_vsrb");
+ pragma Import (LL_Altivec, vsrh, "__builtin_altivec_vsrh");
+ pragma Import (LL_Altivec, vsro, "__builtin_altivec_vsro");
+ pragma Import (LL_Altivec, vsrw, "__builtin_altivec_vsrw");
+ pragma Import (LL_Altivec, vsubcuw, "__builtin_altivec_vsubcuw");
+ pragma Import (LL_Altivec, vsubfp, "__builtin_altivec_vsubfp");
+ pragma Import (LL_Altivec, vsubsbs, "__builtin_altivec_vsubsbs");
+ pragma Import (LL_Altivec, vsubshs, "__builtin_altivec_vsubshs");
+ pragma Import (LL_Altivec, vsubsws, "__builtin_altivec_vsubsws");
+ pragma Import (LL_Altivec, vsububm, "__builtin_altivec_vsububm");
+ pragma Import (LL_Altivec, vsububs, "__builtin_altivec_vsububs");
+ pragma Import (LL_Altivec, vsubuhm, "__builtin_altivec_vsubuhm");
+ pragma Import (LL_Altivec, vsubuhs, "__builtin_altivec_vsubuhs");
+ pragma Import (LL_Altivec, vsubuwm, "__builtin_altivec_vsubuwm");
+ pragma Import (LL_Altivec, vsubuws, "__builtin_altivec_vsubuws");
+ pragma Import (LL_Altivec, vsum2sws, "__builtin_altivec_vsum2sws");
+ pragma Import (LL_Altivec, vsum4sbs, "__builtin_altivec_vsum4sbs");
+ pragma Import (LL_Altivec, vsum4shs, "__builtin_altivec_vsum4shs");
+ pragma Import (LL_Altivec, vsum4ubs, "__builtin_altivec_vsum4ubs");
+ pragma Import (LL_Altivec, vsumsws, "__builtin_altivec_vsumsws");
+ pragma Import (LL_Altivec, vupkhpx, "__builtin_altivec_vupkhpx");
+ pragma Import (LL_Altivec, vupkhsb, "__builtin_altivec_vupkhsb");
+ pragma Import (LL_Altivec, vupkhsh, "__builtin_altivec_vupkhsh");
+ pragma Import (LL_Altivec, vupklpx, "__builtin_altivec_vupklpx");
+ pragma Import (LL_Altivec, vupklsb, "__builtin_altivec_vupklsb");
+ pragma Import (LL_Altivec, vupklsh, "__builtin_altivec_vupklsh");
+ pragma Import (LL_Altivec, vcmpbfp_p, "__builtin_altivec_vcmpbfp_p");
+ pragma Import (LL_Altivec, vcmpeqfp_p, "__builtin_altivec_vcmpeqfp_p");
+ pragma Import (LL_Altivec, vcmpgefp_p, "__builtin_altivec_vcmpgefp_p");
+ pragma Import (LL_Altivec, vcmpgtfp_p, "__builtin_altivec_vcmpgtfp_p");
+ pragma Import (LL_Altivec, vcmpequw_p, "__builtin_altivec_vcmpequw_p");
+ pragma Import (LL_Altivec, vcmpgtsw_p, "__builtin_altivec_vcmpgtsw_p");
+ pragma Import (LL_Altivec, vcmpgtuw_p, "__builtin_altivec_vcmpgtuw_p");
+ pragma Import (LL_Altivec, vcmpgtuh_p, "__builtin_altivec_vcmpgtuh_p");
+ pragma Import (LL_Altivec, vcmpgtsh_p, "__builtin_altivec_vcmpgtsh_p");
+ pragma Import (LL_Altivec, vcmpequh_p, "__builtin_altivec_vcmpequh_p");
+ pragma Import (LL_Altivec, vcmpequb_p, "__builtin_altivec_vcmpequb_p");
+ pragma Import (LL_Altivec, vcmpgtsb_p, "__builtin_altivec_vcmpgtsb_p");
+ pragma Import (LL_Altivec, vcmpgtub_p, "__builtin_altivec_vcmpgtub_p");
+
+end GNAT.Altivec.Low_Level_Vectors;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- G N A T . I O --
--- --
--- B o d y --
--- --
--- Copyright (C) 1995-2017, AdaCore --
--- --
--- 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. --
--- --
-------------------------------------------------------------------------------
-
--- vxworks zfp version of Put (C : Character)
-
-with Interfaces.C; use Interfaces.C;
-
-separate (GNAT.IO)
-procedure Put (C : Character) is
-
- function ioGlobalStdGet
- (File : int) return int;
- pragma Import (C, ioGlobalStdGet, "ioGlobalStdGet");
-
- procedure fdprintf
- (File : int;
- Format : String;
- Value : Character);
- pragma Import (C, fdprintf, "fdprintf");
-
- Stdout_ID : constant int := 1;
-
-begin
- fdprintf (ioGlobalStdGet (Stdout_ID), "%c" & ASCII.NUL, C);
-end Put;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- G N A T . I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1995-2017, AdaCore --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- vxworks zfp version of Put (C : Character)
+
+with Interfaces.C; use Interfaces.C;
+
+separate (GNAT.IO)
+procedure Put (C : Character) is
+
+ function ioGlobalStdGet
+ (File : int) return int;
+ pragma Import (C, ioGlobalStdGet, "ioGlobalStdGet");
+
+ procedure fdprintf
+ (File : int;
+ Format : String;
+ Value : Character);
+ pragma Import (C, fdprintf, "fdprintf");
+
+ Stdout_ID : constant int := 1;
+
+begin
+ fdprintf (ioGlobalStdGet (Stdout_ID), "%c" & ASCII.NUL, C);
+end Put;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S E R I A L _ C O M M U N I C A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the GNU/Linux implementation of this package
-
-with Ada.Streams; use Ada.Streams;
-with Ada; use Ada;
-with Ada.Unchecked_Deallocation;
-
-with System; use System;
-with System.Communication; use System.Communication;
-with System.CRTL; use System.CRTL;
-with System.OS_Constants;
-
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-
-package body GNAT.Serial_Communications is
-
- package OSC renames System.OS_Constants;
-
- use type Interfaces.C.unsigned;
-
- type Port_Data is new int;
-
- subtype unsigned is Interfaces.C.unsigned;
- subtype char is Interfaces.C.char;
- subtype unsigned_char is Interfaces.C.unsigned_char;
-
- function fcntl (fd : int; cmd : int; value : int) return int;
- pragma Import (C, fcntl, "fcntl");
-
- C_Data_Rate : constant array (Data_Rate) of unsigned :=
- (B75 => OSC.B75,
- B110 => OSC.B110,
- B150 => OSC.B150,
- B300 => OSC.B300,
- B600 => OSC.B600,
- B1200 => OSC.B1200,
- B2400 => OSC.B2400,
- B4800 => OSC.B4800,
- B9600 => OSC.B9600,
- B19200 => OSC.B19200,
- B38400 => OSC.B38400,
- B57600 => OSC.B57600,
- B115200 => OSC.B115200);
-
- C_Bits : constant array (Data_Bits) of unsigned :=
- (CS7 => OSC.CS7, CS8 => OSC.CS8);
-
- C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned :=
- (One => 0, Two => OSC.CSTOPB);
-
- C_Parity : constant array (Parity_Check) of unsigned :=
- (None => 0,
- Odd => OSC.PARENB or OSC.PARODD,
- Even => OSC.PARENB);
-
- procedure Raise_Error (Message : String; Error : Integer := Errno);
- pragma No_Return (Raise_Error);
-
- ----------
- -- Name --
- ----------
-
- function Name (Number : Positive) return Port_Name is
- N : constant Natural := Number - 1;
- N_Img : constant String := Natural'Image (N);
- begin
- return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last));
- end Name;
-
- ----------
- -- Open --
- ----------
-
- procedure Open
- (Port : out Serial_Port;
- Name : Port_Name)
- is
- use OSC;
-
- C_Name : constant String := String (Name) & ASCII.NUL;
- Res : int;
-
- begin
- if Port.H = null then
- Port.H := new Port_Data;
- end if;
-
- Port.H.all := Port_Data (open
- (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY)));
-
- if Port.H.all = -1 then
- Raise_Error ("open: open failed");
- end if;
-
- -- By default we are in blocking mode
-
- Res := fcntl (int (Port.H.all), F_SETFL, 0);
-
- if Res = -1 then
- Raise_Error ("open: fcntl failed");
- end if;
- end Open;
-
- -----------------
- -- Raise_Error --
- -----------------
-
- procedure Raise_Error (Message : String; Error : Integer := Errno) is
- begin
- raise Serial_Error with Message
- & (if Error /= 0
- then " (" & Errno_Message (Err => Error) & ')'
- else "");
- end Raise_Error;
-
- ----------
- -- Read --
- ----------
-
- overriding procedure Read
- (Port : in out Serial_Port;
- Buffer : out Stream_Element_Array;
- Last : out Stream_Element_Offset)
- is
- Len : constant size_t := Buffer'Length;
- Res : ssize_t;
-
- begin
- if Port.H = null then
- Raise_Error ("read: port not opened", 0);
- end if;
-
- Res := read (Integer (Port.H.all), Buffer'Address, Len);
-
- if Res = -1 then
- Raise_Error ("read failed");
- end if;
-
- Last := Last_Index (Buffer'First, size_t (Res));
- end Read;
-
- ---------
- -- Set --
- ---------
-
- procedure Set
- (Port : Serial_Port;
- Rate : Data_Rate := B9600;
- Bits : Data_Bits := CS8;
- Stop_Bits : Stop_Bits_Number := One;
- Parity : Parity_Check := None;
- Block : Boolean := True;
- Local : Boolean := True;
- Flow : Flow_Control := None;
- Timeout : Duration := 10.0)
- is
- use OSC;
-
- type termios is record
- c_iflag : unsigned;
- c_oflag : unsigned;
- c_cflag : unsigned;
- c_lflag : unsigned;
- c_line : unsigned_char;
- c_cc : Interfaces.C.char_array (0 .. 31);
- c_ispeed : unsigned;
- c_ospeed : unsigned;
- end record;
- pragma Convention (C, termios);
-
- function tcgetattr (fd : int; termios_p : Address) return int;
- pragma Import (C, tcgetattr, "tcgetattr");
-
- function tcsetattr
- (fd : int; action : int; termios_p : Address) return int;
- pragma Import (C, tcsetattr, "tcsetattr");
-
- function tcflush (fd : int; queue_selector : int) return int;
- pragma Import (C, tcflush, "tcflush");
-
- Current : termios;
-
- Res : int;
- pragma Warnings (Off, Res);
- -- Warnings off, since we don't always test the result
-
- begin
- if Port.H = null then
- Raise_Error ("set: port not opened", 0);
- end if;
-
- -- Get current port settings
-
- Res := tcgetattr (int (Port.H.all), Current'Address);
-
- -- Change settings now
-
- Current.c_cflag := C_Data_Rate (Rate)
- or C_Bits (Bits)
- or C_Stop_Bits (Stop_Bits)
- or C_Parity (Parity)
- or CREAD;
- Current.c_iflag := 0;
- Current.c_lflag := 0;
- Current.c_oflag := 0;
-
- if Local then
- Current.c_cflag := Current.c_cflag or CLOCAL;
- end if;
-
- case Flow is
- when None =>
- null;
-
- when RTS_CTS =>
- Current.c_cflag := Current.c_cflag or CRTSCTS;
-
- when Xon_Xoff =>
- Current.c_iflag := Current.c_iflag or IXON;
- end case;
-
- Current.c_ispeed := Data_Rate_Value (Rate);
- Current.c_ospeed := Data_Rate_Value (Rate);
- Current.c_cc (VMIN) := char'Val (0);
- Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10));
-
- -- Set port settings
-
- Res := tcflush (int (Port.H.all), TCIFLUSH);
- Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address);
-
- -- Block
-
- Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY));
-
- if Res = -1 then
- Raise_Error ("set: fcntl failed");
- end if;
- end Set;
-
- -----------
- -- Write --
- -----------
-
- overriding procedure Write
- (Port : in out Serial_Port;
- Buffer : Stream_Element_Array)
- is
- Len : constant size_t := Buffer'Length;
- Res : ssize_t;
-
- begin
- if Port.H = null then
- Raise_Error ("write: port not opened", 0);
- end if;
-
- Res := write (int (Port.H.all), Buffer'Address, Len);
-
- if Res = -1 then
- Raise_Error ("write failed");
- end if;
-
- pragma Assert (size_t (Res) = Len);
- end Write;
-
- -----------
- -- Close --
- -----------
-
- procedure Close (Port : in out Serial_Port) is
- procedure Unchecked_Free is
- new Unchecked_Deallocation (Port_Data, Port_Data_Access);
-
- Res : int;
- pragma Unreferenced (Res);
-
- begin
- if Port.H /= null then
- Res := close (int (Port.H.all));
- Unchecked_Free (Port.H);
- end if;
- end Close;
-
-end GNAT.Serial_Communications;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S E R I A L _ C O M M U N I C A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Windows implementation of this package
-
-with Ada.Streams; use Ada.Streams;
-with Ada.Unchecked_Deallocation; use Ada;
-
-with System; use System;
-with System.Communication; use System.Communication;
-with System.CRTL; use System.CRTL;
-with System.OS_Constants;
-with System.Win32; use System.Win32;
-with System.Win32.Ext; use System.Win32.Ext;
-
-with GNAT.OS_Lib;
-
-package body GNAT.Serial_Communications is
-
- package OSC renames System.OS_Constants;
-
- -- Common types
-
- type Port_Data is new HANDLE;
-
- C_Bits : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7);
- C_Parity : constant array (Parity_Check) of Interfaces.C.unsigned :=
- (None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY);
- C_Stop_Bits : constant array (Stop_Bits_Number) of Interfaces.C.unsigned :=
- (One => ONESTOPBIT, Two => TWOSTOPBITS);
-
- -----------
- -- Files --
- -----------
-
- procedure Raise_Error (Message : String; Error : DWORD := GetLastError);
- pragma No_Return (Raise_Error);
-
- -----------
- -- Close --
- -----------
-
- procedure Close (Port : in out Serial_Port) is
- procedure Unchecked_Free is
- new Unchecked_Deallocation (Port_Data, Port_Data_Access);
-
- Success : BOOL;
-
- begin
- if Port.H /= null then
- Success := CloseHandle (HANDLE (Port.H.all));
- Unchecked_Free (Port.H);
-
- if Success = Win32.FALSE then
- Raise_Error ("error closing the port");
- end if;
- end if;
- end Close;
-
- ----------
- -- Name --
- ----------
-
- function Name (Number : Positive) return Port_Name is
- N_Img : constant String := Positive'Image (Number);
- begin
- if Number > 9 then
- return
- Port_Name ("\\.\COM" & N_Img (N_Img'First + 1 .. N_Img'Last));
- else
- return
- Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':');
- end if;
- end Name;
-
- ----------
- -- Open --
- ----------
-
- procedure Open
- (Port : out Serial_Port;
- Name : Port_Name)
- is
- C_Name : constant String := String (Name) & ASCII.NUL;
- Success : BOOL;
- pragma Unreferenced (Success);
-
- begin
- if Port.H = null then
- Port.H := new Port_Data;
- else
- Success := CloseHandle (HANDLE (Port.H.all));
- end if;
-
- Port.H.all := CreateFileA
- (lpFileName => C_Name (C_Name'First)'Address,
- dwDesiredAccess => GENERIC_READ or GENERIC_WRITE,
- dwShareMode => 0,
- lpSecurityAttributes => null,
- dwCreationDisposition => OPEN_EXISTING,
- dwFlagsAndAttributes => 0,
- hTemplateFile => 0);
-
- if Port.H.all = Port_Data (INVALID_HANDLE_VALUE) then
- Raise_Error ("cannot open com port");
- end if;
- end Open;
-
- -----------------
- -- Raise_Error --
- -----------------
-
- procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is
- begin
- raise Serial_Error with Message
- & (if Error /= 0
- then " (" & GNAT.OS_Lib.Errno_Message (Err => Integer (Error)) & ')'
- else "");
- end Raise_Error;
-
- ----------
- -- Read --
- ----------
-
- overriding procedure Read
- (Port : in out Serial_Port;
- Buffer : out Stream_Element_Array;
- Last : out Stream_Element_Offset)
- is
- Success : BOOL;
- Read_Last : aliased DWORD;
-
- begin
- if Port.H = null then
- Raise_Error ("read: port not opened", 0);
- end if;
-
- Success :=
- ReadFile
- (hFile => HANDLE (Port.H.all),
- lpBuffer => Buffer (Buffer'First)'Address,
- nNumberOfBytesToRead => DWORD (Buffer'Length),
- lpNumberOfBytesRead => Read_Last'Access,
- lpOverlapped => null);
-
- if Success = Win32.FALSE then
- Raise_Error ("read error");
- end if;
-
- Last := Last_Index (Buffer'First, size_t (Read_Last));
- end Read;
-
- ---------
- -- Set --
- ---------
-
- procedure Set
- (Port : Serial_Port;
- Rate : Data_Rate := B9600;
- Bits : Data_Bits := CS8;
- Stop_Bits : Stop_Bits_Number := One;
- Parity : Parity_Check := None;
- Block : Boolean := True;
- Local : Boolean := True;
- Flow : Flow_Control := None;
- Timeout : Duration := 10.0)
- is
- pragma Unreferenced (Local);
-
- Success : BOOL;
- Com_Time_Out : aliased COMMTIMEOUTS;
- Com_Settings : aliased DCB;
-
- begin
- if Port.H = null then
- Raise_Error ("set: port not opened", 0);
- end if;
-
- Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access);
-
- if Success = Win32.FALSE then
- Success := CloseHandle (HANDLE (Port.H.all));
- Port.H.all := 0;
- Raise_Error ("set: cannot get comm state");
- end if;
-
- Com_Settings.BaudRate := DWORD (Data_Rate_Value (Rate));
- Com_Settings.fParity := 1;
- Com_Settings.fBinary := Bits1 (System.Win32.TRUE);
- Com_Settings.fOutxDsrFlow := 0;
- Com_Settings.fDsrSensitivity := 0;
- Com_Settings.fDtrControl := OSC.DTR_CONTROL_ENABLE;
- Com_Settings.fInX := 0;
- Com_Settings.fRtsControl := OSC.RTS_CONTROL_ENABLE;
-
- case Flow is
- when None =>
- Com_Settings.fOutX := 0;
- Com_Settings.fOutxCtsFlow := 0;
-
- when RTS_CTS =>
- Com_Settings.fOutX := 0;
- Com_Settings.fOutxCtsFlow := 1;
-
- when Xon_Xoff =>
- Com_Settings.fOutX := 1;
- Com_Settings.fOutxCtsFlow := 0;
- end case;
-
- Com_Settings.fAbortOnError := 0;
- Com_Settings.ByteSize := BYTE (C_Bits (Bits));
- Com_Settings.Parity := BYTE (C_Parity (Parity));
- Com_Settings.StopBits := BYTE (C_Stop_Bits (Stop_Bits));
-
- Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access);
-
- if Success = Win32.FALSE then
- Success := CloseHandle (HANDLE (Port.H.all));
- Port.H.all := 0;
- Raise_Error ("cannot set comm state");
- end if;
-
- -- Set the timeout status, to honor our spec with respect to read
- -- timeouts. Always disconnect write timeouts.
-
- -- Blocking reads - no timeout at all
-
- if Block then
- Com_Time_Out := (others => 0);
-
- -- Non-blocking reads and null timeout - immediate return with what we
- -- have - set ReadIntervalTimeout to MAXDWORD.
-
- elsif Timeout = 0.0 then
- Com_Time_Out :=
- (ReadIntervalTimeout => DWORD'Last,
- others => 0);
-
- -- Non-blocking reads with timeout - set total read timeout accordingly
-
- else
- Com_Time_Out :=
- (ReadTotalTimeoutConstant => DWORD (1000 * Timeout),
- others => 0);
- end if;
-
- Success :=
- SetCommTimeouts
- (hFile => HANDLE (Port.H.all),
- lpCommTimeouts => Com_Time_Out'Access);
-
- if Success = Win32.FALSE then
- Raise_Error ("cannot set the timeout");
- end if;
- end Set;
-
- -----------
- -- Write --
- -----------
-
- overriding procedure Write
- (Port : in out Serial_Port;
- Buffer : Stream_Element_Array)
- is
- Success : BOOL;
- Temp_Last : aliased DWORD;
-
- begin
- if Port.H = null then
- Raise_Error ("write: port not opened", 0);
- end if;
-
- Success :=
- WriteFile
- (hFile => HANDLE (Port.H.all),
- lpBuffer => Buffer'Address,
- nNumberOfBytesToWrite => DWORD (Buffer'Length),
- lpNumberOfBytesWritten => Temp_Last'Access,
- lpOverlapped => null);
-
- if Success = Win32.FALSE
- or else Stream_Element_Offset (Temp_Last) /= Buffer'Length
- then
- Raise_Error ("failed to write data");
- end if;
- end Write;
-
-end GNAT.Serial_Communications;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S E R I A L _ C O M M U N I C A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the GNU/Linux implementation of this package
+
+with Ada.Streams; use Ada.Streams;
+with Ada; use Ada;
+with Ada.Unchecked_Deallocation;
+
+with System; use System;
+with System.Communication; use System.Communication;
+with System.CRTL; use System.CRTL;
+with System.OS_Constants;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package body GNAT.Serial_Communications is
+
+ package OSC renames System.OS_Constants;
+
+ use type Interfaces.C.unsigned;
+
+ type Port_Data is new int;
+
+ subtype unsigned is Interfaces.C.unsigned;
+ subtype char is Interfaces.C.char;
+ subtype unsigned_char is Interfaces.C.unsigned_char;
+
+ function fcntl (fd : int; cmd : int; value : int) return int;
+ pragma Import (C, fcntl, "fcntl");
+
+ C_Data_Rate : constant array (Data_Rate) of unsigned :=
+ (B75 => OSC.B75,
+ B110 => OSC.B110,
+ B150 => OSC.B150,
+ B300 => OSC.B300,
+ B600 => OSC.B600,
+ B1200 => OSC.B1200,
+ B2400 => OSC.B2400,
+ B4800 => OSC.B4800,
+ B9600 => OSC.B9600,
+ B19200 => OSC.B19200,
+ B38400 => OSC.B38400,
+ B57600 => OSC.B57600,
+ B115200 => OSC.B115200);
+
+ C_Bits : constant array (Data_Bits) of unsigned :=
+ (CS7 => OSC.CS7, CS8 => OSC.CS8);
+
+ C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned :=
+ (One => 0, Two => OSC.CSTOPB);
+
+ C_Parity : constant array (Parity_Check) of unsigned :=
+ (None => 0,
+ Odd => OSC.PARENB or OSC.PARODD,
+ Even => OSC.PARENB);
+
+ procedure Raise_Error (Message : String; Error : Integer := Errno);
+ pragma No_Return (Raise_Error);
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name (Number : Positive) return Port_Name is
+ N : constant Natural := Number - 1;
+ N_Img : constant String := Natural'Image (N);
+ begin
+ return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last));
+ end Name;
+
+ ----------
+ -- Open --
+ ----------
+
+ procedure Open
+ (Port : out Serial_Port;
+ Name : Port_Name)
+ is
+ use OSC;
+
+ C_Name : constant String := String (Name) & ASCII.NUL;
+ Res : int;
+
+ begin
+ if Port.H = null then
+ Port.H := new Port_Data;
+ end if;
+
+ Port.H.all := Port_Data (open
+ (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY)));
+
+ if Port.H.all = -1 then
+ Raise_Error ("open: open failed");
+ end if;
+
+ -- By default we are in blocking mode
+
+ Res := fcntl (int (Port.H.all), F_SETFL, 0);
+
+ if Res = -1 then
+ Raise_Error ("open: fcntl failed");
+ end if;
+ end Open;
+
+ -----------------
+ -- Raise_Error --
+ -----------------
+
+ procedure Raise_Error (Message : String; Error : Integer := Errno) is
+ begin
+ raise Serial_Error with Message
+ & (if Error /= 0
+ then " (" & Errno_Message (Err => Error) & ')'
+ else "");
+ end Raise_Error;
+
+ ----------
+ -- Read --
+ ----------
+
+ overriding procedure Read
+ (Port : in out Serial_Port;
+ Buffer : out Stream_Element_Array;
+ Last : out Stream_Element_Offset)
+ is
+ Len : constant size_t := Buffer'Length;
+ Res : ssize_t;
+
+ begin
+ if Port.H = null then
+ Raise_Error ("read: port not opened", 0);
+ end if;
+
+ Res := read (Integer (Port.H.all), Buffer'Address, Len);
+
+ if Res = -1 then
+ Raise_Error ("read failed");
+ end if;
+
+ Last := Last_Index (Buffer'First, size_t (Res));
+ end Read;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set
+ (Port : Serial_Port;
+ Rate : Data_Rate := B9600;
+ Bits : Data_Bits := CS8;
+ Stop_Bits : Stop_Bits_Number := One;
+ Parity : Parity_Check := None;
+ Block : Boolean := True;
+ Local : Boolean := True;
+ Flow : Flow_Control := None;
+ Timeout : Duration := 10.0)
+ is
+ use OSC;
+
+ type termios is record
+ c_iflag : unsigned;
+ c_oflag : unsigned;
+ c_cflag : unsigned;
+ c_lflag : unsigned;
+ c_line : unsigned_char;
+ c_cc : Interfaces.C.char_array (0 .. 31);
+ c_ispeed : unsigned;
+ c_ospeed : unsigned;
+ end record;
+ pragma Convention (C, termios);
+
+ function tcgetattr (fd : int; termios_p : Address) return int;
+ pragma Import (C, tcgetattr, "tcgetattr");
+
+ function tcsetattr
+ (fd : int; action : int; termios_p : Address) return int;
+ pragma Import (C, tcsetattr, "tcsetattr");
+
+ function tcflush (fd : int; queue_selector : int) return int;
+ pragma Import (C, tcflush, "tcflush");
+
+ Current : termios;
+
+ Res : int;
+ pragma Warnings (Off, Res);
+ -- Warnings off, since we don't always test the result
+
+ begin
+ if Port.H = null then
+ Raise_Error ("set: port not opened", 0);
+ end if;
+
+ -- Get current port settings
+
+ Res := tcgetattr (int (Port.H.all), Current'Address);
+
+ -- Change settings now
+
+ Current.c_cflag := C_Data_Rate (Rate)
+ or C_Bits (Bits)
+ or C_Stop_Bits (Stop_Bits)
+ or C_Parity (Parity)
+ or CREAD;
+ Current.c_iflag := 0;
+ Current.c_lflag := 0;
+ Current.c_oflag := 0;
+
+ if Local then
+ Current.c_cflag := Current.c_cflag or CLOCAL;
+ end if;
+
+ case Flow is
+ when None =>
+ null;
+
+ when RTS_CTS =>
+ Current.c_cflag := Current.c_cflag or CRTSCTS;
+
+ when Xon_Xoff =>
+ Current.c_iflag := Current.c_iflag or IXON;
+ end case;
+
+ Current.c_ispeed := Data_Rate_Value (Rate);
+ Current.c_ospeed := Data_Rate_Value (Rate);
+ Current.c_cc (VMIN) := char'Val (0);
+ Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10));
+
+ -- Set port settings
+
+ Res := tcflush (int (Port.H.all), TCIFLUSH);
+ Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address);
+
+ -- Block
+
+ Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY));
+
+ if Res = -1 then
+ Raise_Error ("set: fcntl failed");
+ end if;
+ end Set;
+
+ -----------
+ -- Write --
+ -----------
+
+ overriding procedure Write
+ (Port : in out Serial_Port;
+ Buffer : Stream_Element_Array)
+ is
+ Len : constant size_t := Buffer'Length;
+ Res : ssize_t;
+
+ begin
+ if Port.H = null then
+ Raise_Error ("write: port not opened", 0);
+ end if;
+
+ Res := write (int (Port.H.all), Buffer'Address, Len);
+
+ if Res = -1 then
+ Raise_Error ("write failed");
+ end if;
+
+ pragma Assert (size_t (Res) = Len);
+ end Write;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (Port : in out Serial_Port) is
+ procedure Unchecked_Free is
+ new Unchecked_Deallocation (Port_Data, Port_Data_Access);
+
+ Res : int;
+ pragma Unreferenced (Res);
+
+ begin
+ if Port.H /= null then
+ Res := close (int (Port.H.all));
+ Unchecked_Free (Port.H);
+ end if;
+ end Close;
+
+end GNAT.Serial_Communications;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S E R I A L _ C O M M U N I C A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows implementation of this package
+
+with Ada.Streams; use Ada.Streams;
+with Ada.Unchecked_Deallocation; use Ada;
+
+with System; use System;
+with System.Communication; use System.Communication;
+with System.CRTL; use System.CRTL;
+with System.OS_Constants;
+with System.Win32; use System.Win32;
+with System.Win32.Ext; use System.Win32.Ext;
+
+with GNAT.OS_Lib;
+
+package body GNAT.Serial_Communications is
+
+ package OSC renames System.OS_Constants;
+
+ -- Common types
+
+ type Port_Data is new HANDLE;
+
+ C_Bits : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7);
+ C_Parity : constant array (Parity_Check) of Interfaces.C.unsigned :=
+ (None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY);
+ C_Stop_Bits : constant array (Stop_Bits_Number) of Interfaces.C.unsigned :=
+ (One => ONESTOPBIT, Two => TWOSTOPBITS);
+
+ -----------
+ -- Files --
+ -----------
+
+ procedure Raise_Error (Message : String; Error : DWORD := GetLastError);
+ pragma No_Return (Raise_Error);
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (Port : in out Serial_Port) is
+ procedure Unchecked_Free is
+ new Unchecked_Deallocation (Port_Data, Port_Data_Access);
+
+ Success : BOOL;
+
+ begin
+ if Port.H /= null then
+ Success := CloseHandle (HANDLE (Port.H.all));
+ Unchecked_Free (Port.H);
+
+ if Success = Win32.FALSE then
+ Raise_Error ("error closing the port");
+ end if;
+ end if;
+ end Close;
+
+ ----------
+ -- Name --
+ ----------
+
+ function Name (Number : Positive) return Port_Name is
+ N_Img : constant String := Positive'Image (Number);
+ begin
+ if Number > 9 then
+ return
+ Port_Name ("\\.\COM" & N_Img (N_Img'First + 1 .. N_Img'Last));
+ else
+ return
+ Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':');
+ end if;
+ end Name;
+
+ ----------
+ -- Open --
+ ----------
+
+ procedure Open
+ (Port : out Serial_Port;
+ Name : Port_Name)
+ is
+ C_Name : constant String := String (Name) & ASCII.NUL;
+ Success : BOOL;
+ pragma Unreferenced (Success);
+
+ begin
+ if Port.H = null then
+ Port.H := new Port_Data;
+ else
+ Success := CloseHandle (HANDLE (Port.H.all));
+ end if;
+
+ Port.H.all := CreateFileA
+ (lpFileName => C_Name (C_Name'First)'Address,
+ dwDesiredAccess => GENERIC_READ or GENERIC_WRITE,
+ dwShareMode => 0,
+ lpSecurityAttributes => null,
+ dwCreationDisposition => OPEN_EXISTING,
+ dwFlagsAndAttributes => 0,
+ hTemplateFile => 0);
+
+ if Port.H.all = Port_Data (INVALID_HANDLE_VALUE) then
+ Raise_Error ("cannot open com port");
+ end if;
+ end Open;
+
+ -----------------
+ -- Raise_Error --
+ -----------------
+
+ procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is
+ begin
+ raise Serial_Error with Message
+ & (if Error /= 0
+ then " (" & GNAT.OS_Lib.Errno_Message (Err => Integer (Error)) & ')'
+ else "");
+ end Raise_Error;
+
+ ----------
+ -- Read --
+ ----------
+
+ overriding procedure Read
+ (Port : in out Serial_Port;
+ Buffer : out Stream_Element_Array;
+ Last : out Stream_Element_Offset)
+ is
+ Success : BOOL;
+ Read_Last : aliased DWORD;
+
+ begin
+ if Port.H = null then
+ Raise_Error ("read: port not opened", 0);
+ end if;
+
+ Success :=
+ ReadFile
+ (hFile => HANDLE (Port.H.all),
+ lpBuffer => Buffer (Buffer'First)'Address,
+ nNumberOfBytesToRead => DWORD (Buffer'Length),
+ lpNumberOfBytesRead => Read_Last'Access,
+ lpOverlapped => null);
+
+ if Success = Win32.FALSE then
+ Raise_Error ("read error");
+ end if;
+
+ Last := Last_Index (Buffer'First, size_t (Read_Last));
+ end Read;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set
+ (Port : Serial_Port;
+ Rate : Data_Rate := B9600;
+ Bits : Data_Bits := CS8;
+ Stop_Bits : Stop_Bits_Number := One;
+ Parity : Parity_Check := None;
+ Block : Boolean := True;
+ Local : Boolean := True;
+ Flow : Flow_Control := None;
+ Timeout : Duration := 10.0)
+ is
+ pragma Unreferenced (Local);
+
+ Success : BOOL;
+ Com_Time_Out : aliased COMMTIMEOUTS;
+ Com_Settings : aliased DCB;
+
+ begin
+ if Port.H = null then
+ Raise_Error ("set: port not opened", 0);
+ end if;
+
+ Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access);
+
+ if Success = Win32.FALSE then
+ Success := CloseHandle (HANDLE (Port.H.all));
+ Port.H.all := 0;
+ Raise_Error ("set: cannot get comm state");
+ end if;
+
+ Com_Settings.BaudRate := DWORD (Data_Rate_Value (Rate));
+ Com_Settings.fParity := 1;
+ Com_Settings.fBinary := Bits1 (System.Win32.TRUE);
+ Com_Settings.fOutxDsrFlow := 0;
+ Com_Settings.fDsrSensitivity := 0;
+ Com_Settings.fDtrControl := OSC.DTR_CONTROL_ENABLE;
+ Com_Settings.fInX := 0;
+ Com_Settings.fRtsControl := OSC.RTS_CONTROL_ENABLE;
+
+ case Flow is
+ when None =>
+ Com_Settings.fOutX := 0;
+ Com_Settings.fOutxCtsFlow := 0;
+
+ when RTS_CTS =>
+ Com_Settings.fOutX := 0;
+ Com_Settings.fOutxCtsFlow := 1;
+
+ when Xon_Xoff =>
+ Com_Settings.fOutX := 1;
+ Com_Settings.fOutxCtsFlow := 0;
+ end case;
+
+ Com_Settings.fAbortOnError := 0;
+ Com_Settings.ByteSize := BYTE (C_Bits (Bits));
+ Com_Settings.Parity := BYTE (C_Parity (Parity));
+ Com_Settings.StopBits := BYTE (C_Stop_Bits (Stop_Bits));
+
+ Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access);
+
+ if Success = Win32.FALSE then
+ Success := CloseHandle (HANDLE (Port.H.all));
+ Port.H.all := 0;
+ Raise_Error ("cannot set comm state");
+ end if;
+
+ -- Set the timeout status, to honor our spec with respect to read
+ -- timeouts. Always disconnect write timeouts.
+
+ -- Blocking reads - no timeout at all
+
+ if Block then
+ Com_Time_Out := (others => 0);
+
+ -- Non-blocking reads and null timeout - immediate return with what we
+ -- have - set ReadIntervalTimeout to MAXDWORD.
+
+ elsif Timeout = 0.0 then
+ Com_Time_Out :=
+ (ReadIntervalTimeout => DWORD'Last,
+ others => 0);
+
+ -- Non-blocking reads with timeout - set total read timeout accordingly
+
+ else
+ Com_Time_Out :=
+ (ReadTotalTimeoutConstant => DWORD (1000 * Timeout),
+ others => 0);
+ end if;
+
+ Success :=
+ SetCommTimeouts
+ (hFile => HANDLE (Port.H.all),
+ lpCommTimeouts => Com_Time_Out'Access);
+
+ if Success = Win32.FALSE then
+ Raise_Error ("cannot set the timeout");
+ end if;
+ end Set;
+
+ -----------
+ -- Write --
+ -----------
+
+ overriding procedure Write
+ (Port : in out Serial_Port;
+ Buffer : Stream_Element_Array)
+ is
+ Success : BOOL;
+ Temp_Last : aliased DWORD;
+
+ begin
+ if Port.H = null then
+ Raise_Error ("write: port not opened", 0);
+ end if;
+
+ Success :=
+ WriteFile
+ (hFile => HANDLE (Port.H.all),
+ lpBuffer => Buffer'Address,
+ nNumberOfBytesToWrite => DWORD (Buffer'Length),
+ lpNumberOfBytesWritten => Temp_Last'Access,
+ lpOverlapped => null);
+
+ if Success = Win32.FALSE
+ or else Stream_Element_Offset (Temp_Last) /= Buffer'Length
+ then
+ Raise_Error ("failed to write data");
+ end if;
+ end Write;
+
+end GNAT.Serial_Communications;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2017, AdaCore --
--- --
--- 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 No_Body;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package is a placeholder for the sockets binding for platforms where
--- it is not implemented.
-
-package GNAT.Sockets is
- pragma Unimplemented_Unit;
-end GNAT.Sockets;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-2017, AdaCore --
+-- --
+-- 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 No_Body;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package is a placeholder for the sockets binding for platforms where
+-- it is not implemented.
+
+package GNAT.Sockets is
+ pragma Unimplemented_Unit;
+end GNAT.Sockets;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . T H I N --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2017, AdaCore --
--- --
--- 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 No_Body;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . T H I N --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package is a placeholder for the sockets binding for platforms where
--- it is not implemented.
-
-package GNAT.Sockets.Thin is
- pragma Unimplemented_Unit;
-end GNAT.Sockets.Thin;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . T H I N --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides a target dependent thin interface to the sockets
--- layer for use by the GNAT.Sockets package (g-socket.ads). This package
--- should not be directly with'ed by an applications program.
-
--- This version is for NT
-
-with Ada.Unchecked_Conversion;
-with Interfaces.C.Strings; use Interfaces.C.Strings;
-with System; use System;
-with System.Storage_Elements; use System.Storage_Elements;
-
-package body GNAT.Sockets.Thin is
-
- use type C.unsigned;
-
- WSAData_Dummy : array (1 .. 512) of C.int;
-
- WS_Version : constant := 16#0202#;
- -- Winsock 2.2
-
- Initialized : Boolean := False;
-
- function Standard_Connect
- (S : C.int;
- Name : System.Address;
- Namelen : C.int) return C.int;
- pragma Import (Stdcall, Standard_Connect, "connect");
-
- function Standard_Select
- (Nfds : C.int;
- Readfds : access Fd_Set;
- Writefds : access Fd_Set;
- Exceptfds : access Fd_Set;
- Timeout : Timeval_Access) return C.int;
- pragma Import (Stdcall, Standard_Select, "select");
-
- type Error_Type is
- (N_EINTR,
- N_EBADF,
- N_EACCES,
- N_EFAULT,
- N_EINVAL,
- N_EMFILE,
- N_EWOULDBLOCK,
- N_EINPROGRESS,
- N_EALREADY,
- N_ENOTSOCK,
- N_EDESTADDRREQ,
- N_EMSGSIZE,
- N_EPROTOTYPE,
- N_ENOPROTOOPT,
- N_EPROTONOSUPPORT,
- N_ESOCKTNOSUPPORT,
- N_EOPNOTSUPP,
- N_EPFNOSUPPORT,
- N_EAFNOSUPPORT,
- N_EADDRINUSE,
- N_EADDRNOTAVAIL,
- N_ENETDOWN,
- N_ENETUNREACH,
- N_ENETRESET,
- N_ECONNABORTED,
- N_ECONNRESET,
- N_ENOBUFS,
- N_EISCONN,
- N_ENOTCONN,
- N_ESHUTDOWN,
- N_ETOOMANYREFS,
- N_ETIMEDOUT,
- N_ECONNREFUSED,
- N_ELOOP,
- N_ENAMETOOLONG,
- N_EHOSTDOWN,
- N_EHOSTUNREACH,
- N_WSASYSNOTREADY,
- N_WSAVERNOTSUPPORTED,
- N_WSANOTINITIALISED,
- N_WSAEDISCON,
- N_HOST_NOT_FOUND,
- N_TRY_AGAIN,
- N_NO_RECOVERY,
- N_NO_DATA,
- N_OTHERS);
-
- Error_Messages : constant array (Error_Type) of chars_ptr :=
- (N_EINTR =>
- New_String ("Interrupted system call"),
- N_EBADF =>
- New_String ("Bad file number"),
- N_EACCES =>
- New_String ("Permission denied"),
- N_EFAULT =>
- New_String ("Bad address"),
- N_EINVAL =>
- New_String ("Invalid argument"),
- N_EMFILE =>
- New_String ("Too many open files"),
- N_EWOULDBLOCK =>
- New_String ("Operation would block"),
- N_EINPROGRESS =>
- New_String ("Operation now in progress. This error is "
- & "returned if any Windows Sockets API "
- & "function is called while a blocking "
- & "function is in progress"),
- N_EALREADY =>
- New_String ("Operation already in progress"),
- N_ENOTSOCK =>
- New_String ("Socket operation on nonsocket"),
- N_EDESTADDRREQ =>
- New_String ("Destination address required"),
- N_EMSGSIZE =>
- New_String ("Message too long"),
- N_EPROTOTYPE =>
- New_String ("Protocol wrong type for socket"),
- N_ENOPROTOOPT =>
- New_String ("Protocol not available"),
- N_EPROTONOSUPPORT =>
- New_String ("Protocol not supported"),
- N_ESOCKTNOSUPPORT =>
- New_String ("Socket type not supported"),
- N_EOPNOTSUPP =>
- New_String ("Operation not supported on socket"),
- N_EPFNOSUPPORT =>
- New_String ("Protocol family not supported"),
- N_EAFNOSUPPORT =>
- New_String ("Address family not supported by protocol family"),
- N_EADDRINUSE =>
- New_String ("Address already in use"),
- N_EADDRNOTAVAIL =>
- New_String ("Cannot assign requested address"),
- N_ENETDOWN =>
- New_String ("Network is down. This error may be "
- & "reported at any time if the Windows "
- & "Sockets implementation detects an "
- & "underlying failure"),
- N_ENETUNREACH =>
- New_String ("Network is unreachable"),
- N_ENETRESET =>
- New_String ("Network dropped connection on reset"),
- N_ECONNABORTED =>
- New_String ("Software caused connection abort"),
- N_ECONNRESET =>
- New_String ("Connection reset by peer"),
- N_ENOBUFS =>
- New_String ("No buffer space available"),
- N_EISCONN =>
- New_String ("Socket is already connected"),
- N_ENOTCONN =>
- New_String ("Socket is not connected"),
- N_ESHUTDOWN =>
- New_String ("Cannot send after socket shutdown"),
- N_ETOOMANYREFS =>
- New_String ("Too many references: cannot splice"),
- N_ETIMEDOUT =>
- New_String ("Connection timed out"),
- N_ECONNREFUSED =>
- New_String ("Connection refused"),
- N_ELOOP =>
- New_String ("Too many levels of symbolic links"),
- N_ENAMETOOLONG =>
- New_String ("File name too long"),
- N_EHOSTDOWN =>
- New_String ("Host is down"),
- N_EHOSTUNREACH =>
- New_String ("No route to host"),
- N_WSASYSNOTREADY =>
- New_String ("Returned by WSAStartup(), indicating that "
- & "the network subsystem is unusable"),
- N_WSAVERNOTSUPPORTED =>
- New_String ("Returned by WSAStartup(), indicating that "
- & "the Windows Sockets DLL cannot support "
- & "this application"),
- N_WSANOTINITIALISED =>
- New_String ("Winsock not initialized. This message is "
- & "returned by any function except WSAStartup(), "
- & "indicating that a successful WSAStartup() has "
- & "not yet been performed"),
- N_WSAEDISCON =>
- New_String ("Disconnected"),
- N_HOST_NOT_FOUND =>
- New_String ("Host not found. This message indicates "
- & "that the key (name, address, and so on) was not found"),
- N_TRY_AGAIN =>
- New_String ("Nonauthoritative host not found. This error may "
- & "suggest that the name service itself is not "
- & "functioning"),
- N_NO_RECOVERY =>
- New_String ("Nonrecoverable error. This error may suggest that the "
- & "name service itself is not functioning"),
- N_NO_DATA =>
- New_String ("Valid name, no data record of requested type. "
- & "This error indicates that the key (name, address, "
- & "and so on) was not found."),
- N_OTHERS =>
- New_String ("Unknown system error"));
-
- ---------------
- -- C_Connect --
- ---------------
-
- function C_Connect
- (S : C.int;
- Name : System.Address;
- Namelen : C.int) return C.int
- is
- Res : C.int;
-
- begin
- Res := Standard_Connect (S, Name, Namelen);
-
- if Res = -1 then
- if Socket_Errno = SOSC.EWOULDBLOCK then
- Set_Socket_Errno (SOSC.EINPROGRESS);
- end if;
- end if;
-
- return Res;
- end C_Connect;
-
- ------------------
- -- Socket_Ioctl --
- ------------------
-
- function Socket_Ioctl
- (S : C.int;
- Req : SOSC.IOCTL_Req_T;
- Arg : access C.int) return C.int
- is
- begin
- return C_Ioctl (S, Req, Arg);
- end Socket_Ioctl;
-
- ---------------
- -- C_Recvmsg --
- ---------------
-
- function C_Recvmsg
- (S : C.int;
- Msg : System.Address;
- Flags : C.int) return System.CRTL.ssize_t
- is
- use type C.size_t;
-
- Fill : constant Boolean :=
- SOSC.MSG_WAITALL /= -1
- and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0;
- -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors
-
- Res : C.int;
- Count : C.int := 0;
-
- MH : Msghdr;
- for MH'Address use Msg;
-
- Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
- for Iovec'Address use MH.Msg_Iov;
- pragma Import (Ada, Iovec);
-
- Iov_Index : Integer;
- Current_Iovec : Vector_Element;
-
- function To_Access is new Ada.Unchecked_Conversion
- (System.Address, Stream_Element_Reference);
- pragma Warnings (Off, Stream_Element_Reference);
-
- Req : Request_Type (Name => N_Bytes_To_Read);
-
- begin
- -- Windows does not provide an implementation of recvmsg(). The spec for
- -- WSARecvMsg() is incompatible with the data types we define, and is
- -- available starting with Windows Vista and Server 2008 only. So,
- -- we use C_Recv instead.
-
- -- Check how much data are available
-
- Control_Socket (Socket_Type (S), Req);
-
- -- Fill the vectors
-
- Iov_Index := -1;
- Current_Iovec := (Base => null, Length => 0);
-
- loop
- if Current_Iovec.Length = 0 then
- Iov_Index := Iov_Index + 1;
- exit when Iov_Index > Integer (Iovec'Last);
- Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index));
- end if;
-
- Res :=
- C_Recv
- (S,
- Current_Iovec.Base.all'Address,
- C.int (Current_Iovec.Length),
- Flags);
-
- if Res < 0 then
- return System.CRTL.ssize_t (Res);
-
- elsif Res = 0 and then not Fill then
- exit;
-
- else
- pragma Assert (Interfaces.C.size_t (Res) <= Current_Iovec.Length);
-
- Count := Count + Res;
- Current_Iovec.Length :=
- Current_Iovec.Length - Interfaces.C.size_t (Res);
- Current_Iovec.Base :=
- To_Access (Current_Iovec.Base.all'Address
- + Storage_Offset (Res));
-
- -- If all the data that was initially available read, do not
- -- attempt to receive more, since this might block, or merge data
- -- from successive datagrams for a datagram-oriented socket. We
- -- still try to receive more if we need to fill all vectors
- -- (MSG_WAITALL flag is set).
-
- exit when Natural (Count) >= Req.Size
- and then
-
- -- Either we are not in fill mode
-
- (not Fill
-
- -- Or else last vector filled
-
- or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last
- and then Current_Iovec.Length = 0));
- end if;
- end loop;
-
- return System.CRTL.ssize_t (Count);
- end C_Recvmsg;
-
- --------------
- -- C_Select --
- --------------
-
- function C_Select
- (Nfds : C.int;
- Readfds : access Fd_Set;
- Writefds : access Fd_Set;
- Exceptfds : access Fd_Set;
- Timeout : Timeval_Access) return C.int
- is
- pragma Warnings (Off, Exceptfds);
-
- Original_WFS : aliased constant Fd_Set := Writefds.all;
-
- Res : C.int;
- S : aliased C.int;
- Last : aliased C.int;
-
- begin
- -- Asynchronous connection failures are notified in the exception fd
- -- set instead of the write fd set. To ensure POSIX compatibility, copy
- -- write fd set into exception fd set. Once select() returns, check any
- -- socket present in the exception fd set and peek at incoming
- -- out-of-band data. If the test is not successful, and the socket is
- -- present in the initial write fd set, then move the socket from the
- -- exception fd set to the write fd set.
-
- if Writefds /= No_Fd_Set_Access then
-
- -- Add any socket present in write fd set into exception fd set
-
- declare
- WFS : aliased Fd_Set := Writefds.all;
- begin
- Last := Nfds - 1;
- loop
- Get_Socket_From_Set
- (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access);
- exit when S = -1;
- Insert_Socket_In_Set (Exceptfds, S);
- end loop;
- end;
- end if;
-
- Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout);
-
- if Exceptfds /= No_Fd_Set_Access then
- declare
- EFSC : aliased Fd_Set := Exceptfds.all;
- Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB;
- Buffer : Character;
- Length : C.int;
- Fromlen : aliased C.int;
-
- begin
- Last := Nfds - 1;
- loop
- Get_Socket_From_Set
- (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access);
-
- -- No more sockets in EFSC
-
- exit when S = -1;
-
- -- Check out-of-band data
-
- Length :=
- C_Recvfrom
- (S, Buffer'Address, 1, Flag,
- From => System.Null_Address,
- Fromlen => Fromlen'Unchecked_Access);
- -- Is Fromlen necessary if From is Null_Address???
-
- -- If the signal is not an out-of-band data, then it
- -- is a connection failure notification.
-
- if Length = -1 then
- Remove_Socket_From_Set (Exceptfds, S);
-
- -- If S is present in the initial write fd set, move it from
- -- exception fd set back to write fd set. Otherwise, ignore
- -- this event since the user is not watching for it.
-
- if Writefds /= No_Fd_Set_Access
- and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0)
- then
- Insert_Socket_In_Set (Writefds, S);
- end if;
- end if;
- end loop;
- end;
- end if;
- return Res;
- end C_Select;
-
- ---------------
- -- C_Sendmsg --
- ---------------
-
- function C_Sendmsg
- (S : C.int;
- Msg : System.Address;
- Flags : C.int) return System.CRTL.ssize_t
- is
- use type C.size_t;
-
- Res : C.int;
- Count : C.int := 0;
-
- MH : Msghdr;
- for MH'Address use Msg;
-
- Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
- for Iovec'Address use MH.Msg_Iov;
- pragma Import (Ada, Iovec);
-
- begin
- -- Windows does not provide an implementation of sendmsg(). The spec for
- -- WSASendMsg() is incompatible with the data types we define, and is
- -- available starting with Windows Vista and Server 2008 only. So
- -- use C_Sendto instead.
-
- for J in Iovec'Range loop
- Res :=
- C_Sendto
- (S,
- Iovec (J).Base.all'Address,
- C.int (Iovec (J).Length),
- Flags => Flags,
- To => MH.Msg_Name,
- Tolen => C.int (MH.Msg_Namelen));
-
- if Res < 0 then
- return System.CRTL.ssize_t (Res);
- else
- Count := Count + Res;
- end if;
-
- -- Exit now if the buffer is not fully transmitted
-
- exit when Interfaces.C.size_t (Res) < Iovec (J).Length;
- end loop;
-
- return System.CRTL.ssize_t (Count);
- end C_Sendmsg;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize is
- begin
- if Initialized then
- WSACleanup;
- Initialized := False;
- end if;
- end Finalize;
-
- -------------------------
- -- Host_Error_Messages --
- -------------------------
-
- package body Host_Error_Messages is
-
- -- On Windows, socket and host errors share the same code space, and
- -- error messages are provided by Socket_Error_Message, so the default
- -- separate body for Host_Error_Messages is not used in this case.
-
- function Host_Error_Message (H_Errno : Integer) return String
- renames Socket_Error_Message;
-
- end Host_Error_Messages;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- Return_Value : Interfaces.C.int;
- begin
- if not Initialized then
- Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
- pragma Assert (Return_Value = 0);
- Initialized := True;
- end if;
- end Initialize;
-
- --------------------
- -- Signalling_Fds --
- --------------------
-
- package body Signalling_Fds is separate;
-
- --------------------------
- -- Socket_Error_Message --
- --------------------------
-
- function Socket_Error_Message (Errno : Integer) return String is
- use GNAT.Sockets.SOSC;
-
- Errm : C.Strings.chars_ptr;
-
- begin
- case Errno is
- when EINTR => Errm := Error_Messages (N_EINTR);
- when EBADF => Errm := Error_Messages (N_EBADF);
- when EACCES => Errm := Error_Messages (N_EACCES);
- when EFAULT => Errm := Error_Messages (N_EFAULT);
- when EINVAL => Errm := Error_Messages (N_EINVAL);
- when EMFILE => Errm := Error_Messages (N_EMFILE);
- when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK);
- when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS);
- when EALREADY => Errm := Error_Messages (N_EALREADY);
- when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK);
- when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ);
- when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE);
- when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE);
- when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT);
- when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT);
- when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT);
- when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP);
- when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT);
- when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT);
- when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE);
- when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL);
- when ENETDOWN => Errm := Error_Messages (N_ENETDOWN);
- when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH);
- when ENETRESET => Errm := Error_Messages (N_ENETRESET);
- when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED);
- when ECONNRESET => Errm := Error_Messages (N_ECONNRESET);
- when ENOBUFS => Errm := Error_Messages (N_ENOBUFS);
- when EISCONN => Errm := Error_Messages (N_EISCONN);
- when ENOTCONN => Errm := Error_Messages (N_ENOTCONN);
- when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN);
- when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS);
- when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT);
- when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED);
- when ELOOP => Errm := Error_Messages (N_ELOOP);
- when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG);
- when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN);
- when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH);
-
- -- Windows-specific error codes
-
- when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY);
- when WSAVERNOTSUPPORTED =>
- Errm := Error_Messages (N_WSAVERNOTSUPPORTED);
- when WSANOTINITIALISED =>
- Errm := Error_Messages (N_WSANOTINITIALISED);
- when WSAEDISCON => Errm := Error_Messages (N_WSAEDISCON);
-
- -- h_errno values
-
- when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND);
- when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN);
- when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY);
- when NO_DATA => Errm := Error_Messages (N_NO_DATA);
- when others => Errm := Error_Messages (N_OTHERS);
- end case;
-
- return Value (Errm);
- end Socket_Error_Message;
-
-end GNAT.Sockets.Thin;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . T H I N --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides a target dependent thin interface to the sockets
--- layer for use by the GNAT.Sockets package (g-socket.ads). This package
--- should not be directly with'ed by an applications program.
-
--- This version is for NT
-
-with Interfaces.C;
-
-with GNAT.Sockets.Thin_Common;
-
-with System;
-with System.CRTL;
-
-package GNAT.Sockets.Thin is
-
- use Thin_Common;
-
- package C renames Interfaces.C;
-
- use type System.CRTL.ssize_t;
-
- function Socket_Errno return Integer;
- -- Returns last socket error number
-
- procedure Set_Socket_Errno (Errno : Integer);
- -- Set last socket error number
-
- function Socket_Error_Message (Errno : Integer) return String;
- -- Returns the error message string for the error number Errno. If Errno is
- -- not known, returns "Unknown system error".
-
- function Host_Errno return Integer;
- pragma Import (C, Host_Errno, "__gnat_get_h_errno");
- -- Returns last host error number
-
- package Host_Error_Messages is
-
- function Host_Error_Message (H_Errno : Integer) return String;
- -- Returns the error message string for the host error number H_Errno.
- -- If H_Errno is not known, returns "Unknown system error".
-
- end Host_Error_Messages;
-
- --------------------------------
- -- Standard library functions --
- --------------------------------
-
- function C_Accept
- (S : C.int;
- Addr : System.Address;
- Addrlen : not null access C.int) return C.int;
-
- function C_Bind
- (S : C.int;
- Name : System.Address;
- Namelen : C.int) return C.int;
-
- function C_Close
- (Fd : C.int) return C.int;
-
- function C_Connect
- (S : C.int;
- Name : System.Address;
- Namelen : C.int) return C.int;
-
- function C_Gethostname
- (Name : System.Address;
- Namelen : C.int) return C.int;
-
- function C_Getpeername
- (S : C.int;
- Name : System.Address;
- Namelen : not null access C.int) return C.int;
-
- function C_Getsockname
- (S : C.int;
- Name : System.Address;
- Namelen : not null access C.int) return C.int;
-
- function C_Getsockopt
- (S : C.int;
- Level : C.int;
- Optname : C.int;
- Optval : System.Address;
- Optlen : not null access C.int) return C.int;
-
- function Socket_Ioctl
- (S : C.int;
- Req : SOSC.IOCTL_Req_T;
- Arg : access C.int) return C.int;
-
- function C_Listen
- (S : C.int;
- Backlog : C.int) return C.int;
-
- function C_Recv
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int) return C.int;
-
- function C_Recvfrom
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int;
- From : System.Address;
- Fromlen : not null access C.int) return C.int;
-
- function C_Recvmsg
- (S : C.int;
- Msg : System.Address;
- Flags : C.int) return System.CRTL.ssize_t;
-
- function C_Select
- (Nfds : C.int;
- Readfds : access Fd_Set;
- Writefds : access Fd_Set;
- Exceptfds : access Fd_Set;
- Timeout : Timeval_Access) return C.int;
-
- function C_Sendmsg
- (S : C.int;
- Msg : System.Address;
- Flags : C.int) return System.CRTL.ssize_t;
-
- function C_Sendto
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int;
- To : System.Address;
- Tolen : C.int) return C.int;
-
- function C_Setsockopt
- (S : C.int;
- Level : C.int;
- Optname : C.int;
- Optval : System.Address;
- Optlen : C.int) return C.int;
-
- function C_Shutdown
- (S : C.int;
- How : C.int) return C.int;
-
- function C_Socket
- (Domain : C.int;
- Typ : C.int;
- Protocol : C.int) return C.int;
-
- function C_System
- (Command : System.Address) return C.int;
-
- function WSAStartup
- (WS_Version : Interfaces.C.unsigned_short;
- WSADataAddress : System.Address) return Interfaces.C.int;
-
- -------------------------------------------------------
- -- Signalling file descriptors for selector abortion --
- -------------------------------------------------------
-
- package Signalling_Fds is
-
- function Create (Fds : not null access Fd_Pair) return C.int;
- pragma Convention (C, Create);
- -- Create a pair of connected descriptors suitable for use with C_Select
- -- (used for signalling in Selector objects).
-
- function Read (Rsig : C.int) return C.int;
- pragma Convention (C, Read);
- -- Read one byte of data from rsig, the read end of a pair of signalling
- -- fds created by Create_Signalling_Fds.
-
- function Write (Wsig : C.int) return C.int;
- pragma Convention (C, Write);
- -- Write one byte of data to wsig, the write end of a pair of signalling
- -- fds created by Create_Signalling_Fds.
-
- procedure Close (Sig : C.int);
- pragma Convention (C, Close);
- -- Close one end of a pair of signalling fds (ignoring any error)
-
- end Signalling_Fds;
-
- procedure WSACleanup;
-
- procedure Initialize;
- procedure Finalize;
-
-private
- pragma Import (Stdcall, C_Accept, "accept");
- pragma Import (Stdcall, C_Bind, "bind");
- pragma Import (Stdcall, C_Close, "closesocket");
- pragma Import (Stdcall, C_Gethostname, "gethostname");
- pragma Import (Stdcall, C_Getpeername, "getpeername");
- pragma Import (Stdcall, C_Getsockname, "getsockname");
- pragma Import (Stdcall, C_Getsockopt, "getsockopt");
- pragma Import (Stdcall, C_Listen, "listen");
- pragma Import (Stdcall, C_Recv, "recv");
- pragma Import (Stdcall, C_Recvfrom, "recvfrom");
- pragma Import (Stdcall, C_Sendto, "sendto");
- pragma Import (Stdcall, C_Setsockopt, "setsockopt");
- pragma Import (Stdcall, C_Shutdown, "shutdown");
- pragma Import (Stdcall, C_Socket, "socket");
- pragma Import (C, C_System, "_system");
- pragma Import (Stdcall, Socket_Errno, "WSAGetLastError");
- pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError");
- pragma Import (Stdcall, WSAStartup, "WSAStartup");
- pragma Import (Stdcall, WSACleanup, "WSACleanup");
-
-end GNAT.Sockets.Thin;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . T H I N --
--- --
--- B o d y --
--- --
--- Copyright (C) 2002-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides a target dependent thin interface to the sockets
--- layer for use by the GNAT.Sockets package (g-socket.ads). This package
--- should not be directly with'ed by an applications program.
-
--- This version is for VxWorks
-
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with GNAT.Task_Lock;
-
-with Interfaces.C; use Interfaces.C;
-
-package body GNAT.Sockets.Thin is
-
- Non_Blocking_Sockets : aliased Fd_Set;
- -- When this package is initialized with Process_Blocking_IO set
- -- to True, sockets are set in non-blocking mode to avoid blocking
- -- the whole process when a thread wants to perform a blocking IO
- -- operation. But the user can also set a socket in non-blocking
- -- mode by purpose. In order to make a difference between these
- -- two situations, we track the origin of non-blocking mode in
- -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
- -- been set in non-blocking mode by the user.
-
- Quantum : constant Duration := 0.2;
- -- When SOSC.Thread_Blocking_IO is False, we set sockets in
- -- non-blocking mode and we spend a period of time Quantum between
- -- two attempts on a blocking operation.
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- -- All these require comments ???
-
- function Syscall_Accept
- (S : C.int;
- Addr : System.Address;
- Addrlen : not null access C.int) return C.int;
- pragma Import (C, Syscall_Accept, "accept");
-
- function Syscall_Connect
- (S : C.int;
- Name : System.Address;
- Namelen : C.int) return C.int;
- pragma Import (C, Syscall_Connect, "connect");
-
- function Syscall_Recv
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int) return C.int;
- pragma Import (C, Syscall_Recv, "recv");
-
- function Syscall_Recvfrom
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int;
- From : System.Address;
- Fromlen : not null access C.int) return C.int;
- pragma Import (C, Syscall_Recvfrom, "recvfrom");
-
- function Syscall_Recvmsg
- (S : C.int;
- Msg : System.Address;
- Flags : C.int) return C.int;
- pragma Import (C, Syscall_Recvmsg, "recvmsg");
-
- function Syscall_Sendmsg
- (S : C.int;
- Msg : System.Address;
- Flags : C.int) return C.int;
- pragma Import (C, Syscall_Sendmsg, "sendmsg");
-
- function Syscall_Send
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int) return C.int;
- pragma Import (C, Syscall_Send, "send");
-
- function Syscall_Sendto
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int;
- To : System.Address;
- Tolen : C.int) return C.int;
- pragma Import (C, Syscall_Sendto, "sendto");
-
- function Syscall_Socket
- (Domain : C.int;
- Typ : C.int;
- Protocol : C.int) return C.int;
- pragma Import (C, Syscall_Socket, "socket");
-
- function Non_Blocking_Socket (S : C.int) return Boolean;
- procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
-
- --------------
- -- C_Accept --
- --------------
-
- function C_Accept
- (S : C.int;
- Addr : System.Address;
- Addrlen : not null access C.int) return C.int
- is
- R : C.int;
- Val : aliased C.int := 1;
-
- Res : C.int;
- pragma Unreferenced (Res);
-
- begin
- loop
- R := Syscall_Accept (S, Addr, Addrlen);
- exit when SOSC.Thread_Blocking_IO
- or else R /= Failure
- or else Non_Blocking_Socket (S)
- or else Errno /= SOSC.EWOULDBLOCK;
- delay Quantum;
- end loop;
-
- if not SOSC.Thread_Blocking_IO
- and then R /= Failure
- then
- -- A socket inherits the properties of its server especially
- -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
- -- tracks sockets set in non-blocking mode by user.
-
- Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
- Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
- -- Is it OK to ignore result ???
- end if;
-
- return R;
- end C_Accept;
-
- ---------------
- -- C_Connect --
- ---------------
-
- function C_Connect
- (S : C.int;
- Name : System.Address;
- Namelen : C.int) return C.int
- is
- Res : C.int;
-
- begin
- Res := Syscall_Connect (S, Name, Namelen);
-
- if SOSC.Thread_Blocking_IO
- or else Res /= Failure
- or else Non_Blocking_Socket (S)
- or else Errno /= SOSC.EINPROGRESS
- then
- return Res;
- end if;
-
- declare
- WSet : aliased Fd_Set;
- Now : aliased Timeval;
- begin
- Reset_Socket_Set (WSet'Access);
- loop
- Insert_Socket_In_Set (WSet'Access, S);
- Now := Immediat;
- Res := C_Select
- (S + 1,
- No_Fd_Set_Access,
- WSet'Access,
- No_Fd_Set_Access,
- Now'Unchecked_Access);
-
- exit when Res > 0;
-
- if Res = Failure then
- return Res;
- end if;
-
- delay Quantum;
- end loop;
- end;
-
- Res := Syscall_Connect (S, Name, Namelen);
-
- if Res = Failure
- and then Errno = SOSC.EISCONN
- then
- return Thin_Common.Success;
- else
- return Res;
- end if;
- end C_Connect;
-
- ------------------
- -- Socket_Ioctl --
- ------------------
-
- function Socket_Ioctl
- (S : C.int;
- Req : SOSC.IOCTL_Req_T;
- Arg : access C.int) return C.int
- is
- begin
- if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
- if Arg.all /= 0 then
- Set_Non_Blocking_Socket (S, True);
- end if;
- end if;
-
- return C_Ioctl (S, Req, Arg);
- end Socket_Ioctl;
-
- ------------
- -- C_Recv --
- ------------
-
- function C_Recv
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int) return C.int
- is
- Res : C.int;
-
- begin
- loop
- Res := Syscall_Recv (S, Msg, Len, Flags);
- exit when SOSC.Thread_Blocking_IO
- or else Res /= Failure
- or else Non_Blocking_Socket (S)
- or else Errno /= SOSC.EWOULDBLOCK;
- delay Quantum;
- end loop;
-
- return Res;
- end C_Recv;
-
- ----------------
- -- C_Recvfrom --
- ----------------
-
- function C_Recvfrom
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int;
- From : System.Address;
- Fromlen : not null access C.int) return C.int
- is
- Res : C.int;
-
- begin
- loop
- Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
- exit when SOSC.Thread_Blocking_IO
- or else Res /= Failure
- or else Non_Blocking_Socket (S)
- or else Errno /= SOSC.EWOULDBLOCK;
- delay Quantum;
- end loop;
-
- return Res;
- end C_Recvfrom;
-
- ---------------
- -- C_Recvmsg --
- ---------------
-
- function C_Recvmsg
- (S : C.int;
- Msg : System.Address;
- Flags : C.int) return System.CRTL.ssize_t
- is
- Res : C.int;
-
- begin
- loop
- Res := Syscall_Recvmsg (S, Msg, Flags);
- exit when SOSC.Thread_Blocking_IO
- or else Res /= Failure
- or else Non_Blocking_Socket (S)
- or else Errno /= SOSC.EWOULDBLOCK;
- delay Quantum;
- end loop;
-
- return System.CRTL.ssize_t (Res);
- end C_Recvmsg;
-
- ---------------
- -- C_Sendmsg --
- ---------------
-
- function C_Sendmsg
- (S : C.int;
- Msg : System.Address;
- Flags : C.int) return System.CRTL.ssize_t
- is
- Res : C.int;
-
- begin
- loop
- Res := Syscall_Sendmsg (S, Msg, Flags);
- exit when SOSC.Thread_Blocking_IO
- or else Res /= Failure
- or else Non_Blocking_Socket (S)
- or else Errno /= SOSC.EWOULDBLOCK;
- delay Quantum;
- end loop;
-
- return System.CRTL.ssize_t (Res);
- end C_Sendmsg;
-
- --------------
- -- C_Sendto --
- --------------
-
- function C_Sendto
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int;
- To : System.Address;
- Tolen : C.int) return C.int
- is
- use System;
-
- Res : C.int;
-
- begin
- loop
- if To = Null_Address then
-
- -- In violation of the standard sockets API, VxWorks does not
- -- support sendto(2) calls on connected sockets with a null
- -- destination address, so use send(2) instead in that case.
-
- Res := Syscall_Send (S, Msg, Len, Flags);
-
- -- Normal case where destination address is non-null
-
- else
- Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
- end if;
-
- exit when SOSC.Thread_Blocking_IO
- or else Res /= Failure
- or else Non_Blocking_Socket (S)
- or else Errno /= SOSC.EWOULDBLOCK;
- delay Quantum;
- end loop;
-
- return Res;
- end C_Sendto;
-
- --------------
- -- C_Socket --
- --------------
-
- function C_Socket
- (Domain : C.int;
- Typ : C.int;
- Protocol : C.int) return C.int
- is
- R : C.int;
- Val : aliased C.int := 1;
-
- Res : C.int;
- pragma Unreferenced (Res);
-
- begin
- R := Syscall_Socket (Domain, Typ, Protocol);
-
- if not SOSC.Thread_Blocking_IO
- and then R /= Failure
- then
- -- Do not use Socket_Ioctl as this subprogram tracks sockets set
- -- in non-blocking mode by user.
-
- Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
- -- Is it OK to ignore result ???
- Set_Non_Blocking_Socket (R, False);
- end if;
-
- return R;
- end C_Socket;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize is
- begin
- null;
- end Finalize;
-
- -------------------------
- -- Host_Error_Messages --
- -------------------------
-
- package body Host_Error_Messages is separate;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- Reset_Socket_Set (Non_Blocking_Sockets'Access);
- end Initialize;
-
- -------------------------
- -- Non_Blocking_Socket --
- -------------------------
-
- function Non_Blocking_Socket (S : C.int) return Boolean is
- R : Boolean;
- begin
- Task_Lock.Lock;
- R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
- Task_Lock.Unlock;
- return R;
- end Non_Blocking_Socket;
-
- -----------------------------
- -- Set_Non_Blocking_Socket --
- -----------------------------
-
- procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
- begin
- Task_Lock.Lock;
- if V then
- Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
- else
- Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
- end if;
-
- Task_Lock.Unlock;
- end Set_Non_Blocking_Socket;
-
- --------------------
- -- Signalling_Fds --
- --------------------
-
- package body Signalling_Fds is separate;
-
- --------------------------
- -- Socket_Error_Message --
- --------------------------
-
- function Socket_Error_Message (Errno : Integer) return String is separate;
-
-end GNAT.Sockets.Thin;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . T H I N --
--- --
--- S p e c --
--- --
--- Copyright (C) 2002-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides a target dependent thin interface to the sockets
--- layer for use by the GNAT.Sockets package (g-socket.ads). This package
--- should not be directly with'ed by an applications program.
-
--- This is the version for VxWorks
-
-with Interfaces.C;
-
-with GNAT.OS_Lib;
-with GNAT.Sockets.Thin_Common;
-
-with System;
-with System.CRTL;
-
-package GNAT.Sockets.Thin is
-
- use Thin_Common;
-
- package C renames Interfaces.C;
-
- use type System.CRTL.ssize_t;
-
- function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
- -- Returns last socket error number
-
- procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno;
- -- Set last socket error number
-
- function Socket_Error_Message (Errno : Integer) return String;
- -- Returns the error message string for the error number Errno. If Errno is
- -- not known, returns "Unknown system error".
-
- function Host_Errno return Integer;
- pragma Import (C, Host_Errno, "__gnat_get_h_errno");
- -- Returns last host error number
-
- package Host_Error_Messages is
-
- function Host_Error_Message (H_Errno : Integer) return String;
- -- Returns the error message string for the host error number H_Errno.
- -- If H_Errno is not known, returns "Unknown system error".
-
- end Host_Error_Messages;
-
- --------------------------------
- -- Standard library functions --
- --------------------------------
-
- function C_Accept
- (S : C.int;
- Addr : System.Address;
- Addrlen : not null access C.int) return C.int;
-
- function C_Bind
- (S : C.int;
- Name : System.Address;
- Namelen : C.int) return C.int;
-
- function C_Close
- (Fd : C.int) return C.int;
-
- function C_Connect
- (S : C.int;
- Name : System.Address;
- Namelen : C.int) return C.int;
-
- function C_Gethostname
- (Name : System.Address;
- Namelen : C.int) return C.int;
-
- function C_Getpeername
- (S : C.int;
- Name : System.Address;
- Namelen : not null access C.int) return C.int;
-
- function C_Getsockname
- (S : C.int;
- Name : System.Address;
- Namelen : not null access C.int) return C.int;
-
- function C_Getsockopt
- (S : C.int;
- Level : C.int;
- Optname : C.int;
- Optval : System.Address;
- Optlen : not null access C.int) return C.int;
-
- function Socket_Ioctl
- (S : C.int;
- Req : SOSC.IOCTL_Req_T;
- Arg : access C.int) return C.int;
-
- function C_Listen
- (S : C.int;
- Backlog : C.int) return C.int;
-
- function C_Recv
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int) return C.int;
-
- function C_Recvfrom
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int;
- From : System.Address;
- Fromlen : not null access C.int) return C.int;
-
- function C_Recvmsg
- (S : C.int;
- Msg : System.Address;
- Flags : C.int) return System.CRTL.ssize_t;
-
- function C_Select
- (Nfds : C.int;
- Readfds : access Fd_Set;
- Writefds : access Fd_Set;
- Exceptfds : access Fd_Set;
- Timeout : Timeval_Access) return C.int;
-
- function C_Sendmsg
- (S : C.int;
- Msg : System.Address;
- Flags : C.int) return System.CRTL.ssize_t;
-
- function C_Sendto
- (S : C.int;
- Msg : System.Address;
- Len : C.int;
- Flags : C.int;
- To : System.Address;
- Tolen : C.int) return C.int;
-
- function C_Setsockopt
- (S : C.int;
- Level : C.int;
- Optname : C.int;
- Optval : System.Address;
- Optlen : C.int) return C.int;
-
- function C_Shutdown
- (S : C.int;
- How : C.int) return C.int;
-
- function C_Socket
- (Domain : C.int;
- Typ : C.int;
- Protocol : C.int) return C.int;
-
- function C_System
- (Command : System.Address) return C.int;
-
- -------------------------------------------------------
- -- Signalling file descriptors for selector abortion --
- -------------------------------------------------------
-
- package Signalling_Fds is
-
- function Create (Fds : not null access Fd_Pair) return C.int;
- pragma Convention (C, Create);
- -- Create a pair of connected descriptors suitable for use with C_Select
- -- (used for signalling in Selector objects).
-
- function Read (Rsig : C.int) return C.int;
- pragma Convention (C, Read);
- -- Read one byte of data from rsig, the read end of a pair of signalling
- -- fds created by Create_Signalling_Fds.
-
- function Write (Wsig : C.int) return C.int;
- pragma Convention (C, Write);
- -- Write one byte of data to wsig, the write end of a pair of signalling
- -- fds created by Create_Signalling_Fds.
-
- procedure Close (Sig : C.int);
- pragma Convention (C, Close);
- -- Close one end of a pair of signalling fds (ignoring any error)
-
- end Signalling_Fds;
-
- procedure Initialize;
- procedure Finalize;
-
-private
- pragma Import (C, C_Bind, "bind");
- pragma Import (C, C_Close, "close");
- pragma Import (C, C_Gethostname, "gethostname");
- pragma Import (C, C_Getpeername, "getpeername");
- pragma Import (C, C_Getsockname, "getsockname");
- pragma Import (C, C_Getsockopt, "getsockopt");
- pragma Import (C, C_Listen, "listen");
- pragma Import (C, C_Select, "select");
- pragma Import (C, C_Setsockopt, "setsockopt");
- pragma Import (C, C_Shutdown, "shutdown");
- pragma Import (C, C_System, "system");
-end GNAT.Sockets.Thin;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-2017, AdaCore --
+-- --
+-- 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 No_Body;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package is a placeholder for the sockets binding for platforms where
+-- it is not implemented.
+
+package GNAT.Sockets.Thin is
+ pragma Unimplemented_Unit;
+end GNAT.Sockets.Thin;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a target dependent thin interface to the sockets
+-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
+-- should not be directly with'ed by an applications program.
+
+-- This version is for NT
+
+with Ada.Unchecked_Conversion;
+with Interfaces.C.Strings; use Interfaces.C.Strings;
+with System; use System;
+with System.Storage_Elements; use System.Storage_Elements;
+
+package body GNAT.Sockets.Thin is
+
+ use type C.unsigned;
+
+ WSAData_Dummy : array (1 .. 512) of C.int;
+
+ WS_Version : constant := 16#0202#;
+ -- Winsock 2.2
+
+ Initialized : Boolean := False;
+
+ function Standard_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int) return C.int;
+ pragma Import (Stdcall, Standard_Connect, "connect");
+
+ function Standard_Select
+ (Nfds : C.int;
+ Readfds : access Fd_Set;
+ Writefds : access Fd_Set;
+ Exceptfds : access Fd_Set;
+ Timeout : Timeval_Access) return C.int;
+ pragma Import (Stdcall, Standard_Select, "select");
+
+ type Error_Type is
+ (N_EINTR,
+ N_EBADF,
+ N_EACCES,
+ N_EFAULT,
+ N_EINVAL,
+ N_EMFILE,
+ N_EWOULDBLOCK,
+ N_EINPROGRESS,
+ N_EALREADY,
+ N_ENOTSOCK,
+ N_EDESTADDRREQ,
+ N_EMSGSIZE,
+ N_EPROTOTYPE,
+ N_ENOPROTOOPT,
+ N_EPROTONOSUPPORT,
+ N_ESOCKTNOSUPPORT,
+ N_EOPNOTSUPP,
+ N_EPFNOSUPPORT,
+ N_EAFNOSUPPORT,
+ N_EADDRINUSE,
+ N_EADDRNOTAVAIL,
+ N_ENETDOWN,
+ N_ENETUNREACH,
+ N_ENETRESET,
+ N_ECONNABORTED,
+ N_ECONNRESET,
+ N_ENOBUFS,
+ N_EISCONN,
+ N_ENOTCONN,
+ N_ESHUTDOWN,
+ N_ETOOMANYREFS,
+ N_ETIMEDOUT,
+ N_ECONNREFUSED,
+ N_ELOOP,
+ N_ENAMETOOLONG,
+ N_EHOSTDOWN,
+ N_EHOSTUNREACH,
+ N_WSASYSNOTREADY,
+ N_WSAVERNOTSUPPORTED,
+ N_WSANOTINITIALISED,
+ N_WSAEDISCON,
+ N_HOST_NOT_FOUND,
+ N_TRY_AGAIN,
+ N_NO_RECOVERY,
+ N_NO_DATA,
+ N_OTHERS);
+
+ Error_Messages : constant array (Error_Type) of chars_ptr :=
+ (N_EINTR =>
+ New_String ("Interrupted system call"),
+ N_EBADF =>
+ New_String ("Bad file number"),
+ N_EACCES =>
+ New_String ("Permission denied"),
+ N_EFAULT =>
+ New_String ("Bad address"),
+ N_EINVAL =>
+ New_String ("Invalid argument"),
+ N_EMFILE =>
+ New_String ("Too many open files"),
+ N_EWOULDBLOCK =>
+ New_String ("Operation would block"),
+ N_EINPROGRESS =>
+ New_String ("Operation now in progress. This error is "
+ & "returned if any Windows Sockets API "
+ & "function is called while a blocking "
+ & "function is in progress"),
+ N_EALREADY =>
+ New_String ("Operation already in progress"),
+ N_ENOTSOCK =>
+ New_String ("Socket operation on nonsocket"),
+ N_EDESTADDRREQ =>
+ New_String ("Destination address required"),
+ N_EMSGSIZE =>
+ New_String ("Message too long"),
+ N_EPROTOTYPE =>
+ New_String ("Protocol wrong type for socket"),
+ N_ENOPROTOOPT =>
+ New_String ("Protocol not available"),
+ N_EPROTONOSUPPORT =>
+ New_String ("Protocol not supported"),
+ N_ESOCKTNOSUPPORT =>
+ New_String ("Socket type not supported"),
+ N_EOPNOTSUPP =>
+ New_String ("Operation not supported on socket"),
+ N_EPFNOSUPPORT =>
+ New_String ("Protocol family not supported"),
+ N_EAFNOSUPPORT =>
+ New_String ("Address family not supported by protocol family"),
+ N_EADDRINUSE =>
+ New_String ("Address already in use"),
+ N_EADDRNOTAVAIL =>
+ New_String ("Cannot assign requested address"),
+ N_ENETDOWN =>
+ New_String ("Network is down. This error may be "
+ & "reported at any time if the Windows "
+ & "Sockets implementation detects an "
+ & "underlying failure"),
+ N_ENETUNREACH =>
+ New_String ("Network is unreachable"),
+ N_ENETRESET =>
+ New_String ("Network dropped connection on reset"),
+ N_ECONNABORTED =>
+ New_String ("Software caused connection abort"),
+ N_ECONNRESET =>
+ New_String ("Connection reset by peer"),
+ N_ENOBUFS =>
+ New_String ("No buffer space available"),
+ N_EISCONN =>
+ New_String ("Socket is already connected"),
+ N_ENOTCONN =>
+ New_String ("Socket is not connected"),
+ N_ESHUTDOWN =>
+ New_String ("Cannot send after socket shutdown"),
+ N_ETOOMANYREFS =>
+ New_String ("Too many references: cannot splice"),
+ N_ETIMEDOUT =>
+ New_String ("Connection timed out"),
+ N_ECONNREFUSED =>
+ New_String ("Connection refused"),
+ N_ELOOP =>
+ New_String ("Too many levels of symbolic links"),
+ N_ENAMETOOLONG =>
+ New_String ("File name too long"),
+ N_EHOSTDOWN =>
+ New_String ("Host is down"),
+ N_EHOSTUNREACH =>
+ New_String ("No route to host"),
+ N_WSASYSNOTREADY =>
+ New_String ("Returned by WSAStartup(), indicating that "
+ & "the network subsystem is unusable"),
+ N_WSAVERNOTSUPPORTED =>
+ New_String ("Returned by WSAStartup(), indicating that "
+ & "the Windows Sockets DLL cannot support "
+ & "this application"),
+ N_WSANOTINITIALISED =>
+ New_String ("Winsock not initialized. This message is "
+ & "returned by any function except WSAStartup(), "
+ & "indicating that a successful WSAStartup() has "
+ & "not yet been performed"),
+ N_WSAEDISCON =>
+ New_String ("Disconnected"),
+ N_HOST_NOT_FOUND =>
+ New_String ("Host not found. This message indicates "
+ & "that the key (name, address, and so on) was not found"),
+ N_TRY_AGAIN =>
+ New_String ("Nonauthoritative host not found. This error may "
+ & "suggest that the name service itself is not "
+ & "functioning"),
+ N_NO_RECOVERY =>
+ New_String ("Nonrecoverable error. This error may suggest that the "
+ & "name service itself is not functioning"),
+ N_NO_DATA =>
+ New_String ("Valid name, no data record of requested type. "
+ & "This error indicates that the key (name, address, "
+ & "and so on) was not found."),
+ N_OTHERS =>
+ New_String ("Unknown system error"));
+
+ ---------------
+ -- C_Connect --
+ ---------------
+
+ function C_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int) return C.int
+ is
+ Res : C.int;
+
+ begin
+ Res := Standard_Connect (S, Name, Namelen);
+
+ if Res = -1 then
+ if Socket_Errno = SOSC.EWOULDBLOCK then
+ Set_Socket_Errno (SOSC.EINPROGRESS);
+ end if;
+ end if;
+
+ return Res;
+ end C_Connect;
+
+ ------------------
+ -- Socket_Ioctl --
+ ------------------
+
+ function Socket_Ioctl
+ (S : C.int;
+ Req : SOSC.IOCTL_Req_T;
+ Arg : access C.int) return C.int
+ is
+ begin
+ return C_Ioctl (S, Req, Arg);
+ end Socket_Ioctl;
+
+ ---------------
+ -- C_Recvmsg --
+ ---------------
+
+ function C_Recvmsg
+ (S : C.int;
+ Msg : System.Address;
+ Flags : C.int) return System.CRTL.ssize_t
+ is
+ use type C.size_t;
+
+ Fill : constant Boolean :=
+ SOSC.MSG_WAITALL /= -1
+ and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0;
+ -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors
+
+ Res : C.int;
+ Count : C.int := 0;
+
+ MH : Msghdr;
+ for MH'Address use Msg;
+
+ Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
+ for Iovec'Address use MH.Msg_Iov;
+ pragma Import (Ada, Iovec);
+
+ Iov_Index : Integer;
+ Current_Iovec : Vector_Element;
+
+ function To_Access is new Ada.Unchecked_Conversion
+ (System.Address, Stream_Element_Reference);
+ pragma Warnings (Off, Stream_Element_Reference);
+
+ Req : Request_Type (Name => N_Bytes_To_Read);
+
+ begin
+ -- Windows does not provide an implementation of recvmsg(). The spec for
+ -- WSARecvMsg() is incompatible with the data types we define, and is
+ -- available starting with Windows Vista and Server 2008 only. So,
+ -- we use C_Recv instead.
+
+ -- Check how much data are available
+
+ Control_Socket (Socket_Type (S), Req);
+
+ -- Fill the vectors
+
+ Iov_Index := -1;
+ Current_Iovec := (Base => null, Length => 0);
+
+ loop
+ if Current_Iovec.Length = 0 then
+ Iov_Index := Iov_Index + 1;
+ exit when Iov_Index > Integer (Iovec'Last);
+ Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index));
+ end if;
+
+ Res :=
+ C_Recv
+ (S,
+ Current_Iovec.Base.all'Address,
+ C.int (Current_Iovec.Length),
+ Flags);
+
+ if Res < 0 then
+ return System.CRTL.ssize_t (Res);
+
+ elsif Res = 0 and then not Fill then
+ exit;
+
+ else
+ pragma Assert (Interfaces.C.size_t (Res) <= Current_Iovec.Length);
+
+ Count := Count + Res;
+ Current_Iovec.Length :=
+ Current_Iovec.Length - Interfaces.C.size_t (Res);
+ Current_Iovec.Base :=
+ To_Access (Current_Iovec.Base.all'Address
+ + Storage_Offset (Res));
+
+ -- If all the data that was initially available read, do not
+ -- attempt to receive more, since this might block, or merge data
+ -- from successive datagrams for a datagram-oriented socket. We
+ -- still try to receive more if we need to fill all vectors
+ -- (MSG_WAITALL flag is set).
+
+ exit when Natural (Count) >= Req.Size
+ and then
+
+ -- Either we are not in fill mode
+
+ (not Fill
+
+ -- Or else last vector filled
+
+ or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last
+ and then Current_Iovec.Length = 0));
+ end if;
+ end loop;
+
+ return System.CRTL.ssize_t (Count);
+ end C_Recvmsg;
+
+ --------------
+ -- C_Select --
+ --------------
+
+ function C_Select
+ (Nfds : C.int;
+ Readfds : access Fd_Set;
+ Writefds : access Fd_Set;
+ Exceptfds : access Fd_Set;
+ Timeout : Timeval_Access) return C.int
+ is
+ pragma Warnings (Off, Exceptfds);
+
+ Original_WFS : aliased constant Fd_Set := Writefds.all;
+
+ Res : C.int;
+ S : aliased C.int;
+ Last : aliased C.int;
+
+ begin
+ -- Asynchronous connection failures are notified in the exception fd
+ -- set instead of the write fd set. To ensure POSIX compatibility, copy
+ -- write fd set into exception fd set. Once select() returns, check any
+ -- socket present in the exception fd set and peek at incoming
+ -- out-of-band data. If the test is not successful, and the socket is
+ -- present in the initial write fd set, then move the socket from the
+ -- exception fd set to the write fd set.
+
+ if Writefds /= No_Fd_Set_Access then
+
+ -- Add any socket present in write fd set into exception fd set
+
+ declare
+ WFS : aliased Fd_Set := Writefds.all;
+ begin
+ Last := Nfds - 1;
+ loop
+ Get_Socket_From_Set
+ (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access);
+ exit when S = -1;
+ Insert_Socket_In_Set (Exceptfds, S);
+ end loop;
+ end;
+ end if;
+
+ Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout);
+
+ if Exceptfds /= No_Fd_Set_Access then
+ declare
+ EFSC : aliased Fd_Set := Exceptfds.all;
+ Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB;
+ Buffer : Character;
+ Length : C.int;
+ Fromlen : aliased C.int;
+
+ begin
+ Last := Nfds - 1;
+ loop
+ Get_Socket_From_Set
+ (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access);
+
+ -- No more sockets in EFSC
+
+ exit when S = -1;
+
+ -- Check out-of-band data
+
+ Length :=
+ C_Recvfrom
+ (S, Buffer'Address, 1, Flag,
+ From => System.Null_Address,
+ Fromlen => Fromlen'Unchecked_Access);
+ -- Is Fromlen necessary if From is Null_Address???
+
+ -- If the signal is not an out-of-band data, then it
+ -- is a connection failure notification.
+
+ if Length = -1 then
+ Remove_Socket_From_Set (Exceptfds, S);
+
+ -- If S is present in the initial write fd set, move it from
+ -- exception fd set back to write fd set. Otherwise, ignore
+ -- this event since the user is not watching for it.
+
+ if Writefds /= No_Fd_Set_Access
+ and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0)
+ then
+ Insert_Socket_In_Set (Writefds, S);
+ end if;
+ end if;
+ end loop;
+ end;
+ end if;
+ return Res;
+ end C_Select;
+
+ ---------------
+ -- C_Sendmsg --
+ ---------------
+
+ function C_Sendmsg
+ (S : C.int;
+ Msg : System.Address;
+ Flags : C.int) return System.CRTL.ssize_t
+ is
+ use type C.size_t;
+
+ Res : C.int;
+ Count : C.int := 0;
+
+ MH : Msghdr;
+ for MH'Address use Msg;
+
+ Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
+ for Iovec'Address use MH.Msg_Iov;
+ pragma Import (Ada, Iovec);
+
+ begin
+ -- Windows does not provide an implementation of sendmsg(). The spec for
+ -- WSASendMsg() is incompatible with the data types we define, and is
+ -- available starting with Windows Vista and Server 2008 only. So
+ -- use C_Sendto instead.
+
+ for J in Iovec'Range loop
+ Res :=
+ C_Sendto
+ (S,
+ Iovec (J).Base.all'Address,
+ C.int (Iovec (J).Length),
+ Flags => Flags,
+ To => MH.Msg_Name,
+ Tolen => C.int (MH.Msg_Namelen));
+
+ if Res < 0 then
+ return System.CRTL.ssize_t (Res);
+ else
+ Count := Count + Res;
+ end if;
+
+ -- Exit now if the buffer is not fully transmitted
+
+ exit when Interfaces.C.size_t (Res) < Iovec (J).Length;
+ end loop;
+
+ return System.CRTL.ssize_t (Count);
+ end C_Sendmsg;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize is
+ begin
+ if Initialized then
+ WSACleanup;
+ Initialized := False;
+ end if;
+ end Finalize;
+
+ -------------------------
+ -- Host_Error_Messages --
+ -------------------------
+
+ package body Host_Error_Messages is
+
+ -- On Windows, socket and host errors share the same code space, and
+ -- error messages are provided by Socket_Error_Message, so the default
+ -- separate body for Host_Error_Messages is not used in this case.
+
+ function Host_Error_Message (H_Errno : Integer) return String
+ renames Socket_Error_Message;
+
+ end Host_Error_Messages;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ Return_Value : Interfaces.C.int;
+ begin
+ if not Initialized then
+ Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address);
+ pragma Assert (Return_Value = 0);
+ Initialized := True;
+ end if;
+ end Initialize;
+
+ --------------------
+ -- Signalling_Fds --
+ --------------------
+
+ package body Signalling_Fds is separate;
+
+ --------------------------
+ -- Socket_Error_Message --
+ --------------------------
+
+ function Socket_Error_Message (Errno : Integer) return String is
+ use GNAT.Sockets.SOSC;
+
+ Errm : C.Strings.chars_ptr;
+
+ begin
+ case Errno is
+ when EINTR => Errm := Error_Messages (N_EINTR);
+ when EBADF => Errm := Error_Messages (N_EBADF);
+ when EACCES => Errm := Error_Messages (N_EACCES);
+ when EFAULT => Errm := Error_Messages (N_EFAULT);
+ when EINVAL => Errm := Error_Messages (N_EINVAL);
+ when EMFILE => Errm := Error_Messages (N_EMFILE);
+ when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK);
+ when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS);
+ when EALREADY => Errm := Error_Messages (N_EALREADY);
+ when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK);
+ when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ);
+ when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE);
+ when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE);
+ when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT);
+ when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT);
+ when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT);
+ when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP);
+ when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT);
+ when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT);
+ when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE);
+ when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL);
+ when ENETDOWN => Errm := Error_Messages (N_ENETDOWN);
+ when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH);
+ when ENETRESET => Errm := Error_Messages (N_ENETRESET);
+ when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED);
+ when ECONNRESET => Errm := Error_Messages (N_ECONNRESET);
+ when ENOBUFS => Errm := Error_Messages (N_ENOBUFS);
+ when EISCONN => Errm := Error_Messages (N_EISCONN);
+ when ENOTCONN => Errm := Error_Messages (N_ENOTCONN);
+ when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN);
+ when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS);
+ when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT);
+ when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED);
+ when ELOOP => Errm := Error_Messages (N_ELOOP);
+ when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG);
+ when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN);
+ when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH);
+
+ -- Windows-specific error codes
+
+ when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY);
+ when WSAVERNOTSUPPORTED =>
+ Errm := Error_Messages (N_WSAVERNOTSUPPORTED);
+ when WSANOTINITIALISED =>
+ Errm := Error_Messages (N_WSANOTINITIALISED);
+ when WSAEDISCON => Errm := Error_Messages (N_WSAEDISCON);
+
+ -- h_errno values
+
+ when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND);
+ when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN);
+ when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY);
+ when NO_DATA => Errm := Error_Messages (N_NO_DATA);
+ when others => Errm := Error_Messages (N_OTHERS);
+ end case;
+
+ return Value (Errm);
+ end Socket_Error_Message;
+
+end GNAT.Sockets.Thin;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a target dependent thin interface to the sockets
+-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
+-- should not be directly with'ed by an applications program.
+
+-- This version is for NT
+
+with Interfaces.C;
+
+with GNAT.Sockets.Thin_Common;
+
+with System;
+with System.CRTL;
+
+package GNAT.Sockets.Thin is
+
+ use Thin_Common;
+
+ package C renames Interfaces.C;
+
+ use type System.CRTL.ssize_t;
+
+ function Socket_Errno return Integer;
+ -- Returns last socket error number
+
+ procedure Set_Socket_Errno (Errno : Integer);
+ -- Set last socket error number
+
+ function Socket_Error_Message (Errno : Integer) return String;
+ -- Returns the error message string for the error number Errno. If Errno is
+ -- not known, returns "Unknown system error".
+
+ function Host_Errno return Integer;
+ pragma Import (C, Host_Errno, "__gnat_get_h_errno");
+ -- Returns last host error number
+
+ package Host_Error_Messages is
+
+ function Host_Error_Message (H_Errno : Integer) return String;
+ -- Returns the error message string for the host error number H_Errno.
+ -- If H_Errno is not known, returns "Unknown system error".
+
+ end Host_Error_Messages;
+
+ --------------------------------
+ -- Standard library functions --
+ --------------------------------
+
+ function C_Accept
+ (S : C.int;
+ Addr : System.Address;
+ Addrlen : not null access C.int) return C.int;
+
+ function C_Bind
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int) return C.int;
+
+ function C_Close
+ (Fd : C.int) return C.int;
+
+ function C_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int) return C.int;
+
+ function C_Gethostname
+ (Name : System.Address;
+ Namelen : C.int) return C.int;
+
+ function C_Getpeername
+ (S : C.int;
+ Name : System.Address;
+ Namelen : not null access C.int) return C.int;
+
+ function C_Getsockname
+ (S : C.int;
+ Name : System.Address;
+ Namelen : not null access C.int) return C.int;
+
+ function C_Getsockopt
+ (S : C.int;
+ Level : C.int;
+ Optname : C.int;
+ Optval : System.Address;
+ Optlen : not null access C.int) return C.int;
+
+ function Socket_Ioctl
+ (S : C.int;
+ Req : SOSC.IOCTL_Req_T;
+ Arg : access C.int) return C.int;
+
+ function C_Listen
+ (S : C.int;
+ Backlog : C.int) return C.int;
+
+ function C_Recv
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int) return C.int;
+
+ function C_Recvfrom
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ From : System.Address;
+ Fromlen : not null access C.int) return C.int;
+
+ function C_Recvmsg
+ (S : C.int;
+ Msg : System.Address;
+ Flags : C.int) return System.CRTL.ssize_t;
+
+ function C_Select
+ (Nfds : C.int;
+ Readfds : access Fd_Set;
+ Writefds : access Fd_Set;
+ Exceptfds : access Fd_Set;
+ Timeout : Timeval_Access) return C.int;
+
+ function C_Sendmsg
+ (S : C.int;
+ Msg : System.Address;
+ Flags : C.int) return System.CRTL.ssize_t;
+
+ function C_Sendto
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ To : System.Address;
+ Tolen : C.int) return C.int;
+
+ function C_Setsockopt
+ (S : C.int;
+ Level : C.int;
+ Optname : C.int;
+ Optval : System.Address;
+ Optlen : C.int) return C.int;
+
+ function C_Shutdown
+ (S : C.int;
+ How : C.int) return C.int;
+
+ function C_Socket
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int) return C.int;
+
+ function C_System
+ (Command : System.Address) return C.int;
+
+ function WSAStartup
+ (WS_Version : Interfaces.C.unsigned_short;
+ WSADataAddress : System.Address) return Interfaces.C.int;
+
+ -------------------------------------------------------
+ -- Signalling file descriptors for selector abortion --
+ -------------------------------------------------------
+
+ package Signalling_Fds is
+
+ function Create (Fds : not null access Fd_Pair) return C.int;
+ pragma Convention (C, Create);
+ -- Create a pair of connected descriptors suitable for use with C_Select
+ -- (used for signalling in Selector objects).
+
+ function Read (Rsig : C.int) return C.int;
+ pragma Convention (C, Read);
+ -- Read one byte of data from rsig, the read end of a pair of signalling
+ -- fds created by Create_Signalling_Fds.
+
+ function Write (Wsig : C.int) return C.int;
+ pragma Convention (C, Write);
+ -- Write one byte of data to wsig, the write end of a pair of signalling
+ -- fds created by Create_Signalling_Fds.
+
+ procedure Close (Sig : C.int);
+ pragma Convention (C, Close);
+ -- Close one end of a pair of signalling fds (ignoring any error)
+
+ end Signalling_Fds;
+
+ procedure WSACleanup;
+
+ procedure Initialize;
+ procedure Finalize;
+
+private
+ pragma Import (Stdcall, C_Accept, "accept");
+ pragma Import (Stdcall, C_Bind, "bind");
+ pragma Import (Stdcall, C_Close, "closesocket");
+ pragma Import (Stdcall, C_Gethostname, "gethostname");
+ pragma Import (Stdcall, C_Getpeername, "getpeername");
+ pragma Import (Stdcall, C_Getsockname, "getsockname");
+ pragma Import (Stdcall, C_Getsockopt, "getsockopt");
+ pragma Import (Stdcall, C_Listen, "listen");
+ pragma Import (Stdcall, C_Recv, "recv");
+ pragma Import (Stdcall, C_Recvfrom, "recvfrom");
+ pragma Import (Stdcall, C_Sendto, "sendto");
+ pragma Import (Stdcall, C_Setsockopt, "setsockopt");
+ pragma Import (Stdcall, C_Shutdown, "shutdown");
+ pragma Import (Stdcall, C_Socket, "socket");
+ pragma Import (C, C_System, "_system");
+ pragma Import (Stdcall, Socket_Errno, "WSAGetLastError");
+ pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError");
+ pragma Import (Stdcall, WSAStartup, "WSAStartup");
+ pragma Import (Stdcall, WSACleanup, "WSACleanup");
+
+end GNAT.Sockets.Thin;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a target dependent thin interface to the sockets
+-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
+-- should not be directly with'ed by an applications program.
+
+-- This version is for VxWorks
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Task_Lock;
+
+with Interfaces.C; use Interfaces.C;
+
+package body GNAT.Sockets.Thin is
+
+ Non_Blocking_Sockets : aliased Fd_Set;
+ -- When this package is initialized with Process_Blocking_IO set
+ -- to True, sockets are set in non-blocking mode to avoid blocking
+ -- the whole process when a thread wants to perform a blocking IO
+ -- operation. But the user can also set a socket in non-blocking
+ -- mode by purpose. In order to make a difference between these
+ -- two situations, we track the origin of non-blocking mode in
+ -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
+ -- been set in non-blocking mode by the user.
+
+ Quantum : constant Duration := 0.2;
+ -- When SOSC.Thread_Blocking_IO is False, we set sockets in
+ -- non-blocking mode and we spend a period of time Quantum between
+ -- two attempts on a blocking operation.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ -- All these require comments ???
+
+ function Syscall_Accept
+ (S : C.int;
+ Addr : System.Address;
+ Addrlen : not null access C.int) return C.int;
+ pragma Import (C, Syscall_Accept, "accept");
+
+ function Syscall_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int) return C.int;
+ pragma Import (C, Syscall_Connect, "connect");
+
+ function Syscall_Recv
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int) return C.int;
+ pragma Import (C, Syscall_Recv, "recv");
+
+ function Syscall_Recvfrom
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ From : System.Address;
+ Fromlen : not null access C.int) return C.int;
+ pragma Import (C, Syscall_Recvfrom, "recvfrom");
+
+ function Syscall_Recvmsg
+ (S : C.int;
+ Msg : System.Address;
+ Flags : C.int) return C.int;
+ pragma Import (C, Syscall_Recvmsg, "recvmsg");
+
+ function Syscall_Sendmsg
+ (S : C.int;
+ Msg : System.Address;
+ Flags : C.int) return C.int;
+ pragma Import (C, Syscall_Sendmsg, "sendmsg");
+
+ function Syscall_Send
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int) return C.int;
+ pragma Import (C, Syscall_Send, "send");
+
+ function Syscall_Sendto
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ To : System.Address;
+ Tolen : C.int) return C.int;
+ pragma Import (C, Syscall_Sendto, "sendto");
+
+ function Syscall_Socket
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int) return C.int;
+ pragma Import (C, Syscall_Socket, "socket");
+
+ function Non_Blocking_Socket (S : C.int) return Boolean;
+ procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
+
+ --------------
+ -- C_Accept --
+ --------------
+
+ function C_Accept
+ (S : C.int;
+ Addr : System.Address;
+ Addrlen : not null access C.int) return C.int
+ is
+ R : C.int;
+ Val : aliased C.int := 1;
+
+ Res : C.int;
+ pragma Unreferenced (Res);
+
+ begin
+ loop
+ R := Syscall_Accept (S, Addr, Addrlen);
+ exit when SOSC.Thread_Blocking_IO
+ or else R /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= SOSC.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ if not SOSC.Thread_Blocking_IO
+ and then R /= Failure
+ then
+ -- A socket inherits the properties of its server especially
+ -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
+ -- tracks sockets set in non-blocking mode by user.
+
+ Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
+ Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
+ -- Is it OK to ignore result ???
+ end if;
+
+ return R;
+ end C_Accept;
+
+ ---------------
+ -- C_Connect --
+ ---------------
+
+ function C_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int) return C.int
+ is
+ Res : C.int;
+
+ begin
+ Res := Syscall_Connect (S, Name, Namelen);
+
+ if SOSC.Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= SOSC.EINPROGRESS
+ then
+ return Res;
+ end if;
+
+ declare
+ WSet : aliased Fd_Set;
+ Now : aliased Timeval;
+ begin
+ Reset_Socket_Set (WSet'Access);
+ loop
+ Insert_Socket_In_Set (WSet'Access, S);
+ Now := Immediat;
+ Res := C_Select
+ (S + 1,
+ No_Fd_Set_Access,
+ WSet'Access,
+ No_Fd_Set_Access,
+ Now'Unchecked_Access);
+
+ exit when Res > 0;
+
+ if Res = Failure then
+ return Res;
+ end if;
+
+ delay Quantum;
+ end loop;
+ end;
+
+ Res := Syscall_Connect (S, Name, Namelen);
+
+ if Res = Failure
+ and then Errno = SOSC.EISCONN
+ then
+ return Thin_Common.Success;
+ else
+ return Res;
+ end if;
+ end C_Connect;
+
+ ------------------
+ -- Socket_Ioctl --
+ ------------------
+
+ function Socket_Ioctl
+ (S : C.int;
+ Req : SOSC.IOCTL_Req_T;
+ Arg : access C.int) return C.int
+ is
+ begin
+ if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
+ if Arg.all /= 0 then
+ Set_Non_Blocking_Socket (S, True);
+ end if;
+ end if;
+
+ return C_Ioctl (S, Req, Arg);
+ end Socket_Ioctl;
+
+ ------------
+ -- C_Recv --
+ ------------
+
+ function C_Recv
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int) return C.int
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Recv (S, Msg, Len, Flags);
+ exit when SOSC.Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= SOSC.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return Res;
+ end C_Recv;
+
+ ----------------
+ -- C_Recvfrom --
+ ----------------
+
+ function C_Recvfrom
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ From : System.Address;
+ Fromlen : not null access C.int) return C.int
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
+ exit when SOSC.Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= SOSC.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return Res;
+ end C_Recvfrom;
+
+ ---------------
+ -- C_Recvmsg --
+ ---------------
+
+ function C_Recvmsg
+ (S : C.int;
+ Msg : System.Address;
+ Flags : C.int) return System.CRTL.ssize_t
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Recvmsg (S, Msg, Flags);
+ exit when SOSC.Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= SOSC.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return System.CRTL.ssize_t (Res);
+ end C_Recvmsg;
+
+ ---------------
+ -- C_Sendmsg --
+ ---------------
+
+ function C_Sendmsg
+ (S : C.int;
+ Msg : System.Address;
+ Flags : C.int) return System.CRTL.ssize_t
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Sendmsg (S, Msg, Flags);
+ exit when SOSC.Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= SOSC.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return System.CRTL.ssize_t (Res);
+ end C_Sendmsg;
+
+ --------------
+ -- C_Sendto --
+ --------------
+
+ function C_Sendto
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ To : System.Address;
+ Tolen : C.int) return C.int
+ is
+ use System;
+
+ Res : C.int;
+
+ begin
+ loop
+ if To = Null_Address then
+
+ -- In violation of the standard sockets API, VxWorks does not
+ -- support sendto(2) calls on connected sockets with a null
+ -- destination address, so use send(2) instead in that case.
+
+ Res := Syscall_Send (S, Msg, Len, Flags);
+
+ -- Normal case where destination address is non-null
+
+ else
+ Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
+ end if;
+
+ exit when SOSC.Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= SOSC.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return Res;
+ end C_Sendto;
+
+ --------------
+ -- C_Socket --
+ --------------
+
+ function C_Socket
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int) return C.int
+ is
+ R : C.int;
+ Val : aliased C.int := 1;
+
+ Res : C.int;
+ pragma Unreferenced (Res);
+
+ begin
+ R := Syscall_Socket (Domain, Typ, Protocol);
+
+ if not SOSC.Thread_Blocking_IO
+ and then R /= Failure
+ then
+ -- Do not use Socket_Ioctl as this subprogram tracks sockets set
+ -- in non-blocking mode by user.
+
+ Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
+ -- Is it OK to ignore result ???
+ Set_Non_Blocking_Socket (R, False);
+ end if;
+
+ return R;
+ end C_Socket;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize is
+ begin
+ null;
+ end Finalize;
+
+ -------------------------
+ -- Host_Error_Messages --
+ -------------------------
+
+ package body Host_Error_Messages is separate;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Reset_Socket_Set (Non_Blocking_Sockets'Access);
+ end Initialize;
+
+ -------------------------
+ -- Non_Blocking_Socket --
+ -------------------------
+
+ function Non_Blocking_Socket (S : C.int) return Boolean is
+ R : Boolean;
+ begin
+ Task_Lock.Lock;
+ R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
+ Task_Lock.Unlock;
+ return R;
+ end Non_Blocking_Socket;
+
+ -----------------------------
+ -- Set_Non_Blocking_Socket --
+ -----------------------------
+
+ procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
+ begin
+ Task_Lock.Lock;
+ if V then
+ Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
+ else
+ Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
+ end if;
+
+ Task_Lock.Unlock;
+ end Set_Non_Blocking_Socket;
+
+ --------------------
+ -- Signalling_Fds --
+ --------------------
+
+ package body Signalling_Fds is separate;
+
+ --------------------------
+ -- Socket_Error_Message --
+ --------------------------
+
+ function Socket_Error_Message (Errno : Integer) return String is separate;
+
+end GNAT.Sockets.Thin;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a target dependent thin interface to the sockets
+-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
+-- should not be directly with'ed by an applications program.
+
+-- This is the version for VxWorks
+
+with Interfaces.C;
+
+with GNAT.OS_Lib;
+with GNAT.Sockets.Thin_Common;
+
+with System;
+with System.CRTL;
+
+package GNAT.Sockets.Thin is
+
+ use Thin_Common;
+
+ package C renames Interfaces.C;
+
+ use type System.CRTL.ssize_t;
+
+ function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
+ -- Returns last socket error number
+
+ procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno;
+ -- Set last socket error number
+
+ function Socket_Error_Message (Errno : Integer) return String;
+ -- Returns the error message string for the error number Errno. If Errno is
+ -- not known, returns "Unknown system error".
+
+ function Host_Errno return Integer;
+ pragma Import (C, Host_Errno, "__gnat_get_h_errno");
+ -- Returns last host error number
+
+ package Host_Error_Messages is
+
+ function Host_Error_Message (H_Errno : Integer) return String;
+ -- Returns the error message string for the host error number H_Errno.
+ -- If H_Errno is not known, returns "Unknown system error".
+
+ end Host_Error_Messages;
+
+ --------------------------------
+ -- Standard library functions --
+ --------------------------------
+
+ function C_Accept
+ (S : C.int;
+ Addr : System.Address;
+ Addrlen : not null access C.int) return C.int;
+
+ function C_Bind
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int) return C.int;
+
+ function C_Close
+ (Fd : C.int) return C.int;
+
+ function C_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int) return C.int;
+
+ function C_Gethostname
+ (Name : System.Address;
+ Namelen : C.int) return C.int;
+
+ function C_Getpeername
+ (S : C.int;
+ Name : System.Address;
+ Namelen : not null access C.int) return C.int;
+
+ function C_Getsockname
+ (S : C.int;
+ Name : System.Address;
+ Namelen : not null access C.int) return C.int;
+
+ function C_Getsockopt
+ (S : C.int;
+ Level : C.int;
+ Optname : C.int;
+ Optval : System.Address;
+ Optlen : not null access C.int) return C.int;
+
+ function Socket_Ioctl
+ (S : C.int;
+ Req : SOSC.IOCTL_Req_T;
+ Arg : access C.int) return C.int;
+
+ function C_Listen
+ (S : C.int;
+ Backlog : C.int) return C.int;
+
+ function C_Recv
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int) return C.int;
+
+ function C_Recvfrom
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ From : System.Address;
+ Fromlen : not null access C.int) return C.int;
+
+ function C_Recvmsg
+ (S : C.int;
+ Msg : System.Address;
+ Flags : C.int) return System.CRTL.ssize_t;
+
+ function C_Select
+ (Nfds : C.int;
+ Readfds : access Fd_Set;
+ Writefds : access Fd_Set;
+ Exceptfds : access Fd_Set;
+ Timeout : Timeval_Access) return C.int;
+
+ function C_Sendmsg
+ (S : C.int;
+ Msg : System.Address;
+ Flags : C.int) return System.CRTL.ssize_t;
+
+ function C_Sendto
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ To : System.Address;
+ Tolen : C.int) return C.int;
+
+ function C_Setsockopt
+ (S : C.int;
+ Level : C.int;
+ Optname : C.int;
+ Optval : System.Address;
+ Optlen : C.int) return C.int;
+
+ function C_Shutdown
+ (S : C.int;
+ How : C.int) return C.int;
+
+ function C_Socket
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int) return C.int;
+
+ function C_System
+ (Command : System.Address) return C.int;
+
+ -------------------------------------------------------
+ -- Signalling file descriptors for selector abortion --
+ -------------------------------------------------------
+
+ package Signalling_Fds is
+
+ function Create (Fds : not null access Fd_Pair) return C.int;
+ pragma Convention (C, Create);
+ -- Create a pair of connected descriptors suitable for use with C_Select
+ -- (used for signalling in Selector objects).
+
+ function Read (Rsig : C.int) return C.int;
+ pragma Convention (C, Read);
+ -- Read one byte of data from rsig, the read end of a pair of signalling
+ -- fds created by Create_Signalling_Fds.
+
+ function Write (Wsig : C.int) return C.int;
+ pragma Convention (C, Write);
+ -- Write one byte of data to wsig, the write end of a pair of signalling
+ -- fds created by Create_Signalling_Fds.
+
+ procedure Close (Sig : C.int);
+ pragma Convention (C, Close);
+ -- Close one end of a pair of signalling fds (ignoring any error)
+
+ end Signalling_Fds;
+
+ procedure Initialize;
+ procedure Finalize;
+
+private
+ pragma Import (C, C_Bind, "bind");
+ pragma Import (C, C_Close, "close");
+ pragma Import (C, C_Gethostname, "gethostname");
+ pragma Import (C, C_Getpeername, "getpeername");
+ pragma Import (C, C_Getsockname, "getsockname");
+ pragma Import (C, C_Getsockopt, "getsockopt");
+ pragma Import (C, C_Listen, "listen");
+ pragma Import (C, C_Select, "select");
+ pragma Import (C, C_Setsockopt, "setsockopt");
+ pragma Import (C, C_Shutdown, "shutdown");
+ pragma Import (C, C_System, "system");
+end GNAT.Sockets.Thin;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . L I N K E R _ O P T I O N S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package is used to provide target specific linker_options for the
--- support of sockets as required by the package GNAT.Sockets.
-
--- This is the LynxOS version of this package
-
--- This package should not be directly with'ed by an application program
-
-package GNAT.Sockets.Linker_Options is
-private
- pragma Linker_Options ("-lbsd");
-end GNAT.Sockets.Linker_Options;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . L I N K E R _ O P T I O N S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package is used to provide target specific linker_options for the
--- support of sockets as required by the package GNAT.Sockets.
-
--- This is the Windows/NT version of this package
-
--- This package should not be directly with'ed by an application program
-
-package GNAT.Sockets.Linker_Options is
-private
- pragma Linker_Options ("-lws2_32");
-end GNAT.Sockets.Linker_Options;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . L I N K E R _ O P T I O N S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package is used to provide target specific linker_options for the
--- support of sockets as required by the package GNAT.Sockets.
-
--- This is the Solaris version of this package
-
--- This package should not be directly with'ed by an application program
-
-package GNAT.Sockets.Linker_Options is
-private
- pragma Linker_Options ("-lnsl");
- pragma Linker_Options ("-lsocket");
-end GNAT.Sockets.Linker_Options;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package is used to provide target specific linker_options for the
+-- support of sockets as required by the package GNAT.Sockets.
+
+-- This is the LynxOS version of this package
+
+-- This package should not be directly with'ed by an application program
+
+package GNAT.Sockets.Linker_Options is
+private
+ pragma Linker_Options ("-lbsd");
+end GNAT.Sockets.Linker_Options;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package is used to provide target specific linker_options for the
+-- support of sockets as required by the package GNAT.Sockets.
+
+-- This is the Windows/NT version of this package
+
+-- This package should not be directly with'ed by an application program
+
+package GNAT.Sockets.Linker_Options is
+private
+ pragma Linker_Options ("-lws2_32");
+end GNAT.Sockets.Linker_Options;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package is used to provide target specific linker_options for the
+-- support of sockets as required by the package GNAT.Sockets.
+
+-- This is the Solaris version of this package
+
+-- This package should not be directly with'ed by an application program
+
+package GNAT.Sockets.Linker_Options is
+private
+ pragma Linker_Options ("-lnsl");
+ pragma Linker_Options ("-lsocket");
+end GNAT.Sockets.Linker_Options;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . T H I N _ C O M M O N --
--- --
--- B o d y --
--- --
--- Copyright (C) 2008-2017, 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 No_Body;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . T H I N _ C O M M O N --
--- --
--- S p e c --
--- --
--- Copyright (C) 2008-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package is a placeholder for the sockets binding for platforms where
--- it is not implemented.
-
-package GNAT.Sockets.Thin_Common is
- pragma Unimplemented_Unit;
-end GNAT.Sockets.Thin_Common;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N _ C O M M O N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2008-2017, 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 No_Body;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N _ C O M M O N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2008-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package is a placeholder for the sockets binding for platforms where
+-- it is not implemented.
+
+package GNAT.Sockets.Thin_Common is
+ pragma Unimplemented_Unit;
+end GNAT.Sockets.Thin_Common;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . S O C K E T S . T H I N . S I G N A L L I N G _ F D S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2017, AdaCore --
--- --
--- 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. --
--- --
-------------------------------------------------------------------------------
-
--- Portable sockets-based implementation of GNAT.Sockets.Thin.Signalling_Fds
--- used for platforms that do not support UNIX pipes.
-
--- Note: this code used to be in GNAT.Sockets, but has been moved to a
--- platform-specific file. It is now used only for non-UNIX platforms.
-
-separate (GNAT.Sockets.Thin)
-package body Signalling_Fds is
-
- -----------
- -- Close --
- -----------
-
- procedure Close (Sig : C.int) is
- Res : C.int;
- pragma Unreferenced (Res);
- -- Res is assigned but never read, because we purposefully ignore
- -- any error returned by the C_Close system call, as per the spec
- -- of this procedure.
- begin
- Res := C_Close (Sig);
- end Close;
-
- ------------
- -- Create --
- ------------
-
- function Create (Fds : not null access Fd_Pair) return C.int is
- L_Sock, R_Sock, W_Sock : C.int := Failure;
- -- Listening socket, read socket and write socket
-
- Sin : aliased Sockaddr_In;
- Len : aliased C.int;
- -- Address of listening socket
-
- Res : C.int;
- pragma Warnings (Off, Res);
- -- Return status of system calls (usually ignored, hence warnings off)
-
- begin
- Fds.all := (Read_End | Write_End => Failure);
-
- -- We open two signalling sockets. One of them is used to send data
- -- to the other, which is included in a C_Select socket set. The
- -- communication is used to force the call to C_Select to complete,
- -- and the waiting task to resume its execution.
-
- loop
- -- Retry loop, in case the C_Connect below fails
-
- -- Create a listening socket
-
- L_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0);
-
- if L_Sock = Failure then
- goto Fail;
- end if;
-
- -- Bind the socket to an available port on localhost
-
- Set_Family (Sin.Sin_Family, Family_Inet);
- Sin.Sin_Addr.S_B1 := 127;
- Sin.Sin_Addr.S_B2 := 0;
- Sin.Sin_Addr.S_B3 := 0;
- Sin.Sin_Addr.S_B4 := 1;
- Sin.Sin_Port := 0;
-
- Len := C.int (Lengths (Family_Inet));
- Res := C_Bind (L_Sock, Sin'Address, Len);
-
- if Res = Failure then
- goto Fail;
- end if;
-
- -- Get assigned port
-
- Res := C_Getsockname (L_Sock, Sin'Address, Len'Access);
- if Res = Failure then
- goto Fail;
- end if;
-
- -- Set socket to listen mode, with a backlog of 1 to guarantee that
- -- exactly one call to connect(2) succeeds.
-
- Res := C_Listen (L_Sock, 1);
-
- if Res = Failure then
- goto Fail;
- end if;
-
- -- Create read end (client) socket
-
- R_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0);
-
- if R_Sock = Failure then
- goto Fail;
- end if;
-
- -- Connect listening socket
-
- Res := C_Connect (R_Sock, Sin'Address, Len);
-
- exit when Res /= Failure;
-
- if Socket_Errno /= SOSC.EADDRINUSE then
- goto Fail;
- end if;
-
- -- In rare cases, the above C_Bind chooses a port that is still
- -- marked "in use", even though it has been closed (perhaps by some
- -- other process that has already exited). This causes the above
- -- C_Connect to fail with EADDRINUSE. In this case, we close the
- -- ports, and loop back to try again. This mysterious Windows
- -- behavior is documented. See, for example:
- -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx
- -- In an experiment with 2000 calls, 21 required exactly one retry, 7
- -- required two, and none required three or more. Note that no delay
- -- is needed between retries; retrying C_Bind will typically produce
- -- a different port.
-
- pragma Assert (Res = Failure
- and then
- Socket_Errno = SOSC.EADDRINUSE);
- Res := C_Close (W_Sock);
- W_Sock := Failure;
- Res := C_Close (R_Sock);
- R_Sock := Failure;
- end loop;
-
- -- Since the call to connect(2) has succeeded and the backlog limit on
- -- the listening socket is 1, we know that there is now exactly one
- -- pending connection on L_Sock, which is the one from R_Sock.
-
- W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access);
-
- if W_Sock = Failure then
- goto Fail;
- end if;
-
- -- Set TCP_NODELAY on W_Sock, since we always want to send the data out
- -- immediately.
-
- Set_Socket_Option
- (Socket => Socket_Type (W_Sock),
- Level => IP_Protocol_For_TCP_Level,
- Option => (Name => No_Delay, Enabled => True));
-
- -- Close listening socket (ignore exit status)
-
- Res := C_Close (L_Sock);
-
- Fds.all := (Read_End => R_Sock, Write_End => W_Sock);
-
- return Thin_Common.Success;
-
- <<Fail>>
- declare
- Saved_Errno : constant Integer := Socket_Errno;
-
- begin
- if W_Sock /= Failure then
- Res := C_Close (W_Sock);
- end if;
-
- if R_Sock /= Failure then
- Res := C_Close (R_Sock);
- end if;
-
- if L_Sock /= Failure then
- Res := C_Close (L_Sock);
- end if;
-
- Set_Socket_Errno (Saved_Errno);
- end;
-
- return Failure;
- end Create;
-
- ----------
- -- Read --
- ----------
-
- function Read (Rsig : C.int) return C.int is
- Buf : aliased Character;
- begin
- return C_Recv (Rsig, Buf'Address, 1, SOSC.MSG_Forced_Flags);
- end Read;
-
- -----------
- -- Write --
- -----------
-
- function Write (Wsig : C.int) return C.int is
- Buf : aliased Character := ASCII.NUL;
- begin
- return C_Sendto
- (Wsig, Buf'Address, 1,
- Flags => SOSC.MSG_Forced_Flags,
- To => System.Null_Address,
- Tolen => 0);
- end Write;
-
-end Signalling_Fds;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N . S I G N A L L I N G _ F D S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-2017, AdaCore --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Portable sockets-based implementation of GNAT.Sockets.Thin.Signalling_Fds
+-- used for platforms that do not support UNIX pipes.
+
+-- Note: this code used to be in GNAT.Sockets, but has been moved to a
+-- platform-specific file. It is now used only for non-UNIX platforms.
+
+separate (GNAT.Sockets.Thin)
+package body Signalling_Fds is
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (Sig : C.int) is
+ Res : C.int;
+ pragma Unreferenced (Res);
+ -- Res is assigned but never read, because we purposefully ignore
+ -- any error returned by the C_Close system call, as per the spec
+ -- of this procedure.
+ begin
+ Res := C_Close (Sig);
+ end Close;
+
+ ------------
+ -- Create --
+ ------------
+
+ function Create (Fds : not null access Fd_Pair) return C.int is
+ L_Sock, R_Sock, W_Sock : C.int := Failure;
+ -- Listening socket, read socket and write socket
+
+ Sin : aliased Sockaddr_In;
+ Len : aliased C.int;
+ -- Address of listening socket
+
+ Res : C.int;
+ pragma Warnings (Off, Res);
+ -- Return status of system calls (usually ignored, hence warnings off)
+
+ begin
+ Fds.all := (Read_End | Write_End => Failure);
+
+ -- We open two signalling sockets. One of them is used to send data
+ -- to the other, which is included in a C_Select socket set. The
+ -- communication is used to force the call to C_Select to complete,
+ -- and the waiting task to resume its execution.
+
+ loop
+ -- Retry loop, in case the C_Connect below fails
+
+ -- Create a listening socket
+
+ L_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0);
+
+ if L_Sock = Failure then
+ goto Fail;
+ end if;
+
+ -- Bind the socket to an available port on localhost
+
+ Set_Family (Sin.Sin_Family, Family_Inet);
+ Sin.Sin_Addr.S_B1 := 127;
+ Sin.Sin_Addr.S_B2 := 0;
+ Sin.Sin_Addr.S_B3 := 0;
+ Sin.Sin_Addr.S_B4 := 1;
+ Sin.Sin_Port := 0;
+
+ Len := C.int (Lengths (Family_Inet));
+ Res := C_Bind (L_Sock, Sin'Address, Len);
+
+ if Res = Failure then
+ goto Fail;
+ end if;
+
+ -- Get assigned port
+
+ Res := C_Getsockname (L_Sock, Sin'Address, Len'Access);
+ if Res = Failure then
+ goto Fail;
+ end if;
+
+ -- Set socket to listen mode, with a backlog of 1 to guarantee that
+ -- exactly one call to connect(2) succeeds.
+
+ Res := C_Listen (L_Sock, 1);
+
+ if Res = Failure then
+ goto Fail;
+ end if;
+
+ -- Create read end (client) socket
+
+ R_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0);
+
+ if R_Sock = Failure then
+ goto Fail;
+ end if;
+
+ -- Connect listening socket
+
+ Res := C_Connect (R_Sock, Sin'Address, Len);
+
+ exit when Res /= Failure;
+
+ if Socket_Errno /= SOSC.EADDRINUSE then
+ goto Fail;
+ end if;
+
+ -- In rare cases, the above C_Bind chooses a port that is still
+ -- marked "in use", even though it has been closed (perhaps by some
+ -- other process that has already exited). This causes the above
+ -- C_Connect to fail with EADDRINUSE. In this case, we close the
+ -- ports, and loop back to try again. This mysterious Windows
+ -- behavior is documented. See, for example:
+ -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx
+ -- In an experiment with 2000 calls, 21 required exactly one retry, 7
+ -- required two, and none required three or more. Note that no delay
+ -- is needed between retries; retrying C_Bind will typically produce
+ -- a different port.
+
+ pragma Assert (Res = Failure
+ and then
+ Socket_Errno = SOSC.EADDRINUSE);
+ Res := C_Close (W_Sock);
+ W_Sock := Failure;
+ Res := C_Close (R_Sock);
+ R_Sock := Failure;
+ end loop;
+
+ -- Since the call to connect(2) has succeeded and the backlog limit on
+ -- the listening socket is 1, we know that there is now exactly one
+ -- pending connection on L_Sock, which is the one from R_Sock.
+
+ W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access);
+
+ if W_Sock = Failure then
+ goto Fail;
+ end if;
+
+ -- Set TCP_NODELAY on W_Sock, since we always want to send the data out
+ -- immediately.
+
+ Set_Socket_Option
+ (Socket => Socket_Type (W_Sock),
+ Level => IP_Protocol_For_TCP_Level,
+ Option => (Name => No_Delay, Enabled => True));
+
+ -- Close listening socket (ignore exit status)
+
+ Res := C_Close (L_Sock);
+
+ Fds.all := (Read_End => R_Sock, Write_End => W_Sock);
+
+ return Thin_Common.Success;
+
+ <<Fail>>
+ declare
+ Saved_Errno : constant Integer := Socket_Errno;
+
+ begin
+ if W_Sock /= Failure then
+ Res := C_Close (W_Sock);
+ end if;
+
+ if R_Sock /= Failure then
+ Res := C_Close (R_Sock);
+ end if;
+
+ if L_Sock /= Failure then
+ Res := C_Close (L_Sock);
+ end if;
+
+ Set_Socket_Errno (Saved_Errno);
+ end;
+
+ return Failure;
+ end Create;
+
+ ----------
+ -- Read --
+ ----------
+
+ function Read (Rsig : C.int) return C.int is
+ Buf : aliased Character;
+ begin
+ return C_Recv (Rsig, Buf'Address, 1, SOSC.MSG_Forced_Flags);
+ end Read;
+
+ -----------
+ -- Write --
+ -----------
+
+ function Write (Wsig : C.int) return C.int is
+ Buf : aliased Character := ASCII.NUL;
+ begin
+ return C_Sendto
+ (Wsig, Buf'Address, 1,
+ Flags => SOSC.MSG_Forced_Flags,
+ To => System.Null_Address,
+ Tolen => 0);
+ end Write;
+
+end Signalling_Fds;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- I N T E R F A C E S . V X W O R K S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1999-2017, AdaCore --
--- --
--- 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the x86 VxWorks version of this package
-
--- This package provides a limited binding to the VxWorks API
--- In particular, it interfaces with the VxWorks hardware interrupt
--- facilities, allowing the use of low-latency direct-vectored
--- interrupt handlers. Note that such handlers have a variety of
--- restrictions regarding system calls and language constructs. In particular,
--- the use of exception handlers and functions returning variable-length
--- objects cannot be used. Less restrictive, but higher-latency handlers can
--- be written using Ada protected procedures, Ada 83 style interrupt entries,
--- or by signalling an Ada task from within an interrupt handler using a
--- binary semaphore as described in the VxWorks Programmer's Manual.
---
--- For complete documentation of the operations in this package, please
--- consult the VxWorks Programmer's Manual and VxWorks Reference Manual.
-
-pragma Warnings (Off, "*foreign convention*");
-pragma Warnings (Off, "*add Convention pragma*");
-
-with System.VxWorks;
-
-package Interfaces.VxWorks is
- pragma Preelaborate;
-
- ------------------------------------------------------------------------
- -- Here is a complete example that shows how to handle the Interrupt 0x33
- -- with a direct-vectored interrupt handler in Ada using this package:
-
- -- with Interfaces.VxWorks; use Interfaces.VxWorks;
- -- with System;
- --
- -- package P is
- --
- -- Count : Integer;
- -- pragma Atomic (Count);
- --
- -- procedure Handler (Parameter : System.Address);
- --
- -- end P;
- --
- -- package body P is
- --
- -- procedure Handler (Parameter : System.Address) is
- -- begin
- -- Count := Count + 1;
- -- logMsg ("received an interrupt" & ASCII.LF & ASCII.NUL);
- -- end Handler;
- -- end P;
- --
- -- with Interfaces.VxWorks; use Interfaces.VxWorks;
- -- with Ada.Text_IO; use Ada.Text_IO;
- -- with Ada.Interrupts;
- -- with Machine_Code; use Machine_Code;
- --
- -- with P; use P;
- -- procedure Useint is
- --
- -- -- Be sure to use a reasonable interrupt number for target board.
- -- -- This one is an unreserved interrupt for the Pentium 3 BSP
- --
- -- Interrupt : constant := 16#33#;
- --
- -- task T;
- --
- -- S : STATUS;
- --
- -- task body T is
- -- begin
- -- loop
- -- Put_Line ("Generating an interrupt...");
- -- delay 1.0;
- --
- -- -- Generate interrupt, using interrupt number
- --
- -- Asm ("int %0",
- -- Inputs =>
- -- Ada.Interrupts.Interrupt_ID'Asm_Input
- -- ("i", Interrupt));
- -- end loop;
- -- end T;
- --
- -- begin
- -- S := intConnect (INUM_TO_IVEC (Interrupt), Handler'Access);
- --
- -- loop
- -- delay 2.0;
- -- Put_Line ("value of count:" & P.Count'Img);
- -- end loop;
- -- end Useint;
- -------------------------------------
-
- subtype int is Integer;
-
- type STATUS is new int;
- -- Equivalent of the C type STATUS
-
- OK : constant STATUS := 0;
- ERROR : constant STATUS := -1;
-
- type VOIDFUNCPTR is access procedure (parameter : System.Address);
- type Interrupt_Vector is new System.Address;
- type Exception_Vector is new System.Address;
-
- function intConnect
- (vector : Interrupt_Vector;
- handler : VOIDFUNCPTR;
- parameter : System.Address := System.Null_Address) return STATUS;
- -- Binding to the C routine intConnect. Use this to set up an user handler.
- -- The routine generates a wrapper around the user handler to save and
- -- restore context
-
- function intContext return int;
- -- Binding to the C routine intContext. This function returns 1 only if the
- -- current execution state is in interrupt context.
-
- function intVecGet
- (Vector : Interrupt_Vector) return VOIDFUNCPTR;
- -- Binding to the C routine intVecGet. Use this to get the existing handler
- -- for later restoral
-
- procedure intVecSet
- (Vector : Interrupt_Vector;
- Handler : VOIDFUNCPTR);
- -- Binding to the C routine intVecSet. Use this to restore a handler
- -- obtained using intVecGet
-
- procedure intVecGet2
- (vector : Interrupt_Vector;
- pFunction : out VOIDFUNCPTR;
- pIdtGate : not null access int;
- pIdtSelector : not null access int);
- -- Binding to the C routine intVecGet2. Use this to get the existing
- -- handler for later restoral
-
- procedure intVecSet2
- (vector : Interrupt_Vector;
- pFunction : VOIDFUNCPTR;
- pIdtGate : not null access int;
- pIdtSelector : not null access int);
- -- Binding to the C routine intVecSet2. Use this to restore a
- -- handler obtained using intVecGet2
-
- function INUM_TO_IVEC (intNum : int) return Interrupt_Vector;
- -- Equivalent to the C macro INUM_TO_IVEC used to convert an interrupt
- -- number to an interrupt vector
-
- procedure logMsg
- (fmt : String; arg1, arg2, arg3, arg4, arg5, arg6 : int := 0);
- -- Binding to the C routine logMsg. Note that it is the caller's
- -- responsibility to ensure that fmt is a null-terminated string
- -- (e.g logMsg ("Interrupt" & ASCII.NUL))
-
- type FP_CONTEXT is private;
- -- Floating point context save and restore. Handlers using floating point
- -- must be bracketed with these calls. The pFpContext parameter should be
- -- an object of type FP_CONTEXT that is declared local to the handler.
- --
- -- See the VxWorks Intel Architecture Supplement regarding these routines
-
- procedure fppRestore (pFpContext : in out FP_CONTEXT);
- -- Restore floating point context - old style
-
- procedure fppSave (pFpContext : in out FP_CONTEXT);
- -- Save floating point context - old style
-
- procedure fppXrestore (pFpContext : in out FP_CONTEXT);
- -- Restore floating point context - new style
-
- procedure fppXsave (pFpContext : in out FP_CONTEXT);
- -- Save floating point context - new style
-
-private
-
- type FP_CONTEXT is new System.VxWorks.FP_CONTEXT;
- -- Target-dependent floating point context type
-
- pragma Import (C, intConnect, "intConnect");
- pragma Import (C, intContext, "intContext");
- pragma Import (C, intVecGet, "intVecGet");
- pragma Import (C, intVecSet, "intVecSet");
- pragma Import (C, intVecGet2, "intVecGet2");
- pragma Import (C, intVecSet2, "intVecSet2");
- pragma Import (C, INUM_TO_IVEC, "__gnat_inum_to_ivec");
- pragma Import (C, logMsg, "logMsg");
- pragma Import (C, fppRestore, "fppRestore");
- pragma Import (C, fppSave, "fppSave");
- pragma Import (C, fppXrestore, "fppXrestore");
- pragma Import (C, fppXsave, "fppXsave");
-end Interfaces.VxWorks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- I N T E R F A C E S . V X W O R K S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1999-2017, AdaCore --
+-- --
+-- 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the x86 VxWorks version of this package
+
+-- This package provides a limited binding to the VxWorks API
+-- In particular, it interfaces with the VxWorks hardware interrupt
+-- facilities, allowing the use of low-latency direct-vectored
+-- interrupt handlers. Note that such handlers have a variety of
+-- restrictions regarding system calls and language constructs. In particular,
+-- the use of exception handlers and functions returning variable-length
+-- objects cannot be used. Less restrictive, but higher-latency handlers can
+-- be written using Ada protected procedures, Ada 83 style interrupt entries,
+-- or by signalling an Ada task from within an interrupt handler using a
+-- binary semaphore as described in the VxWorks Programmer's Manual.
+--
+-- For complete documentation of the operations in this package, please
+-- consult the VxWorks Programmer's Manual and VxWorks Reference Manual.
+
+pragma Warnings (Off, "*foreign convention*");
+pragma Warnings (Off, "*add Convention pragma*");
+
+with System.VxWorks;
+
+package Interfaces.VxWorks is
+ pragma Preelaborate;
+
+ ------------------------------------------------------------------------
+ -- Here is a complete example that shows how to handle the Interrupt 0x33
+ -- with a direct-vectored interrupt handler in Ada using this package:
+
+ -- with Interfaces.VxWorks; use Interfaces.VxWorks;
+ -- with System;
+ --
+ -- package P is
+ --
+ -- Count : Integer;
+ -- pragma Atomic (Count);
+ --
+ -- procedure Handler (Parameter : System.Address);
+ --
+ -- end P;
+ --
+ -- package body P is
+ --
+ -- procedure Handler (Parameter : System.Address) is
+ -- begin
+ -- Count := Count + 1;
+ -- logMsg ("received an interrupt" & ASCII.LF & ASCII.NUL);
+ -- end Handler;
+ -- end P;
+ --
+ -- with Interfaces.VxWorks; use Interfaces.VxWorks;
+ -- with Ada.Text_IO; use Ada.Text_IO;
+ -- with Ada.Interrupts;
+ -- with Machine_Code; use Machine_Code;
+ --
+ -- with P; use P;
+ -- procedure Useint is
+ --
+ -- -- Be sure to use a reasonable interrupt number for target board.
+ -- -- This one is an unreserved interrupt for the Pentium 3 BSP
+ --
+ -- Interrupt : constant := 16#33#;
+ --
+ -- task T;
+ --
+ -- S : STATUS;
+ --
+ -- task body T is
+ -- begin
+ -- loop
+ -- Put_Line ("Generating an interrupt...");
+ -- delay 1.0;
+ --
+ -- -- Generate interrupt, using interrupt number
+ --
+ -- Asm ("int %0",
+ -- Inputs =>
+ -- Ada.Interrupts.Interrupt_ID'Asm_Input
+ -- ("i", Interrupt));
+ -- end loop;
+ -- end T;
+ --
+ -- begin
+ -- S := intConnect (INUM_TO_IVEC (Interrupt), Handler'Access);
+ --
+ -- loop
+ -- delay 2.0;
+ -- Put_Line ("value of count:" & P.Count'Img);
+ -- end loop;
+ -- end Useint;
+ -------------------------------------
+
+ subtype int is Integer;
+
+ type STATUS is new int;
+ -- Equivalent of the C type STATUS
+
+ OK : constant STATUS := 0;
+ ERROR : constant STATUS := -1;
+
+ type VOIDFUNCPTR is access procedure (parameter : System.Address);
+ type Interrupt_Vector is new System.Address;
+ type Exception_Vector is new System.Address;
+
+ function intConnect
+ (vector : Interrupt_Vector;
+ handler : VOIDFUNCPTR;
+ parameter : System.Address := System.Null_Address) return STATUS;
+ -- Binding to the C routine intConnect. Use this to set up an user handler.
+ -- The routine generates a wrapper around the user handler to save and
+ -- restore context
+
+ function intContext return int;
+ -- Binding to the C routine intContext. This function returns 1 only if the
+ -- current execution state is in interrupt context.
+
+ function intVecGet
+ (Vector : Interrupt_Vector) return VOIDFUNCPTR;
+ -- Binding to the C routine intVecGet. Use this to get the existing handler
+ -- for later restoral
+
+ procedure intVecSet
+ (Vector : Interrupt_Vector;
+ Handler : VOIDFUNCPTR);
+ -- Binding to the C routine intVecSet. Use this to restore a handler
+ -- obtained using intVecGet
+
+ procedure intVecGet2
+ (vector : Interrupt_Vector;
+ pFunction : out VOIDFUNCPTR;
+ pIdtGate : not null access int;
+ pIdtSelector : not null access int);
+ -- Binding to the C routine intVecGet2. Use this to get the existing
+ -- handler for later restoral
+
+ procedure intVecSet2
+ (vector : Interrupt_Vector;
+ pFunction : VOIDFUNCPTR;
+ pIdtGate : not null access int;
+ pIdtSelector : not null access int);
+ -- Binding to the C routine intVecSet2. Use this to restore a
+ -- handler obtained using intVecGet2
+
+ function INUM_TO_IVEC (intNum : int) return Interrupt_Vector;
+ -- Equivalent to the C macro INUM_TO_IVEC used to convert an interrupt
+ -- number to an interrupt vector
+
+ procedure logMsg
+ (fmt : String; arg1, arg2, arg3, arg4, arg5, arg6 : int := 0);
+ -- Binding to the C routine logMsg. Note that it is the caller's
+ -- responsibility to ensure that fmt is a null-terminated string
+ -- (e.g logMsg ("Interrupt" & ASCII.NUL))
+
+ type FP_CONTEXT is private;
+ -- Floating point context save and restore. Handlers using floating point
+ -- must be bracketed with these calls. The pFpContext parameter should be
+ -- an object of type FP_CONTEXT that is declared local to the handler.
+ --
+ -- See the VxWorks Intel Architecture Supplement regarding these routines
+
+ procedure fppRestore (pFpContext : in out FP_CONTEXT);
+ -- Restore floating point context - old style
+
+ procedure fppSave (pFpContext : in out FP_CONTEXT);
+ -- Save floating point context - old style
+
+ procedure fppXrestore (pFpContext : in out FP_CONTEXT);
+ -- Restore floating point context - new style
+
+ procedure fppXsave (pFpContext : in out FP_CONTEXT);
+ -- Save floating point context - new style
+
+private
+
+ type FP_CONTEXT is new System.VxWorks.FP_CONTEXT;
+ -- Target-dependent floating point context type
+
+ pragma Import (C, intConnect, "intConnect");
+ pragma Import (C, intContext, "intContext");
+ pragma Import (C, intVecGet, "intVecGet");
+ pragma Import (C, intVecSet, "intVecSet");
+ pragma Import (C, intVecGet2, "intVecGet2");
+ pragma Import (C, intVecSet2, "intVecSet2");
+ pragma Import (C, INUM_TO_IVEC, "__gnat_inum_to_ivec");
+ pragma Import (C, logMsg, "logMsg");
+ pragma Import (C, fppRestore, "fppRestore");
+ pragma Import (C, fppSave, "fppSave");
+ pragma Import (C, fppXrestore, "fppXrestore");
+ pragma Import (C, fppXsave, "fppXsave");
+end Interfaces.VxWorks;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . A T O M I C _ C O U N T E R S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2011-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package implements Atomic_Counter and Atomic_Unsigned operations
--- for platforms where GCC supports __sync_add_and_fetch_4 and
--- __sync_sub_and_fetch_4 builtins.
-
-package body System.Atomic_Counters is
-
- procedure Sync_Add_And_Fetch
- (Ptr : access Atomic_Unsigned;
- Value : Atomic_Unsigned);
- pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
-
- function Sync_Sub_And_Fetch
- (Ptr : access Atomic_Unsigned;
- Value : Atomic_Unsigned) return Atomic_Unsigned;
- pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4");
-
- ---------------
- -- Decrement --
- ---------------
-
- procedure Decrement (Item : aliased in out Atomic_Unsigned) is
- begin
- if Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0 then
- null;
- end if;
- end Decrement;
-
- function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is
- begin
- return Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0;
- end Decrement;
-
- function Decrement (Item : in out Atomic_Counter) return Boolean is
- begin
- -- Note: the use of Unrestricted_Access here is required because we
- -- are obtaining an access-to-volatile pointer to a non-volatile object.
- -- This is not allowed for [Unchecked_]Access, but is safe in this case
- -- because we know that no aliases are being created.
-
- return Sync_Sub_And_Fetch (Item.Value'Unrestricted_Access, 1) = 0;
- end Decrement;
-
- ---------------
- -- Increment --
- ---------------
-
- procedure Increment (Item : aliased in out Atomic_Unsigned) is
- begin
- Sync_Add_And_Fetch (Item'Unrestricted_Access, 1);
- end Increment;
-
- procedure Increment (Item : in out Atomic_Counter) is
- begin
- -- Note: the use of Unrestricted_Access here is required because we are
- -- obtaining an access-to-volatile pointer to a non-volatile object.
- -- This is not allowed for [Unchecked_]Access, but is safe in this case
- -- because we know that no aliases are being created.
-
- Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1);
- end Increment;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Item : out Atomic_Counter) is
- begin
- Item.Value := 1;
- end Initialize;
-
- ------------
- -- Is_One --
- ------------
-
- function Is_One (Item : Atomic_Counter) return Boolean is
- begin
- return Item.Value = 1;
- end Is_One;
-
-end System.Atomic_Counters;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . A T O M I C _ C O U N T E R S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2011-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This implementation of the package for x86 processor. GCC can't generate
--- code for atomic builtins for 386 CPU. Only increment/decrement instructions
--- are supported, thus this implementaton uses machine code insertions to
--- access the necessary instructions.
-
-with System.Machine_Code;
-
-package body System.Atomic_Counters is
-
- -- Add comments showing in normal asm language what we generate???
-
- ---------------
- -- Decrement --
- ---------------
-
- function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is
- Aux : Boolean;
-
- begin
- System.Machine_Code.Asm
- (Template =>
- "lock%; decl" & ASCII.HT & "%0" & ASCII.LF & ASCII.HT
- & "sete %1",
- Outputs =>
- (Atomic_Unsigned'Asm_Output ("=m", Item),
- Boolean'Asm_Output ("=qm", Aux)),
- Inputs => Atomic_Unsigned'Asm_Input ("m", Item),
- Volatile => True);
-
- return Aux;
- end Decrement;
-
- procedure Decrement (Item : aliased in out Atomic_Unsigned) is
- begin
- if Decrement (Item) then
- null;
- end if;
- end Decrement;
-
- function Decrement (Item : in out Atomic_Counter) return Boolean is
- begin
- return Decrement (Item.Value);
- end Decrement;
-
- ---------------
- -- Increment --
- ---------------
-
- procedure Increment (Item : aliased in out Atomic_Unsigned) is
- begin
- System.Machine_Code.Asm
- (Template => "lock%; incl" & ASCII.HT & "%0",
- Outputs => Atomic_Unsigned'Asm_Output ("=m", Item),
- Inputs => Atomic_Unsigned'Asm_Input ("m", Item),
- Volatile => True);
- end Increment;
-
- procedure Increment (Item : in out Atomic_Counter) is
- begin
- Increment (Item.Value);
- end Increment;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Item : out Atomic_Counter) is
- begin
- Item.Value := 1;
- end Initialize;
-
- ------------
- -- Is_One --
- ------------
-
- function Is_One (Item : Atomic_Counter) return Boolean is
- begin
- return Item.Value = 1;
- end Is_One;
-
-end System.Atomic_Counters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . A T O M I C _ C O U N T E R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package implements Atomic_Counter and Atomic_Unsigned operations
+-- for platforms where GCC supports __sync_add_and_fetch_4 and
+-- __sync_sub_and_fetch_4 builtins.
+
+package body System.Atomic_Counters is
+
+ procedure Sync_Add_And_Fetch
+ (Ptr : access Atomic_Unsigned;
+ Value : Atomic_Unsigned);
+ pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
+
+ function Sync_Sub_And_Fetch
+ (Ptr : access Atomic_Unsigned;
+ Value : Atomic_Unsigned) return Atomic_Unsigned;
+ pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4");
+
+ ---------------
+ -- Decrement --
+ ---------------
+
+ procedure Decrement (Item : aliased in out Atomic_Unsigned) is
+ begin
+ if Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0 then
+ null;
+ end if;
+ end Decrement;
+
+ function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is
+ begin
+ return Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0;
+ end Decrement;
+
+ function Decrement (Item : in out Atomic_Counter) return Boolean is
+ begin
+ -- Note: the use of Unrestricted_Access here is required because we
+ -- are obtaining an access-to-volatile pointer to a non-volatile object.
+ -- This is not allowed for [Unchecked_]Access, but is safe in this case
+ -- because we know that no aliases are being created.
+
+ return Sync_Sub_And_Fetch (Item.Value'Unrestricted_Access, 1) = 0;
+ end Decrement;
+
+ ---------------
+ -- Increment --
+ ---------------
+
+ procedure Increment (Item : aliased in out Atomic_Unsigned) is
+ begin
+ Sync_Add_And_Fetch (Item'Unrestricted_Access, 1);
+ end Increment;
+
+ procedure Increment (Item : in out Atomic_Counter) is
+ begin
+ -- Note: the use of Unrestricted_Access here is required because we are
+ -- obtaining an access-to-volatile pointer to a non-volatile object.
+ -- This is not allowed for [Unchecked_]Access, but is safe in this case
+ -- because we know that no aliases are being created.
+
+ Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1);
+ end Increment;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Item : out Atomic_Counter) is
+ begin
+ Item.Value := 1;
+ end Initialize;
+
+ ------------
+ -- Is_One --
+ ------------
+
+ function Is_One (Item : Atomic_Counter) return Boolean is
+ begin
+ return Item.Value = 1;
+ end Is_One;
+
+end System.Atomic_Counters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . A T O M I C _ C O U N T E R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This implementation of the package for x86 processor. GCC can't generate
+-- code for atomic builtins for 386 CPU. Only increment/decrement instructions
+-- are supported, thus this implementaton uses machine code insertions to
+-- access the necessary instructions.
+
+with System.Machine_Code;
+
+package body System.Atomic_Counters is
+
+ -- Add comments showing in normal asm language what we generate???
+
+ ---------------
+ -- Decrement --
+ ---------------
+
+ function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is
+ Aux : Boolean;
+
+ begin
+ System.Machine_Code.Asm
+ (Template =>
+ "lock%; decl" & ASCII.HT & "%0" & ASCII.LF & ASCII.HT
+ & "sete %1",
+ Outputs =>
+ (Atomic_Unsigned'Asm_Output ("=m", Item),
+ Boolean'Asm_Output ("=qm", Aux)),
+ Inputs => Atomic_Unsigned'Asm_Input ("m", Item),
+ Volatile => True);
+
+ return Aux;
+ end Decrement;
+
+ procedure Decrement (Item : aliased in out Atomic_Unsigned) is
+ begin
+ if Decrement (Item) then
+ null;
+ end if;
+ end Decrement;
+
+ function Decrement (Item : in out Atomic_Counter) return Boolean is
+ begin
+ return Decrement (Item.Value);
+ end Decrement;
+
+ ---------------
+ -- Increment --
+ ---------------
+
+ procedure Increment (Item : aliased in out Atomic_Unsigned) is
+ begin
+ System.Machine_Code.Asm
+ (Template => "lock%; incl" & ASCII.HT & "%0",
+ Outputs => Atomic_Unsigned'Asm_Output ("=m", Item),
+ Inputs => Atomic_Unsigned'Asm_Input ("m", Item),
+ Volatile => True);
+ end Increment;
+
+ procedure Increment (Item : in out Atomic_Counter) is
+ begin
+ Increment (Item.Value);
+ end Increment;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Item : out Atomic_Counter) is
+ begin
+ Item.Value := 1;
+ end Initialize;
+
+ ------------
+ -- Is_One --
+ ------------
+
+ function Is_One (Item : Atomic_Counter) return Boolean is
+ begin
+ return Item.Value = 1;
+ end Is_One;
+
+end System.Atomic_Counters;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . E X C E P T I O N S . M A C H I N E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2013-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-package body System.Exceptions.Machine is
- function New_Occurrence return GNAT_GCC_Exception_Access is
- Res : GNAT_GCC_Exception_Access;
- begin
- Res := new GNAT_GCC_Exception;
- Res.Header.Class := GNAT_Exception_Class;
- Res.Header.Unwinder_Cache. Reserved1 := 0;
- return Res;
- end New_Occurrence;
-
-end System.Exceptions.Machine;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . E X C E P T I O N S . M A C H I N E --
--- --
--- S p e c --
--- --
--- Copyright (C) 2013-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
--- Declaration of the machine exception and some associated facilities. The
--- machine exception is the object that is propagated by low level routines
--- and that contains the Ada exception occurrence.
-
--- This is the version using the ARM EHABI mechanism
-
-with Ada.Unchecked_Conversion;
-with Ada.Exceptions;
-
-package System.Exceptions.Machine is
- pragma Preelaborate;
-
- ------------------------------------------------
- -- Entities to interface with the GCC runtime --
- ------------------------------------------------
-
- -- Return codes from GCC runtime functions used to propagate an exception
-
- type Unwind_Reason_Code is
- (URC_OK,
- URC_FOREIGN_EXCEPTION_CAUGHT,
- URC_Unused2,
- URC_Unused3,
- URC_Unused4,
- URC_Unused5,
- URC_HANDLER_FOUND,
- URC_INSTALL_CONTEXT,
- URC_CONTINUE_UNWIND,
- URC_FAILURE);
-
- pragma Unreferenced
- (URC_OK,
- URC_FOREIGN_EXCEPTION_CAUGHT,
- URC_Unused2,
- URC_Unused3,
- URC_Unused4,
- URC_Unused5,
- URC_HANDLER_FOUND,
- URC_INSTALL_CONTEXT,
- URC_CONTINUE_UNWIND,
- URC_FAILURE);
-
- pragma Convention (C, Unwind_Reason_Code);
- subtype Unwind_Action is Unwind_Reason_Code;
- -- Phase identifiers
-
- type uint32_t is mod 2**32;
- pragma Convention (C, uint32_t);
-
- type uint32_t_array is array (Natural range <>) of uint32_t;
- pragma Convention (C, uint32_t_array);
-
- type Unwind_State is new uint32_t;
- pragma Convention (C, Unwind_State);
-
- US_VIRTUAL_UNWIND_FRAME : constant Unwind_State := 0;
- US_UNWIND_FRAME_STARTING : constant Unwind_State := 1;
- US_UNWIND_FRAME_RESUME : constant Unwind_State := 2;
-
- pragma Unreferenced
- (US_VIRTUAL_UNWIND_FRAME,
- US_UNWIND_FRAME_STARTING,
- US_UNWIND_FRAME_RESUME);
-
- -- Mandatory common header for any exception object handled by the
- -- GCC unwinding runtime.
-
- type Exception_Class is array (0 .. 7) of Character;
-
- GNAT_Exception_Class : constant Exception_Class := "GNU-Ada" & ASCII.NUL;
- -- "GNU-Ada\0"
-
- type Unwinder_Cache_Type is record
- Reserved1 : uint32_t;
- Reserved2 : uint32_t;
- Reserved3 : uint32_t;
- Reserved4 : uint32_t;
- Reserved5 : uint32_t;
- end record;
-
- type Barrier_Cache_Type is record
- Sp : uint32_t;
- Bitpattern : uint32_t_array (0 .. 4);
- end record;
-
- type Cleanup_Cache_Type is record
- Bitpattern : uint32_t_array (0 .. 3);
- end record;
-
- type Pr_Cache_Type is record
- Fnstart : uint32_t;
- Ehtp : System.Address;
- Additional : uint32_t;
- Reserved1 : uint32_t;
- end record;
-
- type Unwind_Control_Block is record
- Class : Exception_Class;
- Cleanup : System.Address;
-
- -- Caches
- Unwinder_Cache : Unwinder_Cache_Type;
- Barrier_Cache : Barrier_Cache_Type;
- Cleanup_Cache : Cleanup_Cache_Type;
- Pr_Cache : Pr_Cache_Type;
- end record;
- pragma Convention (C, Unwind_Control_Block);
- for Unwind_Control_Block'Alignment use 8;
- -- Map the GCC struct used for exception handling
-
- type Unwind_Control_Block_Access is access all Unwind_Control_Block;
- subtype GCC_Exception_Access is Unwind_Control_Block_Access;
- -- Pointer to a UCB
-
- procedure Unwind_DeleteException
- (Ucbp : not null Unwind_Control_Block_Access);
- pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
- -- Procedure to free any GCC exception
-
- --------------------------------------------------------------
- -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
- --------------------------------------------------------------
-
- -- A GNAT exception object to be dealt with by the personality routine
- -- called by the GCC unwinding runtime.
-
- type GNAT_GCC_Exception is record
- Header : Unwind_Control_Block;
- -- ABI Exception header first
-
- Occurrence : aliased Ada.Exceptions.Exception_Occurrence;
- -- The Ada occurrence
- end record;
-
- pragma Convention (C, GNAT_GCC_Exception);
-
- type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
-
- function To_GCC_Exception is new
- Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access);
-
- function To_GNAT_GCC_Exception is new
- Ada.Unchecked_Conversion
- (GCC_Exception_Access, GNAT_GCC_Exception_Access);
-
- function New_Occurrence return GNAT_GCC_Exception_Access;
- -- Allocate and initialize a machine occurrence
-
-end System.Exceptions.Machine;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . E X C E P T I O N S . M A C H I N E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2013-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-package body System.Exceptions.Machine is
- function New_Occurrence return GNAT_GCC_Exception_Access is
- Res : GNAT_GCC_Exception_Access;
- begin
- Res := new GNAT_GCC_Exception;
- Res.Header := (Class => GNAT_Exception_Class,
- Cleanup => Null_Address,
- others => 0);
- return Res;
- end New_Occurrence;
-
-end System.Exceptions.Machine;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . E X C E P T I O N S . M A C H I N E --
--- --
--- S p e c --
--- --
--- Copyright (C) 2013-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
--- Declaration of the machine exception and some associated facilities. The
--- machine exception is the object that is propagated by low level routines
--- and that contains the Ada exception occurrence.
-
--- This is the version using the GCC EH mechanism
-
-with Ada.Unchecked_Conversion;
-with Ada.Exceptions;
-
-package System.Exceptions.Machine is
- pragma Preelaborate;
-
- ------------------------------------------------
- -- Entities to interface with the GCC runtime --
- ------------------------------------------------
-
- -- These come from "C++ ABI for Itanium: Exception handling", which is
- -- the reference for GCC.
-
- -- Return codes from the GCC runtime functions used to propagate
- -- an exception.
-
- type Unwind_Reason_Code is
- (URC_NO_REASON,
- URC_FOREIGN_EXCEPTION_CAUGHT,
- URC_PHASE2_ERROR,
- URC_PHASE1_ERROR,
- URC_NORMAL_STOP,
- URC_END_OF_STACK,
- URC_HANDLER_FOUND,
- URC_INSTALL_CONTEXT,
- URC_CONTINUE_UNWIND);
-
- pragma Unreferenced
- (URC_NO_REASON,
- URC_FOREIGN_EXCEPTION_CAUGHT,
- URC_PHASE2_ERROR,
- URC_PHASE1_ERROR,
- URC_NORMAL_STOP,
- URC_END_OF_STACK,
- URC_HANDLER_FOUND,
- URC_INSTALL_CONTEXT,
- URC_CONTINUE_UNWIND);
-
- pragma Convention (C, Unwind_Reason_Code);
-
- -- Phase identifiers
-
- type Unwind_Action is new Integer;
- pragma Convention (C, Unwind_Action);
-
- UA_SEARCH_PHASE : constant Unwind_Action := 1;
- UA_CLEANUP_PHASE : constant Unwind_Action := 2;
- UA_HANDLER_FRAME : constant Unwind_Action := 4;
- UA_FORCE_UNWIND : constant Unwind_Action := 8;
- UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension
-
- pragma Unreferenced
- (UA_SEARCH_PHASE,
- UA_CLEANUP_PHASE,
- UA_HANDLER_FRAME,
- UA_FORCE_UNWIND,
- UA_END_OF_STACK);
-
- -- Mandatory common header for any exception object handled by the
- -- GCC unwinding runtime.
-
- type Exception_Class is mod 2 ** 64;
-
- GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
- -- "GNU-Ada\0"
-
- type Unwind_Word is mod 2 ** System.Word_Size;
- for Unwind_Word'Size use System.Word_Size;
- -- Map the corresponding C type used in Unwind_Exception below
-
- type Unwind_Exception is record
- Class : Exception_Class;
- Cleanup : System.Address;
- Private1 : Unwind_Word;
- Private2 : Unwind_Word;
-
- -- Usual exception structure has only two private fields, but the SEH
- -- one has six. To avoid making this file more complex, we use six
- -- fields on all platforms, wasting a few bytes on some.
-
- Private3 : Unwind_Word;
- Private4 : Unwind_Word;
- Private5 : Unwind_Word;
- Private6 : Unwind_Word;
- end record;
- pragma Convention (C, Unwind_Exception);
- -- Map the GCC struct used for exception handling
-
- for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
- -- The C++ ABI mandates the common exception header to be at least
- -- doubleword aligned, and the libGCC implementation actually makes it
- -- maximally aligned (see unwind.h). See additional comments on the
- -- alignment below.
-
- -- There is a subtle issue with the common header alignment, since the C
- -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
- -- Standard'Maximum_Alignment, and those two values don't quite represent
- -- the same concepts and so may be decoupled someday. One typical reason
- -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system
- -- allocator guarantees, and there are extra costs involved in allocating
- -- objects aligned to such factors.
-
- -- To deal with the potential alignment differences between the C and Ada
- -- representations, the Ada part of the whole structure is only accessed
- -- by the personality routine through accessors. Ada specific fields are
- -- thus always accessed through consistent layout, and we expect the
- -- actual alignment to always be large enough to avoid traps from the C
- -- accesses to the common header. Besides, accessors alleviate the need
- -- for a C struct whole counterpart, both painful and error-prone to
- -- maintain anyway.
-
- type GCC_Exception_Access is access all Unwind_Exception;
- -- Pointer to a GCC exception
-
- procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
- pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
- -- Procedure to free any GCC exception
-
- --------------------------------------------------------------
- -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
- --------------------------------------------------------------
-
- -- A GNAT exception object to be dealt with by the personality routine
- -- called by the GCC unwinding runtime.
-
- type GNAT_GCC_Exception is record
- Header : Unwind_Exception;
- -- ABI Exception header first
-
- Occurrence : aliased Ada.Exceptions.Exception_Occurrence;
- -- The Ada occurrence
- end record;
-
- pragma Convention (C, GNAT_GCC_Exception);
-
- type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
-
- function To_GCC_Exception is new
- Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access);
-
- function To_GNAT_GCC_Exception is new
- Ada.Unchecked_Conversion
- (GCC_Exception_Access, GNAT_GCC_Exception_Access);
-
- function New_Occurrence return GNAT_GCC_Exception_Access;
- -- Allocate and initialize a machine occurrence
-
-end System.Exceptions.Machine;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . E X C E P T I O N S . M A C H I N E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2013-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Exceptions.Machine is
+ function New_Occurrence return GNAT_GCC_Exception_Access is
+ Res : GNAT_GCC_Exception_Access;
+ begin
+ Res := new GNAT_GCC_Exception;
+ Res.Header.Class := GNAT_Exception_Class;
+ Res.Header.Unwinder_Cache. Reserved1 := 0;
+ return Res;
+ end New_Occurrence;
+
+end System.Exceptions.Machine;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . E X C E P T I O N S . M A C H I N E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2013-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Declaration of the machine exception and some associated facilities. The
+-- machine exception is the object that is propagated by low level routines
+-- and that contains the Ada exception occurrence.
+
+-- This is the version using the ARM EHABI mechanism
+
+with Ada.Unchecked_Conversion;
+with Ada.Exceptions;
+
+package System.Exceptions.Machine is
+ pragma Preelaborate;
+
+ ------------------------------------------------
+ -- Entities to interface with the GCC runtime --
+ ------------------------------------------------
+
+ -- Return codes from GCC runtime functions used to propagate an exception
+
+ type Unwind_Reason_Code is
+ (URC_OK,
+ URC_FOREIGN_EXCEPTION_CAUGHT,
+ URC_Unused2,
+ URC_Unused3,
+ URC_Unused4,
+ URC_Unused5,
+ URC_HANDLER_FOUND,
+ URC_INSTALL_CONTEXT,
+ URC_CONTINUE_UNWIND,
+ URC_FAILURE);
+
+ pragma Unreferenced
+ (URC_OK,
+ URC_FOREIGN_EXCEPTION_CAUGHT,
+ URC_Unused2,
+ URC_Unused3,
+ URC_Unused4,
+ URC_Unused5,
+ URC_HANDLER_FOUND,
+ URC_INSTALL_CONTEXT,
+ URC_CONTINUE_UNWIND,
+ URC_FAILURE);
+
+ pragma Convention (C, Unwind_Reason_Code);
+ subtype Unwind_Action is Unwind_Reason_Code;
+ -- Phase identifiers
+
+ type uint32_t is mod 2**32;
+ pragma Convention (C, uint32_t);
+
+ type uint32_t_array is array (Natural range <>) of uint32_t;
+ pragma Convention (C, uint32_t_array);
+
+ type Unwind_State is new uint32_t;
+ pragma Convention (C, Unwind_State);
+
+ US_VIRTUAL_UNWIND_FRAME : constant Unwind_State := 0;
+ US_UNWIND_FRAME_STARTING : constant Unwind_State := 1;
+ US_UNWIND_FRAME_RESUME : constant Unwind_State := 2;
+
+ pragma Unreferenced
+ (US_VIRTUAL_UNWIND_FRAME,
+ US_UNWIND_FRAME_STARTING,
+ US_UNWIND_FRAME_RESUME);
+
+ -- Mandatory common header for any exception object handled by the
+ -- GCC unwinding runtime.
+
+ type Exception_Class is array (0 .. 7) of Character;
+
+ GNAT_Exception_Class : constant Exception_Class := "GNU-Ada" & ASCII.NUL;
+ -- "GNU-Ada\0"
+
+ type Unwinder_Cache_Type is record
+ Reserved1 : uint32_t;
+ Reserved2 : uint32_t;
+ Reserved3 : uint32_t;
+ Reserved4 : uint32_t;
+ Reserved5 : uint32_t;
+ end record;
+
+ type Barrier_Cache_Type is record
+ Sp : uint32_t;
+ Bitpattern : uint32_t_array (0 .. 4);
+ end record;
+
+ type Cleanup_Cache_Type is record
+ Bitpattern : uint32_t_array (0 .. 3);
+ end record;
+
+ type Pr_Cache_Type is record
+ Fnstart : uint32_t;
+ Ehtp : System.Address;
+ Additional : uint32_t;
+ Reserved1 : uint32_t;
+ end record;
+
+ type Unwind_Control_Block is record
+ Class : Exception_Class;
+ Cleanup : System.Address;
+
+ -- Caches
+ Unwinder_Cache : Unwinder_Cache_Type;
+ Barrier_Cache : Barrier_Cache_Type;
+ Cleanup_Cache : Cleanup_Cache_Type;
+ Pr_Cache : Pr_Cache_Type;
+ end record;
+ pragma Convention (C, Unwind_Control_Block);
+ for Unwind_Control_Block'Alignment use 8;
+ -- Map the GCC struct used for exception handling
+
+ type Unwind_Control_Block_Access is access all Unwind_Control_Block;
+ subtype GCC_Exception_Access is Unwind_Control_Block_Access;
+ -- Pointer to a UCB
+
+ procedure Unwind_DeleteException
+ (Ucbp : not null Unwind_Control_Block_Access);
+ pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
+ -- Procedure to free any GCC exception
+
+ --------------------------------------------------------------
+ -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
+ --------------------------------------------------------------
+
+ -- A GNAT exception object to be dealt with by the personality routine
+ -- called by the GCC unwinding runtime.
+
+ type GNAT_GCC_Exception is record
+ Header : Unwind_Control_Block;
+ -- ABI Exception header first
+
+ Occurrence : aliased Ada.Exceptions.Exception_Occurrence;
+ -- The Ada occurrence
+ end record;
+
+ pragma Convention (C, GNAT_GCC_Exception);
+
+ type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
+
+ function To_GCC_Exception is new
+ Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access);
+
+ function To_GNAT_GCC_Exception is new
+ Ada.Unchecked_Conversion
+ (GCC_Exception_Access, GNAT_GCC_Exception_Access);
+
+ function New_Occurrence return GNAT_GCC_Exception_Access;
+ -- Allocate and initialize a machine occurrence
+
+end System.Exceptions.Machine;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . E X C E P T I O N S . M A C H I N E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2013-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Exceptions.Machine is
+ function New_Occurrence return GNAT_GCC_Exception_Access is
+ Res : GNAT_GCC_Exception_Access;
+ begin
+ Res := new GNAT_GCC_Exception;
+ Res.Header := (Class => GNAT_Exception_Class,
+ Cleanup => Null_Address,
+ others => 0);
+ return Res;
+ end New_Occurrence;
+
+end System.Exceptions.Machine;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . E X C E P T I O N S . M A C H I N E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2013-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Declaration of the machine exception and some associated facilities. The
+-- machine exception is the object that is propagated by low level routines
+-- and that contains the Ada exception occurrence.
+
+-- This is the version using the GCC EH mechanism
+
+with Ada.Unchecked_Conversion;
+with Ada.Exceptions;
+
+package System.Exceptions.Machine is
+ pragma Preelaborate;
+
+ ------------------------------------------------
+ -- Entities to interface with the GCC runtime --
+ ------------------------------------------------
+
+ -- These come from "C++ ABI for Itanium: Exception handling", which is
+ -- the reference for GCC.
+
+ -- Return codes from the GCC runtime functions used to propagate
+ -- an exception.
+
+ type Unwind_Reason_Code is
+ (URC_NO_REASON,
+ URC_FOREIGN_EXCEPTION_CAUGHT,
+ URC_PHASE2_ERROR,
+ URC_PHASE1_ERROR,
+ URC_NORMAL_STOP,
+ URC_END_OF_STACK,
+ URC_HANDLER_FOUND,
+ URC_INSTALL_CONTEXT,
+ URC_CONTINUE_UNWIND);
+
+ pragma Unreferenced
+ (URC_NO_REASON,
+ URC_FOREIGN_EXCEPTION_CAUGHT,
+ URC_PHASE2_ERROR,
+ URC_PHASE1_ERROR,
+ URC_NORMAL_STOP,
+ URC_END_OF_STACK,
+ URC_HANDLER_FOUND,
+ URC_INSTALL_CONTEXT,
+ URC_CONTINUE_UNWIND);
+
+ pragma Convention (C, Unwind_Reason_Code);
+
+ -- Phase identifiers
+
+ type Unwind_Action is new Integer;
+ pragma Convention (C, Unwind_Action);
+
+ UA_SEARCH_PHASE : constant Unwind_Action := 1;
+ UA_CLEANUP_PHASE : constant Unwind_Action := 2;
+ UA_HANDLER_FRAME : constant Unwind_Action := 4;
+ UA_FORCE_UNWIND : constant Unwind_Action := 8;
+ UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension
+
+ pragma Unreferenced
+ (UA_SEARCH_PHASE,
+ UA_CLEANUP_PHASE,
+ UA_HANDLER_FRAME,
+ UA_FORCE_UNWIND,
+ UA_END_OF_STACK);
+
+ -- Mandatory common header for any exception object handled by the
+ -- GCC unwinding runtime.
+
+ type Exception_Class is mod 2 ** 64;
+
+ GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
+ -- "GNU-Ada\0"
+
+ type Unwind_Word is mod 2 ** System.Word_Size;
+ for Unwind_Word'Size use System.Word_Size;
+ -- Map the corresponding C type used in Unwind_Exception below
+
+ type Unwind_Exception is record
+ Class : Exception_Class;
+ Cleanup : System.Address;
+ Private1 : Unwind_Word;
+ Private2 : Unwind_Word;
+
+ -- Usual exception structure has only two private fields, but the SEH
+ -- one has six. To avoid making this file more complex, we use six
+ -- fields on all platforms, wasting a few bytes on some.
+
+ Private3 : Unwind_Word;
+ Private4 : Unwind_Word;
+ Private5 : Unwind_Word;
+ Private6 : Unwind_Word;
+ end record;
+ pragma Convention (C, Unwind_Exception);
+ -- Map the GCC struct used for exception handling
+
+ for Unwind_Exception'Alignment use Standard'Maximum_Alignment;
+ -- The C++ ABI mandates the common exception header to be at least
+ -- doubleword aligned, and the libGCC implementation actually makes it
+ -- maximally aligned (see unwind.h). See additional comments on the
+ -- alignment below.
+
+ -- There is a subtle issue with the common header alignment, since the C
+ -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on
+ -- Standard'Maximum_Alignment, and those two values don't quite represent
+ -- the same concepts and so may be decoupled someday. One typical reason
+ -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system
+ -- allocator guarantees, and there are extra costs involved in allocating
+ -- objects aligned to such factors.
+
+ -- To deal with the potential alignment differences between the C and Ada
+ -- representations, the Ada part of the whole structure is only accessed
+ -- by the personality routine through accessors. Ada specific fields are
+ -- thus always accessed through consistent layout, and we expect the
+ -- actual alignment to always be large enough to avoid traps from the C
+ -- accesses to the common header. Besides, accessors alleviate the need
+ -- for a C struct whole counterpart, both painful and error-prone to
+ -- maintain anyway.
+
+ type GCC_Exception_Access is access all Unwind_Exception;
+ -- Pointer to a GCC exception
+
+ procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
+ pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");
+ -- Procedure to free any GCC exception
+
+ --------------------------------------------------------------
+ -- GNAT Specific Entities To Deal With The GCC EH Circuitry --
+ --------------------------------------------------------------
+
+ -- A GNAT exception object to be dealt with by the personality routine
+ -- called by the GCC unwinding runtime.
+
+ type GNAT_GCC_Exception is record
+ Header : Unwind_Exception;
+ -- ABI Exception header first
+
+ Occurrence : aliased Ada.Exceptions.Exception_Occurrence;
+ -- The Ada occurrence
+ end record;
+
+ pragma Convention (C, GNAT_GCC_Exception);
+
+ type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
+
+ function To_GCC_Exception is new
+ Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access);
+
+ function To_GNAT_GCC_Exception is new
+ Ada.Unchecked_Conversion
+ (GCC_Exception_Access, GNAT_GCC_Exception_Access);
+
+ function New_Occurrence return GNAT_GCC_Exception_Access;
+ -- Allocate and initialize a machine occurrence
+
+end System.Exceptions.Machine;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . F L O A T _ C O N T R O L --
--- --
--- B o d y --
--- --
--- Copyright (C) 2011-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This implementation does nothing and can be used when the floating point
--- unit is fully under control.
-
-package body System.Float_Control is
-
- -----------
- -- Reset --
- -----------
-
- procedure Reset is
- begin
- null;
- end Reset;
-
-end System.Float_Control;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . F L O A T _ C O N T R O L --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2011-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This implementation does nothing and can be used when the floating point
+-- unit is fully under control.
+
+package body System.Float_Control is
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset is
+ begin
+ null;
+ end Reset;
+
+end System.Float_Control;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . G L O B A L _ L O C K S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1999-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This implementation is specific to NT
-
-with System.OS_Interface;
-with System.Task_Lock;
-with System.Win32;
-
-with Interfaces.C.Strings;
-
-package body System.Global_Locks is
-
- package TSL renames System.Task_Lock;
- package OSI renames System.OS_Interface;
- package ICS renames Interfaces.C.Strings;
-
- subtype Lock_File_Entry is Win32.HANDLE;
-
- Last_Lock : Lock_Type := Null_Lock;
- Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry;
-
- -----------------
- -- Create_Lock --
- -----------------
-
- procedure Create_Lock (Lock : out Lock_Type; Name : String) is
- L : Lock_Type;
-
- begin
- TSL.Lock;
- Last_Lock := Last_Lock + 1;
- L := Last_Lock;
- TSL.Unlock;
-
- if L > Lock_Table'Last then
- raise Lock_Error;
- end if;
-
- Lock_Table (L) :=
- OSI.CreateMutex (null, Win32.FALSE, ICS.New_String (Name));
- Lock := L;
- end Create_Lock;
-
- ------------------
- -- Acquire_Lock --
- ------------------
-
- procedure Acquire_Lock (Lock : in out Lock_Type) is
- use type Win32.DWORD;
-
- Res : Win32.DWORD;
-
- begin
- Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite);
-
- if Res = OSI.WAIT_FAILED then
- raise Lock_Error;
- end if;
- end Acquire_Lock;
-
- ------------------
- -- Release_Lock --
- ------------------
-
- procedure Release_Lock (Lock : in out Lock_Type) is
- use type Win32.BOOL;
-
- Res : Win32.BOOL;
-
- begin
- Res := OSI.ReleaseMutex (Lock_Table (Lock));
-
- if Res = Win32.FALSE then
- raise Lock_Error;
- end if;
- end Release_Lock;
-
-end System.Global_Locks;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . G L O B A L _ L O C K S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This implementation is specific to NT
+
+with System.OS_Interface;
+with System.Task_Lock;
+with System.Win32;
+
+with Interfaces.C.Strings;
+
+package body System.Global_Locks is
+
+ package TSL renames System.Task_Lock;
+ package OSI renames System.OS_Interface;
+ package ICS renames Interfaces.C.Strings;
+
+ subtype Lock_File_Entry is Win32.HANDLE;
+
+ Last_Lock : Lock_Type := Null_Lock;
+ Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry;
+
+ -----------------
+ -- Create_Lock --
+ -----------------
+
+ procedure Create_Lock (Lock : out Lock_Type; Name : String) is
+ L : Lock_Type;
+
+ begin
+ TSL.Lock;
+ Last_Lock := Last_Lock + 1;
+ L := Last_Lock;
+ TSL.Unlock;
+
+ if L > Lock_Table'Last then
+ raise Lock_Error;
+ end if;
+
+ Lock_Table (L) :=
+ OSI.CreateMutex (null, Win32.FALSE, ICS.New_String (Name));
+ Lock := L;
+ end Create_Lock;
+
+ ------------------
+ -- Acquire_Lock --
+ ------------------
+
+ procedure Acquire_Lock (Lock : in out Lock_Type) is
+ use type Win32.DWORD;
+
+ Res : Win32.DWORD;
+
+ begin
+ Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite);
+
+ if Res = OSI.WAIT_FAILED then
+ raise Lock_Error;
+ end if;
+ end Acquire_Lock;
+
+ ------------------
+ -- Release_Lock --
+ ------------------
+
+ procedure Release_Lock (Lock : in out Lock_Type) is
+ use type Win32.BOOL;
+
+ Res : Win32.BOOL;
+
+ begin
+ Res := OSI.ReleaseMutex (Lock_Table (Lock));
+
+ if Res = Win32.FALSE then
+ raise Lock_Error;
+ end if;
+ end Release_Lock;
+
+end System.Global_Locks;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . M E M O R Y --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version provides ways to limit the amount of used memory for systems
--- that do not have OS support for that.
-
--- The amount of available memory available for dynamic allocation is limited
--- by setting the environment variable GNAT_MEMORY_LIMIT to the number of
--- kilobytes that can be used.
---
--- Windows is currently using this version.
-
-with Ada.Exceptions;
-with System.Soft_Links;
-
-package body System.Memory is
-
- use Ada.Exceptions;
- use System.Soft_Links;
-
- function c_malloc (Size : size_t) return System.Address;
- pragma Import (C, c_malloc, "malloc");
-
- procedure c_free (Ptr : System.Address);
- pragma Import (C, c_free, "free");
-
- function c_realloc
- (Ptr : System.Address; Size : size_t) return System.Address;
- pragma Import (C, c_realloc, "realloc");
-
- function msize (Ptr : System.Address) return size_t;
- pragma Import (C, msize, "_msize");
-
- function getenv (Str : String) return System.Address;
- pragma Import (C, getenv);
-
- function atoi (Str : System.Address) return Integer;
- pragma Import (C, atoi);
-
- Available_Memory : size_t := 0;
- -- Amount of memory that is available for heap allocations.
- -- A value of 0 means that the amount is not yet initialized.
-
- Msize_Accuracy : constant := 4096;
- -- Defines the amount of memory to add to requested allocation sizes,
- -- because malloc may return a bigger block than requested. As msize
- -- is used when by Free, it must be used on allocation as well. To
- -- prevent underflow of available_memory we need to use a reserve.
-
- procedure Check_Available_Memory (Size : size_t);
- -- This routine must be called while holding the task lock. When the
- -- memory limit is not yet initialized, it will be set to the value of
- -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that
- -- does not exist. If the size is larger than the amount of available
- -- memory, the task lock will be freed and a storage_error exception
- -- will be raised.
-
- -----------
- -- Alloc --
- -----------
-
- function Alloc (Size : size_t) return System.Address is
- Result : System.Address;
- Actual_Size : size_t := Size;
-
- begin
- if Size = size_t'Last then
- Raise_Exception (Storage_Error'Identity, "object too large");
- end if;
-
- -- Change size from zero to non-zero. We still want a proper pointer
- -- for the zero case because pointers to zero length objects have to
- -- be distinct, but we can't just go ahead and allocate zero bytes,
- -- since some malloc's return zero for a zero argument.
-
- if Size = 0 then
- Actual_Size := 1;
- end if;
-
- Lock_Task.all;
-
- if Actual_Size + Msize_Accuracy >= Available_Memory then
- Check_Available_Memory (Size + Msize_Accuracy);
- end if;
-
- Result := c_malloc (Actual_Size);
-
- if Result /= System.Null_Address then
- Available_Memory := Available_Memory - msize (Result);
- end if;
-
- Unlock_Task.all;
-
- if Result = System.Null_Address then
- Raise_Exception (Storage_Error'Identity, "heap exhausted");
- end if;
-
- return Result;
- end Alloc;
-
- ----------------------------
- -- Check_Available_Memory --
- ----------------------------
-
- procedure Check_Available_Memory (Size : size_t) is
- Gnat_Memory_Limit : System.Address;
-
- begin
- if Available_Memory = 0 then
-
- -- The amount of available memory hasn't been initialized yet
-
- Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL);
-
- if Gnat_Memory_Limit /= System.Null_Address then
- Available_Memory :=
- size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy;
- else
- Available_Memory := size_t'Last;
- end if;
- end if;
-
- if Size >= Available_Memory then
-
- -- There is a memory overflow
-
- Unlock_Task.all;
- Raise_Exception
- (Storage_Error'Identity, "heap memory limit exceeded");
- end if;
- end Check_Available_Memory;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Ptr : System.Address) is
- begin
- Lock_Task.all;
-
- if Ptr /= System.Null_Address then
- Available_Memory := Available_Memory + msize (Ptr);
- end if;
-
- c_free (Ptr);
-
- Unlock_Task.all;
- end Free;
-
- -------------
- -- Realloc --
- -------------
-
- function Realloc
- (Ptr : System.Address;
- Size : size_t)
- return System.Address
- is
- Result : System.Address;
- Actual_Size : constant size_t := Size;
- Old_Size : size_t;
-
- begin
- if Size = size_t'Last then
- Raise_Exception (Storage_Error'Identity, "object too large");
- end if;
-
- Lock_Task.all;
-
- Old_Size := msize (Ptr);
-
- -- Conservative check - no need to try to be precise here
-
- if Size + Msize_Accuracy >= Available_Memory then
- Check_Available_Memory (Size + Msize_Accuracy);
- end if;
-
- Result := c_realloc (Ptr, Actual_Size);
-
- if Result /= System.Null_Address then
- Available_Memory := Available_Memory + Old_Size - msize (Result);
- end if;
-
- Unlock_Task.all;
-
- if Result = System.Null_Address then
- Raise_Exception (Storage_Error'Identity, "heap exhausted");
- end if;
-
- return Result;
- end Realloc;
-
-end System.Memory;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M E M O R Y --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version provides ways to limit the amount of used memory for systems
+-- that do not have OS support for that.
+
+-- The amount of available memory available for dynamic allocation is limited
+-- by setting the environment variable GNAT_MEMORY_LIMIT to the number of
+-- kilobytes that can be used.
+--
+-- Windows is currently using this version.
+
+with Ada.Exceptions;
+with System.Soft_Links;
+
+package body System.Memory is
+
+ use Ada.Exceptions;
+ use System.Soft_Links;
+
+ function c_malloc (Size : size_t) return System.Address;
+ pragma Import (C, c_malloc, "malloc");
+
+ procedure c_free (Ptr : System.Address);
+ pragma Import (C, c_free, "free");
+
+ function c_realloc
+ (Ptr : System.Address; Size : size_t) return System.Address;
+ pragma Import (C, c_realloc, "realloc");
+
+ function msize (Ptr : System.Address) return size_t;
+ pragma Import (C, msize, "_msize");
+
+ function getenv (Str : String) return System.Address;
+ pragma Import (C, getenv);
+
+ function atoi (Str : System.Address) return Integer;
+ pragma Import (C, atoi);
+
+ Available_Memory : size_t := 0;
+ -- Amount of memory that is available for heap allocations.
+ -- A value of 0 means that the amount is not yet initialized.
+
+ Msize_Accuracy : constant := 4096;
+ -- Defines the amount of memory to add to requested allocation sizes,
+ -- because malloc may return a bigger block than requested. As msize
+ -- is used when by Free, it must be used on allocation as well. To
+ -- prevent underflow of available_memory we need to use a reserve.
+
+ procedure Check_Available_Memory (Size : size_t);
+ -- This routine must be called while holding the task lock. When the
+ -- memory limit is not yet initialized, it will be set to the value of
+ -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that
+ -- does not exist. If the size is larger than the amount of available
+ -- memory, the task lock will be freed and a storage_error exception
+ -- will be raised.
+
+ -----------
+ -- Alloc --
+ -----------
+
+ function Alloc (Size : size_t) return System.Address is
+ Result : System.Address;
+ Actual_Size : size_t := Size;
+
+ begin
+ if Size = size_t'Last then
+ Raise_Exception (Storage_Error'Identity, "object too large");
+ end if;
+
+ -- Change size from zero to non-zero. We still want a proper pointer
+ -- for the zero case because pointers to zero length objects have to
+ -- be distinct, but we can't just go ahead and allocate zero bytes,
+ -- since some malloc's return zero for a zero argument.
+
+ if Size = 0 then
+ Actual_Size := 1;
+ end if;
+
+ Lock_Task.all;
+
+ if Actual_Size + Msize_Accuracy >= Available_Memory then
+ Check_Available_Memory (Size + Msize_Accuracy);
+ end if;
+
+ Result := c_malloc (Actual_Size);
+
+ if Result /= System.Null_Address then
+ Available_Memory := Available_Memory - msize (Result);
+ end if;
+
+ Unlock_Task.all;
+
+ if Result = System.Null_Address then
+ Raise_Exception (Storage_Error'Identity, "heap exhausted");
+ end if;
+
+ return Result;
+ end Alloc;
+
+ ----------------------------
+ -- Check_Available_Memory --
+ ----------------------------
+
+ procedure Check_Available_Memory (Size : size_t) is
+ Gnat_Memory_Limit : System.Address;
+
+ begin
+ if Available_Memory = 0 then
+
+ -- The amount of available memory hasn't been initialized yet
+
+ Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL);
+
+ if Gnat_Memory_Limit /= System.Null_Address then
+ Available_Memory :=
+ size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy;
+ else
+ Available_Memory := size_t'Last;
+ end if;
+ end if;
+
+ if Size >= Available_Memory then
+
+ -- There is a memory overflow
+
+ Unlock_Task.all;
+ Raise_Exception
+ (Storage_Error'Identity, "heap memory limit exceeded");
+ end if;
+ end Check_Available_Memory;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Ptr : System.Address) is
+ begin
+ Lock_Task.all;
+
+ if Ptr /= System.Null_Address then
+ Available_Memory := Available_Memory + msize (Ptr);
+ end if;
+
+ c_free (Ptr);
+
+ Unlock_Task.all;
+ end Free;
+
+ -------------
+ -- Realloc --
+ -------------
+
+ function Realloc
+ (Ptr : System.Address;
+ Size : size_t)
+ return System.Address
+ is
+ Result : System.Address;
+ Actual_Size : constant size_t := Size;
+ Old_Size : size_t;
+
+ begin
+ if Size = size_t'Last then
+ Raise_Exception (Storage_Error'Identity, "object too large");
+ end if;
+
+ Lock_Task.all;
+
+ Old_Size := msize (Ptr);
+
+ -- Conservative check - no need to try to be precise here
+
+ if Size + Msize_Accuracy >= Available_Memory then
+ Check_Available_Memory (Size + Msize_Accuracy);
+ end if;
+
+ Result := c_realloc (Ptr, Actual_Size);
+
+ if Result /= System.Null_Address then
+ Available_Memory := Available_Memory + Old_Size - msize (Result);
+ end if;
+
+ Unlock_Task.all;
+
+ if Result = System.Null_Address then
+ Raise_Exception (Storage_Error'Identity, "heap exhausted");
+ end if;
+
+ return Result;
+ end Realloc;
+
+end System.Memory;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . M M A P . U N I X --
--- --
--- S p e c --
--- --
--- Copyright (C) 2007-2017, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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. --
--- --
-------------------------------------------------------------------------------
-
--- Declaration of off_t/mmap/munmap. This particular implementation
--- supposes off_t is long.
-
-with System.OS_Lib;
-with Interfaces.C;
-
-package System.Mmap.Unix is
-
- type Mmap_Prot is new Interfaces.C.int;
--- PROT_NONE : constant Mmap_Prot := 16#00#;
--- PROT_EXEC : constant Mmap_Prot := 16#04#;
- PROT_READ : constant Mmap_Prot := 16#01#;
- PROT_WRITE : constant Mmap_Prot := 16#02#;
-
- type Mmap_Flags is new Interfaces.C.int;
--- MAP_NONE : constant Mmap_Flags := 16#00#;
--- MAP_FIXED : constant Mmap_Flags := 16#10#;
- MAP_SHARED : constant Mmap_Flags := 16#01#;
- MAP_PRIVATE : constant Mmap_Flags := 16#02#;
-
- type off_t is new Long_Integer;
-
- function Mmap (Start : Address := Null_Address;
- Length : Interfaces.C.size_t;
- Prot : Mmap_Prot := PROT_READ;
- Flags : Mmap_Flags := MAP_PRIVATE;
- Fd : System.OS_Lib.File_Descriptor;
- Offset : off_t) return Address;
- pragma Import (C, Mmap, "mmap");
-
- function Munmap (Start : Address;
- Length : Interfaces.C.size_t) return Integer;
- pragma Import (C, Munmap, "munmap");
-
- function Is_Mapping_Available return Boolean is (True);
- -- Wheter memory mapping is actually available on this system. It is an
- -- error to use Create_Mapping and Dispose_Mapping if this is False.
-end System.Mmap.Unix;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . U N I X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2017, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Declaration of off_t/mmap/munmap. This particular implementation
+-- supposes off_t is long.
+
+with System.OS_Lib;
+with Interfaces.C;
+
+package System.Mmap.Unix is
+
+ type Mmap_Prot is new Interfaces.C.int;
+-- PROT_NONE : constant Mmap_Prot := 16#00#;
+-- PROT_EXEC : constant Mmap_Prot := 16#04#;
+ PROT_READ : constant Mmap_Prot := 16#01#;
+ PROT_WRITE : constant Mmap_Prot := 16#02#;
+
+ type Mmap_Flags is new Interfaces.C.int;
+-- MAP_NONE : constant Mmap_Flags := 16#00#;
+-- MAP_FIXED : constant Mmap_Flags := 16#10#;
+ MAP_SHARED : constant Mmap_Flags := 16#01#;
+ MAP_PRIVATE : constant Mmap_Flags := 16#02#;
+
+ type off_t is new Long_Integer;
+
+ function Mmap (Start : Address := Null_Address;
+ Length : Interfaces.C.size_t;
+ Prot : Mmap_Prot := PROT_READ;
+ Flags : Mmap_Flags := MAP_PRIVATE;
+ Fd : System.OS_Lib.File_Descriptor;
+ Offset : off_t) return Address;
+ pragma Import (C, Mmap, "mmap");
+
+ function Munmap (Start : Address;
+ Length : Interfaces.C.size_t) return Integer;
+ pragma Import (C, Munmap, "munmap");
+
+ function Is_Mapping_Available return Boolean is (True);
+ -- Wheter memory mapping is actually available on this system. It is an
+ -- error to use Create_Mapping and Dispose_Mapping if this is False.
+end System.Mmap.Unix;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . M M A P . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-2017, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.IO_Exceptions;
-with System.Strings; use System.Strings;
-
-with System.OS_Lib;
-pragma Unreferenced (System.OS_Lib);
--- Only used to generate same runtime dependencies and same binder file on
--- GNU/Linux and Windows.
-
-package body System.Mmap.OS_Interface is
-
- use Win;
-
- function Align
- (Addr : File_Size) return File_Size;
- -- Align some offset/length to the lowest page boundary
-
- function Open_Common
- (Filename : String;
- Use_Mmap_If_Available : Boolean;
- Write : Boolean) return System_File;
-
- function From_UTF8 (Path : String) return Wide_String;
- -- Convert from UTF-8 to Wide_String
-
- ---------------
- -- From_UTF8 --
- ---------------
-
- function From_UTF8 (Path : String) return Wide_String is
- function MultiByteToWideChar
- (Codepage : Interfaces.C.unsigned;
- Flags : Interfaces.C.unsigned;
- Mbstr : Address;
- Mb : Natural;
- Wcstr : Address;
- Wc : Natural) return Integer;
- pragma Import (Stdcall, MultiByteToWideChar, "MultiByteToWideChar");
-
- Current_Codepage : Interfaces.C.unsigned;
- pragma Import (C, Current_Codepage, "__gnat_current_codepage");
-
- Len : Natural;
- begin
- -- Compute length of the result
- Len := MultiByteToWideChar
- (Current_Codepage, 0, Path'Address, Path'Length, Null_Address, 0);
- if Len = 0 then
- raise Constraint_Error;
- end if;
-
- declare
- -- Declare result
- Res : Wide_String (1 .. Len);
- begin
- -- And compute it
- Len := MultiByteToWideChar
- (Current_Codepage, 0,
- Path'Address, Path'Length,
- Res'Address, Len);
- if Len = 0 then
- raise Constraint_Error;
- end if;
- return Res;
- end;
- end From_UTF8;
-
- -----------------
- -- Open_Common --
- -----------------
-
- function Open_Common
- (Filename : String;
- Use_Mmap_If_Available : Boolean;
- Write : Boolean) return System_File
- is
- dwDesiredAccess, dwShareMode : DWORD;
- PageFlags : DWORD;
-
- W_Filename : constant Wide_String :=
- From_UTF8 (Filename) & Wide_Character'Val (0);
- File_Handle, Mapping_Handle : HANDLE;
-
- SizeH : aliased DWORD;
- Size : File_Size;
- begin
- if Write then
- dwDesiredAccess := GENERIC_READ + GENERIC_WRITE;
- dwShareMode := 0;
- PageFlags := Win.PAGE_READWRITE;
- else
- dwDesiredAccess := GENERIC_READ;
- dwShareMode := Win.FILE_SHARE_READ;
- PageFlags := Win.PAGE_READONLY;
- end if;
-
- -- Actually open the file
-
- File_Handle := CreateFile
- (W_Filename'Address, dwDesiredAccess, dwShareMode,
- null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0);
-
- if File_Handle = Win.INVALID_HANDLE_VALUE then
- return Invalid_System_File;
- end if;
-
- -- Compute its size
-
- Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access));
-
- if Size = Win.INVALID_FILE_SIZE then
- return Invalid_System_File;
- end if;
-
- if SizeH /= 0 and then File_Size'Size > 32 then
- Size := Size + (File_Size (SizeH) * 2 ** 32);
- end if;
-
- -- Then create a mapping object, if needed. On Win32, file memory
- -- mapping is always available.
-
- if Use_Mmap_If_Available then
- Mapping_Handle :=
- Win.CreateFileMapping
- (File_Handle, null, PageFlags,
- 0, DWORD (Size), Standard.System.Null_Address);
- else
- Mapping_Handle := Win.INVALID_HANDLE_VALUE;
- end if;
-
- return
- (Handle => File_Handle,
- Mapped => Use_Mmap_If_Available,
- Mapping_Handle => Mapping_Handle,
- Write => Write,
- Length => Size);
- end Open_Common;
-
- ---------------
- -- Open_Read --
- ---------------
-
- function Open_Read
- (Filename : String;
- Use_Mmap_If_Available : Boolean := True) return System_File is
- begin
- return Open_Common (Filename, Use_Mmap_If_Available, False);
- end Open_Read;
-
- ----------------
- -- Open_Write --
- ----------------
-
- function Open_Write
- (Filename : String;
- Use_Mmap_If_Available : Boolean := True) return System_File is
- begin
- return Open_Common (Filename, Use_Mmap_If_Available, True);
- end Open_Write;
-
- -----------
- -- Close --
- -----------
-
- procedure Close (File : in out System_File) is
- Ignored : BOOL;
- pragma Unreferenced (Ignored);
- begin
- Ignored := CloseHandle (File.Mapping_Handle);
- Ignored := CloseHandle (File.Handle);
- File.Handle := Win.INVALID_HANDLE_VALUE;
- File.Mapping_Handle := Win.INVALID_HANDLE_VALUE;
- end Close;
-
- --------------------
- -- Read_From_Disk --
- --------------------
-
- function Read_From_Disk
- (File : System_File;
- Offset, Length : File_Size) return System.Strings.String_Access
- is
- Buffer : String_Access := new String (1 .. Integer (Length));
-
- Pos : DWORD;
- NbRead : aliased DWORD;
- pragma Unreferenced (Pos);
- begin
- Pos := Win.SetFilePointer
- (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
-
- if Win.ReadFile
- (File.Handle, Buffer.all'Address,
- DWORD (Length), NbRead'Unchecked_Access, null) = Win.FALSE
- then
- System.Strings.Free (Buffer);
- raise Ada.IO_Exceptions.Device_Error;
- end if;
- return Buffer;
- end Read_From_Disk;
-
- -------------------
- -- Write_To_Disk --
- -------------------
-
- procedure Write_To_Disk
- (File : System_File;
- Offset, Length : File_Size;
- Buffer : System.Strings.String_Access)
- is
- Pos : DWORD;
- NbWritten : aliased DWORD;
- pragma Unreferenced (Pos);
- begin
- pragma Assert (File.Write);
- Pos := Win.SetFilePointer
- (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
-
- if Win.WriteFile
- (File.Handle, Buffer.all'Address,
- DWORD (Length), NbWritten'Unchecked_Access, null) = Win.FALSE
- then
- raise Ada.IO_Exceptions.Device_Error;
- end if;
- end Write_To_Disk;
-
- --------------------
- -- Create_Mapping --
- --------------------
-
- procedure Create_Mapping
- (File : System_File;
- Offset, Length : in out File_Size;
- Mutable : Boolean;
- Mapping : out System_Mapping)
- is
- Flags : DWORD;
- begin
- if File.Write then
- Flags := Win.FILE_MAP_WRITE;
- elsif Mutable then
- Flags := Win.FILE_MAP_COPY;
- else
- Flags := Win.FILE_MAP_READ;
- end if;
-
- -- Adjust offset and mapping length to account for the required
- -- alignment of offset on page boundary.
-
- declare
- Queried_Offset : constant File_Size := Offset;
- begin
- Offset := Align (Offset);
-
- -- First extend the length to compensate the offset shift, then align
- -- it on the upper page boundary, so that the whole queried area is
- -- covered.
-
- Length := Length + Queried_Offset - Offset;
- Length := Align (Length + Get_Page_Size - 1);
-
- -- But do not exceed the length of the file
- if Offset + Length > File.Length then
- Length := File.Length - Offset;
- end if;
- end;
-
- if Length > File_Size (Integer'Last) then
- raise Ada.IO_Exceptions.Device_Error;
- else
- Mapping := Invalid_System_Mapping;
- Mapping.Address :=
- Win.MapViewOfFile
- (File.Mapping_Handle, Flags,
- 0, DWORD (Offset), SIZE_T (Length));
- Mapping.Length := Length;
- end if;
- end Create_Mapping;
-
- ---------------------
- -- Dispose_Mapping --
- ---------------------
-
- procedure Dispose_Mapping
- (Mapping : in out System_Mapping)
- is
- Ignored : BOOL;
- pragma Unreferenced (Ignored);
- begin
- Ignored := Win.UnmapViewOfFile (Mapping.Address);
- Mapping := Invalid_System_Mapping;
- end Dispose_Mapping;
-
- -------------------
- -- Get_Page_Size --
- -------------------
-
- function Get_Page_Size return File_Size is
- SystemInfo : aliased SYSTEM_INFO;
- begin
- GetSystemInfo (SystemInfo'Unchecked_Access);
- return File_Size (SystemInfo.dwAllocationGranularity);
- end Get_Page_Size;
-
- -----------
- -- Align --
- -----------
-
- function Align
- (Addr : File_Size) return File_Size is
- begin
- return Addr - Addr mod Get_Page_Size;
- end Align;
-
-end System.Mmap.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . M M A P . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 2007-2017, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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. --
--- --
-------------------------------------------------------------------------------
-
--- OS pecularities abstraction package for Win32 systems.
-
-package System.Mmap.OS_Interface is
-
- -- The Win package contains copy of definition found in recent System.Win32
- -- unit provided with the GNAT compiler. The copy is needed to be able to
- -- compile this unit with older compilers. Note that this internal Win
- -- package can be removed when GNAT 6.1.0 is not supported anymore.
-
- package Win is
-
- subtype PVOID is Standard.System.Address;
-
- type HANDLE is new Interfaces.C.ptrdiff_t;
-
- type WORD is new Interfaces.C.unsigned_short;
- type DWORD is new Interfaces.C.unsigned_long;
- type LONG is new Interfaces.C.long;
- type SIZE_T is new Interfaces.C.size_t;
-
- type BOOL is new Interfaces.C.int;
- for BOOL'Size use Interfaces.C.int'Size;
-
- FALSE : constant := 0;
-
- GENERIC_READ : constant := 16#80000000#;
- GENERIC_WRITE : constant := 16#40000000#;
- OPEN_EXISTING : constant := 3;
-
- type OVERLAPPED is record
- Internal : DWORD;
- InternalHigh : DWORD;
- Offset : DWORD;
- OffsetHigh : DWORD;
- hEvent : HANDLE;
- end record;
-
- type SECURITY_ATTRIBUTES is record
- nLength : DWORD;
- pSecurityDescriptor : PVOID;
- bInheritHandle : BOOL;
- end record;
-
- type SYSTEM_INFO is record
- dwOemId : DWORD;
- dwPageSize : DWORD;
- lpMinimumApplicationAddress : PVOID;
- lpMaximumApplicationAddress : PVOID;
- dwActiveProcessorMask : PVOID;
- dwNumberOfProcessors : DWORD;
- dwProcessorType : DWORD;
- dwAllocationGranularity : DWORD;
- wProcessorLevel : WORD;
- wProcessorRevision : WORD;
- end record;
- type LP_SYSTEM_INFO is access all SYSTEM_INFO;
-
- INVALID_HANDLE_VALUE : constant HANDLE := -1;
- FILE_BEGIN : constant := 0;
- FILE_SHARE_READ : constant := 16#00000001#;
- FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#;
- FILE_MAP_COPY : constant := 1;
- FILE_MAP_READ : constant := 4;
- FILE_MAP_WRITE : constant := 2;
- PAGE_READONLY : constant := 16#0002#;
- PAGE_READWRITE : constant := 16#0004#;
- INVALID_FILE_SIZE : constant := 16#FFFFFFFF#;
-
- function CreateFile
- (lpFileName : Standard.System.Address;
- dwDesiredAccess : DWORD;
- dwShareMode : DWORD;
- lpSecurityAttributes : access SECURITY_ATTRIBUTES;
- dwCreationDisposition : DWORD;
- dwFlagsAndAttributes : DWORD;
- hTemplateFile : HANDLE) return HANDLE;
- pragma Import (Stdcall, CreateFile, "CreateFileW");
-
- function WriteFile
- (hFile : HANDLE;
- lpBuffer : Standard.System.Address;
- nNumberOfBytesToWrite : DWORD;
- lpNumberOfBytesWritten : access DWORD;
- lpOverlapped : access OVERLAPPED) return BOOL;
- pragma Import (Stdcall, WriteFile, "WriteFile");
-
- function ReadFile
- (hFile : HANDLE;
- lpBuffer : Standard.System.Address;
- nNumberOfBytesToRead : DWORD;
- lpNumberOfBytesRead : access DWORD;
- lpOverlapped : access OVERLAPPED) return BOOL;
- pragma Import (Stdcall, ReadFile, "ReadFile");
-
- function CloseHandle (hObject : HANDLE) return BOOL;
- pragma Import (Stdcall, CloseHandle, "CloseHandle");
-
- function GetFileSize
- (hFile : HANDLE; lpFileSizeHigh : access DWORD) return DWORD;
- pragma Import (Stdcall, GetFileSize, "GetFileSize");
-
- function SetFilePointer
- (hFile : HANDLE;
- lDistanceToMove : LONG;
- lpDistanceToMoveHigh : access LONG;
- dwMoveMethod : DWORD) return DWORD;
- pragma Import (Stdcall, SetFilePointer, "SetFilePointer");
-
- function CreateFileMapping
- (hFile : HANDLE;
- lpSecurityAttributes : access SECURITY_ATTRIBUTES;
- flProtect : DWORD;
- dwMaximumSizeHigh : DWORD;
- dwMaximumSizeLow : DWORD;
- lpName : Standard.System.Address) return HANDLE;
- pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingW");
-
- function MapViewOfFile
- (hFileMappingObject : HANDLE;
- dwDesiredAccess : DWORD;
- dwFileOffsetHigh : DWORD;
- dwFileOffsetLow : DWORD;
- dwNumberOfBytesToMap : SIZE_T) return Standard.System.Address;
- pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile");
-
- function UnmapViewOfFile
- (lpBaseAddress : Standard.System.Address) return BOOL;
- pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile");
-
- procedure GetSystemInfo (lpSystemInfo : LP_SYSTEM_INFO);
- pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo");
-
- end Win;
-
- type System_File is record
- Handle : Win.HANDLE;
-
- Mapped : Boolean;
- -- Whether mapping is requested by the user and available on the system
-
- Mapping_Handle : Win.HANDLE;
-
- Write : Boolean;
- -- Whether this file can be written to
-
- Length : File_Size;
- -- Length of the file. Used to know what can be mapped in the file
- end record;
-
- type System_Mapping is record
- Address : Standard.System.Address;
- Length : File_Size;
- end record;
-
- Invalid_System_File : constant System_File :=
- (Win.INVALID_HANDLE_VALUE, False, Win.INVALID_HANDLE_VALUE, False, 0);
- Invalid_System_Mapping : constant System_Mapping :=
- (Standard.System.Null_Address, 0);
-
- function Open_Read
- (Filename : String;
- Use_Mmap_If_Available : Boolean := True) return System_File;
- -- Open a file for reading and return the corresponding System_File. Return
- -- Invalid_System_File if unsuccessful.
-
- function Open_Write
- (Filename : String;
- Use_Mmap_If_Available : Boolean := True) return System_File;
- -- Likewise for writing to a file
-
- procedure Close (File : in out System_File);
- -- Close a system file
-
- function Read_From_Disk
- (File : System_File;
- Offset, Length : File_Size) return System.Strings.String_Access;
- -- Read a fragment of a file. It is up to the caller to free the result
- -- when done with it.
-
- procedure Write_To_Disk
- (File : System_File;
- Offset, Length : File_Size;
- Buffer : System.Strings.String_Access);
- -- Write some content to a fragment of a file
-
- procedure Create_Mapping
- (File : System_File;
- Offset, Length : in out File_Size;
- Mutable : Boolean;
- Mapping : out System_Mapping);
- -- Create a memory mapping for the given File, for the area starting at
- -- Offset and containing Length bytes. Store it to Mapping.
- -- Note that Offset and Length may be modified according to the system
- -- needs (for boudaries, for instance). The caller must cope with actually
- -- wider mapped areas.
-
- procedure Dispose_Mapping
- (Mapping : in out System_Mapping);
- -- Unmap a previously-created mapping
-
- function Get_Page_Size return File_Size;
- -- Return the number of bytes in a system page.
-
-end System.Mmap.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . M M A P . O S _ I N T E R F A C E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007-2017, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.IO_Exceptions;
-with System; use System;
-
-with System.OS_Lib; use System.OS_Lib;
-with System.Mmap.Unix; use System.Mmap.Unix;
-
-package body System.Mmap.OS_Interface is
-
- function Align
- (Addr : File_Size) return File_Size;
- -- Align some offset/length to the lowest page boundary
-
- function Is_Mapping_Available return Boolean renames
- System.Mmap.Unix.Is_Mapping_Available;
- -- Wheter memory mapping is actually available on this system. It is an
- -- error to use Create_Mapping and Dispose_Mapping if this is False.
-
- ---------------
- -- Open_Read --
- ---------------
-
- function Open_Read
- (Filename : String;
- Use_Mmap_If_Available : Boolean := True) return System_File is
- Fd : constant File_Descriptor :=
- Open_Read (Filename, Binary);
- begin
- if Fd = Invalid_FD then
- return Invalid_System_File;
- end if;
- return
- (Fd => Fd,
- Mapped => Use_Mmap_If_Available and then Is_Mapping_Available,
- Write => False,
- Length => File_Size (File_Length (Fd)));
- end Open_Read;
-
- ----------------
- -- Open_Write --
- ----------------
-
- function Open_Write
- (Filename : String;
- Use_Mmap_If_Available : Boolean := True) return System_File is
- Fd : constant File_Descriptor :=
- Open_Read_Write (Filename, Binary);
- begin
- if Fd = Invalid_FD then
- return Invalid_System_File;
- end if;
- return
- (Fd => Fd,
- Mapped => Use_Mmap_If_Available and then Is_Mapping_Available,
- Write => True,
- Length => File_Size (File_Length (Fd)));
- end Open_Write;
-
- -----------
- -- Close --
- -----------
-
- procedure Close (File : in out System_File) is
- begin
- Close (File.Fd);
- File.Fd := Invalid_FD;
- end Close;
-
- --------------------
- -- Read_From_Disk --
- --------------------
-
- function Read_From_Disk
- (File : System_File;
- Offset, Length : File_Size) return System.Strings.String_Access
- is
- Buffer : String_Access := new String (1 .. Integer (Length));
- begin
- -- ??? Lseek offset should be a size_t instead of a Long_Integer
-
- Lseek (File.Fd, Long_Integer (Offset), Seek_Set);
- if System.OS_Lib.Read (File.Fd, Buffer.all'Address, Integer (Length))
- /= Integer (Length)
- then
- System.Strings.Free (Buffer);
- raise Ada.IO_Exceptions.Device_Error;
- end if;
- return Buffer;
- end Read_From_Disk;
-
- -------------------
- -- Write_To_Disk --
- -------------------
-
- procedure Write_To_Disk
- (File : System_File;
- Offset, Length : File_Size;
- Buffer : System.Strings.String_Access) is
- begin
- pragma Assert (File.Write);
- Lseek (File.Fd, Long_Integer (Offset), Seek_Set);
- if System.OS_Lib.Write (File.Fd, Buffer.all'Address, Integer (Length))
- /= Integer (Length)
- then
- raise Ada.IO_Exceptions.Device_Error;
- end if;
- end Write_To_Disk;
-
- --------------------
- -- Create_Mapping --
- --------------------
-
- procedure Create_Mapping
- (File : System_File;
- Offset, Length : in out File_Size;
- Mutable : Boolean;
- Mapping : out System_Mapping)
- is
- Prot : Mmap_Prot;
- Flags : Mmap_Flags;
- begin
- if File.Write then
- Prot := PROT_READ + PROT_WRITE;
- Flags := MAP_SHARED;
- else
- Prot := PROT_READ;
- if Mutable then
- Prot := Prot + PROT_WRITE;
- end if;
- Flags := MAP_PRIVATE;
- end if;
-
- -- Adjust offset and mapping length to account for the required
- -- alignment of offset on page boundary.
-
- declare
- Queried_Offset : constant File_Size := Offset;
- begin
- Offset := Align (Offset);
-
- -- First extend the length to compensate the offset shift, then align
- -- it on the upper page boundary, so that the whole queried area is
- -- covered.
-
- Length := Length + Queried_Offset - Offset;
- Length := Align (Length + Get_Page_Size - 1);
- end;
-
- if Length > File_Size (Integer'Last) then
- raise Ada.IO_Exceptions.Device_Error;
- else
- Mapping :=
- (Address => System.Mmap.Unix.Mmap
- (Offset => off_t (Offset),
- Length => Interfaces.C.size_t (Length),
- Prot => Prot,
- Flags => Flags,
- Fd => File.Fd),
- Length => Length);
- end if;
- end Create_Mapping;
-
- ---------------------
- -- Dispose_Mapping --
- ---------------------
-
- procedure Dispose_Mapping
- (Mapping : in out System_Mapping)
- is
- Ignored : Integer;
- pragma Unreferenced (Ignored);
- begin
- Ignored := Munmap
- (Mapping.Address, Interfaces.C.size_t (Mapping.Length));
- Mapping := Invalid_System_Mapping;
- end Dispose_Mapping;
-
- -------------------
- -- Get_Page_Size --
- -------------------
-
- function Get_Page_Size return File_Size is
- function Internal return Integer;
- pragma Import (C, Internal, "getpagesize");
- begin
- return File_Size (Internal);
- end Get_Page_Size;
-
- -----------
- -- Align --
- -----------
-
- function Align
- (Addr : File_Size) return File_Size is
- begin
- return Addr - Addr mod Get_Page_Size;
- end Align;
-
-end System.Mmap.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . M M A P . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 2007-2017, AdaCore --
--- --
--- This library is free software; you can redistribute it and/or modify it --
--- under terms of the GNU General Public License as published by the Free --
--- Software Foundation; either version 3, or (at your option) any later --
--- version. This library is distributed in the hope that it will be useful, --
--- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
--- TABILITY 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. --
--- --
-------------------------------------------------------------------------------
-
-with System.OS_Lib;
-
--- OS pecularities abstraction package for Unix systems.
-
-package System.Mmap.OS_Interface is
-
- type System_File is record
- Fd : System.OS_Lib.File_Descriptor;
-
- Mapped : Boolean;
- -- Whether mapping is requested by the user and available on the system
-
- Write : Boolean;
- -- Whether this file can be written to
-
- Length : File_Size;
- -- Length of the file. Used to know what can be mapped in the file
- end record;
-
- type System_Mapping is record
- Address : Standard.System.Address;
- Length : File_Size;
- end record;
-
- Invalid_System_File : constant System_File :=
- (System.OS_Lib.Invalid_FD, False, False, 0);
- Invalid_System_Mapping : constant System_Mapping :=
- (Standard.System.Null_Address, 0);
-
- function Open_Read
- (Filename : String;
- Use_Mmap_If_Available : Boolean := True) return System_File;
- -- Open a file for reading and return the corresponding System_File. Return
- -- Invalid_System_File if unsuccessful.
-
- function Open_Write
- (Filename : String;
- Use_Mmap_If_Available : Boolean := True) return System_File;
- -- Likewise for writing to a file
-
- procedure Close (File : in out System_File);
- -- Close a system file
-
- function Read_From_Disk
- (File : System_File;
- Offset, Length : File_Size) return System.Strings.String_Access;
- -- Read a fragment of a file. It is up to the caller to free the result
- -- when done with it.
-
- procedure Write_To_Disk
- (File : System_File;
- Offset, Length : File_Size;
- Buffer : System.Strings.String_Access);
- -- Write some content to a fragment of a file
-
- procedure Create_Mapping
- (File : System_File;
- Offset, Length : in out File_Size;
- Mutable : Boolean;
- Mapping : out System_Mapping);
- -- Create a memory mapping for the given File, for the area starting at
- -- Offset and containing Length bytes. Store it to Mapping.
- -- Note that Offset and Length may be modified according to the system
- -- needs (for boudaries, for instance). The caller must cope with actually
- -- wider mapped areas.
-
- procedure Dispose_Mapping
- (Mapping : in out System_Mapping);
- -- Unmap a previously-created mapping
-
- function Get_Page_Size return File_Size;
- -- Return the number of bytes in a system page.
-
-end System.Mmap.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2017, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions;
+with System.Strings; use System.Strings;
+
+with System.OS_Lib;
+pragma Unreferenced (System.OS_Lib);
+-- Only used to generate same runtime dependencies and same binder file on
+-- GNU/Linux and Windows.
+
+package body System.Mmap.OS_Interface is
+
+ use Win;
+
+ function Align
+ (Addr : File_Size) return File_Size;
+ -- Align some offset/length to the lowest page boundary
+
+ function Open_Common
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean;
+ Write : Boolean) return System_File;
+
+ function From_UTF8 (Path : String) return Wide_String;
+ -- Convert from UTF-8 to Wide_String
+
+ ---------------
+ -- From_UTF8 --
+ ---------------
+
+ function From_UTF8 (Path : String) return Wide_String is
+ function MultiByteToWideChar
+ (Codepage : Interfaces.C.unsigned;
+ Flags : Interfaces.C.unsigned;
+ Mbstr : Address;
+ Mb : Natural;
+ Wcstr : Address;
+ Wc : Natural) return Integer;
+ pragma Import (Stdcall, MultiByteToWideChar, "MultiByteToWideChar");
+
+ Current_Codepage : Interfaces.C.unsigned;
+ pragma Import (C, Current_Codepage, "__gnat_current_codepage");
+
+ Len : Natural;
+ begin
+ -- Compute length of the result
+ Len := MultiByteToWideChar
+ (Current_Codepage, 0, Path'Address, Path'Length, Null_Address, 0);
+ if Len = 0 then
+ raise Constraint_Error;
+ end if;
+
+ declare
+ -- Declare result
+ Res : Wide_String (1 .. Len);
+ begin
+ -- And compute it
+ Len := MultiByteToWideChar
+ (Current_Codepage, 0,
+ Path'Address, Path'Length,
+ Res'Address, Len);
+ if Len = 0 then
+ raise Constraint_Error;
+ end if;
+ return Res;
+ end;
+ end From_UTF8;
+
+ -----------------
+ -- Open_Common --
+ -----------------
+
+ function Open_Common
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean;
+ Write : Boolean) return System_File
+ is
+ dwDesiredAccess, dwShareMode : DWORD;
+ PageFlags : DWORD;
+
+ W_Filename : constant Wide_String :=
+ From_UTF8 (Filename) & Wide_Character'Val (0);
+ File_Handle, Mapping_Handle : HANDLE;
+
+ SizeH : aliased DWORD;
+ Size : File_Size;
+ begin
+ if Write then
+ dwDesiredAccess := GENERIC_READ + GENERIC_WRITE;
+ dwShareMode := 0;
+ PageFlags := Win.PAGE_READWRITE;
+ else
+ dwDesiredAccess := GENERIC_READ;
+ dwShareMode := Win.FILE_SHARE_READ;
+ PageFlags := Win.PAGE_READONLY;
+ end if;
+
+ -- Actually open the file
+
+ File_Handle := CreateFile
+ (W_Filename'Address, dwDesiredAccess, dwShareMode,
+ null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0);
+
+ if File_Handle = Win.INVALID_HANDLE_VALUE then
+ return Invalid_System_File;
+ end if;
+
+ -- Compute its size
+
+ Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access));
+
+ if Size = Win.INVALID_FILE_SIZE then
+ return Invalid_System_File;
+ end if;
+
+ if SizeH /= 0 and then File_Size'Size > 32 then
+ Size := Size + (File_Size (SizeH) * 2 ** 32);
+ end if;
+
+ -- Then create a mapping object, if needed. On Win32, file memory
+ -- mapping is always available.
+
+ if Use_Mmap_If_Available then
+ Mapping_Handle :=
+ Win.CreateFileMapping
+ (File_Handle, null, PageFlags,
+ 0, DWORD (Size), Standard.System.Null_Address);
+ else
+ Mapping_Handle := Win.INVALID_HANDLE_VALUE;
+ end if;
+
+ return
+ (Handle => File_Handle,
+ Mapped => Use_Mmap_If_Available,
+ Mapping_Handle => Mapping_Handle,
+ Write => Write,
+ Length => Size);
+ end Open_Common;
+
+ ---------------
+ -- Open_Read --
+ ---------------
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ begin
+ return Open_Common (Filename, Use_Mmap_If_Available, False);
+ end Open_Read;
+
+ ----------------
+ -- Open_Write --
+ ----------------
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ begin
+ return Open_Common (Filename, Use_Mmap_If_Available, True);
+ end Open_Write;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out System_File) is
+ Ignored : BOOL;
+ pragma Unreferenced (Ignored);
+ begin
+ Ignored := CloseHandle (File.Mapping_Handle);
+ Ignored := CloseHandle (File.Handle);
+ File.Handle := Win.INVALID_HANDLE_VALUE;
+ File.Mapping_Handle := Win.INVALID_HANDLE_VALUE;
+ end Close;
+
+ --------------------
+ -- Read_From_Disk --
+ --------------------
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access
+ is
+ Buffer : String_Access := new String (1 .. Integer (Length));
+
+ Pos : DWORD;
+ NbRead : aliased DWORD;
+ pragma Unreferenced (Pos);
+ begin
+ Pos := Win.SetFilePointer
+ (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
+
+ if Win.ReadFile
+ (File.Handle, Buffer.all'Address,
+ DWORD (Length), NbRead'Unchecked_Access, null) = Win.FALSE
+ then
+ System.Strings.Free (Buffer);
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ return Buffer;
+ end Read_From_Disk;
+
+ -------------------
+ -- Write_To_Disk --
+ -------------------
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access)
+ is
+ Pos : DWORD;
+ NbWritten : aliased DWORD;
+ pragma Unreferenced (Pos);
+ begin
+ pragma Assert (File.Write);
+ Pos := Win.SetFilePointer
+ (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
+
+ if Win.WriteFile
+ (File.Handle, Buffer.all'Address,
+ DWORD (Length), NbWritten'Unchecked_Access, null) = Win.FALSE
+ then
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ end Write_To_Disk;
+
+ --------------------
+ -- Create_Mapping --
+ --------------------
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping)
+ is
+ Flags : DWORD;
+ begin
+ if File.Write then
+ Flags := Win.FILE_MAP_WRITE;
+ elsif Mutable then
+ Flags := Win.FILE_MAP_COPY;
+ else
+ Flags := Win.FILE_MAP_READ;
+ end if;
+
+ -- Adjust offset and mapping length to account for the required
+ -- alignment of offset on page boundary.
+
+ declare
+ Queried_Offset : constant File_Size := Offset;
+ begin
+ Offset := Align (Offset);
+
+ -- First extend the length to compensate the offset shift, then align
+ -- it on the upper page boundary, so that the whole queried area is
+ -- covered.
+
+ Length := Length + Queried_Offset - Offset;
+ Length := Align (Length + Get_Page_Size - 1);
+
+ -- But do not exceed the length of the file
+ if Offset + Length > File.Length then
+ Length := File.Length - Offset;
+ end if;
+ end;
+
+ if Length > File_Size (Integer'Last) then
+ raise Ada.IO_Exceptions.Device_Error;
+ else
+ Mapping := Invalid_System_Mapping;
+ Mapping.Address :=
+ Win.MapViewOfFile
+ (File.Mapping_Handle, Flags,
+ 0, DWORD (Offset), SIZE_T (Length));
+ Mapping.Length := Length;
+ end if;
+ end Create_Mapping;
+
+ ---------------------
+ -- Dispose_Mapping --
+ ---------------------
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping)
+ is
+ Ignored : BOOL;
+ pragma Unreferenced (Ignored);
+ begin
+ Ignored := Win.UnmapViewOfFile (Mapping.Address);
+ Mapping := Invalid_System_Mapping;
+ end Dispose_Mapping;
+
+ -------------------
+ -- Get_Page_Size --
+ -------------------
+
+ function Get_Page_Size return File_Size is
+ SystemInfo : aliased SYSTEM_INFO;
+ begin
+ GetSystemInfo (SystemInfo'Unchecked_Access);
+ return File_Size (SystemInfo.dwAllocationGranularity);
+ end Get_Page_Size;
+
+ -----------
+ -- Align --
+ -----------
+
+ function Align
+ (Addr : File_Size) return File_Size is
+ begin
+ return Addr - Addr mod Get_Page_Size;
+ end Align;
+
+end System.Mmap.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2017, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- OS pecularities abstraction package for Win32 systems.
+
+package System.Mmap.OS_Interface is
+
+ -- The Win package contains copy of definition found in recent System.Win32
+ -- unit provided with the GNAT compiler. The copy is needed to be able to
+ -- compile this unit with older compilers. Note that this internal Win
+ -- package can be removed when GNAT 6.1.0 is not supported anymore.
+
+ package Win is
+
+ subtype PVOID is Standard.System.Address;
+
+ type HANDLE is new Interfaces.C.ptrdiff_t;
+
+ type WORD is new Interfaces.C.unsigned_short;
+ type DWORD is new Interfaces.C.unsigned_long;
+ type LONG is new Interfaces.C.long;
+ type SIZE_T is new Interfaces.C.size_t;
+
+ type BOOL is new Interfaces.C.int;
+ for BOOL'Size use Interfaces.C.int'Size;
+
+ FALSE : constant := 0;
+
+ GENERIC_READ : constant := 16#80000000#;
+ GENERIC_WRITE : constant := 16#40000000#;
+ OPEN_EXISTING : constant := 3;
+
+ type OVERLAPPED is record
+ Internal : DWORD;
+ InternalHigh : DWORD;
+ Offset : DWORD;
+ OffsetHigh : DWORD;
+ hEvent : HANDLE;
+ end record;
+
+ type SECURITY_ATTRIBUTES is record
+ nLength : DWORD;
+ pSecurityDescriptor : PVOID;
+ bInheritHandle : BOOL;
+ end record;
+
+ type SYSTEM_INFO is record
+ dwOemId : DWORD;
+ dwPageSize : DWORD;
+ lpMinimumApplicationAddress : PVOID;
+ lpMaximumApplicationAddress : PVOID;
+ dwActiveProcessorMask : PVOID;
+ dwNumberOfProcessors : DWORD;
+ dwProcessorType : DWORD;
+ dwAllocationGranularity : DWORD;
+ wProcessorLevel : WORD;
+ wProcessorRevision : WORD;
+ end record;
+ type LP_SYSTEM_INFO is access all SYSTEM_INFO;
+
+ INVALID_HANDLE_VALUE : constant HANDLE := -1;
+ FILE_BEGIN : constant := 0;
+ FILE_SHARE_READ : constant := 16#00000001#;
+ FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#;
+ FILE_MAP_COPY : constant := 1;
+ FILE_MAP_READ : constant := 4;
+ FILE_MAP_WRITE : constant := 2;
+ PAGE_READONLY : constant := 16#0002#;
+ PAGE_READWRITE : constant := 16#0004#;
+ INVALID_FILE_SIZE : constant := 16#FFFFFFFF#;
+
+ function CreateFile
+ (lpFileName : Standard.System.Address;
+ dwDesiredAccess : DWORD;
+ dwShareMode : DWORD;
+ lpSecurityAttributes : access SECURITY_ATTRIBUTES;
+ dwCreationDisposition : DWORD;
+ dwFlagsAndAttributes : DWORD;
+ hTemplateFile : HANDLE) return HANDLE;
+ pragma Import (Stdcall, CreateFile, "CreateFileW");
+
+ function WriteFile
+ (hFile : HANDLE;
+ lpBuffer : Standard.System.Address;
+ nNumberOfBytesToWrite : DWORD;
+ lpNumberOfBytesWritten : access DWORD;
+ lpOverlapped : access OVERLAPPED) return BOOL;
+ pragma Import (Stdcall, WriteFile, "WriteFile");
+
+ function ReadFile
+ (hFile : HANDLE;
+ lpBuffer : Standard.System.Address;
+ nNumberOfBytesToRead : DWORD;
+ lpNumberOfBytesRead : access DWORD;
+ lpOverlapped : access OVERLAPPED) return BOOL;
+ pragma Import (Stdcall, ReadFile, "ReadFile");
+
+ function CloseHandle (hObject : HANDLE) return BOOL;
+ pragma Import (Stdcall, CloseHandle, "CloseHandle");
+
+ function GetFileSize
+ (hFile : HANDLE; lpFileSizeHigh : access DWORD) return DWORD;
+ pragma Import (Stdcall, GetFileSize, "GetFileSize");
+
+ function SetFilePointer
+ (hFile : HANDLE;
+ lDistanceToMove : LONG;
+ lpDistanceToMoveHigh : access LONG;
+ dwMoveMethod : DWORD) return DWORD;
+ pragma Import (Stdcall, SetFilePointer, "SetFilePointer");
+
+ function CreateFileMapping
+ (hFile : HANDLE;
+ lpSecurityAttributes : access SECURITY_ATTRIBUTES;
+ flProtect : DWORD;
+ dwMaximumSizeHigh : DWORD;
+ dwMaximumSizeLow : DWORD;
+ lpName : Standard.System.Address) return HANDLE;
+ pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingW");
+
+ function MapViewOfFile
+ (hFileMappingObject : HANDLE;
+ dwDesiredAccess : DWORD;
+ dwFileOffsetHigh : DWORD;
+ dwFileOffsetLow : DWORD;
+ dwNumberOfBytesToMap : SIZE_T) return Standard.System.Address;
+ pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile");
+
+ function UnmapViewOfFile
+ (lpBaseAddress : Standard.System.Address) return BOOL;
+ pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile");
+
+ procedure GetSystemInfo (lpSystemInfo : LP_SYSTEM_INFO);
+ pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo");
+
+ end Win;
+
+ type System_File is record
+ Handle : Win.HANDLE;
+
+ Mapped : Boolean;
+ -- Whether mapping is requested by the user and available on the system
+
+ Mapping_Handle : Win.HANDLE;
+
+ Write : Boolean;
+ -- Whether this file can be written to
+
+ Length : File_Size;
+ -- Length of the file. Used to know what can be mapped in the file
+ end record;
+
+ type System_Mapping is record
+ Address : Standard.System.Address;
+ Length : File_Size;
+ end record;
+
+ Invalid_System_File : constant System_File :=
+ (Win.INVALID_HANDLE_VALUE, False, Win.INVALID_HANDLE_VALUE, False, 0);
+ Invalid_System_Mapping : constant System_Mapping :=
+ (Standard.System.Null_Address, 0);
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Open a file for reading and return the corresponding System_File. Return
+ -- Invalid_System_File if unsuccessful.
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Likewise for writing to a file
+
+ procedure Close (File : in out System_File);
+ -- Close a system file
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access;
+ -- Read a fragment of a file. It is up to the caller to free the result
+ -- when done with it.
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access);
+ -- Write some content to a fragment of a file
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping);
+ -- Create a memory mapping for the given File, for the area starting at
+ -- Offset and containing Length bytes. Store it to Mapping.
+ -- Note that Offset and Length may be modified according to the system
+ -- needs (for boudaries, for instance). The caller must cope with actually
+ -- wider mapped areas.
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping);
+ -- Unmap a previously-created mapping
+
+ function Get_Page_Size return File_Size;
+ -- Return the number of bytes in a system page.
+
+end System.Mmap.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2017, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions;
+with System; use System;
+
+with System.OS_Lib; use System.OS_Lib;
+with System.Mmap.Unix; use System.Mmap.Unix;
+
+package body System.Mmap.OS_Interface is
+
+ function Align
+ (Addr : File_Size) return File_Size;
+ -- Align some offset/length to the lowest page boundary
+
+ function Is_Mapping_Available return Boolean renames
+ System.Mmap.Unix.Is_Mapping_Available;
+ -- Wheter memory mapping is actually available on this system. It is an
+ -- error to use Create_Mapping and Dispose_Mapping if this is False.
+
+ ---------------
+ -- Open_Read --
+ ---------------
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ Fd : constant File_Descriptor :=
+ Open_Read (Filename, Binary);
+ begin
+ if Fd = Invalid_FD then
+ return Invalid_System_File;
+ end if;
+ return
+ (Fd => Fd,
+ Mapped => Use_Mmap_If_Available and then Is_Mapping_Available,
+ Write => False,
+ Length => File_Size (File_Length (Fd)));
+ end Open_Read;
+
+ ----------------
+ -- Open_Write --
+ ----------------
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ Fd : constant File_Descriptor :=
+ Open_Read_Write (Filename, Binary);
+ begin
+ if Fd = Invalid_FD then
+ return Invalid_System_File;
+ end if;
+ return
+ (Fd => Fd,
+ Mapped => Use_Mmap_If_Available and then Is_Mapping_Available,
+ Write => True,
+ Length => File_Size (File_Length (Fd)));
+ end Open_Write;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out System_File) is
+ begin
+ Close (File.Fd);
+ File.Fd := Invalid_FD;
+ end Close;
+
+ --------------------
+ -- Read_From_Disk --
+ --------------------
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access
+ is
+ Buffer : String_Access := new String (1 .. Integer (Length));
+ begin
+ -- ??? Lseek offset should be a size_t instead of a Long_Integer
+
+ Lseek (File.Fd, Long_Integer (Offset), Seek_Set);
+ if System.OS_Lib.Read (File.Fd, Buffer.all'Address, Integer (Length))
+ /= Integer (Length)
+ then
+ System.Strings.Free (Buffer);
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ return Buffer;
+ end Read_From_Disk;
+
+ -------------------
+ -- Write_To_Disk --
+ -------------------
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access) is
+ begin
+ pragma Assert (File.Write);
+ Lseek (File.Fd, Long_Integer (Offset), Seek_Set);
+ if System.OS_Lib.Write (File.Fd, Buffer.all'Address, Integer (Length))
+ /= Integer (Length)
+ then
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ end Write_To_Disk;
+
+ --------------------
+ -- Create_Mapping --
+ --------------------
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping)
+ is
+ Prot : Mmap_Prot;
+ Flags : Mmap_Flags;
+ begin
+ if File.Write then
+ Prot := PROT_READ + PROT_WRITE;
+ Flags := MAP_SHARED;
+ else
+ Prot := PROT_READ;
+ if Mutable then
+ Prot := Prot + PROT_WRITE;
+ end if;
+ Flags := MAP_PRIVATE;
+ end if;
+
+ -- Adjust offset and mapping length to account for the required
+ -- alignment of offset on page boundary.
+
+ declare
+ Queried_Offset : constant File_Size := Offset;
+ begin
+ Offset := Align (Offset);
+
+ -- First extend the length to compensate the offset shift, then align
+ -- it on the upper page boundary, so that the whole queried area is
+ -- covered.
+
+ Length := Length + Queried_Offset - Offset;
+ Length := Align (Length + Get_Page_Size - 1);
+ end;
+
+ if Length > File_Size (Integer'Last) then
+ raise Ada.IO_Exceptions.Device_Error;
+ else
+ Mapping :=
+ (Address => System.Mmap.Unix.Mmap
+ (Offset => off_t (Offset),
+ Length => Interfaces.C.size_t (Length),
+ Prot => Prot,
+ Flags => Flags,
+ Fd => File.Fd),
+ Length => Length);
+ end if;
+ end Create_Mapping;
+
+ ---------------------
+ -- Dispose_Mapping --
+ ---------------------
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping)
+ is
+ Ignored : Integer;
+ pragma Unreferenced (Ignored);
+ begin
+ Ignored := Munmap
+ (Mapping.Address, Interfaces.C.size_t (Mapping.Length));
+ Mapping := Invalid_System_Mapping;
+ end Dispose_Mapping;
+
+ -------------------
+ -- Get_Page_Size --
+ -------------------
+
+ function Get_Page_Size return File_Size is
+ function Internal return Integer;
+ pragma Import (C, Internal, "getpagesize");
+ begin
+ return File_Size (Internal);
+ end Get_Page_Size;
+
+ -----------
+ -- Align --
+ -----------
+
+ function Align
+ (Addr : File_Size) return File_Size is
+ begin
+ return Addr - Addr mod Get_Page_Size;
+ end Align;
+
+end System.Mmap.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2017, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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. --
+-- --
+------------------------------------------------------------------------------
+
+with System.OS_Lib;
+
+-- OS pecularities abstraction package for Unix systems.
+
+package System.Mmap.OS_Interface is
+
+ type System_File is record
+ Fd : System.OS_Lib.File_Descriptor;
+
+ Mapped : Boolean;
+ -- Whether mapping is requested by the user and available on the system
+
+ Write : Boolean;
+ -- Whether this file can be written to
+
+ Length : File_Size;
+ -- Length of the file. Used to know what can be mapped in the file
+ end record;
+
+ type System_Mapping is record
+ Address : Standard.System.Address;
+ Length : File_Size;
+ end record;
+
+ Invalid_System_File : constant System_File :=
+ (System.OS_Lib.Invalid_FD, False, False, 0);
+ Invalid_System_Mapping : constant System_Mapping :=
+ (Standard.System.Null_Address, 0);
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Open a file for reading and return the corresponding System_File. Return
+ -- Invalid_System_File if unsuccessful.
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Likewise for writing to a file
+
+ procedure Close (File : in out System_File);
+ -- Close a system file
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access;
+ -- Read a fragment of a file. It is up to the caller to free the result
+ -- when done with it.
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access);
+ -- Write some content to a fragment of a file
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping);
+ -- Create a memory mapping for the given File, for the area starting at
+ -- Offset and containing Length bytes. Store it to Mapping.
+ -- Note that Offset and Length may be modified according to the system
+ -- needs (for boudaries, for instance). The caller must cope with actually
+ -- wider mapped areas.
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping);
+ -- Unmap a previously-created mapping
+
+ function Get_Page_Size return File_Size;
+ -- Return the number of bytes in a system page.
+
+end System.Mmap.OS_Interface;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ P R I M I T I V E S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for darwin
-
-package body System.OS_Primitives is
-
- -- ??? These definitions are duplicated from System.OS_Interface
- -- because we don't want to depend on any package. Consider removing
- -- these declarations in System.OS_Interface and move these ones in
- -- the spec.
-
- type struct_timezone is record
- tz_minuteswest : Integer;
- tz_dsttime : Integer;
- end record;
- pragma Convention (C, struct_timezone);
- type struct_timezone_ptr is access all struct_timezone;
-
- type time_t is new Long_Integer;
-
- type struct_timeval is record
- tv_sec : time_t;
- tv_usec : Integer;
- end record;
- pragma Convention (C, struct_timeval);
-
- function gettimeofday
- (tv : not null access struct_timeval;
- tz : struct_timezone_ptr) return Integer;
- pragma Import (C, gettimeofday, "gettimeofday");
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : Long_Integer;
- end record;
- pragma Convention (C, timespec);
-
- function nanosleep (rqtp, rmtp : not null access timespec) return Integer;
- pragma Import (C, nanosleep, "nanosleep");
-
- -----------
- -- Clock --
- -----------
-
- function Clock return Duration is
- TV : aliased struct_timeval;
-
- Result : Integer;
- pragma Unreferenced (Result);
-
- begin
- -- The return codes for gettimeofday are as follows (from man pages):
- -- EPERM settimeofday is called by someone other than the superuser
- -- EINVAL Timezone (or something else) is invalid
- -- EFAULT One of tv or tz pointed outside accessible address space
-
- -- None of these codes signal a potential clock skew, hence the return
- -- value is never checked.
-
- Result := gettimeofday (TV'Access, null);
- return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
- end Clock;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec;
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return
- timespec'(tv_sec => S,
- tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Time : Duration;
- Mode : Integer)
- is
- Request : aliased timespec;
- Remaind : aliased timespec;
- Rel_Time : Duration;
- Abs_Time : Duration;
- Base_Time : constant Duration := Clock;
- Check_Time : Duration := Base_Time;
-
- Result : Integer;
- pragma Unreferenced (Result);
-
- begin
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Time + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- loop
- Request := To_Timespec (Rel_Time);
- Result := nanosleep (Request'Access, Remaind'Access);
- Check_Time := Clock;
-
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
- end if;
- end Timed_Delay;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
-end System.OS_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ P R I M I T I V E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides low level primitives used to implement clock and
--- delays in non tasking applications, for LynxOS.
-
--- The choice of the real clock/delay implementation (depending on whether
--- tasking is involved or not) is done via soft links (see s-soflin.ads)
-
--- NEVER add any dependency to tasking packages here
-
-package System.OS_Primitives is
- pragma Preelaborate;
-
- Max_Sensible_Delay : constant Duration := 16#10_0000.0#;
- -- LynxOS does not support delays as long as half a year, so we set this to
- -- a shorter, but still fairly long, duration. Experiments show that if
- -- pthread_cond_timedwait is passed an abstime much greater than about
- -- 2**21, it fails, returning EAGAIN. The cutoff is somewhere between
- -- 16#20_8000.0# and 16#20_F000.0#. This behavior is not documented.
-
- procedure Initialize;
- -- Initialize global settings related to this package. This procedure
- -- should be called before any other subprograms in this package. Note
- -- that this procedure can be called several times.
-
- function Clock return Duration;
- pragma Inline (Clock);
- -- Returns "absolute" time, represented as an offset relative to "the
- -- Epoch", which is Jan 1, 1970 00:00:00 UTC on UNIX systems. This
- -- implementation is affected by system's clock changes.
-
- Relative : constant := 0;
- Absolute_Calendar : constant := 1;
- Absolute_RT : constant := 2;
- -- Values for Mode call below. Note that the compiler (exp_ch9.adb) relies
- -- on these values. So any change here must be reflected in corresponding
- -- changes in the compiler.
-
- procedure Timed_Delay (Time : Duration; Mode : Integer);
- -- Implements the semantics of the delay statement when no tasking is used
- -- in the application.
- --
- -- Mode is one of the three values above
- --
- -- Time is a relative or absolute duration value, depending on Mode.
- --
- -- Note that currently Ada.Real_Time always uses the tasking run time,
- -- so this procedure should never be called with Mode set to Absolute_RT.
- -- This may change in future or bare board implementations.
-
-end System.OS_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ P R I M I T I V E S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the NT version of this package
-
-with System.Task_Lock;
-with System.Win32.Ext;
-
-package body System.OS_Primitives is
-
- use System.Task_Lock;
- use System.Win32;
- use System.Win32.Ext;
-
- ----------------------------------------
- -- Data for the high resolution clock --
- ----------------------------------------
-
- Tick_Frequency : aliased LARGE_INTEGER;
- -- Holds frequency of high-performance counter used by Clock
- -- Windows NT uses a 1_193_182 Hz counter on PCs.
-
- Base_Monotonic_Ticks : LARGE_INTEGER;
- -- Holds the Tick count for the base monotonic time
-
- Base_Monotonic_Clock : Duration;
- -- Holds the current clock for monotonic clock's base time
-
- type Clock_Data is record
- Base_Ticks : LARGE_INTEGER;
- -- Holds the Tick count for the base time
-
- Base_Time : Long_Long_Integer;
- -- Holds the base time used to check for system time change, used with
- -- the standard clock.
-
- Base_Clock : Duration;
- -- Holds the current clock for the standard clock's base time
- end record;
-
- type Clock_Data_Access is access all Clock_Data;
-
- -- Two base clock buffers. This is used to be able to update a buffer while
- -- the other buffer is read. The point is that we do not want to use a lock
- -- inside the Clock routine for performance reasons. We still use a lock
- -- in the Get_Base_Time which is called very rarely. Current is a pointer,
- -- the pragma Atomic is there to ensure that the value can be set or read
- -- atomically. That's it, when Get_Base_Time has updated a buffer the
- -- switch to the new value is done by changing Current pointer.
-
- First, Second : aliased Clock_Data;
-
- Current : Clock_Data_Access := First'Access;
- pragma Atomic (Current);
-
- -- The following signature is to detect change on the base clock data
- -- above. The signature is a modular type, it will wrap around without
- -- raising an exception. We would need to have exactly 2**32 updates of
- -- the base data for the changes to get undetected.
-
- type Signature_Type is mod 2**32;
- Signature : Signature_Type := 0;
- pragma Atomic (Signature);
-
- function Monotonic_Clock return Duration;
- pragma Export (Ada, Monotonic_Clock, "__gnat_monotonic_clock");
- -- Return "absolute" time, represented as an offset relative to "the Unix
- -- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is
- -- immune to the system's clock changes. Export this function so that it
- -- can be imported from s-taprop-mingw.adb without changing the shared
- -- spec (s-osprim.ads).
-
- procedure Get_Base_Time (Data : in out Clock_Data);
- -- Retrieve the base time and base ticks. These values will be used by
- -- clock to compute the current time by adding to it a fraction of the
- -- performance counter. This is for the implementation of a high-resolution
- -- clock. Note that this routine does not change the base monotonic values
- -- used by the monotonic clock.
-
- -----------
- -- Clock --
- -----------
-
- -- This implementation of clock provides high resolution timer values
- -- using QueryPerformanceCounter. This call return a 64 bits values (based
- -- on the 8253 16 bits counter). This counter is updated every 1/1_193_182
- -- times per seconds. The call to QueryPerformanceCounter takes 6
- -- microsecs to complete.
-
- function Clock return Duration is
- Max_Shift : constant Duration := 2.0;
- Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7;
- Data : Clock_Data;
- Current_Ticks : aliased LARGE_INTEGER;
- Elap_Secs_Tick : Duration;
- Elap_Secs_Sys : Duration;
- Now : aliased Long_Long_Integer;
- Sig1, Sig2 : Signature_Type;
-
- begin
- -- Try ten times to get a coherent set of base data. For this we just
- -- check that the signature hasn't changed during the copy of the
- -- current data.
- --
- -- This loop will always be done once if there is no interleaved call
- -- to Get_Base_Time.
-
- for K in 1 .. 10 loop
- Sig1 := Signature;
- Data := Current.all;
- Sig2 := Signature;
- exit when Sig1 = Sig2;
- end loop;
-
- if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then
- return 0.0;
- end if;
-
- GetSystemTimeAsFileTime (Now'Access);
-
- Elap_Secs_Sys :=
- Duration (Long_Long_Float (abs (Now - Data.Base_Time)) /
- Hundreds_Nano_In_Sec);
-
- Elap_Secs_Tick :=
- Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) /
- Long_Long_Float (Tick_Frequency));
-
- -- If we have a shift of more than Max_Shift seconds we resynchronize
- -- the Clock. This is probably due to a manual Clock adjustment, a DST
- -- adjustment or an NTP synchronisation. And we want to adjust the time
- -- for this system (non-monotonic) clock.
-
- if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then
- Get_Base_Time (Data);
-
- Elap_Secs_Tick :=
- Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) /
- Long_Long_Float (Tick_Frequency));
- end if;
-
- return Data.Base_Clock + Elap_Secs_Tick;
- end Clock;
-
- -------------------
- -- Get_Base_Time --
- -------------------
-
- procedure Get_Base_Time (Data : in out Clock_Data) is
-
- -- The resolution for GetSystemTime is 1 millisecond
-
- -- The time to get both base times should take less than 1 millisecond.
- -- Therefore, the elapsed time reported by GetSystemTime between both
- -- actions should be null.
-
- epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch
- system_time_ns : constant := 100; -- 100 ns per tick
- Sec_Unit : constant := 10#1#E9;
-
- Max_Elapsed : constant LARGE_INTEGER :=
- LARGE_INTEGER (Tick_Frequency / 100_000);
- -- Look for a precision of 0.01 ms
-
- Sig : constant Signature_Type := Signature;
-
- Loc_Ticks, Ctrl_Ticks : aliased LARGE_INTEGER;
- Loc_Time, Ctrl_Time : aliased Long_Long_Integer;
- Elapsed : LARGE_INTEGER;
- Current_Max : LARGE_INTEGER := LARGE_INTEGER'Last;
- New_Data : Clock_Data_Access;
-
- begin
- -- Here we must be sure that both of these calls are done in a short
- -- amount of time. Both are base time and should in theory be taken
- -- at the very same time.
-
- -- The goal of the following loop is to synchronize the system time
- -- with the Win32 performance counter by getting a base offset for both.
- -- Using these offsets it is then possible to compute actual time using
- -- a performance counter which has a better precision than the Win32
- -- time API.
-
- -- Try at most 10 times to reach the best synchronisation (below 1
- -- millisecond) otherwise the runtime will use the best value reached
- -- during the runs.
-
- Lock;
-
- -- First check that the current value has not been updated. This
- -- could happen if another task has called Clock at the same time
- -- and that Max_Shift has been reached too.
- --
- -- But if the current value has been changed just before we entered
- -- into the critical section, we can safely return as the current
- -- base data (time, clock, ticks) have already been updated.
-
- if Sig /= Signature then
- Unlock;
- return;
- end if;
-
- -- Check for the unused data buffer and set New_Data to point to it
-
- if Current = First'Access then
- New_Data := Second'Access;
- else
- New_Data := First'Access;
- end if;
-
- for K in 1 .. 10 loop
- if QueryPerformanceCounter (Loc_Ticks'Access) = Win32.FALSE then
- pragma Assert
- (Standard.False,
- "Could not query high performance counter in Clock");
- null;
- end if;
-
- GetSystemTimeAsFileTime (Ctrl_Time'Access);
-
- -- Scan for clock tick, will take up to 16ms/1ms depending on PC.
- -- This cannot be an infinite loop or the system hardware is badly
- -- damaged.
-
- loop
- GetSystemTimeAsFileTime (Loc_Time'Access);
-
- if QueryPerformanceCounter (Ctrl_Ticks'Access) = Win32.FALSE then
- pragma Assert
- (Standard.False,
- "Could not query high performance counter in Clock");
- null;
- end if;
-
- exit when Loc_Time /= Ctrl_Time;
- Loc_Ticks := Ctrl_Ticks;
- end loop;
-
- -- Check elapsed Performance Counter between samples
- -- to choose the best one.
-
- Elapsed := Ctrl_Ticks - Loc_Ticks;
-
- if Elapsed < Current_Max then
- New_Data.Base_Time := Loc_Time;
- New_Data.Base_Ticks := Loc_Ticks;
- Current_Max := Elapsed;
-
- -- Exit the loop when we have reached the expected precision
-
- exit when Elapsed <= Max_Elapsed;
- end if;
- end loop;
-
- New_Data.Base_Clock :=
- Duration
- (Long_Long_Float
- ((New_Data.Base_Time - epoch_1970) * system_time_ns) /
- Long_Long_Float (Sec_Unit));
-
- -- At this point all the base values have been set into the new data
- -- record. Change the pointer (atomic operation) to these new values.
-
- Current := New_Data;
- Data := New_Data.all;
-
- -- Set new signature for this data set
-
- Signature := Signature + 1;
-
- Unlock;
-
- exception
- when others =>
- Unlock;
- raise;
- end Get_Base_Time;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- function Monotonic_Clock return Duration is
- Current_Ticks : aliased LARGE_INTEGER;
- Elap_Secs_Tick : Duration;
-
- begin
- if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then
- return 0.0;
-
- else
- Elap_Secs_Tick :=
- Duration (Long_Long_Float (Current_Ticks - Base_Monotonic_Ticks) /
- Long_Long_Float (Tick_Frequency));
- return Base_Monotonic_Clock + Elap_Secs_Tick;
- end if;
- end Monotonic_Clock;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay (Time : Duration; Mode : Integer) is
- function Mode_Clock return Duration;
- pragma Inline (Mode_Clock);
- -- Return the current clock value using either the monotonic clock or
- -- standard clock depending on the Mode value.
-
- ----------------
- -- Mode_Clock --
- ----------------
-
- function Mode_Clock return Duration is
- begin
- case Mode is
- when Absolute_RT => return Monotonic_Clock;
- when others => return Clock;
- end case;
- end Mode_Clock;
-
- -- Local Variables
-
- Base_Time : constant Duration := Mode_Clock;
- -- Base_Time is used to detect clock set backward, in this case we
- -- cannot ensure the delay accuracy.
-
- Rel_Time : Duration;
- Abs_Time : Duration;
- Check_Time : Duration := Base_Time;
-
- -- Start of processing for Timed Delay
-
- begin
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Time + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- loop
- Sleep (DWORD (Rel_Time * 1000.0));
- Check_Time := Mode_Clock;
-
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
- end if;
- end Timed_Delay;
-
- ----------------
- -- Initialize --
- ----------------
-
- Initialized : Boolean := False;
-
- procedure Initialize is
- begin
- if Initialized then
- return;
- end if;
-
- Initialized := True;
-
- -- Get starting time as base
-
- if QueryPerformanceFrequency (Tick_Frequency'Access) = Win32.FALSE then
- raise Program_Error with
- "cannot get high performance counter frequency";
- end if;
-
- Get_Base_Time (Current.all);
-
- -- Keep base clock and ticks for the monotonic clock. These values
- -- should never be changed to ensure proper behavior of the monotonic
- -- clock.
-
- Base_Monotonic_Clock := Current.Base_Clock;
- Base_Monotonic_Ticks := Current.Base_Ticks;
- end Initialize;
-
-end System.OS_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ P R I M I T I V E S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for POSIX-like operating systems
-
-package body System.OS_Primitives is
-
- -- ??? These definitions are duplicated from System.OS_Interface
- -- because we don't want to depend on any package. Consider removing
- -- these declarations in System.OS_Interface and move these ones in
- -- the spec.
-
- type time_t is new Long_Integer;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : Long_Integer;
- end record;
- pragma Convention (C, timespec);
-
- function nanosleep (rqtp, rmtp : not null access timespec) return Integer;
- pragma Import (C, nanosleep, "nanosleep");
-
- -----------
- -- Clock --
- -----------
-
- function Clock return Duration is
-
- type timeval is array (1 .. 3) of Long_Integer;
- -- The timeval array is sized to contain Long_Long_Integer sec and
- -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then
- -- it will be overly large but that will not effect the implementation
- -- since it is not accessed directly.
-
- procedure timeval_to_duration
- (T : not null access timeval;
- sec : not null access Long_Long_Integer;
- usec : not null access Long_Integer);
- pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
-
- Micro : constant := 10**6;
- sec : aliased Long_Long_Integer;
- usec : aliased Long_Integer;
- TV : aliased timeval;
- Result : Integer;
- pragma Unreferenced (Result);
-
- function gettimeofday
- (Tv : access timeval;
- Tz : System.Address := System.Null_Address) return Integer;
- pragma Import (C, gettimeofday, "gettimeofday");
-
- begin
- -- The return codes for gettimeofday are as follows (from man pages):
- -- EPERM settimeofday is called by someone other than the superuser
- -- EINVAL Timezone (or something else) is invalid
- -- EFAULT One of tv or tz pointed outside accessible address space
-
- -- None of these codes signal a potential clock skew, hence the return
- -- value is never checked.
-
- Result := gettimeofday (TV'Access, System.Null_Address);
- timeval_to_duration (TV'Access, sec'Access, usec'Access);
- return Duration (sec) + Duration (usec) / Micro;
- end Clock;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec;
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return
- timespec'(tv_sec => S,
- tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Time : Duration;
- Mode : Integer)
- is
- Request : aliased timespec;
- Remaind : aliased timespec;
- Rel_Time : Duration;
- Abs_Time : Duration;
- Base_Time : constant Duration := Clock;
- Check_Time : Duration := Base_Time;
-
- Result : Integer;
- pragma Unreferenced (Result);
-
- begin
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Time + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- loop
- Request := To_Timespec (Rel_Time);
- Result := nanosleep (Request'Access, Remaind'Access);
- Check_Time := Clock;
-
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
- end if;
- end Timed_Delay;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
-end System.OS_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ P R I M I T I V E S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for POSIX.1-2008-like operating systems
-
-with System.CRTL;
-package body System.OS_Primitives is
-
- -- ??? These definitions are duplicated from System.OS_Interface because
- -- we don't want to depend on any package. Consider removing these
- -- declarations in System.OS_Interface and move these ones to the spec.
-
- type time_t is new System.CRTL.int64;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : Long_Integer;
- end record;
- pragma Convention (C, timespec);
-
- function nanosleep (rqtp, rmtp : not null access timespec) return Integer;
- pragma Import (C, nanosleep, "nanosleep");
-
- -----------
- -- Clock --
- -----------
-
- function Clock return Duration is
-
- type timeval is array (1 .. 3) of Long_Integer;
- -- The timeval array is sized to contain Long_Long_Integer sec and
- -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then
- -- it will be overly large but that will not effect the implementation
- -- since it is not accessed directly.
-
- procedure timeval_to_duration
- (T : not null access timeval;
- sec : not null access Long_Long_Integer;
- usec : not null access Long_Integer);
- pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
-
- Micro : constant := 10**6;
- sec : aliased Long_Long_Integer;
- usec : aliased Long_Integer;
- TV : aliased timeval;
- Result : Integer;
- pragma Unreferenced (Result);
-
- function gettimeofday
- (Tv : access timeval;
- Tz : System.Address := System.Null_Address) return Integer;
- pragma Import (C, gettimeofday, "gettimeofday");
-
- begin
- -- The return codes for gettimeofday are as follows (from man pages):
- -- EPERM settimeofday is called by someone other than the superuser
- -- EINVAL Timezone (or something else) is invalid
- -- EFAULT One of tv or tz pointed outside accessible address space
-
- -- None of these codes signal a potential clock skew, hence the return
- -- value is never checked.
-
- Result := gettimeofday (TV'Access, System.Null_Address);
- timeval_to_duration (TV'Access, sec'Access, usec'Access);
- return Duration (sec) + Duration (usec) / Micro;
- end Clock;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec;
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return
- timespec'(tv_sec => S,
- tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9)));
- end To_Timespec;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Time : Duration;
- Mode : Integer)
- is
- Request : aliased timespec;
- Remaind : aliased timespec;
- Rel_Time : Duration;
- Abs_Time : Duration;
- Base_Time : constant Duration := Clock;
- Check_Time : Duration := Base_Time;
-
- Result : Integer;
- pragma Unreferenced (Result);
-
- begin
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Time + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- loop
- Request := To_Timespec (Rel_Time);
- Result := nanosleep (Request'Access, Remaind'Access);
- Check_Time := Clock;
-
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
- end if;
- end Timed_Delay;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
-end System.OS_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ P R I M I T I V E S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version uses gettimeofday and select
--- This file is suitable for Solaris (32 and 64 bits).
-
-package body System.OS_Primitives is
-
- -- ??? These definitions are duplicated from System.OS_Interface
- -- because we don't want to depend on any package. Consider removing
- -- these declarations in System.OS_Interface and move these ones in
- -- the spec.
-
- type struct_timeval is record
- tv_sec : Long_Integer;
- tv_usec : Long_Integer;
- end record;
- pragma Convention (C, struct_timeval);
-
- procedure gettimeofday
- (tv : not null access struct_timeval;
- tz : Address := Null_Address);
- pragma Import (C, gettimeofday, "gettimeofday");
-
- procedure C_select
- (n : Integer := 0;
- readfds,
- writefds,
- exceptfds : Address := Null_Address;
- timeout : not null access struct_timeval);
- pragma Import (C, C_select, "select");
-
- -----------
- -- Clock --
- -----------
-
- function Clock return Duration is
- TV : aliased struct_timeval;
-
- begin
- gettimeofday (TV'Access);
- return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
- end Clock;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Time : Duration;
- Mode : Integer)
- is
- Rel_Time : Duration;
- Abs_Time : Duration;
- Base_Time : constant Duration := Clock;
- Check_Time : Duration := Base_Time;
- timeval : aliased struct_timeval;
-
- begin
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Time + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- loop
- timeval.tv_sec := Long_Integer (Rel_Time);
-
- if Duration (timeval.tv_sec) > Rel_Time then
- timeval.tv_sec := timeval.tv_sec - 1;
- end if;
-
- timeval.tv_usec :=
- Long_Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6);
-
- C_select (timeout => timeval'Unchecked_Access);
- Check_Time := Clock;
-
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
- end if;
- end Timed_Delay;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
-end System.OS_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ P R I M I T I V E S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version uses gettimeofday and select
--- This file is suitable for OpenNT, Dec Unix and SCO UnixWare.
-
-package body System.OS_Primitives is
-
- -- ??? These definitions are duplicated from System.OS_Interface
- -- because we don't want to depend on any package. Consider removing
- -- these declarations in System.OS_Interface and move these ones in
- -- the spec.
-
- type struct_timeval is record
- tv_sec : Integer;
- tv_usec : Integer;
- end record;
- pragma Convention (C, struct_timeval);
-
- procedure gettimeofday
- (tv : not null access struct_timeval;
- tz : Address := Null_Address);
- pragma Import (C, gettimeofday, "gettimeofday");
-
- procedure C_select
- (n : Integer := 0;
- readfds,
- writefds,
- exceptfds : Address := Null_Address;
- timeout : not null access struct_timeval);
- pragma Import (C, C_select, "select");
-
- -----------
- -- Clock --
- -----------
-
- function Clock return Duration is
- TV : aliased struct_timeval;
-
- begin
- gettimeofday (TV'Access);
- return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
- end Clock;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Time : Duration;
- Mode : Integer)
- is
- Rel_Time : Duration;
- Abs_Time : Duration;
- Base_Time : constant Duration := Clock;
- Check_Time : Duration := Base_Time;
- timeval : aliased struct_timeval;
-
- begin
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Time + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- loop
- timeval.tv_sec := Integer (Rel_Time);
-
- if Duration (timeval.tv_sec) > Rel_Time then
- timeval.tv_sec := timeval.tv_sec - 1;
- end if;
-
- timeval.tv_usec :=
- Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6);
-
- C_select (timeout => timeval'Unchecked_Access);
- Check_Time := Clock;
-
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
- end if;
- end Timed_Delay;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
-end System.OS_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ P R I M I T I V E S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for VxWorks targets
-
-with System.OS_Interface;
--- Since the thread library is part of the VxWorks kernel, using OS_Interface
--- is not a problem here, as long as we only use System.OS_Interface as a
--- set of C imported routines: using Ada routines from this package would
--- create a dependency on libgnarl in libgnat, which is not desirable.
-
-with System.OS_Constants;
-with Interfaces.C;
-
-package body System.OS_Primitives is
-
- use System.OS_Interface;
- use type Interfaces.C.int;
-
- package OSC renames System.OS_Constants;
-
- ------------------------
- -- Internal functions --
- ------------------------
-
- function To_Clock_Ticks (D : Duration) return int;
- -- Convert a duration value (in seconds) into clock ticks.
- -- Note that this routine is duplicated from System.OS_Interface since
- -- as explained above, we do not want to depend on libgnarl
-
- function To_Clock_Ticks (D : Duration) return int is
- Ticks : Long_Long_Integer;
- Rate_Duration : Duration;
- Ticks_Duration : Duration;
-
- begin
- if D < 0.0 then
- return -1;
- end if;
-
- -- Ensure that the duration can be converted to ticks
- -- at the current clock tick rate without overflowing.
-
- Rate_Duration := Duration (sysClkRateGet);
-
- if D > (Duration'Last / Rate_Duration) then
- Ticks := Long_Long_Integer (int'Last);
- else
- Ticks_Duration := D * Rate_Duration;
- Ticks := Long_Long_Integer (Ticks_Duration);
-
- if Ticks_Duration > Duration (Ticks) then
- Ticks := Ticks + 1;
- end if;
-
- if Ticks > Long_Long_Integer (int'Last) then
- Ticks := Long_Long_Integer (int'Last);
- end if;
- end if;
-
- return int (Ticks);
- end To_Clock_Ticks;
-
- -----------
- -- Clock --
- -----------
-
- function Clock return Duration is
- TS : aliased timespec;
- Result : int;
- begin
- Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
- pragma Assert (Result = 0);
- return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
- end Clock;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Time : Duration;
- Mode : Integer)
- is
- Rel_Time : Duration;
- Abs_Time : Duration;
- Base_Time : constant Duration := Clock;
- Check_Time : Duration := Base_Time;
- Ticks : int;
-
- Result : int;
- pragma Unreferenced (Result);
-
- begin
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Time + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- loop
- Ticks := To_Clock_Ticks (Rel_Time);
-
- if Mode = Relative and then Ticks < int'Last then
- -- The first tick will delay anytime between 0 and
- -- 1 / sysClkRateGet seconds, so we need to add one to
- -- be on the safe side.
-
- Ticks := Ticks + 1;
- end if;
-
- Result := taskDelay (Ticks);
- Check_Time := Clock;
-
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
- end if;
- end Timed_Delay;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
-end System.OS_Primitives;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ P R I M I T I V E S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2013-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version is for Linux/x32
-
-package body System.OS_Primitives is
-
- -- ??? These definitions are duplicated from System.OS_Interface
- -- because we don't want to depend on any package. Consider removing
- -- these declarations in System.OS_Interface and move these ones in
- -- the spec.
-
- type time_t is new Long_Long_Integer;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : Long_Long_Integer;
- end record;
- pragma Convention (C, timespec);
-
- function nanosleep (rqtp, rmtp : not null access timespec) return Integer;
- pragma Import (C, nanosleep, "nanosleep");
-
- -----------
- -- Clock --
- -----------
-
- function Clock return Duration is
- type timeval is array (1 .. 2) of Long_Long_Integer;
-
- procedure timeval_to_duration
- (T : not null access timeval;
- sec : not null access Long_Integer;
- usec : not null access Long_Integer);
- pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
-
- Micro : constant := 10**6;
- sec : aliased Long_Integer;
- usec : aliased Long_Integer;
- TV : aliased timeval;
- Result : Integer;
- pragma Unreferenced (Result);
-
- function gettimeofday
- (Tv : access timeval;
- Tz : System.Address := System.Null_Address) return Integer;
- pragma Import (C, gettimeofday, "gettimeofday");
-
- begin
- -- The return codes for gettimeofday are as follows (from man pages):
- -- EPERM settimeofday is called by someone other than the superuser
- -- EINVAL Timezone (or something else) is invalid
- -- EFAULT One of tv or tz pointed outside accessible address space
-
- -- None of these codes signal a potential clock skew, hence the return
- -- value is never checked.
-
- Result := gettimeofday (TV'Access, System.Null_Address);
- timeval_to_duration (TV'Access, sec'Access, usec'Access);
- return Duration (sec) + Duration (usec) / Micro;
- end Clock;
-
- -----------------
- -- To_Timespec --
- -----------------
-
- function To_Timespec (D : Duration) return timespec;
-
- function To_Timespec (D : Duration) return timespec is
- S : time_t;
- F : Duration;
-
- begin
- S := time_t (Long_Long_Integer (D));
- F := D - Duration (S);
-
- -- If F has negative value due to a round-up, adjust for positive F
- -- value.
-
- if F < 0.0 then
- S := S - 1;
- F := F + 1.0;
- end if;
-
- return
- timespec'(tv_sec => S,
- tv_nsec => Long_Long_Integer (F * 10#1#E9));
- end To_Timespec;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- procedure Timed_Delay
- (Time : Duration;
- Mode : Integer)
- is
- Request : aliased timespec;
- Remaind : aliased timespec;
- Rel_Time : Duration;
- Abs_Time : Duration;
- Base_Time : constant Duration := Clock;
- Check_Time : Duration := Base_Time;
-
- Result : Integer;
- pragma Unreferenced (Result);
-
- begin
- if Mode = Relative then
- Rel_Time := Time;
- Abs_Time := Time + Check_Time;
- else
- Rel_Time := Time - Check_Time;
- Abs_Time := Time;
- end if;
-
- if Rel_Time > 0.0 then
- loop
- Request := To_Timespec (Rel_Time);
- Result := nanosleep (Request'Access, Remaind'Access);
- Check_Time := Clock;
-
- exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
-
- Rel_Time := Abs_Time - Check_Time;
- end loop;
- end if;
- end Timed_Delay;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- null;
- end Initialize;
-
-end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for darwin
+
+package body System.OS_Primitives is
+
+ -- ??? These definitions are duplicated from System.OS_Interface
+ -- because we don't want to depend on any package. Consider removing
+ -- these declarations in System.OS_Interface and move these ones in
+ -- the spec.
+
+ type struct_timezone is record
+ tz_minuteswest : Integer;
+ tz_dsttime : Integer;
+ end record;
+ pragma Convention (C, struct_timezone);
+ type struct_timezone_ptr is access all struct_timezone;
+
+ type time_t is new Long_Integer;
+
+ type struct_timeval is record
+ tv_sec : time_t;
+ tv_usec : Integer;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ function gettimeofday
+ (tv : not null access struct_timeval;
+ tz : struct_timezone_ptr) return Integer;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : Long_Integer;
+ end record;
+ pragma Convention (C, timespec);
+
+ function nanosleep (rqtp, rmtp : not null access timespec) return Integer;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+ TV : aliased struct_timeval;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
+
+ begin
+ -- The return codes for gettimeofday are as follows (from man pages):
+ -- EPERM settimeofday is called by someone other than the superuser
+ -- EINVAL Timezone (or something else) is invalid
+ -- EFAULT One of tv or tz pointed outside accessible address space
+
+ -- None of these codes signal a potential clock skew, hence the return
+ -- value is never checked.
+
+ Result := gettimeofday (TV'Access, null);
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ end Clock;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec;
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return
+ timespec'(tv_sec => S,
+ tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Request : aliased timespec;
+ Remaind : aliased timespec;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Base_Time : constant Duration := Clock;
+ Check_Time : Duration := Base_Time;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ Request := To_Timespec (Rel_Time);
+ Result := nanosleep (Request'Access, Remaind'Access);
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides low level primitives used to implement clock and
+-- delays in non tasking applications, for LynxOS.
+
+-- The choice of the real clock/delay implementation (depending on whether
+-- tasking is involved or not) is done via soft links (see s-soflin.ads)
+
+-- NEVER add any dependency to tasking packages here
+
+package System.OS_Primitives is
+ pragma Preelaborate;
+
+ Max_Sensible_Delay : constant Duration := 16#10_0000.0#;
+ -- LynxOS does not support delays as long as half a year, so we set this to
+ -- a shorter, but still fairly long, duration. Experiments show that if
+ -- pthread_cond_timedwait is passed an abstime much greater than about
+ -- 2**21, it fails, returning EAGAIN. The cutoff is somewhere between
+ -- 16#20_8000.0# and 16#20_F000.0#. This behavior is not documented.
+
+ procedure Initialize;
+ -- Initialize global settings related to this package. This procedure
+ -- should be called before any other subprograms in this package. Note
+ -- that this procedure can be called several times.
+
+ function Clock return Duration;
+ pragma Inline (Clock);
+ -- Returns "absolute" time, represented as an offset relative to "the
+ -- Epoch", which is Jan 1, 1970 00:00:00 UTC on UNIX systems. This
+ -- implementation is affected by system's clock changes.
+
+ Relative : constant := 0;
+ Absolute_Calendar : constant := 1;
+ Absolute_RT : constant := 2;
+ -- Values for Mode call below. Note that the compiler (exp_ch9.adb) relies
+ -- on these values. So any change here must be reflected in corresponding
+ -- changes in the compiler.
+
+ procedure Timed_Delay (Time : Duration; Mode : Integer);
+ -- Implements the semantics of the delay statement when no tasking is used
+ -- in the application.
+ --
+ -- Mode is one of the three values above
+ --
+ -- Time is a relative or absolute duration value, depending on Mode.
+ --
+ -- Note that currently Ada.Real_Time always uses the tasking run time,
+ -- so this procedure should never be called with Mode set to Absolute_RT.
+ -- This may change in future or bare board implementations.
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the NT version of this package
+
+with System.Task_Lock;
+with System.Win32.Ext;
+
+package body System.OS_Primitives is
+
+ use System.Task_Lock;
+ use System.Win32;
+ use System.Win32.Ext;
+
+ ----------------------------------------
+ -- Data for the high resolution clock --
+ ----------------------------------------
+
+ Tick_Frequency : aliased LARGE_INTEGER;
+ -- Holds frequency of high-performance counter used by Clock
+ -- Windows NT uses a 1_193_182 Hz counter on PCs.
+
+ Base_Monotonic_Ticks : LARGE_INTEGER;
+ -- Holds the Tick count for the base monotonic time
+
+ Base_Monotonic_Clock : Duration;
+ -- Holds the current clock for monotonic clock's base time
+
+ type Clock_Data is record
+ Base_Ticks : LARGE_INTEGER;
+ -- Holds the Tick count for the base time
+
+ Base_Time : Long_Long_Integer;
+ -- Holds the base time used to check for system time change, used with
+ -- the standard clock.
+
+ Base_Clock : Duration;
+ -- Holds the current clock for the standard clock's base time
+ end record;
+
+ type Clock_Data_Access is access all Clock_Data;
+
+ -- Two base clock buffers. This is used to be able to update a buffer while
+ -- the other buffer is read. The point is that we do not want to use a lock
+ -- inside the Clock routine for performance reasons. We still use a lock
+ -- in the Get_Base_Time which is called very rarely. Current is a pointer,
+ -- the pragma Atomic is there to ensure that the value can be set or read
+ -- atomically. That's it, when Get_Base_Time has updated a buffer the
+ -- switch to the new value is done by changing Current pointer.
+
+ First, Second : aliased Clock_Data;
+
+ Current : Clock_Data_Access := First'Access;
+ pragma Atomic (Current);
+
+ -- The following signature is to detect change on the base clock data
+ -- above. The signature is a modular type, it will wrap around without
+ -- raising an exception. We would need to have exactly 2**32 updates of
+ -- the base data for the changes to get undetected.
+
+ type Signature_Type is mod 2**32;
+ Signature : Signature_Type := 0;
+ pragma Atomic (Signature);
+
+ function Monotonic_Clock return Duration;
+ pragma Export (Ada, Monotonic_Clock, "__gnat_monotonic_clock");
+ -- Return "absolute" time, represented as an offset relative to "the Unix
+ -- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is
+ -- immune to the system's clock changes. Export this function so that it
+ -- can be imported from s-taprop-mingw.adb without changing the shared
+ -- spec (s-osprim.ads).
+
+ procedure Get_Base_Time (Data : in out Clock_Data);
+ -- Retrieve the base time and base ticks. These values will be used by
+ -- clock to compute the current time by adding to it a fraction of the
+ -- performance counter. This is for the implementation of a high-resolution
+ -- clock. Note that this routine does not change the base monotonic values
+ -- used by the monotonic clock.
+
+ -----------
+ -- Clock --
+ -----------
+
+ -- This implementation of clock provides high resolution timer values
+ -- using QueryPerformanceCounter. This call return a 64 bits values (based
+ -- on the 8253 16 bits counter). This counter is updated every 1/1_193_182
+ -- times per seconds. The call to QueryPerformanceCounter takes 6
+ -- microsecs to complete.
+
+ function Clock return Duration is
+ Max_Shift : constant Duration := 2.0;
+ Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7;
+ Data : Clock_Data;
+ Current_Ticks : aliased LARGE_INTEGER;
+ Elap_Secs_Tick : Duration;
+ Elap_Secs_Sys : Duration;
+ Now : aliased Long_Long_Integer;
+ Sig1, Sig2 : Signature_Type;
+
+ begin
+ -- Try ten times to get a coherent set of base data. For this we just
+ -- check that the signature hasn't changed during the copy of the
+ -- current data.
+ --
+ -- This loop will always be done once if there is no interleaved call
+ -- to Get_Base_Time.
+
+ for K in 1 .. 10 loop
+ Sig1 := Signature;
+ Data := Current.all;
+ Sig2 := Signature;
+ exit when Sig1 = Sig2;
+ end loop;
+
+ if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then
+ return 0.0;
+ end if;
+
+ GetSystemTimeAsFileTime (Now'Access);
+
+ Elap_Secs_Sys :=
+ Duration (Long_Long_Float (abs (Now - Data.Base_Time)) /
+ Hundreds_Nano_In_Sec);
+
+ Elap_Secs_Tick :=
+ Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) /
+ Long_Long_Float (Tick_Frequency));
+
+ -- If we have a shift of more than Max_Shift seconds we resynchronize
+ -- the Clock. This is probably due to a manual Clock adjustment, a DST
+ -- adjustment or an NTP synchronisation. And we want to adjust the time
+ -- for this system (non-monotonic) clock.
+
+ if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then
+ Get_Base_Time (Data);
+
+ Elap_Secs_Tick :=
+ Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) /
+ Long_Long_Float (Tick_Frequency));
+ end if;
+
+ return Data.Base_Clock + Elap_Secs_Tick;
+ end Clock;
+
+ -------------------
+ -- Get_Base_Time --
+ -------------------
+
+ procedure Get_Base_Time (Data : in out Clock_Data) is
+
+ -- The resolution for GetSystemTime is 1 millisecond
+
+ -- The time to get both base times should take less than 1 millisecond.
+ -- Therefore, the elapsed time reported by GetSystemTime between both
+ -- actions should be null.
+
+ epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch
+ system_time_ns : constant := 100; -- 100 ns per tick
+ Sec_Unit : constant := 10#1#E9;
+
+ Max_Elapsed : constant LARGE_INTEGER :=
+ LARGE_INTEGER (Tick_Frequency / 100_000);
+ -- Look for a precision of 0.01 ms
+
+ Sig : constant Signature_Type := Signature;
+
+ Loc_Ticks, Ctrl_Ticks : aliased LARGE_INTEGER;
+ Loc_Time, Ctrl_Time : aliased Long_Long_Integer;
+ Elapsed : LARGE_INTEGER;
+ Current_Max : LARGE_INTEGER := LARGE_INTEGER'Last;
+ New_Data : Clock_Data_Access;
+
+ begin
+ -- Here we must be sure that both of these calls are done in a short
+ -- amount of time. Both are base time and should in theory be taken
+ -- at the very same time.
+
+ -- The goal of the following loop is to synchronize the system time
+ -- with the Win32 performance counter by getting a base offset for both.
+ -- Using these offsets it is then possible to compute actual time using
+ -- a performance counter which has a better precision than the Win32
+ -- time API.
+
+ -- Try at most 10 times to reach the best synchronisation (below 1
+ -- millisecond) otherwise the runtime will use the best value reached
+ -- during the runs.
+
+ Lock;
+
+ -- First check that the current value has not been updated. This
+ -- could happen if another task has called Clock at the same time
+ -- and that Max_Shift has been reached too.
+ --
+ -- But if the current value has been changed just before we entered
+ -- into the critical section, we can safely return as the current
+ -- base data (time, clock, ticks) have already been updated.
+
+ if Sig /= Signature then
+ Unlock;
+ return;
+ end if;
+
+ -- Check for the unused data buffer and set New_Data to point to it
+
+ if Current = First'Access then
+ New_Data := Second'Access;
+ else
+ New_Data := First'Access;
+ end if;
+
+ for K in 1 .. 10 loop
+ if QueryPerformanceCounter (Loc_Ticks'Access) = Win32.FALSE then
+ pragma Assert
+ (Standard.False,
+ "Could not query high performance counter in Clock");
+ null;
+ end if;
+
+ GetSystemTimeAsFileTime (Ctrl_Time'Access);
+
+ -- Scan for clock tick, will take up to 16ms/1ms depending on PC.
+ -- This cannot be an infinite loop or the system hardware is badly
+ -- damaged.
+
+ loop
+ GetSystemTimeAsFileTime (Loc_Time'Access);
+
+ if QueryPerformanceCounter (Ctrl_Ticks'Access) = Win32.FALSE then
+ pragma Assert
+ (Standard.False,
+ "Could not query high performance counter in Clock");
+ null;
+ end if;
+
+ exit when Loc_Time /= Ctrl_Time;
+ Loc_Ticks := Ctrl_Ticks;
+ end loop;
+
+ -- Check elapsed Performance Counter between samples
+ -- to choose the best one.
+
+ Elapsed := Ctrl_Ticks - Loc_Ticks;
+
+ if Elapsed < Current_Max then
+ New_Data.Base_Time := Loc_Time;
+ New_Data.Base_Ticks := Loc_Ticks;
+ Current_Max := Elapsed;
+
+ -- Exit the loop when we have reached the expected precision
+
+ exit when Elapsed <= Max_Elapsed;
+ end if;
+ end loop;
+
+ New_Data.Base_Clock :=
+ Duration
+ (Long_Long_Float
+ ((New_Data.Base_Time - epoch_1970) * system_time_ns) /
+ Long_Long_Float (Sec_Unit));
+
+ -- At this point all the base values have been set into the new data
+ -- record. Change the pointer (atomic operation) to these new values.
+
+ Current := New_Data;
+ Data := New_Data.all;
+
+ -- Set new signature for this data set
+
+ Signature := Signature + 1;
+
+ Unlock;
+
+ exception
+ when others =>
+ Unlock;
+ raise;
+ end Get_Base_Time;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ Current_Ticks : aliased LARGE_INTEGER;
+ Elap_Secs_Tick : Duration;
+
+ begin
+ if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then
+ return 0.0;
+
+ else
+ Elap_Secs_Tick :=
+ Duration (Long_Long_Float (Current_Ticks - Base_Monotonic_Ticks) /
+ Long_Long_Float (Tick_Frequency));
+ return Base_Monotonic_Clock + Elap_Secs_Tick;
+ end if;
+ end Monotonic_Clock;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay (Time : Duration; Mode : Integer) is
+ function Mode_Clock return Duration;
+ pragma Inline (Mode_Clock);
+ -- Return the current clock value using either the monotonic clock or
+ -- standard clock depending on the Mode value.
+
+ ----------------
+ -- Mode_Clock --
+ ----------------
+
+ function Mode_Clock return Duration is
+ begin
+ case Mode is
+ when Absolute_RT => return Monotonic_Clock;
+ when others => return Clock;
+ end case;
+ end Mode_Clock;
+
+ -- Local Variables
+
+ Base_Time : constant Duration := Mode_Clock;
+ -- Base_Time is used to detect clock set backward, in this case we
+ -- cannot ensure the delay accuracy.
+
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Check_Time : Duration := Base_Time;
+
+ -- Start of processing for Timed Delay
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ Sleep (DWORD (Rel_Time * 1000.0));
+ Check_Time := Mode_Clock;
+
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ Initialized : Boolean := False;
+
+ procedure Initialize is
+ begin
+ if Initialized then
+ return;
+ end if;
+
+ Initialized := True;
+
+ -- Get starting time as base
+
+ if QueryPerformanceFrequency (Tick_Frequency'Access) = Win32.FALSE then
+ raise Program_Error with
+ "cannot get high performance counter frequency";
+ end if;
+
+ Get_Base_Time (Current.all);
+
+ -- Keep base clock and ticks for the monotonic clock. These values
+ -- should never be changed to ensure proper behavior of the monotonic
+ -- clock.
+
+ Base_Monotonic_Clock := Current.Base_Clock;
+ Base_Monotonic_Ticks := Current.Base_Ticks;
+ end Initialize;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for POSIX-like operating systems
+
+package body System.OS_Primitives is
+
+ -- ??? These definitions are duplicated from System.OS_Interface
+ -- because we don't want to depend on any package. Consider removing
+ -- these declarations in System.OS_Interface and move these ones in
+ -- the spec.
+
+ type time_t is new Long_Integer;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : Long_Integer;
+ end record;
+ pragma Convention (C, timespec);
+
+ function nanosleep (rqtp, rmtp : not null access timespec) return Integer;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+
+ type timeval is array (1 .. 3) of Long_Integer;
+ -- The timeval array is sized to contain Long_Long_Integer sec and
+ -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then
+ -- it will be overly large but that will not effect the implementation
+ -- since it is not accessed directly.
+
+ procedure timeval_to_duration
+ (T : not null access timeval;
+ sec : not null access Long_Long_Integer;
+ usec : not null access Long_Integer);
+ pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
+
+ Micro : constant := 10**6;
+ sec : aliased Long_Long_Integer;
+ usec : aliased Long_Integer;
+ TV : aliased timeval;
+ Result : Integer;
+ pragma Unreferenced (Result);
+
+ function gettimeofday
+ (Tv : access timeval;
+ Tz : System.Address := System.Null_Address) return Integer;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ begin
+ -- The return codes for gettimeofday are as follows (from man pages):
+ -- EPERM settimeofday is called by someone other than the superuser
+ -- EINVAL Timezone (or something else) is invalid
+ -- EFAULT One of tv or tz pointed outside accessible address space
+
+ -- None of these codes signal a potential clock skew, hence the return
+ -- value is never checked.
+
+ Result := gettimeofday (TV'Access, System.Null_Address);
+ timeval_to_duration (TV'Access, sec'Access, usec'Access);
+ return Duration (sec) + Duration (usec) / Micro;
+ end Clock;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec;
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return
+ timespec'(tv_sec => S,
+ tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Request : aliased timespec;
+ Remaind : aliased timespec;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Base_Time : constant Duration := Clock;
+ Check_Time : Duration := Base_Time;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ Request := To_Timespec (Rel_Time);
+ Result := nanosleep (Request'Access, Remaind'Access);
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for POSIX.1-2008-like operating systems
+
+with System.CRTL;
+package body System.OS_Primitives is
+
+ -- ??? These definitions are duplicated from System.OS_Interface because
+ -- we don't want to depend on any package. Consider removing these
+ -- declarations in System.OS_Interface and move these ones to the spec.
+
+ type time_t is new System.CRTL.int64;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : Long_Integer;
+ end record;
+ pragma Convention (C, timespec);
+
+ function nanosleep (rqtp, rmtp : not null access timespec) return Integer;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+
+ type timeval is array (1 .. 3) of Long_Integer;
+ -- The timeval array is sized to contain Long_Long_Integer sec and
+ -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then
+ -- it will be overly large but that will not effect the implementation
+ -- since it is not accessed directly.
+
+ procedure timeval_to_duration
+ (T : not null access timeval;
+ sec : not null access Long_Long_Integer;
+ usec : not null access Long_Integer);
+ pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
+
+ Micro : constant := 10**6;
+ sec : aliased Long_Long_Integer;
+ usec : aliased Long_Integer;
+ TV : aliased timeval;
+ Result : Integer;
+ pragma Unreferenced (Result);
+
+ function gettimeofday
+ (Tv : access timeval;
+ Tz : System.Address := System.Null_Address) return Integer;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ begin
+ -- The return codes for gettimeofday are as follows (from man pages):
+ -- EPERM settimeofday is called by someone other than the superuser
+ -- EINVAL Timezone (or something else) is invalid
+ -- EFAULT One of tv or tz pointed outside accessible address space
+
+ -- None of these codes signal a potential clock skew, hence the return
+ -- value is never checked.
+
+ Result := gettimeofday (TV'Access, System.Null_Address);
+ timeval_to_duration (TV'Access, sec'Access, usec'Access);
+ return Duration (sec) + Duration (usec) / Micro;
+ end Clock;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec;
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return
+ timespec'(tv_sec => S,
+ tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Request : aliased timespec;
+ Remaind : aliased timespec;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Base_Time : constant Duration := Clock;
+ Check_Time : Duration := Base_Time;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ Request := To_Timespec (Rel_Time);
+ Result := nanosleep (Request'Access, Remaind'Access);
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version uses gettimeofday and select
+-- This file is suitable for Solaris (32 and 64 bits).
+
+package body System.OS_Primitives is
+
+ -- ??? These definitions are duplicated from System.OS_Interface
+ -- because we don't want to depend on any package. Consider removing
+ -- these declarations in System.OS_Interface and move these ones in
+ -- the spec.
+
+ type struct_timeval is record
+ tv_sec : Long_Integer;
+ tv_usec : Long_Integer;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ procedure gettimeofday
+ (tv : not null access struct_timeval;
+ tz : Address := Null_Address);
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ procedure C_select
+ (n : Integer := 0;
+ readfds,
+ writefds,
+ exceptfds : Address := Null_Address;
+ timeout : not null access struct_timeval);
+ pragma Import (C, C_select, "select");
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+ TV : aliased struct_timeval;
+
+ begin
+ gettimeofday (TV'Access);
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ end Clock;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Base_Time : constant Duration := Clock;
+ Check_Time : Duration := Base_Time;
+ timeval : aliased struct_timeval;
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ timeval.tv_sec := Long_Integer (Rel_Time);
+
+ if Duration (timeval.tv_sec) > Rel_Time then
+ timeval.tv_sec := timeval.tv_sec - 1;
+ end if;
+
+ timeval.tv_usec :=
+ Long_Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6);
+
+ C_select (timeout => timeval'Unchecked_Access);
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version uses gettimeofday and select
+-- This file is suitable for OpenNT, Dec Unix and SCO UnixWare.
+
+package body System.OS_Primitives is
+
+ -- ??? These definitions are duplicated from System.OS_Interface
+ -- because we don't want to depend on any package. Consider removing
+ -- these declarations in System.OS_Interface and move these ones in
+ -- the spec.
+
+ type struct_timeval is record
+ tv_sec : Integer;
+ tv_usec : Integer;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ procedure gettimeofday
+ (tv : not null access struct_timeval;
+ tz : Address := Null_Address);
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ procedure C_select
+ (n : Integer := 0;
+ readfds,
+ writefds,
+ exceptfds : Address := Null_Address;
+ timeout : not null access struct_timeval);
+ pragma Import (C, C_select, "select");
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+ TV : aliased struct_timeval;
+
+ begin
+ gettimeofday (TV'Access);
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ end Clock;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Base_Time : constant Duration := Clock;
+ Check_Time : Duration := Base_Time;
+ timeval : aliased struct_timeval;
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ timeval.tv_sec := Integer (Rel_Time);
+
+ if Duration (timeval.tv_sec) > Rel_Time then
+ timeval.tv_sec := timeval.tv_sec - 1;
+ end if;
+
+ timeval.tv_usec :=
+ Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6);
+
+ C_select (timeout => timeval'Unchecked_Access);
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for VxWorks targets
+
+with System.OS_Interface;
+-- Since the thread library is part of the VxWorks kernel, using OS_Interface
+-- is not a problem here, as long as we only use System.OS_Interface as a
+-- set of C imported routines: using Ada routines from this package would
+-- create a dependency on libgnarl in libgnat, which is not desirable.
+
+with System.OS_Constants;
+with Interfaces.C;
+
+package body System.OS_Primitives is
+
+ use System.OS_Interface;
+ use type Interfaces.C.int;
+
+ package OSC renames System.OS_Constants;
+
+ ------------------------
+ -- Internal functions --
+ ------------------------
+
+ function To_Clock_Ticks (D : Duration) return int;
+ -- Convert a duration value (in seconds) into clock ticks.
+ -- Note that this routine is duplicated from System.OS_Interface since
+ -- as explained above, we do not want to depend on libgnarl
+
+ function To_Clock_Ticks (D : Duration) return int is
+ Ticks : Long_Long_Integer;
+ Rate_Duration : Duration;
+ Ticks_Duration : Duration;
+
+ begin
+ if D < 0.0 then
+ return -1;
+ end if;
+
+ -- Ensure that the duration can be converted to ticks
+ -- at the current clock tick rate without overflowing.
+
+ Rate_Duration := Duration (sysClkRateGet);
+
+ if D > (Duration'Last / Rate_Duration) then
+ Ticks := Long_Long_Integer (int'Last);
+ else
+ Ticks_Duration := D * Rate_Duration;
+ Ticks := Long_Long_Integer (Ticks_Duration);
+
+ if Ticks_Duration > Duration (Ticks) then
+ Ticks := Ticks + 1;
+ end if;
+
+ if Ticks > Long_Long_Integer (int'Last) then
+ Ticks := Long_Long_Integer (int'Last);
+ end if;
+ end if;
+
+ return int (Ticks);
+ end To_Clock_Ticks;
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+ TS : aliased timespec;
+ Result : int;
+ begin
+ Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9;
+ end Clock;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Base_Time : constant Duration := Clock;
+ Check_Time : Duration := Base_Time;
+ Ticks : int;
+
+ Result : int;
+ pragma Unreferenced (Result);
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ Ticks := To_Clock_Ticks (Rel_Time);
+
+ if Mode = Relative and then Ticks < int'Last then
+ -- The first tick will delay anytime between 0 and
+ -- 1 / sysClkRateGet seconds, so we need to add one to
+ -- be on the safe side.
+
+ Ticks := Ticks + 1;
+ end if;
+
+ Result := taskDelay (Ticks);
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2013-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for Linux/x32
+
+package body System.OS_Primitives is
+
+ -- ??? These definitions are duplicated from System.OS_Interface
+ -- because we don't want to depend on any package. Consider removing
+ -- these declarations in System.OS_Interface and move these ones in
+ -- the spec.
+
+ type time_t is new Long_Long_Integer;
+
+ type timespec is record
+ tv_sec : time_t;
+ tv_nsec : Long_Long_Integer;
+ end record;
+ pragma Convention (C, timespec);
+
+ function nanosleep (rqtp, rmtp : not null access timespec) return Integer;
+ pragma Import (C, nanosleep, "nanosleep");
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+ type timeval is array (1 .. 2) of Long_Long_Integer;
+
+ procedure timeval_to_duration
+ (T : not null access timeval;
+ sec : not null access Long_Integer;
+ usec : not null access Long_Integer);
+ pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration");
+
+ Micro : constant := 10**6;
+ sec : aliased Long_Integer;
+ usec : aliased Long_Integer;
+ TV : aliased timeval;
+ Result : Integer;
+ pragma Unreferenced (Result);
+
+ function gettimeofday
+ (Tv : access timeval;
+ Tz : System.Address := System.Null_Address) return Integer;
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ begin
+ -- The return codes for gettimeofday are as follows (from man pages):
+ -- EPERM settimeofday is called by someone other than the superuser
+ -- EINVAL Timezone (or something else) is invalid
+ -- EFAULT One of tv or tz pointed outside accessible address space
+
+ -- None of these codes signal a potential clock skew, hence the return
+ -- value is never checked.
+
+ Result := gettimeofday (TV'Access, System.Null_Address);
+ timeval_to_duration (TV'Access, sec'Access, usec'Access);
+ return Duration (sec) + Duration (usec) / Micro;
+ end Clock;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec;
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return
+ timespec'(tv_sec => S,
+ tv_nsec => Long_Long_Integer (F * 10#1#E9));
+ end To_Timespec;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Request : aliased timespec;
+ Remaind : aliased timespec;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Base_Time : constant Duration := Clock;
+ Check_Time : Duration := Base_Time;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ Request := To_Timespec (Rel_Time);
+ Result := nanosleep (Request'Access, Remaind'Access);
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time or else Check_Time < Base_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ null;
+ end Initialize;
+
+end System.OS_Primitives;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . O S _ V E R S I O N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2010-2017, AdaCore --
+-- --
+-- 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/>. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks 653 Partition OS version of this file. If you add an OS
+-- variant please be sure to update type OS_Version in all variants of this
+-- file, which is part of the Level A certified run-time libraries.
+
+package System.OS_Versions is
+ pragma Pure (System.OS_Versions);
+ type OS_Version is
+ (LynxOS_178, VxWorks_Cert, VxWorks_Cert_RTP, VxWorks_653, VxWorks_MILS);
+ OS : constant OS_Version := VxWorks_653;
+end System.OS_Versions;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . P A R A M E T E R S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
--- Version is used by VxWorks 653, VxWorks MILS, and VxWorks6 cert Ravenscar
-
--- This package defines some system dependent parameters for GNAT. These
--- are values that are referenced by the runtime library and are therefore
--- relevant to the target machine.
-
--- The parameters whose value is defined in the spec are not generally
--- expected to be changed. If they are changed, it will be necessary to
--- recompile the run-time library.
-
--- The parameters which are defined by functions can be changed by modifying
--- the body of System.Parameters in file s-parame.adb. A change to this body
--- requires only rebinding and relinking of the application.
-
--- Note: do not introduce any pragma Inline statements into this unit, since
--- otherwise the relinking and rebinding capability would be deactivated.
-
-package System.Parameters is
- pragma Pure;
-
- ---------------------------------------
- -- Task And Stack Allocation Control --
- ---------------------------------------
-
- type Task_Storage_Size is new Integer;
- -- Type used in tasking units for task storage size
-
- type Size_Type is new Task_Storage_Size;
- -- Type used to provide task storage size to runtime
-
- Unspecified_Size : constant Size_Type := Size_Type'First;
- -- Value used to indicate that no size type is set
-
- subtype Percentage is Size_Type range -1 .. 100;
- Dynamic : constant Size_Type := -1;
- -- The secondary stack ratio is a constant between 0 and 100 which
- -- determines the percentage of the allocated task stack that is
- -- used by the secondary stack (the rest being the primary stack).
- -- The special value of minus one indicates that the secondary
- -- stack is to be allocated from the heap instead.
-
- Sec_Stack_Percentage : constant Percentage := 25;
- -- This constant defines the handling of the secondary stack
-
- Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic;
- -- Convenient Boolean for testing for dynamic secondary stack
-
- function Default_Stack_Size return Size_Type;
- -- Default task stack size used if none is specified
-
- function Minimum_Stack_Size return Size_Type;
- -- Minimum task stack size permitted
-
- function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
- -- Given the storage size stored in the TCB, return the Storage_Size
- -- value required by the RM for the Storage_Size attribute. The
- -- required adjustment is as follows:
- --
- -- when Size = Unspecified_Size, return Default_Stack_Size
- -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
- -- otherwise return given Size
-
- Default_Env_Stack_Size : constant Size_Type := 14_336;
- -- Assumed size of the environment task, if no other information
- -- is available. This value is used when stack checking is
- -- enabled and no GNAT_STACK_LIMIT environment variable is set.
- -- This value is chosen as the VxWorks default stack size is 20kB,
- -- and a little more than 4kB is necessary for the run time.
-
- Stack_Grows_Down : constant Boolean := True;
- -- This constant indicates whether the stack grows up (False) or
- -- down (True) in memory as functions are called. It is used for
- -- proper implementation of the stack overflow check.
-
- ----------------------------------------------
- -- Characteristics of types in Interfaces.C --
- ----------------------------------------------
-
- long_bits : constant := Long_Integer'Size;
- -- Number of bits in type long and unsigned_long. The normal convention
- -- is that this is the same as type Long_Integer, but this may not be true
- -- of all targets.
-
- ptr_bits : constant := Standard'Address_Size;
- subtype C_Address is System.Address;
- -- Number of bits in Interfaces.C pointers, normally a standard address
-
- C_Malloc_Linkname : constant String := "__gnat_malloc";
- -- Name of runtime function used to allocate such a pointer
-
- ----------------------------------------------
- -- Behavior of Pragma Finalize_Storage_Only --
- ----------------------------------------------
-
- -- Garbage_Collected is a Boolean constant whose value indicates the
- -- effect of the pragma Finalize_Storage_Entry on a controlled type.
-
- -- Garbage_Collected = False
-
- -- The system releases all storage on program termination only,
- -- but not other garbage collection occurs, so finalization calls
- -- are omitted only for outer level objects can be omitted if
- -- pragma Finalize_Storage_Only is used.
-
- -- Garbage_Collected = True
-
- -- The system provides full garbage collection, so it is never
- -- necessary to release storage for controlled objects for which
- -- a pragma Finalize_Storage_Only is used.
-
- Garbage_Collected : constant Boolean := False;
- -- The storage mode for this system (release on program exit)
-
- ---------------------
- -- Tasking Profile --
- ---------------------
-
- -- In the following sections, constant parameters are defined to
- -- allow some optimizations and fine tuning within the tasking run time
- -- based on restrictions on the tasking features.
-
- ----------------------
- -- Locking Strategy --
- ----------------------
-
- Single_Lock : constant Boolean := False;
- -- Indicates whether a single lock should be used within the tasking
- -- run-time to protect internal structures. If True, a single lock
- -- will be used, meaning less locking/unlocking operations, but also
- -- more global contention. In general, Single_Lock should be set to
- -- True on single processor machines, and to False to multi-processor
- -- systems, but this can vary from application to application and also
- -- depends on the scheduling policy.
-
- -------------------
- -- Task Abortion --
- -------------------
-
- No_Abort : constant Boolean := False;
- -- This constant indicates whether abort statements and asynchronous
- -- transfer of control (ATC) are disallowed. If set to True, it is
- -- assumed that neither construct is used, and the run time does not
- -- need to defer/undefer abort and check for pending actions at
- -- completion points. A value of True for No_Abort corresponds to:
- -- pragma Restrictions (No_Abort_Statements);
- -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
-
- ---------------------
- -- Task Attributes --
- ---------------------
-
- Max_Attribute_Count : constant := 8;
- -- Number of task attributes stored in the task control block
-
- -----------------------
- -- Task Image Length --
- -----------------------
-
- Max_Task_Image_Length : constant := 32;
- -- This constant specifies the maximum length of a task's image
-
- ------------------------------
- -- Exception Message Length --
- ------------------------------
-
- Default_Exception_Msg_Max_Length : constant := 200;
- -- This constant specifies the default number of characters to allow
- -- in an exception message (200 is minimum required by RM 11.4.1(18)).
-
-end System.Parameters;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . P A R A M E T E R S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the HP version of this package
-
--- This package defines some system dependent parameters for GNAT. These
--- are values that are referenced by the runtime library and are therefore
--- relevant to the target machine.
-
--- The parameters whose value is defined in the spec are not generally
--- expected to be changed. If they are changed, it will be necessary to
--- recompile the run-time library.
-
--- The parameters which are defined by functions can be changed by modifying
--- the body of System.Parameters in file s-parame.adb. A change to this body
--- requires only rebinding and relinking of the application.
-
--- Note: do not introduce any pragma Inline statements into this unit, since
--- otherwise the relinking and rebinding capability would be deactivated.
-
-package System.Parameters is
- pragma Pure;
-
- ---------------------------------------
- -- Task And Stack Allocation Control --
- ---------------------------------------
-
- type Task_Storage_Size is new Integer;
- -- Type used in tasking units for task storage size
-
- type Size_Type is new Task_Storage_Size;
- -- Type used to provide task storage size to runtime
-
- Unspecified_Size : constant Size_Type := Size_Type'First;
- -- Value used to indicate that no size type is set
-
- subtype Percentage is Size_Type range -1 .. 100;
- Dynamic : constant Size_Type := -1;
- -- The secondary stack ratio is a constant between 0 and 100 which
- -- determines the percentage of the allocated task stack that is
- -- used by the secondary stack (the rest being the primary stack).
- -- The special value of minus one indicates that the secondary
- -- stack is to be allocated from the heap instead.
-
- Sec_Stack_Percentage : constant Percentage := Dynamic;
- -- This constant defines the handling of the secondary stack
-
- Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic;
- -- Convenient Boolean for testing for dynamic secondary stack
-
- function Default_Stack_Size return Size_Type;
- -- Default task stack size used if none is specified
-
- function Minimum_Stack_Size return Size_Type;
- -- Minimum task stack size permitted
-
- function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
- -- Given the storage size stored in the TCB, return the Storage_Size
- -- value required by the RM for the Storage_Size attribute. The
- -- required adjustment is as follows:
- --
- -- when Size = Unspecified_Size, return Default_Stack_Size
- -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
- -- otherwise return given Size
-
- Default_Env_Stack_Size : constant Size_Type := 8_192_000;
- -- Assumed size of the environment task, if no other information
- -- is available. This value is used when stack checking is
- -- enabled and no GNAT_STACK_LIMIT environment variable is set.
-
- Stack_Grows_Down : constant Boolean := False;
- -- This constant indicates whether the stack grows up (False) or
- -- down (True) in memory as functions are called. It is used for
- -- proper implementation of the stack overflow check.
-
- ----------------------------------------------
- -- Characteristics of Types in Interfaces.C --
- ----------------------------------------------
-
- long_bits : constant := Long_Integer'Size;
- -- Number of bits in type long and unsigned_long. The normal convention
- -- is that this is the same as type Long_Integer, but this may not be true
- -- of all targets.
-
- ptr_bits : constant := Standard'Address_Size;
- subtype C_Address is System.Address;
- -- Number of bits in Interfaces.C pointers, normally a standard address
-
- C_Malloc_Linkname : constant String := "__gnat_malloc";
- -- Name of runtime function used to allocate such a pointer
-
- ----------------------------------------------
- -- Behavior of Pragma Finalize_Storage_Only --
- ----------------------------------------------
-
- -- Garbage_Collected is a Boolean constant whose value indicates the
- -- effect of the pragma Finalize_Storage_Entry on a controlled type.
-
- -- Garbage_Collected = False
-
- -- The system releases all storage on program termination only,
- -- but not other garbage collection occurs, so finalization calls
- -- are omitted only for outer level objects can be omitted if
- -- pragma Finalize_Storage_Only is used.
-
- -- Garbage_Collected = True
-
- -- The system provides full garbage collection, so it is never
- -- necessary to release storage for controlled objects for which
- -- a pragma Finalize_Storage_Only is used.
-
- Garbage_Collected : constant Boolean := False;
- -- The storage mode for this system (release on program exit)
-
- ---------------------
- -- Tasking Profile --
- ---------------------
-
- -- In the following sections, constant parameters are defined to
- -- allow some optimizations and fine tuning within the tasking run time
- -- based on restrictions on the tasking features.
-
- ----------------------
- -- Locking Strategy --
- ----------------------
-
- Single_Lock : constant Boolean := False;
- -- Indicates whether a single lock should be used within the tasking
- -- run-time to protect internal structures. If True, a single lock
- -- will be used, meaning less locking/unlocking operations, but also
- -- more global contention. In general, Single_Lock should be set to
- -- True on single processor machines, and to False to multi-processor
- -- systems, but this can vary from application to application and also
- -- depends on the scheduling policy.
-
- -------------------
- -- Task Abortion --
- -------------------
-
- No_Abort : constant Boolean := False;
- -- This constant indicates whether abort statements and asynchronous
- -- transfer of control (ATC) are disallowed. If set to True, it is
- -- assumed that neither construct is used, and the run time does not
- -- need to defer/undefer abort and check for pending actions at
- -- completion points. A value of True for No_Abort corresponds to:
- -- pragma Restrictions (No_Abort_Statements);
- -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
-
- ---------------------
- -- Task Attributes --
- ---------------------
-
- Max_Attribute_Count : constant := 32;
- -- Number of task attributes stored in the task control block
-
- -----------------------
- -- Task Image Length --
- -----------------------
-
- Max_Task_Image_Length : constant := 256;
- -- This constant specifies the maximum length of a task's image
-
- ------------------------------
- -- Exception Message Length --
- ------------------------------
-
- Default_Exception_Msg_Max_Length : constant := 200;
- -- This constant specifies the default number of characters to allow
- -- in an exception message (200 is minimum required by RM 11.4.1(18)).
-
-end System.Parameters;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . P A R A M E T E R S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1997-2009 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the RTEMS specific version
-
-with Interfaces.C;
-
-package body System.Parameters is
-
- function ada_pthread_minimum_stack_size return Interfaces.C.size_t;
- pragma Import (C, ada_pthread_minimum_stack_size,
- "_ada_pthread_minimum_stack_size");
-
- ------------------------
- -- Default_Stack_Size --
- ------------------------
-
- function Default_Stack_Size return Size_Type is
- begin
- return Size_Type (ada_pthread_minimum_stack_size);
- end Default_Stack_Size;
-
- ------------------------
- -- Minimum_Stack_Size --
- ------------------------
-
- function Minimum_Stack_Size return Size_Type is
-
- begin
- return Size_Type (ada_pthread_minimum_stack_size);
- end Minimum_Stack_Size;
-
- -------------------------
- -- Adjust_Storage_Size --
- -------------------------
-
- function Adjust_Storage_Size (Size : Size_Type) return Size_Type is
- begin
- if Size = Unspecified_Size then
- return Default_Stack_Size;
-
- elsif Size < Minimum_Stack_Size then
- return Minimum_Stack_Size;
-
- else
- return Size;
- end if;
- end Adjust_Storage_Size;
-
-end System.Parameters;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . P A R A M E T E R S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1995-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
--- Version used on all VxWorks targets
-
-package body System.Parameters is
-
- -------------------------
- -- Adjust_Storage_Size --
- -------------------------
-
- function Adjust_Storage_Size (Size : Size_Type) return Size_Type is
- begin
- if Size = Unspecified_Size then
- return Default_Stack_Size;
- elsif Size < Minimum_Stack_Size then
- return Minimum_Stack_Size;
- else
- return Size;
- end if;
- end Adjust_Storage_Size;
-
- ------------------------
- -- Default_Stack_Size --
- ------------------------
-
- function Default_Stack_Size return Size_Type is
- Default_Stack_Size : Integer;
- pragma Import (C, Default_Stack_Size, "__gl_default_stack_size");
- begin
- if Default_Stack_Size = -1 then
- if Stack_Check_Limits then
- return 32 * 1024;
- -- Extra stack to allow for 12K exception area.
- else
- return 20 * 1024;
- end if;
- else
- return Size_Type (Default_Stack_Size);
- end if;
- end Default_Stack_Size;
-
- ------------------------
- -- Minimum_Stack_Size --
- ------------------------
-
- function Minimum_Stack_Size return Size_Type is
- begin
- return 8 * 1024;
- end Minimum_Stack_Size;
-
-end System.Parameters;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . P A R A M E T E R S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the default VxWorks version of the package
-
--- This package defines some system dependent parameters for GNAT. These
--- are values that are referenced by the runtime library and are therefore
--- relevant to the target machine.
-
--- The parameters whose value is defined in the spec are not generally
--- expected to be changed. If they are changed, it will be necessary to
--- recompile the run-time library.
-
--- The parameters which are defined by functions can be changed by modifying
--- the body of System.Parameters in file s-parame.adb. A change to this body
--- requires only rebinding and relinking of the application.
-
--- Note: do not introduce any pragma Inline statements into this unit, since
--- otherwise the relinking and rebinding capability would be deactivated.
-
-package System.Parameters is
- pragma Pure;
-
- ---------------------------------------
- -- Task And Stack Allocation Control --
- ---------------------------------------
-
- type Task_Storage_Size is new Integer;
- -- Type used in tasking units for task storage size
-
- type Size_Type is new Task_Storage_Size;
- -- Type used to provide task storage size to runtime
-
- Unspecified_Size : constant Size_Type := Size_Type'First;
- -- Value used to indicate that no size type is set
-
- subtype Percentage is Size_Type range -1 .. 100;
- Dynamic : constant Size_Type := -1;
- -- The secondary stack ratio is a constant between 0 and 100 which
- -- determines the percentage of the allocated task stack that is
- -- used by the secondary stack (the rest being the primary stack).
- -- The special value of minus one indicates that the secondary
- -- stack is to be allocated from the heap instead.
-
- Sec_Stack_Percentage : constant Percentage := Dynamic;
- -- This constant defines the handling of the secondary stack
-
- Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic;
- -- Convenient Boolean for testing for dynamic secondary stack
-
- function Default_Stack_Size return Size_Type;
- -- Default task stack size used if none is specified
-
- function Minimum_Stack_Size return Size_Type;
- -- Minimum task stack size permitted
-
- function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
- -- Given the storage size stored in the TCB, return the Storage_Size
- -- value required by the RM for the Storage_Size attribute. The
- -- required adjustment is as follows:
- --
- -- when Size = Unspecified_Size, return Default_Stack_Size
- -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
- -- otherwise return given Size
-
- Default_Env_Stack_Size : constant Size_Type := 14_336;
- -- Assumed size of the environment task, if no other information
- -- is available. This value is used when stack checking is
- -- enabled and no GNAT_STACK_LIMIT environment variable is set.
- -- This value is chosen as the VxWorks default stack size is 20kB,
- -- and a little more than 4kB is necessary for the run time.
-
- Stack_Grows_Down : constant Boolean := True;
- -- This constant indicates whether the stack grows up (False) or
- -- down (True) in memory as functions are called. It is used for
- -- proper implementation of the stack overflow check.
-
- ----------------------------------------------
- -- Characteristics of types in Interfaces.C --
- ----------------------------------------------
-
- long_bits : constant := Long_Integer'Size;
- -- Number of bits in type long and unsigned_long. The normal convention
- -- is that this is the same as type Long_Integer, but this may not be true
- -- of all targets.
-
- ptr_bits : constant := Standard'Address_Size;
- subtype C_Address is System.Address;
- -- Number of bits in Interfaces.C pointers, normally a standard address
-
- C_Malloc_Linkname : constant String := "__gnat_malloc";
- -- Name of runtime function used to allocate such a pointer
-
- ----------------------------------------------
- -- Behavior of Pragma Finalize_Storage_Only --
- ----------------------------------------------
-
- -- Garbage_Collected is a Boolean constant whose value indicates the
- -- effect of the pragma Finalize_Storage_Entry on a controlled type.
-
- -- Garbage_Collected = False
-
- -- The system releases all storage on program termination only,
- -- but not other garbage collection occurs, so finalization calls
- -- are omitted only for outer level objects can be omitted if
- -- pragma Finalize_Storage_Only is used.
-
- -- Garbage_Collected = True
-
- -- The system provides full garbage collection, so it is never
- -- necessary to release storage for controlled objects for which
- -- a pragma Finalize_Storage_Only is used.
-
- Garbage_Collected : constant Boolean := False;
- -- The storage mode for this system (release on program exit)
-
- ---------------------
- -- Tasking Profile --
- ---------------------
-
- -- In the following sections, constant parameters are defined to
- -- allow some optimizations and fine tuning within the tasking run time
- -- based on restrictions on the tasking features.
-
- ----------------------
- -- Locking Strategy --
- ----------------------
-
- Single_Lock : constant Boolean := False;
- -- Indicates whether a single lock should be used within the tasking
- -- run-time to protect internal structures. If True, a single lock
- -- will be used, meaning less locking/unlocking operations, but also
- -- more global contention. In general, Single_Lock should be set to
- -- True on single processor machines, and to False to multi-processor
- -- systems, but this can vary from application to application and also
- -- depends on the scheduling policy.
-
- -------------------
- -- Task Abortion --
- -------------------
-
- No_Abort : constant Boolean := False;
- -- This constant indicates whether abort statements and asynchronous
- -- transfer of control (ATC) are disallowed. If set to True, it is
- -- assumed that neither construct is used, and the run time does not
- -- need to defer/undefer abort and check for pending actions at
- -- completion points. A value of True for No_Abort corresponds to:
- -- pragma Restrictions (No_Abort_Statements);
- -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
-
- ---------------------
- -- Task Attributes --
- ---------------------
-
- Max_Attribute_Count : constant := 16;
- -- Number of task attributes stored in the task control block
-
- -----------------------
- -- Task Image Length --
- -----------------------
-
- Max_Task_Image_Length : constant := 32;
- -- This constant specifies the maximum length of a task's image
-
- ------------------------------
- -- Exception Message Length --
- ------------------------------
-
- Default_Exception_Msg_Max_Length : constant := 200;
- -- This constant specifies the default number of characters to allow
- -- in an exception message (200 is minimum required by RM 11.4.1(18)).
-
-end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Version is used by VxWorks 653, VxWorks MILS, and VxWorks6 cert Ravenscar
+
+-- This package defines some system dependent parameters for GNAT. These
+-- are values that are referenced by the runtime library and are therefore
+-- relevant to the target machine.
+
+-- The parameters whose value is defined in the spec are not generally
+-- expected to be changed. If they are changed, it will be necessary to
+-- recompile the run-time library.
+
+-- The parameters which are defined by functions can be changed by modifying
+-- the body of System.Parameters in file s-parame.adb. A change to this body
+-- requires only rebinding and relinking of the application.
+
+-- Note: do not introduce any pragma Inline statements into this unit, since
+-- otherwise the relinking and rebinding capability would be deactivated.
+
+package System.Parameters is
+ pragma Pure;
+
+ ---------------------------------------
+ -- Task And Stack Allocation Control --
+ ---------------------------------------
+
+ type Task_Storage_Size is new Integer;
+ -- Type used in tasking units for task storage size
+
+ type Size_Type is new Task_Storage_Size;
+ -- Type used to provide task storage size to runtime
+
+ Unspecified_Size : constant Size_Type := Size_Type'First;
+ -- Value used to indicate that no size type is set
+
+ subtype Percentage is Size_Type range -1 .. 100;
+ Dynamic : constant Size_Type := -1;
+ -- The secondary stack ratio is a constant between 0 and 100 which
+ -- determines the percentage of the allocated task stack that is
+ -- used by the secondary stack (the rest being the primary stack).
+ -- The special value of minus one indicates that the secondary
+ -- stack is to be allocated from the heap instead.
+
+ Sec_Stack_Percentage : constant Percentage := 25;
+ -- This constant defines the handling of the secondary stack
+
+ Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic;
+ -- Convenient Boolean for testing for dynamic secondary stack
+
+ function Default_Stack_Size return Size_Type;
+ -- Default task stack size used if none is specified
+
+ function Minimum_Stack_Size return Size_Type;
+ -- Minimum task stack size permitted
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
+ -- Given the storage size stored in the TCB, return the Storage_Size
+ -- value required by the RM for the Storage_Size attribute. The
+ -- required adjustment is as follows:
+ --
+ -- when Size = Unspecified_Size, return Default_Stack_Size
+ -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
+ -- otherwise return given Size
+
+ Default_Env_Stack_Size : constant Size_Type := 14_336;
+ -- Assumed size of the environment task, if no other information
+ -- is available. This value is used when stack checking is
+ -- enabled and no GNAT_STACK_LIMIT environment variable is set.
+ -- This value is chosen as the VxWorks default stack size is 20kB,
+ -- and a little more than 4kB is necessary for the run time.
+
+ Stack_Grows_Down : constant Boolean := True;
+ -- This constant indicates whether the stack grows up (False) or
+ -- down (True) in memory as functions are called. It is used for
+ -- proper implementation of the stack overflow check.
+
+ ----------------------------------------------
+ -- Characteristics of types in Interfaces.C --
+ ----------------------------------------------
+
+ long_bits : constant := Long_Integer'Size;
+ -- Number of bits in type long and unsigned_long. The normal convention
+ -- is that this is the same as type Long_Integer, but this may not be true
+ -- of all targets.
+
+ ptr_bits : constant := Standard'Address_Size;
+ subtype C_Address is System.Address;
+ -- Number of bits in Interfaces.C pointers, normally a standard address
+
+ C_Malloc_Linkname : constant String := "__gnat_malloc";
+ -- Name of runtime function used to allocate such a pointer
+
+ ----------------------------------------------
+ -- Behavior of Pragma Finalize_Storage_Only --
+ ----------------------------------------------
+
+ -- Garbage_Collected is a Boolean constant whose value indicates the
+ -- effect of the pragma Finalize_Storage_Entry on a controlled type.
+
+ -- Garbage_Collected = False
+
+ -- The system releases all storage on program termination only,
+ -- but not other garbage collection occurs, so finalization calls
+ -- are omitted only for outer level objects can be omitted if
+ -- pragma Finalize_Storage_Only is used.
+
+ -- Garbage_Collected = True
+
+ -- The system provides full garbage collection, so it is never
+ -- necessary to release storage for controlled objects for which
+ -- a pragma Finalize_Storage_Only is used.
+
+ Garbage_Collected : constant Boolean := False;
+ -- The storage mode for this system (release on program exit)
+
+ ---------------------
+ -- Tasking Profile --
+ ---------------------
+
+ -- In the following sections, constant parameters are defined to
+ -- allow some optimizations and fine tuning within the tasking run time
+ -- based on restrictions on the tasking features.
+
+ ----------------------
+ -- Locking Strategy --
+ ----------------------
+
+ Single_Lock : constant Boolean := False;
+ -- Indicates whether a single lock should be used within the tasking
+ -- run-time to protect internal structures. If True, a single lock
+ -- will be used, meaning less locking/unlocking operations, but also
+ -- more global contention. In general, Single_Lock should be set to
+ -- True on single processor machines, and to False to multi-processor
+ -- systems, but this can vary from application to application and also
+ -- depends on the scheduling policy.
+
+ -------------------
+ -- Task Abortion --
+ -------------------
+
+ No_Abort : constant Boolean := False;
+ -- This constant indicates whether abort statements and asynchronous
+ -- transfer of control (ATC) are disallowed. If set to True, it is
+ -- assumed that neither construct is used, and the run time does not
+ -- need to defer/undefer abort and check for pending actions at
+ -- completion points. A value of True for No_Abort corresponds to:
+ -- pragma Restrictions (No_Abort_Statements);
+ -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
+
+ ---------------------
+ -- Task Attributes --
+ ---------------------
+
+ Max_Attribute_Count : constant := 8;
+ -- Number of task attributes stored in the task control block
+
+ -----------------------
+ -- Task Image Length --
+ -----------------------
+
+ Max_Task_Image_Length : constant := 32;
+ -- This constant specifies the maximum length of a task's image
+
+ ------------------------------
+ -- Exception Message Length --
+ ------------------------------
+
+ Default_Exception_Msg_Max_Length : constant := 200;
+ -- This constant specifies the default number of characters to allow
+ -- in an exception message (200 is minimum required by RM 11.4.1(18)).
+
+end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the HP version of this package
+
+-- This package defines some system dependent parameters for GNAT. These
+-- are values that are referenced by the runtime library and are therefore
+-- relevant to the target machine.
+
+-- The parameters whose value is defined in the spec are not generally
+-- expected to be changed. If they are changed, it will be necessary to
+-- recompile the run-time library.
+
+-- The parameters which are defined by functions can be changed by modifying
+-- the body of System.Parameters in file s-parame.adb. A change to this body
+-- requires only rebinding and relinking of the application.
+
+-- Note: do not introduce any pragma Inline statements into this unit, since
+-- otherwise the relinking and rebinding capability would be deactivated.
+
+package System.Parameters is
+ pragma Pure;
+
+ ---------------------------------------
+ -- Task And Stack Allocation Control --
+ ---------------------------------------
+
+ type Task_Storage_Size is new Integer;
+ -- Type used in tasking units for task storage size
+
+ type Size_Type is new Task_Storage_Size;
+ -- Type used to provide task storage size to runtime
+
+ Unspecified_Size : constant Size_Type := Size_Type'First;
+ -- Value used to indicate that no size type is set
+
+ subtype Percentage is Size_Type range -1 .. 100;
+ Dynamic : constant Size_Type := -1;
+ -- The secondary stack ratio is a constant between 0 and 100 which
+ -- determines the percentage of the allocated task stack that is
+ -- used by the secondary stack (the rest being the primary stack).
+ -- The special value of minus one indicates that the secondary
+ -- stack is to be allocated from the heap instead.
+
+ Sec_Stack_Percentage : constant Percentage := Dynamic;
+ -- This constant defines the handling of the secondary stack
+
+ Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic;
+ -- Convenient Boolean for testing for dynamic secondary stack
+
+ function Default_Stack_Size return Size_Type;
+ -- Default task stack size used if none is specified
+
+ function Minimum_Stack_Size return Size_Type;
+ -- Minimum task stack size permitted
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
+ -- Given the storage size stored in the TCB, return the Storage_Size
+ -- value required by the RM for the Storage_Size attribute. The
+ -- required adjustment is as follows:
+ --
+ -- when Size = Unspecified_Size, return Default_Stack_Size
+ -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
+ -- otherwise return given Size
+
+ Default_Env_Stack_Size : constant Size_Type := 8_192_000;
+ -- Assumed size of the environment task, if no other information
+ -- is available. This value is used when stack checking is
+ -- enabled and no GNAT_STACK_LIMIT environment variable is set.
+
+ Stack_Grows_Down : constant Boolean := False;
+ -- This constant indicates whether the stack grows up (False) or
+ -- down (True) in memory as functions are called. It is used for
+ -- proper implementation of the stack overflow check.
+
+ ----------------------------------------------
+ -- Characteristics of Types in Interfaces.C --
+ ----------------------------------------------
+
+ long_bits : constant := Long_Integer'Size;
+ -- Number of bits in type long and unsigned_long. The normal convention
+ -- is that this is the same as type Long_Integer, but this may not be true
+ -- of all targets.
+
+ ptr_bits : constant := Standard'Address_Size;
+ subtype C_Address is System.Address;
+ -- Number of bits in Interfaces.C pointers, normally a standard address
+
+ C_Malloc_Linkname : constant String := "__gnat_malloc";
+ -- Name of runtime function used to allocate such a pointer
+
+ ----------------------------------------------
+ -- Behavior of Pragma Finalize_Storage_Only --
+ ----------------------------------------------
+
+ -- Garbage_Collected is a Boolean constant whose value indicates the
+ -- effect of the pragma Finalize_Storage_Entry on a controlled type.
+
+ -- Garbage_Collected = False
+
+ -- The system releases all storage on program termination only,
+ -- but not other garbage collection occurs, so finalization calls
+ -- are omitted only for outer level objects can be omitted if
+ -- pragma Finalize_Storage_Only is used.
+
+ -- Garbage_Collected = True
+
+ -- The system provides full garbage collection, so it is never
+ -- necessary to release storage for controlled objects for which
+ -- a pragma Finalize_Storage_Only is used.
+
+ Garbage_Collected : constant Boolean := False;
+ -- The storage mode for this system (release on program exit)
+
+ ---------------------
+ -- Tasking Profile --
+ ---------------------
+
+ -- In the following sections, constant parameters are defined to
+ -- allow some optimizations and fine tuning within the tasking run time
+ -- based on restrictions on the tasking features.
+
+ ----------------------
+ -- Locking Strategy --
+ ----------------------
+
+ Single_Lock : constant Boolean := False;
+ -- Indicates whether a single lock should be used within the tasking
+ -- run-time to protect internal structures. If True, a single lock
+ -- will be used, meaning less locking/unlocking operations, but also
+ -- more global contention. In general, Single_Lock should be set to
+ -- True on single processor machines, and to False to multi-processor
+ -- systems, but this can vary from application to application and also
+ -- depends on the scheduling policy.
+
+ -------------------
+ -- Task Abortion --
+ -------------------
+
+ No_Abort : constant Boolean := False;
+ -- This constant indicates whether abort statements and asynchronous
+ -- transfer of control (ATC) are disallowed. If set to True, it is
+ -- assumed that neither construct is used, and the run time does not
+ -- need to defer/undefer abort and check for pending actions at
+ -- completion points. A value of True for No_Abort corresponds to:
+ -- pragma Restrictions (No_Abort_Statements);
+ -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
+
+ ---------------------
+ -- Task Attributes --
+ ---------------------
+
+ Max_Attribute_Count : constant := 32;
+ -- Number of task attributes stored in the task control block
+
+ -----------------------
+ -- Task Image Length --
+ -----------------------
+
+ Max_Task_Image_Length : constant := 256;
+ -- This constant specifies the maximum length of a task's image
+
+ ------------------------------
+ -- Exception Message Length --
+ ------------------------------
+
+ Default_Exception_Msg_Max_Length : constant := 200;
+ -- This constant specifies the default number of characters to allow
+ -- in an exception message (200 is minimum required by RM 11.4.1(18)).
+
+end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1997-2009 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS specific version
+
+with Interfaces.C;
+
+package body System.Parameters is
+
+ function ada_pthread_minimum_stack_size return Interfaces.C.size_t;
+ pragma Import (C, ada_pthread_minimum_stack_size,
+ "_ada_pthread_minimum_stack_size");
+
+ ------------------------
+ -- Default_Stack_Size --
+ ------------------------
+
+ function Default_Stack_Size return Size_Type is
+ begin
+ return Size_Type (ada_pthread_minimum_stack_size);
+ end Default_Stack_Size;
+
+ ------------------------
+ -- Minimum_Stack_Size --
+ ------------------------
+
+ function Minimum_Stack_Size return Size_Type is
+
+ begin
+ return Size_Type (ada_pthread_minimum_stack_size);
+ end Minimum_Stack_Size;
+
+ -------------------------
+ -- Adjust_Storage_Size --
+ -------------------------
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type is
+ begin
+ if Size = Unspecified_Size then
+ return Default_Stack_Size;
+
+ elsif Size < Minimum_Stack_Size then
+ return Minimum_Stack_Size;
+
+ else
+ return Size;
+ end if;
+ end Adjust_Storage_Size;
+
+end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1995-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Version used on all VxWorks targets
+
+package body System.Parameters is
+
+ -------------------------
+ -- Adjust_Storage_Size --
+ -------------------------
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type is
+ begin
+ if Size = Unspecified_Size then
+ return Default_Stack_Size;
+ elsif Size < Minimum_Stack_Size then
+ return Minimum_Stack_Size;
+ else
+ return Size;
+ end if;
+ end Adjust_Storage_Size;
+
+ ------------------------
+ -- Default_Stack_Size --
+ ------------------------
+
+ function Default_Stack_Size return Size_Type is
+ Default_Stack_Size : Integer;
+ pragma Import (C, Default_Stack_Size, "__gl_default_stack_size");
+ begin
+ if Default_Stack_Size = -1 then
+ if Stack_Check_Limits then
+ return 32 * 1024;
+ -- Extra stack to allow for 12K exception area.
+ else
+ return 20 * 1024;
+ end if;
+ else
+ return Size_Type (Default_Stack_Size);
+ end if;
+ end Default_Stack_Size;
+
+ ------------------------
+ -- Minimum_Stack_Size --
+ ------------------------
+
+ function Minimum_Stack_Size return Size_Type is
+ begin
+ return 8 * 1024;
+ end Minimum_Stack_Size;
+
+end System.Parameters;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the default VxWorks version of the package
+
+-- This package defines some system dependent parameters for GNAT. These
+-- are values that are referenced by the runtime library and are therefore
+-- relevant to the target machine.
+
+-- The parameters whose value is defined in the spec are not generally
+-- expected to be changed. If they are changed, it will be necessary to
+-- recompile the run-time library.
+
+-- The parameters which are defined by functions can be changed by modifying
+-- the body of System.Parameters in file s-parame.adb. A change to this body
+-- requires only rebinding and relinking of the application.
+
+-- Note: do not introduce any pragma Inline statements into this unit, since
+-- otherwise the relinking and rebinding capability would be deactivated.
+
+package System.Parameters is
+ pragma Pure;
+
+ ---------------------------------------
+ -- Task And Stack Allocation Control --
+ ---------------------------------------
+
+ type Task_Storage_Size is new Integer;
+ -- Type used in tasking units for task storage size
+
+ type Size_Type is new Task_Storage_Size;
+ -- Type used to provide task storage size to runtime
+
+ Unspecified_Size : constant Size_Type := Size_Type'First;
+ -- Value used to indicate that no size type is set
+
+ subtype Percentage is Size_Type range -1 .. 100;
+ Dynamic : constant Size_Type := -1;
+ -- The secondary stack ratio is a constant between 0 and 100 which
+ -- determines the percentage of the allocated task stack that is
+ -- used by the secondary stack (the rest being the primary stack).
+ -- The special value of minus one indicates that the secondary
+ -- stack is to be allocated from the heap instead.
+
+ Sec_Stack_Percentage : constant Percentage := Dynamic;
+ -- This constant defines the handling of the secondary stack
+
+ Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic;
+ -- Convenient Boolean for testing for dynamic secondary stack
+
+ function Default_Stack_Size return Size_Type;
+ -- Default task stack size used if none is specified
+
+ function Minimum_Stack_Size return Size_Type;
+ -- Minimum task stack size permitted
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
+ -- Given the storage size stored in the TCB, return the Storage_Size
+ -- value required by the RM for the Storage_Size attribute. The
+ -- required adjustment is as follows:
+ --
+ -- when Size = Unspecified_Size, return Default_Stack_Size
+ -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
+ -- otherwise return given Size
+
+ Default_Env_Stack_Size : constant Size_Type := 14_336;
+ -- Assumed size of the environment task, if no other information
+ -- is available. This value is used when stack checking is
+ -- enabled and no GNAT_STACK_LIMIT environment variable is set.
+ -- This value is chosen as the VxWorks default stack size is 20kB,
+ -- and a little more than 4kB is necessary for the run time.
+
+ Stack_Grows_Down : constant Boolean := True;
+ -- This constant indicates whether the stack grows up (False) or
+ -- down (True) in memory as functions are called. It is used for
+ -- proper implementation of the stack overflow check.
+
+ ----------------------------------------------
+ -- Characteristics of types in Interfaces.C --
+ ----------------------------------------------
+
+ long_bits : constant := Long_Integer'Size;
+ -- Number of bits in type long and unsigned_long. The normal convention
+ -- is that this is the same as type Long_Integer, but this may not be true
+ -- of all targets.
+
+ ptr_bits : constant := Standard'Address_Size;
+ subtype C_Address is System.Address;
+ -- Number of bits in Interfaces.C pointers, normally a standard address
+
+ C_Malloc_Linkname : constant String := "__gnat_malloc";
+ -- Name of runtime function used to allocate such a pointer
+
+ ----------------------------------------------
+ -- Behavior of Pragma Finalize_Storage_Only --
+ ----------------------------------------------
+
+ -- Garbage_Collected is a Boolean constant whose value indicates the
+ -- effect of the pragma Finalize_Storage_Entry on a controlled type.
+
+ -- Garbage_Collected = False
+
+ -- The system releases all storage on program termination only,
+ -- but not other garbage collection occurs, so finalization calls
+ -- are omitted only for outer level objects can be omitted if
+ -- pragma Finalize_Storage_Only is used.
+
+ -- Garbage_Collected = True
+
+ -- The system provides full garbage collection, so it is never
+ -- necessary to release storage for controlled objects for which
+ -- a pragma Finalize_Storage_Only is used.
+
+ Garbage_Collected : constant Boolean := False;
+ -- The storage mode for this system (release on program exit)
+
+ ---------------------
+ -- Tasking Profile --
+ ---------------------
+
+ -- In the following sections, constant parameters are defined to
+ -- allow some optimizations and fine tuning within the tasking run time
+ -- based on restrictions on the tasking features.
+
+ ----------------------
+ -- Locking Strategy --
+ ----------------------
+
+ Single_Lock : constant Boolean := False;
+ -- Indicates whether a single lock should be used within the tasking
+ -- run-time to protect internal structures. If True, a single lock
+ -- will be used, meaning less locking/unlocking operations, but also
+ -- more global contention. In general, Single_Lock should be set to
+ -- True on single processor machines, and to False to multi-processor
+ -- systems, but this can vary from application to application and also
+ -- depends on the scheduling policy.
+
+ -------------------
+ -- Task Abortion --
+ -------------------
+
+ No_Abort : constant Boolean := False;
+ -- This constant indicates whether abort statements and asynchronous
+ -- transfer of control (ATC) are disallowed. If set to True, it is
+ -- assumed that neither construct is used, and the run time does not
+ -- need to defer/undefer abort and check for pending actions at
+ -- completion points. A value of True for No_Abort corresponds to:
+ -- pragma Restrictions (No_Abort_Statements);
+ -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
+
+ ---------------------
+ -- Task Attributes --
+ ---------------------
+
+ Max_Attribute_Count : constant := 16;
+ -- Number of task attributes stored in the task control block
+
+ -----------------------
+ -- Task Image Length --
+ -----------------------
+
+ Max_Task_Image_Length : constant := 32;
+ -- This constant specifies the maximum length of a task's image
+
+ ------------------------------
+ -- Exception Message Length --
+ ------------------------------
+
+ Default_Exception_Msg_Max_Length : constant := 200;
+ -- This constant specifies the default number of characters to allow
+ -- in an exception message (200 is minimum required by RM 11.4.1(18)).
+
+end System.Parameters;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1999-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version of this package is for implementations which use
--- the stack limit approach (the limit of the stack is stored into a per
--- thread variable).
-
-pragma Restrictions (No_Elaboration_Code);
--- We want to guarantee the absence of elaboration code because the binder
--- does not handle references to this package.
-
-pragma Polling (Off);
--- Turn off polling, we do not want polling to take place during stack
--- checking operations. It causes infinite loops and other problems.
-
-package System.Stack_Checking.Operations is
- pragma Preelaborate;
-
- procedure Initialize_Stack_Limit;
- pragma Export (C, Initialize_Stack_Limit,
- "__gnat_initialize_stack_limit");
- -- This procedure is called before elaboration to setup the stack limit
- -- for the environment task and to register the hook to be called at
- -- task creation.
-end System.Stack_Checking.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1999-2009, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the RTEMS version of this package.
--- This file should be kept synchronized with the general implementation
--- provided by s-stchop.adb.
-
-pragma Restrictions (No_Elaboration_Code);
--- We want to guarantee the absence of elaboration code because the
--- binder does not handle references to this package.
-
-with Ada.Exceptions;
-
-with Interfaces.C; use Interfaces.C;
-
-package body System.Stack_Checking.Operations is
-
- ----------------------------
- -- Invalidate_Stack_Cache --
- ----------------------------
-
- procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
- pragma Warnings (Off, Any_Stack);
- begin
- Cache := Null_Stack;
- end Invalidate_Stack_Cache;
-
- -----------------------------
- -- Notify_Stack_Attributes --
- -----------------------------
-
- procedure Notify_Stack_Attributes
- (Initial_SP : System.Address;
- Size : System.Storage_Elements.Storage_Offset)
- is
-
- -- RTEMS keeps all the information we need.
-
- pragma Unreferenced (Size);
- pragma Unreferenced (Initial_SP);
-
- begin
- null;
- end Notify_Stack_Attributes;
-
- -----------------
- -- Stack_Check --
- -----------------
-
- function Stack_Check
- (Stack_Address : System.Address) return Stack_Access
- is
- pragma Unreferenced (Stack_Address);
-
- -- RTEMS has a routine to check if the stack is blown.
- -- It returns a C99 bool.
- function rtems_stack_checker_is_blown return Interfaces.C.unsigned_char;
- pragma Import (C,
- rtems_stack_checker_is_blown, "rtems_stack_checker_is_blown");
-
- begin
- -- RTEMS has a routine to check this. So use it.
-
- if rtems_stack_checker_is_blown /= 0 then
- Ada.Exceptions.Raise_Exception
- (E => Storage_Error'Identity,
- Message => "stack overflow detected");
- end if;
-
- return null;
-
- end Stack_Check;
-
- ------------------------
- -- Update_Stack_Cache --
- ------------------------
-
- procedure Update_Stack_Cache (Stack : Stack_Access) is
- begin
- if not Multi_Processor then
- Cache := Stack;
- end if;
- end Update_Stack_Cache;
-
-end System.Stack_Checking.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1999-2017, Free Software Foundation, Inc. --
--- --
--- GNARL 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/>. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the verson for VxWorks 5, VxWorks 6 Cert and VxWorks MILS
-
--- This file should be kept synchronized with the general implementation
--- provided by s-stchop.adb.
-
-pragma Restrictions (No_Elaboration_Code);
--- We want to guarantee the absence of elaboration code because the
--- binder does not handle references to this package.
-
-with System.Storage_Elements; use System.Storage_Elements;
-with System.Parameters; use System.Parameters;
-with Interfaces.C;
-
-package body System.Stack_Checking.Operations is
-
- -- In order to have stack checking working appropriately on VxWorks we need
- -- to extract the stack size information from the VxWorks kernel itself.
-
- -- For VxWorks 5 & 6 the library for showing task-related information
- -- needs to be linked into the VxWorks system, when using stack checking.
- -- The taskShow library can be linked into the VxWorks system by either:
-
- -- * defining INCLUDE_SHOW_ROUTINES in config.h when using
- -- configuration header files, or
-
- -- * selecting INCLUDE_TASK_SHOW when using the Tornado project
- -- facility.
-
- -- VxWorks MILS includes the necessary routine in taskLib, so nothing
- -- special needs to be done there.
-
- Stack_Limit : Address;
-
- pragma Import (C, Stack_Limit, "__gnat_stack_limit");
-
- -- Stack_Limit contains the limit of the stack. This variable is later made
- -- a task variable (by calling taskVarAdd) and then correctly set to the
- -- stack limit of the task. Before being so initialized its value must be
- -- valid so that any subprogram with stack checking enabled will run. We
- -- use extreme values according to the direction of the stack.
-
- type Set_Stack_Limit_Proc_Acc is access procedure;
- pragma Convention (C, Set_Stack_Limit_Proc_Acc);
-
- Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
- pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
- -- Procedure to be called when a task is created to set stack
- -- limit.
-
- procedure Set_Stack_Limit_For_Current_Task;
- pragma Convention (C, Set_Stack_Limit_For_Current_Task);
- -- Register Initial_SP as the initial stack pointer value for the current
- -- task when it starts and Size as the associated stack area size. This
- -- should be called once, after the soft-links have been initialized?
-
- -----------------------------
- -- Initialize_Stack_Limit --
- -----------------------------
-
- procedure Initialize_Stack_Limit is
- begin
-
- Set_Stack_Limit_For_Current_Task;
-
- -- Will be called by every created task
-
- Set_Stack_Limit_Hook := Set_Stack_Limit_For_Current_Task'Access;
- end Initialize_Stack_Limit;
-
- --------------------------------------
- -- Set_Stack_Limit_For_Current_Task --
- --------------------------------------
-
- procedure Set_Stack_Limit_For_Current_Task is
- use Interfaces.C;
-
- type OS_Stack_Info is record
- Size : Interfaces.C.int;
- Base : System.Address;
- Limit : System.Address;
- end record;
- pragma Convention (C, OS_Stack_Info);
- -- Type representing the information that we want to extract from the
- -- underlying kernel.
-
- procedure Get_Stack_Info (Stack : not null access OS_Stack_Info);
- pragma Import (C, Get_Stack_Info, "__gnat_get_stack_info");
- -- Procedure that fills the stack information associated to the
- -- currently executing task.
-
- Stack_Info : aliased OS_Stack_Info;
-
- Limit : System.Address;
-
- begin
-
- -- Get stack bounds from VxWorks
-
- Get_Stack_Info (Stack_Info'Access);
-
- if Stack_Grows_Down then
- Limit :=
- Stack_Info.Base - Storage_Offset (Stack_Info.Size) +
- Storage_Offset'(12_000);
- else
- Limit :=
- Stack_Info.Base + Storage_Offset (Stack_Info.Size) -
- Storage_Offset'(12_000);
- end if;
-
- Stack_Limit := Limit;
-
- end Set_Stack_Limit_For_Current_Task;
-end System.Stack_Checking.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1999-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version of this package is for implementations which use
+-- the stack limit approach (the limit of the stack is stored into a per
+-- thread variable).
+
+pragma Restrictions (No_Elaboration_Code);
+-- We want to guarantee the absence of elaboration code because the binder
+-- does not handle references to this package.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want polling to take place during stack
+-- checking operations. It causes infinite loops and other problems.
+
+package System.Stack_Checking.Operations is
+ pragma Preelaborate;
+
+ procedure Initialize_Stack_Limit;
+ pragma Export (C, Initialize_Stack_Limit,
+ "__gnat_initialize_stack_limit");
+ -- This procedure is called before elaboration to setup the stack limit
+ -- for the environment task and to register the hook to be called at
+ -- task creation.
+end System.Stack_Checking.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-2009, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the RTEMS version of this package.
+-- This file should be kept synchronized with the general implementation
+-- provided by s-stchop.adb.
+
+pragma Restrictions (No_Elaboration_Code);
+-- We want to guarantee the absence of elaboration code because the
+-- binder does not handle references to this package.
+
+with Ada.Exceptions;
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.Stack_Checking.Operations is
+
+ ----------------------------
+ -- Invalidate_Stack_Cache --
+ ----------------------------
+
+ procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
+ pragma Warnings (Off, Any_Stack);
+ begin
+ Cache := Null_Stack;
+ end Invalidate_Stack_Cache;
+
+ -----------------------------
+ -- Notify_Stack_Attributes --
+ -----------------------------
+
+ procedure Notify_Stack_Attributes
+ (Initial_SP : System.Address;
+ Size : System.Storage_Elements.Storage_Offset)
+ is
+
+ -- RTEMS keeps all the information we need.
+
+ pragma Unreferenced (Size);
+ pragma Unreferenced (Initial_SP);
+
+ begin
+ null;
+ end Notify_Stack_Attributes;
+
+ -----------------
+ -- Stack_Check --
+ -----------------
+
+ function Stack_Check
+ (Stack_Address : System.Address) return Stack_Access
+ is
+ pragma Unreferenced (Stack_Address);
+
+ -- RTEMS has a routine to check if the stack is blown.
+ -- It returns a C99 bool.
+ function rtems_stack_checker_is_blown return Interfaces.C.unsigned_char;
+ pragma Import (C,
+ rtems_stack_checker_is_blown, "rtems_stack_checker_is_blown");
+
+ begin
+ -- RTEMS has a routine to check this. So use it.
+
+ if rtems_stack_checker_is_blown /= 0 then
+ Ada.Exceptions.Raise_Exception
+ (E => Storage_Error'Identity,
+ Message => "stack overflow detected");
+ end if;
+
+ return null;
+
+ end Stack_Check;
+
+ ------------------------
+ -- Update_Stack_Cache --
+ ------------------------
+
+ procedure Update_Stack_Cache (Stack : Stack_Access) is
+ begin
+ if not Multi_Processor then
+ Cache := Stack;
+ end if;
+ end Update_Stack_Cache;
+
+end System.Stack_Checking.Operations;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-2017, Free Software Foundation, Inc. --
+-- --
+-- GNARL 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/>. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the verson for VxWorks 5, VxWorks 6 Cert and VxWorks MILS
+
+-- This file should be kept synchronized with the general implementation
+-- provided by s-stchop.adb.
+
+pragma Restrictions (No_Elaboration_Code);
+-- We want to guarantee the absence of elaboration code because the
+-- binder does not handle references to this package.
+
+with System.Storage_Elements; use System.Storage_Elements;
+with System.Parameters; use System.Parameters;
+with Interfaces.C;
+
+package body System.Stack_Checking.Operations is
+
+ -- In order to have stack checking working appropriately on VxWorks we need
+ -- to extract the stack size information from the VxWorks kernel itself.
+
+ -- For VxWorks 5 & 6 the library for showing task-related information
+ -- needs to be linked into the VxWorks system, when using stack checking.
+ -- The taskShow library can be linked into the VxWorks system by either:
+
+ -- * defining INCLUDE_SHOW_ROUTINES in config.h when using
+ -- configuration header files, or
+
+ -- * selecting INCLUDE_TASK_SHOW when using the Tornado project
+ -- facility.
+
+ -- VxWorks MILS includes the necessary routine in taskLib, so nothing
+ -- special needs to be done there.
+
+ Stack_Limit : Address;
+
+ pragma Import (C, Stack_Limit, "__gnat_stack_limit");
+
+ -- Stack_Limit contains the limit of the stack. This variable is later made
+ -- a task variable (by calling taskVarAdd) and then correctly set to the
+ -- stack limit of the task. Before being so initialized its value must be
+ -- valid so that any subprogram with stack checking enabled will run. We
+ -- use extreme values according to the direction of the stack.
+
+ type Set_Stack_Limit_Proc_Acc is access procedure;
+ pragma Convention (C, Set_Stack_Limit_Proc_Acc);
+
+ Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
+ pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
+ -- Procedure to be called when a task is created to set stack
+ -- limit.
+
+ procedure Set_Stack_Limit_For_Current_Task;
+ pragma Convention (C, Set_Stack_Limit_For_Current_Task);
+ -- Register Initial_SP as the initial stack pointer value for the current
+ -- task when it starts and Size as the associated stack area size. This
+ -- should be called once, after the soft-links have been initialized?
+
+ -----------------------------
+ -- Initialize_Stack_Limit --
+ -----------------------------
+
+ procedure Initialize_Stack_Limit is
+ begin
+
+ Set_Stack_Limit_For_Current_Task;
+
+ -- Will be called by every created task
+
+ Set_Stack_Limit_Hook := Set_Stack_Limit_For_Current_Task'Access;
+ end Initialize_Stack_Limit;
+
+ --------------------------------------
+ -- Set_Stack_Limit_For_Current_Task --
+ --------------------------------------
+
+ procedure Set_Stack_Limit_For_Current_Task is
+ use Interfaces.C;
+
+ type OS_Stack_Info is record
+ Size : Interfaces.C.int;
+ Base : System.Address;
+ Limit : System.Address;
+ end record;
+ pragma Convention (C, OS_Stack_Info);
+ -- Type representing the information that we want to extract from the
+ -- underlying kernel.
+
+ procedure Get_Stack_Info (Stack : not null access OS_Stack_Info);
+ pragma Import (C, Get_Stack_Info, "__gnat_get_stack_info");
+ -- Procedure that fills the stack information associated to the
+ -- currently executing task.
+
+ Stack_Info : aliased OS_Stack_Info;
+
+ Limit : System.Address;
+
+ begin
+
+ -- Get stack bounds from VxWorks
+
+ Get_Stack_Info (Stack_Info'Access);
+
+ if Stack_Grows_Down then
+ Limit :=
+ Stack_Info.Base - Storage_Offset (Stack_Info.Size) +
+ Storage_Offset'(12_000);
+ else
+ Limit :=
+ Stack_Info.Base + Storage_Offset (Stack_Info.Size) -
+ Storage_Offset'(12_000);
+ end if;
+
+ Stack_Limit := Limit;
+
+ end Set_Stack_Limit_For_Current_Task;
+end System.Stack_Checking.Operations;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . S T R E A M _ A T T R I B U T E S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1996-2017, Free Software Foundation, Inc. --
--- --
--- GARLIC is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This file is an alternate version of s-stratt.adb based on the XDR
--- standard. It is especially useful for exchanging streams between two
--- different systems with different basic type representations and endianness.
-
-pragma Warnings (Off, "*not allowed in compiler unit");
--- This body is used only when rebuilding the runtime library, not when
--- building the compiler, so it's OK to depend on features that would
--- otherwise break bootstrap (e.g. IF-expressions).
-
-with Ada.IO_Exceptions;
-with Ada.Streams; use Ada.Streams;
-with Ada.Unchecked_Conversion;
-
-package body System.Stream_Attributes is
-
- pragma Suppress (Range_Check);
- pragma Suppress (Overflow_Check);
-
- use UST;
-
- Data_Error : exception renames Ada.IO_Exceptions.End_Error;
- -- Exception raised if insufficient data read (End_Error is mandated by
- -- AI95-00132).
-
- SU : constant := System.Storage_Unit;
- -- The code in this body assumes that SU = 8
-
- BB : constant := 2 ** SU; -- Byte base
- BL : constant := 2 ** SU - 1; -- Byte last
- BS : constant := 2 ** (SU - 1); -- Byte sign
-
- US : constant := Unsigned'Size; -- Unsigned size
- UB : constant := (US - 1) / SU + 1; -- Unsigned byte
- UL : constant := 2 ** US - 1; -- Unsigned last
-
- subtype SE is Ada.Streams.Stream_Element;
- subtype SEA is Ada.Streams.Stream_Element_Array;
- subtype SEO is Ada.Streams.Stream_Element_Offset;
-
- generic function UC renames Ada.Unchecked_Conversion;
-
- type Field_Type is
- record
- E_Size : Integer; -- Exponent bit size
- E_Bias : Integer; -- Exponent bias
- F_Size : Integer; -- Fraction bit size
- E_Last : Integer; -- Max exponent value
- F_Mask : SE; -- Mask to apply on first fraction byte
- E_Bytes : SEO; -- N. of exponent bytes completely used
- F_Bytes : SEO; -- N. of fraction bytes completely used
- F_Bits : Integer; -- N. of bits used on first fraction word
- end record;
-
- type Precision is (Single, Double, Quadruple);
-
- Fields : constant array (Precision) of Field_Type := (
-
- -- Single precision
-
- (E_Size => 8,
- E_Bias => 127,
- F_Size => 23,
- E_Last => 2 ** 8 - 1,
- F_Mask => 16#7F#, -- 2 ** 7 - 1,
- E_Bytes => 2,
- F_Bytes => 3,
- F_Bits => 23 mod US),
-
- -- Double precision
-
- (E_Size => 11,
- E_Bias => 1023,
- F_Size => 52,
- E_Last => 2 ** 11 - 1,
- F_Mask => 16#0F#, -- 2 ** 4 - 1,
- E_Bytes => 2,
- F_Bytes => 7,
- F_Bits => 52 mod US),
-
- -- Quadruple precision
-
- (E_Size => 15,
- E_Bias => 16383,
- F_Size => 112,
- E_Last => 2 ** 8 - 1,
- F_Mask => 16#FF#, -- 2 ** 8 - 1,
- E_Bytes => 2,
- F_Bytes => 14,
- F_Bits => 112 mod US));
-
- -- The representation of all items requires a multiple of four bytes
- -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes
- -- are read or written to some byte stream such that byte m always
- -- precedes byte m+1. If the n bytes needed to contain the data are not
- -- a multiple of four, then the n bytes are followed by enough (0 to 3)
- -- residual zero bytes, r, to make the total byte count a multiple of 4.
-
- -- An XDR signed integer is a 32-bit datum that encodes an integer
- -- in the range [-2147483648,2147483647]. The integer is represented
- -- in two's complement notation. The most and least significant bytes
- -- are 0 and 3, respectively. Integers are declared as follows:
-
- -- (MSB) (LSB)
- -- +-------+-------+-------+-------+
- -- |byte 0 |byte 1 |byte 2 |byte 3 |
- -- +-------+-------+-------+-------+
- -- <------------32 bits------------>
-
- SSI_L : constant := 1;
- SI_L : constant := 2;
- I_L : constant := 4;
- LI_L : constant := 8;
- LLI_L : constant := 8;
-
- subtype XDR_S_SSI is SEA (1 .. SSI_L);
- subtype XDR_S_SI is SEA (1 .. SI_L);
- subtype XDR_S_I is SEA (1 .. I_L);
- subtype XDR_S_LI is SEA (1 .. LI_L);
- subtype XDR_S_LLI is SEA (1 .. LLI_L);
-
- function Short_Short_Integer_To_XDR_S_SSI is
- new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI);
- function XDR_S_SSI_To_Short_Short_Integer is
- new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer);
-
- function Short_Integer_To_XDR_S_SI is
- new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI);
- function XDR_S_SI_To_Short_Integer is
- new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer);
-
- function Integer_To_XDR_S_I is
- new Ada.Unchecked_Conversion (Integer, XDR_S_I);
- function XDR_S_I_To_Integer is
- new Ada.Unchecked_Conversion (XDR_S_I, Integer);
-
- function Long_Long_Integer_To_XDR_S_LI is
- new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI);
- function XDR_S_LI_To_Long_Long_Integer is
- new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer);
-
- function Long_Long_Integer_To_XDR_S_LLI is
- new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI);
- function XDR_S_LLI_To_Long_Long_Integer is
- new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer);
-
- -- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative
- -- integer in the range [0,4294967295]. It is represented by an unsigned
- -- binary number whose most and least significant bytes are 0 and 3,
- -- respectively. An unsigned integer is declared as follows:
-
- -- (MSB) (LSB)
- -- +-------+-------+-------+-------+
- -- |byte 0 |byte 1 |byte 2 |byte 3 |
- -- +-------+-------+-------+-------+
- -- <------------32 bits------------>
-
- SSU_L : constant := 1;
- SU_L : constant := 2;
- U_L : constant := 4;
- LU_L : constant := 8;
- LLU_L : constant := 8;
-
- subtype XDR_S_SSU is SEA (1 .. SSU_L);
- subtype XDR_S_SU is SEA (1 .. SU_L);
- subtype XDR_S_U is SEA (1 .. U_L);
- subtype XDR_S_LU is SEA (1 .. LU_L);
- subtype XDR_S_LLU is SEA (1 .. LLU_L);
-
- type XDR_SSU is mod BB ** SSU_L;
- type XDR_SU is mod BB ** SU_L;
- type XDR_U is mod BB ** U_L;
-
- function Short_Unsigned_To_XDR_S_SU is
- new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU);
- function XDR_S_SU_To_Short_Unsigned is
- new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned);
-
- function Unsigned_To_XDR_S_U is
- new Ada.Unchecked_Conversion (Unsigned, XDR_S_U);
- function XDR_S_U_To_Unsigned is
- new Ada.Unchecked_Conversion (XDR_S_U, Unsigned);
-
- function Long_Long_Unsigned_To_XDR_S_LU is
- new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU);
- function XDR_S_LU_To_Long_Long_Unsigned is
- new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned);
-
- function Long_Long_Unsigned_To_XDR_S_LLU is
- new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU);
- function XDR_S_LLU_To_Long_Long_Unsigned is
- new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned);
-
- -- The standard defines the floating-point data type "float" (32 bits
- -- or 4 bytes). The encoding used is the IEEE standard for normalized
- -- single-precision floating-point numbers.
-
- -- The standard defines the encoding used for the double-precision
- -- floating-point data type "double" (64 bits or 8 bytes). The encoding
- -- used is the IEEE standard for normalized double-precision floating-point
- -- numbers.
-
- SF_L : constant := 4; -- Single precision
- F_L : constant := 4; -- Single precision
- LF_L : constant := 8; -- Double precision
- LLF_L : constant := 16; -- Quadruple precision
-
- TM_L : constant := 8;
- subtype XDR_S_TM is SEA (1 .. TM_L);
- type XDR_TM is mod BB ** TM_L;
-
- type XDR_SA is mod 2 ** Standard'Address_Size;
- function To_XDR_SA is new UC (System.Address, XDR_SA);
- function To_XDR_SA is new UC (XDR_SA, System.Address);
-
- -- Enumerations have the same representation as signed integers.
- -- Enumerations are handy for describing subsets of the integers.
-
- -- Booleans are important enough and occur frequently enough to warrant
- -- their own explicit type in the standard. Booleans are declared as
- -- an enumeration, with FALSE = 0 and TRUE = 1.
-
- -- The standard defines a string of n (numbered 0 through n-1) ASCII
- -- bytes to be the number n encoded as an unsigned integer (as described
- -- above), and followed by the n bytes of the string. Byte m of the string
- -- always precedes byte m+1 of the string, and byte 0 of the string always
- -- follows the string's length. If n is not a multiple of four, then the
- -- n bytes are followed by enough (0 to 3) residual zero bytes, r, to make
- -- the total byte count a multiple of four.
-
- -- To fit with XDR string, do not consider character as an enumeration
- -- type.
-
- C_L : constant := 1;
- subtype XDR_S_C is SEA (1 .. C_L);
-
- -- Consider Wide_Character as an enumeration type
-
- WC_L : constant := 4;
- subtype XDR_S_WC is SEA (1 .. WC_L);
- type XDR_WC is mod BB ** WC_L;
-
- -- Consider Wide_Wide_Character as an enumeration type
-
- WWC_L : constant := 8;
- subtype XDR_S_WWC is SEA (1 .. WWC_L);
- type XDR_WWC is mod BB ** WWC_L;
-
- -- Optimization: if we already have the correct Bit_Order, then some
- -- computations can be avoided since the source and the target will be
- -- identical anyway. They will be replaced by direct unchecked
- -- conversions.
-
- Optimize_Integers : constant Boolean :=
- Default_Bit_Order = High_Order_First;
-
- -----------------
- -- Block_IO_OK --
- -----------------
-
- -- We must inhibit Block_IO, because in XDR mode, each element is output
- -- according to XDR requirements, which is not at all the same as writing
- -- the whole array in one block.
-
- function Block_IO_OK return Boolean is
- begin
- return False;
- end Block_IO_OK;
-
- ----------
- -- I_AD --
- ----------
-
- function I_AD (Stream : not null access RST) return Fat_Pointer is
- FP : Fat_Pointer;
-
- begin
- FP.P1 := I_AS (Stream).P1;
- FP.P2 := I_AS (Stream).P1;
-
- return FP;
- end I_AD;
-
- ----------
- -- I_AS --
- ----------
-
- function I_AS (Stream : not null access RST) return Thin_Pointer is
- S : XDR_S_TM;
- L : SEO;
- U : XDR_TM := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- else
- for N in S'Range loop
- U := U * BB + XDR_TM (S (N));
- end loop;
-
- return (P1 => To_XDR_SA (XDR_SA (U)));
- end if;
- end I_AS;
-
- ---------
- -- I_B --
- ---------
-
- function I_B (Stream : not null access RST) return Boolean is
- begin
- case I_SSU (Stream) is
- when 0 => return False;
- when 1 => return True;
- when others => raise Data_Error;
- end case;
- end I_B;
-
- ---------
- -- I_C --
- ---------
-
- function I_C (Stream : not null access RST) return Character is
- S : XDR_S_C;
- L : SEO;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- else
- -- Use Ada requirements on Character representation clause
-
- return Character'Val (S (1));
- end if;
- end I_C;
-
- ---------
- -- I_F --
- ---------
-
- function I_F (Stream : not null access RST) return Float is
- I : constant Precision := Single;
- E_Size : Integer renames Fields (I).E_Size;
- E_Bias : Integer renames Fields (I).E_Bias;
- E_Last : Integer renames Fields (I).E_Last;
- F_Mask : SE renames Fields (I).F_Mask;
- E_Bytes : SEO renames Fields (I).E_Bytes;
- F_Bytes : SEO renames Fields (I).F_Bytes;
- F_Size : Integer renames Fields (I).F_Size;
-
- Is_Positive : Boolean;
- Exponent : Long_Unsigned;
- Fraction : Long_Unsigned;
- Result : Float;
- S : SEA (1 .. F_L);
- L : SEO;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
- end if;
-
- -- Extract Fraction, Sign and Exponent
-
- Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask);
- for N in F_L + 2 - F_Bytes .. F_L loop
- Fraction := Fraction * BB + Long_Unsigned (S (N));
- end loop;
- Result := Float'Scaling (Float (Fraction), -F_Size);
-
- if BS <= S (1) then
- Is_Positive := False;
- Exponent := Long_Unsigned (S (1) - BS);
- else
- Is_Positive := True;
- Exponent := Long_Unsigned (S (1));
- end if;
-
- for N in 2 .. E_Bytes loop
- Exponent := Exponent * BB + Long_Unsigned (S (N));
- end loop;
- Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
-
- -- NaN or Infinities
-
- if Integer (Exponent) = E_Last then
- raise Constraint_Error;
-
- elsif Exponent = 0 then
-
- -- Signed zeros
-
- if Fraction = 0 then
- null;
-
- -- Denormalized float
-
- else
- Result := Float'Scaling (Result, 1 - E_Bias);
- end if;
-
- -- Normalized float
-
- else
- Result := Float'Scaling
- (1.0 + Result, Integer (Exponent) - E_Bias);
- end if;
-
- if not Is_Positive then
- Result := -Result;
- end if;
-
- return Result;
- end I_F;
-
- ---------
- -- I_I --
- ---------
-
- function I_I (Stream : not null access RST) return Integer is
- S : XDR_S_I;
- L : SEO;
- U : XDR_U := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- elsif Optimize_Integers then
- return XDR_S_I_To_Integer (S);
-
- else
- for N in S'Range loop
- U := U * BB + XDR_U (S (N));
- end loop;
-
- -- Test sign and apply two complement notation
-
- if S (1) < BL then
- return Integer (U);
-
- else
- return Integer (-((XDR_U'Last xor U) + 1));
- end if;
- end if;
- end I_I;
-
- ----------
- -- I_LF --
- ----------
-
- function I_LF (Stream : not null access RST) return Long_Float is
- I : constant Precision := Double;
- E_Size : Integer renames Fields (I).E_Size;
- E_Bias : Integer renames Fields (I).E_Bias;
- E_Last : Integer renames Fields (I).E_Last;
- F_Mask : SE renames Fields (I).F_Mask;
- E_Bytes : SEO renames Fields (I).E_Bytes;
- F_Bytes : SEO renames Fields (I).F_Bytes;
- F_Size : Integer renames Fields (I).F_Size;
-
- Is_Positive : Boolean;
- Exponent : Long_Unsigned;
- Fraction : Long_Long_Unsigned;
- Result : Long_Float;
- S : SEA (1 .. LF_L);
- L : SEO;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
- end if;
-
- -- Extract Fraction, Sign and Exponent
-
- Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask);
- for N in LF_L + 2 - F_Bytes .. LF_L loop
- Fraction := Fraction * BB + Long_Long_Unsigned (S (N));
- end loop;
-
- Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size);
-
- if BS <= S (1) then
- Is_Positive := False;
- Exponent := Long_Unsigned (S (1) - BS);
- else
- Is_Positive := True;
- Exponent := Long_Unsigned (S (1));
- end if;
-
- for N in 2 .. E_Bytes loop
- Exponent := Exponent * BB + Long_Unsigned (S (N));
- end loop;
-
- Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
-
- -- NaN or Infinities
-
- if Integer (Exponent) = E_Last then
- raise Constraint_Error;
-
- elsif Exponent = 0 then
-
- -- Signed zeros
-
- if Fraction = 0 then
- null;
-
- -- Denormalized float
-
- else
- Result := Long_Float'Scaling (Result, 1 - E_Bias);
- end if;
-
- -- Normalized float
-
- else
- Result := Long_Float'Scaling
- (1.0 + Result, Integer (Exponent) - E_Bias);
- end if;
-
- if not Is_Positive then
- Result := -Result;
- end if;
-
- return Result;
- end I_LF;
-
- ----------
- -- I_LI --
- ----------
-
- function I_LI (Stream : not null access RST) return Long_Integer is
- S : XDR_S_LI;
- L : SEO;
- U : Unsigned := 0;
- X : Long_Unsigned := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- elsif Optimize_Integers then
- return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S));
-
- else
-
- -- Compute using machine unsigned
- -- rather than long_long_unsigned
-
- for N in S'Range loop
- U := U * BB + Unsigned (S (N));
-
- -- We have filled an unsigned
-
- if N mod UB = 0 then
- X := Shift_Left (X, US) + Long_Unsigned (U);
- U := 0;
- end if;
- end loop;
-
- -- Test sign and apply two complement notation
-
- if S (1) < BL then
- return Long_Integer (X);
- else
- return Long_Integer (-((Long_Unsigned'Last xor X) + 1));
- end if;
-
- end if;
- end I_LI;
-
- -----------
- -- I_LLF --
- -----------
-
- function I_LLF (Stream : not null access RST) return Long_Long_Float is
- I : constant Precision := Quadruple;
- E_Size : Integer renames Fields (I).E_Size;
- E_Bias : Integer renames Fields (I).E_Bias;
- E_Last : Integer renames Fields (I).E_Last;
- E_Bytes : SEO renames Fields (I).E_Bytes;
- F_Bytes : SEO renames Fields (I).F_Bytes;
- F_Size : Integer renames Fields (I).F_Size;
-
- Is_Positive : Boolean;
- Exponent : Long_Unsigned;
- Fraction_1 : Long_Long_Unsigned := 0;
- Fraction_2 : Long_Long_Unsigned := 0;
- Result : Long_Long_Float;
- HF : constant Natural := F_Size / 2;
- S : SEA (1 .. LLF_L);
- L : SEO;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
- end if;
-
- -- Extract Fraction, Sign and Exponent
-
- for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop
- Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I));
- end loop;
-
- for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop
- Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I));
- end loop;
-
- Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF);
- Result := Long_Long_Float (Fraction_1) + Result;
- Result := Long_Long_Float'Scaling (Result, HF - F_Size);
-
- if BS <= S (1) then
- Is_Positive := False;
- Exponent := Long_Unsigned (S (1) - BS);
- else
- Is_Positive := True;
- Exponent := Long_Unsigned (S (1));
- end if;
-
- for N in 2 .. E_Bytes loop
- Exponent := Exponent * BB + Long_Unsigned (S (N));
- end loop;
-
- Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
-
- -- NaN or Infinities
-
- if Integer (Exponent) = E_Last then
- raise Constraint_Error;
-
- elsif Exponent = 0 then
-
- -- Signed zeros
-
- if Fraction_1 = 0 and then Fraction_2 = 0 then
- null;
-
- -- Denormalized float
-
- else
- Result := Long_Long_Float'Scaling (Result, 1 - E_Bias);
- end if;
-
- -- Normalized float
-
- else
- Result := Long_Long_Float'Scaling
- (1.0 + Result, Integer (Exponent) - E_Bias);
- end if;
-
- if not Is_Positive then
- Result := -Result;
- end if;
-
- return Result;
- end I_LLF;
-
- -----------
- -- I_LLI --
- -----------
-
- function I_LLI (Stream : not null access RST) return Long_Long_Integer is
- S : XDR_S_LLI;
- L : SEO;
- U : Unsigned := 0;
- X : Long_Long_Unsigned := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- elsif Optimize_Integers then
- return XDR_S_LLI_To_Long_Long_Integer (S);
-
- else
- -- Compute using machine unsigned for computing
- -- rather than long_long_unsigned.
-
- for N in S'Range loop
- U := U * BB + Unsigned (S (N));
-
- -- We have filled an unsigned
-
- if N mod UB = 0 then
- X := Shift_Left (X, US) + Long_Long_Unsigned (U);
- U := 0;
- end if;
- end loop;
-
- -- Test sign and apply two complement notation
-
- if S (1) < BL then
- return Long_Long_Integer (X);
- else
- return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1));
- end if;
- end if;
- end I_LLI;
-
- -----------
- -- I_LLU --
- -----------
-
- function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is
- S : XDR_S_LLU;
- L : SEO;
- U : Unsigned := 0;
- X : Long_Long_Unsigned := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- elsif Optimize_Integers then
- return XDR_S_LLU_To_Long_Long_Unsigned (S);
-
- else
- -- Compute using machine unsigned
- -- rather than long_long_unsigned.
-
- for N in S'Range loop
- U := U * BB + Unsigned (S (N));
-
- -- We have filled an unsigned
-
- if N mod UB = 0 then
- X := Shift_Left (X, US) + Long_Long_Unsigned (U);
- U := 0;
- end if;
- end loop;
-
- return X;
- end if;
- end I_LLU;
-
- ----------
- -- I_LU --
- ----------
-
- function I_LU (Stream : not null access RST) return Long_Unsigned is
- S : XDR_S_LU;
- L : SEO;
- U : Unsigned := 0;
- X : Long_Unsigned := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- elsif Optimize_Integers then
- return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S));
-
- else
- -- Compute using machine unsigned
- -- rather than long_unsigned.
-
- for N in S'Range loop
- U := U * BB + Unsigned (S (N));
-
- -- We have filled an unsigned
-
- if N mod UB = 0 then
- X := Shift_Left (X, US) + Long_Unsigned (U);
- U := 0;
- end if;
- end loop;
-
- return X;
- end if;
- end I_LU;
-
- ----------
- -- I_SF --
- ----------
-
- function I_SF (Stream : not null access RST) return Short_Float is
- I : constant Precision := Single;
- E_Size : Integer renames Fields (I).E_Size;
- E_Bias : Integer renames Fields (I).E_Bias;
- E_Last : Integer renames Fields (I).E_Last;
- F_Mask : SE renames Fields (I).F_Mask;
- E_Bytes : SEO renames Fields (I).E_Bytes;
- F_Bytes : SEO renames Fields (I).F_Bytes;
- F_Size : Integer renames Fields (I).F_Size;
-
- Exponent : Long_Unsigned;
- Fraction : Long_Unsigned;
- Is_Positive : Boolean;
- Result : Short_Float;
- S : SEA (1 .. SF_L);
- L : SEO;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
- end if;
-
- -- Extract Fraction, Sign and Exponent
-
- Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask);
- for N in SF_L + 2 - F_Bytes .. SF_L loop
- Fraction := Fraction * BB + Long_Unsigned (S (N));
- end loop;
- Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size);
-
- if BS <= S (1) then
- Is_Positive := False;
- Exponent := Long_Unsigned (S (1) - BS);
- else
- Is_Positive := True;
- Exponent := Long_Unsigned (S (1));
- end if;
-
- for N in 2 .. E_Bytes loop
- Exponent := Exponent * BB + Long_Unsigned (S (N));
- end loop;
- Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
-
- -- NaN or Infinities
-
- if Integer (Exponent) = E_Last then
- raise Constraint_Error;
-
- elsif Exponent = 0 then
-
- -- Signed zeros
-
- if Fraction = 0 then
- null;
-
- -- Denormalized float
-
- else
- Result := Short_Float'Scaling (Result, 1 - E_Bias);
- end if;
-
- -- Normalized float
-
- else
- Result := Short_Float'Scaling
- (1.0 + Result, Integer (Exponent) - E_Bias);
- end if;
-
- if not Is_Positive then
- Result := -Result;
- end if;
-
- return Result;
- end I_SF;
-
- ----------
- -- I_SI --
- ----------
-
- function I_SI (Stream : not null access RST) return Short_Integer is
- S : XDR_S_SI;
- L : SEO;
- U : XDR_SU := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- elsif Optimize_Integers then
- return XDR_S_SI_To_Short_Integer (S);
-
- else
- for N in S'Range loop
- U := U * BB + XDR_SU (S (N));
- end loop;
-
- -- Test sign and apply two complement notation
-
- if S (1) < BL then
- return Short_Integer (U);
- else
- return Short_Integer (-((XDR_SU'Last xor U) + 1));
- end if;
- end if;
- end I_SI;
-
- -----------
- -- I_SSI --
- -----------
-
- function I_SSI (Stream : not null access RST) return Short_Short_Integer is
- S : XDR_S_SSI;
- L : SEO;
- U : XDR_SSU;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- elsif Optimize_Integers then
- return XDR_S_SSI_To_Short_Short_Integer (S);
-
- else
- U := XDR_SSU (S (1));
-
- -- Test sign and apply two complement notation
-
- if S (1) < BL then
- return Short_Short_Integer (U);
- else
- return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1));
- end if;
- end if;
- end I_SSI;
-
- -----------
- -- I_SSU --
- -----------
-
- function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is
- S : XDR_S_SSU;
- L : SEO;
- U : XDR_SSU := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- else
- U := XDR_SSU (S (1));
- return Short_Short_Unsigned (U);
- end if;
- end I_SSU;
-
- ----------
- -- I_SU --
- ----------
-
- function I_SU (Stream : not null access RST) return Short_Unsigned is
- S : XDR_S_SU;
- L : SEO;
- U : XDR_SU := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- elsif Optimize_Integers then
- return XDR_S_SU_To_Short_Unsigned (S);
-
- else
- for N in S'Range loop
- U := U * BB + XDR_SU (S (N));
- end loop;
-
- return Short_Unsigned (U);
- end if;
- end I_SU;
-
- ---------
- -- I_U --
- ---------
-
- function I_U (Stream : not null access RST) return Unsigned is
- S : XDR_S_U;
- L : SEO;
- U : XDR_U := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- elsif Optimize_Integers then
- return XDR_S_U_To_Unsigned (S);
-
- else
- for N in S'Range loop
- U := U * BB + XDR_U (S (N));
- end loop;
-
- return Unsigned (U);
- end if;
- end I_U;
-
- ----------
- -- I_WC --
- ----------
-
- function I_WC (Stream : not null access RST) return Wide_Character is
- S : XDR_S_WC;
- L : SEO;
- U : XDR_WC := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- else
- for N in S'Range loop
- U := U * BB + XDR_WC (S (N));
- end loop;
-
- -- Use Ada requirements on Wide_Character representation clause
-
- return Wide_Character'Val (U);
- end if;
- end I_WC;
-
- -----------
- -- I_WWC --
- -----------
-
- function I_WWC (Stream : not null access RST) return Wide_Wide_Character is
- S : XDR_S_WWC;
- L : SEO;
- U : XDR_WWC := 0;
-
- begin
- Ada.Streams.Read (Stream.all, S, L);
-
- if L /= S'Last then
- raise Data_Error;
-
- else
- for N in S'Range loop
- U := U * BB + XDR_WWC (S (N));
- end loop;
-
- -- Use Ada requirements on Wide_Wide_Character representation clause
-
- return Wide_Wide_Character'Val (U);
- end if;
- end I_WWC;
-
- ----------
- -- W_AD --
- ----------
-
- procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is
- S : XDR_S_TM;
- U : XDR_TM;
-
- begin
- U := XDR_TM (To_XDR_SA (Item.P1));
- for N in reverse S'Range loop
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- Ada.Streams.Write (Stream.all, S);
-
- U := XDR_TM (To_XDR_SA (Item.P2));
- for N in reverse S'Range loop
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- Ada.Streams.Write (Stream.all, S);
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end W_AD;
-
- ----------
- -- W_AS --
- ----------
-
- procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is
- S : XDR_S_TM;
- U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1));
-
- begin
- for N in reverse S'Range loop
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- Ada.Streams.Write (Stream.all, S);
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end W_AS;
-
- ---------
- -- W_B --
- ---------
-
- procedure W_B (Stream : not null access RST; Item : Boolean) is
- begin
- if Item then
- W_SSU (Stream, 1);
- else
- W_SSU (Stream, 0);
- end if;
- end W_B;
-
- ---------
- -- W_C --
- ---------
-
- procedure W_C (Stream : not null access RST; Item : Character) is
- S : XDR_S_C;
-
- pragma Assert (C_L = 1);
-
- begin
- -- Use Ada requirements on Character representation clause
-
- S (1) := SE (Character'Pos (Item));
-
- Ada.Streams.Write (Stream.all, S);
- end W_C;
-
- ---------
- -- W_F --
- ---------
-
- procedure W_F (Stream : not null access RST; Item : Float) is
- I : constant Precision := Single;
- E_Size : Integer renames Fields (I).E_Size;
- E_Bias : Integer renames Fields (I).E_Bias;
- E_Bytes : SEO renames Fields (I).E_Bytes;
- F_Bytes : SEO renames Fields (I).F_Bytes;
- F_Size : Integer renames Fields (I).F_Size;
- F_Mask : SE renames Fields (I).F_Mask;
-
- Exponent : Long_Unsigned;
- Fraction : Long_Unsigned;
- Is_Positive : Boolean;
- E : Integer;
- F : Float;
- S : SEA (1 .. F_L) := (others => 0);
-
- begin
- if not Item'Valid then
- raise Constraint_Error;
- end if;
-
- -- Compute Sign
-
- Is_Positive := (0.0 <= Item);
- F := abs (Item);
-
- -- Signed zero
-
- if F = 0.0 then
- Exponent := 0;
- Fraction := 0;
-
- else
- E := Float'Exponent (F) - 1;
-
- -- Denormalized float
-
- if E <= -E_Bias then
- F := Float'Scaling (F, F_Size + E_Bias - 1);
- E := -E_Bias;
- else
- F := Float'Scaling (Float'Fraction (F), F_Size + 1);
- end if;
-
- -- Compute Exponent and Fraction
-
- Exponent := Long_Unsigned (E + E_Bias);
- Fraction := Long_Unsigned (F * 2.0) / 2;
- end if;
-
- -- Store Fraction
-
- for I in reverse F_L - F_Bytes + 1 .. F_L loop
- S (I) := SE (Fraction mod BB);
- Fraction := Fraction / BB;
- end loop;
-
- -- Remove implicit bit
-
- S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask;
-
- -- Store Exponent (not always at the beginning of a byte)
-
- Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
- for N in reverse 1 .. E_Bytes loop
- S (N) := SE (Exponent mod BB) + S (N);
- Exponent := Exponent / BB;
- end loop;
-
- -- Store Sign
-
- if not Is_Positive then
- S (1) := S (1) + BS;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_F;
-
- ---------
- -- W_I --
- ---------
-
- procedure W_I (Stream : not null access RST; Item : Integer) is
- S : XDR_S_I;
- U : XDR_U;
-
- begin
- if Optimize_Integers then
- S := Integer_To_XDR_S_I (Item);
-
- else
- -- Test sign and apply two complement notation
-
- U := (if Item < 0
- then XDR_U'Last xor XDR_U (-(Item + 1))
- else XDR_U (Item));
-
- for N in reverse S'Range loop
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_I;
-
- ----------
- -- W_LF --
- ----------
-
- procedure W_LF (Stream : not null access RST; Item : Long_Float) is
- I : constant Precision := Double;
- E_Size : Integer renames Fields (I).E_Size;
- E_Bias : Integer renames Fields (I).E_Bias;
- E_Bytes : SEO renames Fields (I).E_Bytes;
- F_Bytes : SEO renames Fields (I).F_Bytes;
- F_Size : Integer renames Fields (I).F_Size;
- F_Mask : SE renames Fields (I).F_Mask;
-
- Exponent : Long_Unsigned;
- Fraction : Long_Long_Unsigned;
- Is_Positive : Boolean;
- E : Integer;
- F : Long_Float;
- S : SEA (1 .. LF_L) := (others => 0);
-
- begin
- if not Item'Valid then
- raise Constraint_Error;
- end if;
-
- -- Compute Sign
-
- Is_Positive := (0.0 <= Item);
- F := abs (Item);
-
- -- Signed zero
-
- if F = 0.0 then
- Exponent := 0;
- Fraction := 0;
-
- else
- E := Long_Float'Exponent (F) - 1;
-
- -- Denormalized float
-
- if E <= -E_Bias then
- E := -E_Bias;
- F := Long_Float'Scaling (F, F_Size + E_Bias - 1);
- else
- F := Long_Float'Scaling (F, F_Size - E);
- end if;
-
- -- Compute Exponent and Fraction
-
- Exponent := Long_Unsigned (E + E_Bias);
- Fraction := Long_Long_Unsigned (F * 2.0) / 2;
- end if;
-
- -- Store Fraction
-
- for I in reverse LF_L - F_Bytes + 1 .. LF_L loop
- S (I) := SE (Fraction mod BB);
- Fraction := Fraction / BB;
- end loop;
-
- -- Remove implicit bit
-
- S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask;
-
- -- Store Exponent (not always at the beginning of a byte)
-
- Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
- for N in reverse 1 .. E_Bytes loop
- S (N) := SE (Exponent mod BB) + S (N);
- Exponent := Exponent / BB;
- end loop;
-
- -- Store Sign
-
- if not Is_Positive then
- S (1) := S (1) + BS;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_LF;
-
- ----------
- -- W_LI --
- ----------
-
- procedure W_LI (Stream : not null access RST; Item : Long_Integer) is
- S : XDR_S_LI;
- U : Unsigned;
- X : Long_Unsigned;
-
- begin
- if Optimize_Integers then
- S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item));
-
- else
- -- Test sign and apply two complement notation
-
- if Item < 0 then
- X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1));
- else
- X := Long_Unsigned (Item);
- end if;
-
- -- Compute using machine unsigned rather than long_unsigned
-
- for N in reverse S'Range loop
-
- -- We have filled an unsigned
-
- if (LU_L - N) mod UB = 0 then
- U := Unsigned (X and UL);
- X := Shift_Right (X, US);
- end if;
-
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_LI;
-
- -----------
- -- W_LLF --
- -----------
-
- procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is
- I : constant Precision := Quadruple;
- E_Size : Integer renames Fields (I).E_Size;
- E_Bias : Integer renames Fields (I).E_Bias;
- E_Bytes : SEO renames Fields (I).E_Bytes;
- F_Bytes : SEO renames Fields (I).F_Bytes;
- F_Size : Integer renames Fields (I).F_Size;
-
- HFS : constant Integer := F_Size / 2;
-
- Exponent : Long_Unsigned;
- Fraction_1 : Long_Long_Unsigned;
- Fraction_2 : Long_Long_Unsigned;
- Is_Positive : Boolean;
- E : Integer;
- F : Long_Long_Float := Item;
- S : SEA (1 .. LLF_L) := (others => 0);
-
- begin
- if not Item'Valid then
- raise Constraint_Error;
- end if;
-
- -- Compute Sign
-
- Is_Positive := (0.0 <= Item);
-
- if F < 0.0 then
- F := -Item;
- end if;
-
- -- Signed zero
-
- if F = 0.0 then
- Exponent := 0;
- Fraction_1 := 0;
- Fraction_2 := 0;
-
- else
- E := Long_Long_Float'Exponent (F) - 1;
-
- -- Denormalized float
-
- if E <= -E_Bias then
- F := Long_Long_Float'Scaling (F, E_Bias - 1);
- E := -E_Bias;
- else
- F := Long_Long_Float'Scaling
- (Long_Long_Float'Fraction (F), 1);
- end if;
-
- -- Compute Exponent and Fraction
-
- Exponent := Long_Unsigned (E + E_Bias);
- F := Long_Long_Float'Scaling (F, F_Size - HFS);
- Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F));
- F := F - Long_Long_Float (Fraction_1);
- F := Long_Long_Float'Scaling (F, HFS);
- Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F));
- end if;
-
- -- Store Fraction_1
-
- for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop
- S (I) := SE (Fraction_1 mod BB);
- Fraction_1 := Fraction_1 / BB;
- end loop;
-
- -- Store Fraction_2
-
- for I in reverse LLF_L - 6 .. LLF_L loop
- S (SEO (I)) := SE (Fraction_2 mod BB);
- Fraction_2 := Fraction_2 / BB;
- end loop;
-
- -- Store Exponent (not always at the beginning of a byte)
-
- Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
- for N in reverse 1 .. E_Bytes loop
- S (N) := SE (Exponent mod BB) + S (N);
- Exponent := Exponent / BB;
- end loop;
-
- -- Store Sign
-
- if not Is_Positive then
- S (1) := S (1) + BS;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_LLF;
-
- -----------
- -- W_LLI --
- -----------
-
- procedure W_LLI
- (Stream : not null access RST;
- Item : Long_Long_Integer)
- is
- S : XDR_S_LLI;
- U : Unsigned;
- X : Long_Long_Unsigned;
-
- begin
- if Optimize_Integers then
- S := Long_Long_Integer_To_XDR_S_LLI (Item);
-
- else
- -- Test sign and apply two complement notation
-
- if Item < 0 then
- X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1));
- else
- X := Long_Long_Unsigned (Item);
- end if;
-
- -- Compute using machine unsigned rather than long_long_unsigned
-
- for N in reverse S'Range loop
-
- -- We have filled an unsigned
-
- if (LLU_L - N) mod UB = 0 then
- U := Unsigned (X and UL);
- X := Shift_Right (X, US);
- end if;
-
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_LLI;
-
- -----------
- -- W_LLU --
- -----------
-
- procedure W_LLU
- (Stream : not null access RST;
- Item : Long_Long_Unsigned)
- is
- S : XDR_S_LLU;
- U : Unsigned;
- X : Long_Long_Unsigned := Item;
-
- begin
- if Optimize_Integers then
- S := Long_Long_Unsigned_To_XDR_S_LLU (Item);
-
- else
- -- Compute using machine unsigned rather than long_long_unsigned
-
- for N in reverse S'Range loop
-
- -- We have filled an unsigned
-
- if (LLU_L - N) mod UB = 0 then
- U := Unsigned (X and UL);
- X := Shift_Right (X, US);
- end if;
-
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_LLU;
-
- ----------
- -- W_LU --
- ----------
-
- procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is
- S : XDR_S_LU;
- U : Unsigned;
- X : Long_Unsigned := Item;
-
- begin
- if Optimize_Integers then
- S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item));
-
- else
- -- Compute using machine unsigned rather than long_unsigned
-
- for N in reverse S'Range loop
-
- -- We have filled an unsigned
-
- if (LU_L - N) mod UB = 0 then
- U := Unsigned (X and UL);
- X := Shift_Right (X, US);
- end if;
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_LU;
-
- ----------
- -- W_SF --
- ----------
-
- procedure W_SF (Stream : not null access RST; Item : Short_Float) is
- I : constant Precision := Single;
- E_Size : Integer renames Fields (I).E_Size;
- E_Bias : Integer renames Fields (I).E_Bias;
- E_Bytes : SEO renames Fields (I).E_Bytes;
- F_Bytes : SEO renames Fields (I).F_Bytes;
- F_Size : Integer renames Fields (I).F_Size;
- F_Mask : SE renames Fields (I).F_Mask;
-
- Exponent : Long_Unsigned;
- Fraction : Long_Unsigned;
- Is_Positive : Boolean;
- E : Integer;
- F : Short_Float;
- S : SEA (1 .. SF_L) := (others => 0);
-
- begin
- if not Item'Valid then
- raise Constraint_Error;
- end if;
-
- -- Compute Sign
-
- Is_Positive := (0.0 <= Item);
- F := abs (Item);
-
- -- Signed zero
-
- if F = 0.0 then
- Exponent := 0;
- Fraction := 0;
-
- else
- E := Short_Float'Exponent (F) - 1;
-
- -- Denormalized float
-
- if E <= -E_Bias then
- E := -E_Bias;
- F := Short_Float'Scaling (F, F_Size + E_Bias - 1);
- else
- F := Short_Float'Scaling (F, F_Size - E);
- end if;
-
- -- Compute Exponent and Fraction
-
- Exponent := Long_Unsigned (E + E_Bias);
- Fraction := Long_Unsigned (F * 2.0) / 2;
- end if;
-
- -- Store Fraction
-
- for I in reverse SF_L - F_Bytes + 1 .. SF_L loop
- S (I) := SE (Fraction mod BB);
- Fraction := Fraction / BB;
- end loop;
-
- -- Remove implicit bit
-
- S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask;
-
- -- Store Exponent (not always at the beginning of a byte)
-
- Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
- for N in reverse 1 .. E_Bytes loop
- S (N) := SE (Exponent mod BB) + S (N);
- Exponent := Exponent / BB;
- end loop;
-
- -- Store Sign
-
- if not Is_Positive then
- S (1) := S (1) + BS;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_SF;
-
- ----------
- -- W_SI --
- ----------
-
- procedure W_SI (Stream : not null access RST; Item : Short_Integer) is
- S : XDR_S_SI;
- U : XDR_SU;
-
- begin
- if Optimize_Integers then
- S := Short_Integer_To_XDR_S_SI (Item);
-
- else
- -- Test sign and apply two complement's notation
-
- U := (if Item < 0
- then XDR_SU'Last xor XDR_SU (-(Item + 1))
- else XDR_SU (Item));
-
- for N in reverse S'Range loop
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_SI;
-
- -----------
- -- W_SSI --
- -----------
-
- procedure W_SSI
- (Stream : not null access RST;
- Item : Short_Short_Integer)
- is
- S : XDR_S_SSI;
- U : XDR_SSU;
-
- begin
- if Optimize_Integers then
- S := Short_Short_Integer_To_XDR_S_SSI (Item);
-
- else
- -- Test sign and apply two complement's notation
-
- U := (if Item < 0
- then XDR_SSU'Last xor XDR_SSU (-(Item + 1))
- else XDR_SSU (Item));
-
- S (1) := SE (U);
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_SSI;
-
- -----------
- -- W_SSU --
- -----------
-
- procedure W_SSU
- (Stream : not null access RST;
- Item : Short_Short_Unsigned)
- is
- U : constant XDR_SSU := XDR_SSU (Item);
- S : XDR_S_SSU;
-
- begin
- S (1) := SE (U);
- Ada.Streams.Write (Stream.all, S);
- end W_SSU;
-
- ----------
- -- W_SU --
- ----------
-
- procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is
- S : XDR_S_SU;
- U : XDR_SU := XDR_SU (Item);
-
- begin
- if Optimize_Integers then
- S := Short_Unsigned_To_XDR_S_SU (Item);
-
- else
- for N in reverse S'Range loop
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_SU;
-
- ---------
- -- W_U --
- ---------
-
- procedure W_U (Stream : not null access RST; Item : Unsigned) is
- S : XDR_S_U;
- U : XDR_U := XDR_U (Item);
-
- begin
- if Optimize_Integers then
- S := Unsigned_To_XDR_S_U (Item);
-
- else
- for N in reverse S'Range loop
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end if;
-
- Ada.Streams.Write (Stream.all, S);
- end W_U;
-
- ----------
- -- W_WC --
- ----------
-
- procedure W_WC (Stream : not null access RST; Item : Wide_Character) is
- S : XDR_S_WC;
- U : XDR_WC;
-
- begin
- -- Use Ada requirements on Wide_Character representation clause
-
- U := XDR_WC (Wide_Character'Pos (Item));
-
- for N in reverse S'Range loop
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- Ada.Streams.Write (Stream.all, S);
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end W_WC;
-
- -----------
- -- W_WWC --
- -----------
-
- procedure W_WWC
- (Stream : not null access RST; Item : Wide_Wide_Character)
- is
- S : XDR_S_WWC;
- U : XDR_WWC;
-
- begin
- -- Use Ada requirements on Wide_Wide_Character representation clause
-
- U := XDR_WWC (Wide_Wide_Character'Pos (Item));
-
- for N in reverse S'Range loop
- S (N) := SE (U mod BB);
- U := U / BB;
- end loop;
-
- Ada.Streams.Write (Stream.all, S);
-
- if U /= 0 then
- raise Data_Error;
- end if;
- end W_WWC;
-
-end System.Stream_Attributes;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . S T R E A M _ A T T R I B U T E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1996-2017, Free Software Foundation, Inc. --
+-- --
+-- GARLIC is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This file is an alternate version of s-stratt.adb based on the XDR
+-- standard. It is especially useful for exchanging streams between two
+-- different systems with different basic type representations and endianness.
+
+pragma Warnings (Off, "*not allowed in compiler unit");
+-- This body is used only when rebuilding the runtime library, not when
+-- building the compiler, so it's OK to depend on features that would
+-- otherwise break bootstrap (e.g. IF-expressions).
+
+with Ada.IO_Exceptions;
+with Ada.Streams; use Ada.Streams;
+with Ada.Unchecked_Conversion;
+
+package body System.Stream_Attributes is
+
+ pragma Suppress (Range_Check);
+ pragma Suppress (Overflow_Check);
+
+ use UST;
+
+ Data_Error : exception renames Ada.IO_Exceptions.End_Error;
+ -- Exception raised if insufficient data read (End_Error is mandated by
+ -- AI95-00132).
+
+ SU : constant := System.Storage_Unit;
+ -- The code in this body assumes that SU = 8
+
+ BB : constant := 2 ** SU; -- Byte base
+ BL : constant := 2 ** SU - 1; -- Byte last
+ BS : constant := 2 ** (SU - 1); -- Byte sign
+
+ US : constant := Unsigned'Size; -- Unsigned size
+ UB : constant := (US - 1) / SU + 1; -- Unsigned byte
+ UL : constant := 2 ** US - 1; -- Unsigned last
+
+ subtype SE is Ada.Streams.Stream_Element;
+ subtype SEA is Ada.Streams.Stream_Element_Array;
+ subtype SEO is Ada.Streams.Stream_Element_Offset;
+
+ generic function UC renames Ada.Unchecked_Conversion;
+
+ type Field_Type is
+ record
+ E_Size : Integer; -- Exponent bit size
+ E_Bias : Integer; -- Exponent bias
+ F_Size : Integer; -- Fraction bit size
+ E_Last : Integer; -- Max exponent value
+ F_Mask : SE; -- Mask to apply on first fraction byte
+ E_Bytes : SEO; -- N. of exponent bytes completely used
+ F_Bytes : SEO; -- N. of fraction bytes completely used
+ F_Bits : Integer; -- N. of bits used on first fraction word
+ end record;
+
+ type Precision is (Single, Double, Quadruple);
+
+ Fields : constant array (Precision) of Field_Type := (
+
+ -- Single precision
+
+ (E_Size => 8,
+ E_Bias => 127,
+ F_Size => 23,
+ E_Last => 2 ** 8 - 1,
+ F_Mask => 16#7F#, -- 2 ** 7 - 1,
+ E_Bytes => 2,
+ F_Bytes => 3,
+ F_Bits => 23 mod US),
+
+ -- Double precision
+
+ (E_Size => 11,
+ E_Bias => 1023,
+ F_Size => 52,
+ E_Last => 2 ** 11 - 1,
+ F_Mask => 16#0F#, -- 2 ** 4 - 1,
+ E_Bytes => 2,
+ F_Bytes => 7,
+ F_Bits => 52 mod US),
+
+ -- Quadruple precision
+
+ (E_Size => 15,
+ E_Bias => 16383,
+ F_Size => 112,
+ E_Last => 2 ** 8 - 1,
+ F_Mask => 16#FF#, -- 2 ** 8 - 1,
+ E_Bytes => 2,
+ F_Bytes => 14,
+ F_Bits => 112 mod US));
+
+ -- The representation of all items requires a multiple of four bytes
+ -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes
+ -- are read or written to some byte stream such that byte m always
+ -- precedes byte m+1. If the n bytes needed to contain the data are not
+ -- a multiple of four, then the n bytes are followed by enough (0 to 3)
+ -- residual zero bytes, r, to make the total byte count a multiple of 4.
+
+ -- An XDR signed integer is a 32-bit datum that encodes an integer
+ -- in the range [-2147483648,2147483647]. The integer is represented
+ -- in two's complement notation. The most and least significant bytes
+ -- are 0 and 3, respectively. Integers are declared as follows:
+
+ -- (MSB) (LSB)
+ -- +-------+-------+-------+-------+
+ -- |byte 0 |byte 1 |byte 2 |byte 3 |
+ -- +-------+-------+-------+-------+
+ -- <------------32 bits------------>
+
+ SSI_L : constant := 1;
+ SI_L : constant := 2;
+ I_L : constant := 4;
+ LI_L : constant := 8;
+ LLI_L : constant := 8;
+
+ subtype XDR_S_SSI is SEA (1 .. SSI_L);
+ subtype XDR_S_SI is SEA (1 .. SI_L);
+ subtype XDR_S_I is SEA (1 .. I_L);
+ subtype XDR_S_LI is SEA (1 .. LI_L);
+ subtype XDR_S_LLI is SEA (1 .. LLI_L);
+
+ function Short_Short_Integer_To_XDR_S_SSI is
+ new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI);
+ function XDR_S_SSI_To_Short_Short_Integer is
+ new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer);
+
+ function Short_Integer_To_XDR_S_SI is
+ new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI);
+ function XDR_S_SI_To_Short_Integer is
+ new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer);
+
+ function Integer_To_XDR_S_I is
+ new Ada.Unchecked_Conversion (Integer, XDR_S_I);
+ function XDR_S_I_To_Integer is
+ new Ada.Unchecked_Conversion (XDR_S_I, Integer);
+
+ function Long_Long_Integer_To_XDR_S_LI is
+ new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI);
+ function XDR_S_LI_To_Long_Long_Integer is
+ new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer);
+
+ function Long_Long_Integer_To_XDR_S_LLI is
+ new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI);
+ function XDR_S_LLI_To_Long_Long_Integer is
+ new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer);
+
+ -- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative
+ -- integer in the range [0,4294967295]. It is represented by an unsigned
+ -- binary number whose most and least significant bytes are 0 and 3,
+ -- respectively. An unsigned integer is declared as follows:
+
+ -- (MSB) (LSB)
+ -- +-------+-------+-------+-------+
+ -- |byte 0 |byte 1 |byte 2 |byte 3 |
+ -- +-------+-------+-------+-------+
+ -- <------------32 bits------------>
+
+ SSU_L : constant := 1;
+ SU_L : constant := 2;
+ U_L : constant := 4;
+ LU_L : constant := 8;
+ LLU_L : constant := 8;
+
+ subtype XDR_S_SSU is SEA (1 .. SSU_L);
+ subtype XDR_S_SU is SEA (1 .. SU_L);
+ subtype XDR_S_U is SEA (1 .. U_L);
+ subtype XDR_S_LU is SEA (1 .. LU_L);
+ subtype XDR_S_LLU is SEA (1 .. LLU_L);
+
+ type XDR_SSU is mod BB ** SSU_L;
+ type XDR_SU is mod BB ** SU_L;
+ type XDR_U is mod BB ** U_L;
+
+ function Short_Unsigned_To_XDR_S_SU is
+ new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU);
+ function XDR_S_SU_To_Short_Unsigned is
+ new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned);
+
+ function Unsigned_To_XDR_S_U is
+ new Ada.Unchecked_Conversion (Unsigned, XDR_S_U);
+ function XDR_S_U_To_Unsigned is
+ new Ada.Unchecked_Conversion (XDR_S_U, Unsigned);
+
+ function Long_Long_Unsigned_To_XDR_S_LU is
+ new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU);
+ function XDR_S_LU_To_Long_Long_Unsigned is
+ new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned);
+
+ function Long_Long_Unsigned_To_XDR_S_LLU is
+ new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU);
+ function XDR_S_LLU_To_Long_Long_Unsigned is
+ new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned);
+
+ -- The standard defines the floating-point data type "float" (32 bits
+ -- or 4 bytes). The encoding used is the IEEE standard for normalized
+ -- single-precision floating-point numbers.
+
+ -- The standard defines the encoding used for the double-precision
+ -- floating-point data type "double" (64 bits or 8 bytes). The encoding
+ -- used is the IEEE standard for normalized double-precision floating-point
+ -- numbers.
+
+ SF_L : constant := 4; -- Single precision
+ F_L : constant := 4; -- Single precision
+ LF_L : constant := 8; -- Double precision
+ LLF_L : constant := 16; -- Quadruple precision
+
+ TM_L : constant := 8;
+ subtype XDR_S_TM is SEA (1 .. TM_L);
+ type XDR_TM is mod BB ** TM_L;
+
+ type XDR_SA is mod 2 ** Standard'Address_Size;
+ function To_XDR_SA is new UC (System.Address, XDR_SA);
+ function To_XDR_SA is new UC (XDR_SA, System.Address);
+
+ -- Enumerations have the same representation as signed integers.
+ -- Enumerations are handy for describing subsets of the integers.
+
+ -- Booleans are important enough and occur frequently enough to warrant
+ -- their own explicit type in the standard. Booleans are declared as
+ -- an enumeration, with FALSE = 0 and TRUE = 1.
+
+ -- The standard defines a string of n (numbered 0 through n-1) ASCII
+ -- bytes to be the number n encoded as an unsigned integer (as described
+ -- above), and followed by the n bytes of the string. Byte m of the string
+ -- always precedes byte m+1 of the string, and byte 0 of the string always
+ -- follows the string's length. If n is not a multiple of four, then the
+ -- n bytes are followed by enough (0 to 3) residual zero bytes, r, to make
+ -- the total byte count a multiple of four.
+
+ -- To fit with XDR string, do not consider character as an enumeration
+ -- type.
+
+ C_L : constant := 1;
+ subtype XDR_S_C is SEA (1 .. C_L);
+
+ -- Consider Wide_Character as an enumeration type
+
+ WC_L : constant := 4;
+ subtype XDR_S_WC is SEA (1 .. WC_L);
+ type XDR_WC is mod BB ** WC_L;
+
+ -- Consider Wide_Wide_Character as an enumeration type
+
+ WWC_L : constant := 8;
+ subtype XDR_S_WWC is SEA (1 .. WWC_L);
+ type XDR_WWC is mod BB ** WWC_L;
+
+ -- Optimization: if we already have the correct Bit_Order, then some
+ -- computations can be avoided since the source and the target will be
+ -- identical anyway. They will be replaced by direct unchecked
+ -- conversions.
+
+ Optimize_Integers : constant Boolean :=
+ Default_Bit_Order = High_Order_First;
+
+ -----------------
+ -- Block_IO_OK --
+ -----------------
+
+ -- We must inhibit Block_IO, because in XDR mode, each element is output
+ -- according to XDR requirements, which is not at all the same as writing
+ -- the whole array in one block.
+
+ function Block_IO_OK return Boolean is
+ begin
+ return False;
+ end Block_IO_OK;
+
+ ----------
+ -- I_AD --
+ ----------
+
+ function I_AD (Stream : not null access RST) return Fat_Pointer is
+ FP : Fat_Pointer;
+
+ begin
+ FP.P1 := I_AS (Stream).P1;
+ FP.P2 := I_AS (Stream).P1;
+
+ return FP;
+ end I_AD;
+
+ ----------
+ -- I_AS --
+ ----------
+
+ function I_AS (Stream : not null access RST) return Thin_Pointer is
+ S : XDR_S_TM;
+ L : SEO;
+ U : XDR_TM := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_TM (S (N));
+ end loop;
+
+ return (P1 => To_XDR_SA (XDR_SA (U)));
+ end if;
+ end I_AS;
+
+ ---------
+ -- I_B --
+ ---------
+
+ function I_B (Stream : not null access RST) return Boolean is
+ begin
+ case I_SSU (Stream) is
+ when 0 => return False;
+ when 1 => return True;
+ when others => raise Data_Error;
+ end case;
+ end I_B;
+
+ ---------
+ -- I_C --
+ ---------
+
+ function I_C (Stream : not null access RST) return Character is
+ S : XDR_S_C;
+ L : SEO;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ else
+ -- Use Ada requirements on Character representation clause
+
+ return Character'Val (S (1));
+ end if;
+ end I_C;
+
+ ---------
+ -- I_F --
+ ---------
+
+ function I_F (Stream : not null access RST) return Float is
+ I : constant Precision := Single;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Last : Integer renames Fields (I).E_Last;
+ F_Mask : SE renames Fields (I).F_Mask;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+
+ Is_Positive : Boolean;
+ Exponent : Long_Unsigned;
+ Fraction : Long_Unsigned;
+ Result : Float;
+ S : SEA (1 .. F_L);
+ L : SEO;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ end if;
+
+ -- Extract Fraction, Sign and Exponent
+
+ Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask);
+ for N in F_L + 2 - F_Bytes .. F_L loop
+ Fraction := Fraction * BB + Long_Unsigned (S (N));
+ end loop;
+ Result := Float'Scaling (Float (Fraction), -F_Size);
+
+ if BS <= S (1) then
+ Is_Positive := False;
+ Exponent := Long_Unsigned (S (1) - BS);
+ else
+ Is_Positive := True;
+ Exponent := Long_Unsigned (S (1));
+ end if;
+
+ for N in 2 .. E_Bytes loop
+ Exponent := Exponent * BB + Long_Unsigned (S (N));
+ end loop;
+ Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+
+ -- NaN or Infinities
+
+ if Integer (Exponent) = E_Last then
+ raise Constraint_Error;
+
+ elsif Exponent = 0 then
+
+ -- Signed zeros
+
+ if Fraction = 0 then
+ null;
+
+ -- Denormalized float
+
+ else
+ Result := Float'Scaling (Result, 1 - E_Bias);
+ end if;
+
+ -- Normalized float
+
+ else
+ Result := Float'Scaling
+ (1.0 + Result, Integer (Exponent) - E_Bias);
+ end if;
+
+ if not Is_Positive then
+ Result := -Result;
+ end if;
+
+ return Result;
+ end I_F;
+
+ ---------
+ -- I_I --
+ ---------
+
+ function I_I (Stream : not null access RST) return Integer is
+ S : XDR_S_I;
+ L : SEO;
+ U : XDR_U := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_I_To_Integer (S);
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_U (S (N));
+ end loop;
+
+ -- Test sign and apply two complement notation
+
+ if S (1) < BL then
+ return Integer (U);
+
+ else
+ return Integer (-((XDR_U'Last xor U) + 1));
+ end if;
+ end if;
+ end I_I;
+
+ ----------
+ -- I_LF --
+ ----------
+
+ function I_LF (Stream : not null access RST) return Long_Float is
+ I : constant Precision := Double;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Last : Integer renames Fields (I).E_Last;
+ F_Mask : SE renames Fields (I).F_Mask;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+
+ Is_Positive : Boolean;
+ Exponent : Long_Unsigned;
+ Fraction : Long_Long_Unsigned;
+ Result : Long_Float;
+ S : SEA (1 .. LF_L);
+ L : SEO;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ end if;
+
+ -- Extract Fraction, Sign and Exponent
+
+ Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask);
+ for N in LF_L + 2 - F_Bytes .. LF_L loop
+ Fraction := Fraction * BB + Long_Long_Unsigned (S (N));
+ end loop;
+
+ Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size);
+
+ if BS <= S (1) then
+ Is_Positive := False;
+ Exponent := Long_Unsigned (S (1) - BS);
+ else
+ Is_Positive := True;
+ Exponent := Long_Unsigned (S (1));
+ end if;
+
+ for N in 2 .. E_Bytes loop
+ Exponent := Exponent * BB + Long_Unsigned (S (N));
+ end loop;
+
+ Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+
+ -- NaN or Infinities
+
+ if Integer (Exponent) = E_Last then
+ raise Constraint_Error;
+
+ elsif Exponent = 0 then
+
+ -- Signed zeros
+
+ if Fraction = 0 then
+ null;
+
+ -- Denormalized float
+
+ else
+ Result := Long_Float'Scaling (Result, 1 - E_Bias);
+ end if;
+
+ -- Normalized float
+
+ else
+ Result := Long_Float'Scaling
+ (1.0 + Result, Integer (Exponent) - E_Bias);
+ end if;
+
+ if not Is_Positive then
+ Result := -Result;
+ end if;
+
+ return Result;
+ end I_LF;
+
+ ----------
+ -- I_LI --
+ ----------
+
+ function I_LI (Stream : not null access RST) return Long_Integer is
+ S : XDR_S_LI;
+ L : SEO;
+ U : Unsigned := 0;
+ X : Long_Unsigned := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S));
+
+ else
+
+ -- Compute using machine unsigned
+ -- rather than long_long_unsigned
+
+ for N in S'Range loop
+ U := U * BB + Unsigned (S (N));
+
+ -- We have filled an unsigned
+
+ if N mod UB = 0 then
+ X := Shift_Left (X, US) + Long_Unsigned (U);
+ U := 0;
+ end if;
+ end loop;
+
+ -- Test sign and apply two complement notation
+
+ if S (1) < BL then
+ return Long_Integer (X);
+ else
+ return Long_Integer (-((Long_Unsigned'Last xor X) + 1));
+ end if;
+
+ end if;
+ end I_LI;
+
+ -----------
+ -- I_LLF --
+ -----------
+
+ function I_LLF (Stream : not null access RST) return Long_Long_Float is
+ I : constant Precision := Quadruple;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Last : Integer renames Fields (I).E_Last;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+
+ Is_Positive : Boolean;
+ Exponent : Long_Unsigned;
+ Fraction_1 : Long_Long_Unsigned := 0;
+ Fraction_2 : Long_Long_Unsigned := 0;
+ Result : Long_Long_Float;
+ HF : constant Natural := F_Size / 2;
+ S : SEA (1 .. LLF_L);
+ L : SEO;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ end if;
+
+ -- Extract Fraction, Sign and Exponent
+
+ for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop
+ Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I));
+ end loop;
+
+ for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop
+ Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I));
+ end loop;
+
+ Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF);
+ Result := Long_Long_Float (Fraction_1) + Result;
+ Result := Long_Long_Float'Scaling (Result, HF - F_Size);
+
+ if BS <= S (1) then
+ Is_Positive := False;
+ Exponent := Long_Unsigned (S (1) - BS);
+ else
+ Is_Positive := True;
+ Exponent := Long_Unsigned (S (1));
+ end if;
+
+ for N in 2 .. E_Bytes loop
+ Exponent := Exponent * BB + Long_Unsigned (S (N));
+ end loop;
+
+ Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+
+ -- NaN or Infinities
+
+ if Integer (Exponent) = E_Last then
+ raise Constraint_Error;
+
+ elsif Exponent = 0 then
+
+ -- Signed zeros
+
+ if Fraction_1 = 0 and then Fraction_2 = 0 then
+ null;
+
+ -- Denormalized float
+
+ else
+ Result := Long_Long_Float'Scaling (Result, 1 - E_Bias);
+ end if;
+
+ -- Normalized float
+
+ else
+ Result := Long_Long_Float'Scaling
+ (1.0 + Result, Integer (Exponent) - E_Bias);
+ end if;
+
+ if not Is_Positive then
+ Result := -Result;
+ end if;
+
+ return Result;
+ end I_LLF;
+
+ -----------
+ -- I_LLI --
+ -----------
+
+ function I_LLI (Stream : not null access RST) return Long_Long_Integer is
+ S : XDR_S_LLI;
+ L : SEO;
+ U : Unsigned := 0;
+ X : Long_Long_Unsigned := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_LLI_To_Long_Long_Integer (S);
+
+ else
+ -- Compute using machine unsigned for computing
+ -- rather than long_long_unsigned.
+
+ for N in S'Range loop
+ U := U * BB + Unsigned (S (N));
+
+ -- We have filled an unsigned
+
+ if N mod UB = 0 then
+ X := Shift_Left (X, US) + Long_Long_Unsigned (U);
+ U := 0;
+ end if;
+ end loop;
+
+ -- Test sign and apply two complement notation
+
+ if S (1) < BL then
+ return Long_Long_Integer (X);
+ else
+ return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1));
+ end if;
+ end if;
+ end I_LLI;
+
+ -----------
+ -- I_LLU --
+ -----------
+
+ function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is
+ S : XDR_S_LLU;
+ L : SEO;
+ U : Unsigned := 0;
+ X : Long_Long_Unsigned := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_LLU_To_Long_Long_Unsigned (S);
+
+ else
+ -- Compute using machine unsigned
+ -- rather than long_long_unsigned.
+
+ for N in S'Range loop
+ U := U * BB + Unsigned (S (N));
+
+ -- We have filled an unsigned
+
+ if N mod UB = 0 then
+ X := Shift_Left (X, US) + Long_Long_Unsigned (U);
+ U := 0;
+ end if;
+ end loop;
+
+ return X;
+ end if;
+ end I_LLU;
+
+ ----------
+ -- I_LU --
+ ----------
+
+ function I_LU (Stream : not null access RST) return Long_Unsigned is
+ S : XDR_S_LU;
+ L : SEO;
+ U : Unsigned := 0;
+ X : Long_Unsigned := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S));
+
+ else
+ -- Compute using machine unsigned
+ -- rather than long_unsigned.
+
+ for N in S'Range loop
+ U := U * BB + Unsigned (S (N));
+
+ -- We have filled an unsigned
+
+ if N mod UB = 0 then
+ X := Shift_Left (X, US) + Long_Unsigned (U);
+ U := 0;
+ end if;
+ end loop;
+
+ return X;
+ end if;
+ end I_LU;
+
+ ----------
+ -- I_SF --
+ ----------
+
+ function I_SF (Stream : not null access RST) return Short_Float is
+ I : constant Precision := Single;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Last : Integer renames Fields (I).E_Last;
+ F_Mask : SE renames Fields (I).F_Mask;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+
+ Exponent : Long_Unsigned;
+ Fraction : Long_Unsigned;
+ Is_Positive : Boolean;
+ Result : Short_Float;
+ S : SEA (1 .. SF_L);
+ L : SEO;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ end if;
+
+ -- Extract Fraction, Sign and Exponent
+
+ Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask);
+ for N in SF_L + 2 - F_Bytes .. SF_L loop
+ Fraction := Fraction * BB + Long_Unsigned (S (N));
+ end loop;
+ Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size);
+
+ if BS <= S (1) then
+ Is_Positive := False;
+ Exponent := Long_Unsigned (S (1) - BS);
+ else
+ Is_Positive := True;
+ Exponent := Long_Unsigned (S (1));
+ end if;
+
+ for N in 2 .. E_Bytes loop
+ Exponent := Exponent * BB + Long_Unsigned (S (N));
+ end loop;
+ Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+
+ -- NaN or Infinities
+
+ if Integer (Exponent) = E_Last then
+ raise Constraint_Error;
+
+ elsif Exponent = 0 then
+
+ -- Signed zeros
+
+ if Fraction = 0 then
+ null;
+
+ -- Denormalized float
+
+ else
+ Result := Short_Float'Scaling (Result, 1 - E_Bias);
+ end if;
+
+ -- Normalized float
+
+ else
+ Result := Short_Float'Scaling
+ (1.0 + Result, Integer (Exponent) - E_Bias);
+ end if;
+
+ if not Is_Positive then
+ Result := -Result;
+ end if;
+
+ return Result;
+ end I_SF;
+
+ ----------
+ -- I_SI --
+ ----------
+
+ function I_SI (Stream : not null access RST) return Short_Integer is
+ S : XDR_S_SI;
+ L : SEO;
+ U : XDR_SU := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_SI_To_Short_Integer (S);
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_SU (S (N));
+ end loop;
+
+ -- Test sign and apply two complement notation
+
+ if S (1) < BL then
+ return Short_Integer (U);
+ else
+ return Short_Integer (-((XDR_SU'Last xor U) + 1));
+ end if;
+ end if;
+ end I_SI;
+
+ -----------
+ -- I_SSI --
+ -----------
+
+ function I_SSI (Stream : not null access RST) return Short_Short_Integer is
+ S : XDR_S_SSI;
+ L : SEO;
+ U : XDR_SSU;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_SSI_To_Short_Short_Integer (S);
+
+ else
+ U := XDR_SSU (S (1));
+
+ -- Test sign and apply two complement notation
+
+ if S (1) < BL then
+ return Short_Short_Integer (U);
+ else
+ return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1));
+ end if;
+ end if;
+ end I_SSI;
+
+ -----------
+ -- I_SSU --
+ -----------
+
+ function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is
+ S : XDR_S_SSU;
+ L : SEO;
+ U : XDR_SSU := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ else
+ U := XDR_SSU (S (1));
+ return Short_Short_Unsigned (U);
+ end if;
+ end I_SSU;
+
+ ----------
+ -- I_SU --
+ ----------
+
+ function I_SU (Stream : not null access RST) return Short_Unsigned is
+ S : XDR_S_SU;
+ L : SEO;
+ U : XDR_SU := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_SU_To_Short_Unsigned (S);
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_SU (S (N));
+ end loop;
+
+ return Short_Unsigned (U);
+ end if;
+ end I_SU;
+
+ ---------
+ -- I_U --
+ ---------
+
+ function I_U (Stream : not null access RST) return Unsigned is
+ S : XDR_S_U;
+ L : SEO;
+ U : XDR_U := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_U_To_Unsigned (S);
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_U (S (N));
+ end loop;
+
+ return Unsigned (U);
+ end if;
+ end I_U;
+
+ ----------
+ -- I_WC --
+ ----------
+
+ function I_WC (Stream : not null access RST) return Wide_Character is
+ S : XDR_S_WC;
+ L : SEO;
+ U : XDR_WC := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_WC (S (N));
+ end loop;
+
+ -- Use Ada requirements on Wide_Character representation clause
+
+ return Wide_Character'Val (U);
+ end if;
+ end I_WC;
+
+ -----------
+ -- I_WWC --
+ -----------
+
+ function I_WWC (Stream : not null access RST) return Wide_Wide_Character is
+ S : XDR_S_WWC;
+ L : SEO;
+ U : XDR_WWC := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_WWC (S (N));
+ end loop;
+
+ -- Use Ada requirements on Wide_Wide_Character representation clause
+
+ return Wide_Wide_Character'Val (U);
+ end if;
+ end I_WWC;
+
+ ----------
+ -- W_AD --
+ ----------
+
+ procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is
+ S : XDR_S_TM;
+ U : XDR_TM;
+
+ begin
+ U := XDR_TM (To_XDR_SA (Item.P1));
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ Ada.Streams.Write (Stream.all, S);
+
+ U := XDR_TM (To_XDR_SA (Item.P2));
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ Ada.Streams.Write (Stream.all, S);
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end W_AD;
+
+ ----------
+ -- W_AS --
+ ----------
+
+ procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is
+ S : XDR_S_TM;
+ U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1));
+
+ begin
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ Ada.Streams.Write (Stream.all, S);
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end W_AS;
+
+ ---------
+ -- W_B --
+ ---------
+
+ procedure W_B (Stream : not null access RST; Item : Boolean) is
+ begin
+ if Item then
+ W_SSU (Stream, 1);
+ else
+ W_SSU (Stream, 0);
+ end if;
+ end W_B;
+
+ ---------
+ -- W_C --
+ ---------
+
+ procedure W_C (Stream : not null access RST; Item : Character) is
+ S : XDR_S_C;
+
+ pragma Assert (C_L = 1);
+
+ begin
+ -- Use Ada requirements on Character representation clause
+
+ S (1) := SE (Character'Pos (Item));
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_C;
+
+ ---------
+ -- W_F --
+ ---------
+
+ procedure W_F (Stream : not null access RST; Item : Float) is
+ I : constant Precision := Single;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+ F_Mask : SE renames Fields (I).F_Mask;
+
+ Exponent : Long_Unsigned;
+ Fraction : Long_Unsigned;
+ Is_Positive : Boolean;
+ E : Integer;
+ F : Float;
+ S : SEA (1 .. F_L) := (others => 0);
+
+ begin
+ if not Item'Valid then
+ raise Constraint_Error;
+ end if;
+
+ -- Compute Sign
+
+ Is_Positive := (0.0 <= Item);
+ F := abs (Item);
+
+ -- Signed zero
+
+ if F = 0.0 then
+ Exponent := 0;
+ Fraction := 0;
+
+ else
+ E := Float'Exponent (F) - 1;
+
+ -- Denormalized float
+
+ if E <= -E_Bias then
+ F := Float'Scaling (F, F_Size + E_Bias - 1);
+ E := -E_Bias;
+ else
+ F := Float'Scaling (Float'Fraction (F), F_Size + 1);
+ end if;
+
+ -- Compute Exponent and Fraction
+
+ Exponent := Long_Unsigned (E + E_Bias);
+ Fraction := Long_Unsigned (F * 2.0) / 2;
+ end if;
+
+ -- Store Fraction
+
+ for I in reverse F_L - F_Bytes + 1 .. F_L loop
+ S (I) := SE (Fraction mod BB);
+ Fraction := Fraction / BB;
+ end loop;
+
+ -- Remove implicit bit
+
+ S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask;
+
+ -- Store Exponent (not always at the beginning of a byte)
+
+ Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+ for N in reverse 1 .. E_Bytes loop
+ S (N) := SE (Exponent mod BB) + S (N);
+ Exponent := Exponent / BB;
+ end loop;
+
+ -- Store Sign
+
+ if not Is_Positive then
+ S (1) := S (1) + BS;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_F;
+
+ ---------
+ -- W_I --
+ ---------
+
+ procedure W_I (Stream : not null access RST; Item : Integer) is
+ S : XDR_S_I;
+ U : XDR_U;
+
+ begin
+ if Optimize_Integers then
+ S := Integer_To_XDR_S_I (Item);
+
+ else
+ -- Test sign and apply two complement notation
+
+ U := (if Item < 0
+ then XDR_U'Last xor XDR_U (-(Item + 1))
+ else XDR_U (Item));
+
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_I;
+
+ ----------
+ -- W_LF --
+ ----------
+
+ procedure W_LF (Stream : not null access RST; Item : Long_Float) is
+ I : constant Precision := Double;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+ F_Mask : SE renames Fields (I).F_Mask;
+
+ Exponent : Long_Unsigned;
+ Fraction : Long_Long_Unsigned;
+ Is_Positive : Boolean;
+ E : Integer;
+ F : Long_Float;
+ S : SEA (1 .. LF_L) := (others => 0);
+
+ begin
+ if not Item'Valid then
+ raise Constraint_Error;
+ end if;
+
+ -- Compute Sign
+
+ Is_Positive := (0.0 <= Item);
+ F := abs (Item);
+
+ -- Signed zero
+
+ if F = 0.0 then
+ Exponent := 0;
+ Fraction := 0;
+
+ else
+ E := Long_Float'Exponent (F) - 1;
+
+ -- Denormalized float
+
+ if E <= -E_Bias then
+ E := -E_Bias;
+ F := Long_Float'Scaling (F, F_Size + E_Bias - 1);
+ else
+ F := Long_Float'Scaling (F, F_Size - E);
+ end if;
+
+ -- Compute Exponent and Fraction
+
+ Exponent := Long_Unsigned (E + E_Bias);
+ Fraction := Long_Long_Unsigned (F * 2.0) / 2;
+ end if;
+
+ -- Store Fraction
+
+ for I in reverse LF_L - F_Bytes + 1 .. LF_L loop
+ S (I) := SE (Fraction mod BB);
+ Fraction := Fraction / BB;
+ end loop;
+
+ -- Remove implicit bit
+
+ S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask;
+
+ -- Store Exponent (not always at the beginning of a byte)
+
+ Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+ for N in reverse 1 .. E_Bytes loop
+ S (N) := SE (Exponent mod BB) + S (N);
+ Exponent := Exponent / BB;
+ end loop;
+
+ -- Store Sign
+
+ if not Is_Positive then
+ S (1) := S (1) + BS;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LF;
+
+ ----------
+ -- W_LI --
+ ----------
+
+ procedure W_LI (Stream : not null access RST; Item : Long_Integer) is
+ S : XDR_S_LI;
+ U : Unsigned;
+ X : Long_Unsigned;
+
+ begin
+ if Optimize_Integers then
+ S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item));
+
+ else
+ -- Test sign and apply two complement notation
+
+ if Item < 0 then
+ X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1));
+ else
+ X := Long_Unsigned (Item);
+ end if;
+
+ -- Compute using machine unsigned rather than long_unsigned
+
+ for N in reverse S'Range loop
+
+ -- We have filled an unsigned
+
+ if (LU_L - N) mod UB = 0 then
+ U := Unsigned (X and UL);
+ X := Shift_Right (X, US);
+ end if;
+
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LI;
+
+ -----------
+ -- W_LLF --
+ -----------
+
+ procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is
+ I : constant Precision := Quadruple;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+
+ HFS : constant Integer := F_Size / 2;
+
+ Exponent : Long_Unsigned;
+ Fraction_1 : Long_Long_Unsigned;
+ Fraction_2 : Long_Long_Unsigned;
+ Is_Positive : Boolean;
+ E : Integer;
+ F : Long_Long_Float := Item;
+ S : SEA (1 .. LLF_L) := (others => 0);
+
+ begin
+ if not Item'Valid then
+ raise Constraint_Error;
+ end if;
+
+ -- Compute Sign
+
+ Is_Positive := (0.0 <= Item);
+
+ if F < 0.0 then
+ F := -Item;
+ end if;
+
+ -- Signed zero
+
+ if F = 0.0 then
+ Exponent := 0;
+ Fraction_1 := 0;
+ Fraction_2 := 0;
+
+ else
+ E := Long_Long_Float'Exponent (F) - 1;
+
+ -- Denormalized float
+
+ if E <= -E_Bias then
+ F := Long_Long_Float'Scaling (F, E_Bias - 1);
+ E := -E_Bias;
+ else
+ F := Long_Long_Float'Scaling
+ (Long_Long_Float'Fraction (F), 1);
+ end if;
+
+ -- Compute Exponent and Fraction
+
+ Exponent := Long_Unsigned (E + E_Bias);
+ F := Long_Long_Float'Scaling (F, F_Size - HFS);
+ Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F));
+ F := F - Long_Long_Float (Fraction_1);
+ F := Long_Long_Float'Scaling (F, HFS);
+ Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F));
+ end if;
+
+ -- Store Fraction_1
+
+ for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop
+ S (I) := SE (Fraction_1 mod BB);
+ Fraction_1 := Fraction_1 / BB;
+ end loop;
+
+ -- Store Fraction_2
+
+ for I in reverse LLF_L - 6 .. LLF_L loop
+ S (SEO (I)) := SE (Fraction_2 mod BB);
+ Fraction_2 := Fraction_2 / BB;
+ end loop;
+
+ -- Store Exponent (not always at the beginning of a byte)
+
+ Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+ for N in reverse 1 .. E_Bytes loop
+ S (N) := SE (Exponent mod BB) + S (N);
+ Exponent := Exponent / BB;
+ end loop;
+
+ -- Store Sign
+
+ if not Is_Positive then
+ S (1) := S (1) + BS;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LLF;
+
+ -----------
+ -- W_LLI --
+ -----------
+
+ procedure W_LLI
+ (Stream : not null access RST;
+ Item : Long_Long_Integer)
+ is
+ S : XDR_S_LLI;
+ U : Unsigned;
+ X : Long_Long_Unsigned;
+
+ begin
+ if Optimize_Integers then
+ S := Long_Long_Integer_To_XDR_S_LLI (Item);
+
+ else
+ -- Test sign and apply two complement notation
+
+ if Item < 0 then
+ X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1));
+ else
+ X := Long_Long_Unsigned (Item);
+ end if;
+
+ -- Compute using machine unsigned rather than long_long_unsigned
+
+ for N in reverse S'Range loop
+
+ -- We have filled an unsigned
+
+ if (LLU_L - N) mod UB = 0 then
+ U := Unsigned (X and UL);
+ X := Shift_Right (X, US);
+ end if;
+
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LLI;
+
+ -----------
+ -- W_LLU --
+ -----------
+
+ procedure W_LLU
+ (Stream : not null access RST;
+ Item : Long_Long_Unsigned)
+ is
+ S : XDR_S_LLU;
+ U : Unsigned;
+ X : Long_Long_Unsigned := Item;
+
+ begin
+ if Optimize_Integers then
+ S := Long_Long_Unsigned_To_XDR_S_LLU (Item);
+
+ else
+ -- Compute using machine unsigned rather than long_long_unsigned
+
+ for N in reverse S'Range loop
+
+ -- We have filled an unsigned
+
+ if (LLU_L - N) mod UB = 0 then
+ U := Unsigned (X and UL);
+ X := Shift_Right (X, US);
+ end if;
+
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LLU;
+
+ ----------
+ -- W_LU --
+ ----------
+
+ procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is
+ S : XDR_S_LU;
+ U : Unsigned;
+ X : Long_Unsigned := Item;
+
+ begin
+ if Optimize_Integers then
+ S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item));
+
+ else
+ -- Compute using machine unsigned rather than long_unsigned
+
+ for N in reverse S'Range loop
+
+ -- We have filled an unsigned
+
+ if (LU_L - N) mod UB = 0 then
+ U := Unsigned (X and UL);
+ X := Shift_Right (X, US);
+ end if;
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LU;
+
+ ----------
+ -- W_SF --
+ ----------
+
+ procedure W_SF (Stream : not null access RST; Item : Short_Float) is
+ I : constant Precision := Single;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+ F_Mask : SE renames Fields (I).F_Mask;
+
+ Exponent : Long_Unsigned;
+ Fraction : Long_Unsigned;
+ Is_Positive : Boolean;
+ E : Integer;
+ F : Short_Float;
+ S : SEA (1 .. SF_L) := (others => 0);
+
+ begin
+ if not Item'Valid then
+ raise Constraint_Error;
+ end if;
+
+ -- Compute Sign
+
+ Is_Positive := (0.0 <= Item);
+ F := abs (Item);
+
+ -- Signed zero
+
+ if F = 0.0 then
+ Exponent := 0;
+ Fraction := 0;
+
+ else
+ E := Short_Float'Exponent (F) - 1;
+
+ -- Denormalized float
+
+ if E <= -E_Bias then
+ E := -E_Bias;
+ F := Short_Float'Scaling (F, F_Size + E_Bias - 1);
+ else
+ F := Short_Float'Scaling (F, F_Size - E);
+ end if;
+
+ -- Compute Exponent and Fraction
+
+ Exponent := Long_Unsigned (E + E_Bias);
+ Fraction := Long_Unsigned (F * 2.0) / 2;
+ end if;
+
+ -- Store Fraction
+
+ for I in reverse SF_L - F_Bytes + 1 .. SF_L loop
+ S (I) := SE (Fraction mod BB);
+ Fraction := Fraction / BB;
+ end loop;
+
+ -- Remove implicit bit
+
+ S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask;
+
+ -- Store Exponent (not always at the beginning of a byte)
+
+ Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+ for N in reverse 1 .. E_Bytes loop
+ S (N) := SE (Exponent mod BB) + S (N);
+ Exponent := Exponent / BB;
+ end loop;
+
+ -- Store Sign
+
+ if not Is_Positive then
+ S (1) := S (1) + BS;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_SF;
+
+ ----------
+ -- W_SI --
+ ----------
+
+ procedure W_SI (Stream : not null access RST; Item : Short_Integer) is
+ S : XDR_S_SI;
+ U : XDR_SU;
+
+ begin
+ if Optimize_Integers then
+ S := Short_Integer_To_XDR_S_SI (Item);
+
+ else
+ -- Test sign and apply two complement's notation
+
+ U := (if Item < 0
+ then XDR_SU'Last xor XDR_SU (-(Item + 1))
+ else XDR_SU (Item));
+
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_SI;
+
+ -----------
+ -- W_SSI --
+ -----------
+
+ procedure W_SSI
+ (Stream : not null access RST;
+ Item : Short_Short_Integer)
+ is
+ S : XDR_S_SSI;
+ U : XDR_SSU;
+
+ begin
+ if Optimize_Integers then
+ S := Short_Short_Integer_To_XDR_S_SSI (Item);
+
+ else
+ -- Test sign and apply two complement's notation
+
+ U := (if Item < 0
+ then XDR_SSU'Last xor XDR_SSU (-(Item + 1))
+ else XDR_SSU (Item));
+
+ S (1) := SE (U);
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_SSI;
+
+ -----------
+ -- W_SSU --
+ -----------
+
+ procedure W_SSU
+ (Stream : not null access RST;
+ Item : Short_Short_Unsigned)
+ is
+ U : constant XDR_SSU := XDR_SSU (Item);
+ S : XDR_S_SSU;
+
+ begin
+ S (1) := SE (U);
+ Ada.Streams.Write (Stream.all, S);
+ end W_SSU;
+
+ ----------
+ -- W_SU --
+ ----------
+
+ procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is
+ S : XDR_S_SU;
+ U : XDR_SU := XDR_SU (Item);
+
+ begin
+ if Optimize_Integers then
+ S := Short_Unsigned_To_XDR_S_SU (Item);
+
+ else
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_SU;
+
+ ---------
+ -- W_U --
+ ---------
+
+ procedure W_U (Stream : not null access RST; Item : Unsigned) is
+ S : XDR_S_U;
+ U : XDR_U := XDR_U (Item);
+
+ begin
+ if Optimize_Integers then
+ S := Unsigned_To_XDR_S_U (Item);
+
+ else
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_U;
+
+ ----------
+ -- W_WC --
+ ----------
+
+ procedure W_WC (Stream : not null access RST; Item : Wide_Character) is
+ S : XDR_S_WC;
+ U : XDR_WC;
+
+ begin
+ -- Use Ada requirements on Wide_Character representation clause
+
+ U := XDR_WC (Wide_Character'Pos (Item));
+
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ Ada.Streams.Write (Stream.all, S);
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end W_WC;
+
+ -----------
+ -- W_WWC --
+ -----------
+
+ procedure W_WWC
+ (Stream : not null access RST; Item : Wide_Wide_Character)
+ is
+ S : XDR_S_WWC;
+ U : XDR_WWC;
+
+ begin
+ -- Use Ada requirements on Wide_Wide_Character representation clause
+
+ U := XDR_WWC (Wide_Wide_Character'Pos (Item));
+
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ Ada.Streams.Write (Stream.all, S);
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end W_WWC;
+
+end System.Stream_Attributes;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T R A C E B A C K --
--- (HP/UX Version) --
--- --
--- B o d y --
--- --
--- Copyright (C) 2009-2017, 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. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Unchecked_Conversion;
-
-package body System.Traceback is
-
- -- This package implements the backtracing facility by way of a dedicated
- -- HP library for stack unwinding described in the "Runtime Architecture
- -- Document".
-
- pragma Linker_Options ("/usr/lib/libcl.a");
-
- -- The library basically offers services to fetch information about a
- -- "previous" frame based on information about a "current" one.
-
- type Current_Frame_Descriptor is record
- cur_fsz : Address; -- Frame size of current routine.
- cur_sp : Address; -- The current value of stack pointer.
- cur_rls : Address; -- PC-space of the caller.
- cur_rlo : Address; -- PC-offset of the caller.
- cur_dp : Address; -- Data Pointer of the current routine.
- top_rp : Address; -- Initial value of RP.
- top_mrp : Address; -- Initial value of MRP.
- top_sr0 : Address; -- Initial value of sr0.
- top_sr4 : Address; -- Initial value of sr4.
- top_r3 : Address; -- Initial value of gr3.
- cur_r19 : Address; -- GR19 value of the calling routine.
- top_r4 : Address; -- Initial value of gr4.
- dummy : Address; -- Reserved.
- out_rlo : Address; -- PC-offset of the caller after get_previous.
- end record;
-
- type Previous_Frame_Descriptor is record
- prev_fsz : Address; -- frame size of calling routine.
- prev_sp : Address; -- SP of calling routine.
- prev_rls : Address; -- PC_space of calling routine's caller.
- prev_rlo : Address; -- PC_offset of calling routine's caller.
- prev_dp : Address; -- DP of calling routine.
- udescr0 : Address; -- low word of calling routine's unwind desc.
- udescr1 : Address; -- high word of calling routine's unwind desc.
- ustart : Address; -- start of the unwind region.
- uend : Address; -- end of the unwind region.
- uw_index : Address; -- index into the unwind table.
- prev_r19 : Address; -- GR19 value of the caller's caller.
- top_r3 : Address; -- Caller's initial gr3.
- top_r4 : Address; -- Caller's initial gr4.
- end record;
-
- -- Provide useful shortcuts for the names
-
- subtype CFD is Current_Frame_Descriptor;
- subtype PFD is Previous_Frame_Descriptor;
-
- -- Frames with dynamic stack allocation are handled using the associated
- -- frame pointer, but HP compilers and GCC setup this pointer differently.
- -- HP compilers set it to point at the top (highest address) of the static
- -- part of the frame, whereas GCC sets it to point at the bottom of this
- -- region. We have to fake the unwinder to compensate for this difference,
- -- for which we'll need to access some subprograms unwind descriptors.
-
- type Bits_2_Value is mod 2 ** 2;
- for Bits_2_Value'Size use 2;
-
- type Bits_4_Value is mod 2 ** 4;
- for Bits_4_Value'Size use 4;
-
- type Bits_5_Value is mod 2 ** 5;
- for Bits_5_Value'Size use 5;
-
- type Bits_27_Value is mod 2 ** 27;
- for Bits_27_Value'Size use 27;
-
- type Unwind_Descriptor is record
- cannot_unwind : Boolean;
- mcode : Boolean;
- mcode_save_restore : Boolean;
- region_desc : Bits_2_Value;
- reserved0 : Boolean;
- entry_sr : Boolean;
- entry_fr : Bits_4_Value;
- entry_gr : Bits_5_Value;
-
- args_stored : Boolean;
- variable_frame : Boolean;
- separate_package_body : Boolean;
- frame_extension_mcode : Boolean;
-
- stack_overflow_check : Boolean;
- two_steps_sp_adjust : Boolean;
- sr4_export : Boolean;
- cxx_info : Boolean;
-
- cxx_try_catch : Boolean;
- sched_entry_seq : Boolean;
- reserved1 : Boolean;
- save_sp : Boolean;
-
- save_rp : Boolean;
- save_mrp : Boolean;
- save_r19 : Boolean;
- cleanups : Boolean;
-
- hpe_interrupt_marker : Boolean;
- hpux_interrupt_marker : Boolean;
- large_frame : Boolean;
- alloca_frame : Boolean;
-
- reserved2 : Boolean;
- frame_size : Bits_27_Value;
- end record;
-
- for Unwind_Descriptor'Size use 64;
-
- for Unwind_Descriptor use record
- cannot_unwind at 0 range 0 .. 0;
- mcode at 0 range 1 .. 1;
- mcode_save_restore at 0 range 2 .. 2;
- region_desc at 0 range 3 .. 4;
- reserved0 at 0 range 5 .. 5;
- entry_sr at 0 range 6 .. 6;
- entry_fr at 0 range 7 .. 10;
-
- entry_gr at 1 range 3 .. 7;
-
- args_stored at 2 range 0 .. 0;
- variable_frame at 2 range 1 .. 1;
- separate_package_body at 2 range 2 .. 2;
- frame_extension_mcode at 2 range 3 .. 3;
- stack_overflow_check at 2 range 4 .. 4;
- two_steps_sp_adjust at 2 range 5 .. 5;
- sr4_export at 2 range 6 .. 6;
- cxx_info at 2 range 7 .. 7;
-
- cxx_try_catch at 3 range 0 .. 0;
- sched_entry_seq at 3 range 1 .. 1;
- reserved1 at 3 range 2 .. 2;
- save_sp at 3 range 3 .. 3;
- save_rp at 3 range 4 .. 4;
- save_mrp at 3 range 5 .. 5;
- save_r19 at 3 range 6 .. 6;
- cleanups at 3 range 7 .. 7;
-
- hpe_interrupt_marker at 4 range 0 .. 0;
- hpux_interrupt_marker at 4 range 1 .. 1;
- large_frame at 4 range 2 .. 2;
- alloca_frame at 4 range 3 .. 3;
-
- reserved2 at 4 range 4 .. 4;
- frame_size at 4 range 5 .. 31;
- end record;
-
- subtype UWD is Unwind_Descriptor;
- type UWD_Ptr is access all UWD;
-
- function To_UWD_Access is new Ada.Unchecked_Conversion (Address, UWD_Ptr);
-
- -- The descriptor associated with a given code location is retrieved
- -- using functions imported from the HP library, requiring the definition
- -- of additional structures.
-
- type Unwind_Table_Region is record
- Table_Start : Address;
- Table_End : Address;
- end record;
- -- An Unwind Table region, which is a memory area containing Unwind
- -- Descriptors.
-
- subtype UWT is Unwind_Table_Region;
-
- -- The subprograms imported below are provided by the HP library
-
- function U_get_unwind_table return UWT;
- pragma Import (C, U_get_unwind_table, "U_get_unwind_table");
- -- Get the unwind table region associated with the current executable.
- -- This function is actually documented as having an argument, but which
- -- is only used for the MPE/iX targets.
-
- function U_get_shLib_unwind_table (r19 : Address) return UWT;
- pragma Import (C, U_get_shLib_unwind_table, "U_get_shLib_unw_tbl");
- -- Return the unwind table region associated with a possible shared
- -- library, as determined by the provided r19 value.
-
- function U_get_shLib_text_addr (r19 : Address) return Address;
- pragma Import (C, U_get_shLib_text_addr, "U_get_shLib_text_addr");
- -- Return the address at which the code for a shared library begins, or
- -- -1 if the value provided for r19 does not identify shared library code.
-
- function U_get_unwind_entry
- (Pc : Address;
- Space : Address;
- Table_Start : Address;
- Table_End : Address) return Address;
- pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry");
- -- Given the bounds of an unwind table, return the address of the
- -- unwind descriptor associated with a code location/space. In the case
- -- of shared library code, the offset from the beginning of the library
- -- is expected as Pc.
-
- procedure U_init_frame_record (Frame : not null access CFD);
- pragma Import (C, U_init_frame_record, "U_init_frame_record");
-
- procedure U_prep_frame_rec_for_unwind (Frame : not null access CFD);
- pragma Import (C, U_prep_frame_rec_for_unwind,
- "U_prep_frame_rec_for_unwind");
-
- -- Fetch the description data of the frame in which these two procedures
- -- are called.
-
- function U_get_u_rlo
- (Cur : not null access CFD; Prev : not null access PFD) return Integer;
- pragma Import (C, U_get_u_rlo, "U_IS_STUB_OR_CALLX");
- -- From a complete current frame with a return location possibly located
- -- into a linker generated stub, and basic information about the previous
- -- frame, place the first non stub return location into the current frame.
- -- Return -1 if something went wrong during the computation.
-
- function U_is_shared_pc (rlo : Address; r19 : Address) return Address;
- pragma Import (C, U_is_shared_pc, "U_is_shared_pc");
- -- Return 0 if the provided return location does not correspond to code
- -- in a shared library, or something non null otherwise.
-
- function U_get_previous_frame_x
- (current_frame : not null access CFD;
- previous_frame : not null access PFD;
- previous_size : Integer) return Integer;
- pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x");
- -- Fetch the data describing the "previous" frame relatively to the
- -- "current" one. "previous_size" should be the size of the "previous"
- -- frame descriptor provided.
- --
- -- The library provides a simpler interface without the size parameter
- -- but it is not usable when frames with dynamically allocated space are
- -- on the way.
-
- procedure Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural;
- Len : out Natural;
- Exclude_Min : System.Address := System.Null_Address;
- Exclude_Max : System.Address := System.Null_Address;
- Skip_Frames : Natural := 1);
- -- Same as the exported version, but takes Traceback as an Address
-
- ------------------
- -- C_Call_Chain --
- ------------------
-
- function C_Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural) return Natural
- is
- Val : Natural;
- begin
- Call_Chain (Traceback, Max_Len, Val);
- return Val;
- end C_Call_Chain;
-
- ----------------
- -- Call_Chain --
- ----------------
-
- procedure Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural;
- Len : out Natural;
- Exclude_Min : System.Address := System.Null_Address;
- Exclude_Max : System.Address := System.Null_Address;
- Skip_Frames : Natural := 1)
- is
- type Tracebacks_Array is array (1 .. Max_Len) of System.Address;
- pragma Suppress_Initialization (Tracebacks_Array);
-
- -- The code location returned by the unwinder is a return location but
- -- what we need is a call point. Under HP-UX call instructions are 4
- -- bytes long and the return point they specify is 4 bytes beyond the
- -- next instruction because of the delay slot.
-
- Call_Size : constant := 4;
- DSlot_Size : constant := 4;
- Rlo_Offset : constant := Call_Size + DSlot_Size;
-
- -- Moreover, the return point is passed via a register which two least
- -- significant bits specify a privilege level that we will have to mask.
-
- Priv_Mask : constant := 16#00000003#;
-
- Frame : aliased CFD;
- Code : System.Address;
- J : Natural := 1;
- Pop_Success : Boolean;
- Trace : Tracebacks_Array;
- for Trace'Address use Traceback;
-
- -- The backtracing process needs a set of subprograms :
-
- function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr;
- -- Return an access to the unwind descriptor for the caller of
- -- a given frame, using only the provided return location.
-
- function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr;
- -- Return an access to the unwind descriptor for the user code caller
- -- of a given frame, or null if the information is not available.
-
- function Pop_Frame (Frame : not null access CFD) return Boolean;
- -- Update the provided machine state structure so that it reflects
- -- the state one call frame "above" the initial one.
- --
- -- Return True if the operation has been successful, False otherwise.
- -- Failure typically occurs when the top of the call stack has been
- -- reached.
-
- function Prepare_For_Unwind_Of
- (Frame : not null access CFD) return Boolean;
- -- Perform the necessary adaptations to the machine state before
- -- calling the unwinder. Currently used for the specific case of
- -- dynamically sized previous frames.
- --
- -- Return True if everything went fine, or False otherwise.
-
- Program_UWT : constant UWT := U_get_unwind_table;
-
- ---------------
- -- Pop_Frame --
- ---------------
-
- function Pop_Frame (Frame : not null access CFD) return Boolean is
- Up_Frame : aliased PFD;
- State_Ready : Boolean;
-
- begin
- -- Check/adapt the state before calling the unwinder and return
- -- if anything went wrong.
-
- State_Ready := Prepare_For_Unwind_Of (Frame);
-
- if not State_Ready then
- return False;
- end if;
-
- -- Now, safely call the unwinder and use the results
-
- if U_get_previous_frame_x (Frame,
- Up_Frame'Access,
- Up_Frame'Size) /= 0
- then
- return False;
- end if;
-
- -- In case a stub is on the way, the usual previous return location
- -- (the one in prev_rlo) is the one in the stub and the "real" one
- -- is placed in the "current" record, so let's take this one into
- -- account.
-
- Frame.out_rlo := Frame.cur_rlo;
-
- Frame.cur_fsz := Up_Frame.prev_fsz;
- Frame.cur_sp := Up_Frame.prev_sp;
- Frame.cur_rls := Up_Frame.prev_rls;
- Frame.cur_rlo := Up_Frame.prev_rlo;
- Frame.cur_dp := Up_Frame.prev_dp;
- Frame.cur_r19 := Up_Frame.prev_r19;
- Frame.top_r3 := Up_Frame.top_r3;
- Frame.top_r4 := Up_Frame.top_r4;
-
- return True;
- end Pop_Frame;
-
- ---------------------------------
- -- Prepare_State_For_Unwind_Of --
- ---------------------------------
-
- function Prepare_For_Unwind_Of
- (Frame : not null access CFD) return Boolean
- is
- Caller_UWD : UWD_Ptr;
- FP_Adjustment : Integer;
-
- begin
- -- No need to bother doing anything if the stack is already fully
- -- unwound.
-
- if Frame.cur_rlo = 0 then
- return False;
- end if;
-
- -- When ALLOCA_FRAME is set in an unwind descriptor, the unwinder
- -- uses the value provided in current.top_r3 or current.top_r4 as
- -- a frame pointer to compute the size of the frame. What decides
- -- between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with
- -- r4 chosen if the bit is set.
-
- -- The size computed by the unwinder is STATIC_PART + (SP - FP),
- -- which is correct with HP's frame pointer convention, but not
- -- with GCC's one since we end up with the static part accounted
- -- for twice.
-
- -- We have to compute r4 when it is required because the unwinder
- -- has looked for it at a place where it was not if we went through
- -- GCC frames.
-
- -- The size of the static part of a frame can be found in the
- -- associated unwind descriptor.
-
- Caller_UWD := UWD_For_Caller_Of (Frame);
-
- -- If we cannot get it, we are unable to compute the potentially
- -- necessary adjustments. We'd better not try to go on then.
-
- if Caller_UWD = null then
- return False;
- end if;
-
- -- If the caller frame is a GCC one, r3 is its frame pointer and
- -- points to the bottom of the frame. The value to provide for r4
- -- can then be computed directly from the one of r3, compensating
- -- for the static part of the frame.
-
- -- If the caller frame is an HP one, r3 is used to locate the
- -- previous frame marker, that is it also points to the bottom of
- -- the frame (this is why r3 cannot be used as the frame pointer in
- -- the HP sense for large frames). The value to provide for r4 can
- -- then also be computed from the one of r3 with the compensation
- -- for the static part of the frame.
-
- FP_Adjustment := Integer (Caller_UWD.frame_size * 8);
- Frame.top_r4 := Address (Integer (Frame.top_r3) + FP_Adjustment);
-
- return True;
- end Prepare_For_Unwind_Of;
-
- -----------------------
- -- UWD_For_Caller_Of --
- -----------------------
-
- function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr
- is
- UWD_Access : UWD_Ptr;
-
- begin
- -- First try the most direct path, using the return location data
- -- associated with the frame.
-
- UWD_Access := UWD_For_RLO_Of (Frame);
-
- if UWD_Access /= null then
- return UWD_Access;
- end if;
-
- -- If we did not get a result, we might face an in-stub return
- -- address. In this case U_get_previous_frame can tell us what the
- -- first not-in-stub return point is. We cannot call it directly,
- -- though, because we haven't computed the potentially necessary
- -- frame pointer adjustments, which might lead to SEGV in some
- -- circumstances. Instead, we directly call the libcl routine which
- -- is called by U_get_previous_frame and which only requires few
- -- information. Take care, however, that the information is provided
- -- in the "current" argument, so we need to work on a copy to avoid
- -- disturbing our caller.
-
- declare
- U_Current : aliased CFD := Frame.all;
- U_Previous : aliased PFD;
-
- begin
- U_Previous.prev_dp := U_Current.cur_dp;
- U_Previous.prev_rls := U_Current.cur_rls;
- U_Previous.prev_sp := U_Current.cur_sp - U_Current.cur_fsz;
-
- if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then
- UWD_Access := UWD_For_RLO_Of (U_Current'Access);
- end if;
- end;
-
- return UWD_Access;
- end UWD_For_Caller_Of;
-
- --------------------
- -- UWD_For_RLO_Of --
- --------------------
-
- function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr
- is
- UWD_Address : Address;
-
- -- The addresses returned by the library point to full descriptors
- -- including the frame information bits but also the applicable PC
- -- range. We need to account for this.
-
- Frame_Info_Offset : constant := 8;
-
- begin
- -- First try to locate the descriptor in the program's unwind table
-
- UWD_Address := U_get_unwind_entry (Frame.cur_rlo,
- Frame.cur_rls,
- Program_UWT.Table_Start,
- Program_UWT.Table_End);
-
- -- If we did not get it, we might have a frame from code in a
- -- stub or shared library. For code in stub we would have to
- -- compute the first non-stub return location but this is not
- -- the role of this subprogram, so let's just try to see if we
- -- can get a result from the tables in shared libraries.
-
- if UWD_Address = -1
- and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0
- then
- declare
- Shlib_UWT : constant UWT :=
- U_get_shLib_unwind_table (Frame.cur_r19);
- Shlib_Start : constant Address :=
- U_get_shLib_text_addr (Frame.cur_r19);
- Rlo_Offset : constant Address :=
- Frame.cur_rlo - Shlib_Start;
- begin
- UWD_Address := U_get_unwind_entry (Rlo_Offset,
- Frame.cur_rls,
- Shlib_UWT.Table_Start,
- Shlib_UWT.Table_End);
- end;
- end if;
-
- if UWD_Address /= -1 then
- return To_UWD_Access (UWD_Address + Frame_Info_Offset);
- else
- return null;
- end if;
- end UWD_For_RLO_Of;
-
- -- Start of processing for Call_Chain
-
- begin
- -- Fetch the state for this subprogram's frame and pop it so that we
- -- start with an initial out_rlo "here".
-
- U_init_frame_record (Frame'Access);
- Frame.top_sr0 := 0;
- Frame.top_sr4 := 0;
-
- U_prep_frame_rec_for_unwind (Frame'Access);
-
- Pop_Success := Pop_Frame (Frame'Access);
-
- -- Skip the requested number of frames
-
- for I in 1 .. Skip_Frames loop
- Pop_Success := Pop_Frame (Frame'Access);
- end loop;
-
- -- Loop popping frames and storing locations until either a problem
- -- occurs, or the top of the call chain is reached, or the provided
- -- array is full.
-
- loop
- -- We have to test some conditions against the return location
- -- as it is returned, so get it as is first.
-
- Code := Frame.out_rlo;
-
- exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1;
-
- -- Compute the call point from the retrieved return location :
- -- Mask the privilege bits and account for the delta between the
- -- call site and the return point.
-
- Code := (Code and not Priv_Mask) - Rlo_Offset;
-
- if Code < Exclude_Min or else Code > Exclude_Max then
- Trace (J) := Code;
- J := J + 1;
- end if;
-
- Pop_Success := Pop_Frame (Frame'Access);
- end loop;
-
- Len := J - 1;
- end Call_Chain;
-
- procedure Call_Chain
- (Traceback : in out System.Traceback_Entries.Tracebacks_Array;
- Max_Len : Natural;
- Len : out Natural;
- Exclude_Min : System.Address := System.Null_Address;
- Exclude_Max : System.Address := System.Null_Address;
- Skip_Frames : Natural := 1)
- is
- begin
- Call_Chain
- (Traceback'Address, Max_Len, Len,
- Exclude_Min, Exclude_Max,
-
- -- Skip one extra frame to skip the other Call_Chain entry as well
-
- Skip_Frames => Skip_Frames + 1);
- end Call_Chain;
-
-end System.Traceback;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . T R A C E B A C K --
--- --
--- B o d y --
--- --
--- Copyright (C) 1999-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This version uses System.Machine_State_Operations routines
-
-with System.Machine_State_Operations;
-
-package body System.Traceback is
-
- use System.Machine_State_Operations;
-
- procedure Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural;
- Len : out Natural;
- Exclude_Min : System.Address := System.Null_Address;
- Exclude_Max : System.Address := System.Null_Address;
- Skip_Frames : Natural := 1);
- -- Same as the exported version, but takes Traceback as an Address
-
- ----------------
- -- Call_Chain --
- ----------------
-
- procedure Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural;
- Len : out Natural;
- Exclude_Min : System.Address := System.Null_Address;
- Exclude_Max : System.Address := System.Null_Address;
- Skip_Frames : Natural := 1)
- is
- type Tracebacks_Array is array (1 .. Max_Len) of Code_Loc;
- pragma Suppress_Initialization (Tracebacks_Array);
-
- M : Machine_State;
- Code : Code_Loc;
-
- Trace : Tracebacks_Array;
- for Trace'Address use Traceback;
-
- N_Skips : Natural := 0;
-
- begin
- M := Allocate_Machine_State;
- Set_Machine_State (M);
-
- -- Skip the requested number of frames
-
- loop
- Code := Get_Code_Loc (M);
- exit when Code = Null_Address or else N_Skips = Skip_Frames;
-
- Pop_Frame (M);
- N_Skips := N_Skips + 1;
- end loop;
-
- -- Now, record the frames outside the exclusion bounds, updating
- -- the Len output value along the way.
-
- Len := 0;
- loop
- Code := Get_Code_Loc (M);
- exit when Code = Null_Address or else Len = Max_Len;
-
- if Code < Exclude_Min or else Code > Exclude_Max then
- Len := Len + 1;
- Trace (Len) := Code;
- end if;
-
- Pop_Frame (M);
- end loop;
-
- Free_Machine_State (M);
- end Call_Chain;
-
- procedure Call_Chain
- (Traceback : in out System.Traceback_Entries.Tracebacks_Array;
- Max_Len : Natural;
- Len : out Natural;
- Exclude_Min : System.Address := System.Null_Address;
- Exclude_Max : System.Address := System.Null_Address;
- Skip_Frames : Natural := 1)
- is
- begin
- Call_Chain
- (Traceback'Address, Max_Len, Len,
- Exclude_Min, Exclude_Max,
-
- -- Skip one extra frame to skip the other Call_Chain entry as well
-
- Skip_Frames => Skip_Frames + 1);
- end Call_Chain;
-
- ------------------
- -- C_Call_Chain --
- ------------------
-
- function C_Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural) return Natural
- is
- Val : Natural;
- begin
- Call_Chain (Traceback, Max_Len, Val);
- return Val;
- end C_Call_Chain;
-
-end System.Traceback;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K --
+-- (HP/UX Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2009-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Conversion;
+
+package body System.Traceback is
+
+ -- This package implements the backtracing facility by way of a dedicated
+ -- HP library for stack unwinding described in the "Runtime Architecture
+ -- Document".
+
+ pragma Linker_Options ("/usr/lib/libcl.a");
+
+ -- The library basically offers services to fetch information about a
+ -- "previous" frame based on information about a "current" one.
+
+ type Current_Frame_Descriptor is record
+ cur_fsz : Address; -- Frame size of current routine.
+ cur_sp : Address; -- The current value of stack pointer.
+ cur_rls : Address; -- PC-space of the caller.
+ cur_rlo : Address; -- PC-offset of the caller.
+ cur_dp : Address; -- Data Pointer of the current routine.
+ top_rp : Address; -- Initial value of RP.
+ top_mrp : Address; -- Initial value of MRP.
+ top_sr0 : Address; -- Initial value of sr0.
+ top_sr4 : Address; -- Initial value of sr4.
+ top_r3 : Address; -- Initial value of gr3.
+ cur_r19 : Address; -- GR19 value of the calling routine.
+ top_r4 : Address; -- Initial value of gr4.
+ dummy : Address; -- Reserved.
+ out_rlo : Address; -- PC-offset of the caller after get_previous.
+ end record;
+
+ type Previous_Frame_Descriptor is record
+ prev_fsz : Address; -- frame size of calling routine.
+ prev_sp : Address; -- SP of calling routine.
+ prev_rls : Address; -- PC_space of calling routine's caller.
+ prev_rlo : Address; -- PC_offset of calling routine's caller.
+ prev_dp : Address; -- DP of calling routine.
+ udescr0 : Address; -- low word of calling routine's unwind desc.
+ udescr1 : Address; -- high word of calling routine's unwind desc.
+ ustart : Address; -- start of the unwind region.
+ uend : Address; -- end of the unwind region.
+ uw_index : Address; -- index into the unwind table.
+ prev_r19 : Address; -- GR19 value of the caller's caller.
+ top_r3 : Address; -- Caller's initial gr3.
+ top_r4 : Address; -- Caller's initial gr4.
+ end record;
+
+ -- Provide useful shortcuts for the names
+
+ subtype CFD is Current_Frame_Descriptor;
+ subtype PFD is Previous_Frame_Descriptor;
+
+ -- Frames with dynamic stack allocation are handled using the associated
+ -- frame pointer, but HP compilers and GCC setup this pointer differently.
+ -- HP compilers set it to point at the top (highest address) of the static
+ -- part of the frame, whereas GCC sets it to point at the bottom of this
+ -- region. We have to fake the unwinder to compensate for this difference,
+ -- for which we'll need to access some subprograms unwind descriptors.
+
+ type Bits_2_Value is mod 2 ** 2;
+ for Bits_2_Value'Size use 2;
+
+ type Bits_4_Value is mod 2 ** 4;
+ for Bits_4_Value'Size use 4;
+
+ type Bits_5_Value is mod 2 ** 5;
+ for Bits_5_Value'Size use 5;
+
+ type Bits_27_Value is mod 2 ** 27;
+ for Bits_27_Value'Size use 27;
+
+ type Unwind_Descriptor is record
+ cannot_unwind : Boolean;
+ mcode : Boolean;
+ mcode_save_restore : Boolean;
+ region_desc : Bits_2_Value;
+ reserved0 : Boolean;
+ entry_sr : Boolean;
+ entry_fr : Bits_4_Value;
+ entry_gr : Bits_5_Value;
+
+ args_stored : Boolean;
+ variable_frame : Boolean;
+ separate_package_body : Boolean;
+ frame_extension_mcode : Boolean;
+
+ stack_overflow_check : Boolean;
+ two_steps_sp_adjust : Boolean;
+ sr4_export : Boolean;
+ cxx_info : Boolean;
+
+ cxx_try_catch : Boolean;
+ sched_entry_seq : Boolean;
+ reserved1 : Boolean;
+ save_sp : Boolean;
+
+ save_rp : Boolean;
+ save_mrp : Boolean;
+ save_r19 : Boolean;
+ cleanups : Boolean;
+
+ hpe_interrupt_marker : Boolean;
+ hpux_interrupt_marker : Boolean;
+ large_frame : Boolean;
+ alloca_frame : Boolean;
+
+ reserved2 : Boolean;
+ frame_size : Bits_27_Value;
+ end record;
+
+ for Unwind_Descriptor'Size use 64;
+
+ for Unwind_Descriptor use record
+ cannot_unwind at 0 range 0 .. 0;
+ mcode at 0 range 1 .. 1;
+ mcode_save_restore at 0 range 2 .. 2;
+ region_desc at 0 range 3 .. 4;
+ reserved0 at 0 range 5 .. 5;
+ entry_sr at 0 range 6 .. 6;
+ entry_fr at 0 range 7 .. 10;
+
+ entry_gr at 1 range 3 .. 7;
+
+ args_stored at 2 range 0 .. 0;
+ variable_frame at 2 range 1 .. 1;
+ separate_package_body at 2 range 2 .. 2;
+ frame_extension_mcode at 2 range 3 .. 3;
+ stack_overflow_check at 2 range 4 .. 4;
+ two_steps_sp_adjust at 2 range 5 .. 5;
+ sr4_export at 2 range 6 .. 6;
+ cxx_info at 2 range 7 .. 7;
+
+ cxx_try_catch at 3 range 0 .. 0;
+ sched_entry_seq at 3 range 1 .. 1;
+ reserved1 at 3 range 2 .. 2;
+ save_sp at 3 range 3 .. 3;
+ save_rp at 3 range 4 .. 4;
+ save_mrp at 3 range 5 .. 5;
+ save_r19 at 3 range 6 .. 6;
+ cleanups at 3 range 7 .. 7;
+
+ hpe_interrupt_marker at 4 range 0 .. 0;
+ hpux_interrupt_marker at 4 range 1 .. 1;
+ large_frame at 4 range 2 .. 2;
+ alloca_frame at 4 range 3 .. 3;
+
+ reserved2 at 4 range 4 .. 4;
+ frame_size at 4 range 5 .. 31;
+ end record;
+
+ subtype UWD is Unwind_Descriptor;
+ type UWD_Ptr is access all UWD;
+
+ function To_UWD_Access is new Ada.Unchecked_Conversion (Address, UWD_Ptr);
+
+ -- The descriptor associated with a given code location is retrieved
+ -- using functions imported from the HP library, requiring the definition
+ -- of additional structures.
+
+ type Unwind_Table_Region is record
+ Table_Start : Address;
+ Table_End : Address;
+ end record;
+ -- An Unwind Table region, which is a memory area containing Unwind
+ -- Descriptors.
+
+ subtype UWT is Unwind_Table_Region;
+
+ -- The subprograms imported below are provided by the HP library
+
+ function U_get_unwind_table return UWT;
+ pragma Import (C, U_get_unwind_table, "U_get_unwind_table");
+ -- Get the unwind table region associated with the current executable.
+ -- This function is actually documented as having an argument, but which
+ -- is only used for the MPE/iX targets.
+
+ function U_get_shLib_unwind_table (r19 : Address) return UWT;
+ pragma Import (C, U_get_shLib_unwind_table, "U_get_shLib_unw_tbl");
+ -- Return the unwind table region associated with a possible shared
+ -- library, as determined by the provided r19 value.
+
+ function U_get_shLib_text_addr (r19 : Address) return Address;
+ pragma Import (C, U_get_shLib_text_addr, "U_get_shLib_text_addr");
+ -- Return the address at which the code for a shared library begins, or
+ -- -1 if the value provided for r19 does not identify shared library code.
+
+ function U_get_unwind_entry
+ (Pc : Address;
+ Space : Address;
+ Table_Start : Address;
+ Table_End : Address) return Address;
+ pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry");
+ -- Given the bounds of an unwind table, return the address of the
+ -- unwind descriptor associated with a code location/space. In the case
+ -- of shared library code, the offset from the beginning of the library
+ -- is expected as Pc.
+
+ procedure U_init_frame_record (Frame : not null access CFD);
+ pragma Import (C, U_init_frame_record, "U_init_frame_record");
+
+ procedure U_prep_frame_rec_for_unwind (Frame : not null access CFD);
+ pragma Import (C, U_prep_frame_rec_for_unwind,
+ "U_prep_frame_rec_for_unwind");
+
+ -- Fetch the description data of the frame in which these two procedures
+ -- are called.
+
+ function U_get_u_rlo
+ (Cur : not null access CFD; Prev : not null access PFD) return Integer;
+ pragma Import (C, U_get_u_rlo, "U_IS_STUB_OR_CALLX");
+ -- From a complete current frame with a return location possibly located
+ -- into a linker generated stub, and basic information about the previous
+ -- frame, place the first non stub return location into the current frame.
+ -- Return -1 if something went wrong during the computation.
+
+ function U_is_shared_pc (rlo : Address; r19 : Address) return Address;
+ pragma Import (C, U_is_shared_pc, "U_is_shared_pc");
+ -- Return 0 if the provided return location does not correspond to code
+ -- in a shared library, or something non null otherwise.
+
+ function U_get_previous_frame_x
+ (current_frame : not null access CFD;
+ previous_frame : not null access PFD;
+ previous_size : Integer) return Integer;
+ pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x");
+ -- Fetch the data describing the "previous" frame relatively to the
+ -- "current" one. "previous_size" should be the size of the "previous"
+ -- frame descriptor provided.
+ --
+ -- The library provides a simpler interface without the size parameter
+ -- but it is not usable when frames with dynamically allocated space are
+ -- on the way.
+
+ procedure Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural;
+ Len : out Natural;
+ Exclude_Min : System.Address := System.Null_Address;
+ Exclude_Max : System.Address := System.Null_Address;
+ Skip_Frames : Natural := 1);
+ -- Same as the exported version, but takes Traceback as an Address
+
+ ------------------
+ -- C_Call_Chain --
+ ------------------
+
+ function C_Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural) return Natural
+ is
+ Val : Natural;
+ begin
+ Call_Chain (Traceback, Max_Len, Val);
+ return Val;
+ end C_Call_Chain;
+
+ ----------------
+ -- Call_Chain --
+ ----------------
+
+ procedure Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural;
+ Len : out Natural;
+ Exclude_Min : System.Address := System.Null_Address;
+ Exclude_Max : System.Address := System.Null_Address;
+ Skip_Frames : Natural := 1)
+ is
+ type Tracebacks_Array is array (1 .. Max_Len) of System.Address;
+ pragma Suppress_Initialization (Tracebacks_Array);
+
+ -- The code location returned by the unwinder is a return location but
+ -- what we need is a call point. Under HP-UX call instructions are 4
+ -- bytes long and the return point they specify is 4 bytes beyond the
+ -- next instruction because of the delay slot.
+
+ Call_Size : constant := 4;
+ DSlot_Size : constant := 4;
+ Rlo_Offset : constant := Call_Size + DSlot_Size;
+
+ -- Moreover, the return point is passed via a register which two least
+ -- significant bits specify a privilege level that we will have to mask.
+
+ Priv_Mask : constant := 16#00000003#;
+
+ Frame : aliased CFD;
+ Code : System.Address;
+ J : Natural := 1;
+ Pop_Success : Boolean;
+ Trace : Tracebacks_Array;
+ for Trace'Address use Traceback;
+
+ -- The backtracing process needs a set of subprograms :
+
+ function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr;
+ -- Return an access to the unwind descriptor for the caller of
+ -- a given frame, using only the provided return location.
+
+ function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr;
+ -- Return an access to the unwind descriptor for the user code caller
+ -- of a given frame, or null if the information is not available.
+
+ function Pop_Frame (Frame : not null access CFD) return Boolean;
+ -- Update the provided machine state structure so that it reflects
+ -- the state one call frame "above" the initial one.
+ --
+ -- Return True if the operation has been successful, False otherwise.
+ -- Failure typically occurs when the top of the call stack has been
+ -- reached.
+
+ function Prepare_For_Unwind_Of
+ (Frame : not null access CFD) return Boolean;
+ -- Perform the necessary adaptations to the machine state before
+ -- calling the unwinder. Currently used for the specific case of
+ -- dynamically sized previous frames.
+ --
+ -- Return True if everything went fine, or False otherwise.
+
+ Program_UWT : constant UWT := U_get_unwind_table;
+
+ ---------------
+ -- Pop_Frame --
+ ---------------
+
+ function Pop_Frame (Frame : not null access CFD) return Boolean is
+ Up_Frame : aliased PFD;
+ State_Ready : Boolean;
+
+ begin
+ -- Check/adapt the state before calling the unwinder and return
+ -- if anything went wrong.
+
+ State_Ready := Prepare_For_Unwind_Of (Frame);
+
+ if not State_Ready then
+ return False;
+ end if;
+
+ -- Now, safely call the unwinder and use the results
+
+ if U_get_previous_frame_x (Frame,
+ Up_Frame'Access,
+ Up_Frame'Size) /= 0
+ then
+ return False;
+ end if;
+
+ -- In case a stub is on the way, the usual previous return location
+ -- (the one in prev_rlo) is the one in the stub and the "real" one
+ -- is placed in the "current" record, so let's take this one into
+ -- account.
+
+ Frame.out_rlo := Frame.cur_rlo;
+
+ Frame.cur_fsz := Up_Frame.prev_fsz;
+ Frame.cur_sp := Up_Frame.prev_sp;
+ Frame.cur_rls := Up_Frame.prev_rls;
+ Frame.cur_rlo := Up_Frame.prev_rlo;
+ Frame.cur_dp := Up_Frame.prev_dp;
+ Frame.cur_r19 := Up_Frame.prev_r19;
+ Frame.top_r3 := Up_Frame.top_r3;
+ Frame.top_r4 := Up_Frame.top_r4;
+
+ return True;
+ end Pop_Frame;
+
+ ---------------------------------
+ -- Prepare_State_For_Unwind_Of --
+ ---------------------------------
+
+ function Prepare_For_Unwind_Of
+ (Frame : not null access CFD) return Boolean
+ is
+ Caller_UWD : UWD_Ptr;
+ FP_Adjustment : Integer;
+
+ begin
+ -- No need to bother doing anything if the stack is already fully
+ -- unwound.
+
+ if Frame.cur_rlo = 0 then
+ return False;
+ end if;
+
+ -- When ALLOCA_FRAME is set in an unwind descriptor, the unwinder
+ -- uses the value provided in current.top_r3 or current.top_r4 as
+ -- a frame pointer to compute the size of the frame. What decides
+ -- between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with
+ -- r4 chosen if the bit is set.
+
+ -- The size computed by the unwinder is STATIC_PART + (SP - FP),
+ -- which is correct with HP's frame pointer convention, but not
+ -- with GCC's one since we end up with the static part accounted
+ -- for twice.
+
+ -- We have to compute r4 when it is required because the unwinder
+ -- has looked for it at a place where it was not if we went through
+ -- GCC frames.
+
+ -- The size of the static part of a frame can be found in the
+ -- associated unwind descriptor.
+
+ Caller_UWD := UWD_For_Caller_Of (Frame);
+
+ -- If we cannot get it, we are unable to compute the potentially
+ -- necessary adjustments. We'd better not try to go on then.
+
+ if Caller_UWD = null then
+ return False;
+ end if;
+
+ -- If the caller frame is a GCC one, r3 is its frame pointer and
+ -- points to the bottom of the frame. The value to provide for r4
+ -- can then be computed directly from the one of r3, compensating
+ -- for the static part of the frame.
+
+ -- If the caller frame is an HP one, r3 is used to locate the
+ -- previous frame marker, that is it also points to the bottom of
+ -- the frame (this is why r3 cannot be used as the frame pointer in
+ -- the HP sense for large frames). The value to provide for r4 can
+ -- then also be computed from the one of r3 with the compensation
+ -- for the static part of the frame.
+
+ FP_Adjustment := Integer (Caller_UWD.frame_size * 8);
+ Frame.top_r4 := Address (Integer (Frame.top_r3) + FP_Adjustment);
+
+ return True;
+ end Prepare_For_Unwind_Of;
+
+ -----------------------
+ -- UWD_For_Caller_Of --
+ -----------------------
+
+ function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr
+ is
+ UWD_Access : UWD_Ptr;
+
+ begin
+ -- First try the most direct path, using the return location data
+ -- associated with the frame.
+
+ UWD_Access := UWD_For_RLO_Of (Frame);
+
+ if UWD_Access /= null then
+ return UWD_Access;
+ end if;
+
+ -- If we did not get a result, we might face an in-stub return
+ -- address. In this case U_get_previous_frame can tell us what the
+ -- first not-in-stub return point is. We cannot call it directly,
+ -- though, because we haven't computed the potentially necessary
+ -- frame pointer adjustments, which might lead to SEGV in some
+ -- circumstances. Instead, we directly call the libcl routine which
+ -- is called by U_get_previous_frame and which only requires few
+ -- information. Take care, however, that the information is provided
+ -- in the "current" argument, so we need to work on a copy to avoid
+ -- disturbing our caller.
+
+ declare
+ U_Current : aliased CFD := Frame.all;
+ U_Previous : aliased PFD;
+
+ begin
+ U_Previous.prev_dp := U_Current.cur_dp;
+ U_Previous.prev_rls := U_Current.cur_rls;
+ U_Previous.prev_sp := U_Current.cur_sp - U_Current.cur_fsz;
+
+ if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then
+ UWD_Access := UWD_For_RLO_Of (U_Current'Access);
+ end if;
+ end;
+
+ return UWD_Access;
+ end UWD_For_Caller_Of;
+
+ --------------------
+ -- UWD_For_RLO_Of --
+ --------------------
+
+ function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr
+ is
+ UWD_Address : Address;
+
+ -- The addresses returned by the library point to full descriptors
+ -- including the frame information bits but also the applicable PC
+ -- range. We need to account for this.
+
+ Frame_Info_Offset : constant := 8;
+
+ begin
+ -- First try to locate the descriptor in the program's unwind table
+
+ UWD_Address := U_get_unwind_entry (Frame.cur_rlo,
+ Frame.cur_rls,
+ Program_UWT.Table_Start,
+ Program_UWT.Table_End);
+
+ -- If we did not get it, we might have a frame from code in a
+ -- stub or shared library. For code in stub we would have to
+ -- compute the first non-stub return location but this is not
+ -- the role of this subprogram, so let's just try to see if we
+ -- can get a result from the tables in shared libraries.
+
+ if UWD_Address = -1
+ and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0
+ then
+ declare
+ Shlib_UWT : constant UWT :=
+ U_get_shLib_unwind_table (Frame.cur_r19);
+ Shlib_Start : constant Address :=
+ U_get_shLib_text_addr (Frame.cur_r19);
+ Rlo_Offset : constant Address :=
+ Frame.cur_rlo - Shlib_Start;
+ begin
+ UWD_Address := U_get_unwind_entry (Rlo_Offset,
+ Frame.cur_rls,
+ Shlib_UWT.Table_Start,
+ Shlib_UWT.Table_End);
+ end;
+ end if;
+
+ if UWD_Address /= -1 then
+ return To_UWD_Access (UWD_Address + Frame_Info_Offset);
+ else
+ return null;
+ end if;
+ end UWD_For_RLO_Of;
+
+ -- Start of processing for Call_Chain
+
+ begin
+ -- Fetch the state for this subprogram's frame and pop it so that we
+ -- start with an initial out_rlo "here".
+
+ U_init_frame_record (Frame'Access);
+ Frame.top_sr0 := 0;
+ Frame.top_sr4 := 0;
+
+ U_prep_frame_rec_for_unwind (Frame'Access);
+
+ Pop_Success := Pop_Frame (Frame'Access);
+
+ -- Skip the requested number of frames
+
+ for I in 1 .. Skip_Frames loop
+ Pop_Success := Pop_Frame (Frame'Access);
+ end loop;
+
+ -- Loop popping frames and storing locations until either a problem
+ -- occurs, or the top of the call chain is reached, or the provided
+ -- array is full.
+
+ loop
+ -- We have to test some conditions against the return location
+ -- as it is returned, so get it as is first.
+
+ Code := Frame.out_rlo;
+
+ exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1;
+
+ -- Compute the call point from the retrieved return location :
+ -- Mask the privilege bits and account for the delta between the
+ -- call site and the return point.
+
+ Code := (Code and not Priv_Mask) - Rlo_Offset;
+
+ if Code < Exclude_Min or else Code > Exclude_Max then
+ Trace (J) := Code;
+ J := J + 1;
+ end if;
+
+ Pop_Success := Pop_Frame (Frame'Access);
+ end loop;
+
+ Len := J - 1;
+ end Call_Chain;
+
+ procedure Call_Chain
+ (Traceback : in out System.Traceback_Entries.Tracebacks_Array;
+ Max_Len : Natural;
+ Len : out Natural;
+ Exclude_Min : System.Address := System.Null_Address;
+ Exclude_Max : System.Address := System.Null_Address;
+ Skip_Frames : Natural := 1)
+ is
+ begin
+ Call_Chain
+ (Traceback'Address, Max_Len, Len,
+ Exclude_Min, Exclude_Max,
+
+ -- Skip one extra frame to skip the other Call_Chain entry as well
+
+ Skip_Frames => Skip_Frames + 1);
+ end Call_Chain;
+
+end System.Traceback;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version uses System.Machine_State_Operations routines
+
+with System.Machine_State_Operations;
+
+package body System.Traceback is
+
+ use System.Machine_State_Operations;
+
+ procedure Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural;
+ Len : out Natural;
+ Exclude_Min : System.Address := System.Null_Address;
+ Exclude_Max : System.Address := System.Null_Address;
+ Skip_Frames : Natural := 1);
+ -- Same as the exported version, but takes Traceback as an Address
+
+ ----------------
+ -- Call_Chain --
+ ----------------
+
+ procedure Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural;
+ Len : out Natural;
+ Exclude_Min : System.Address := System.Null_Address;
+ Exclude_Max : System.Address := System.Null_Address;
+ Skip_Frames : Natural := 1)
+ is
+ type Tracebacks_Array is array (1 .. Max_Len) of Code_Loc;
+ pragma Suppress_Initialization (Tracebacks_Array);
+
+ M : Machine_State;
+ Code : Code_Loc;
+
+ Trace : Tracebacks_Array;
+ for Trace'Address use Traceback;
+
+ N_Skips : Natural := 0;
+
+ begin
+ M := Allocate_Machine_State;
+ Set_Machine_State (M);
+
+ -- Skip the requested number of frames
+
+ loop
+ Code := Get_Code_Loc (M);
+ exit when Code = Null_Address or else N_Skips = Skip_Frames;
+
+ Pop_Frame (M);
+ N_Skips := N_Skips + 1;
+ end loop;
+
+ -- Now, record the frames outside the exclusion bounds, updating
+ -- the Len output value along the way.
+
+ Len := 0;
+ loop
+ Code := Get_Code_Loc (M);
+ exit when Code = Null_Address or else Len = Max_Len;
+
+ if Code < Exclude_Min or else Code > Exclude_Max then
+ Len := Len + 1;
+ Trace (Len) := Code;
+ end if;
+
+ Pop_Frame (M);
+ end loop;
+
+ Free_Machine_State (M);
+ end Call_Chain;
+
+ procedure Call_Chain
+ (Traceback : in out System.Traceback_Entries.Tracebacks_Array;
+ Max_Len : Natural;
+ Len : out Natural;
+ Exclude_Min : System.Address := System.Null_Address;
+ Exclude_Max : System.Address := System.Null_Address;
+ Skip_Frames : Natural := 1)
+ is
+ begin
+ Call_Chain
+ (Traceback'Address, Max_Len, Len,
+ Exclude_Min, Exclude_Max,
+
+ -- Skip one extra frame to skip the other Call_Chain entry as well
+
+ Skip_Frames => Skip_Frames + 1);
+ end Call_Chain;
+
+ ------------------
+ -- C_Call_Chain --
+ ------------------
+
+ function C_Call_Chain
+ (Traceback : System.Address;
+ Max_Len : Natural) return Natural
+ is
+ Val : Natural;
+ begin
+ Call_Chain (Traceback, Max_Len, Val);
+ return Val;
+ end C_Call_Chain;
+
+end System.Traceback;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M . T R A C E B A C K . S Y M B O L I C --
--- --
--- B o d y --
--- --
--- Copyright (C) 1999-2017, AdaCore --
--- --
--- 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. --
--- --
-------------------------------------------------------------------------------
-
--- Run-time symbolic traceback support for targets using DWARF debug data
-
-pragma Polling (Off);
--- We must turn polling off for this unit, because otherwise we can get
--- elaboration circularities when polling is turned on.
-
-with Ada.Unchecked_Deallocation;
-
-with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
-with Ada.Containers.Generic_Array_Sort;
-
-with System.Address_To_Access_Conversions;
-with System.Soft_Links;
-with System.CRTL;
-with System.Dwarf_Lines;
-with System.Exception_Traces;
-with System.Standard_Library;
-with System.Traceback_Entries;
-with System.Strings;
-with System.Bounded_Strings;
-
-package body System.Traceback.Symbolic is
-
- use System.Bounded_Strings;
- use System.Dwarf_Lines;
-
- subtype Big_String is String (Positive);
- -- To deal with C strings
-
- package Big_String_Conv is new System.Address_To_Access_Conversions
- (Big_String);
-
- type Module_Cache;
- type Module_Cache_Acc is access all Module_Cache;
-
- type Module_Cache is record
- Name : Strings.String_Access;
- -- Name of the module
-
- C : Dwarf_Context (In_Exception => True);
- -- Context to symbolize an address within this module
-
- Chain : Module_Cache_Acc;
- end record;
-
- procedure Free is new Ada.Unchecked_Deallocation
- (Module_Cache,
- Module_Cache_Acc);
-
- Cache_Chain : Module_Cache_Acc;
- -- Simply linked list of modules
-
- type Module_Array is array (Natural range <>) of Module_Cache_Acc;
- type Module_Array_Acc is access Module_Array;
-
- Modules_Cache : Module_Array_Acc;
- -- Sorted array of cached modules (if not null)
-
- Exec_Module : aliased Module_Cache;
- -- Context for the executable
-
- type Init_State is (Uninitialized, Initialized, Failed);
- Exec_Module_State : Init_State := Uninitialized;
- -- How Exec_Module is initialized
-
- procedure Init_Exec_Module;
- -- Initialize Exec_Module if not already initialized
-
- function Symbolic_Traceback
- (Traceback : System.Traceback_Entries.Tracebacks_Array;
- Suppress_Hex : Boolean) return String;
- function Symbolic_Traceback
- (E : Ada.Exceptions.Exception_Occurrence;
- Suppress_Hex : Boolean) return String;
- -- Suppress_Hex means do not print any hexadecimal addresses, even if the
- -- symbol is not available.
-
- function Lt (Left, Right : Module_Cache_Acc) return Boolean;
- -- Sort function for Module_Cache
-
- procedure Init_Module
- (Module : out Module_Cache;
- Success : out Boolean;
- Module_Name : String;
- Load_Address : Address := Null_Address);
- -- Initialize Module
-
- procedure Close_Module (Module : in out Module_Cache);
- -- Finalize Module
-
- function Value (Item : System.Address) return String;
- -- Return the String contained in Item, up until the first NUL character
-
- pragma Warnings (Off, "*Add_Module_To_Cache*");
- procedure Add_Module_To_Cache (Module_Name : String);
- -- To be called by Build_Cache_For_All_Modules to add a new module to the
- -- list. May not be referenced.
-
- package Module_Name is
-
- procedure Build_Cache_For_All_Modules;
- -- Create the cache for all current modules
-
- function Get (Addr : access System.Address) return String;
- -- Returns the module name for the given address, Addr may be updated
- -- to be set relative to a shared library. This depends on the platform.
- -- Returns an empty string for the main executable.
-
- function Is_Supported return Boolean;
- pragma Inline (Is_Supported);
- -- Returns True if Module_Name is supported, so if the traceback is
- -- supported for shared libraries.
-
- end Module_Name;
-
- package body Module_Name is separate;
-
- function Executable_Name return String;
- -- Returns the executable name as reported by argv[0]. If gnat_argv not
- -- initialized or if argv[0] executable not found in path, function returns
- -- an empty string.
-
- function Get_Executable_Load_Address return System.Address;
- pragma Import
- (C,
- Get_Executable_Load_Address,
- "__gnat_get_executable_load_address");
- -- Get the load address of the executable, or Null_Address if not known
-
- procedure Hexa_Traceback
- (Traceback : Tracebacks_Array;
- Suppress_Hex : Boolean;
- Res : in out Bounded_String);
- -- Non-symbolic traceback (simply write addresses in hexa)
-
- procedure Symbolic_Traceback_No_Lock
- (Traceback : Tracebacks_Array;
- Suppress_Hex : Boolean;
- Res : in out Bounded_String);
- -- Like the public Symbolic_Traceback_No_Lock except there is no provision
- -- against concurrent accesses.
-
- procedure Module_Symbolic_Traceback
- (Traceback : Tracebacks_Array;
- Module : Module_Cache;
- Suppress_Hex : Boolean;
- Res : in out Bounded_String);
- -- Returns the Traceback for a given module
-
- procedure Multi_Module_Symbolic_Traceback
- (Traceback : Tracebacks_Array;
- Suppress_Hex : Boolean;
- Res : in out Bounded_String);
- -- Build string containing symbolic traceback for the given call chain
-
- procedure Multi_Module_Symbolic_Traceback
- (Traceback : Tracebacks_Array;
- Module : Module_Cache;
- Suppress_Hex : Boolean;
- Res : in out Bounded_String);
- -- Likewise but using Module
-
- Max_String_Length : constant := 4096;
- -- Arbitrary limit on Bounded_Str length
-
- -----------
- -- Value --
- -----------
-
- function Value (Item : System.Address) return String is
- begin
- if Item /= Null_Address then
- for J in Big_String'Range loop
- if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then
- return Big_String_Conv.To_Pointer (Item) (1 .. J - 1);
- end if;
- end loop;
- end if;
-
- return "";
- end Value;
-
- -------------------------
- -- Add_Module_To_Cache --
- -------------------------
-
- procedure Add_Module_To_Cache (Module_Name : String) is
- Module : Module_Cache_Acc;
- Success : Boolean;
- begin
- Module := new Module_Cache;
- Init_Module (Module.all, Success, Module_Name);
- if not Success then
- Free (Module);
- return;
- end if;
- Module.Chain := Cache_Chain;
- Cache_Chain := Module;
- end Add_Module_To_Cache;
-
- ----------------------
- -- Init_Exec_Module --
- ----------------------
-
- procedure Init_Exec_Module is
- begin
- if Exec_Module_State = Uninitialized then
- declare
- Exec_Path : constant String := Executable_Name;
- Exec_Load : constant Address := Get_Executable_Load_Address;
- Success : Boolean;
- begin
- Init_Module (Exec_Module, Success, Exec_Path, Exec_Load);
-
- if Success then
- Exec_Module_State := Initialized;
- else
- Exec_Module_State := Failed;
- end if;
- end;
- end if;
- end Init_Exec_Module;
-
- --------
- -- Lt --
- --------
-
- function Lt (Left, Right : Module_Cache_Acc) return Boolean is
- begin
- return Low (Left.C) < Low (Right.C);
- end Lt;
-
- -----------------------------
- -- Module_Cache_Array_Sort --
- -----------------------------
-
- procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort
- (Natural,
- Module_Cache_Acc,
- Module_Array,
- Lt);
-
- ------------------
- -- Enable_Cache --
- ------------------
-
- procedure Enable_Cache (Include_Modules : Boolean := False) is
- begin
- -- Can be called at most once
- if Cache_Chain /= null then
- return;
- end if;
-
- -- Add all modules
- Init_Exec_Module;
- Cache_Chain := Exec_Module'Access;
-
- if Include_Modules then
- Module_Name.Build_Cache_For_All_Modules;
- end if;
-
- -- Build and fill the array of modules
- declare
- Count : Natural;
- Module : Module_Cache_Acc;
- begin
- for Phase in 1 .. 2 loop
- Count := 0;
- Module := Cache_Chain;
- while Module /= null loop
- Count := Count + 1;
-
- if Phase = 1 then
- Enable_Cache (Module.C);
- else
- Modules_Cache (Count) := Module;
- end if;
- Module := Module.Chain;
- end loop;
-
- if Phase = 1 then
- Modules_Cache := new Module_Array (1 .. Count);
- end if;
- end loop;
- end;
-
- -- Sort the array
- Module_Cache_Array_Sort (Modules_Cache.all);
- end Enable_Cache;
-
- ---------------------
- -- Executable_Name --
- ---------------------
-
- function Executable_Name return String is
- -- We have to import gnat_argv as an Address to match the type of
- -- gnat_argv in the binder generated file. Otherwise, we get spurious
- -- warnings about type mismatch when LTO is turned on.
-
- Gnat_Argv : System.Address;
- pragma Import (C, Gnat_Argv, "gnat_argv");
-
- type Argv_Array is array (0 .. 0) of System.Address;
- package Conv is new System.Address_To_Access_Conversions (Argv_Array);
-
- function locate_exec_on_path (A : System.Address) return System.Address;
- pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path");
-
- begin
- if Gnat_Argv = Null_Address then
- return "";
- end if;
-
- declare
- Addr : constant System.Address :=
- locate_exec_on_path (Conv.To_Pointer (Gnat_Argv) (0));
- Result : constant String := Value (Addr);
-
- begin
- -- The buffer returned by locate_exec_on_path was allocated using
- -- malloc, so we should use free to release the memory.
-
- if Addr /= Null_Address then
- System.CRTL.free (Addr);
- end if;
-
- return Result;
- end;
- end Executable_Name;
-
- ------------------
- -- Close_Module --
- ------------------
-
- procedure Close_Module (Module : in out Module_Cache) is
- begin
- Close (Module.C);
- Strings.Free (Module.Name);
- end Close_Module;
-
- -----------------
- -- Init_Module --
- -----------------
-
- procedure Init_Module
- (Module : out Module_Cache;
- Success : out Boolean;
- Module_Name : String;
- Load_Address : Address := Null_Address)
- is
- begin
- -- Early return if the module is not known
-
- if Module_Name = "" then
- Success := False;
- return;
- end if;
-
- Open (Module_Name, Module.C, Success);
-
- -- If a module can't be opened just return now, we just cannot give more
- -- information in this case.
-
- if not Success then
- return;
- end if;
-
- Set_Load_Address (Module.C, Load_Address);
-
- Module.Name := new String'(Module_Name);
- end Init_Module;
-
- -------------------------------
- -- Module_Symbolic_Traceback --
- -------------------------------
-
- procedure Module_Symbolic_Traceback
- (Traceback : Tracebacks_Array;
- Module : Module_Cache;
- Suppress_Hex : Boolean;
- Res : in out Bounded_String)
- is
- Success : Boolean := False;
- begin
- if Symbolic.Module_Name.Is_Supported then
- Append (Res, '[');
- Append (Res, Module.Name.all);
- Append (Res, ']' & ASCII.LF);
- end if;
-
- Dwarf_Lines.Symbolic_Traceback
- (Module.C,
- Traceback,
- Suppress_Hex,
- Success,
- Res);
-
- if not Success then
- Hexa_Traceback (Traceback, Suppress_Hex, Res);
- end if;
-
- -- We must not allow an unhandled exception here, since this function
- -- may be installed as a decorator for all automatic exceptions.
-
- exception
- when others =>
- return;
- end Module_Symbolic_Traceback;
-
- -------------------------------------
- -- Multi_Module_Symbolic_Traceback --
- -------------------------------------
-
- procedure Multi_Module_Symbolic_Traceback
- (Traceback : Tracebacks_Array;
- Suppress_Hex : Boolean;
- Res : in out Bounded_String)
- is
- F : constant Natural := Traceback'First;
- begin
- if Traceback'Length = 0 or else Is_Full (Res) then
- return;
- end if;
-
- if Modules_Cache /= null then
- -- Search in the cache
-
- declare
- Addr : constant Address := Traceback (F);
- Hi, Lo, Mid : Natural;
- begin
- Lo := Modules_Cache'First;
- Hi := Modules_Cache'Last;
- while Lo <= Hi loop
- Mid := (Lo + Hi) / 2;
- if Addr < Low (Modules_Cache (Mid).C) then
- Hi := Mid - 1;
- elsif Is_Inside (Modules_Cache (Mid).C, Addr) then
- Multi_Module_Symbolic_Traceback
- (Traceback,
- Modules_Cache (Mid).all,
- Suppress_Hex,
- Res);
- return;
- else
- Lo := Mid + 1;
- end if;
- end loop;
-
- -- Not found
- Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
- Multi_Module_Symbolic_Traceback
- (Traceback (F + 1 .. Traceback'Last),
- Suppress_Hex,
- Res);
- end;
- else
-
- -- First try the executable
- if Is_Inside (Exec_Module.C, Traceback (F)) then
- Multi_Module_Symbolic_Traceback
- (Traceback,
- Exec_Module,
- Suppress_Hex,
- Res);
- return;
- end if;
-
- -- Otherwise, try a shared library
- declare
- Addr : aliased System.Address := Traceback (F);
- M_Name : constant String := Module_Name.Get (Addr'Access);
- Module : Module_Cache;
- Success : Boolean;
- begin
- Init_Module (Module, Success, M_Name, System.Null_Address);
- if Success then
- Multi_Module_Symbolic_Traceback
- (Traceback,
- Module,
- Suppress_Hex,
- Res);
- Close_Module (Module);
- else
- -- Module not found
- Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
- Multi_Module_Symbolic_Traceback
- (Traceback (F + 1 .. Traceback'Last),
- Suppress_Hex,
- Res);
- end if;
- end;
- end if;
- end Multi_Module_Symbolic_Traceback;
-
- procedure Multi_Module_Symbolic_Traceback
- (Traceback : Tracebacks_Array;
- Module : Module_Cache;
- Suppress_Hex : Boolean;
- Res : in out Bounded_String)
- is
- Pos : Positive;
- begin
- -- Will symbolize the first address...
-
- Pos := Traceback'First + 1;
-
- -- ... and all addresses in the same module
-
- Same_Module :
- loop
- exit Same_Module when Pos > Traceback'Last;
-
- -- Get address to check for corresponding module name
-
- exit Same_Module when not Is_Inside (Module.C, Traceback (Pos));
-
- Pos := Pos + 1;
- end loop Same_Module;
-
- Module_Symbolic_Traceback
- (Traceback (Traceback'First .. Pos - 1),
- Module,
- Suppress_Hex,
- Res);
- Multi_Module_Symbolic_Traceback
- (Traceback (Pos .. Traceback'Last),
- Suppress_Hex,
- Res);
- end Multi_Module_Symbolic_Traceback;
-
- --------------------
- -- Hexa_Traceback --
- --------------------
-
- procedure Hexa_Traceback
- (Traceback : Tracebacks_Array;
- Suppress_Hex : Boolean;
- Res : in out Bounded_String)
- is
- use System.Traceback_Entries;
- begin
- if Suppress_Hex then
- Append (Res, "...");
- Append (Res, ASCII.LF);
- else
- for J in Traceback'Range loop
- Append_Address (Res, PC_For (Traceback (J)));
- Append (Res, ASCII.LF);
- end loop;
- end if;
- end Hexa_Traceback;
-
- --------------------------------
- -- Symbolic_Traceback_No_Lock --
- --------------------------------
-
- procedure Symbolic_Traceback_No_Lock
- (Traceback : Tracebacks_Array;
- Suppress_Hex : Boolean;
- Res : in out Bounded_String)
- is
- begin
- if Symbolic.Module_Name.Is_Supported then
- Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res);
- else
- if Exec_Module_State = Failed then
- Append (Res, "Call stack traceback locations:" & ASCII.LF);
- Hexa_Traceback (Traceback, Suppress_Hex, Res);
- else
- Module_Symbolic_Traceback
- (Traceback,
- Exec_Module,
- Suppress_Hex,
- Res);
- end if;
- end if;
- end Symbolic_Traceback_No_Lock;
-
- ------------------------
- -- Symbolic_Traceback --
- ------------------------
-
- function Symbolic_Traceback
- (Traceback : Tracebacks_Array;
- Suppress_Hex : Boolean) return String
- is
- Res : Bounded_String (Max_Length => Max_String_Length);
- begin
- System.Soft_Links.Lock_Task.all;
- Init_Exec_Module;
- Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res);
- System.Soft_Links.Unlock_Task.all;
-
- return To_String (Res);
-
- exception
- when others =>
- System.Soft_Links.Unlock_Task.all;
- raise;
- end Symbolic_Traceback;
-
- function Symbolic_Traceback
- (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
- begin
- return Symbolic_Traceback (Traceback, Suppress_Hex => False);
- end Symbolic_Traceback;
-
- function Symbolic_Traceback_No_Hex
- (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
- begin
- return Symbolic_Traceback (Traceback, Suppress_Hex => True);
- end Symbolic_Traceback_No_Hex;
-
- function Symbolic_Traceback
- (E : Ada.Exceptions.Exception_Occurrence;
- Suppress_Hex : Boolean) return String
- is
- begin
- return Symbolic_Traceback
- (Ada.Exceptions.Traceback.Tracebacks (E),
- Suppress_Hex);
- end Symbolic_Traceback;
-
- function Symbolic_Traceback
- (E : Ada.Exceptions.Exception_Occurrence) return String
- is
- begin
- return Symbolic_Traceback (E, Suppress_Hex => False);
- end Symbolic_Traceback;
-
- function Symbolic_Traceback_No_Hex
- (E : Ada.Exceptions.Exception_Occurrence) return String is
- begin
- return Symbolic_Traceback (E, Suppress_Hex => True);
- end Symbolic_Traceback_No_Hex;
-
- Exception_Tracebacks_Symbolic : Integer;
- pragma Import
- (C,
- Exception_Tracebacks_Symbolic,
- "__gl_exception_tracebacks_symbolic");
- -- Boolean indicating whether symbolic tracebacks should be generated.
-
- use Standard_Library;
-begin
- -- If this version of this package is available, and the binder switch -Es
- -- was given, then we want to use this as the decorator by default, and we
- -- want to turn on tracing for Unhandled_Raise_In_Main. Note that the user
- -- cannot have already set Exception_Trace, because the runtime library is
- -- elaborated before user-defined code.
-
- if Exception_Tracebacks_Symbolic /= 0 then
- Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access);
- pragma Assert (Exception_Trace = RM_Convention);
- Exception_Trace := Unhandled_Raise_In_Main;
- end if;
-end System.Traceback.Symbolic;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K . S Y M B O L I C --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-2017, AdaCore --
+-- --
+-- 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Run-time symbolic traceback support for targets using DWARF debug data
+
+pragma Polling (Off);
+-- We must turn polling off for this unit, because otherwise we can get
+-- elaboration circularities when polling is turned on.
+
+with Ada.Unchecked_Deallocation;
+
+with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
+with Ada.Containers.Generic_Array_Sort;
+
+with System.Address_To_Access_Conversions;
+with System.Soft_Links;
+with System.CRTL;
+with System.Dwarf_Lines;
+with System.Exception_Traces;
+with System.Standard_Library;
+with System.Traceback_Entries;
+with System.Strings;
+with System.Bounded_Strings;
+
+package body System.Traceback.Symbolic is
+
+ use System.Bounded_Strings;
+ use System.Dwarf_Lines;
+
+ subtype Big_String is String (Positive);
+ -- To deal with C strings
+
+ package Big_String_Conv is new System.Address_To_Access_Conversions
+ (Big_String);
+
+ type Module_Cache;
+ type Module_Cache_Acc is access all Module_Cache;
+
+ type Module_Cache is record
+ Name : Strings.String_Access;
+ -- Name of the module
+
+ C : Dwarf_Context (In_Exception => True);
+ -- Context to symbolize an address within this module
+
+ Chain : Module_Cache_Acc;
+ end record;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Module_Cache,
+ Module_Cache_Acc);
+
+ Cache_Chain : Module_Cache_Acc;
+ -- Simply linked list of modules
+
+ type Module_Array is array (Natural range <>) of Module_Cache_Acc;
+ type Module_Array_Acc is access Module_Array;
+
+ Modules_Cache : Module_Array_Acc;
+ -- Sorted array of cached modules (if not null)
+
+ Exec_Module : aliased Module_Cache;
+ -- Context for the executable
+
+ type Init_State is (Uninitialized, Initialized, Failed);
+ Exec_Module_State : Init_State := Uninitialized;
+ -- How Exec_Module is initialized
+
+ procedure Init_Exec_Module;
+ -- Initialize Exec_Module if not already initialized
+
+ function Symbolic_Traceback
+ (Traceback : System.Traceback_Entries.Tracebacks_Array;
+ Suppress_Hex : Boolean) return String;
+ function Symbolic_Traceback
+ (E : Ada.Exceptions.Exception_Occurrence;
+ Suppress_Hex : Boolean) return String;
+ -- Suppress_Hex means do not print any hexadecimal addresses, even if the
+ -- symbol is not available.
+
+ function Lt (Left, Right : Module_Cache_Acc) return Boolean;
+ -- Sort function for Module_Cache
+
+ procedure Init_Module
+ (Module : out Module_Cache;
+ Success : out Boolean;
+ Module_Name : String;
+ Load_Address : Address := Null_Address);
+ -- Initialize Module
+
+ procedure Close_Module (Module : in out Module_Cache);
+ -- Finalize Module
+
+ function Value (Item : System.Address) return String;
+ -- Return the String contained in Item, up until the first NUL character
+
+ pragma Warnings (Off, "*Add_Module_To_Cache*");
+ procedure Add_Module_To_Cache (Module_Name : String);
+ -- To be called by Build_Cache_For_All_Modules to add a new module to the
+ -- list. May not be referenced.
+
+ package Module_Name is
+
+ procedure Build_Cache_For_All_Modules;
+ -- Create the cache for all current modules
+
+ function Get (Addr : access System.Address) return String;
+ -- Returns the module name for the given address, Addr may be updated
+ -- to be set relative to a shared library. This depends on the platform.
+ -- Returns an empty string for the main executable.
+
+ function Is_Supported return Boolean;
+ pragma Inline (Is_Supported);
+ -- Returns True if Module_Name is supported, so if the traceback is
+ -- supported for shared libraries.
+
+ end Module_Name;
+
+ package body Module_Name is separate;
+
+ function Executable_Name return String;
+ -- Returns the executable name as reported by argv[0]. If gnat_argv not
+ -- initialized or if argv[0] executable not found in path, function returns
+ -- an empty string.
+
+ function Get_Executable_Load_Address return System.Address;
+ pragma Import
+ (C,
+ Get_Executable_Load_Address,
+ "__gnat_get_executable_load_address");
+ -- Get the load address of the executable, or Null_Address if not known
+
+ procedure Hexa_Traceback
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String);
+ -- Non-symbolic traceback (simply write addresses in hexa)
+
+ procedure Symbolic_Traceback_No_Lock
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String);
+ -- Like the public Symbolic_Traceback_No_Lock except there is no provision
+ -- against concurrent accesses.
+
+ procedure Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Module : Module_Cache;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String);
+ -- Returns the Traceback for a given module
+
+ procedure Multi_Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String);
+ -- Build string containing symbolic traceback for the given call chain
+
+ procedure Multi_Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Module : Module_Cache;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String);
+ -- Likewise but using Module
+
+ Max_String_Length : constant := 4096;
+ -- Arbitrary limit on Bounded_Str length
+
+ -----------
+ -- Value --
+ -----------
+
+ function Value (Item : System.Address) return String is
+ begin
+ if Item /= Null_Address then
+ for J in Big_String'Range loop
+ if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then
+ return Big_String_Conv.To_Pointer (Item) (1 .. J - 1);
+ end if;
+ end loop;
+ end if;
+
+ return "";
+ end Value;
+
+ -------------------------
+ -- Add_Module_To_Cache --
+ -------------------------
+
+ procedure Add_Module_To_Cache (Module_Name : String) is
+ Module : Module_Cache_Acc;
+ Success : Boolean;
+ begin
+ Module := new Module_Cache;
+ Init_Module (Module.all, Success, Module_Name);
+ if not Success then
+ Free (Module);
+ return;
+ end if;
+ Module.Chain := Cache_Chain;
+ Cache_Chain := Module;
+ end Add_Module_To_Cache;
+
+ ----------------------
+ -- Init_Exec_Module --
+ ----------------------
+
+ procedure Init_Exec_Module is
+ begin
+ if Exec_Module_State = Uninitialized then
+ declare
+ Exec_Path : constant String := Executable_Name;
+ Exec_Load : constant Address := Get_Executable_Load_Address;
+ Success : Boolean;
+ begin
+ Init_Module (Exec_Module, Success, Exec_Path, Exec_Load);
+
+ if Success then
+ Exec_Module_State := Initialized;
+ else
+ Exec_Module_State := Failed;
+ end if;
+ end;
+ end if;
+ end Init_Exec_Module;
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (Left, Right : Module_Cache_Acc) return Boolean is
+ begin
+ return Low (Left.C) < Low (Right.C);
+ end Lt;
+
+ -----------------------------
+ -- Module_Cache_Array_Sort --
+ -----------------------------
+
+ procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort
+ (Natural,
+ Module_Cache_Acc,
+ Module_Array,
+ Lt);
+
+ ------------------
+ -- Enable_Cache --
+ ------------------
+
+ procedure Enable_Cache (Include_Modules : Boolean := False) is
+ begin
+ -- Can be called at most once
+ if Cache_Chain /= null then
+ return;
+ end if;
+
+ -- Add all modules
+ Init_Exec_Module;
+ Cache_Chain := Exec_Module'Access;
+
+ if Include_Modules then
+ Module_Name.Build_Cache_For_All_Modules;
+ end if;
+
+ -- Build and fill the array of modules
+ declare
+ Count : Natural;
+ Module : Module_Cache_Acc;
+ begin
+ for Phase in 1 .. 2 loop
+ Count := 0;
+ Module := Cache_Chain;
+ while Module /= null loop
+ Count := Count + 1;
+
+ if Phase = 1 then
+ Enable_Cache (Module.C);
+ else
+ Modules_Cache (Count) := Module;
+ end if;
+ Module := Module.Chain;
+ end loop;
+
+ if Phase = 1 then
+ Modules_Cache := new Module_Array (1 .. Count);
+ end if;
+ end loop;
+ end;
+
+ -- Sort the array
+ Module_Cache_Array_Sort (Modules_Cache.all);
+ end Enable_Cache;
+
+ ---------------------
+ -- Executable_Name --
+ ---------------------
+
+ function Executable_Name return String is
+ -- We have to import gnat_argv as an Address to match the type of
+ -- gnat_argv in the binder generated file. Otherwise, we get spurious
+ -- warnings about type mismatch when LTO is turned on.
+
+ Gnat_Argv : System.Address;
+ pragma Import (C, Gnat_Argv, "gnat_argv");
+
+ type Argv_Array is array (0 .. 0) of System.Address;
+ package Conv is new System.Address_To_Access_Conversions (Argv_Array);
+
+ function locate_exec_on_path (A : System.Address) return System.Address;
+ pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path");
+
+ begin
+ if Gnat_Argv = Null_Address then
+ return "";
+ end if;
+
+ declare
+ Addr : constant System.Address :=
+ locate_exec_on_path (Conv.To_Pointer (Gnat_Argv) (0));
+ Result : constant String := Value (Addr);
+
+ begin
+ -- The buffer returned by locate_exec_on_path was allocated using
+ -- malloc, so we should use free to release the memory.
+
+ if Addr /= Null_Address then
+ System.CRTL.free (Addr);
+ end if;
+
+ return Result;
+ end;
+ end Executable_Name;
+
+ ------------------
+ -- Close_Module --
+ ------------------
+
+ procedure Close_Module (Module : in out Module_Cache) is
+ begin
+ Close (Module.C);
+ Strings.Free (Module.Name);
+ end Close_Module;
+
+ -----------------
+ -- Init_Module --
+ -----------------
+
+ procedure Init_Module
+ (Module : out Module_Cache;
+ Success : out Boolean;
+ Module_Name : String;
+ Load_Address : Address := Null_Address)
+ is
+ begin
+ -- Early return if the module is not known
+
+ if Module_Name = "" then
+ Success := False;
+ return;
+ end if;
+
+ Open (Module_Name, Module.C, Success);
+
+ -- If a module can't be opened just return now, we just cannot give more
+ -- information in this case.
+
+ if not Success then
+ return;
+ end if;
+
+ Set_Load_Address (Module.C, Load_Address);
+
+ Module.Name := new String'(Module_Name);
+ end Init_Module;
+
+ -------------------------------
+ -- Module_Symbolic_Traceback --
+ -------------------------------
+
+ procedure Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Module : Module_Cache;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String)
+ is
+ Success : Boolean := False;
+ begin
+ if Symbolic.Module_Name.Is_Supported then
+ Append (Res, '[');
+ Append (Res, Module.Name.all);
+ Append (Res, ']' & ASCII.LF);
+ end if;
+
+ Dwarf_Lines.Symbolic_Traceback
+ (Module.C,
+ Traceback,
+ Suppress_Hex,
+ Success,
+ Res);
+
+ if not Success then
+ Hexa_Traceback (Traceback, Suppress_Hex, Res);
+ end if;
+
+ -- We must not allow an unhandled exception here, since this function
+ -- may be installed as a decorator for all automatic exceptions.
+
+ exception
+ when others =>
+ return;
+ end Module_Symbolic_Traceback;
+
+ -------------------------------------
+ -- Multi_Module_Symbolic_Traceback --
+ -------------------------------------
+
+ procedure Multi_Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String)
+ is
+ F : constant Natural := Traceback'First;
+ begin
+ if Traceback'Length = 0 or else Is_Full (Res) then
+ return;
+ end if;
+
+ if Modules_Cache /= null then
+ -- Search in the cache
+
+ declare
+ Addr : constant Address := Traceback (F);
+ Hi, Lo, Mid : Natural;
+ begin
+ Lo := Modules_Cache'First;
+ Hi := Modules_Cache'Last;
+ while Lo <= Hi loop
+ Mid := (Lo + Hi) / 2;
+ if Addr < Low (Modules_Cache (Mid).C) then
+ Hi := Mid - 1;
+ elsif Is_Inside (Modules_Cache (Mid).C, Addr) then
+ Multi_Module_Symbolic_Traceback
+ (Traceback,
+ Modules_Cache (Mid).all,
+ Suppress_Hex,
+ Res);
+ return;
+ else
+ Lo := Mid + 1;
+ end if;
+ end loop;
+
+ -- Not found
+ Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
+ Multi_Module_Symbolic_Traceback
+ (Traceback (F + 1 .. Traceback'Last),
+ Suppress_Hex,
+ Res);
+ end;
+ else
+
+ -- First try the executable
+ if Is_Inside (Exec_Module.C, Traceback (F)) then
+ Multi_Module_Symbolic_Traceback
+ (Traceback,
+ Exec_Module,
+ Suppress_Hex,
+ Res);
+ return;
+ end if;
+
+ -- Otherwise, try a shared library
+ declare
+ Addr : aliased System.Address := Traceback (F);
+ M_Name : constant String := Module_Name.Get (Addr'Access);
+ Module : Module_Cache;
+ Success : Boolean;
+ begin
+ Init_Module (Module, Success, M_Name, System.Null_Address);
+ if Success then
+ Multi_Module_Symbolic_Traceback
+ (Traceback,
+ Module,
+ Suppress_Hex,
+ Res);
+ Close_Module (Module);
+ else
+ -- Module not found
+ Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res);
+ Multi_Module_Symbolic_Traceback
+ (Traceback (F + 1 .. Traceback'Last),
+ Suppress_Hex,
+ Res);
+ end if;
+ end;
+ end if;
+ end Multi_Module_Symbolic_Traceback;
+
+ procedure Multi_Module_Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Module : Module_Cache;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String)
+ is
+ Pos : Positive;
+ begin
+ -- Will symbolize the first address...
+
+ Pos := Traceback'First + 1;
+
+ -- ... and all addresses in the same module
+
+ Same_Module :
+ loop
+ exit Same_Module when Pos > Traceback'Last;
+
+ -- Get address to check for corresponding module name
+
+ exit Same_Module when not Is_Inside (Module.C, Traceback (Pos));
+
+ Pos := Pos + 1;
+ end loop Same_Module;
+
+ Module_Symbolic_Traceback
+ (Traceback (Traceback'First .. Pos - 1),
+ Module,
+ Suppress_Hex,
+ Res);
+ Multi_Module_Symbolic_Traceback
+ (Traceback (Pos .. Traceback'Last),
+ Suppress_Hex,
+ Res);
+ end Multi_Module_Symbolic_Traceback;
+
+ --------------------
+ -- Hexa_Traceback --
+ --------------------
+
+ procedure Hexa_Traceback
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String)
+ is
+ use System.Traceback_Entries;
+ begin
+ if Suppress_Hex then
+ Append (Res, "...");
+ Append (Res, ASCII.LF);
+ else
+ for J in Traceback'Range loop
+ Append_Address (Res, PC_For (Traceback (J)));
+ Append (Res, ASCII.LF);
+ end loop;
+ end if;
+ end Hexa_Traceback;
+
+ --------------------------------
+ -- Symbolic_Traceback_No_Lock --
+ --------------------------------
+
+ procedure Symbolic_Traceback_No_Lock
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean;
+ Res : in out Bounded_String)
+ is
+ begin
+ if Symbolic.Module_Name.Is_Supported then
+ Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res);
+ else
+ if Exec_Module_State = Failed then
+ Append (Res, "Call stack traceback locations:" & ASCII.LF);
+ Hexa_Traceback (Traceback, Suppress_Hex, Res);
+ else
+ Module_Symbolic_Traceback
+ (Traceback,
+ Exec_Module,
+ Suppress_Hex,
+ Res);
+ end if;
+ end if;
+ end Symbolic_Traceback_No_Lock;
+
+ ------------------------
+ -- Symbolic_Traceback --
+ ------------------------
+
+ function Symbolic_Traceback
+ (Traceback : Tracebacks_Array;
+ Suppress_Hex : Boolean) return String
+ is
+ Res : Bounded_String (Max_Length => Max_String_Length);
+ begin
+ System.Soft_Links.Lock_Task.all;
+ Init_Exec_Module;
+ Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res);
+ System.Soft_Links.Unlock_Task.all;
+
+ return To_String (Res);
+
+ exception
+ when others =>
+ System.Soft_Links.Unlock_Task.all;
+ raise;
+ end Symbolic_Traceback;
+
+ function Symbolic_Traceback
+ (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
+ begin
+ return Symbolic_Traceback (Traceback, Suppress_Hex => False);
+ end Symbolic_Traceback;
+
+ function Symbolic_Traceback_No_Hex
+ (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is
+ begin
+ return Symbolic_Traceback (Traceback, Suppress_Hex => True);
+ end Symbolic_Traceback_No_Hex;
+
+ function Symbolic_Traceback
+ (E : Ada.Exceptions.Exception_Occurrence;
+ Suppress_Hex : Boolean) return String
+ is
+ begin
+ return Symbolic_Traceback
+ (Ada.Exceptions.Traceback.Tracebacks (E),
+ Suppress_Hex);
+ end Symbolic_Traceback;
+
+ function Symbolic_Traceback
+ (E : Ada.Exceptions.Exception_Occurrence) return String
+ is
+ begin
+ return Symbolic_Traceback (E, Suppress_Hex => False);
+ end Symbolic_Traceback;
+
+ function Symbolic_Traceback_No_Hex
+ (E : Ada.Exceptions.Exception_Occurrence) return String is
+ begin
+ return Symbolic_Traceback (E, Suppress_Hex => True);
+ end Symbolic_Traceback_No_Hex;
+
+ Exception_Tracebacks_Symbolic : Integer;
+ pragma Import
+ (C,
+ Exception_Tracebacks_Symbolic,
+ "__gl_exception_tracebacks_symbolic");
+ -- Boolean indicating whether symbolic tracebacks should be generated.
+
+ use Standard_Library;
+begin
+ -- If this version of this package is available, and the binder switch -Es
+ -- was given, then we want to use this as the decorator by default, and we
+ -- want to turn on tracing for Unhandled_Raise_In_Main. Note that the user
+ -- cannot have already set Exception_Trace, because the runtime library is
+ -- elaborated before user-defined code.
+
+ if Exception_Tracebacks_Symbolic /= 0 then
+ Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access);
+ pragma Assert (Exception_Trace = RM_Convention);
+ Exception_Trace := Unhandled_Raise_In_Main;
+ end if;
+end System.Traceback.Symbolic;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2012-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the GNU/Linux specific version of this package
-with Interfaces.C; use Interfaces.C;
-
-with System.Address_Operations; use System.Address_Operations;
-
-separate (System.Traceback.Symbolic)
-
-package body Module_Name is
-
- use System;
-
- pragma Linker_Options ("-ldl");
-
- function Is_Shared_Lib (Base : Address) return Boolean;
- -- Returns True if a shared library
-
- -- The principle is:
-
- -- 1. We get information about the module containing the address.
-
- -- 2. We check that the full pathname is pointing to a shared library.
-
- -- 3. for shared libraries, we return the non relocated address (so
- -- the absolute address in the shared library).
-
- -- 4. we also return the full pathname of the module containing this
- -- address.
-
- -------------------
- -- Is_Shared_Lib --
- -------------------
-
- function Is_Shared_Lib (Base : Address) return Boolean is
- EI_NIDENT : constant := 16;
- type u16 is mod 2 ** 16;
-
- -- Just declare the needed header information, we just need to read the
- -- type encoded in the second field.
-
- type Elf32_Ehdr is record
- e_ident : char_array (1 .. EI_NIDENT);
- e_type : u16;
- end record;
-
- ET_DYN : constant := 3; -- A shared lib if e_type = ET_DYN
-
- Header : Elf32_Ehdr;
- pragma Import (Ada, Header);
- -- Suppress initialization in Normalized_Scalars mode
- for Header'Address use Base;
-
- begin
- return Header.e_type = ET_DYN;
- exception
- when others =>
- return False;
- end Is_Shared_Lib;
-
- ---------------------------------
- -- Build_Cache_For_All_Modules --
- ---------------------------------
-
- procedure Build_Cache_For_All_Modules is
- type link_map;
- type link_map_acc is access all link_map;
- pragma Convention (C, link_map_acc);
-
- type link_map is record
- l_addr : Address;
- -- Base address of the shared object
-
- l_name : Address;
- -- Null-terminated absolute file name
-
- l_ld : Address;
- -- Dynamic section
-
- l_next, l_prev : link_map_acc;
- -- Chain
- end record;
- pragma Convention (C, link_map);
-
- type r_debug_type is record
- r_version : Integer;
- r_map : link_map_acc;
- end record;
- pragma Convention (C, r_debug_type);
-
- r_debug : r_debug_type;
- pragma Import (C, r_debug, "_r_debug");
-
- lm : link_map_acc;
- begin
- lm := r_debug.r_map;
- while lm /= null loop
- if Big_String_Conv.To_Pointer (lm.l_name) (1) /= ASCII.NUL then
- -- Discard non-file (like the executable itself or the gate).
- Add_Module_To_Cache (Value (lm.l_name));
- end if;
- lm := lm.l_next;
- end loop;
- end Build_Cache_For_All_Modules;
-
- ---------
- -- Get --
- ---------
-
- function Get (Addr : access System.Address) return String is
-
- -- Dl_info record for Linux, used to get sym reloc offset
-
- type Dl_info is record
- dli_fname : System.Address;
- dli_fbase : System.Address;
- dli_sname : System.Address;
- dli_saddr : System.Address;
- end record;
-
- function dladdr
- (addr : System.Address;
- info : not null access Dl_info) return int;
- pragma Import (C, dladdr, "dladdr");
- -- This is a Linux extension and not POSIX
-
- info : aliased Dl_info;
-
- begin
- if dladdr (Addr.all, info'Access) /= 0 then
-
- -- If we have a shared library we need to adjust the address to
- -- be relative to the base address of the library.
-
- if Is_Shared_Lib (info.dli_fbase) then
- Addr.all := SubA (Addr.all, info.dli_fbase);
- end if;
-
- return Value (info.dli_fname);
-
- -- Not found, fallback to executable name
-
- else
- return "";
- end if;
-
- exception
- when others =>
- return "";
- end Get;
-
- ------------------
- -- Is_Supported --
- ------------------
-
- function Is_Supported return Boolean is
- begin
- return True;
- end Is_Supported;
-
-end Module_Name;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2012-2017, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Windows specific version of this package
-
-with System.Win32; use System.Win32;
-
-separate (System.Traceback.Symbolic)
-
-package body Module_Name is
-
- use System;
-
- ---------------------------------
- -- Build_Cache_For_All_Modules --
- ---------------------------------
-
- procedure Build_Cache_For_All_Modules is
- begin
- null;
- end Build_Cache_For_All_Modules;
-
- ---------
- -- Get --
- ---------
-
- function Get (Addr : access System.Address) return String is
- Res : DWORD;
- hModule : aliased HANDLE;
- Path : String (1 .. 1_024);
-
- begin
- if GetModuleHandleEx
- (GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
- Addr.all,
- hModule'Access) = Win32.TRUE
- then
- Res := GetModuleFileName (hModule, Path'Address, Path'Length);
-
- if FreeLibrary (hModule) = Win32.FALSE then
- null;
- end if;
-
- if Res > 0 then
- return Path (1 .. Positive (Res));
- end if;
- end if;
-
- return "";
-
- exception
- when others =>
- return "";
- end Get;
-
- ------------------
- -- Is_Supported --
- ------------------
-
- function Is_Supported return Boolean is
- begin
- return True;
- end Is_Supported;
-
-end Module_Name;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2012-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the GNU/Linux specific version of this package
+with Interfaces.C; use Interfaces.C;
+
+with System.Address_Operations; use System.Address_Operations;
+
+separate (System.Traceback.Symbolic)
+
+package body Module_Name is
+
+ use System;
+
+ pragma Linker_Options ("-ldl");
+
+ function Is_Shared_Lib (Base : Address) return Boolean;
+ -- Returns True if a shared library
+
+ -- The principle is:
+
+ -- 1. We get information about the module containing the address.
+
+ -- 2. We check that the full pathname is pointing to a shared library.
+
+ -- 3. for shared libraries, we return the non relocated address (so
+ -- the absolute address in the shared library).
+
+ -- 4. we also return the full pathname of the module containing this
+ -- address.
+
+ -------------------
+ -- Is_Shared_Lib --
+ -------------------
+
+ function Is_Shared_Lib (Base : Address) return Boolean is
+ EI_NIDENT : constant := 16;
+ type u16 is mod 2 ** 16;
+
+ -- Just declare the needed header information, we just need to read the
+ -- type encoded in the second field.
+
+ type Elf32_Ehdr is record
+ e_ident : char_array (1 .. EI_NIDENT);
+ e_type : u16;
+ end record;
+
+ ET_DYN : constant := 3; -- A shared lib if e_type = ET_DYN
+
+ Header : Elf32_Ehdr;
+ pragma Import (Ada, Header);
+ -- Suppress initialization in Normalized_Scalars mode
+ for Header'Address use Base;
+
+ begin
+ return Header.e_type = ET_DYN;
+ exception
+ when others =>
+ return False;
+ end Is_Shared_Lib;
+
+ ---------------------------------
+ -- Build_Cache_For_All_Modules --
+ ---------------------------------
+
+ procedure Build_Cache_For_All_Modules is
+ type link_map;
+ type link_map_acc is access all link_map;
+ pragma Convention (C, link_map_acc);
+
+ type link_map is record
+ l_addr : Address;
+ -- Base address of the shared object
+
+ l_name : Address;
+ -- Null-terminated absolute file name
+
+ l_ld : Address;
+ -- Dynamic section
+
+ l_next, l_prev : link_map_acc;
+ -- Chain
+ end record;
+ pragma Convention (C, link_map);
+
+ type r_debug_type is record
+ r_version : Integer;
+ r_map : link_map_acc;
+ end record;
+ pragma Convention (C, r_debug_type);
+
+ r_debug : r_debug_type;
+ pragma Import (C, r_debug, "_r_debug");
+
+ lm : link_map_acc;
+ begin
+ lm := r_debug.r_map;
+ while lm /= null loop
+ if Big_String_Conv.To_Pointer (lm.l_name) (1) /= ASCII.NUL then
+ -- Discard non-file (like the executable itself or the gate).
+ Add_Module_To_Cache (Value (lm.l_name));
+ end if;
+ lm := lm.l_next;
+ end loop;
+ end Build_Cache_For_All_Modules;
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get (Addr : access System.Address) return String is
+
+ -- Dl_info record for Linux, used to get sym reloc offset
+
+ type Dl_info is record
+ dli_fname : System.Address;
+ dli_fbase : System.Address;
+ dli_sname : System.Address;
+ dli_saddr : System.Address;
+ end record;
+
+ function dladdr
+ (addr : System.Address;
+ info : not null access Dl_info) return int;
+ pragma Import (C, dladdr, "dladdr");
+ -- This is a Linux extension and not POSIX
+
+ info : aliased Dl_info;
+
+ begin
+ if dladdr (Addr.all, info'Access) /= 0 then
+
+ -- If we have a shared library we need to adjust the address to
+ -- be relative to the base address of the library.
+
+ if Is_Shared_Lib (info.dli_fbase) then
+ Addr.all := SubA (Addr.all, info.dli_fbase);
+ end if;
+
+ return Value (info.dli_fname);
+
+ -- Not found, fallback to executable name
+
+ else
+ return "";
+ end if;
+
+ exception
+ when others =>
+ return "";
+ end Get;
+
+ ------------------
+ -- Is_Supported --
+ ------------------
+
+ function Is_Supported return Boolean is
+ begin
+ return True;
+ end Is_Supported;
+
+end Module_Name;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2012-2017, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Windows specific version of this package
+
+with System.Win32; use System.Win32;
+
+separate (System.Traceback.Symbolic)
+
+package body Module_Name is
+
+ use System;
+
+ ---------------------------------
+ -- Build_Cache_For_All_Modules --
+ ---------------------------------
+
+ procedure Build_Cache_For_All_Modules is
+ begin
+ null;
+ end Build_Cache_For_All_Modules;
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get (Addr : access System.Address) return String is
+ Res : DWORD;
+ hModule : aliased HANDLE;
+ Path : String (1 .. 1_024);
+
+ begin
+ if GetModuleHandleEx
+ (GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
+ Addr.all,
+ hModule'Access) = Win32.TRUE
+ then
+ Res := GetModuleFileName (hModule, Path'Address, Path'Length);
+
+ if FreeLibrary (hModule) = Win32.FALSE then
+ null;
+ end if;
+
+ if Res > 0 then
+ return Path (1 .. Positive (Res));
+ end if;
+ end if;
+
+ return "";
+
+ exception
+ when others =>
+ return "";
+ end Get;
+
+ ------------------
+ -- Is_Supported --
+ ------------------
+
+ function Is_Supported return Boolean is
+ begin
+ return True;
+ end Is_Supported;
+
+end Module_Name;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T H R E A D S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks 653 version of this package
+
+pragma Restrictions (No_Tasking);
+-- The VxWorks 653 version of this package is intended only for programs
+-- which do not use Ada tasking. This restriction ensures that this
+-- will be checked by the binder.
+
+with System.OS_Versions; use System.OS_Versions;
+with System.Secondary_Stack;
+pragma Elaborate_All (System.Secondary_Stack);
+
+package body System.Threads is
+
+ use Interfaces.C;
+
+ package SSS renames System.Secondary_Stack;
+
+ package SSL renames System.Soft_Links;
+
+ Current_ATSD : aliased System.Address := System.Null_Address;
+ pragma Export (C, Current_ATSD, "__gnat_current_atsd");
+
+ Main_ATSD : aliased ATSD;
+ -- TSD for environment task
+
+ Stack_Limit : Address;
+
+ pragma Import (C, Stack_Limit, "__gnat_stack_limit");
+
+ type Set_Stack_Limit_Proc_Acc is access procedure;
+ pragma Convention (C, Set_Stack_Limit_Proc_Acc);
+
+ Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc;
+ pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
+ -- Procedure to be called when a task is created to set stack limit if
+ -- limit checking is used.
+
+ --------------------------
+ -- VxWorks specific API --
+ --------------------------
+
+ ERROR : constant STATUS := Interfaces.C.int (-1);
+
+ function taskIdVerify (tid : t_id) return STATUS;
+ pragma Import (C, taskIdVerify, "taskIdVerify");
+
+ function taskIdSelf return t_id;
+ pragma Import (C, taskIdSelf, "taskIdSelf");
+
+ function taskVarAdd
+ (tid : t_id; pVar : System.Address) return int;
+ pragma Import (C, taskVarAdd, "taskVarAdd");
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Init_RTS;
+ -- This procedure performs the initialization of the run-time lib.
+ -- It installs System.Threads versions of certain operations of the
+ -- run-time lib.
+
+ procedure Install_Handler;
+ pragma Import (C, Install_Handler, "__gnat_install_handler");
+
+ function Get_Sec_Stack_Addr return Address;
+
+ procedure Set_Sec_Stack_Addr (Addr : Address);
+
+ -----------------------
+ -- Thread_Body_Enter --
+ -----------------------
+
+ procedure Thread_Body_Enter
+ (Sec_Stack_Address : System.Address;
+ Sec_Stack_Size : Natural;
+ Process_ATSD_Address : System.Address)
+ is
+ -- Current_ATSD must already be a taskVar of taskIdSelf.
+ -- No assertion because taskVarGet is not available on VxWorks/CERT,
+ -- which is used on VxWorks 653 3.x as a guest OS.
+
+ TSD : constant ATSD_Access := From_Address (Process_ATSD_Address);
+
+ begin
+
+ TSD.Sec_Stack_Addr := Sec_Stack_Address;
+ SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size);
+ Current_ATSD := Process_ATSD_Address;
+
+ Install_Handler;
+
+ -- Initialize stack limit if needed
+
+ if Current_ATSD /= Main_ATSD'Address
+ and then Set_Stack_Limit_Hook /= null
+ then
+ Set_Stack_Limit_Hook.all;
+ end if;
+ end Thread_Body_Enter;
+
+ ----------------------------------
+ -- Thread_Body_Exceptional_Exit --
+ ----------------------------------
+
+ procedure Thread_Body_Exceptional_Exit
+ (EO : Ada.Exceptions.Exception_Occurrence)
+ is
+ pragma Unreferenced (EO);
+
+ begin
+ -- No action for this target
+
+ null;
+ end Thread_Body_Exceptional_Exit;
+
+ -----------------------
+ -- Thread_Body_Leave --
+ -----------------------
+
+ procedure Thread_Body_Leave is
+ begin
+ -- No action for this target
+
+ null;
+ end Thread_Body_Leave;
+
+ --------------
+ -- Init_RTS --
+ --------------
+
+ procedure Init_RTS is
+ -- Register environment task
+ Result : constant Interfaces.C.int := Register (taskIdSelf);
+ pragma Assert (Result /= ERROR);
+
+ begin
+ Main_ATSD.Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT;
+ Current_ATSD := Main_ATSD'Address;
+ Install_Handler;
+ SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access;
+ SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access;
+ end Init_RTS;
+
+ ------------------------
+ -- Get_Sec_Stack_Addr --
+ ------------------------
+
+ function Get_Sec_Stack_Addr return Address is
+ CTSD : constant ATSD_Access := From_Address (Current_ATSD);
+ begin
+ pragma Assert (CTSD /= null);
+ return CTSD.Sec_Stack_Addr;
+ end Get_Sec_Stack_Addr;
+
+ --------------
+ -- Register --
+ --------------
+
+ function Register (T : Thread_Id) return STATUS is
+ Result : STATUS;
+
+ begin
+ -- It cannot be assumed that the caller of this routine has a ATSD;
+ -- so neither this procedure nor the procedures that it calls should
+ -- raise or handle exceptions, or make use of a secondary stack.
+
+ -- This routine is only necessary because taskVarAdd cannot be
+ -- executed once an VxWorks 653 partition has entered normal mode
+ -- (depending on configRecord.c, allocation could be disabled).
+ -- Otherwise, everything could have been done in Thread_Body_Enter.
+
+ if taskIdVerify (T) = ERROR then
+ return ERROR;
+ end if;
+
+ Result := taskVarAdd (T, Current_ATSD'Address);
+ pragma Assert (Result /= ERROR);
+
+ -- The same issue applies to the task variable that contains the stack
+ -- limit when that overflow checking mechanism is used instead of
+ -- probing. If stack checking is enabled and limit checking is used,
+ -- allocate the limit for this task. The environment task has this
+ -- initialized by the binder-generated main when
+ -- System.Stack_Check_Limits = True.
+
+ pragma Warnings (Off);
+ -- OS is a constant
+ if Result /= ERROR
+ and then OS /= VxWorks_653
+ and then Set_Stack_Limit_Hook /= null
+ then
+ Result := taskVarAdd (T, Stack_Limit'Address);
+ pragma Assert (Result /= ERROR);
+ end if;
+ pragma Warnings (On);
+
+ return Result;
+ end Register;
+
+ ------------------------
+ -- Set_Sec_Stack_Addr --
+ ------------------------
+
+ procedure Set_Sec_Stack_Addr (Addr : Address) is
+ CTSD : constant ATSD_Access := From_Address (Current_ATSD);
+ begin
+ pragma Assert (CTSD /= null);
+ CTSD.Sec_Stack_Addr := Addr;
+ end Set_Sec_Stack_Addr;
+
+begin
+ -- Initialize run-time library
+
+ Init_RTS;
+end System.Threads;
projects / gcc.git / commitdiff