diff --git a/.gitattributes b/.gitattributes
index 412eeda78d..cfd07fbb0b 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -1,6 +1,3 @@
-# Auto detect text files and perform LF normalization
-* text=auto
-
# Custom for Visual Studio
*.cs diff=csharp
*.sln merge=union
diff --git a/.gitignore b/.gitignore
index b033d0828c..9970124e10 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,22 +1,73 @@
+## .gitignore strategy
+#
+# Only keep ren-c project specific file exclusions in .gitignore
+#
+# For files created by...
+#
+# * Editors (for eg. Vim, Eclipse, etc)
+# * Machines (Windows, Linux, OSX, etc)
+# * or any artifacts of your development environment
+#
+# then please keep these exclusions in a global .gitignore file which
+# should not be commited into the ren-c repo.
+#
+# For more info please see "Create a global .gitignore" at:
+#
+# https://help.github.com/articles/ignoring-files/
+#
+# Our recommended advice is to use a .gitignore_global file described
+# in link.
+#
+# Here is an example .gitignore_global used on OS X (Mac):
+#
+# ## Mac stuff
+# .DS_Store
+#
+# ## Vim stuff
+# *.un~
+# *.swp
+#
+# This is kept in the users home directory: ~/.gitignore_global
+#
+
+
#################
## REBOL R3
#################
+make/makefile
make/r3*
make/objs/
+
+# It can be convenient if you are doing multiple builds of the same Rebol
+# codebase for different platforms to put them in separate make
+# directories (such as make-win32 or make-osx-x64) so they don't erase
+# each other's state
+#
+make-*
+!tests/**/make-*
+
+# While some generated files are intended to be semi-persistent products
+# (e.g. an API file), many generated files are temporary and not meant to be
+# the concern of users. Over time, these have been standardized to start
+# with "tmp-". Ignore any such file in any directory.
+#
+tmp-*
+
src/boot/boot-code.r
src/boot/host-init.r
+
src/core/b-boot.c
-src/include/ext-types.h
-src/include/host-*
+
+src/include/host-ext-*
+src/include/host-init.h
+src/include/host-lib.h
+src/include/host-table.inc
src/include/reb-dialect.h
src/include/reb-evtypes.h
src/include/reb-lib-lib.h
src/include/reb-lib.h
src/include/reb-types.h
-src/include/tmp-*
-src/tools/reb-lib-doc.txt
-src/reb-lib-doc.txt
#################
## Eclipse
@@ -178,6 +229,3 @@ pip-log.txt
#Mr Developer
.mr.developer.cfg
-
-# Mac crap
-.DS_Store
diff --git a/.gitmodules b/.gitmodules
new file mode 100644
index 0000000000..d37f2f8b07
--- /dev/null
+++ b/.gitmodules
@@ -0,0 +1,6 @@
+[submodule "external/libffi"]
+ path = external/libffi
+ url = git://github.com/metaeducation/libffi.git
+[submodule "external/tcc"]
+ path = external/tcc
+ url = git://github.com/metaeducation/tcc.git
diff --git a/.travis.yml b/.travis.yml
new file mode 100644
index 0000000000..f7ab51b6ff
--- /dev/null
+++ b/.travis.yml
@@ -0,0 +1,452 @@
+#
+# .travis.yaml contains YAML-formatted (http://www.yaml.org/) build
+# instructions for continuous integration via Travis CI
+# (http://docs.travis-ci.com/).
+#
+
+
+notifications:
+ email: false
+
+
+language: c
+
+
+matrix:
+ include:
+ # OSX x64, debug, g++
+ #
+ # !!! Can't do all warnings as errors, because the switch for
+ # files that end in .c as c++ ("-x c++") is deprecated for some overly
+ # prescriptive and annoying reason.
+ #
+ - os: osx
+ osx_image: xcode8.2
+ language: cpp
+ env: OS_ID=0.2.40 DEBUG=asserts STANDARD=c++14 RIGOROUS=no STATIC=no FFI="dynamic"
+
+ # OSX x64, debug, gcc
+ #
+ # TCC currently doesn't quite support OSX yet
+ #
+ # !!! Also, does not honor GCC's static linking flag for libc.
+ #
+ - os: osx
+ osx_image: xcode8.2
+ language: c
+ env: OS_ID=0.2.40 DEBUG=asserts STANDARD=c99 RIGOROUS=no STATIC=no FFI="dynamic"
+
+ # OSX x64, release, gcc
+ #
+ # !!! Again, does not honor static linking switch.
+ #
+ - os: osx
+ language: c
+ env: OS_ID=0.2.40 DEBUG=none STANDARD=c RIGOROUS=no STATIC=no FFI="dynamic"
+
+ # Linux x86, release, gcc
+ #
+ - os: linux
+ sudo: false #Force new container-based infrastructure.
+ language: c
+ env: OS_ID=0.4.4 DEBUG=none STANDARD=gnu89 RIGOROUS=yes STATIC=yes TCC=i386-tcc ARCH_CFLAGS=-m32 FFI="dynamic"
+
+ # Linux x64, debug, g++
+ #
+ # !!! Note this binary does not support c++11 completely, it's an old
+ # gcc 4.6
+ #
+ - os: linux
+ dist: trusty #gcc on Ubuntu 12.04 does not support sanitizers
+ sudo: false #Force new container-based infrastructure.
+ language: cpp
+ env: OS_ID=0.4.40 DEBUG=asserts STANDARD=c++0x RIGOROUS=yes STATIC=yes TCC=tcc FFI="dynamic"
+
+ # Linux x64, release, gcc
+ #
+ - os: linux
+ sudo: false #Force new container-based infrastructure.
+ language: c
+ env: OS_ID=0.4.40 DEBUG=none STANDARD=gnu99 RIGOROUS=yes STATIC=yes TCC=tcc FFI="dynamic"
+
+ # Windows x86, release, gcc
+ #
+ - os: linux
+ sudo: false #Force new container-based infrastructure.
+ language: c
+ env: OS_ID=0.3.1 DEBUG=none TOOLS=i686-w64-mingw32- STANDARD=c RIGOROUS=yes STATIC=yes TCC=i386-win32-tcc TCC_CPP_EXTRA_FLAGS='-I../external/tcc/win32/include -DPVAR=TVAR -DTVAR="extern __attribute__((dllimport))"' HOST=i686-w64-mingw32 ARCH_CFLAGS=-m32 FFI="dynamic"
+
+ # Windows x64, debug, gcc
+ #
+ - os: linux
+ sudo: false #Force new container-based infrastructure.
+ language: c
+ env: OS_ID=0.3.40 DEBUG=asserts TOOLS=x86_64-w64-mingw32- STANDARD=c RIGOROUS=yes STATIC=yes TCC=x86_64-win32-tcc TCC_CPP_EXTRA_FLAGS='-I../external/tcc/win32/include -DPVAR=TVAR -DTVAR="extern __attribute__((dllimport))"' HOST=x86_64-w64-mingw32 FFI="dynamic"
+
+ # Windows x64, debug, g++
+ #
+ # !!! Note this binary does not support c++11 or above
+ #
+ - os: linux
+ sudo: false #Force new container-based infrastructure.
+ language: cpp
+ env: OS_ID=0.3.40 DEBUG=asserts TOOLS=x86_64-w64-mingw32- STANDARD=c++ RIGOROUS=yes STATIC=yes TCC=x86_64-win32-tcc TCC_CPP_EXTRA_FLAGS='-I../external/tcc/win32/include -DPVAR=TVAR -DTVAR="extern __attribute__((dllimport))"' HOST=x86_64-w64-mingw32 FFI="dynamic"
+
+ # Android5, debug, gcc
+ #
+ - os: linux
+ dist: trusty #gcc on Ubuntu 12.04 does not support sanitizers
+ sudo: false #Force new container-based infrastructure.
+ language: c
+ env: OS_ID=0.13.2 DEBUG=asserts STANDARD=c RIGOROUS=yes STATIC=yes HOST=arm-eabi FFI="no"
+
+ # Android5, release, gcc
+ #
+ - os: linux
+ dist: trusty #gcc on Ubuntu 12.04 does not support sanitizers
+ sudo: false #Force new container-based infrastructure.
+ language: c
+ env: OS_ID=0.13.2 DEBUG=none STANDARD=c RIGOROUS=yes STATIC=yes HOST=arm-eabi FFI="no"
+
+env:
+ global:
+ #
+ # travis encrypt AWS_ACCESS_KEY_ID=$AWS_ACCESS_KEY_ID
+ #
+ - secure: "Bex3tqrlsnv+t3+AJu6nG8bcbfHXeBNWIUUdcEeyB8gWnWnVuBsC5hTw9cUhEWJchJSsV4LeWVL51harzOQRntszyfjeNvPQozCXbTQVGd1tn5Rpt1QKN9VBK007c+ERj9L8JzFkM2HdeVusYY4Bz5tI883DSJkydyJpJp21mG9i8a17bqJsgBW0JmMsMsdv1ilaeb8/Luo8bn0ObIWTTz+4/6RF4XU9UcWLH7I4HlGb3qufR9chWCX7jTT0SLRkEgfudr+KVrY4xIspiPlVwrKvagnOTFcYLxN4JpGOgn1rnCcOxsWo4kE4dwgXZvEn8W2HJmJhzhAHDLkF0S7YhIDQaScJLwSVECI9xu68V5siWdyhzyrSb2K7V8Mtzryjzq1QueCrRRTj7XLY7sx5OxeP//RVMY0Poil5DdB84nI1wezzmT1kj7dkc1Fr1ZqdYSEfCZNd1v+DeRmAf/N70xUyx1tSxAHD96kjDM3lGILIrlt9RLWdeT0BqxQxzaKCowPVgfztH0nzPcoe1DfNfIhG9mEdjeJfLC7hAgc9Dn0KTo/oSwX/TBsTavV+6SPxH1D4q1xVdY9p4G2hS/N1xaqf7ys4DQOPwWZwvhujwGtto4fy7VMvDtX7jI6++0dJe+baG0DetlHvUGKzWpBJgk02k3mREH+9Ui8f7T9vn8Y="
+
+ # travis encrypt AWS_SECRET_ACCESS_KEY=$AWS_SECRET_ACCESS_KEY
+ #
+ - secure: "IlBRG9mRM0BDtb9ZJDKl4QVRjs/e3KxvjEdVS9e8+PlGq+xMDVGQdje9WOED/bhTcoAYabhLKkXY8YZg6rlVj4ecyjjmZRfPA4D9YVMVHZVNldLX9Ed79Kv95dTvFdn6xl9Tbk/CEqtxfDwcN2hZqv9M3TXN2+sKzny6p4ENc8O7sz0Stb4GyFgPdWSIs4SZv/r8/feMgWiUx+q1NFFarMmFsLtKVuiPIyoU6fGW1zZPyh10jKuhi9GYBStcMHIWqvU+9+jbqchMJT1t/1fyEf0fJokNMH2KXCVDbsu7nKhaVZbIxirLdZNicKfzype1uRgzAB/Crpup+TwnINd17HPSqjCnqntuS+pO0mIRcXVhNSE8TG9S8x4N0pgtKYHKyfAjElmjLwPfoMhu5VlZishn6heeUALbQ7y44YwWwG8EoW4PnRFIGg7V4EjlHJkcmDhJWrZX2hVvSGJ72lFhHXFMcr+VKhXWlmK97XdFAz/c/LlSyyrmKtIE6W5kwhJC8bbrpETA/wQ9pP3WEVY28bka24LqI1g0hiDn7cyXae7Ikss36Y8eB/9/00EovCPHw1o+dyenXI10Q8+yorQ42xrjo1bXuYRohCvI+FmV4XFLkJ+c6wDTSKhJTcUhZsQva2F0ipeyqhGQQGkLiZ8BvdoSPHHBx2odikgho9VQZ48="
+
+ - AWS_S3_BUCKET_NAME: "metaeducation"
+
+
+addons:
+ apt:
+ packages:
+ #
+ # For building 32b binaries on a 64b host (not necessary when we
+ # build for 64b):
+ #
+ - gcc-multilib
+ - g++-multilib
+
+ # For cross-compiling to Windows.
+ #
+ - binutils-mingw-w64-i686
+ - binutils-mingw-w64-x86-64
+ - gcc-mingw-w64-i686
+ - gcc-mingw-w64-x86-64
+ - g++-mingw-w64-i686
+ - g++-mingw-w64-x86-64
+ - mingw-w64
+
+ # for makeinfo, required to build FFI
+ - texinfo
+
+
+install:
+ #
+ # Fetch a Rebol bootstrap binary, which is needed for building Rebol.
+ # Travis uses the last r3-alpha that was ever published on rebol.com
+ # in order to ensure that still works.
+ #
+ - if [[ "$TRAVIS_OS_NAME" == "linux" ]]; then export REBOL_TOOL=r3-linux-x64-gbf237fc-static ; fi
+ - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then export REBOL_TOOL=r3-osx-x64-gbf237fc ; fi
+
+script:
+ # Nice to know what version of gcc this is
+ - ${TOOLS}gcc --version
+ - if [[ "$TRAVIS_OS_NAME" == "linux" ]]; then export MAKE_JOBS=`nproc`; fi
+ - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then export MAKE_JOBS=`sysctl -n hw.ncpu`; fi
+
+ - TOP_DIR=${PWD}
+ - |
+ if [[ ${OS_ID} = "0.13.2" || ${OS_ID} = "0.13.1" ]]; then
+ if [ `uname -m` = x86_64 ]; then wget https://github.com/giuliolunati/android-travis/releases/download/v1.0.0/android-ndk-r13.tgz; ANDROID_NDK=$TOP_DIR/android-ndk-r13; else exit 1; fi
+ tar zxf android-ndk-r13.tgz
+ echo $PWD
+ ls -dl $PWD/android-ndk-r13
+ export TOOLS=$ANDROID_NDK/toolchains/arm-linux-androideabi-4.9/prebuilt/linux-x86_64/bin/arm-linux-androideabi-
+ export EXTRA_CC_FLAGS="--sysroot=$ANDROID_NDK/platforms/android-19/arch-arm"
+ fi
+ if [[ ${OS_ID} = "0.3.40" || ${OS_ID} = "0.3.1" ]]; then
+ # Use prebuilt binaries
+ if [[ ${OS_ID} = "0.3.40" ]]; then
+ export PKG_CONFIG_PATH=${TOP_DIR}/external/ffi-prebuilt/lib64/pkgconfig
+ else
+ export PKG_CONFIG_PATH=${TOP_DIR}/external/ffi-prebuilt/lib32/pkgconfig
+ fi
+ # --define-prefix would be better, but it is not recognized
+ export PKGCONFIG="pkg-config --define-variable=prefix=${TOP_DIR}/external/ffi-prebuilt"
+ # check cflags and libs
+ ${PKGCONFIG} --cflags libffi
+ ${PKGCONFIG} --libs libffi
+ elif [[ -z ${FFI} || ${FFI} != "no" ]]; then
+ # Build libffi
+ mkdir build
+ cd external/libffi
+ ./autogen.sh
+ cd ${TOP_DIR}/build
+ if [[ -z ${HOST} ]]; then
+ ${TOP_DIR}/external/libffi/configure --prefix=$PWD/fakeroot CFLAGS=${ARCH_CFLAGS}
+ else #cross-compiling
+ ${TOP_DIR}/external/libffi/configure --prefix=$PWD/fakeroot --host=${HOST}
+ fi
+ make -j ${MAKE_JOBS}
+ make install
+ export PKG_CONFIG_PATH=$PWD/fakeroot/lib/pkgconfig
+ # check cflags and libs
+ pkg-config --cflags libffi
+ pkg-config --libs libffi
+
+ ls `pkg-config --variable=toolexeclibdir libffi`
+ #remove dynamic libraries to force it to link with static libraries
+ rm -f `pkg-config --variable=toolexeclibdir libffi`/*.so*
+ rm -f `pkg-config --variable=toolexeclibdir libffi`/*.dylib*
+ rm -f `pkg-config --variable=toolexeclibdir libffi`/*.dll*
+ ls `pkg-config --variable=toolexeclibdir libffi`
+ fi
+
+ - cd ${TOP_DIR}/make/
+
+ # Build TCC
+ - |
+ if [[ ! -z ${TCC} ]]; then
+ mkdir tcc
+ cd tcc
+ if [[ ${OS_ID} != "0.4.40" ]]; then
+ #generate cross-compiler (on x86_64 host and target for i386)
+ echo "Generating the cross-compiler"
+ ${TOP_DIR}/external/tcc/configure --enable-cross --extra-cflags="-DEMBEDDED_IN_R3"
+ make -j ${MAKE_JOBS}
+ mkdir bin
+ cp *tcc bin #save cross-compilers
+ ls bin/ #take a look at the cross-compilers
+ make clean
+ #generate libtcc.a
+ # libtcc.a requires --enable-mingw32, or it doesn't think it's a native compiler and disables tcc_run
+ echo "Generating libtcc.a"
+ if [[ ${OS_ID} = "0.4.4" ]]; then
+ ${TOP_DIR}/external/tcc/configure --cpu=x86 --extra-cflags="-DEMBEDDED_IN_R3 ${ARCH_CFLAGS}"
+ elif [[ ${OS_ID} == "0.3.1" ]]; then #x86-win32
+ ${TOP_DIR}/external/tcc/configure --cpu=x86 --extra-cflags="-DEMBEDDED_IN_R3" --enable-mingw32 --cross-prefix=${TOOLS}
+ else #x86_64-win32
+ ${TOP_DIR}/external/tcc/configure --enable-mingw32 --cpu=x86_64 --extra-cflags="-DEMBEDDED_IN_R3" --cross-prefix=${TOOLS}
+ fi
+ make libtcc.a && cp libtcc.a libtcc.a.bak
+
+ #generate libtcc1.a
+ # --enable-mingw32 must be turned off, or it will try to compile with tcc.exe
+ make clean
+
+ echo "Generating libtcc1.a"
+ if [[ ${OS_ID} = "0.4.4" ]]; then
+ ${TOP_DIR}/external/tcc/configure --cpu=x86 --extra-cflags="-DEMBEDDED_IN_R3 ${ARCH_CFLAGS}"
+ elif [[ ${OS_ID} == "0.3.1" ]]; then #x86-win32
+ ${TOP_DIR}/external/tcc/configure --cpu=x86 --extra-cflags="-DEMBEDDED_IN_R3" --cross-prefix=${TOOLS}
+ else #x86_64-win32
+ ${TOP_DIR}/external/tcc/configure --cpu=x86_64 --extra-cflags="-DEMBEDDED_IN_R3" --cross-prefix=${TOOLS}
+ fi
+
+ echo "make libtcc1.a"
+ make libtcc1.a XCC=${TOOLS}gcc XAR=${TOOLS}ar || echo "ignoring error in building libtcc1.a" #this could fail to build tcc due to lack of '-ldl' on Windows
+ cp bin/* . #restore cross-compilers, libtcc1.a depends on tcc
+ touch tcc #update the timestamp so it won't be rebuilt
+ echo "ls"
+ ls #take a look at files under current directory
+ echo "make libtcc1.a"
+ make libtcc1.a XCC=${TOOLS}gcc XAR=${TOOLS}ar
+
+ echo "Looking for symbol r3_tcc_alloca"
+ if [[ ${OS_ID} == "0.3.1" ]]; then #x86-win32
+ ${TOOLS}objdump -t lib/i386/alloca86.o |grep alloca
+ elif [[ ${OS_ID} == "0.3.40" ]]; then
+ ${TOOLS}objdump -t lib/x86_64/alloca86_64.o |grep alloca
+ fi
+
+ #restore libtcc.a
+ # make libtcc1.a could have generated a new libtcc.a
+ cp libtcc.a.bak libtcc.a
+ else
+ ${TOP_DIR}/external/tcc/configure --extra-cflags="-DEMBEDDED_IN_R3 ${ARCH_CFLAGS}"
+ fi
+ make
+ cd ${TOP_DIR}/make
+ fi
+
+ # Grab the abbreviated and full git commit ID into environment variables.
+ # The full commit is passed to make to build into the binary, and the
+ # abbreviated commit is used to name the executable.
+ #
+ # http://stackoverflow.com/a/42549385/211160
+ #
+ - GIT_COMMIT="$(git show --format="%H" --no-patch)"
+ - echo ${GIT_COMMIT}
+ - GIT_COMMIT_SHORT="$(git show --format="%h" --no-patch)"
+ - echo ${GIT_COMMIT_SHORT}
+
+ # Take a look at assert.h
+ # - find /usr/include -name assert.h | xargs cat
+
+ # We have to set REBOL_TOOL explicitly to circumvent the automatic r3-make
+ # filename inference, as we always use Linux "r3-make" (not "r3-make.exe")
+ # even when doing windows builds, since this is a cross-compilation.
+ #
+ # As an extra step to test bootstrap ability, we make the 64-bit debug
+ # build go even further by doing another full build, but using the
+ # just built r3 as its own r3-make.
+ #
+ - |
+ if [[ ("${OS_ID}" = "0.4.40" || "${OS_ID}" = "0.2.40") && "${DEBUG}" != "none" ]]; then
+ #
+ # If building twice, don't specify GIT_COMMIT for the first build.
+ # This means there's a test of the build process when one is not
+ # specified, in case something is broken about that. (This is how
+ # most people will build locally, so good to test it.)
+ #
+ # Also request address sanitizer to be used for the first build. It
+ # is very heavyweight and makes the executable *huge* and slow, so
+ # we do not apply it to any of the binaries which are uploaded to s3
+ # -- not even debug ones.
+ #
+ make -f makefile.boot NUM_JOBS=${MAKE_JOBS} REBOL_TOOL=${REBOL_TOOL} STANDARD="${STANDARD}" OS_ID="${OS_ID}" RIGOROUS="${RIGOROUS}" DEBUG=sanitize OPTIMIZE=2 STATIC=no
+
+ rm r3-make;
+ mv r3 r3-make;
+ make clean;
+ export R3_ALWAYS_MALLOC=1
+ export REBOL_TOOL=r3-make
+ fi
+
+ # On the second build of building twice, or just building once, include
+ # the GIT_COMMIT
+ #
+ - |
+ if [[ -z ${TCC} ]]; then
+ make -f makefile.boot NUM_JOBS=${MAKE_JOBS} REBOL_TOOL=${REBOL_TOOL} STANDARD="${STANDARD}" OS_ID="${OS_ID}" DEBUG="${DEBUG}" GIT_COMMIT="${GIT_COMMIT}" RIGOROUS="${RIGOROUS}" STATIC="${STATIC}" WITH_FFI=${FFI} WITH_TCC="no"
+ else
+ make -f makefile.boot NUM_JOBS=${MAKE_JOBS} REBOL_TOOL=${REBOL_TOOL} STANDARD="${STANDARD}" OS_ID="${OS_ID}" DEBUG="${DEBUG}" GIT_COMMIT="${GIT_COMMIT}" RIGOROUS="${RIGOROUS}" STATIC="${STATIC}" WITH_FFI=${FFI} WITH_TCC="${PWD}/tcc/${TCC}"
+ fi
+
+ # take a look at the preprocess header file
+ # - cat ../src/include/sys-core.i || true
+
+ # output the needed libraries
+ - |
+ if [[ "${OS_ID}" = "0.4.40" || "${OS_ID}" = "0.4.4" ]]; then
+ ldd ./r3
+ elif [[ "${OS_ID}" = "0.2.40" ]]; then
+ otool -L ./r3
+ fi
+
+ # Run once but don't pipe output, in case it prints out useful crash msg
+ # that we want to see in the Travis log (especially helpful for failures
+ # only happening in the Travis builds that aren't reproducing locally)
+ # Save the exit code ($?) so we can return it to Travis as last step
+ #
+ # !!! This is a very minimal sanity check to ensure the built R3 does
+ # *something*, and it can obviously only be used on the linux version.
+ # Running the full test suite would be a bit much, and developers are
+ # expected to have already done that. But doing an HTTPS read exercises
+ # a fair amount of code.
+ #
+ - |
+ if [[ "${OS_ID}" = "0.4.40" || "${OS_ID}" = "0.4.4" || "${OS_ID}" = "0.2.40" ]]; then
+ ./r3 --do "print {Testing...} quit/with either find to-string read https://example.com {Example Domain
} [0] [1]";
+ R3_EXIT_STATUS=$?;
+ else
+ R3_EXIT_STATUS=0;
+ fi
+ - echo ${R3_EXIT_STATUS}
+
+ # Run basic testing with FFI, this is a linux-only script
+ - |
+ if [[ "${OS_ID}" = "0.4.40" || "${OS_ID}" = "0.4.4" ]]; then
+ ./r3 ../tests/misc/qsort_r.r
+ R3_EXIT_STATUS=$?;
+ else
+ R3_EXIT_STATUS=0;
+ fi
+ - echo ${R3_EXIT_STATUS}
+
+ # Run basic testing with user natives
+ - |
+ if [[ ! -z "$TCC" && "$TCC" != "no" && ( "${OS_ID}" = "0.4.40" || "${OS_ID}" = "0.4.4" ) ]]; then
+ ./r3 ../tests/misc/fib.r
+ R3_EXIT_STATUS=$?;
+ else
+ R3_EXIT_STATUS=0;
+ fi
+ - echo ${R3_EXIT_STATUS}
+
+ # Clean Android elf executable
+ - |
+ if [[ ${OS_ID} = "0.13.2" || ${OS_ID} = "0.13.1" ]]; then
+ $ANDROID_NDK/android-elf-cleaner r3
+ fi
+
+ # Delete the obj file directory so we don't upload those to S3
+ #
+ - rm -rf objs
+
+ - rm -f makefile*
+ - rm -f Toolchain*
+ - rm -f r3-make* #-f makes retval a success even when r3-make* doesn't exist
+ - rm r3-linux-x64-gbf237fc-static
+ - rm r3-osx-x64-gbf237fc
+ - rm -f CMakeLists.txt
+ - rm -rf tcc
+
+ # Name the executable based on the abbreviated commit, whether it is a
+ # debug or release build, and if it was built using C++ or not. Note that
+ # the C++ debug builds have additional runtime checks in the debug
+ # build...though there should not be any impact on the release build.
+ # (Though there may be additional DLL dependencies regardless.)
+ #
+ # !!! All Ren-C stakeholders should be using debug builds at this time.
+ #
+ # Note: -z tests if a variable is undefined
+ #
+ - NEW_NAME=${OS_ID}/r3-${GIT_COMMIT_SHORT}
+ - if [[ "${DEBUG}" != "none" ]]; then NEW_NAME+="-debug"; fi
+ - |
+ if [[ "${STANDARD}" = "c++" || "${STANDARD}" = "c++0x" || "${STANDARD}" = "c++11" || "${STANDARD}" = "c++14" || "${STANDARD}" = "c++17" ]]; then
+ NEW_NAME+="-cpp";
+ fi
+ - echo ${NEW_NAME}
+
+ # Move the executable into a directory based on its OS_ID platform.
+ # This is because the deploy step is run for each OS and would
+ # otherwise overwrite executables in the same location.
+ #
+ - mkdir ${OS_ID}
+ - |
+ if [[ -e "r3.exe" ]]; then
+ mv r3.exe ${NEW_NAME}.exe;
+ else
+ mv r3 ${NEW_NAME};
+ fi
+
+ # Return whether the build succeeded or not to Travis. If this succeeded
+ # then the deploy step to S3 will run
+ #
+ # http://stackoverflow.com/a/10457902/211160
+ #
+ - (exit ${R3_EXIT_STATUS})
+
+
+# After everything is finished (e.g. script section above), upload build
+# product to Amazon S3. For how the configuration works and manages to keep
+# the private key secure, see:
+#
+# http://stackoverflow.com/a/42547424/211160
+#
+deploy:
+ provider: s3
+ access_key_id: $AWS_ACCESS_KEY_ID
+ secret_access_key: $AWS_SECRET_ACCESS_KEY
+ bucket: $AWS_S3_BUCKET_NAME
+ skip_cleanup: true
+ upload-dir: travis-builds
diff --git a/.travis.yml.tcc b/.travis.yml.tcc
new file mode 100644
index 0000000000..5304020cb5
--- /dev/null
+++ b/.travis.yml.tcc
@@ -0,0 +1,156 @@
+#
+# .travis.yaml contains YAML-formatted (http://www.yaml.org/) build
+# instructions for continuous integration via Travis CI
+# (http://docs.travis-ci.com/).
+#
+
+notifications:
+ email: false
+
+language: c
+
+matrix:
+ include:
+ # Linux x86, release
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.4.4 BUILD_TYPE=RELEASE R3_CPP=0 CFLAGS=-m32 CXXFLAGS=-m32 EXTRA_CMAKE_ARGS="-DCMAKE_ASM_FLAGS=-m32"
+
+ # Linux x86, debug
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.4.4 BUILD_TYPE=DEBUG R3_CPP=0 CFLAGS=-m32 CXXFLAGS=-m32 EXTRA_CMAKE_ARGS="-DCMAKE_ASM_FLAGS=-m32"
+
+ # Linux x86, debug, build with CPP
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.4.4 BUILD_TYPE=DEBUG R3_CPP=1 CFLAGS=-m32 CXXFLAGS=-m32 EXTRA_CMAKE_ARGS="-DCMAKE_ASM_FLAGS=-m32"
+
+ # Linux x64, debug
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.4.40 BUILD_TYPE=DEBUG R3_CPP=0
+
+ # Linux x64, debug, build with CPP
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.4.40 BUILD_TYPE=DEBUG R3_CPP=1
+
+ # Linux x64, release
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.4.40 BUILD_TYPE=RELEASE R3_CPP=0
+
+ # Windows x86, release
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.3.1 EXE_SUFFIX=.exe BUILD_TYPE=RELEASE R3_CPP=0 EXTRA_CMAKE_ARGS="-DCMAKE_TOOLCHAIN_FILE=Toolchain-cross-mingw32-linux.cmake"
+ # Windows x86, debug
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.3.1 EXE_SUFFIX=.exe BUILD_TYPE=DEBUG R3_CPP=0 EXTRA_CMAKE_ARGS="-DCMAKE_TOOLCHAIN_FILE=Toolchain-cross-mingw32-linux.cmake"
+ # Windows x86, debug, CPP
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.3.1 EXE_SUFFIX=.exe BUILD_TYPE=DEBUG R3_CPP=1 EXTRA_CMAKE_ARGS="-DCMAKE_TOOLCHAIN_FILE=Toolchain-cross-mingw32-linux.cmake"
+ # Windows x64, release
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.3.40 EXE_SUFFIX=.exe BUILD_TYPE=RELEASE R3_CPP=0 EXTRA_CMAKE_ARGS="-DCMAKE_TOOLCHAIN_FILE=Toolchain-cross-mingw64-linux.cmake"
+ # Windows x64, debug
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.3.40 EXE_SUFFIX=.exe BUILD_TYPE=DEBUG R3_CPP=0 EXTRA_CMAKE_ARGS="-DCMAKE_TOOLCHAIN_FILE=Toolchain-cross-mingw64-linux.cmake"
+ # Windows x64, debug, CPP
+ - os: linux
+ sudo: required
+ dist: trusty
+ env: OS_ID=0.3.40 EXE_SUFFIX=.exe BUILD_TYPE=DEBUG R3_CPP=1 EXTRA_CMAKE_ARGS="-DCMAKE_TOOLCHAIN_FILE=Toolchain-cross-mingw64-linux.cmake"
+ # OSX x86
+ - os: osx
+ osx_image: xcode8
+ env: OS_ID=0.2.5 BUILD_TYPE=RELEASE R3_CPP=0 EXTRA_CMAKE_ARGS="-DCMAKE_OSX_ARCHITECTURES=i386 -DCMAKE_ASM_FLAGS=\"-arch i386\""
+ - os: osx
+ osx_image: xcode8
+ env: OS_ID=0.2.5 BUILD_TYPE=DEBUG R3_CPP=0 EXTRA_CMAKE_ARGS="-DCMAKE_OSX_ARCHITECTURES=i386 -DCMAKE_ASM_FLAGS=\"-arch i386\""
+ - os: osx
+ osx_image: xcode8
+ env: OS_ID=0.2.5 BUILD_TYPE=DEBUG R3_CPP=1 EXTRA_CMAKE_ARGS="-DCMAKE_OSX_ARCHITECTURES=i386 -DCMAKE_ASM_FLAGS=\"-arch i386\""
+ # OSX x64
+ - os: osx
+ osx_image: xcode8
+ env: OS_ID=0.2.40 BUILD_TYPE=RELEASE R3_CPP=0
+ - os: osx
+ osx_image: xcode8
+ env: OS_ID=0.2.40 BUILD_TYPE=DEBUG R3_CPP=0
+ - os: osx
+ osx_image: xcode8
+ env: OS_ID=0.2.40 BUILD_TYPE=DEBUG R3_CPP=1
+
+addons:
+ apt:
+ packages:
+ # For building 32b binaries on a 64b host (not necessary when we
+ # build for 64b):
+ - gcc-multilib
+ - g++-multilib
+
+ # For cross-compiling to Windows.
+ - binutils-mingw-w64-i686
+ - binutils-mingw-w64-x86-64
+ - gcc-mingw-w64-i686
+ - gcc-mingw-w64-x86-64
+ - g++-mingw-w64-i686
+ - g++-mingw-w64-x86-64
+ - mingw-w64
+
+install:
+ # Fetch a Rebol bootstrap binary, which is needed for building Rebol.
+ #- wget http://www.rebol.com/r3/downloads/r3-a111-4-2.tar.gz
+ #- tar xvzf r3-a111-4-2.tar.gz
+ - if [[ "$TRAVIS_OS_NAME" == "linux" ]]; then wget http://www.rebolsource.net/downloads/experimental/r3-linux-x64-gbf237fc-static && cp r3-linux-x64-gbf237fc-static make/r3-make; fi
+ - if [[ "$TRAVIS_OS_NAME" == "osx" ]]; then wget http://rebolsource.net/downloads/experimental/r3-osx-x64-gbf237fc && cp r3-osx-x64-gbf237fc make/r3-make; fi
+ - chmod +x make/r3-make
+
+script:
+ - cd make/
+ #compile tcc as a cross-compiler
+ - if [ "${OS_ID}" = "0.3.1" ]; then mkdir tcc-build && cd tcc-build && cmake -DTCC_BUILD_WIN32=1 -G "Unix Makefiles" ../../external/tcc && make i386-w64-mingw32-tcc i386-w64-mingw32-libtcc1 VERBOSE=1 && cp i386-w64-mingw32-tcc ../cross-tcc && cp i386-w64-mingw32-libtcc1.a ../cross-libtcc1.a && cd .. && rm -fr tcc-build; fi
+ - if [ "${OS_ID}" = "0.3.40" ]; then mkdir tcc-build && cd tcc-build && cmake -DTCC_BUILD_WIN64=1 -G "Unix Makefiles" ../../external/tcc && make x86_64-w64-mingw32-tcc x86_64-w64-mingw32-libtcc1 VERBOSE=1 && cp x86_64-w64-mingw32-tcc ../cross-tcc && cp x86_64-w64-mingw32-libtcc1.a ../cross-libtcc1.a && cd .. && rm -fr tcc-build; fi
+ - cmake -DR3_OS_ID="${OS_ID}" -DR3_EXTERNAL_FFI=0 -DR3_CPP="${R3_CPP}" -DCMAKE_BUILD_TYPE="${BUILD_TYPE}" -DR3_WITH_TCC=1 -G "Unix Makefiles" "${EXTRA_CMAKE_ARGS}"
+ - make r3-core VERBOSE=1
+ # A minimal sanity check that the built R3 does _something_. Eventually, we
+ # should run the full test suite.
+
+ # Run once but don't pipe output, in case it prints out useful crash msg
+ - if [ "${OS_ID}" = "0.4.40" ]; then ./r3-core --do 'print {OK}'; fi
+
+ # Run a second time with piped output to return success/faiure to Travis
+ - if [ "${OS_ID}" = "0.4.40" ]; then ./r3-core --do 'print {OK}' | grep OK; fi
+
+ # overwriting libtcc1.a with the cross-compiled version
+ - if [ "${OS_ID}" = "0.3.1" -o "${OS_ID}" = "0.3.40" ]; then cp cross-libtcc1.a tcc/libtcc1.a; fi
+
+ # Rename files before uploading
+ - zip r3-core-${OS_ID}-${TRAVIS_COMMIT}-${BUILD_TYPE}-CPP${R3_CPP}.zip r3-core${EXE_SUFFIX} tcc/libtcc1.a
+
+deploy:
+ provider: releases
+ api_key:
+ secure: V6a5VzBv+ut3hKZKMmnuY4Urzc4QA/EBcfarve837q+7p9QgDseiuW93yUVys7LacIl8D6y13m71QBxzG6LC9WnttNgfy+PfyrMbWfaMvg9zLQQ1jTGKWjW6Fn4/xyU0NYyrjvgxW2itQ4/r9r0lcmKHbsAcm/ZhvLzg4o3dnc0=
+ file:
+ - r3-core-${OS_ID}-${TRAVIS_COMMIT}-${BUILD_TYPE}-CPP${R3_CPP}.zip
+ skip_cleanup: true #or, Travis CI deletes all the files created during the build
+ on:
+ tags: true
diff --git a/CHANGES.md b/CHANGES.md
new file mode 100644
index 0000000000..795791deaf
--- /dev/null
+++ b/CHANGES.md
@@ -0,0 +1,25 @@
+# Rebol 3 (Ren/C branch) Changes
+
+All notable changes to this project will be documented in this file.
+
+Alternate ChangeLogs:
+
+* [ChangeLog + pre-built binaries](https://forum.rebol.info/t/rebol3-ren-c-branch-change-logs/54/10000)
+* [Complete Github commits](https://github.com/metaeducation/ren-c/commits/master)
+
+Alternatively using Git:
+
+ git log
+
+
+Below is a stub for summary of changes by version.
+
+## 2.102.0
+### Added
+- Ren/C branch by @hostfilefork
+
+### Changed
+### Fixed
+
+
+## R3-Alpha
diff --git a/CREDITS.md b/CREDITS.md
new file mode 100644
index 0000000000..73642171b8
--- /dev/null
+++ b/CREDITS.md
@@ -0,0 +1,165 @@
+> This file's intent is to centralize credit to organizations, individuals,
+> and to code + libraries + tools used. For all new source contributions
+> please give copyright attribution to "Rebol Open Source Contributors".
+> Include any new credits in pull requests as a modification to this file.
+>
+> **NOTE** The project has also benefited from significant supporting work
+> outside this code repository by members of the community--too numerous to
+> list here!
+
+
+CREDITS
+=======
+
+Originators of REBOL
+--------------------
+
+Carl Sassenrath, Rebol Technologies
+* http://www.rebol.com
+* [@carls](https://github.com/carls) on GitHub
+
+_REBOL is a trademark of REBOL Technologies_
+
+Rebol 3 Alpha was [released to the open source community][1] under an Apache 2
+license on 12-Dec-2012:
+
+[1]: http://www.rebol.com/cgi-bin/blog.r?view=0519#comments
+
+
+Code Contributors
+-----------------
+
+Contributors to this project are encouraged to add/edit entries here, with a
+one-line summary and a link to a landing webpage of their choice:
+
+**Andreas Bolka**
+- [@earl](https://github.com/earl) on GitHub
+- http://rebolsource.net
+- 64-bit and other porting, build farm, core design, core patches, test suite...
+
+**Brian Dickens**
+- [@hostilefork](https://github.com/hostilefork) on GitHub
+- http://hostilefork.com
+- "Ren-C" branch founder, core evaluator rethinking and design...
+
+**Brett Handley**
+- [@codebybrett](https://github.com/codebybrett) on GitHub
+- http://codeconscious.com
+- Libraries to parse and process Rebol's C code using Rebol, file conversions.
+
+**Brian Hawley**
+- [@BrianHawley](https://github.com/brianh) on GitHub
+- Mezzanine design and module system, core patches, PARSE design for Rebol3.
+
+**Giulio Lunati**
+- [@giuliolunati](https://github.com/giuliolunati) on GitHub
+- MAP! and hashing updates, Android builds, source serialization improvements.
+
+**Joshua Shireman**
+- [@kealist](https://github.com/kealist) on GitHub
+- Serial port driver work (based on code by Carl Sassenrath)
+
+**Ladislav Mecir**
+- [@ladislav](https://github.com/ladislav) on GitHub
+- Advanced math and currency support, test suite, core patches, core design...
+
+**Richard Smolak**
+- [@cyphre](https://github.com/cyphre) on GitHub
+- TLS and HTTPS, Diffie-Hellman and crypto, extension model, GUI support...
+
+**Shixin Zeng**
+* [@zsx](https://github.com/zsx) on GitHub
+- FFI library, CALL implementation, unix signals, native math, GUI support...
+
+
+Corporate Support
+-----------------
+
+**Atronix Engineering, Inc**
+- http://www.atronixengineering.com/downloads
+- David den Haring, Director of Engineering
+
+**Saphirion AG**
+- http://development.saphirion.com/rebol/
+- Robert M.Münch, CEO, Prototype sponsoring
+
+
+Third-Party Components
+----------------------
+
+This aims to list all the third-party components of this distribution but may
+not be complete. Please amend with any corrections.
+
+**AES**
+- Copyright (c) 2007, Cameron Rich
+- `%src/codecs/aes/aes.h`
+- `%src/codecs/aes/aes.c`
+
+**bigint**
+- Copyright (c) 2007, Cameron Rich
+- `%src/codecs/bigint/bigint_impl.h`
+- `%src/codecs/bigint/bigint_config.h`
+- `%src/codecs/bigint/bigint.h`
+- `%src/codecs/bigint/bigint.c`
+
+**crc32**
+- Derived from code in chapter 19 of the book "C Programmer's Guide to Serial
+ Communications", by Joe Campbell. Generalized to any CRC width by Philip
+ Zimmermann.
+- `%src/core/s-crc.c`
+
+**debugbreak**
+- Copyright (c) 2011-2015, Scott Tsai
+- `%src/include/debugbreak.h`
+
+**dtoa**
+- Copyright (c) 1991, 2000, 2001 by Lucent Technologies.
+- `%src/core/f-dtoa.c`
+
+**JPEG**
+- Copyright 1994-1996, Thomas G. Lane.
+- `%src/core/u-jpg.c`
+- `%src/include/sys-jpg.h`
+
+**LodePNG**
+- Copyright (c) 2005-2013 Lode Vandevenne
+- `%src/codecs/png/lodepng.h`
+- `%src/codecs/png/lodepng.c`
+
+**MD5**
+- This software contains code derived from the RSA Data Security Inc. MD5
+ Message-Digest Algorithm, including various modifications by Spyglass Inc.,
+ Carnegie Mellon University, and Bell Communications Research, Inc (Bellcore).
+- `%src/core/u-md5.c`
+
+**qsort**
+- Copyright (c) 1992, 1993 The Regents of the University of California.
+- `%src/core/f-qsort.c`
+
+**rc4**
+- Copyright (c) 2007, Cameron Rich
+- `%src/codecs/rc4/rc4.h`
+- `%src/codecs/rc4/rc4.c`
+
+**rsa**
+- Copyright (c) 2007, Cameron Rich
+- `%src/codecs/rsa/rsa.h`
+- `%src/codecs/rsa/rsa.c`
+
+**sha1**
+- Copyright 1995-1998 Eric Young
+- `%src/core/u-sha1.c`
+
+**sha256**
+- Copyright 2006-2012 (?) Brad Conte
+- `%src/codecs/sha256.c`
+- `%src/codecs/sha256.h`
+
+**Unicode**
+- Copyright 2001-2004 Unicode, Inc.
+- `%src/core/s-unicode.c`
+
+**ZLIB**
+- Copyright 1995-1998 Jean-loup Gailly and Mark Adler
+- `%src/core/u-zlib.c`
+- `%src/include/sys-zlib.h`
diff --git a/NOTICE b/NOTICE
deleted file mode 100644
index a4814f87a2..0000000000
--- a/NOTICE
+++ /dev/null
@@ -1,37 +0,0 @@
-REBOL [R3] Language Interpreter and Run-time Environment
-Copyright 2012 REBOL Technologies
-REBOL is a trademark of REBOL Technologies
-Licensed under the Apache License, Version 2.0
-See included LICENSE file for details
-
-
-Credits for Non-REBOL orginated C files and modules
----------------------------------------------------
-
-Unicode encoding/decoding functions:
-Copyright 2001-2004 Unicode, Inc.
-
-MD5:
-This software contains code derived from the RSA Data Security
-Inc. MD5 Message-Digest Algorithm, including various
-modifications by Spyglass Inc., Carnegie Mellon University, and
-Bell Communications Research, Inc (Bellcore).
-
-SHA1:
-Copyright 1995-1998 Eric Young (eay@cryptsoft.com)
-All rights reserved.
-
-ZLIB general purpose compression library:
-Version 1.1.2, March 19th, 1998
-Copyright 1995-1998 Jean-loup Gailly and Mark Adler
-
-JPEG decoder:
-Copyright 1994-1996, Thomas G. Lane.
-This file is part of the Independent JPEG Group's software.
-
-dtoa:
-The author of this software is David M. Gay.
-Copyright (c) 1991, 2000, 2001 by Lucent Technologies.
-
-qsort:
-Copyright (c) 1992, 1993 The Regents of the University of California.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000000..497f05458e
--- /dev/null
+++ b/README.md
@@ -0,0 +1,94 @@
+![Ren-C Logo][100]
+
+# Ren/C
+[![Build Status][101]](https://travis-ci.org/metaeducation/ren-c)
+
+
+**Ren-C** is an interim fork of the [Apache 2.0 open-sourced][1] [Rebol][2] codebase. The
+goal of the project isn't to be a new language or a different console, rather to provide
+a smooth API for embedding a Rebol interpreter in C programs. This API would offer
+nearly the full range of power that is internally offered to the core, making it
+easy to write new clients or REPLs using it.
+
+[1]: http://www.rebol.com/cgi-bin/blog.r?view=0519
+[2]: https://en.wikipedia.org/wiki/Rebol
+
+Because the API is not fully ready for publication, the current way to explore the new
+features of Ren-C is using the `r3` console built by the makefile. It should function
+nearly identically (though it has been extended through user contribution to support a
+multi-line continuation method similar to Rebol2.) For those interested in a more
+novel application of the Ren-C library, see the C++ binding and [Ren Garden][3].
+
+[3]: http://rencpp.hostilefork.com
+
+In the process of designing the library, Ren-C also aspires to solve several of the
+major outstanding design problems that were left unfinished in the R3-Alpha codebase.
+Several of these problems have been solved already--and for progress and notes on
+these issues, a [Trello board][4] is frequently updated to reflect a summary of
+some of the changes.
+
+[4]: https://trello.com/b/l385BE7a/rebol3-porting-guide-ren-c-branch
+
+In doing this work, the hope is to provide an artifact that would rally common
+usage between the [mainline builds][5], community builds, and those made by
+[Atronix Engineering][6] and [Saphirion AG][7].
+
+[5]: http://rebolsource.net
+[6]: http://www.atronixengineering.com/downloads
+[7]: http://development.saphirion.com/rebol/saphir/
+
+For more information, please visit the FAQ:
+
+https://github.com/metaeducation/ren-c/wiki/FAQ
+
+Feel free to add your own questions to the bottom of the list.
+
+
+## Community
+
+To promote the Rebol community's participation in public forums, development discussion
+for Ren-C generally takes place in the [Rebol and Red StackOverflow Chat][8].
+
+[8]: http://rebolsource.net/go/chat-faq
+
+It is also possible to contact the developers through the [Ren-C GitHub Issues][9]
+page. This should be limited to questions regarding the Ren-C builds specifically, as
+overall language design wishes and debates are kept in the `rebol-issues` repository
+of Rebol's GitHub.
+
+[9]: https://github.com/metaeducation/ren-c/issues
+
+
+## Building
+
+There are currently two build systems in Ren-C: plain make files for basic features, and CMake for extended features.
+
+* With plain make files
+
+First get the sources -- from cloning the repository with `git`, or downloading a ZIP:
+
+https://github.com/metaeducation/ren-c/archive/master.zip
+
+Next you need to [get a pre-built R3-Alpha interpreter](http://rebolsource.net), rename
+it to `r3-make` or `r3-make.exe`, and put it in the `%make/` subdirectory.
+
+Then run:
+
+ make -f makefile.boot
+
+The platform to target will be assumed to be the same as the build type of the
+`r3-make` you use. If your needs are more complex *(such as doing a cross-compilation,
+or if the `system/version` in your r3-make doesn't match the target you want)*, refer
+to the bootstrap makefile `%src/make/makefile.boot`:
+
+https://github.com/metaeducation/ren-c/blob/master/make/makefile.boot
+
+*(Note: Ren-C's build process cannot be performed with Rebol2. It requires R3-Alpha
+or Ren-C itself. However, it can build using an old pre-open-source R3-Alpha A111.)*
+
+* With CMake
+
+Please see https://github.com/metaeducation/ren-c/wiki/Building-Ren-C-with-CMake
+
+[100]: https://raw.githubusercontent.com/metaeducation/ren-c/master/ren-c-logo.png
+[101]: https://travis-ci.org/metaeducation/ren-c.svg?branch=master
diff --git a/external/README.md b/external/README.md
new file mode 100644
index 0000000000..1bc8210658
--- /dev/null
+++ b/external/README.md
@@ -0,0 +1,10 @@
+This is an external dependencies directory; e.g. source for projects that are not
+part of the Ren/C project or maintained as part of its version history. Directories
+are either Git submodules or instructions will be added to this file for how to
+get ahold of the dependencies.
+
+Inspired by Rebol's choice to do targeted subsetting of dependent C libraries via
+Rebol scripts and include that source, the goal is not to require a large dependent
+build process. Hence any build process required by these dependencies should be
+taken care of by a script. (See make-zlib for an example.)
+
diff --git a/external/ffi-prebuilt/lib32/libffi-3.2.1/include/ffi.h b/external/ffi-prebuilt/lib32/libffi-3.2.1/include/ffi.h
new file mode 100644
index 0000000000..c0059b06cb
--- /dev/null
+++ b/external/ffi-prebuilt/lib32/libffi-3.2.1/include/ffi.h
@@ -0,0 +1,487 @@
+/* -----------------------------------------------------------------*-C-*-
+ libffi 3.2.1 - Copyright (c) 2011, 2014 Anthony Green
+ - Copyright (c) 1996-2003, 2007, 2008 Red Hat, Inc.
+
+ Permission is hereby granted, free of charge, to any person
+ obtaining a copy of this software and associated documentation
+ files (the ``Software''), to deal in the Software without
+ restriction, including without limitation the rights to use, copy,
+ modify, merge, publish, distribute, sublicense, and/or sell copies
+ of the Software, and to permit persons to whom the Software is
+ furnished to do so, subject to the following conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+ HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ DEALINGS IN THE SOFTWARE.
+
+ ----------------------------------------------------------------------- */
+
+/* -------------------------------------------------------------------
+ The basic API is described in the README file.
+
+ The raw API is designed to bypass some of the argument packing
+ and unpacking on architectures for which it can be avoided.
+
+ The closure API allows interpreted functions to be packaged up
+ inside a C function pointer, so that they can be called as C functions,
+ with no understanding on the client side that they are interpreted.
+ It can also be used in other cases in which it is necessary to package
+ up a user specified parameter and a function pointer as a single
+ function pointer.
+
+ The closure API must be implemented in order to get its functionality,
+ e.g. for use by gij. Routines are provided to emulate the raw API
+ if the underlying platform doesn't allow faster implementation.
+
+ More details on the raw and cloure API can be found in:
+
+ http://gcc.gnu.org/ml/java/1999-q3/msg00138.html
+
+ and
+
+ http://gcc.gnu.org/ml/java/1999-q3/msg00174.html
+ -------------------------------------------------------------------- */
+
+#ifndef LIBFFI_H
+#define LIBFFI_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* Specify which architecture libffi is configured for. */
+#ifndef X86_WIN32
+#define X86_WIN32
+#endif
+
+/* ---- System configuration information --------------------------------- */
+
+#include
+
+#ifndef LIBFFI_ASM
+
+#if defined(_MSC_VER) && !defined(__clang__)
+#define __attribute__(X)
+#endif
+
+#include
+#include
+
+/* LONG_LONG_MAX is not always defined (not if STRICT_ANSI, for example).
+ But we can find it either under the correct ANSI name, or under GNU
+ C's internal name. */
+
+#define FFI_64_BIT_MAX 9223372036854775807
+
+#ifdef LONG_LONG_MAX
+# define FFI_LONG_LONG_MAX LONG_LONG_MAX
+#else
+# ifdef LLONG_MAX
+# define FFI_LONG_LONG_MAX LLONG_MAX
+# ifdef _AIX52 /* or newer has C99 LLONG_MAX */
+# undef FFI_64_BIT_MAX
+# define FFI_64_BIT_MAX 9223372036854775807LL
+# endif /* _AIX52 or newer */
+# else
+# ifdef __GNUC__
+# define FFI_LONG_LONG_MAX __LONG_LONG_MAX__
+# endif
+# ifdef _AIX /* AIX 5.1 and earlier have LONGLONG_MAX */
+# ifndef __PPC64__
+# if defined (__IBMC__) || defined (__IBMCPP__)
+# define FFI_LONG_LONG_MAX LONGLONG_MAX
+# endif
+# endif /* __PPC64__ */
+# undef FFI_64_BIT_MAX
+# define FFI_64_BIT_MAX 9223372036854775807LL
+# endif
+# endif
+#endif
+
+/* The closure code assumes that this works on pointers, i.e. a size_t */
+/* can hold a pointer. */
+
+typedef struct _ffi_type
+{
+ size_t size;
+ unsigned short alignment;
+ unsigned short type;
+ struct _ffi_type **elements;
+} ffi_type;
+
+#ifndef LIBFFI_HIDE_BASIC_TYPES
+#if SCHAR_MAX == 127
+# define ffi_type_uchar ffi_type_uint8
+# define ffi_type_schar ffi_type_sint8
+#else
+ #error "char size not supported"
+#endif
+
+#if SHRT_MAX == 32767
+# define ffi_type_ushort ffi_type_uint16
+# define ffi_type_sshort ffi_type_sint16
+#elif SHRT_MAX == 2147483647
+# define ffi_type_ushort ffi_type_uint32
+# define ffi_type_sshort ffi_type_sint32
+#else
+ #error "short size not supported"
+#endif
+
+#if INT_MAX == 32767
+# define ffi_type_uint ffi_type_uint16
+# define ffi_type_sint ffi_type_sint16
+#elif INT_MAX == 2147483647
+# define ffi_type_uint ffi_type_uint32
+# define ffi_type_sint ffi_type_sint32
+#elif INT_MAX == 9223372036854775807
+# define ffi_type_uint ffi_type_uint64
+# define ffi_type_sint ffi_type_sint64
+#else
+ #error "int size not supported"
+#endif
+
+#if LONG_MAX == 2147483647
+# if FFI_LONG_LONG_MAX != FFI_64_BIT_MAX
+ #error "no 64-bit data type supported"
+# endif
+#elif LONG_MAX != FFI_64_BIT_MAX
+ #error "long size not supported"
+#endif
+
+#if LONG_MAX == 2147483647
+# define ffi_type_ulong ffi_type_uint32
+# define ffi_type_slong ffi_type_sint32
+#elif LONG_MAX == FFI_64_BIT_MAX
+# define ffi_type_ulong ffi_type_uint64
+# define ffi_type_slong ffi_type_sint64
+#else
+ #error "long size not supported"
+#endif
+
+/* Need minimal decorations for DLLs to works on Windows. */
+/* GCC has autoimport and autoexport. Rely on Libtool to */
+/* help MSVC export from a DLL, but always declare data */
+/* to be imported for MSVC clients. This costs an extra */
+/* indirection for MSVC clients using the static version */
+/* of the library, but don't worry about that. Besides, */
+/* as a workaround, they can define FFI_BUILDING if they */
+/* *know* they are going to link with the static library. */
+#if defined _MSC_VER && !defined FFI_BUILDING
+#define FFI_EXTERN extern __declspec(dllimport)
+#else
+#define FFI_EXTERN extern
+#endif
+
+/* These are defined in types.c */
+FFI_EXTERN ffi_type ffi_type_void;
+FFI_EXTERN ffi_type ffi_type_uint8;
+FFI_EXTERN ffi_type ffi_type_sint8;
+FFI_EXTERN ffi_type ffi_type_uint16;
+FFI_EXTERN ffi_type ffi_type_sint16;
+FFI_EXTERN ffi_type ffi_type_uint32;
+FFI_EXTERN ffi_type ffi_type_sint32;
+FFI_EXTERN ffi_type ffi_type_uint64;
+FFI_EXTERN ffi_type ffi_type_sint64;
+FFI_EXTERN ffi_type ffi_type_float;
+FFI_EXTERN ffi_type ffi_type_double;
+FFI_EXTERN ffi_type ffi_type_pointer;
+
+#if 1
+FFI_EXTERN ffi_type ffi_type_longdouble;
+#else
+#define ffi_type_longdouble ffi_type_double
+#endif
+
+#ifdef FFI_TARGET_HAS_COMPLEX_TYPE
+FFI_EXTERN ffi_type ffi_type_complex_float;
+FFI_EXTERN ffi_type ffi_type_complex_double;
+#if 1
+FFI_EXTERN ffi_type ffi_type_complex_longdouble;
+#else
+#define ffi_type_complex_longdouble ffi_type_complex_double
+#endif
+#endif
+#endif /* LIBFFI_HIDE_BASIC_TYPES */
+
+typedef enum {
+ FFI_OK = 0,
+ FFI_BAD_TYPEDEF,
+ FFI_BAD_ABI
+} ffi_status;
+
+typedef unsigned FFI_TYPE;
+
+typedef struct {
+ ffi_abi abi;
+ unsigned nargs;
+ ffi_type **arg_types;
+ ffi_type *rtype;
+ unsigned bytes;
+ unsigned flags;
+#ifdef FFI_EXTRA_CIF_FIELDS
+ FFI_EXTRA_CIF_FIELDS;
+#endif
+} ffi_cif;
+
+#if 0
+/* Used to adjust size/alignment of ffi types. */
+void ffi_prep_types (ffi_abi abi);
+#endif
+
+/* Used internally, but overridden by some architectures */
+ffi_status ffi_prep_cif_core(ffi_cif *cif,
+ ffi_abi abi,
+ unsigned int isvariadic,
+ unsigned int nfixedargs,
+ unsigned int ntotalargs,
+ ffi_type *rtype,
+ ffi_type **atypes);
+
+/* ---- Definitions for the raw API -------------------------------------- */
+
+#ifndef FFI_SIZEOF_ARG
+# if LONG_MAX == 2147483647
+# define FFI_SIZEOF_ARG 4
+# elif LONG_MAX == FFI_64_BIT_MAX
+# define FFI_SIZEOF_ARG 8
+# endif
+#endif
+
+#ifndef FFI_SIZEOF_JAVA_RAW
+# define FFI_SIZEOF_JAVA_RAW FFI_SIZEOF_ARG
+#endif
+
+typedef union {
+ ffi_sarg sint;
+ ffi_arg uint;
+ float flt;
+ char data[FFI_SIZEOF_ARG];
+ void* ptr;
+} ffi_raw;
+
+#if FFI_SIZEOF_JAVA_RAW == 4 && FFI_SIZEOF_ARG == 8
+/* This is a special case for mips64/n32 ABI (and perhaps others) where
+ sizeof(void *) is 4 and FFI_SIZEOF_ARG is 8. */
+typedef union {
+ signed int sint;
+ unsigned int uint;
+ float flt;
+ char data[FFI_SIZEOF_JAVA_RAW];
+ void* ptr;
+} ffi_java_raw;
+#else
+typedef ffi_raw ffi_java_raw;
+#endif
+
+
+void ffi_raw_call (ffi_cif *cif,
+ void (*fn)(void),
+ void *rvalue,
+ ffi_raw *avalue);
+
+void ffi_ptrarray_to_raw (ffi_cif *cif, void **args, ffi_raw *raw);
+void ffi_raw_to_ptrarray (ffi_cif *cif, ffi_raw *raw, void **args);
+size_t ffi_raw_size (ffi_cif *cif);
+
+/* This is analogous to the raw API, except it uses Java parameter */
+/* packing, even on 64-bit machines. I.e. on 64-bit machines */
+/* longs and doubles are followed by an empty 64-bit word. */
+
+void ffi_java_raw_call (ffi_cif *cif,
+ void (*fn)(void),
+ void *rvalue,
+ ffi_java_raw *avalue);
+
+void ffi_java_ptrarray_to_raw (ffi_cif *cif, void **args, ffi_java_raw *raw);
+void ffi_java_raw_to_ptrarray (ffi_cif *cif, ffi_java_raw *raw, void **args);
+size_t ffi_java_raw_size (ffi_cif *cif);
+
+/* ---- Definitions for closures ----------------------------------------- */
+
+#if FFI_CLOSURES
+
+#ifdef _MSC_VER
+__declspec(align(8))
+#endif
+typedef struct {
+#if 0
+ void *trampoline_table;
+ void *trampoline_table_entry;
+#else
+ char tramp[FFI_TRAMPOLINE_SIZE];
+#endif
+ ffi_cif *cif;
+ void (*fun)(ffi_cif*,void*,void**,void*);
+ void *user_data;
+#ifdef __GNUC__
+} ffi_closure __attribute__((aligned (8)));
+#else
+} ffi_closure;
+# ifdef __sgi
+# pragma pack 0
+# endif
+#endif
+
+void *ffi_closure_alloc (size_t size, void **code);
+void ffi_closure_free (void *);
+
+ffi_status
+ffi_prep_closure (ffi_closure*,
+ ffi_cif *,
+ void (*fun)(ffi_cif*,void*,void**,void*),
+ void *user_data);
+
+ffi_status
+ffi_prep_closure_loc (ffi_closure*,
+ ffi_cif *,
+ void (*fun)(ffi_cif*,void*,void**,void*),
+ void *user_data,
+ void*codeloc);
+
+#ifdef __sgi
+# pragma pack 8
+#endif
+typedef struct {
+#if 0
+ void *trampoline_table;
+ void *trampoline_table_entry;
+#else
+ char tramp[FFI_TRAMPOLINE_SIZE];
+#endif
+ ffi_cif *cif;
+
+#if !FFI_NATIVE_RAW_API
+
+ /* if this is enabled, then a raw closure has the same layout
+ as a regular closure. We use this to install an intermediate
+ handler to do the transaltion, void** -> ffi_raw*. */
+
+ void (*translate_args)(ffi_cif*,void*,void**,void*);
+ void *this_closure;
+
+#endif
+
+ void (*fun)(ffi_cif*,void*,ffi_raw*,void*);
+ void *user_data;
+
+} ffi_raw_closure;
+
+typedef struct {
+#if 0
+ void *trampoline_table;
+ void *trampoline_table_entry;
+#else
+ char tramp[FFI_TRAMPOLINE_SIZE];
+#endif
+
+ ffi_cif *cif;
+
+#if !FFI_NATIVE_RAW_API
+
+ /* if this is enabled, then a raw closure has the same layout
+ as a regular closure. We use this to install an intermediate
+ handler to do the transaltion, void** -> ffi_raw*. */
+
+ void (*translate_args)(ffi_cif*,void*,void**,void*);
+ void *this_closure;
+
+#endif
+
+ void (*fun)(ffi_cif*,void*,ffi_java_raw*,void*);
+ void *user_data;
+
+} ffi_java_raw_closure;
+
+ffi_status
+ffi_prep_raw_closure (ffi_raw_closure*,
+ ffi_cif *cif,
+ void (*fun)(ffi_cif*,void*,ffi_raw*,void*),
+ void *user_data);
+
+ffi_status
+ffi_prep_raw_closure_loc (ffi_raw_closure*,
+ ffi_cif *cif,
+ void (*fun)(ffi_cif*,void*,ffi_raw*,void*),
+ void *user_data,
+ void *codeloc);
+
+ffi_status
+ffi_prep_java_raw_closure (ffi_java_raw_closure*,
+ ffi_cif *cif,
+ void (*fun)(ffi_cif*,void*,ffi_java_raw*,void*),
+ void *user_data);
+
+ffi_status
+ffi_prep_java_raw_closure_loc (ffi_java_raw_closure*,
+ ffi_cif *cif,
+ void (*fun)(ffi_cif*,void*,ffi_java_raw*,void*),
+ void *user_data,
+ void *codeloc);
+
+#endif /* FFI_CLOSURES */
+
+/* ---- Public interface definition -------------------------------------- */
+
+ffi_status ffi_prep_cif(ffi_cif *cif,
+ ffi_abi abi,
+ unsigned int nargs,
+ ffi_type *rtype,
+ ffi_type **atypes);
+
+ffi_status ffi_prep_cif_var(ffi_cif *cif,
+ ffi_abi abi,
+ unsigned int nfixedargs,
+ unsigned int ntotalargs,
+ ffi_type *rtype,
+ ffi_type **atypes);
+
+void ffi_call(ffi_cif *cif,
+ void (*fn)(void),
+ void *rvalue,
+ void **avalue);
+
+/* Useful for eliminating compiler warnings */
+#define FFI_FN(f) ((void (*)(void))f)
+
+/* ---- Definitions shared with assembly code ---------------------------- */
+
+#endif
+
+/* If these change, update src/mips/ffitarget.h. */
+#define FFI_TYPE_VOID 0
+#define FFI_TYPE_INT 1
+#define FFI_TYPE_FLOAT 2
+#define FFI_TYPE_DOUBLE 3
+#if 1
+#define FFI_TYPE_LONGDOUBLE 4
+#else
+#define FFI_TYPE_LONGDOUBLE FFI_TYPE_DOUBLE
+#endif
+#define FFI_TYPE_UINT8 5
+#define FFI_TYPE_SINT8 6
+#define FFI_TYPE_UINT16 7
+#define FFI_TYPE_SINT16 8
+#define FFI_TYPE_UINT32 9
+#define FFI_TYPE_SINT32 10
+#define FFI_TYPE_UINT64 11
+#define FFI_TYPE_SINT64 12
+#define FFI_TYPE_STRUCT 13
+#define FFI_TYPE_POINTER 14
+#define FFI_TYPE_COMPLEX 15
+
+/* This should always refer to the last type code (for sanity checks) */
+#define FFI_TYPE_LAST FFI_TYPE_COMPLEX
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/external/ffi-prebuilt/lib32/libffi-3.2.1/include/ffitarget.h b/external/ffi-prebuilt/lib32/libffi-3.2.1/include/ffitarget.h
new file mode 100644
index 0000000000..214278a6cf
--- /dev/null
+++ b/external/ffi-prebuilt/lib32/libffi-3.2.1/include/ffitarget.h
@@ -0,0 +1,154 @@
+/* -----------------------------------------------------------------*-C-*-
+ ffitarget.h - Copyright (c) 2012, 2014 Anthony Green
+ Copyright (c) 1996-2003, 2010 Red Hat, Inc.
+ Copyright (C) 2008 Free Software Foundation, Inc.
+
+ Target configuration macros for x86 and x86-64.
+
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ ``Software''), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+
+ The above copyright notice and this permission notice shall be included
+ in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+ HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ DEALINGS IN THE SOFTWARE.
+
+ ----------------------------------------------------------------------- */
+
+#ifndef LIBFFI_TARGET_H
+#define LIBFFI_TARGET_H
+
+#ifndef LIBFFI_H
+#error "Please do not include ffitarget.h directly into your source. Use ffi.h instead."
+#endif
+
+/* ---- System specific configurations ----------------------------------- */
+
+/* For code common to all platforms on x86 and x86_64. */
+#define X86_ANY
+
+#if defined (X86_64) && defined (__i386__)
+#undef X86_64
+#define X86
+#endif
+
+#ifdef X86_WIN64
+#define FFI_SIZEOF_ARG 8
+#define USE_BUILTIN_FFS 0 /* not yet implemented in mingw-64 */
+#endif
+
+#define FFI_TARGET_SPECIFIC_STACK_SPACE_ALLOCATION
+#ifndef _MSC_VER
+/* MSC doesn't support _Complex types:
+https://connect.microsoft.com/VisualStudio/feedback/details/1551173/msvc-2015-complex-hs-complex-i-macro-does-not-conform-to-the-standard */
+#define FFI_TARGET_HAS_COMPLEX_TYPE
+#endif
+
+/* ---- Generic type definitions ----------------------------------------- */
+
+#ifndef LIBFFI_ASM
+#ifdef X86_WIN64
+#ifdef _MSC_VER
+typedef unsigned __int64 ffi_arg;
+typedef __int64 ffi_sarg;
+#else
+typedef unsigned long long ffi_arg;
+typedef long long ffi_sarg;
+#endif
+#else
+#if defined __x86_64__ && defined __ILP32__
+#define FFI_SIZEOF_ARG 8
+#define FFI_SIZEOF_JAVA_RAW 4
+typedef unsigned long long ffi_arg;
+typedef long long ffi_sarg;
+#else
+typedef unsigned long ffi_arg;
+typedef signed long ffi_sarg;
+#endif
+#endif
+
+typedef enum ffi_abi {
+ FFI_FIRST_ABI = 0,
+
+ /* ---- Intel x86 Win32 ---------- */
+#ifdef X86_WIN32
+ FFI_SYSV,
+ FFI_STDCALL,
+ FFI_THISCALL,
+ FFI_FASTCALL,
+ FFI_MS_CDECL,
+ FFI_PASCAL,
+ FFI_REGISTER,
+ FFI_LAST_ABI,
+#ifdef _MSC_VER
+ FFI_DEFAULT_ABI = FFI_MS_CDECL
+#else
+ FFI_DEFAULT_ABI = FFI_SYSV
+#endif
+
+#elif defined(X86_WIN64)
+ FFI_WIN64,
+ FFI_LAST_ABI,
+ FFI_DEFAULT_ABI = FFI_WIN64
+
+#else
+ /* ---- Intel x86 and AMD x86-64 - */
+ FFI_SYSV,
+ FFI_UNIX64, /* Unix variants all use the same ABI for x86-64 */
+ FFI_THISCALL,
+ FFI_FASTCALL,
+ FFI_STDCALL,
+ FFI_PASCAL,
+ FFI_REGISTER,
+ FFI_LAST_ABI,
+#if defined(__i386__) || defined(__i386)
+ FFI_DEFAULT_ABI = FFI_SYSV
+#else
+ FFI_DEFAULT_ABI = FFI_UNIX64
+#endif
+#endif
+} ffi_abi;
+#endif
+
+/* ---- Definitions for closures ----------------------------------------- */
+
+#define FFI_CLOSURES 1
+#define FFI_TYPE_SMALL_STRUCT_1B (FFI_TYPE_LAST + 1)
+#define FFI_TYPE_SMALL_STRUCT_2B (FFI_TYPE_LAST + 2)
+#define FFI_TYPE_SMALL_STRUCT_4B (FFI_TYPE_LAST + 3)
+#define FFI_TYPE_MS_STRUCT (FFI_TYPE_LAST + 4)
+
+#if defined (X86_64) || (defined (__x86_64__) && defined (X86_DARWIN))
+#define FFI_TRAMPOLINE_SIZE 24
+#define FFI_NATIVE_RAW_API 0
+#else
+#ifdef X86_WIN32
+#define FFI_TRAMPOLINE_SIZE 52
+#else
+#ifdef X86_WIN64
+#define FFI_TRAMPOLINE_SIZE 29
+#define FFI_NATIVE_RAW_API 0
+#define FFI_NO_RAW_API 1
+#else
+#define FFI_TRAMPOLINE_SIZE 10
+#endif
+#endif
+#ifndef X86_WIN64
+#define FFI_NATIVE_RAW_API 1 /* x86 has native raw api support */
+#endif
+#endif
+
+#endif
+
diff --git a/external/ffi-prebuilt/lib32/libffi.a b/external/ffi-prebuilt/lib32/libffi.a
new file mode 100644
index 0000000000..0b0edc6b2b
Binary files /dev/null and b/external/ffi-prebuilt/lib32/libffi.a differ
diff --git a/external/ffi-prebuilt/lib32/pkgconfig/libffi.pc b/external/ffi-prebuilt/lib32/pkgconfig/libffi.pc
new file mode 100644
index 0000000000..f970edf675
--- /dev/null
+++ b/external/ffi-prebuilt/lib32/pkgconfig/libffi.pc
@@ -0,0 +1,11 @@
+prefix=/home/zsx/r3-dev/external/ffi-prebuilt
+exec_prefix=${prefix}
+libdir=${exec_prefix}/lib32
+toolexeclibdir=${exec_prefix}/lib32
+includedir=${libdir}/libffi-3.2.1/include
+
+Name: libffi
+Description: Library supporting Foreign Function Interfaces
+Version: 3.2.1
+Libs: -L${toolexeclibdir} -lffi
+Cflags: -I${includedir}
diff --git a/external/ffi-prebuilt/lib64/libffi-3.2.1/include/ffi.h b/external/ffi-prebuilt/lib64/libffi-3.2.1/include/ffi.h
new file mode 100644
index 0000000000..a884b596f3
--- /dev/null
+++ b/external/ffi-prebuilt/lib64/libffi-3.2.1/include/ffi.h
@@ -0,0 +1,487 @@
+/* -----------------------------------------------------------------*-C-*-
+ libffi 3.2.1 - Copyright (c) 2011, 2014 Anthony Green
+ - Copyright (c) 1996-2003, 2007, 2008 Red Hat, Inc.
+
+ Permission is hereby granted, free of charge, to any person
+ obtaining a copy of this software and associated documentation
+ files (the ``Software''), to deal in the Software without
+ restriction, including without limitation the rights to use, copy,
+ modify, merge, publish, distribute, sublicense, and/or sell copies
+ of the Software, and to permit persons to whom the Software is
+ furnished to do so, subject to the following conditions:
+
+ The above copyright notice and this permission notice shall be
+ included in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+ HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ DEALINGS IN THE SOFTWARE.
+
+ ----------------------------------------------------------------------- */
+
+/* -------------------------------------------------------------------
+ The basic API is described in the README file.
+
+ The raw API is designed to bypass some of the argument packing
+ and unpacking on architectures for which it can be avoided.
+
+ The closure API allows interpreted functions to be packaged up
+ inside a C function pointer, so that they can be called as C functions,
+ with no understanding on the client side that they are interpreted.
+ It can also be used in other cases in which it is necessary to package
+ up a user specified parameter and a function pointer as a single
+ function pointer.
+
+ The closure API must be implemented in order to get its functionality,
+ e.g. for use by gij. Routines are provided to emulate the raw API
+ if the underlying platform doesn't allow faster implementation.
+
+ More details on the raw and cloure API can be found in:
+
+ http://gcc.gnu.org/ml/java/1999-q3/msg00138.html
+
+ and
+
+ http://gcc.gnu.org/ml/java/1999-q3/msg00174.html
+ -------------------------------------------------------------------- */
+
+#ifndef LIBFFI_H
+#define LIBFFI_H
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* Specify which architecture libffi is configured for. */
+#ifndef X86_WIN64
+#define X86_WIN64
+#endif
+
+/* ---- System configuration information --------------------------------- */
+
+#include
+
+#ifndef LIBFFI_ASM
+
+#if defined(_MSC_VER) && !defined(__clang__)
+#define __attribute__(X)
+#endif
+
+#include
+#include
+
+/* LONG_LONG_MAX is not always defined (not if STRICT_ANSI, for example).
+ But we can find it either under the correct ANSI name, or under GNU
+ C's internal name. */
+
+#define FFI_64_BIT_MAX 9223372036854775807
+
+#ifdef LONG_LONG_MAX
+# define FFI_LONG_LONG_MAX LONG_LONG_MAX
+#else
+# ifdef LLONG_MAX
+# define FFI_LONG_LONG_MAX LLONG_MAX
+# ifdef _AIX52 /* or newer has C99 LLONG_MAX */
+# undef FFI_64_BIT_MAX
+# define FFI_64_BIT_MAX 9223372036854775807LL
+# endif /* _AIX52 or newer */
+# else
+# ifdef __GNUC__
+# define FFI_LONG_LONG_MAX __LONG_LONG_MAX__
+# endif
+# ifdef _AIX /* AIX 5.1 and earlier have LONGLONG_MAX */
+# ifndef __PPC64__
+# if defined (__IBMC__) || defined (__IBMCPP__)
+# define FFI_LONG_LONG_MAX LONGLONG_MAX
+# endif
+# endif /* __PPC64__ */
+# undef FFI_64_BIT_MAX
+# define FFI_64_BIT_MAX 9223372036854775807LL
+# endif
+# endif
+#endif
+
+/* The closure code assumes that this works on pointers, i.e. a size_t */
+/* can hold a pointer. */
+
+typedef struct _ffi_type
+{
+ size_t size;
+ unsigned short alignment;
+ unsigned short type;
+ struct _ffi_type **elements;
+} ffi_type;
+
+#ifndef LIBFFI_HIDE_BASIC_TYPES
+#if SCHAR_MAX == 127
+# define ffi_type_uchar ffi_type_uint8
+# define ffi_type_schar ffi_type_sint8
+#else
+ #error "char size not supported"
+#endif
+
+#if SHRT_MAX == 32767
+# define ffi_type_ushort ffi_type_uint16
+# define ffi_type_sshort ffi_type_sint16
+#elif SHRT_MAX == 2147483647
+# define ffi_type_ushort ffi_type_uint32
+# define ffi_type_sshort ffi_type_sint32
+#else
+ #error "short size not supported"
+#endif
+
+#if INT_MAX == 32767
+# define ffi_type_uint ffi_type_uint16
+# define ffi_type_sint ffi_type_sint16
+#elif INT_MAX == 2147483647
+# define ffi_type_uint ffi_type_uint32
+# define ffi_type_sint ffi_type_sint32
+#elif INT_MAX == 9223372036854775807
+# define ffi_type_uint ffi_type_uint64
+# define ffi_type_sint ffi_type_sint64
+#else
+ #error "int size not supported"
+#endif
+
+#if LONG_MAX == 2147483647
+# if FFI_LONG_LONG_MAX != FFI_64_BIT_MAX
+ #error "no 64-bit data type supported"
+# endif
+#elif LONG_MAX != FFI_64_BIT_MAX
+ #error "long size not supported"
+#endif
+
+#if LONG_MAX == 2147483647
+# define ffi_type_ulong ffi_type_uint32
+# define ffi_type_slong ffi_type_sint32
+#elif LONG_MAX == FFI_64_BIT_MAX
+# define ffi_type_ulong ffi_type_uint64
+# define ffi_type_slong ffi_type_sint64
+#else
+ #error "long size not supported"
+#endif
+
+/* Need minimal decorations for DLLs to works on Windows. */
+/* GCC has autoimport and autoexport. Rely on Libtool to */
+/* help MSVC export from a DLL, but always declare data */
+/* to be imported for MSVC clients. This costs an extra */
+/* indirection for MSVC clients using the static version */
+/* of the library, but don't worry about that. Besides, */
+/* as a workaround, they can define FFI_BUILDING if they */
+/* *know* they are going to link with the static library. */
+#if defined _MSC_VER && !defined FFI_BUILDING
+#define FFI_EXTERN extern __declspec(dllimport)
+#else
+#define FFI_EXTERN extern
+#endif
+
+/* These are defined in types.c */
+FFI_EXTERN ffi_type ffi_type_void;
+FFI_EXTERN ffi_type ffi_type_uint8;
+FFI_EXTERN ffi_type ffi_type_sint8;
+FFI_EXTERN ffi_type ffi_type_uint16;
+FFI_EXTERN ffi_type ffi_type_sint16;
+FFI_EXTERN ffi_type ffi_type_uint32;
+FFI_EXTERN ffi_type ffi_type_sint32;
+FFI_EXTERN ffi_type ffi_type_uint64;
+FFI_EXTERN ffi_type ffi_type_sint64;
+FFI_EXTERN ffi_type ffi_type_float;
+FFI_EXTERN ffi_type ffi_type_double;
+FFI_EXTERN ffi_type ffi_type_pointer;
+
+#if 1
+FFI_EXTERN ffi_type ffi_type_longdouble;
+#else
+#define ffi_type_longdouble ffi_type_double
+#endif
+
+#ifdef FFI_TARGET_HAS_COMPLEX_TYPE
+FFI_EXTERN ffi_type ffi_type_complex_float;
+FFI_EXTERN ffi_type ffi_type_complex_double;
+#if 1
+FFI_EXTERN ffi_type ffi_type_complex_longdouble;
+#else
+#define ffi_type_complex_longdouble ffi_type_complex_double
+#endif
+#endif
+#endif /* LIBFFI_HIDE_BASIC_TYPES */
+
+typedef enum {
+ FFI_OK = 0,
+ FFI_BAD_TYPEDEF,
+ FFI_BAD_ABI
+} ffi_status;
+
+typedef unsigned FFI_TYPE;
+
+typedef struct {
+ ffi_abi abi;
+ unsigned nargs;
+ ffi_type **arg_types;
+ ffi_type *rtype;
+ unsigned bytes;
+ unsigned flags;
+#ifdef FFI_EXTRA_CIF_FIELDS
+ FFI_EXTRA_CIF_FIELDS;
+#endif
+} ffi_cif;
+
+#if 0
+/* Used to adjust size/alignment of ffi types. */
+void ffi_prep_types (ffi_abi abi);
+#endif
+
+/* Used internally, but overridden by some architectures */
+ffi_status ffi_prep_cif_core(ffi_cif *cif,
+ ffi_abi abi,
+ unsigned int isvariadic,
+ unsigned int nfixedargs,
+ unsigned int ntotalargs,
+ ffi_type *rtype,
+ ffi_type **atypes);
+
+/* ---- Definitions for the raw API -------------------------------------- */
+
+#ifndef FFI_SIZEOF_ARG
+# if LONG_MAX == 2147483647
+# define FFI_SIZEOF_ARG 4
+# elif LONG_MAX == FFI_64_BIT_MAX
+# define FFI_SIZEOF_ARG 8
+# endif
+#endif
+
+#ifndef FFI_SIZEOF_JAVA_RAW
+# define FFI_SIZEOF_JAVA_RAW FFI_SIZEOF_ARG
+#endif
+
+typedef union {
+ ffi_sarg sint;
+ ffi_arg uint;
+ float flt;
+ char data[FFI_SIZEOF_ARG];
+ void* ptr;
+} ffi_raw;
+
+#if FFI_SIZEOF_JAVA_RAW == 4 && FFI_SIZEOF_ARG == 8
+/* This is a special case for mips64/n32 ABI (and perhaps others) where
+ sizeof(void *) is 4 and FFI_SIZEOF_ARG is 8. */
+typedef union {
+ signed int sint;
+ unsigned int uint;
+ float flt;
+ char data[FFI_SIZEOF_JAVA_RAW];
+ void* ptr;
+} ffi_java_raw;
+#else
+typedef ffi_raw ffi_java_raw;
+#endif
+
+
+void ffi_raw_call (ffi_cif *cif,
+ void (*fn)(void),
+ void *rvalue,
+ ffi_raw *avalue);
+
+void ffi_ptrarray_to_raw (ffi_cif *cif, void **args, ffi_raw *raw);
+void ffi_raw_to_ptrarray (ffi_cif *cif, ffi_raw *raw, void **args);
+size_t ffi_raw_size (ffi_cif *cif);
+
+/* This is analogous to the raw API, except it uses Java parameter */
+/* packing, even on 64-bit machines. I.e. on 64-bit machines */
+/* longs and doubles are followed by an empty 64-bit word. */
+
+void ffi_java_raw_call (ffi_cif *cif,
+ void (*fn)(void),
+ void *rvalue,
+ ffi_java_raw *avalue);
+
+void ffi_java_ptrarray_to_raw (ffi_cif *cif, void **args, ffi_java_raw *raw);
+void ffi_java_raw_to_ptrarray (ffi_cif *cif, ffi_java_raw *raw, void **args);
+size_t ffi_java_raw_size (ffi_cif *cif);
+
+/* ---- Definitions for closures ----------------------------------------- */
+
+#if FFI_CLOSURES
+
+#ifdef _MSC_VER
+__declspec(align(8))
+#endif
+typedef struct {
+#if 0
+ void *trampoline_table;
+ void *trampoline_table_entry;
+#else
+ char tramp[FFI_TRAMPOLINE_SIZE];
+#endif
+ ffi_cif *cif;
+ void (*fun)(ffi_cif*,void*,void**,void*);
+ void *user_data;
+#ifdef __GNUC__
+} ffi_closure __attribute__((aligned (8)));
+#else
+} ffi_closure;
+# ifdef __sgi
+# pragma pack 0
+# endif
+#endif
+
+void *ffi_closure_alloc (size_t size, void **code);
+void ffi_closure_free (void *);
+
+ffi_status
+ffi_prep_closure (ffi_closure*,
+ ffi_cif *,
+ void (*fun)(ffi_cif*,void*,void**,void*),
+ void *user_data);
+
+ffi_status
+ffi_prep_closure_loc (ffi_closure*,
+ ffi_cif *,
+ void (*fun)(ffi_cif*,void*,void**,void*),
+ void *user_data,
+ void*codeloc);
+
+#ifdef __sgi
+# pragma pack 8
+#endif
+typedef struct {
+#if 0
+ void *trampoline_table;
+ void *trampoline_table_entry;
+#else
+ char tramp[FFI_TRAMPOLINE_SIZE];
+#endif
+ ffi_cif *cif;
+
+#if !FFI_NATIVE_RAW_API
+
+ /* if this is enabled, then a raw closure has the same layout
+ as a regular closure. We use this to install an intermediate
+ handler to do the transaltion, void** -> ffi_raw*. */
+
+ void (*translate_args)(ffi_cif*,void*,void**,void*);
+ void *this_closure;
+
+#endif
+
+ void (*fun)(ffi_cif*,void*,ffi_raw*,void*);
+ void *user_data;
+
+} ffi_raw_closure;
+
+typedef struct {
+#if 0
+ void *trampoline_table;
+ void *trampoline_table_entry;
+#else
+ char tramp[FFI_TRAMPOLINE_SIZE];
+#endif
+
+ ffi_cif *cif;
+
+#if !FFI_NATIVE_RAW_API
+
+ /* if this is enabled, then a raw closure has the same layout
+ as a regular closure. We use this to install an intermediate
+ handler to do the transaltion, void** -> ffi_raw*. */
+
+ void (*translate_args)(ffi_cif*,void*,void**,void*);
+ void *this_closure;
+
+#endif
+
+ void (*fun)(ffi_cif*,void*,ffi_java_raw*,void*);
+ void *user_data;
+
+} ffi_java_raw_closure;
+
+ffi_status
+ffi_prep_raw_closure (ffi_raw_closure*,
+ ffi_cif *cif,
+ void (*fun)(ffi_cif*,void*,ffi_raw*,void*),
+ void *user_data);
+
+ffi_status
+ffi_prep_raw_closure_loc (ffi_raw_closure*,
+ ffi_cif *cif,
+ void (*fun)(ffi_cif*,void*,ffi_raw*,void*),
+ void *user_data,
+ void *codeloc);
+
+ffi_status
+ffi_prep_java_raw_closure (ffi_java_raw_closure*,
+ ffi_cif *cif,
+ void (*fun)(ffi_cif*,void*,ffi_java_raw*,void*),
+ void *user_data);
+
+ffi_status
+ffi_prep_java_raw_closure_loc (ffi_java_raw_closure*,
+ ffi_cif *cif,
+ void (*fun)(ffi_cif*,void*,ffi_java_raw*,void*),
+ void *user_data,
+ void *codeloc);
+
+#endif /* FFI_CLOSURES */
+
+/* ---- Public interface definition -------------------------------------- */
+
+ffi_status ffi_prep_cif(ffi_cif *cif,
+ ffi_abi abi,
+ unsigned int nargs,
+ ffi_type *rtype,
+ ffi_type **atypes);
+
+ffi_status ffi_prep_cif_var(ffi_cif *cif,
+ ffi_abi abi,
+ unsigned int nfixedargs,
+ unsigned int ntotalargs,
+ ffi_type *rtype,
+ ffi_type **atypes);
+
+void ffi_call(ffi_cif *cif,
+ void (*fn)(void),
+ void *rvalue,
+ void **avalue);
+
+/* Useful for eliminating compiler warnings */
+#define FFI_FN(f) ((void (*)(void))f)
+
+/* ---- Definitions shared with assembly code ---------------------------- */
+
+#endif
+
+/* If these change, update src/mips/ffitarget.h. */
+#define FFI_TYPE_VOID 0
+#define FFI_TYPE_INT 1
+#define FFI_TYPE_FLOAT 2
+#define FFI_TYPE_DOUBLE 3
+#if 1
+#define FFI_TYPE_LONGDOUBLE 4
+#else
+#define FFI_TYPE_LONGDOUBLE FFI_TYPE_DOUBLE
+#endif
+#define FFI_TYPE_UINT8 5
+#define FFI_TYPE_SINT8 6
+#define FFI_TYPE_UINT16 7
+#define FFI_TYPE_SINT16 8
+#define FFI_TYPE_UINT32 9
+#define FFI_TYPE_SINT32 10
+#define FFI_TYPE_UINT64 11
+#define FFI_TYPE_SINT64 12
+#define FFI_TYPE_STRUCT 13
+#define FFI_TYPE_POINTER 14
+#define FFI_TYPE_COMPLEX 15
+
+/* This should always refer to the last type code (for sanity checks) */
+#define FFI_TYPE_LAST FFI_TYPE_COMPLEX
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/external/ffi-prebuilt/lib64/libffi-3.2.1/include/ffitarget.h b/external/ffi-prebuilt/lib64/libffi-3.2.1/include/ffitarget.h
new file mode 100644
index 0000000000..214278a6cf
--- /dev/null
+++ b/external/ffi-prebuilt/lib64/libffi-3.2.1/include/ffitarget.h
@@ -0,0 +1,154 @@
+/* -----------------------------------------------------------------*-C-*-
+ ffitarget.h - Copyright (c) 2012, 2014 Anthony Green
+ Copyright (c) 1996-2003, 2010 Red Hat, Inc.
+ Copyright (C) 2008 Free Software Foundation, Inc.
+
+ Target configuration macros for x86 and x86-64.
+
+ Permission is hereby granted, free of charge, to any person obtaining
+ a copy of this software and associated documentation files (the
+ ``Software''), to deal in the Software without restriction, including
+ without limitation the rights to use, copy, modify, merge, publish,
+ distribute, sublicense, and/or sell copies of the Software, and to
+ permit persons to whom the Software is furnished to do so, subject to
+ the following conditions:
+
+ The above copyright notice and this permission notice shall be included
+ in all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND,
+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+ HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+ WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+ OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ DEALINGS IN THE SOFTWARE.
+
+ ----------------------------------------------------------------------- */
+
+#ifndef LIBFFI_TARGET_H
+#define LIBFFI_TARGET_H
+
+#ifndef LIBFFI_H
+#error "Please do not include ffitarget.h directly into your source. Use ffi.h instead."
+#endif
+
+/* ---- System specific configurations ----------------------------------- */
+
+/* For code common to all platforms on x86 and x86_64. */
+#define X86_ANY
+
+#if defined (X86_64) && defined (__i386__)
+#undef X86_64
+#define X86
+#endif
+
+#ifdef X86_WIN64
+#define FFI_SIZEOF_ARG 8
+#define USE_BUILTIN_FFS 0 /* not yet implemented in mingw-64 */
+#endif
+
+#define FFI_TARGET_SPECIFIC_STACK_SPACE_ALLOCATION
+#ifndef _MSC_VER
+/* MSC doesn't support _Complex types:
+https://connect.microsoft.com/VisualStudio/feedback/details/1551173/msvc-2015-complex-hs-complex-i-macro-does-not-conform-to-the-standard */
+#define FFI_TARGET_HAS_COMPLEX_TYPE
+#endif
+
+/* ---- Generic type definitions ----------------------------------------- */
+
+#ifndef LIBFFI_ASM
+#ifdef X86_WIN64
+#ifdef _MSC_VER
+typedef unsigned __int64 ffi_arg;
+typedef __int64 ffi_sarg;
+#else
+typedef unsigned long long ffi_arg;
+typedef long long ffi_sarg;
+#endif
+#else
+#if defined __x86_64__ && defined __ILP32__
+#define FFI_SIZEOF_ARG 8
+#define FFI_SIZEOF_JAVA_RAW 4
+typedef unsigned long long ffi_arg;
+typedef long long ffi_sarg;
+#else
+typedef unsigned long ffi_arg;
+typedef signed long ffi_sarg;
+#endif
+#endif
+
+typedef enum ffi_abi {
+ FFI_FIRST_ABI = 0,
+
+ /* ---- Intel x86 Win32 ---------- */
+#ifdef X86_WIN32
+ FFI_SYSV,
+ FFI_STDCALL,
+ FFI_THISCALL,
+ FFI_FASTCALL,
+ FFI_MS_CDECL,
+ FFI_PASCAL,
+ FFI_REGISTER,
+ FFI_LAST_ABI,
+#ifdef _MSC_VER
+ FFI_DEFAULT_ABI = FFI_MS_CDECL
+#else
+ FFI_DEFAULT_ABI = FFI_SYSV
+#endif
+
+#elif defined(X86_WIN64)
+ FFI_WIN64,
+ FFI_LAST_ABI,
+ FFI_DEFAULT_ABI = FFI_WIN64
+
+#else
+ /* ---- Intel x86 and AMD x86-64 - */
+ FFI_SYSV,
+ FFI_UNIX64, /* Unix variants all use the same ABI for x86-64 */
+ FFI_THISCALL,
+ FFI_FASTCALL,
+ FFI_STDCALL,
+ FFI_PASCAL,
+ FFI_REGISTER,
+ FFI_LAST_ABI,
+#if defined(__i386__) || defined(__i386)
+ FFI_DEFAULT_ABI = FFI_SYSV
+#else
+ FFI_DEFAULT_ABI = FFI_UNIX64
+#endif
+#endif
+} ffi_abi;
+#endif
+
+/* ---- Definitions for closures ----------------------------------------- */
+
+#define FFI_CLOSURES 1
+#define FFI_TYPE_SMALL_STRUCT_1B (FFI_TYPE_LAST + 1)
+#define FFI_TYPE_SMALL_STRUCT_2B (FFI_TYPE_LAST + 2)
+#define FFI_TYPE_SMALL_STRUCT_4B (FFI_TYPE_LAST + 3)
+#define FFI_TYPE_MS_STRUCT (FFI_TYPE_LAST + 4)
+
+#if defined (X86_64) || (defined (__x86_64__) && defined (X86_DARWIN))
+#define FFI_TRAMPOLINE_SIZE 24
+#define FFI_NATIVE_RAW_API 0
+#else
+#ifdef X86_WIN32
+#define FFI_TRAMPOLINE_SIZE 52
+#else
+#ifdef X86_WIN64
+#define FFI_TRAMPOLINE_SIZE 29
+#define FFI_NATIVE_RAW_API 0
+#define FFI_NO_RAW_API 1
+#else
+#define FFI_TRAMPOLINE_SIZE 10
+#endif
+#endif
+#ifndef X86_WIN64
+#define FFI_NATIVE_RAW_API 1 /* x86 has native raw api support */
+#endif
+#endif
+
+#endif
+
diff --git a/external/ffi-prebuilt/lib64/libffi.a b/external/ffi-prebuilt/lib64/libffi.a
new file mode 100644
index 0000000000..aa1c0ef315
Binary files /dev/null and b/external/ffi-prebuilt/lib64/libffi.a differ
diff --git a/external/ffi-prebuilt/lib64/pkgconfig/libffi.pc b/external/ffi-prebuilt/lib64/pkgconfig/libffi.pc
new file mode 100644
index 0000000000..40ce53b66b
--- /dev/null
+++ b/external/ffi-prebuilt/lib64/pkgconfig/libffi.pc
@@ -0,0 +1,11 @@
+prefix=/home/zsx/r3-dev/external/ffi-prebuilt
+exec_prefix=${prefix}
+libdir=${exec_prefix}/lib64
+toolexeclibdir=${exec_prefix}/lib64
+includedir=${libdir}/libffi-3.2.1/include
+
+Name: libffi
+Description: Library supporting Foreign Function Interfaces
+Version: 3.2.1
+Libs: -L${toolexeclibdir} -lffi
+Cflags: -I${includedir}
diff --git a/external/libffi b/external/libffi
new file mode 160000
index 0000000000..12e1d551b0
--- /dev/null
+++ b/external/libffi
@@ -0,0 +1 @@
+Subproject commit 12e1d551b09f149128e56191dcf7503d575f0de9
diff --git a/external/tcc b/external/tcc
new file mode 160000
index 0000000000..06bb332687
--- /dev/null
+++ b/external/tcc
@@ -0,0 +1 @@
+Subproject commit 06bb3326876bcac738ba302218ecf81b4861488e
diff --git a/git-hooks/README.md b/git-hooks/README.md
new file mode 100644
index 0000000000..a5ceff63e6
--- /dev/null
+++ b/git-hooks/README.md
@@ -0,0 +1,13 @@
+The hooks that git executes (such as a "pre-commit" hook), are placed
+in `.git/hooks`. These are *not* part of the tracked files under
+version control, so you will not get them installed from a `git clone`
+
+So it is necessary for each developer to copy these over after they
+have cloned. The hooks may rely on functions that are not available
+on some build systems, so that should be considered.
+
+Improvements are welcome. For now, the goal is just to keep spaces from
+sneaking into files where they shouldn't be, but much more can be
+done. Please at minimum do this if you are going to be contributing:
+
+ cp git-hooks/pre-commit .git/hooks/pre-commit
diff --git a/git-hooks/pre-commit b/git-hooks/pre-commit
new file mode 100755
index 0000000000..2dc02d4678
--- /dev/null
+++ b/git-hooks/pre-commit
@@ -0,0 +1,79 @@
+#!/bin/sh
+#
+# An example hook script to verify what is about to be committed.
+# Called by git-commit with no arguments. The hook should
+# exit with non-zero status after issuing an appropriate message if
+# it wants to stop the commit.
+#
+# To enable this hook, make this file executable.
+
+# This is slightly modified from Andrew Morton's Perfect Patch.
+# Lines you introduce should not have trailing whitespace.
+# Also check for an indentation that has SP before a TAB.
+
+# Original code borrowed from:
+#
+# https://gist.github.com/benprew/6384274
+# http://git.xiph.org/speex.git/hooks/pre-commit
+#
+# !!! Should use a Rebol solution
+
+if git rev-parse --verify HEAD 2>/dev/null
+then
+ git diff-index -p -M --cached HEAD
+else
+ # NEEDSWORK: we should produce a diff with an empty tree here
+ # if we want to do the same verification for the initial import.
+ :
+fi |
+perl -e '
+ my $found_bad = 0;
+ my $filename;
+ my $reported_filename = "";
+ my $lineno;
+
+ sub bad_line {
+ my ($why, $line) = @_;
+ if (!$found_bad) {
+ print STDERR "*\n";
+ print STDERR "* You have some suspicious patch lines:\n";
+ print STDERR "*\n";
+ $found_bad = 1;
+ }
+ if ($reported_filename ne $filename) {
+ print STDERR "* In $filename\n";
+ $reported_filename = $filename;
+ }
+ print STDERR "* $why (line $lineno)\n";
+ print STDERR "$filename:$lineno:$line\n";
+ }
+
+ while (<>) {
+ if (m|^diff --git a/(.*) b/\1$|) {
+ $filename = $1;
+ next;
+ }
+ if (/^@@ -\S+ \+(\d+)/) {
+ $lineno = $1 - 1;
+ next;
+ }
+ if (/^ /) {
+ $lineno++;
+ next;
+ }
+ if (s/^\+//) {
+ $lineno++;
+ chomp;
+ if (/\s$/) {
+ bad_line("trailing whitespace", $_);
+ }
+ if (/^\s* /) {
+ bad_line("indent SP followed by a TAB", $_);
+ }
+ if (/^(?:[<>=]){7}/) {
+ bad_line("unresolved merge conflict", $_);
+ }
+ }
+ }
+ exit($found_bad);
+'
diff --git a/make/CMakeLists.txt b/make/CMakeLists.txt
new file mode 100644
index 0000000000..4804447822
--- /dev/null
+++ b/make/CMakeLists.txt
@@ -0,0 +1,1133 @@
+# vim: ts=4 shiftwidth=4 filetype=cmake expandtab
+
+#
+# Sample command lines:
+#
+# cd make
+# mkdir build
+# cd build
+# CMake .. -G "Visual Studio 14 Win64" -DR3_OS_ID=0.3.40
+# -DR3_EXTERNAL_FFI=yes -DR3_CPP=no
+#
+
+cmake_minimum_required (VERSION 2.8)
+
+project (Rebol3 C CXX)
+
+# While the project is technically able to build as C++98, the interesting
+# added checks are only enabled in the C++11 (or later) builds.
+#
+set (CMAKE_CXX_STANDARD 11)
+
+# Simplify appending flags to the C build settings, C++ settings, or both
+
+macro(add_cxx_flags flags)
+ set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} ${flags}")
+endmacro()
+
+macro(add_c_flags flags)
+ set(CMAKE_C_FLAGS "${CMAKE_CXX_FLAGS} ${flags}")
+endmacro()
+
+macro(add_c_and_cxx_flags flags)
+ set(CMAKE_C_FLAGS "${CMAKE_CXX_FLAGS} ${flags}")
+ set(CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} ${flags}")
+endmacro()
+
+#Only interpret if() arguments as variables or keywords when unquoted
+if (POLICY CMP0054)
+ cmake_policy(SET CMP0054 NEW)
+endif ()
+
+set (TOP_SRC_DIR "${CMAKE_CURRENT_SOURCE_DIR}/../src")
+set (TOP_GENERATED_SRC_DIR "${CMAKE_CURRENT_BINARY_DIR}/src")
+set (CORE_DIR "${TOP_SRC_DIR}/core")
+set (CORE_GENERATED_DIR "${TOP_GENERATED_SRC_DIR}/core")
+set (OS_DIR "${TOP_SRC_DIR}/os")
+set (EXT_DIR "${TOP_SRC_DIR}/extensions")
+set (AGG_DIR "${TOP_SRC_DIR}/agg")
+set (TOOLS_DIR "${TOP_SRC_DIR}/tools")
+set (EXTERNAL_DIR "${TOP_SRC_DIR}/../external")
+set (FFI_DIR "${EXTERNAL_DIR}/libffi")
+set (TCC_DIR "${EXTERNAL_DIR}/tcc")
+set (GIT_EXE "git" CACHE FILEPATH "Path to the git executable")
+
+if(CMAKE_HOST_WIN32)
+ set (REBOL "${CMAKE_CURRENT_BINARY_DIR}/r3-make.exe")
+else()
+ set (REBOL "${CMAKE_CURRENT_BINARY_DIR}/r3-make")
+endif()
+set (R3_MAKE ${REBOL} CACHE FILEPATH "Path to an R3 executable for tool scripts")
+set (REBOL ${R3_MAKE})
+
+option(R3_EXTERNAL_FFI "Build with external FFI" OFF)
+option(R3_CPP "Build C files as C++" OFF)
+option(R3_WITH_TCC "Build with libtcc" OFF)
+
+if (NOT EXISTS ${REBOL})
+ message(FATAL_ERROR "${REBOL} doesn't exist, an executable r3 is required")
+endif()
+
+execute_process(COMMAND ${GIT_EXE} show --format="%H" --no-patch
+ WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}
+ RESULT_VARIABLE GIT_COMMIT_STATUS
+ OUTPUT_VARIABLE GIT_COMMIT)
+
+#message("commit status: ${GIT_COMMIT_STATUS}, commit: ${GIT_COMMIT}")
+if (NOT "${GIT_COMMIT_STATUS}" EQUAL "0")
+ set(GIT_COMMIT "unknown")
+endif ()
+
+if (NOT DEFINED R3_OS_ID)
+ message("Trying to obtain OS_ID from r3-make, as R3_OS_ID is not defined ...")
+ execute_process(COMMAND ${REBOL} --do "print rejoin [\"0.\" system/version/4 \".\" system/version/5]" OUTPUT_VARIABLE R3_OS_ID)
+ string(STRIP ${R3_OS_ID} R3_OS_ID)
+endif()
+
+if (NOT DEFINED R3_OS_ID)
+ message(FATAL_ERROR "R3_OS_ID is not defined")
+endif()
+message("Building Rebol 3 for OS_ID: ${R3_OS_ID}")
+
+string(REPLACE "." ";" OS_ID_LIST ${R3_OS_ID})
+list(GET OS_ID_LIST 1 OS_MAJOR)
+list(GET OS_ID_LIST 2 OS_MINOR)
+message("OS: ${OS_MAJOR}.${OS_MINOR}")
+if (NOT DEFINED OS_MAJOR OR NOT DEFINED OS_MINOR)
+ message(FATAL_ERROR "Unrecognized R3_OS_ID: ${R3_OS_ID}")
+endif()
+set (COMMON_MACROS "")
+if ("${OS_MAJOR}" STREQUAL "2")
+ set (TO_OSX TRUE)
+ list (APPEND COMMON_MACROS
+ ENDIAN_LITTLE
+ HAS_LL_CONSTS
+ )
+elseif ("${OS_MAJOR}" STREQUAL "3")
+ set (TO_WINDOWS TRUE)
+ list (APPEND COMMON_MACROS
+ WIN32
+ TO_WINDOWS
+ ENDIAN_LITTLE
+ UNICODE
+ _UNICODE
+ ZLIB_DLL #to export symbols in zlib for u-png.c usage
+ )
+ set(LIBS wsock32 comdlg32)
+elseif ("${OS_MAJOR}" STREQUAL "4")
+ set (TO_LINUX TRUE)
+ list (APPEND COMMON_MACROS
+ TO_LINUX
+ ENDIAN_LITTLE
+ HAS_LL_CONSTS
+ )
+ set(LIBS m dl)
+elseif ("${OS_MAJOR}" STREQUAL "13")
+ set (TO_ANDROID TRUE)
+ list (APPEND COMMON_MACROS
+ TO_ANDROID
+ ENDIAN_LITTLE
+ HAS_LL_CONSTS
+ )
+ set(LIBS m dl)
+else ()
+ message(FATAL_ERROR "Unsupported system")
+endif ()
+
+if (R3_OS_ID STREQUAL "0.2.5")
+ set (TO_OSX_X86 TRUE)
+ list (APPEND COMMON_MACROS
+ TO_OSX_X86
+ )
+ set(CMAKE_OSX_ARCHITECTURE i386)
+elseif (R3_OS_ID STREQUAL "0.2.40")
+ set (TO_OSX_X64 TRUE)
+ list (APPEND COMMON_MACROS
+ TO_OSX_X64
+ __LP64__
+ )
+ set(CMAKE_OSX_ARCHITECTURE x86_64)
+elseif (R3_OS_ID STREQUAL "0.3.1")
+ set (TO_WINDOWS_X86 TRUE)
+ list (APPEND COMMON_MACROS
+ TO_WINDOWS_X86
+ )
+elseif (R3_OS_ID STREQUAL "0.3.40")
+ set (TO_WINDOWS_X64 TRUE)
+ list (APPEND COMMON_MACROS
+ TO_WINDOWS_X64
+ __LLP64__
+ )
+elseif (R3_OS_ID STREQUAL "0.4.4")
+ set (TO_LINUX_X86 TRUE)
+ list (APPEND COMMON_MACROS
+ TO_LINUX_X86
+ )
+elseif (R3_OS_ID STREQUAL "0.4.20") #linux arm
+ set (TO_LINUX_ARM TRUE)
+ list (APPEND COMMON_MACROS
+ TO_LINUX_ARM
+ )
+elseif (R3_OS_ID STREQUAL "0.4.22") #linux arm64
+ set (TO_LINUX_AARCH64 TRUE)
+ list (APPEND COMMON_MACROS
+ TO_LINUX_AARCH64
+ __LP64__
+ )
+elseif (R3_OS_ID STREQUAL "0.4.40") #linux x86_64
+ set (TO_LINUX_X64 TRUE)
+ list (APPEND COMMON_MACROS
+ TO_LINUX_X64
+ __LP64__
+ )
+elseif (R3_OS_ID STREQUAL "0.13.2") #android5 arm
+ set (TO_ANDROID5 TRUE)
+ set (TO_ANDROID5_ARM TRUE)
+ list (APPEND COMMON_MACROS
+ TO_ANDROID_ARM
+ )
+endif ()
+
+if (MSVC)
+ set (LINK_FLAGS /STACK:4194304)
+
+ # !!! At the moment, there are many places where in the 64-bit build, a
+ # 64-bit integer is used in places where a 32-bit integer is expected.
+ # Ren-C intends to use 64-bit series indices in 64-bit builds, but that
+ # just hasn't been done yet.
+ #
+ # (Note: /WD is "Warning Disable")
+ #
+ add_c_and_cxx_flags(/wd4244) # possible data loss in argument conversion
+ add_c_and_cxx_flags(/wd4267) # possible data loss in initialization
+
+ # MSVC complains if you use old-style functions like `strcpy` instead of
+ # `strcpy_s`. There should be a review of these cases, but for now they
+ # are allowed as-is
+ #
+ add_c_and_cxx_flags(-D_CRT_SECURE_NO_WARNINGS)
+endif()
+
+if (TO_WINDOWS)
+ set (CORE_PLATFORM_SOURCE
+ ${OS_DIR}/windows/host-lib.c
+ ${OS_DIR}/windows/dev-stdio.c
+ ${OS_DIR}/windows/dev-file.c
+ ${OS_DIR}/windows/dev-serial.c
+ ${OS_DIR}/windows/dev-event.c
+ ${OS_DIR}/windows/dev-clipboard.c
+ )
+else ()
+ set (CORE_PLATFORM_SOURCE
+ ${OS_DIR}/generic/host-memory.c
+ ${OS_DIR}/generic/host-locale.c
+ ${OS_DIR}/generic/iso-639.c
+ ${OS_DIR}/generic/iso-3166.c
+ ${OS_DIR}/generic/host-gob.c
+ ${OS_DIR}/posix/host-readline.c
+ ${OS_DIR}/posix/dev-stdio.c
+ ${OS_DIR}/posix/dev-event.c
+ ${OS_DIR}/posix/dev-file.c
+ ${OS_DIR}/posix/host-browse.c
+ ${OS_DIR}/posix/host-config.c
+ ${OS_DIR}/posix/host-error.c
+ ${OS_DIR}/posix/host-library.c
+ ${OS_DIR}/posix/host-process.c
+ ${OS_DIR}/posix/host-time.c
+ ${OS_DIR}/posix/dev-serial.c
+ )
+ if (TO_LINUX)
+ set (CORE_PLATFORM_SOURCE ${CORE_PLATFORM_SOURCE}
+ # Linux supports siginfo_t-style signals
+ ${OS_DIR}/linux/dev-signal.c
+ )
+ endif ()
+ if (TO_OSX)
+ list(APPEND CORE_PLATFORM_SOURCE
+ ${OS_DIR}/osx/host-exec-path.c
+ )
+ else ()
+ list(APPEND CORE_PLATFORM_SOURCE
+ ${OS_DIR}/posix/host-exec-path.c
+ )
+ endif ()
+endif ()
+
+if (R3_EXTERNAL_FFI)
+ find_package(PkgConfig)
+ pkg_search_module(FFI libffi)
+ if (${FFI_FOUND})
+ set (COMMON_MACROS ${COMMON_MACROS} HAVE_LIBFFI_AVAILABLE)
+ else ()
+ message(WARNING "FFI is not found, External Library Access will not work!")
+ endif ()
+else ()
+ if (XCODE) #Xcode has problem with EXCLUDE_FROM_ALL
+ add_subdirectory(${FFI_DIR} ${CMAKE_CURRENT_BINARY_DIR}/ffi)
+ else ()
+ add_subdirectory(${FFI_DIR} ${CMAKE_CURRENT_BINARY_DIR}/ffi EXCLUDE_FROM_ALL)
+ endif ()
+ set (COMMON_MACROS ${COMMON_MACROS} HAVE_LIBFFI_AVAILABLE FFI_BUILDING)
+ set (FFI_LIBRARIES ffi_s)
+endif ()
+
+if (R3_WITH_TCC)
+ set (COMMON_MACROS ${COMMON_MACROS} WITH_TCC)
+endif ()
+
+#CORE
+set (CORE_SOURCE
+ ${CORE_DIR}/a-constants.c
+ ${CORE_DIR}/a-globals.c
+ ${CORE_DIR}/a-lib.c
+ ${CORE_DIR}/b-init.c
+ ${CORE_DIR}/c-bind.c
+ ${CORE_DIR}/c-context.c
+ ${CORE_DIR}/c-do.c
+ ${CORE_DIR}/c-eval.c
+ ${CORE_DIR}/c-error.c
+ ${CORE_DIR}/c-function.c
+ ${CORE_DIR}/c-path.c
+ ${CORE_DIR}/c-port.c
+ ${CORE_DIR}/c-signal.c
+ ${CORE_DIR}/c-word.c
+ ${CORE_DIR}/c-value.c
+ ${CORE_DIR}/d-break.c
+ ${CORE_DIR}/d-crash.c
+ ${CORE_DIR}/d-dump.c
+ ${CORE_DIR}/d-eval.c
+ ${CORE_DIR}/d-legacy.c
+ ${CORE_DIR}/d-print.c
+ ${CORE_DIR}/d-stack.c
+ ${CORE_DIR}/d-trace.c
+ ${CORE_DIR}/f-blocks.c
+ ${CORE_DIR}/f-deci.c
+ ${CORE_DIR}/f-dtoa.c
+ ${CORE_DIR}/f-enbase.c
+ ${CORE_DIR}/f-extension.c
+ ${CORE_DIR}/f-int.c
+ ${CORE_DIR}/f-math.c
+ ${CORE_DIR}/f-modify.c
+ ${CORE_DIR}/f-qsort.c
+ ${CORE_DIR}/f-random.c
+ ${CORE_DIR}/f-round.c
+ ${CORE_DIR}/f-series.c
+ ${CORE_DIR}/f-stubs.c
+ ${CORE_DIR}/l-scan.c
+ ${CORE_DIR}/l-types.c
+ ${CORE_DIR}/m-gc.c
+ ${CORE_DIR}/m-pools.c
+ ${CORE_DIR}/m-series.c
+ ${CORE_DIR}/m-stacks.c
+ ${CORE_DIR}/n-control.c
+ ${CORE_DIR}/n-data.c
+ ${CORE_DIR}/n-do.c
+ ${CORE_DIR}/n-error.c
+ ${CORE_DIR}/n-function.c
+ ${CORE_DIR}/n-io.c
+ ${CORE_DIR}/n-loop.c
+ ${CORE_DIR}/n-math.c
+ ${CORE_DIR}/n-native.c
+ ${CORE_DIR}/n-protect.c
+ ${CORE_DIR}/n-reduce.c
+ ${CORE_DIR}/n-sets.c
+ ${CORE_DIR}/n-strings.c
+ ${CORE_DIR}/n-system.c
+ ${CORE_DIR}/n-textcodecs.c
+ ${CORE_DIR}/p-clipboard.c
+ ${CORE_DIR}/p-console.c
+ ${CORE_DIR}/p-dir.c
+ ${CORE_DIR}/p-dns.c
+ ${CORE_DIR}/p-event.c
+ ${CORE_DIR}/p-file.c
+ ${CORE_DIR}/p-net.c
+ ${CORE_DIR}/p-serial.c
+ ${CORE_DIR}/p-signal.c
+ ${CORE_DIR}/s-cases.c
+ ${CORE_DIR}/s-crc.c
+ ${CORE_DIR}/s-file.c
+ ${CORE_DIR}/s-find.c
+ ${CORE_DIR}/s-make.c
+ ${CORE_DIR}/s-mold.c
+ ${CORE_DIR}/s-ops.c
+ ${CORE_DIR}/s-trim.c
+ ${CORE_DIR}/s-unicode.c
+ ${CORE_DIR}/t-bitset.c
+ ${CORE_DIR}/t-blank.c
+ ${CORE_DIR}/t-block.c
+ ${CORE_DIR}/t-char.c
+ ${CORE_DIR}/t-datatype.c
+ ${CORE_DIR}/t-date.c
+ ${CORE_DIR}/t-decimal.c
+ ${CORE_DIR}/t-event.c
+ ${CORE_DIR}/t-function.c
+ ${CORE_DIR}/t-gob.c
+ ${CORE_DIR}/t-image.c
+ ${CORE_DIR}/t-integer.c
+ ${CORE_DIR}/t-library.c
+ ${CORE_DIR}/t-logic.c
+ ${CORE_DIR}/t-map.c
+ ${CORE_DIR}/t-money.c
+ ${CORE_DIR}/t-object.c
+ ${CORE_DIR}/t-pair.c
+ ${CORE_DIR}/t-port.c
+ ${CORE_DIR}/t-routine.c
+ ${CORE_DIR}/t-string.c
+ ${CORE_DIR}/t-struct.c
+ ${CORE_DIR}/t-time.c
+ ${CORE_DIR}/t-tuple.c
+ ${CORE_DIR}/t-typeset.c
+ ${CORE_DIR}/t-varargs.c
+ ${CORE_DIR}/t-vector.c
+ ${CORE_DIR}/t-word.c
+ ${CORE_DIR}/u-compress.c
+ ${CORE_DIR}/u-md5.c
+ ${CORE_DIR}/u-parse.c
+ ${CORE_DIR}/u-sha1.c
+ ${CORE_DIR}/u-zlib.c
+ )
+
+set (CORE_HEADER
+ ${TOP_SRC_DIR}/include/debugbreak.h
+ ${TOP_SRC_DIR}/include/mem-pools.h
+ ${TOP_SRC_DIR}/include/mem-series.h
+ ${TOP_SRC_DIR}/include/reb-c.h
+ ${TOP_SRC_DIR}/include/reb-config.h
+ ${TOP_SRC_DIR}/include/reb-defs.h
+ ${TOP_SRC_DIR}/include/reb-device.h
+ ${TOP_SRC_DIR}/include/reb-dtoa.h
+ ${TOP_SRC_DIR}/include/reb-event.h
+ ${TOP_SRC_DIR}/include/reb-ext.h
+ ${TOP_SRC_DIR}/include/reb-file.h
+ ${TOP_SRC_DIR}/include/reb-filereq.h
+ ${TOP_SRC_DIR}/include/reb-gob.h
+ ${TOP_SRC_DIR}/include/reb-host.h
+ ${TOP_SRC_DIR}/include/reb-math.h
+ ${TOP_SRC_DIR}/include/reb-net.h
+ ${TOP_SRC_DIR}/include/reb-struct.h
+ ${TOP_SRC_DIR}/include/sys-action.h
+ ${TOP_SRC_DIR}/include/sys-array.h
+ ${TOP_SRC_DIR}/include/sys-binary.h
+ ${TOP_SRC_DIR}/include/sys-bind.h
+ ${TOP_SRC_DIR}/include/sys-context.h
+ ${TOP_SRC_DIR}/include/sys-core.h
+ ${TOP_SRC_DIR}/include/sys-deci-funcs.h
+ ${TOP_SRC_DIR}/include/sys-deci.h
+ ${TOP_SRC_DIR}/include/sys-dec-to-char.h
+ ${TOP_SRC_DIR}/include/sys-do.h
+ ${TOP_SRC_DIR}/include/sys-ext.h
+ ${TOP_SRC_DIR}/include/sys-frame.h
+ ${TOP_SRC_DIR}/include/sys-function.h
+ ${TOP_SRC_DIR}/include/sys-globals.h
+ ${TOP_SRC_DIR}/include/sys-handle.h
+ ${TOP_SRC_DIR}/include/sys-indexor.h
+ ${TOP_SRC_DIR}/include/sys-int-funcs.h
+ ${TOP_SRC_DIR}/include/sys-map.h
+ ${TOP_SRC_DIR}/include/sys-pair.h
+ ${TOP_SRC_DIR}/include/sys-path.h
+ ${TOP_SRC_DIR}/include/sys-rebfrm.h
+ ${TOP_SRC_DIR}/include/sys-rebnod.h
+ ${TOP_SRC_DIR}/include/sys-rebser.h
+ ${TOP_SRC_DIR}/include/sys-rebval.h
+ ${TOP_SRC_DIR}/include/sys-scan.h
+ ${TOP_SRC_DIR}/include/sys-series.h
+ ${TOP_SRC_DIR}/include/sys-stack.h
+ ${TOP_SRC_DIR}/include/sys-state.h
+ ${TOP_SRC_DIR}/include/sys-string.h
+ ${TOP_SRC_DIR}/include/sys-trap.h
+ ${TOP_SRC_DIR}/include/sys-typeset.h
+ ${TOP_SRC_DIR}/include/sys-value.h
+ ${TOP_SRC_DIR}/include/sys-varargs.h
+ ${TOP_SRC_DIR}/include/sys-word.h
+ ${TOP_SRC_DIR}/include/sys-zlib.h
+)
+
+file(GLOB CORE_C_FILES ${CORE_DIR}/*.c)
+#message("CORE_C_FILES: ${CORE_C_FILES}")
+
+set(NATIVE_OUTPUT
+ ${TOP_GENERATED_SRC_DIR}/boot/tmp-natives.r
+ ${TOP_GENERATED_SRC_DIR}/boot/tmp-actions.r
+ )
+
+set(NATIVE_DEPENDS
+ ${TOP_SRC_DIR}/boot/actions.r
+ ${TOP_SRC_DIR}/boot/types.r
+)
+
+set(TOOL_DEPENDS
+ ${TOOLS_DIR}/common.r
+ ${TOOLS_DIR}/common-parsers.r
+)
+
+#all files with REBNATIVE
+foreach(CORE_C_FILE ${CORE_C_FILES})
+ FILE(STRINGS ${CORE_C_FILE} HAS_NATIVE REGEX "^REBNATIVE\\([a-zA-Z_][a-zA-Z0-9_]*\\)$")
+ #message("HAS_NATIVE in ${CORE_C_FILE}: ${HAS_NATIVE}")
+ if(HAS_NATIVE)
+ #message("${CORE_C_FILE} has natives")
+ list(APPEND NATIVE_DEPENDS ${CORE_C_FILE})
+ endif()
+endforeach()
+#message("NATIVE_DEPENDS: ${NATIVE_DEPENDS}")
+
+add_custom_command(OUTPUT
+ ${NATIVE_OUTPUT}
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-natives.r OUTDIR=${TOP_GENERATED_SRC_DIR}
+ DEPENDS
+ ${REBOL} ${TOOLS_DIR}/make-natives.r
+ ${TOOL_DEPENDS}
+ ${NATIVE_DEPENDS}
+)
+
+SET(GENERATED_HEADER
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-funcs.h
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-paramlists.h
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-strings.h
+ )
+set(HEADER_OUTPUT
+ ${GENERATED_HEADER}
+ ${CORE_GENERATED_DIR}/tmp-symbols.c
+ )
+set(HEADER_DEPENDS
+ ${TOOLS_DIR}/common.r
+ ${TOOLS_DIR}/common-parsers.r
+ ${TOOLS_DIR}/form-header.r
+ ${CORE_C_FILES}
+ ${NATIVE_OUTPUT}
+ ${BOOT_OUTPUT}
+ )
+
+add_custom_command(OUTPUT
+ ${HEADER_OUTPUT}
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-headers.r OUTDIR=${TOP_GENERATED_SRC_DIR}
+ DEPENDS
+ ${TOOLS_DIR}/make-headers.r
+ ${TOOL_DEPENDS}
+ ${HEADER_DEPENDS}
+ )
+
+set (BOOT_HEADER
+ ${TOP_GENERATED_SRC_DIR}/include/reb-types.h
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-bootdefs.h
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-sysobj.h
+ ${TOP_GENERATED_SRC_DIR}/include/reb-evtypes.h
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-errnums.h
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-error-funcs.h
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-portmodes.h
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-sysctx.h
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-boot.h
+ )
+set(BOOT_OUTPUT
+ ${BOOT_HEADER}
+ ${CORE_GENERATED_DIR}/tmp-boot-block.c
+ ${CORE_GENERATED_DIR}/tmp-evaltypes.c
+ ${CORE_GENERATED_DIR}/tmp-maketypes.c
+ ${CORE_GENERATED_DIR}/tmp-comptypes.c
+ )
+set(BOOT_DEPENDS
+ # all of the files loaded by make-boot.r
+ ${TOP_SRC_DIR}/boot/version.r
+ ${TOP_SRC_DIR}/boot/types.r
+ ${TOP_SRC_DIR}/boot/errors.r
+ ${TOP_SRC_DIR}/boot/words.r
+ ${TOP_SRC_DIR}/boot/modes.r
+ ${TOP_GENERATED_SRC_DIR}/boot/tmp-actions.r
+ ${TOP_SRC_DIR}/boot/sysobj.r
+ ${TOP_SRC_DIR}/boot/platforms.r
+
+ ${TOP_SRC_DIR}/mezz/boot-files.r
+
+ ${TOP_GENERATED_SRC_DIR}/boot/tmp-natives.r
+ ${TOP_SRC_DIR}/boot/typespec.r
+ ${TOP_SRC_DIR}/boot/root.r
+ ${TOP_SRC_DIR}/boot/task.r
+
+ # all of the files in boot-files.r
+ ${TOP_SRC_DIR}/mezz/base-constants.r
+ ${TOP_SRC_DIR}/mezz/base-funcs.r
+ ${TOP_SRC_DIR}/mezz/base-infix.r
+ ${TOP_SRC_DIR}/mezz/base-series.r
+ ${TOP_SRC_DIR}/mezz/base-files.r
+ ${TOP_SRC_DIR}/mezz/base-defs.r
+
+ ${TOP_SRC_DIR}/mezz/sys-base.r
+ ${TOP_SRC_DIR}/mezz/sys-ports.r
+ ${TOP_SRC_DIR}/mezz/sys-codec.r # export to lib!
+ ${TOP_SRC_DIR}/mezz/sys-load.r
+ ${TOP_SRC_DIR}/mezz/sys-start.r
+
+ ${TOP_SRC_DIR}/mezz/mezz-types.r
+ ${TOP_SRC_DIR}/mezz/mezz-func.r
+ ${TOP_SRC_DIR}/mezz/mezz-debug.r
+ ${TOP_SRC_DIR}/mezz/mezz-control.r
+ ${TOP_SRC_DIR}/mezz/mezz-save.r
+ ${TOP_SRC_DIR}/mezz/mezz-series.r
+ ${TOP_SRC_DIR}/mezz/mezz-files.r
+ ${TOP_SRC_DIR}/mezz/mezz-shell.r
+ ${TOP_SRC_DIR}/mezz/mezz-math.r
+ ${TOP_SRC_DIR}/mezz/mezz-help.r # move dump-obj!
+ ${TOP_SRC_DIR}/mezz/mezz-colors.r
+ ${TOP_SRC_DIR}/mezz/mezz-tail.r
+ ${TOP_SRC_DIR}/mezz/mezz-legacy.r
+
+ ${TOP_SRC_DIR}/mezz/prot-http.r
+ ${TOP_SRC_DIR}/mezz/prot-tls.r
+ )
+
+add_custom_command(OUTPUT
+ ${BOOT_OUTPUT}
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-boot.r OS_ID=${R3_OS_ID} OUTDIR=${TOP_GENERATED_SRC_DIR} GIT_COMMIT=${GIT_COMMIT}
+ DEPENDS
+ ${TOOLS_DIR}/make-boot.r
+ ${TOOL_DEPENDS}
+ ${BOOT_DEPENDS}
+ )
+
+set(REB_LIB_OUTPUT
+ ${TOP_GENERATED_SRC_DIR}/include/reb-lib.h
+ ${TOP_GENERATED_SRC_DIR}/include/reb-lib-lib.h
+ )
+
+set(REB_LIB_DEPENDS
+ ${TOOLS_DIR}/common.r
+ ${TOOLS_DIR}/common-parsers.r
+ ${TOOLS_DIR}/form-header.r
+ ${TOP_SRC_DIR}/boot/version.r
+ ${CORE_DIR}/a-lib.c
+ ${CORE_DIR}/f-extension.c
+ )
+
+add_custom_command(OUTPUT
+ ${REB_LIB_OUTPUT}
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-reb-lib.r OUTDIR=${TOP_GENERATED_SRC_DIR}
+ DEPENDS
+ ${TOOLS_DIR}/make-reb-lib.r
+ ${TOOL_DEPENDS}
+ ${REB_LIB_DEPENDS}
+ )
+
+set (GENERATED_CORE_SOURCE
+ ${CORE_GENERATED_DIR}/tmp-boot-block.c
+ ${CORE_GENERATED_DIR}/tmp-evaltypes.c
+ ${CORE_GENERATED_DIR}/tmp-maketypes.c
+ ${CORE_GENERATED_DIR}/tmp-comptypes.c
+ ${CORE_GENERATED_DIR}/tmp-symbols.c
+ )
+
+set (GENERATED_CORE_HEADER
+ ${GENERATED_HEADER}
+ ${REB_LIB_OUTPUT}
+ ${BOOT_HEADER}
+ ${EXT_CORE_OUTPUT}
+ )
+
+#HOST
+set(EXT_OS_OUTPUT
+ ${TOP_GENERATED_SRC_DIR}/include/host-lib.h
+ ${TOP_GENERATED_SRC_DIR}/include/host-table.inc
+ ${TOP_GENERATED_SRC_DIR}/os/tmp-host-start.inc
+ )
+
+macro(add_module name source other)
+ string (TOUPPER ${name} u_name)
+ string (TOLOWER ${name} l_name)
+
+ set (GENERATED_MOD_${u_name}_HEADER
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-mod-${l_name}-first.h
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-mod-${l_name}-last.h
+ )
+ add_custom_command(OUTPUT
+ ${GENERATED_MOD_${u_name}_HEADER}
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-ext-natives.r SRC=${source} MODULE=${name} OUTDIR=${TOP_GENERATED_SRC_DIR}
+ DEPENDS
+ ${TOOL_DEPENDS}
+ ${TOOLS_DIR}/make-ext-natives.r
+ ${source}
+ )
+
+ set (MODULE_${u_name}_SOURCE ${source} ${other})
+ set_source_files_properties(
+ ${GENERATED_MOD_${u_name}_HEADER}
+ PROPERTIES
+ HEADER_FILE_ONLY TRUE
+ )
+endmacro (add_module)
+
+macro(add_extension libname name can_be_module source modules init_script includes definitions)
+ string (TOUPPER ${name} u_name)
+ string (TOLOWER ${name} l_name)
+ if (${can_be_module})
+ set (R3_EXT_${u_name} "Y" CACHE STRING "Build with extension ${l_name} ([Y], M or N)")
+ else ()
+ option (R3_EXT_${u_name} "Build with extension ${l_name}" TRUE)
+ endif ()
+
+ if ((${can_be_module}
+ AND (R3_EXT_${u_name} STREQUAL "M"
+ OR R3_EXT_${u_name} STREQUAL "Y")
+ ) OR ((NOT ${can_be_module}) AND R3_EXT_${u_name}))
+ set(MODULE_SOURCES "")
+ set(GENERATED_MODULE_HEADERS "")
+ foreach (mod ${modules})
+ string (TOUPPER ${mod} u_mod_name)
+ list(APPEND MODULE_SOURCES "${MODULE_${u_mod_name}_SOURCE}")
+ list(APPEND GENERATED_MODULE_HEADERS "${GENERATED_MOD_${u_mod_name}_HEADER}")
+ endforeach(mod)
+
+ set(R3_EXT_${u_name}_SOURCES
+ ${source} ${MODULE_SOURCES} ${GENERATED_MODULE_HEADERS})
+
+ set_source_files_properties(
+ ${GENERATED_MODULE_HEADERS}
+ PROPERTIES
+ HEADER_FILE_ONLY TRUE
+ )
+
+ message("init_script: ${init_script}")
+ if (NOT "${init_script}" STREQUAL "")
+ get_filename_component(script_ext ${init_script} EXT)
+ get_filename_component(script_name ${init_script} NAME)
+ get_filename_component(script_dir ${init_script} DIRECTORY)
+ message("script ext: ${script_ext}")
+ string(REPLACE ${script_ext} ".inc" INIT_SCRIPT_C ${script_name})
+ string(CONCAT DEST ${script_dir} "/tmp-" ${INIT_SCRIPT_C})
+ message("Generating: ${DEST}")
+ add_custom_command(OUTPUT
+ ${DEST}
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-ext-init.r SRC=${init_script} DEST=${DEST}
+ DEPENDS
+ ${TOOLS_DIR}/make-ext-init.r
+ ${TOOL_DEPENDS}
+ )
+
+ list(APPEND R3_EXT_${u_name}_SOURCES ${DEST})
+ set_source_files_properties(${DEST} PROPERTIES HEADER_FILE_ONLY TRUE)
+ endif ()
+
+ if (R3_CPP)
+ set_property(SOURCE ${R3_EXT_${u_name}_SOURCES} PROPERTY LANGUAGE CXX)
+ endif (R3_CPP)
+
+ set(defs "${definitions}") #it seems that macro input can't be modified, so make a copy here
+ if (R3_EXT_${u_name} STREQUAL "M")
+ if (NOT ${can_be_module}) #sanity check
+ message (FATAL "Wrong configuration: ${name} can not be an external extension")
+ endif ()
+ message("Building ${name} as an external extension")
+ add_library(${libname} SHARED ${R3_EXT_${u_name}_SOURCES})
+ target_link_libraries(${libname} r3-core)
+ add_dependencies(${libname} r3-core)
+ list(APPEND defs "EXT_DLL")
+ elseif ((${can_be_module} AND R3_EXT_${u_name} STREQUAL "Y")
+ OR ((NOT ${can_be_module}) AND R3_EXT_${u_name}))
+ message("Building ${name} into the executable")
+ add_library(${libname} OBJECT ${R3_EXT_${u_name}_SOURCES})
+
+ #setup the dependency for the files included by sys-core.h
+ set_source_files_properties(
+ ${source}
+ PROPERTIES
+ OBJECT_DEPENDS "${BOOT_HEADER};${GENERATED_HEADER};${EXT_OS_OUTPUT}"
+ )
+
+ list(APPEND BOOT_EXTENSIONS ${name})
+ list(APPEND EXT_OBJECTS "$")
+ endif ()
+ target_include_directories(${libname} PUBLIC ${includes})
+ target_compile_definitions(${libname} PUBLIC ${defs})
+ else ()
+ message("${name} is not built")
+ endif ()
+endmacro(add_extension)
+
+
+#<-------------- modules (put all add_module in this section) --------------->
+
+# CRYPT extension
+#
+# Crypt has to be built-in because TLS (loaded by the host at boot time)
+# requires it, or RC4 and RSA natives will not be bound properly.
+#
+add_module(
+ Crypt
+ "${EXT_DIR}/crypt/mod-crypt.c"
+ "${EXT_DIR}/crypt/aes/aes.c;${EXT_DIR}/crypt/bigint/bigint.c;${EXT_DIR}/crypt/dh/dh.c;${EXT_DIR}/crypt/rc4/rc4.c;${EXT_DIR}/crypt/rsa/rsa.c;${EXT_DIR}/crypt/sha256/sha256.c"
+)
+add_extension(
+ r3-crypt Crypt FALSE "${EXT_DIR}/crypt/ext-crypt.c" "Crypt" "${EXT_DIR}/crypt/ext-crypt-init.reb"
+ "${TOP_GENERATED_SRC_DIR}/include;${TOP_SRC_DIR}/include;${FFI_INCLUDE_DIRS};${INC}"
+ "${COMMON_MACROS}"
+)
+if (TO_WINDOWS AND ${R3_EXT_CRYPT} STREQUAL "M")
+ target_link_libraries(r3-crypt "Ws2_32.lib")
+endif ()
+
+# CALL extension
+#
+add_module(
+ Process
+ "${EXT_DIR}/process/mod-process.c"
+ ""
+)
+add_extension(
+ r3-process Process TRUE "${EXT_DIR}/process/ext-process.c" "Process" "${EXT_DIR}/process/ext-process-init.reb"
+ "${TOP_GENERATED_SRC_DIR}/include;${TOP_SRC_DIR}/include;${FFI_INCLUDE_DIRS};${INC}"
+ "${COMMON_MACROS}"
+)
+
+# PNG extension
+#
+add_module(
+ LodePNG
+ "${EXT_DIR}/png/mod-lodepng.c"
+ "${EXT_DIR}/png/lodepng.c;"
+)
+add_module(
+ uPNG
+ "${EXT_DIR}/png/u-png.c"
+ ""
+)
+add_extension(
+ r3-png PNG TRUE "${EXT_DIR}/png/ext-png.c" "LodePNG;uPNG" ""
+ "${TOP_GENERATED_SRC_DIR}/include;${TOP_SRC_DIR}/include;${FFI_INCLUDE_DIRS};${INC}"
+ "${COMMON_MACROS}"
+)
+
+# GIF extension
+#
+add_module(
+ GIF
+ "${EXT_DIR}/gif/mod-gif.c"
+ ""
+)
+add_extension(
+ r3-gif GIF TRUE "${EXT_DIR}/gif/ext-gif.c" "GIF" ""
+ "${TOP_GENERATED_SRC_DIR}/include;${TOP_SRC_DIR}/include;${FFI_INCLUDE_DIRS};${INC}"
+ "${COMMON_MACROS}"
+)
+
+# BMP extension
+#
+add_module(
+ BMP
+ "${EXT_DIR}/bmp/mod-bmp.c"
+ ""
+)
+add_extension(
+ r3-bmp BMP TRUE "${EXT_DIR}/bmp/ext-bmp.c" "BMP" ""
+ "${TOP_GENERATED_SRC_DIR}/include;${TOP_SRC_DIR}/include;${FFI_INCLUDE_DIRS};${INC}"
+ "${COMMON_MACROS}"
+)
+
+# JPG extension
+#
+add_module(
+ JPG
+ "${EXT_DIR}/jpg/mod-jpg.c"
+ "${EXT_DIR}/jpg/u-jpg.c"
+)
+add_extension(
+ r3-jpg JPG TRUE "${EXT_DIR}/jpg/ext-jpg.c" "JPG" ""
+ "${TOP_GENERATED_SRC_DIR}/include;${TOP_SRC_DIR}/include;${FFI_INCLUDE_DIRS};${INC}"
+ "${COMMON_MACROS}"
+)
+
+# Locale extension
+#
+add_module(
+ Locale
+ "${EXT_DIR}/locale/mod-locale.c"
+ ""
+)
+add_extension(
+ r3-locale Locale TRUE "${EXT_DIR}/locale/ext-locale.c" "Locale" "${EXT_DIR}/locale/ext-locale-init.reb"
+ "${TOP_GENERATED_SRC_DIR}/include;${TOP_SRC_DIR}/include;${FFI_INCLUDE_DIRS};${INC}"
+ "${COMMON_MACROS}"
+)
+
+#<------------- end of modules --------->
+
+string(REPLACE ";" "," BOOT_EXTENSION_LIST "${BOOT_EXTENSIONS}")
+SET(BOOT_MODULE_HEADER ${TOP_GENERATED_SRC_DIR}/include/tmp-boot-extensions.h)
+add_custom_command(OUTPUT
+ ${BOOT_MODULE_HEADER}
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-boot-ext-header.r EXTENSIONS=${BOOT_EXTENSION_LIST} OUTDIR=${TOP_GENERATED_SRC_DIR}
+ DEPENDS
+ ${TOOL_DEPENDS}
+ ${TOOLS_DIR}/make-boot-ext-header.r
+ )
+
+if (R3_WITH_TCC)
+ enable_language(ASM)
+ if (XCODE) #Xcode has problem with EXCLUDE_FROM_ALL
+ add_subdirectory(${TCC_DIR} ${CMAKE_CURRENT_BINARY_DIR}/tcc)
+ else ()
+ add_subdirectory(${TCC_DIR} ${CMAKE_CURRENT_BINARY_DIR}/tcc EXCLUDE_FROM_ALL)
+ #add_subdirectory(${TCC_DIR} ${CMAKE_CURRENT_BINARY_DIR}/tcc)
+ endif ()
+ list (APPEND INC ${TCC_DIR})
+
+ set (TCC_ARGS "")
+ foreach (macro ${COMMON_MACROS})
+ list(APPEND TCC_ARGS "-D${macro}")
+ endforeach(macro)
+ foreach (macro ${FFI_INCLUDE_DIRS})
+ list(APPEND TCC_ARGS "-I${macro}")
+ endforeach(macro)
+
+ string (TOLOWER "${CMAKE_BUILD_TYPE}" build_type)
+
+ if ("${build_type}" STREQUAL "debug")
+ set(tcc_c_flags "${CMAKE_C_FLAGS_DEBUG}")
+ elseif ("${build_type}" STREQUAL "minsizerel")
+ set(tcc_c_flags "${CMAKE_C_FLAGS_MINSIZEREL}")
+ elseif ("${build_type}" STREQUAL "relwithdebinfo")
+ set(tcc_c_flags "${CMAKE_C_FLAGS_RELWITHDEBINFO}")
+ elseif ("${build_type}" STREQUAL "release")
+ set(tcc_c_flags "${CMAKE_C_FLAGS_RELEASE}")
+ else ()
+ message (FATAL_ERROR "Unknown CMAKE_BUILD_TYPE: ${build_type}")
+ endif ()
+
+ #flags needs to be a list
+ string(REGEX MATCH "[-/][DI][ \t]*[^ \t]+" interested "${tcc_c_flags}")
+ string(REGEX REPLACE "[-/]([DI])[ \t]*" "-\\1" no_spaces "${interested}")
+
+ string(REGEX REPLACE "[ \t]+" ";" tcc_c_flag_list "${no_spaces}")
+ #message("cflags: ${tcc_c_flag_list}")
+
+ set (SYS_CORE_PREP ${TOP_GENERATED_SRC_DIR}/include/sys-core.i)
+ set (SYS_CORE_HEADER ${TOP_SRC_DIR}/include/sys-core.h)
+
+ set (TCC_DEPENDS "libtcc")
+ message("HOST: ${CMAKE_HOST_SYSTEM} SYSTEM: ${CMAKE_SYSTEM}")
+ if ("${CMAKE_HOST_SYSTEM}" STREQUAL "${CMAKE_SYSTEM}") #native build
+ #
+ # Using `get_target_property(TCC_EXE tcc LOCATION)` causes an error
+ # Explained at https://cmake.org/cmake/help/v3.0/policy/CMP0026.html
+ #
+ set(TCC_EXE "tcc")
+
+ list(APPEND TCC_DEPENDS "tcc")
+ else () #cross-compile
+ set(TCC_EXE ${CMAKE_CURRENT_BINARY_DIR}/cross-tcc)
+ if (NOT EXISTS ${TCC_EXE})
+ message (FATAL_ERROR "Can't find tcc at: ${TCC_EXE}")
+ endif ()
+ list(APPEND tcc_c_flag_list "-nostdlib")
+ endif ()
+ list(APPEND TCC_DEPENDS "r3_libtcc1")
+
+ if (TO_WINDOWS)
+ list(APPEND tcc_c_flag_list "-I${TCC_DIR}/win32/include")
+ list(APPEND tcc_c_flag_list "-DPVAR=TVAR;-DTVAR=extern __attribute__((dllimport))")
+ elseif(TO_ANDROID)
+ list(APPEND tcc_c_flag_list "-I${ANDROID_SYSROOT}/usr/include")
+
+ #FIXME: pretend to be GCC, or it will fail:
+ #In file included from ../src/include/sys-core.h:54:
+ #In file included from /opt/android-ndk/platforms/android-16/arch-arm/usr/include/stdlib.h:31:
+ #/opt/android-ndk/platforms/android-16/arch-arm/usr/include/sys/cdefs.h:277: error: #error "No function renaming possible"
+ #Not sure what problem it could cause, but it worked for %tests/misc/fib.r
+ list(APPEND tcc_c_flag_list "-D__GNUC__")
+ endif ()
+
+ list(APPEND tcc_c_flag_list "-DREN_C_STDIO_OK;-UHAVE_ASAN_INTERFACE_H") #allow stdio.h
+ message("cflags: ${tcc_c_flags}")
+
+ add_custom_command(OUTPUT
+ ${SYS_CORE_PREP}
+ COMMAND ${TCC_EXE} -E -dD -o ${SYS_CORE_PREP} ${SYS_CORE_HEADER} -I${TCC_DIR}/include -I${TOP_GENERATED_SRC_DIR}/include -I${TOP_SRC_DIR}/include ${TCC_ARGS} ${tcc_c_flag_list}
+ DEPENDS
+ ${TCC_DEPENDS}
+ ${TOOLS_DIR}/make-embedded-header.r
+ ${BOOT_OUTPUT}
+ ${HEADER_OUTPUT}
+ ${SYS_CORE_HEADER}
+ ${TOP_GENERATED_SRC_DIR}/include/host-lib.h
+ ${TOP_GENERATED_SRC_DIR}/include/tmp-funcs.h
+ VERBATIM
+ )
+
+ add_custom_command(OUTPUT
+ ${CORE_GENERATED_DIR}/e-embedded-header.c
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-embedded-header.r OUTDIR=${TOP_GENERATED_SRC_DIR}
+ DEPENDS
+ ${TOOLS_DIR}/make-embedded-header.r
+ ${SYS_CORE_PREP}
+ )
+
+ list (APPEND GENERATED_CORE_SOURCE ${CORE_GENERATED_DIR}/e-embedded-header.c)
+
+endif()
+
+#HOST
+set_source_files_properties(
+ ${TOP_GENERATED_SRC_DIR}/include/host-table.inc
+ ${GENERATED_EXT_HEADER}
+ ${BOOT_MODULE_HEADER}
+ PROPERTIES
+ HEADER_FILE_ONLY TRUE
+ )
+set_source_files_properties(
+ ${CORE_HEADER}
+ ${GENERATED_CORE_HEADER}
+ PROPERTIES
+ HEADER_FILE_ONLY TRUE
+ )
+
+set(EXT_OS_DEPENDS
+ ${TOP_SRC_DIR}/boot/version.r
+ ${TOOLS_DIR}/common.r
+ ${TOOLS_DIR}/common-parsers.r
+ ${TOOLS_DIR}/form-header.r
+ ${TOOLS_DIR}/file-base.r
+ ${OS_SOURCE}
+ )
+
+if (R3_BUILD_VIEW)
+ add_custom_command(OUTPUT
+ ${EXT_OS_OUTPUT}
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-os-ext.r OS_ID=${R3_OS_ID} GFX=1 OUTDIR=${TOP_GENERATED_SRC_DIR}
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-host-init.r OS_ID=${R3_OS_ID} OUTDIR=${TOP_GENERATED_SRC_DIR}
+ DEPENDS
+ ${TOOLS_DIR}/make-os-ext.r
+ ${TOOLS_DIR}/make-host-init.r
+ ${TOP_SRC_DIR}/os/host-start.r
+ ${TOOL_DEPENDS}
+ ${EXT_OS_DEPENDS}
+ )
+else ()
+ add_custom_command(OUTPUT
+ ${EXT_OS_OUTPUT}
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-os-ext.r OS_ID=${R3_OS_ID} OUTDIR=${TOP_GENERATED_SRC_DIR}
+ COMMAND ${REBOL} ${TOOLS_DIR}/make-host-init.r OS_ID=${R3_OS_ID} OUTDIR=${TOP_GENERATED_SRC_DIR}
+ DEPENDS
+ ${TOOLS_DIR}/make-os-ext.r
+ ${TOOLS_DIR}/make-host-init.r
+ ${TOP_SRC_DIR}/os/host-start.r
+ ${TOOL_DEPENDS}
+ ${EXT_OS_DEPENDS}
+ )
+endif ()
+
+set (OS_SOURCE
+ ${OS_DIR}/host-main.c
+ ${OS_DIR}/host-device.c
+ ${OS_DIR}/host-stdio.c
+ ${OS_DIR}/host-table.c
+ ${OS_DIR}/dev-net.c
+ ${OS_DIR}/dev-dns.c
+ ${OS_DIR}/generic/host-memory.c
+ ${CORE_PLATFORM_SOURCE}
+ )
+
+set (GENERATED_OS_SOURCE
+ ${EXT_OS_SOURCE}
+ ${BOOT_MODULE_HEADER}
+ )
+
+if(NOT (MSVC_IDE OR XCODE))
+ add_custom_target(clean-generated COMMAND ${CMAKE_COMMAND} -P ${CMAKE_CURRENT_SOURCE_DIR}/clean-generated.cmake)
+ add_custom_target(clean-all
+ COMMAND ${CMAKE_BUILD_TOOL} clean
+ COMMAND ${CMAKE_COMMAND} -P ${CMAKE_CURRENT_SOURCE_DIR}/clean-generated.cmake
+ )
+endif()
+
+#get rid of '-rdynamic' option at link stage
+#Do not add flags to export symbols from executables without the ENABLE_EXPORTS target property.
+#https://cmake.org/cmake/help/v3.4/policy/CMP0065.html
+if (POLICY CMP0065)
+ cmake_policy(SET CMP0065 NEW)
+else ()
+ if (LINUX)
+ if (CMAKE_COMILER_IS_GNUCC)
+ set(CMAKE_SHARED_LIBRARY_LINK_C_FLAGS "")
+ endif()
+ if (CMAKE_COMILER_IS_GNUCXX)
+ set(CMAKE_SHARED_LIBRARY_LINK_CXX_FLAGS "")
+ endif ()
+ endif (LINUX)
+endif ()
+
+add_library(libr3_core_core OBJECT ${CORE_SOURCE} ${GENERATED_CORE_SOURCE} ${CORE_HEADER} ${GENERATED_CORE_HEADER})
+
+set (HOST_SOURCE
+ ${OS_SOURCE}
+ ${GENERATED_OS_SOURCE}
+ )
+
+if(R3_WITH_TCC)
+ add_executable(r3-core $ $ $ ${EXT_OBJECTS} ${HOST_SOURCE})
+else()
+ add_executable(r3-core $ ${EXT_OBJECTS} ${HOST_SOURCE})
+endif()
+
+set_target_properties(r3-core PROPERTIES ENABLE_EXPORTS TRUE)
+
+target_include_directories(libr3_core_core PUBLIC
+ ${TOP_GENERATED_SRC_DIR}/include
+ ${TOP_SRC_DIR}/include
+ ${FFI_INCLUDE_DIRS}
+ ${INC}
+ )
+target_include_directories(r3-core PUBLIC
+ ${TOP_GENERATED_SRC_DIR}/include
+ ${TOP_GENERATED_SRC_DIR}/os
+ ${TOP_SRC_DIR}/include
+ ${FFI_INCLUDE_DIRS}
+ ${INC}
+ )
+target_compile_definitions(libr3_core_core PUBLIC
+ REB_API
+ REB_CORE
+ ${COMMON_MACROS})
+
+if (TO_WINDOWS)
+ target_compile_definitions(libr3_core_core PRIVATE ZLIB_INTERNAL)
+
+ #WINSYS_WIN32 is needed for dev-event.c
+ target_compile_definitions(r3-core PUBLIC REB_CORE WINSYS_WIN32 ${COMMON_MACROS})
+else ()
+ target_compile_definitions(r3-core PUBLIC REB_CORE ${COMMON_MACROS})
+endif ()
+target_compile_definitions(r3-core PRIVATE REB_EXE)
+
+set (EXTRA_C_FLAGS "")
+set (R3_CORE_SOURCE
+ ${CORE_SOURCE}
+ ${GENERATED_CORE_SOURCE}
+ ${HOST_SOURCE}
+ )
+# Build as C by default, but there are extra checks if you build as C++11
+# (fewer interesting checks if you only build as C++98)
+#
+if (R3_CPP)
+ set_property(SOURCE ${R3_CORE_SOURCE} PROPERTY LANGUAGE CXX)
+ if ("${CMAKE_CXX_COMPILER_ID}" STREQUAL "Clang")
+ #to get rid of this clang warning:
+ #warning: treating 'c' input as 'c++' when in C++ mode, this behavior is deprecated
+ set(EXTRA_C_FLAGS "${EXTRA_C_FLAGS} -x c++")
+ #warning: 50 enumeration values not handled in switch: 'REB_0', 'REB_FUNCTION', 'REB_BAR'... [-Wswitch]
+ set(EXTRA_C_FLAGS "${EXTRA_C_FLAGS} -Wno-switch")
+ endif ()
+ set_target_properties(r3-core PROPERTIES LINKER_LANGUAGE CXX)
+else ()
+ if ("${CMAKE_C_COMPILER_ID}" STREQUAL "Clang")
+ set(EXTRA_C_FLAGS "${EXTRA_C_FLAGS} -Wno-switch")
+ endif()
+endif()
+message("Extra compile flags: ${EXTRA_C_FLAGS}")
+set_property(SOURCE ${R3_CORE_SOURCE} PROPERTY COMPILE_FLAGS ${EXTRA_C_FLAGS})
+
+if (DEFINED LINK_FLAGS)
+ set_target_properties(r3-core PROPERTIES LINK_FLAGS ${LINK_FLAGS})
+endif()
+
+if (TO_ANDROID5)
+ list(APPEND LIBS "-fPIC -fPIE")
+endif ()
+
+target_link_libraries(r3-core ${LIBS} ${FFI_LIBRARIES})
diff --git a/make/Toolchain-cross-mingw32-linux.cmake b/make/Toolchain-cross-mingw32-linux.cmake
new file mode 100644
index 0000000000..92e729b5e5
--- /dev/null
+++ b/make/Toolchain-cross-mingw32-linux.cmake
@@ -0,0 +1,29 @@
+# the name of the target operating system
+SET(CMAKE_SYSTEM_NAME Windows)
+SET(CMAKE_SYSTEM_PROCESSOR "X86")
+
+# Choose an appropriate compiler prefix
+
+# for classical mingw32
+# see http://www.mingw.org/
+#set(COMPILER_PREFIX "i586-mingw32msvc")
+
+# for 32 or 64 bits mingw-w64
+# see http://mingw-w64.sourceforge.net/
+set(COMPILER_PREFIX "i686-w64-mingw32")
+
+# which compilers to use for C and C++
+find_program(CMAKE_RC_COMPILER NAMES ${COMPILER_PREFIX}-windres)
+find_program(CMAKE_C_COMPILER NAMES ${COMPILER_PREFIX}-gcc)
+find_program(CMAKE_CXX_COMPILER NAMES ${COMPILER_PREFIX}-g++)
+
+
+# here is the target environment located
+SET(CMAKE_FIND_ROOT_PATH /usr/${COMPILER_PREFIX} ${USER_ROOT_PATH})
+
+# adjust the default behaviour of the FIND_XXX() commands:
+# search headers and libraries in the target environment, search
+# programs in the host environment
+set(CMAKE_FIND_ROOT_PATH_MODE_PROGRAM NEVER)
+set(CMAKE_FIND_ROOT_PATH_MODE_LIBRARY ONLY)
+set(CMAKE_FIND_ROOT_PATH_MODE_INCLUDE ONLY)
diff --git a/make/Toolchain-cross-mingw64-linux.cmake b/make/Toolchain-cross-mingw64-linux.cmake
new file mode 100644
index 0000000000..87dbba39c8
--- /dev/null
+++ b/make/Toolchain-cross-mingw64-linux.cmake
@@ -0,0 +1,27 @@
+# the name of the target operating system
+SET(CMAKE_SYSTEM_NAME Windows)
+SET(CMAKE_SYSTEM_PROCESSOR "x86_64")
+
+# Choose an appropriate compiler prefix
+
+# for classical mingw32
+# see http://www.mingw.org/
+#set(COMPILER_PREFIX "i586-mingw32msvc")
+
+# for 32 or 64 bits mingw-w64
+# see http://mingw-w64.sourceforge.net/
+set(COMPILER_PREFIX "x86_64-w64-mingw32")
+
+# which compilers to use for C and C++
+find_program(CMAKE_RC_COMPILER NAMES ${COMPILER_PREFIX}-windres)
+find_program(CMAKE_C_COMPILER NAMES ${COMPILER_PREFIX}-gcc)
+find_program(CMAKE_CXX_COMPILER NAMES ${COMPILER_PREFIX}-g++)
+
+SET(CMAKE_FIND_ROOT_PATH /usr/${COMPILER_PREFIX} ${USER_ROOT_PATH})
+
+# adjust the default behaviour of the FIND_XXX() commands:
+# search headers and libraries in the target environment, search
+# programs in the host environment
+set(CMAKE_FIND_ROOT_PATH_MODE_PROGRAM NEVER)
+set(CMAKE_FIND_ROOT_PATH_MODE_LIBRARY ONLY)
+set(CMAKE_FIND_ROOT_PATH_MODE_INCLUDE ONLY)
diff --git a/make/makefile b/make/makefile
deleted file mode 100644
index fa91ce0ea3..0000000000
--- a/make/makefile
+++ /dev/null
@@ -1,497 +0,0 @@
-# REBOL Makefile -- Generated by make-make.r (do not edit) on 5-Oct-2013/20:20:10+2:00
-# This makefile is intentional kept simple to make builds possible on
-# a wider range of target platforms.
-
-# To regenerate this file:
-# make make
-
-# To generate this file for a different platform, check systems.r file
-# and provide an OS_ID (from the systems table). Linux 2.5 for example:
-# make make OS_ID=0.4.3
-
-# To cross compile using a different toolchain and include files:
-# $TOOLS - should point to bin where gcc is found
-# $INCL - should point to the dir for includes
-# Example make:
-# make TOOLS=~/amiga/amiga/bin/ppc-amigaos- INCL=/SDK/newlib/include
-
-# For the build toolchain:
-CC= $(TOOLS)gcc
-NM= $(TOOLS)nm
-STRIP= $(TOOLS)strip
-
-# CP allows different copy progs:
-CP= cp
-# LS allows different ls progs:
-LS= ls -l
-# UP - some systems do not use ../
-UP= ..
-# CD - some systems do not use ./
-CD= ./
-# Special tools:
-T= $(UP)/src/tools
-# Paths used by make:
-S= ../src
-R= $S/core
-
-INCL ?= .
-I= -I$(INCL) -I$S/include/
-
-TO_OS?= TO_LINUX
-OS_ID?= 0.4.4
-BIN_SUFFIX=
-RAPI_FLAGS= -O2 -fvisibility=hidden -m32
-HOST_FLAGS= -DREB_EXE -O2 -fvisibility=hidden -m32 -D_FILE_OFFSET_BITS=64
-RLIB_FLAGS=
-
-# Flags for core and for host:
-RFLAGS= -c -D$(TO_OS) -DREB_API $(RAPI_FLAGS) $I
-HFLAGS= -c -D$(TO_OS) -DREB_CORE $(HOST_FLAGS) $I
-CLIB= -ldl -m32 -lm
-
-# REBOL is needed to build various include files:
-REBOL_TOOL= r3-make
-REBOL= $(CD)$(REBOL_TOOL) -qs
-
-# For running tests, ship, build, etc.
-R3= $(CD)r3$(BIN_SUFFIX) -qs
-
-### Build targets:
-top:
- $(MAKE) r3$(BIN_SUFFIX)
-
-update:
- -cd $(UP)/; cvs -q update src
-
-make:
- $(REBOL) $T/make-make.r $(OS_ID)
-
-clean:
- @-rm -rf libr3.so objs/
-
-all:
- $(MAKE) clean
- $(MAKE) prep
- $(MAKE) r3$(BIN_SUFFIX)
- $(MAKE) lib
- $(MAKE) host$(BIN_SUFFIX)
-
-prep:
- $(REBOL) $T/make-headers.r
- $(REBOL) $T/make-boot.r $(OS_ID)
- $(REBOL) $T/make-host-init.r
- $(REBOL) $T/make-os-ext.r # ok, but not always
- $(REBOL) $T/make-host-ext.r
- $(REBOL) $T/make-reb-lib.r
-
-### Provide more info if make fails due to no local Rebol build tool:
-tmps: $S/include/tmp-bootdefs.h
-
-$S/include/tmp-bootdefs.h: $(REBOL_TOOL)
- $(MAKE) prep
-
-$(REBOL_TOOL):
- @echo
- @echo "*** ERROR: Missing $(REBOL_TOOL) to build various tmp files."
- @echo "*** Download Rebol 3 and copy it here as $(REBOL_TOOL), then"
- @echo "*** make prep. Or, make prep on some other machine and copy"
- @echo "*** the src/include files here. See README for details."
- @echo
- false
-
-### Post build actions
-purge:
- -rm libr3.*
- -rm host$(BIN_SUFFIX)
- $(MAKE) lib
- $(MAKE) host$(BIN_SUFFIX)
-
-test:
- $(CP) r3$(BIN_SUFFIX) $(UP)/src/tests/
- $(R3) $S/tests/test.r
-
-install:
- sudo cp r3$(BIN_SUFFIX) /usr/local/bin
-
-ship:
- $(R3) $S/tools/upload.r
-
-build: libr3.so
- $(R3) $S/tools/make-build.r
-
-cln:
- rm libr3.* r3.o
-
-check:
- $(STRIP) -s -o r3.s r3$(BIN_SUFFIX)
- $(STRIP) -x -o r3.x r3$(BIN_SUFFIX)
- $(STRIP) -X -o r3.X r3$(BIN_SUFFIX)
- $(LS) r3*
-
-OBJS = objs/a-constants.o objs/a-globals.o objs/a-lib.o objs/b-boot.o \
- objs/b-init.o objs/c-do.o objs/c-error.o objs/c-frame.o \
- objs/c-function.o objs/c-port.o objs/c-task.o objs/c-word.o \
- objs/d-crash.o objs/d-dump.o objs/d-print.o objs/f-blocks.o \
- objs/f-deci.o objs/f-dtoa.o objs/f-enbase.o objs/f-extension.o \
- objs/f-math.o objs/f-modify.o objs/f-qsort.o objs/f-random.o \
- objs/f-round.o objs/f-series.o objs/f-stubs.o objs/l-scan.o \
- objs/l-types.o objs/m-gc.o objs/m-pools.o objs/m-series.o \
- objs/n-control.o objs/n-data.o objs/n-io.o objs/n-loop.o \
- objs/n-math.o objs/n-sets.o objs/n-strings.o objs/n-system.o \
- objs/p-clipboard.o objs/p-console.o objs/p-dir.o objs/p-dns.o \
- objs/p-event.o objs/p-file.o objs/p-net.o objs/s-cases.o \
- objs/s-crc.o objs/s-file.o objs/s-find.o objs/s-make.o \
- objs/s-mold.o objs/s-ops.o objs/s-trim.o objs/s-unicode.o \
- objs/t-bitset.o objs/t-block.o objs/t-char.o objs/t-datatype.o \
- objs/t-date.o objs/t-decimal.o objs/t-event.o objs/t-function.o \
- objs/t-gob.o objs/t-image.o objs/t-integer.o objs/t-logic.o \
- objs/t-map.o objs/t-money.o objs/t-none.o objs/t-object.o \
- objs/t-pair.o objs/t-port.o objs/t-string.o objs/t-time.o \
- objs/t-tuple.o objs/t-typeset.o objs/t-utype.o objs/t-vector.o \
- objs/t-word.o objs/u-bmp.o objs/u-compress.o objs/u-dialect.o \
- objs/u-gif.o objs/u-jpg.o objs/u-md5.o objs/u-parse.o \
- objs/u-png.o objs/u-sha1.o objs/u-zlib.o
-
-HOST = objs/host-main.o objs/host-args.o objs/host-device.o objs/host-stdio.o \
- objs/dev-net.o objs/dev-dns.o objs/host-lib.o objs/host-readline.o \
- objs/dev-stdio.o objs/dev-event.o objs/dev-file.o
-
-
-# Directly linked r3 executable:
-r3$(BIN_SUFFIX): tmps objs $(OBJS) $(HOST)
- $(CC) -o r3$(BIN_SUFFIX) $(OBJS) $(HOST) $(CLIB)
- $(STRIP) r3$(BIN_SUFFIX)
- -$(NM) -a r3$(BIN_SUFFIX)
- $(LS) r3$(BIN_SUFFIX)
-
-objs:
- mkdir -p objs
-
-lib: libr3.so
-
-# PUBLIC: Shared library:
-# NOTE: Did not use "-Wl,-soname,libr3.so" because won't find .so in local dir.
-libr3.so: $(OBJS)
- $(CC) -o libr3.so -shared $(OBJS) $(CLIB)
- $(STRIP) libr3.so
- -$(NM) -D libr3.so
- -$(NM) -a libr3.so | grep "Do_"
- $(LS) libr3.so
-
-# PUBLIC: Host using the shared lib:
-host$(BIN_SUFFIX): $(HOST)
- $(CC) -o host$(BIN_SUFFIX) $(HOST) libr3.so $(CLIB)
- $(STRIP) host$(BIN_SUFFIX)
- $(LS) host$(BIN_SUFFIX)
- echo "export LD_LIBRARY_PATH=.:$LD_LIBRARY_PATH"
-
-### File build targets:
-b-boot.c: $(SRC)/boot/boot.r
- $(REBOL) -sqw $(SRC)/tools/make-boot.r
-
-objs/a-constants.o: $R/a-constants.c
- $(CC) $R/a-constants.c $(RFLAGS) -o objs/a-constants.o
-
-objs/a-globals.o: $R/a-globals.c
- $(CC) $R/a-globals.c $(RFLAGS) -o objs/a-globals.o
-
-objs/a-lib.o: $R/a-lib.c
- $(CC) $R/a-lib.c $(RFLAGS) -o objs/a-lib.o
-
-objs/b-boot.o: $R/b-boot.c
- $(CC) $R/b-boot.c $(RFLAGS) -o objs/b-boot.o
-
-objs/b-init.o: $R/b-init.c
- $(CC) $R/b-init.c $(RFLAGS) -o objs/b-init.o
-
-objs/c-do.o: $R/c-do.c
- $(CC) $R/c-do.c $(RFLAGS) -o objs/c-do.o
-
-objs/c-error.o: $R/c-error.c
- $(CC) $R/c-error.c $(RFLAGS) -o objs/c-error.o
-
-objs/c-frame.o: $R/c-frame.c
- $(CC) $R/c-frame.c $(RFLAGS) -o objs/c-frame.o
-
-objs/c-function.o: $R/c-function.c
- $(CC) $R/c-function.c $(RFLAGS) -o objs/c-function.o
-
-objs/c-port.o: $R/c-port.c
- $(CC) $R/c-port.c $(RFLAGS) -o objs/c-port.o
-
-objs/c-task.o: $R/c-task.c
- $(CC) $R/c-task.c $(RFLAGS) -o objs/c-task.o
-
-objs/c-word.o: $R/c-word.c
- $(CC) $R/c-word.c $(RFLAGS) -o objs/c-word.o
-
-objs/d-crash.o: $R/d-crash.c
- $(CC) $R/d-crash.c $(RFLAGS) -o objs/d-crash.o
-
-objs/d-dump.o: $R/d-dump.c
- $(CC) $R/d-dump.c $(RFLAGS) -o objs/d-dump.o
-
-objs/d-print.o: $R/d-print.c
- $(CC) $R/d-print.c $(RFLAGS) -o objs/d-print.o
-
-objs/f-blocks.o: $R/f-blocks.c
- $(CC) $R/f-blocks.c $(RFLAGS) -o objs/f-blocks.o
-
-objs/f-deci.o: $R/f-deci.c
- $(CC) $R/f-deci.c $(RFLAGS) -o objs/f-deci.o
-
-objs/f-dtoa.o: $R/f-dtoa.c
- $(CC) $R/f-dtoa.c $(RFLAGS) -o objs/f-dtoa.o
-
-objs/f-enbase.o: $R/f-enbase.c
- $(CC) $R/f-enbase.c $(RFLAGS) -o objs/f-enbase.o
-
-objs/f-extension.o: $R/f-extension.c
- $(CC) $R/f-extension.c $(RFLAGS) -o objs/f-extension.o
-
-objs/f-math.o: $R/f-math.c
- $(CC) $R/f-math.c $(RFLAGS) -o objs/f-math.o
-
-objs/f-modify.o: $R/f-modify.c
- $(CC) $R/f-modify.c $(RFLAGS) -o objs/f-modify.o
-
-objs/f-qsort.o: $R/f-qsort.c
- $(CC) $R/f-qsort.c $(RFLAGS) -o objs/f-qsort.o
-
-objs/f-random.o: $R/f-random.c
- $(CC) $R/f-random.c $(RFLAGS) -o objs/f-random.o
-
-objs/f-round.o: $R/f-round.c
- $(CC) $R/f-round.c $(RFLAGS) -o objs/f-round.o
-
-objs/f-series.o: $R/f-series.c
- $(CC) $R/f-series.c $(RFLAGS) -o objs/f-series.o
-
-objs/f-stubs.o: $R/f-stubs.c
- $(CC) $R/f-stubs.c $(RFLAGS) -o objs/f-stubs.o
-
-objs/l-scan.o: $R/l-scan.c
- $(CC) $R/l-scan.c $(RFLAGS) -o objs/l-scan.o
-
-objs/l-types.o: $R/l-types.c
- $(CC) $R/l-types.c $(RFLAGS) -o objs/l-types.o
-
-objs/m-gc.o: $R/m-gc.c
- $(CC) $R/m-gc.c $(RFLAGS) -o objs/m-gc.o
-
-objs/m-pools.o: $R/m-pools.c
- $(CC) $R/m-pools.c $(RFLAGS) -o objs/m-pools.o
-
-objs/m-series.o: $R/m-series.c
- $(CC) $R/m-series.c $(RFLAGS) -o objs/m-series.o
-
-objs/n-control.o: $R/n-control.c
- $(CC) $R/n-control.c $(RFLAGS) -o objs/n-control.o
-
-objs/n-data.o: $R/n-data.c
- $(CC) $R/n-data.c $(RFLAGS) -o objs/n-data.o
-
-objs/n-io.o: $R/n-io.c
- $(CC) $R/n-io.c $(RFLAGS) -o objs/n-io.o
-
-objs/n-loop.o: $R/n-loop.c
- $(CC) $R/n-loop.c $(RFLAGS) -o objs/n-loop.o
-
-objs/n-math.o: $R/n-math.c
- $(CC) $R/n-math.c $(RFLAGS) -o objs/n-math.o
-
-objs/n-sets.o: $R/n-sets.c
- $(CC) $R/n-sets.c $(RFLAGS) -o objs/n-sets.o
-
-objs/n-strings.o: $R/n-strings.c
- $(CC) $R/n-strings.c $(RFLAGS) -o objs/n-strings.o
-
-objs/n-system.o: $R/n-system.c
- $(CC) $R/n-system.c $(RFLAGS) -o objs/n-system.o
-
-objs/p-clipboard.o: $R/p-clipboard.c
- $(CC) $R/p-clipboard.c $(RFLAGS) -o objs/p-clipboard.o
-
-objs/p-console.o: $R/p-console.c
- $(CC) $R/p-console.c $(RFLAGS) -o objs/p-console.o
-
-objs/p-dir.o: $R/p-dir.c
- $(CC) $R/p-dir.c $(RFLAGS) -o objs/p-dir.o
-
-objs/p-dns.o: $R/p-dns.c
- $(CC) $R/p-dns.c $(RFLAGS) -o objs/p-dns.o
-
-objs/p-event.o: $R/p-event.c
- $(CC) $R/p-event.c $(RFLAGS) -o objs/p-event.o
-
-objs/p-file.o: $R/p-file.c
- $(CC) $R/p-file.c $(RFLAGS) -o objs/p-file.o
-
-objs/p-net.o: $R/p-net.c
- $(CC) $R/p-net.c $(RFLAGS) -o objs/p-net.o
-
-objs/s-cases.o: $R/s-cases.c
- $(CC) $R/s-cases.c $(RFLAGS) -o objs/s-cases.o
-
-objs/s-crc.o: $R/s-crc.c
- $(CC) $R/s-crc.c $(RFLAGS) -o objs/s-crc.o
-
-objs/s-file.o: $R/s-file.c
- $(CC) $R/s-file.c $(RFLAGS) -o objs/s-file.o
-
-objs/s-find.o: $R/s-find.c
- $(CC) $R/s-find.c $(RFLAGS) -o objs/s-find.o
-
-objs/s-make.o: $R/s-make.c
- $(CC) $R/s-make.c $(RFLAGS) -o objs/s-make.o
-
-objs/s-mold.o: $R/s-mold.c
- $(CC) $R/s-mold.c $(RFLAGS) -o objs/s-mold.o
-
-objs/s-ops.o: $R/s-ops.c
- $(CC) $R/s-ops.c $(RFLAGS) -o objs/s-ops.o
-
-objs/s-trim.o: $R/s-trim.c
- $(CC) $R/s-trim.c $(RFLAGS) -o objs/s-trim.o
-
-objs/s-unicode.o: $R/s-unicode.c
- $(CC) $R/s-unicode.c $(RFLAGS) -o objs/s-unicode.o
-
-objs/t-bitset.o: $R/t-bitset.c
- $(CC) $R/t-bitset.c $(RFLAGS) -o objs/t-bitset.o
-
-objs/t-block.o: $R/t-block.c
- $(CC) $R/t-block.c $(RFLAGS) -o objs/t-block.o
-
-objs/t-char.o: $R/t-char.c
- $(CC) $R/t-char.c $(RFLAGS) -o objs/t-char.o
-
-objs/t-datatype.o: $R/t-datatype.c
- $(CC) $R/t-datatype.c $(RFLAGS) -o objs/t-datatype.o
-
-objs/t-date.o: $R/t-date.c
- $(CC) $R/t-date.c $(RFLAGS) -o objs/t-date.o
-
-objs/t-decimal.o: $R/t-decimal.c
- $(CC) $R/t-decimal.c $(RFLAGS) -o objs/t-decimal.o
-
-objs/t-event.o: $R/t-event.c
- $(CC) $R/t-event.c $(RFLAGS) -o objs/t-event.o
-
-objs/t-function.o: $R/t-function.c
- $(CC) $R/t-function.c $(RFLAGS) -o objs/t-function.o
-
-objs/t-gob.o: $R/t-gob.c
- $(CC) $R/t-gob.c $(RFLAGS) -o objs/t-gob.o
-
-objs/t-image.o: $R/t-image.c
- $(CC) $R/t-image.c $(RFLAGS) -o objs/t-image.o
-
-objs/t-integer.o: $R/t-integer.c
- $(CC) $R/t-integer.c $(RFLAGS) -o objs/t-integer.o
-
-objs/t-logic.o: $R/t-logic.c
- $(CC) $R/t-logic.c $(RFLAGS) -o objs/t-logic.o
-
-objs/t-map.o: $R/t-map.c
- $(CC) $R/t-map.c $(RFLAGS) -o objs/t-map.o
-
-objs/t-money.o: $R/t-money.c
- $(CC) $R/t-money.c $(RFLAGS) -o objs/t-money.o
-
-objs/t-none.o: $R/t-none.c
- $(CC) $R/t-none.c $(RFLAGS) -o objs/t-none.o
-
-objs/t-object.o: $R/t-object.c
- $(CC) $R/t-object.c $(RFLAGS) -o objs/t-object.o
-
-objs/t-pair.o: $R/t-pair.c
- $(CC) $R/t-pair.c $(RFLAGS) -o objs/t-pair.o
-
-objs/t-port.o: $R/t-port.c
- $(CC) $R/t-port.c $(RFLAGS) -o objs/t-port.o
-
-objs/t-string.o: $R/t-string.c
- $(CC) $R/t-string.c $(RFLAGS) -o objs/t-string.o
-
-objs/t-time.o: $R/t-time.c
- $(CC) $R/t-time.c $(RFLAGS) -o objs/t-time.o
-
-objs/t-tuple.o: $R/t-tuple.c
- $(CC) $R/t-tuple.c $(RFLAGS) -o objs/t-tuple.o
-
-objs/t-typeset.o: $R/t-typeset.c
- $(CC) $R/t-typeset.c $(RFLAGS) -o objs/t-typeset.o
-
-objs/t-utype.o: $R/t-utype.c
- $(CC) $R/t-utype.c $(RFLAGS) -o objs/t-utype.o
-
-objs/t-vector.o: $R/t-vector.c
- $(CC) $R/t-vector.c $(RFLAGS) -o objs/t-vector.o
-
-objs/t-word.o: $R/t-word.c
- $(CC) $R/t-word.c $(RFLAGS) -o objs/t-word.o
-
-objs/u-bmp.o: $R/u-bmp.c
- $(CC) $R/u-bmp.c $(RFLAGS) -o objs/u-bmp.o
-
-objs/u-compress.o: $R/u-compress.c
- $(CC) $R/u-compress.c $(RFLAGS) -o objs/u-compress.o
-
-objs/u-dialect.o: $R/u-dialect.c
- $(CC) $R/u-dialect.c $(RFLAGS) -o objs/u-dialect.o
-
-objs/u-gif.o: $R/u-gif.c
- $(CC) $R/u-gif.c $(RFLAGS) -o objs/u-gif.o
-
-objs/u-jpg.o: $R/u-jpg.c
- $(CC) $R/u-jpg.c $(RFLAGS) -o objs/u-jpg.o
-
-objs/u-md5.o: $R/u-md5.c
- $(CC) $R/u-md5.c $(RFLAGS) -o objs/u-md5.o
-
-objs/u-parse.o: $R/u-parse.c
- $(CC) $R/u-parse.c $(RFLAGS) -o objs/u-parse.o
-
-objs/u-png.o: $R/u-png.c
- $(CC) $R/u-png.c $(RFLAGS) -o objs/u-png.o
-
-objs/u-sha1.o: $R/u-sha1.c
- $(CC) $R/u-sha1.c $(RFLAGS) -o objs/u-sha1.o
-
-objs/u-zlib.o: $R/u-zlib.c
- $(CC) $R/u-zlib.c $(RFLAGS) -o objs/u-zlib.o
-
-objs/host-main.o: $S/os/host-main.c
- $(CC) $S/os/host-main.c $(HFLAGS) -o objs/host-main.o
-
-objs/host-args.o: $S/os/host-args.c
- $(CC) $S/os/host-args.c $(HFLAGS) -o objs/host-args.o
-
-objs/host-device.o: $S/os/host-device.c
- $(CC) $S/os/host-device.c $(HFLAGS) -o objs/host-device.o
-
-objs/host-stdio.o: $S/os/host-stdio.c
- $(CC) $S/os/host-stdio.c $(HFLAGS) -o objs/host-stdio.o
-
-objs/dev-net.o: $S/os/dev-net.c
- $(CC) $S/os/dev-net.c $(HFLAGS) -o objs/dev-net.o
-
-objs/dev-dns.o: $S/os/dev-dns.c
- $(CC) $S/os/dev-dns.c $(HFLAGS) -o objs/dev-dns.o
-
-objs/host-lib.o: $S/os/posix/host-lib.c
- $(CC) $S/os/posix/host-lib.c $(HFLAGS) -o objs/host-lib.o
-
-objs/host-readline.o: $S/os/posix/host-readline.c
- $(CC) $S/os/posix/host-readline.c $(HFLAGS) -o objs/host-readline.o
-
-objs/dev-stdio.o: $S/os/posix/dev-stdio.c
- $(CC) $S/os/posix/dev-stdio.c $(HFLAGS) -o objs/dev-stdio.o
-
-objs/dev-event.o: $S/os/posix/dev-event.c
- $(CC) $S/os/posix/dev-event.c $(HFLAGS) -o objs/dev-event.o
-
-objs/dev-file.o: $S/os/posix/dev-file.c
- $(CC) $S/os/posix/dev-file.c $(HFLAGS) -o objs/dev-file.o
-
diff --git a/make/makefile.boot b/make/makefile.boot
new file mode 100644
index 0000000000..76e326477a
--- /dev/null
+++ b/make/makefile.boot
@@ -0,0 +1,174 @@
+# Bootstrap Makefile for the Rebol Interpreter Core (a.k.a. Ren/C)
+# This manually produced file was created 17-Jul-2015/10:20:03-04:00
+
+# This makefile is tracked in version control, and can be used to kick off
+# a build process. To do so you can either copy it to 'makefile' and type
+# 'make', or pass a command line switch to tell it to use this file:
+#
+# make -f makefile.boot
+#
+# What will happen is that it will first kick off a call to:
+#
+# make -f makefile.boot make
+#
+# This runs a Rebol script in the %src/tools directory called %make-make.r
+# which will generate a platform-specific makefile. Since it is a Rebol
+# script, you will need a Rebol3 interpreter...and it expects you to have
+# one in the %make/ directory called 'r3-make' (or 'r3-make.exe' on Windows)
+#
+# The next thing it will do is run 'make r3' using the new makefile:
+#
+# make r3
+#
+# For most purposes this should "just work". The platform detection is very
+# simple: it assumes that you want to build a version that's the same as what
+# the 'r3-make' interpreter was built with. However, you may be wanting to
+# "cross-compile" Rebol's generated code to copy %src/include/* over to a
+# machine that needs an executable to bootstrap. (Or maybe it just guessed
+# wrong.) In which case you should check the %src/tools/systems.r file, and
+# provide an OS_ID from the table. For example, Linux with clib 2.5:
+#
+# make -f makefile.boot OS_ID=0.4.3
+#
+# (Note: These numbers are what appear at the tail of a full Rebol version
+# number. So you might find the ones above in a tuple like `2.101.0.4.3`,
+# where the first numbers are referring to the version of the actual Rebol
+# codebase itself. This tuple can be retrieved as `system/version`.)
+#
+# Rebol's bootstrapping scripts are supposed to be kept stable, even in the
+# presence of language changes. So you *should* even be able to use an old
+# executable from the pre-open-source Rebol3 downloads on rebol.com:
+#
+# http://www.rebol.com/r3/downloads.html
+#
+# (At least, in theory. If you notice bootstrap with an old interpreter is
+# broken on your system, please report it! Few are testing old binaries.)
+#
+# For a more recent download, try getting your r3-make from:
+#
+# http://rebolsource.net/
+#
+# !!! Efforts to be able to have Rebol build itself using itself (without a
+# make tool, and perhaps even without a separate C toolchain) are being
+# considered. If you want to chime in on that, or need support while
+# building, please come chime in on chat:
+#
+# http://rebolsource.net/go/chat-faq
+#
+
+# PARAMETERS %MAKE-MAKE.R WILL ACCEPT
+#
+# Note: variables assigned with ?= will only take the value if the variable
+# is not already defined (e.g. not passed as a parameter to `make`)
+#
+# Note: LANGUAGE is some kind of reserved variable in make, so use STANDARD
+#
+# DEBUG can be "none", "asserts", "symbols", "sanitize"...each a level of
+# assumed greater debugging. Adding symbols makes the executable much
+# larger, and Address Sanitization makes the executable much slower. To
+# try and get casual builders to bear a modest useful burden, the default
+# is set to just including the asserts.
+#
+OS_ID?= detect
+DEBUG?= asserts
+OPTIMIZE?=auto
+GIT_COMMIT?= unknown
+STANDARD?= c
+RIGOROUS?= no
+WITH_FFI?= no
+WITH_TCC?= no
+STATIC?= no
+
+NUM_JOBS?=8
+
+# UP - some systems do not use ../
+UP= ..
+# CD - some systems do not use ./
+CD= ./
+# Special tools:
+T= $(UP)/src/tools
+
+# http://stackoverflow.com/a/12099167/211160
+ifeq ($(OS),Windows_NT)
+ BIN_SUFFIX = .exe
+else
+ BIN_SUFFIX =
+endif
+
+REBOL_TOOL= r3-make$(BIN_SUFFIX)
+REBOL= $(CD)$(REBOL_TOOL) -qs
+
+### Build targets:
+top: makefile
+ $(MAKE) clean
+ $(MAKE) prep
+ echo "Going to build with $(NUM_JOBS) jobs"
+ $(MAKE) -j $(NUM_JOBS) top
+
+# .FORCE is a file assumed to not exist, and is an idiom in makefiles to have
+# a null "phony target" you can use as a dependency for a target representing
+# a real file to say "always generate the real target, even if it already
+# exists. (We named our target 'makefile', so we need this to overwrite it)
+.FORCE:
+
+makefile: $(REBOL_TOOL) .FORCE
+ $(REBOL) $T/make-make.r OS_ID="$(OS_ID)" DEBUG="$(DEBUG)" \
+ GIT_COMMIT="$(GIT_COMMIT)" SANITIZE="$(SANITIZE)" \
+ STANDARD="$(STANDARD)" RIGOROUS="$(RIGOROUS)" WITH_FFI="$(WITH_FFI)" \
+ WITH_TCC="$(WITH_TCC)" STATIC="$(STATIC)" SYMBOLS="$(SYMBOLS)" \
+ OPTIMIZE="$(OPTIMIZE)"
+
+# Synonym for `make -f makefile.boot makefile` which can also be used in the
+# generated makefile (without causing repeated regenerations)
+#
+# http://stackoverflow.com/questions/31490689/
+#
+make: makefile
+
+$(REBOL_TOOL):
+ @echo
+ @echo "*** ERROR: Missing $(REBOL_TOOL) to build various tmp files."
+ @echo "*** Download Rebol 3 and copy it here as $(REBOL_TOOL), then"
+ @echo "*** make prep. Or, make prep on some other machine and copy"
+ @echo "*** the src/include files here. You can download executable"
+ @echo "*** images of Rebol for several platforms from:"
+ @echo "***"
+ @echo "*** http://rebolsource.net"
+ @echo "***"
+ @echo "*** The bootstrap process is kept simple so it should be able"
+ @echo "*** to run even on old Rebol builds prior to open-sourcing:"
+ @echo "***"
+ @echo "*** http://www.rebol.com/r3/downloads.html"
+ @echo "***"
+ @echo "*** Visit chat for support: http://rebolsource.net/go/chat-faq"
+ @echo
+# !!! Is false the best way to return an error code?
+ false
+
+# !!! This is supposed to be a catch-all rule. Not working. If it did work,
+# this is what it should say (more or less)
+
+#%:: $(REBOL_TOOL)$(BIN_SUFFIX)
+# @echo
+# @echo
+# @echo "*** The %makefile.boot bootstrapping makefile only handles an"
+# @echo "*** automatic build with these options:"
+# @echo "***"
+# @echo "*** make -f makefile.boot"
+# @echo "*** make -f makefile.boot OS_ID=##.##.##"
+# @echo "***"
+# @echo "*** The first will assume you want to build the same OS_ID as"
+# @echo "*** what your r3-make is. The second lets you override what"
+# @echo "*** OS to build for from system identification numbers in the"
+# @echo "*** systems table (see %src/tools/systems.r)"
+# @echo "***"
+# @echo "*** If you want to prepare the platform-specific makefile without"
+# @echo "*** *actually* building, then choose 'makefile' as your target:"
+# @echo "***"
+# @echo "*** make -f makefile.boot makefile"
+# @echo "*** make -f makefile.boot makefile OS_ID=##.##.##"
+# @echo "***"
+# @echo "*** Visit chat for support: http://rebolsource.net/go/chat-faq"
+# @echo
+# !!! Is false the best way to return an error code?
+# false
diff --git a/make/makefile.vc b/make/makefile.vc
deleted file mode 100644
index f36a050d99..0000000000
--- a/make/makefile.vc
+++ /dev/null
@@ -1,82 +0,0 @@
-# Makefile for Visual Studio's nmake
-# TODO: this should be automatically generated, like Makefile
-
-CC= cl.exe
-LD= link.exe
-
-UP= ..
-T= $(UP)\src\tools
-CD= ./
-
-I= /I..\src\include
-TO_OS= TO_WIN32
-OS_ID= 0.4.4
-
-CFLAGS=/c /Os /D "UNICODE" /D "WIN32" /W3 /GR- /Zi /GS /Gy /GF /EHs-c- /GL /D "NDEBUG" /D "_CRT_SECURE_NO_WARNINGS"
-
-RAPI_FLAGS= $(CFLAGS)
-HOST_FLAGS= $(CFLAGS)
-RLIB_FLAGS=
-
-RFLAGS= $(RAPI_FLAGS) $(I) /D$(TO_OS) /DREB_API
-HFLAGS= $(HOST_FLAGS) $(I) /D$(TO_OS) /DREB_CORE
-
-LIBS= user32.lib ws2_32.lib advapi32.lib shell32.lib comdlg32.lib
-LDFLAGS = /nologo /DEBUG /RELEASE /opt:ref /opt:icf /LTCG
-
-REBOL= r3-make.exe -qs
-
-all: prep r3.exe
-
-prep:
- $(REBOL) $T/make-headers.r
- $(REBOL) $T/make-boot.r $(OS_ID)
- $(REBOL) $T/make-host-init.r
- $(REBOL) $T/make-os-ext.r # ok, but not always
- $(REBOL) $T/make-host-ext.r
- $(REBOL) $T/make-reb-lib.r
-
-objs:
- mkdir objs
-
-OBJS = objs/a-constants.obj objs/a-globals.obj objs/a-lib.obj objs/b-boot.obj \
- objs/b-init.obj objs/c-do.obj objs/c-error.obj objs/c-frame.obj \
- objs/c-function.obj objs/c-port.obj objs/c-task.obj objs/c-word.obj \
- objs/d-crash.obj objs/d-dump.obj objs/d-print.obj objs/f-blocks.obj \
- objs/f-deci.obj objs/f-enbase.obj objs/f-extension.obj objs/f-math.obj \
- objs/f-modify.obj objs/f-random.obj objs/f-round.obj objs/f-series.obj \
- objs/f-stubs.obj objs/l-scan.obj objs/l-types.obj objs/m-gc.obj \
- objs/m-pools.obj objs/m-series.obj objs/n-control.obj objs/n-data.obj \
- objs/n-io.obj objs/n-loop.obj objs/n-math.obj objs/n-sets.obj \
- objs/n-strings.obj objs/n-system.obj objs/p-clipboard.obj objs/p-console.obj \
- objs/p-dir.obj objs/p-dns.obj objs/p-event.obj objs/p-file.obj \
- objs/p-net.obj objs/s-cases.obj objs/s-crc.obj objs/s-file.obj \
- objs/s-find.obj objs/s-make.obj objs/s-mold.obj objs/s-ops.obj \
- objs/s-trim.obj objs/s-unicode.obj objs/t-bitset.obj objs/t-block.obj \
- objs/t-char.obj objs/t-datatype.obj objs/t-date.obj objs/t-decimal.obj \
- objs/t-event.obj objs/t-function.obj objs/t-gob.obj objs/t-image.obj \
- objs/t-integer.obj objs/t-logic.obj objs/t-map.obj objs/t-money.obj \
- objs/t-none.obj objs/t-object.obj objs/t-pair.obj objs/t-port.obj \
- objs/t-string.obj objs/t-time.obj objs/t-tuple.obj objs/t-typeset.obj \
- objs/t-utype.obj objs/t-vector.obj objs/t-word.obj objs/u-bmp.obj \
- objs/u-compress.obj objs/u-dialect.obj objs/u-gif.obj objs/u-jpg.obj \
- objs/u-md5.obj objs/u-parse.obj objs/u-png.obj objs/u-sha1.obj \
- objs/u-zlib.obj
-
-HOST = objs/host-main.obj objs/host-args.obj objs/host-device.obj objs/host-stdio.obj \
- objs/dev-net.obj objs/dev-dns.obj objs/host-lib.obj \
- objs/dev-stdio.obj objs/dev-event.obj objs/dev-file.obj \
- objs/dev-clipboard.obj
-
-# Directly linked r3 executable:
-r3.exe: objs $(OBJS) $(HOST)
- $(LD) $(LDFLAGS) $(OBJS) $(HOST) $(LIBS) /PDB:$*.pdb /OUT:r3.exe /SUBSYSTEM:WINDOWS
-
-{..\src\core}.c{objs}.obj::
- $(CC) $(RFLAGS) /Foobjs\ /Fdobjs\vc80.pdb $<
-
-{..\src\os}.c{objs}.obj::
- $(CC) $(HFLAGS) /Foobjs\ /Fdobjs\vc80.pdb $<
-
-{..\src\os\win32}.c{objs}.obj::
- $(CC) $(HFLAGS) /Foobjs\ /Fdobjs\vc80.pdb $<
diff --git a/make/r3-linux-x64-gbf237fc-static b/make/r3-linux-x64-gbf237fc-static
new file mode 100755
index 0000000000..cd0331d40e
Binary files /dev/null and b/make/r3-linux-x64-gbf237fc-static differ
diff --git a/make/r3-osx-x64-gbf237fc b/make/r3-osx-x64-gbf237fc
new file mode 100755
index 0000000000..f720288998
Binary files /dev/null and b/make/r3-osx-x64-gbf237fc differ
diff --git a/make/vcbuild.bat b/make/vcbuild.bat
deleted file mode 100755
index 02c4584890..0000000000
--- a/make/vcbuild.bat
+++ /dev/null
@@ -1,28 +0,0 @@
-@ECHO OFF
-
-REM Allow to explicitly specify the desired Visual Studio version
-IF /I "%1" == "vc12" GOTO TRY_VS12
-IF /I "%1" == "vc10" GOTO TRY_VS10
-IF /I "%1" == "vc9" GOTO TRY_VS9
-
-REM vs9 is VS 2008
-:TRY_VS9
-CALL "%VS90COMNTOOLS%\vsvars32.bat" 2>NUL
-IF NOT ERRORLEVEL 1 GOTO BUILD
-
-REM vs10 is VS 2010
-:TRY_VS10
-CALL "%VS100COMNTOOLS%\vsvars32.bat" 2>NUL
-IF NOT ERRORLEVEL 1 GOTO BUILD
-
-REM vs12 is VS 2012
-:TRY_VS12
-CALL "%VS110COMNTOOLS%\vsvars32.bat" 2>NUL
-IF NOT ERRORLEVEL 1 GOTO BUILD
-
-ECHO Visual Studio 2012, 2010, or 2008 doesn't seem to be installed
-EXIT /B 1
-
-:BUILD
-nmake -f makefile.vc all
-
diff --git a/ren-c-logo.png b/ren-c-logo.png
new file mode 100644
index 0000000000..aaac1f9e02
Binary files /dev/null and b/ren-c-logo.png differ
diff --git a/src/boot/actions.r b/src/boot/actions.r
index dd1c90679c..f9206130af 100644
--- a/src/boot/actions.r
+++ b/src/boot/actions.r
@@ -1,447 +1,425 @@
REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Datatype action definitions"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Note: [
- "This list is order dependent!"
- "Used to generate C enums and tables"
- "Boot bind attributes are SET and not DEEP"
- "Todo: before beta release remove extra/unused refinements"
- ]
+ System: "REBOL [R3] Language Interpreter and Run-time Environment"
+ Title: "Datatype action definitions"
+ Rights: {
+ Copyright 2012 REBOL Technologies
+ REBOL is a trademark of REBOL Technologies
+ }
+ License: {
+ Licensed under the Apache License, Version 2.0.
+ See: http://www.apache.org/licenses/LICENSE-2.0
+ }
+ Note: [
+ "This list is order dependent!"
+ "Used to generate C enums and tables"
+ "Boot bind attributes are SET and not DEEP"
+ "Todo: before beta release remove extra/unused refinements"
+ ]
]
;-- Binary Math & Logic
add: action [
- {Returns the addition of two values.}
- value1 [scalar! date!]
- value2
+ {Returns the addition of two values.}
+ value1 [any-scalar! date! binary!]
+ value2
]
subtract: action [
- {Returns the second value subtracted from the first.}
- value1 [scalar! date!]
- value2 [scalar! date!]
+ {Returns the second value subtracted from the first.}
+ value1 [any-scalar! date! binary!]
+ value2 [any-scalar! date!]
]
multiply: action [
- {Returns the first value multiplied by the second.}
- value1 [scalar!]
- value2 [scalar!]
+ {Returns the first value multiplied by the second.}
+ value1 [any-scalar!]
+ value2 [any-scalar!]
]
divide: action [
- {Returns the first value divided by the second.}
- value1 [scalar!]
- value2 [scalar!]
+ {Returns the first value divided by the second.}
+ value1 [any-scalar!]
+ value2 [any-scalar!]
]
remainder: action [
- {Returns the remainder of first value divided by second.}
- value1 [scalar!]
- value2 [scalar!]
+ {Returns the remainder of first value divided by second.}
+ value1 [any-scalar!]
+ value2 [any-scalar!]
]
power: action [
- {Returns the first number raised to the second number.}
- number [number!]
- exponent [number!]
+ {Returns the first number raised to the second number.}
+ number [any-number!]
+ exponent [any-number!]
]
and~: action [
- {Returns the first value ANDed with the second.}
- value1 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
- value2 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
+ {Returns the first value ANDed with the second.}
+ value1 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
+ value2 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
]
or~: action [
- {Returns the first value ORed with the second.}
- value1 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
- value2 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
+ {Returns the first value ORed with the second.}
+ value1 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
+ value2 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
]
xor~: action [
- {Returns the first value exclusive ORed with the second.}
- value1 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
- value2 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
+ {Returns the first value exclusive ORed with the second.}
+ value1 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
+ value2 [logic! integer! char! tuple! binary! bitset! typeset! datatype!]
]
;-- Unary
negate: action [
- {Changes the sign of a number.}
- number [number! pair! money! time! bitset!]
+ {Changes the sign of a number.}
+ number [any-number! pair! money! time! bitset!]
]
complement: action [
- {Returns the one's complement value.}
- value [logic! integer! tuple! binary! bitset! typeset! image!]
+ {Returns the one's complement value.}
+ value [logic! integer! tuple! binary! bitset! typeset! image!]
]
absolute: action [
- {Returns the absolute value.}
- value [number! pair! money! time!]
+ {Returns the absolute value.}
+ value [any-number! pair! money! time!]
]
round: action [
- {Rounds a numeric value; halves round up (away from zero) by default.}
- value [number! pair! money! time!] "The value to round"
- /to "Return the nearest multiple of the scale parameter"
- scale [number! money! time!] "Must be a non-zero value"
- /even "Halves round toward even results"
- /down "Round toward zero, ignoring discarded digits. (truncate)"
- /half-down "Halves round toward zero"
- /floor "Round in negative direction"
- /ceiling "Round in positive direction"
- /half-ceiling "Halves round in positive direction"
+ {Rounds a numeric value; halves round up (away from zero) by default.}
+ value [any-number! pair! money! time!] "The value to round"
+ /to "Return the nearest multiple of the scale parameter"
+ scale [any-number! money! time!] "Must be a non-zero value"
+ /even "Halves round toward even results"
+ /down "Round toward zero, ignoring discarded digits. (truncate)"
+ /half-down "Halves round toward zero"
+ /floor "Round in negative direction"
+ /ceiling "Round in positive direction"
+ /half-ceiling "Halves round in positive direction"
]
random: action [
- {Returns a random value of the same datatype; or shuffles series.}
- value {Maximum value of result (modified when series)}
- /seed {Restart or randomize}
- /secure {Returns a cryptographically secure random number}
- /only {Pick a random value from a series}
+ {Returns a random value of the same datatype; or shuffles series.}
+ return: [ any-value!]
+ value {Maximum value of result (modified when series)}
+ /seed {Restart or randomize}
+ /secure {Returns a cryptographically secure random number}
+ /only {Pick a random value from a series}
]
odd?: action [
- {Returns TRUE if the number is odd.}
- number [number! char! date! money! time! pair!]
+ {Returns TRUE if the number is odd.}
+ number [any-number! char! date! money! time! pair!]
]
even?: action [
- {Returns TRUE if the number is even.}
- number [number! char! date! money! time! pair!]
+ {Returns TRUE if the number is even.}
+ number [any-number! char! date! money! time! pair!]
]
;-- Series Navigation
-head: action [
- {Returns the series at its beginning.}
- series [series! gob! port!]
+head-of: action [
+ {Returns the series at its beginning.}
+ series [any-series! gob! port!]
]
-tail: action [
- {Returns the series just past its end.}
- series [series! gob! port!]
+tail-of: action [
+ {Returns the series just past its end.}
+ series [any-series! gob! port!]
]
head?: action [
- {Returns TRUE if a series is at its beginning.}
- series [series! gob! port!]
+ {Returns TRUE if a series is at its beginning.}
+ series [any-series! gob! port!]
]
tail?: action [
- {Returns TRUE if series is at or past its end; or empty for other types.}
- series [series! gob! port! bitset! map!]
+ {Returns TRUE if series is at or past its end; or empty for other types.}
+ series [any-series! object! gob! port! bitset! map! blank! varargs!]
]
past?: action [
- {Returns TRUE if series is past its end.}
- series [series! gob! port!]
-]
-
-next: action [
- {Returns the series at its next position.}
- series [series! gob! port!]
-]
-
-back: action [
- {Returns the series at its previous position.}
- series [series! gob! port!]
+ {Returns TRUE if series is past its end.}
+ series [any-series! gob! port!]
]
skip: action [
- {Returns the series forward or backward from the current position.}
- series [series! gob! port!]
- offset [number! logic! pair!]
+ {Returns the series forward or backward from the current position.}
+ series [any-series! gob! port!]
+ offset [any-number! logic! pair!]
]
at: action [
- {Returns the series at the specified index.}
- series [series! gob! port!]
- index [number! logic! pair!]
+ {Returns the series at the specified index.}
+ series [any-series! gob! port!]
+ index [any-number! logic! pair!]
]
-index?: action [
- {Returns the current position (index) of the series.}
- series [series! gob! port! none!]
- /xy {Returns index as an XY pair offset}
+index-of: action [
+ {Returns the current position (index) of the series.}
+ series [any-series! gob! port! blank!]
+ /xy {Returns index as an XY pair offset}
]
-length?: action [
- {Returns the length (from the current position for series.)}
- series [series! port! map! tuple! bitset! object! gob! struct! any-word! none!]
-]
-
-;-- Series Extraction
-
-pick: action [
- {Returns the value at the specified position.}
- aggregate [series! map! gob! pair! date! time! tuple! bitset! port!]
- index {Index offset, symbol, or other value to use as index}
+length-of: action [
+ {Returns the length (from the current position for series.)}
+ series [any-series! port! map! tuple! bitset! object! gob! struct! any-word! blank!]
]
;-- Series Search
find: action [
- {Searches for a value; for series returns where found, else none.}
- series [series! gob! port! bitset! typeset! object! none!]
- value [any-type!]
- /part {Limits the search to a given length or position}
- length [number! series! pair!]
- /only {Treats a series value as only a single value}
- /case {Characters are case-sensitive}
- /any {Enables the * and ? wildcards}
- /with {Allows custom wildcards}
- wild [string!] "Specifies alternates for * and ?"
- /skip {Treat the series as records of fixed size}
- size [integer!]
- /last {Backwards from end of series}
- /reverse {Backwards from the current position}
- /tail {Returns the end of the series}
- /match {Performs comparison and returns the tail of the match}
-]
-
-select: action [
- {Searches for a value; returns the value that follows, else none.}
- series [series! port! map! object! none!]
- value [any-type!]
- /part {Limits the search to a given length or position}
- length [number! series! pair!]
- /only {Treats a series value as only a single value}
- /case {Characters are case-sensitive}
- /any {Enables the * and ? wildcards}
- /with {Allows custom wildcards}
- wild [string!] "Specifies alternates for * and ?"
- /skip {Treat the series as records of fixed size}
- size [integer!]
- /last {Backwards from end of series}
- /reverse {Backwards from the current position}
+ {Searches for a value; for series returns where found, else blank.}
+ return: [any-series! blank! logic!]
+ series [any-series! any-context! map! gob! bitset! typeset! blank!]
+ value [ any-value!]
+ /part {Limits the search to a given length or position}
+ limit [any-number! any-series! pair!]
+ /only {Treats a series value as only a single value}
+ /case {Characters are case-sensitive}
+ /skip {Treat the series as records of fixed size}
+ size [integer!]
+ /last {Backwards from end of series}
+ /reverse {Backwards from the current position}
+ /tail {Returns the end of the series}
+ /match {Performs comparison and returns the tail of the match}
+]
+
+select*: action [
+ {Searches for a value; returns the value that follows, else void.}
+ return: [ any-value!]
+ series [any-series! any-context! map! blank!]
+ value [any-value!]
+ /part {Limits the search to a given length or position}
+ limit [any-number! any-series! pair!]
+ /only {Treats a series value as only a single value}
+ /case {Characters are case-sensitive}
+ /skip {Treat the series as records of fixed size}
+ size [integer!]
+ /last {Backwards from end of series}
+ /reverse {Backwards from the current position}
+ /tail ;-- for frame compatibility with FIND
+ /match ;-- for frame compatibility with FIND
+
]
;;;;!!! MATCH
reflect: action [
- {Returns specific details about a datatype.}
- value [any-type!]
- field [word!] "Such as: spec, body, words, values, title"
+ {Returns specific details about a datatype.}
+ value [any-value!]
+ field [word!] "Such as: spec, body, words, values, title"
]
;-- Making, copying, modifying
-make: action [
- {Constructs or allocates the specified datatype.}
- type [any-type!] {The datatype or an example value}
- spec [any-type!] {Attributes or size of the new value (modified)}
-]
-
-to: action [
- {Converts to a specified datatype.}
- type [any-type!] {The datatype or example value}
- spec [any-type!] {The attributes of the new value}
-]
-
copy: action [
- {Copies a series, object, or other value.}
- value [series! port! map! object! bitset! any-function!] {At position}
- /part {Limits to a given length or position}
- length [number! series! pair!]
- /deep {Also copies series values within the block}
- /types {What datatypes to copy}
- kinds [typeset! datatype!]
-]
-
-take: action [
- {Removes and returns one or more elements.}
- series [series! port! gob! none!] {At position (modified)}
- /part {Specifies a length or end position}
- length [number! series! pair!]
- /deep {Also copies series values within the block}
- /last {Take it from the tail end}
+ {Copies a series, object, or other value.}
+
+ return: [any-value!]
+ {Return type will match the input type.}
+ value [any-value!]
+ {If an ANY-SERIES!, it is only copied from its current position}
+ /part
+ {Limits to a given length or position}
+ limit [any-number! any-series! pair!]
+ /deep
+ {Also copies series values within the block}
+ /types
+ {What datatypes to copy}
+ kinds [typeset! datatype!]
+]
+
+take*: action [
+ {Removes and returns one or more elements.}
+ return: [ any-value!]
+ series [any-series! port! gob! blank! varargs!] {At position (modified)}
+ /part {Specifies a length or end position}
+ limit [any-number! any-series! pair! bar!]
+ /deep {Also copies series values within the block}
+ /last {Take it from the tail end}
]
insert: action [
- {Inserts element(s); for series, returns just past the insert.}
- series [series! port! map! gob! object! bitset! port!] {At position (modified)}
- value [any-type!] {The value to insert}
- /part {Limits to a given length or position}
- length [number! series! pair!]
- /only {Only insert a block as a single value (not the contents of the block)}
- /dup {Duplicates the insert a specified number of times}
- count [number! pair!]
+ {Inserts element(s); for series, returns just past the insert.}
+ series [any-series! port! map! gob! object! bitset! port!] {At position (modified)}
+ value [ any-value!] {The value to insert}
+ /part {Limits to a given length or position}
+ limit [any-number! any-series! pair!]
+ /only {Only insert a block as a single value (not the contents of the block)}
+ /dup {Duplicates the insert a specified number of times}
+ count [any-number! pair!]
]
append: action [
- {Inserts element(s) at tail; for series, returns head.}
- series [series! port! map! gob! object! bitset!] {Any position (modified)}
- value [any-type!] {The value to insert}
- /part {Limits to a given length or position}
- length [number! series! pair!]
- /only {Only insert a block as a single value (not the contents of the block)}
- /dup {Duplicates the insert a specified number of times}
- count [number! pair!]
+ {Inserts element(s) at tail; for series, returns head.}
+ series [any-series! port! map! gob! object! module! bitset!]
+ {Any position (modified)}
+ value [ any-value!] {The value to insert}
+ /part {Limits to a given length or position}
+ limit [any-number! any-series! pair!]
+ /only {Only insert a block as a single value (not the contents of the block)}
+ /dup {Duplicates the insert a specified number of times}
+ count [any-number! pair!]
]
remove: action [
- {Removes element(s); returns same position.}
- series [series! gob! port! bitset! none!] {At position (modified)}
- /part {Removes multiple elements or to a given position}
- length [number! series! pair! char!]
+ {Removes element(s); returns same position.}
+ series [any-series! map! gob! port! bitset! blank!] {At position (modified)}
+ /part {Removes multiple elements or to a given position}
+ limit [any-number! any-series! pair! char!]
+ /map {Remove key from map}
+ key
]
change: action [
- {Replaces element(s); returns just past the change.}
- series [series! gob! port!]{At position (modified)}
- value [any-type!] {The new value}
- /part {Limits the amount to change to a given length or position}
- length [number! series! pair!]
- /only {Only change a block as a single value (not the contents of the block)}
- /dup {Duplicates the change a specified number of times}
- count [number! pair!]
-]
-
-poke: action [
- {Replaces an element at a given position.}
- series [series! port! map! gob! bitset!] {(modified)}
- index {Index offset, symbol, or other value to use as index}
- value [any-type!] {The new value (returned)}
+ {Replaces element(s); returns just past the change.}
+ series [any-series! gob! port! struct!]{At position (modified)}
+ value [ any-value!] {The new value}
+ /part {Limits the amount to change to a given length or position}
+ limit [any-number! any-series! pair!]
+ /only {Only change a block as a single value (not the contents of the block)}
+ /dup {Duplicates the change a specified number of times}
+ count [any-number! pair!]
]
clear: action [
- {Removes elements from current position to tail; returns at new tail.}
- series [series! port! map! gob! bitset! none!] {At position (modified)}
+ {Removes elements from current position to tail; returns at new tail.}
+ series [any-series! port! map! gob! bitset! blank!] {At position (modified)}
]
trim: action [
- {Removes spaces from strings or nones from blocks or objects.}
- series [series! object! error! module!] {Series (modified) or object (made)}
- /head {Removes only from the head}
- /tail {Removes only from the tail}
- /auto {Auto indents lines relative to first line}
- /lines {Removes all line breaks and extra spaces}
- /all {Removes all whitespace}
- /with str [char! string! binary! integer!] {Same as /all, but removes characters in 'str'}
+ {Removes spaces from strings or blanks from blocks or objects.}
+ series [any-series! object! error! module!] {Series (modified) or object (made)}
+ /head {Removes only from the head}
+ /tail {Removes only from the tail}
+ /auto {Auto indents lines relative to first line}
+ /lines {Removes all line breaks and extra spaces}
+ /all {Removes all whitespace}
+ /with str [char! string! binary! integer!] {Same as /all, but removes characters in 'str'}
]
swap: action [
- {Swaps elements between two series or the same series.}
- series1 [series! gob!] {At position (modified)}
- series2 [series! gob!] {At position (modified)}
+ {Swaps elements between two series or the same series.}
+ series1 [any-series! gob!] {At position (modified)}
+ series2 [any-series! gob!] {At position (modified)}
]
reverse: action [
- {Reverses the order of elements; returns at same position.}
- series [series! gob! tuple! pair!] {At position (modified)}
- /part {Limits to a given length or position}
- length [number! series!]
+ {Reverses the order of elements; returns at same position.}
+ series [any-series! gob! tuple! pair!] {At position (modified)}
+ /part {Limits to a given length or position}
+ limit [any-number! any-series!]
]
sort: action [
- {Sorts a series; default sort order is ascending.}
- series [series!] {At position (modified)}
- /case {Case sensitive sort}
- /skip {Treat the series as records of fixed size}
- size [integer!] {Size of each record}
- /compare {Comparator offset, block or function}
- comparator [integer! block! any-function!]
- /part {Sort only part of a series}
- length [number! series!] {Length of series to sort}
- /all {Compare all fields}
- /reverse {Reverse sort order}
+ {Sorts a series; default sort order is ascending.}
+ series [any-series!] {At position (modified)}
+ /case {Case sensitive sort}
+ /skip {Treat the series as records of fixed size}
+ size [integer!] {Size of each record}
+ /compare {Comparator offset, block or function}
+ comparator [integer! block! function!]
+ /part {Sort only part of a series}
+ limit [any-number! any-series!] {Length of series to sort}
+ /all {Compare all fields}
+ /reverse {Reverse sort order}
]
;-- Port actions:
create: action [
- {Send port a create request.}
- port [port! file! url! block!]
+ {Send port a create request.}
+ port [port! file! url! block!]
]
delete: action [
- {Send port a delete request.}
- port [port! file! url! block!]
+ {Send port a delete request.}
+ port [port! file! url! block!]
]
open: action [
- {Opens a port; makes a new port from a specification if necessary.}
- spec [port! file! url! block!]
- /new {Create new file - if it exists, reset it (truncate)}
- /read {Open for read access}
- /write {Open for write access}
- /seek {Optimize for random access}
- /allow {Specifies protection attributes}
- access [block!]
+ {Opens a port; makes a new port from a specification if necessary.}
+ spec [port! file! url! block!]
+ /new {Create new file - if it exists, reset it (truncate)}
+ /read {Open for read access}
+ /write {Open for write access}
+ /seek {Optimize for random access}
+ /allow {Specifies protection attributes}
+ access [block!]
]
close: action [
- {Closes a port.}
- port [port!]
+ {Closes a port/library.}
+ return: [ any-value!]
+ port [port! library!]
]
read: action [
- {Read from a file, URL, or other port.}
- source [port! file! url! block!]
- /part {Partial read a given number of units (source relative)}
- length [number!]
- /seek {Read from a specific position (source relative)}
- index [number!]
- /string {Convert UTF and line terminators to standard text string}
- /lines {Convert to block of strings (implies /string)}
-; /as {Convert to string using a specified encoding}
-; encoding [none! number!] {UTF number (0 8 16 -16)}
+ {Read from a file, URL, or other port.}
+ source [port! file! url! block!]
+ /part {Partial read a given number of units (source relative)}
+ limit [any-number!]
+ /seek {Read from a specific position (source relative)}
+ index [any-number!]
+ /string {Convert UTF and line terminators to standard text string}
+ /lines {Convert to block of strings (implies /string)}
+; /as {Convert to string using a specified encoding}
+; encoding [blank! any-number!] {UTF number (0 8 16 -16)}
]
write: action [
- {Writes to a file, URL, or port - auto-converts text strings.}
- destination [port! file! url! block!]
- data [binary! string! block!] {Data to write (non-binary converts to UTF-8)}
- /part {Partial write a given number of units}
- length [number!]
- /seek {Write at a specific position}
- index [number!]
- /append {Write data at end of file}
- /allow {Specifies protection attributes}
- access [block!]
- /lines {Write each value in a block as a separate line}
-; /as {Convert string to a specified encoding}
-; encoding [none! number!] {UTF number (0 8 16 -16)}
+ {Writes to a file, URL, or port - auto-converts text strings.}
+ destination [port! file! url! block!]
+ data [binary! string! block! object!] ; !!! CHAR! support?
+ {Data to write (non-binary converts to UTF-8)}
+ /part {Partial write a given number of units}
+ limit [any-number!]
+ /seek {Write at a specific position}
+ index [any-number!]
+ /append {Write data at end of file}
+ /allow {Specifies protection attributes}
+ access [block!]
+ /lines {Write each value in a block as a separate line}
+; /as {Convert string to a specified encoding}
+; encoding [blank! any-number!] {UTF number (0 8 16 -16)}
]
open?: action [
- {Returns TRUE if port is open.}
- port [port!]
+ {Returns TRUE if port is open.}
+ port [port!]
]
query: action [
- {Returns information about a port, file, or URL.}
- target [port! file! url! block!]
- /mode "Get mode information"
- field [word! none!] "NONE will return valid modes for port type"
+ {Returns information about a port, file, or URL.}
+ target [port! file! url! block!]
+ /mode "Get mode information"
+ field [word! blank!] "NONE will return valid modes for port type"
]
modify: action [
- {Change mode or control for port or file.}
- target [port! file!]
- field [word! none!]
- value
+ {Change mode or control for port or file.}
+ target [port! file!]
+ field [word! blank!]
+ value
]
update: action [
- {Updates external and internal states (normally after read/write).}
- port [port!]
+ {Updates external and internal states (normally after read/write).}
+ port [port!]
]
rename: action [
- {Rename a file.}
- from [port! file! url! block!]
- to [port! file! url! block!]
+ {Rename a file.}
+ from [port! file! url! block!]
+ to [port! file! url! block!]
]
+;-- Expectation is that evaluation ends with no result, empty GROUP! does that
+()
diff --git a/src/boot/booters.r b/src/boot/booters.r
deleted file mode 100644
index 61ecf54a73..0000000000
--- a/src/boot/booters.r
+++ /dev/null
@@ -1,31 +0,0 @@
-REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Special boot native function specs"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- These are used to define natives and actions.
- Bind attributes for this block are: BIND_SET and SHALLOW
- }
-]
-
-; Special block used as spec to the datatype test functions (e.g. time?):
-["Returns TRUE if it is this type." value [any-type!] 0]
-
-; The native function must be defined first. This is a
-; special boot function created manually within the C code.
-native: native [
- {Creates native function (for internal usage only).}
- spec ; [block!] -- no check required, we know it is correct
-]
-
-action: native [
- {Creates datatype action (for internal usage only).}
- spec ; [block!] -- no check required, we know it is correct
-]
diff --git a/src/boot/draw.r b/src/boot/draw.r
deleted file mode 100644
index c38611b6c7..0000000000
--- a/src/boot/draw.r
+++ /dev/null
@@ -1,299 +0,0 @@
-REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "REBOL Graphics - DRAW commands"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Name: draw
- Type: extension
- Exports: none
- Note: "Run make-host-ext.r to convert"
-]
-
-;don't change order of already defined words unless you know what you are doing
-
-words: [
- ;fill-rule
- even-odd
- non-zero
-
- ;grad-pen
- conic
- cubic
- diagonal
- diamond
- linear
- radial
- normal
- repeat
- reflect
-
- ;line-cap
- butt
- square
- rounded
-
- ;line-join
- miter
- miter-bevel
- round
- bevel
-
- ;line-width
- variable
- fixed
-
- ;arc
- opened
- closed
-
- ;image
- no-border
- border
-
- ;image-filter
- nearest
- bilinear
- bicubic
- gaussian
- resize
- resample
-
- ;text
- raster
- vectorial
-]
-
-;temp hack - will be removed later
-init-words: command [
- words [block!]
-]
-
-init-words words
-
-;please alphabetize the order of commands so it easier to lookup things
-
-anti-alias: command [
- "Turns anti-aliasing on or off."
- state [logic!]
-]
-
-arc: command [
- "Draws a partial section of an ellipse or circle."
- center [pair!] "The center of the circle"
- radius [pair!] "The radius of the circle"
- angle-begin [number!] "The angle where the arc begins, in degrees"
- angle-length [number!] "The length of the arc in degrees"
- 'arc-ending [word!] "Leave the arc: OPENED or CLOSED"
-]
-
-arrow: command [
- "Sets the arrow mode."
- mode [pair!] "Possible numbers for combination. 0 for none, 1 for head, 2 for tail"
- color [tuple! none!] "Color of the head/tail of the arrow. NONE means use PEN color"
-]
-
-box: command [
- "Draws a rectangular box."
- origin [pair!] "Corner of box"
- end [pair!] "End of box"
- corner-radius [number!] "Rounds corners"
-]
-
-circle: command [
- "Draws a circle or ellipse."
- center [pair!]
- radius [pair!]
-]
-
-curve: command [
- "Draws a smooth Bezier curve.(using 3 or 4 points)"
- point-1 [pair!] "End point A"
- point-2 [pair!] "Control point A"
- point-3 [pair!] "End point B, or control point B"
- point-4 [pair! none!] "End point B"
-]
-
-clip: command [
- "Specifies a clipping region."
- origin [pair!] "Corner of box"
- end [pair!] "End of box"
-]
-
-ellipse: command [
- "Draws an ellipse."
- origin [pair!] "The upper-left-point of the ellipse bounding box"
- diameter [pair!]
-]
-
-fill-pen: command [
- "Sets the area fill pen color."
- color [tuple! image! logic!] "Set to OFF to disable fill pen"
-]
-
-fill-rule: command [
- "Determines the algorithm used to determine what area to fill."
- 'mode [word!] "Rule type: EVEN-ODD or NON-ZERO"
-]
-
-gamma: command [
- "Sets the gamma correction value."
- gamma-value [number!]
-]
-
-grad-pen: command [
- "Sets the color gradient for area filling. To disable it set the color block to NONE."
- 'type [word!] "The gradient type: RADIAL CONIC DIAMOND LINEAR DIAGONAL CUBIC"
- 'mode [word!] "The gradient rendering mode: NORMAL REPEAT REFLECT"
- offset [pair!] "offset from where should the gradient be rendered"
- range [pair!] "begin and end of the gradient range"
- angle [number!] "rotation of the gradient in degrees"
- scale [pair!] "X and Y scale factor"
- colors [block! none!] "block containing up to 256 gradient colors (optionally with color offsets)"
-]
-
-image: command [
- "Draws an image, with optional scaling, borders, and color keying."
- image [image!]
- offset-points [pair! block!]
-]
-
-image-filter: command [
- "Specifies type of algorithm used when an image is scaled."
- 'filter-type [word!] "supported filters: NEAREST, BILINEAR, BICUBIC, GAUSSIAN"
- 'filter-mode [word!] "Output quality: RESIZE(low, faster) or RESAMPLE(high, slower)"
- blur [number! none!] "Used only in RESAMPLE mode"
-]
-
-image-options: command [
- "Sets options related to image rendering."
- key-color [tuple! none!] "Color to be rendered as transparent or NONE to disable it"
- 'border-flag [word!] "can be BORDER or NO-BORDER"
-]
-
-image-pattern: command [
- "Configure the image pattern fill settings."
- 'pattern-mode [word!] "can be NORMAL, REPEAT or REFLECT"
- pattern-offset [pair!]
- pattern-size [pair!] "set to 0x0 for auto-size"
-
-]
-
-line: command [
- "Draws (poly)line from a number of points."
- lines [block!] "Block of pairs"
-]
-
-line-cap: command [
- "Sets the style that will be used when drawing the ends of lines."
- 'type [word!] "Cap type: BUTT, SQUARE or ROUNDED"
-]
-
-line-join: command [
- "Sets the style that will be used where lines are joined."
- 'type [word!] "Join type: MITER, MITER-BEVEL, ROUND, or BEVEL"
-]
-
-line-pattern: command [
- "Sets the line pattern. To disable it set the pattern block to NONE."
- color [tuple!] "Dash color"
- pattern [block! none!] "Block of dash-size/stroke-size number pairs"
-]
-
-line-width: command [
- "Sets the line width."
- width [number!] "Zero, or negative values, produce a line-width of 1."
- 'mode [word!] "Line width mode during scaling: FIXED or VARIABLE"
-]
-
-invert-matrix: command [
- "Applies an algebraic matrix inversion operation on the current transformation matrix."
-]
-
-matrix: command [
- "Premultiplies the current transformation matrix with the given block."
- matrix-setup [block!] "content must be 6 numbers"
-]
-
-pen: command [
- "Sets the line pen color."
- color [tuple! image! logic!] "Set to OFF to disable pen"
-]
-
-polygon: command [
- "Draws a closed area of line segments. First and last points are connected."
- vertices [block!] "Block of pairs"
-]
-
-push: command [
- "Stores the current attribute setup in stack."
- draw-block [block!]
-]
-
-reset-matrix: command [
- "Resets the current transformation matrix to its default values."
-]
-
-rotate: command [
- "Sets the clockwise rotation in current transformation matrix."
- angle [number!] "in degrees"
-]
-
-scale: command [
- "Sets the scaling factor in current transformation matrix."
- factor [pair!]
-]
-
-shape: command [
- "Draws shapes using the SHAPE sub-dialect."
- commands [block!] "Block of SHAPE sub-commands"
-]
-
-skew: command [
- "Sets a coordinate system skewed from the original by the given number of degrees in specified axis."
- angle [pair!] "Positive numbers skew to the right; negative numbers skew to the left."
-]
-
-spline: command [
- "Draws a curve through any number of points. The smoothness of the curve will be determined by the segment factor."
- points [block!] "Block of pairs"
- segmentation [integer!]
- 'spline-ending [word!] "Leave the spline: OPENED or CLOSED"
-]
-
-text: command [
- "Draws a string of text."
- offset [pair!] "offset from where should the text be rendered"
- size [pair!] "size of the text area"
- 'render-mode [word!] "RASTER or VECTORIAL"
- rich-text-block [block!]
-]
-
-transform: command [
- "Applies transformation such as translation, scaling, and rotation."
- angle [number!]
- center [pair!]
- scale [pair!]
- translation [pair!]
-]
-
-translate: command [
- "Sets the translation in current transformation matrix."
- offset [pair!]
-]
-
-triangle: command [
- "Draws triangular polygon with shading parameters (Gouraud shading). Set colors to NONE to turn of shading."
- vertex-1 [pair!]
- vertex-2 [pair!]
- vertex-3 [pair!]
- color-1 [tuple! none!]
- color-2 [tuple! none!]
- color-3 [tuple! none!]
- dilation [number!] "Useful for eliminating anitaliased edges"
-]
diff --git a/src/boot/errors.r b/src/boot/errors.r
index 51d573f78f..b1deee7128 100644
--- a/src/boot/errors.r
+++ b/src/boot/errors.r
@@ -1,195 +1,333 @@
REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Error objects"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- Specifies error categories and default error messages.
- }
+ System: "REBOL [R3] Language Interpreter and Run-time Environment"
+ Title: "Error objects"
+ Rights: {
+ Copyright 2012 REBOL Technologies
+ REBOL is a trademark of REBOL Technologies
+ }
+ License: {
+ Licensed under the Apache License, Version 2.0.
+ See: http://www.apache.org/licenses/LICENSE-2.0
+ }
+ Purpose: {
+ Specifies error categories and default error messages.
+ }
]
-Throw: [
- code: 0
- type: "throw error"
- break: {no loop to break}
- return: {return or exit not in function}
- throw: [{no catch for throw:} :arg1]
- continue: {no loop to continue}
- halt: [{halted by user or script}]
- quit: [{user script quit}]
+Special: [
+ code: 0
+ type: "special" ; Not really "errors"
+ null: {invalid error code zero}
+ halt: {halted by user or script}
]
-Note: [
- code: 100
- type: "note"
- no-load: [{cannot load: } :arg1]
- exited: [{exit occurred}]
- deprecated: {deprecated function not allowed}
+Internal: [
+ code: 1000
+ type: "internal"
+
+ ; !!! Should there be a distinction made between different kinds of
+ ; stack overflows? (Call stack, Data stack?)
+ ;
+ stack-overflow: {stack overflow}
+
+ not-done: {reserved for future use (or not yet implemented)}
+
+ no-memory: [{not enough memory:} :arg1 {bytes}]
+
+ io-error: {problem with IO}
+ locked-series: {locked series expansion}
+ unexpected-case: {no case in switch statement}
+ invalid-datatype: [{invalid datatype #} :arg1]
+ bad-path: [{bad path:} :arg1]
+ not-here: [:arg1 {not supported on your system}]
+ globals-full: {no more global variable space}
+ bad-sys-func: [{invalid or missing system function:} :arg1]
+ invalid-error: [{error object or fields were not valid:} :arg1]
+ hash-overflow: {Hash ran out of space}
+ no-print-ptr: {print is missing string pointer}
+
+ bad-utf8: {invalid UTF-8 byte sequence found during decoding}
+ codepoint-too-high: [{codepoint} :arg1 {too large (or data is not UTF-8)}]
+
+ debug-only: {Feature available only in DEBUG builds}
+
+ host-no-breakpoint: {Interpreter host code has no breakpoint handler}
+ no-current-pause: {No current PAUSE or BREAKPOINT instruction in effect}
+
+ invalid-exit: {Frame does not exist on the stack to EXIT from}
+ out-of-error-numbers: {There is no more base error code available}
]
Syntax: [
- code: 200
- type: "syntax error"
- invalid: [{invalid} :arg1 {--} :arg2]
- missing: [{missing} :arg2 {at} :arg1]
- no-header: [{script is missing a REBOL header:} :arg1]
- bad-header: [{script header is not valid:} :arg1]
- bad-checksum: [{script checksum failed:} :arg1]
- malconstruct: [{invalid construction spec:} :arg1]
- bad-char: [{invalid character in:} :arg1]
- needs: [{this script needs} :arg1 :arg2 {or better to run correctly}]
+ code: 2000
+ type: "syntax error"
+ scan-invalid: [{invalid} :arg1 {--} :arg2]
+ scan-missing: [{missing} :arg1]
+ scan-extra: [{extra} :arg1]
+ scan-mismatch: [{expected} :arg1 {but got} :arg2]
+
+ no-header: [{script is missing a REBOL header:} :arg1]
+ bad-header: [{script header is not valid:} :arg1]
+ bad-checksum: [{script checksum failed:} :arg1]
+ malconstruct: [{invalid construction spec:} :arg1]
+ bad-char: [{invalid character in:} :arg1]
+ needs: [{this script needs} :arg1 :arg2 {or better to run correctly}]
]
Script: [
- code: 300
- type: "script error"
- no-value: [:arg1 {has no value}]
- need-value: [:arg1 {needs a value}]
- not-defined: [:arg1 {word is not bound to a context}]
- not-in-context: [:arg1 {is not in the specified context}]
-
- no-arg: [:arg1 {is missing its} :arg2 {argument}]
- expect-arg: [:arg1 {does not allow} :arg3 {for its} :arg2 {argument}]
- expect-val: [{expected} :arg1 {not} :arg2]
- expect-type: [:arg1 :arg2 {field must be of type} :arg3]
- cannot-use: [{cannot use} :arg1 {on} :arg2 {value}]
-
- invalid-arg: [{invalid argument:} :arg1]
- invalid-type: [:arg1 {type is not allowed here}]
- invalid-op: [{invalid operator:} :arg1]
- no-op-arg: [:arg1 {operator is missing an argument}]
- invalid-data: [{data not in correct format:} :arg1]
- not-same-type: {values must be of the same type}
- not-related: [{incompatible argument for} :arg1 {of} :arg2]
- bad-func-def: [{invalid function definition:} :arg1]
- bad-func-arg: [{function argument} :arg1 {is not valid}] ; can be a number
-
- no-refine: [:arg1 {has no refinement called} :arg2]
- bad-refines: {incompatible or invalid refinements}
- bad-refine: [{incompatible refinement:} :arg1]
- invalid-path: [{cannot access} :arg2 {in path} :arg1]
- bad-path-type: [{path} :arg1 {is not valid for} :arg2 {type}]
- bad-path-set: [{cannot set} :arg2 {in path} :arg1]
- bad-field-set: [{cannot set} :arg1 {field to} :arg2 {datatype}]
- dup-vars: [{duplicate variable specified:} :arg1]
-
- past-end: {out of range or past end}
- missing-arg: {missing a required argument or refinement}
- out-of-range: [{value out of range:} :arg1]
- too-short: {content too short (or just whitespace)}
- too-long: {content too long}
- invalid-chars: {contains invalid characters}
- invalid-compare: [{cannot compare} :arg1 {with} :arg2]
- assert-failed: [{assertion failed for:} :arg1]
- wrong-type: [{datatype assertion failed for:} :arg1]
-
- invalid-part: [{invalid /part count:} :arg1]
- type-limit: [:arg1 {overflow/underflow}]
- size-limit: [{maximum limit reached:} :arg1]
-
- no-return: {block did not return a value}
- block-lines: {expected block of lines}
- throw-usage: {invalid use of a thrown error value}
-
- locked-word: [{protected variable - cannot modify:} :arg1]
- protected: {protected value or series - cannot modify}
- hidden: {not allowed - would expose or modify hidden values}
- self-protected: {cannot set/unset self - it is protected}
- bad-bad: [:arg1 {error:} :arg2]
-
- bad-make-arg: [{cannot MAKE/TO} :arg1 {from:} :arg2]
- bad-decode: {missing or unsupported encoding marker}
-; no-decode: [{cannot decode} :arg1 {encoding}]
- already-used: [{alias word is already in use:} :arg1]
- wrong-denom: [:arg1 {not same denomination as} :arg2]
+ code: 3000
+ type: "script error"
+
+ no-value: [:arg1 {has no value}]
+ need-value: [:arg1 {needs a value}]
+ not-bound: [:arg1 {word is not bound to a context}]
+ no-relative: [:arg1 {word is bound relative to context not on stack}]
+ not-in-context: [:arg1 {is not in the specified context}]
+
+ no-arg: [:arg1 {is missing its} :arg2 {argument}]
+ expect-arg: [:arg1 {does not allow} :arg2 {for its} :arg3 {argument}]
+ arg-required: [:arg1 {requires} :arg2 {argument to not be void}]
+ expect-val: [{expected} :arg1 {not} :arg2]
+ expect-type: [:arg1 :arg2 {field must be of type} :arg3]
+ cannot-use: [{cannot use} :arg1 {on} :arg2 {value}]
+
+ do-running-frame: [{Must COPY a FRAME! that's RUNNING? before DOing it}]
+ do-expired-frame: [{Cannot DO a FRAME! whose stack storage expired}]
+
+ multiple-do-errors: [{DO-ALL encountered multiple failures} :arg1 :arg2]
+
+ apply-too-many: {Too many values in processed argument block of APPLY.}
+ apply-has-changed: {APPLY takes frame def block (or see r3-alpha-apply)}
+ apply-non-function: [:arg1 {needs to be a function for APPLY/SPECIALIZE}]
+
+ invalid-tighten: {TIGHTEN does not support SPECIALIZE/ADAPT/CHAIN}
+ print-needs-eval: {PRINT needs /EVAL to process non-literal blocks}
+
+ hijack-blank: {Hijacked function was captured but no body given yet}
+
+ expression-barrier: {Expression barrier hit while processing arguments}
+ bar-hit-mid-case: {Expression barrier hit in middle of CASE pairing}
+ enfix-quote-late: [:arg1 {can't left quote a forward quoted value}]
+ partial-lookback: [:arg1 {can't complete} :arg2 {expression on left}]
+ evaluate-void: {voids cannot be evaluated}
+
+ enfix-path-group: [:arg1 {GROUP! can't be in a lookback quoted PATH!}]
+
+ hard-quote-void: [:arg1 {is hard quoted and can't be optionally void}]
+
+ reduce-made-void: {Expression in REDUCE evaluated to void}
+ break-not-continue: {Use BREAK/WITH when body is the breaking condition}
+
+ ; !!! Temporary errors while faulty constructs are still outstanding
+ ; (more informative than just saying "function doesn't take that type")
+ use-eval-for-eval: {Use EVAL or APPLY to call functions arity > 0, not DO}
+ use-fail-for-error: [{Use FAIL (not THROW or DO) to raise} :arg1]
+ use-split-simple: {Use SPLIT (instead of PARSE) for "simple" parsing}
+
+ limited-fail-input: {FAIL requires complex expressions to be in a GROUP!}
+
+ invalid-arg: [{invalid argument:} :arg1]
+ invalid-type: [:arg1 {type is not allowed here}]
+ invalid-op: [{invalid operator:} :arg1]
+ no-op-arg: [:arg1 {operator is missing an argument}]
+ invalid-data: [{data not in correct format:} :arg1]
+ not-same-type: {values must be of the same type}
+ not-related: [{incompatible argument for} :arg1 {of} :arg2]
+ bad-func-def: [{invalid function definition:} :arg1]
+ bad-func-arg: [{function argument} :arg1 {is not valid}] ; can be a number
+
+ needs-return-value: [:arg1 {must return value (use PROC or RETURN: )}]
+ bad-return-type: [:arg1 {doesn't have RETURN: enabled for} :arg2]
+
+ no-refine: [:arg1 {has no refinement called} :arg2]
+ bad-refines: {incompatible or invalid refinements}
+ bad-refine: [{incompatible or duplicate refinement:} :arg1]
+ argument-revoked: [:arg1 {refinement revoked, cannot supply} :arg2]
+ bad-refine-revoke: [:arg1 {refinement in use, can't be revoked by} :arg2]
+ non-logic-refine: [:arg1 {refinement must be LOGIC!, not} :arg2]
+ refinement-arg-opt: [{refinement arguments cannot be }]
+
+ invalid-path: [{cannot access} :arg2 {in path} :arg1]
+ bad-path-type: [{path} :arg1 {is not valid for} :arg2 {type}]
+ bad-path-set: [{cannot set} :arg2 {in path} :arg1]
+ bad-field-set: [{cannot set} :arg1 {field to} :arg2 {datatype}]
+ dup-vars: [{duplicate variable specified:} :arg1]
+
+ past-end: {out of range or past end}
+ missing-arg: {missing a required argument or refinement}
+ too-short: {content too short (or just whitespace)}
+ too-long: {content too long}
+ invalid-chars: {contains invalid characters}
+ invalid-compare: [{cannot compare} :arg1 {with} :arg2]
+
+ verify-void: [{verification condition void at:} :arg1]
+ verify-failed: [{verification failed for:} :arg1]
+
+ invalid-part: [{invalid /part count:} :arg1]
+
+ no-return: {block did not return a value}
+ block-lines: {expected block of lines}
+ no-catch: [{Missing CATCH for THROW of} :arg1]
+ no-catch-named: [{Missing CATCH for THROW of} :arg1 {with /NAME:} :arg2]
+
+ bad-bad: [:arg1 {error:} :arg2]
+
+ bad-make-arg: [{cannot MAKE/TO} :arg1 {from:} :arg2]
+; no-decode: [{cannot decode} :arg1 {encoding}]
+ wrong-denom: [:arg1 {not same denomination as} :arg2]
; bad-convert: [{invalid conversion value:} :arg1]
- bad-press: [{invalid compressed data - problem:} :arg1]
- dialect: [{incorrect} :arg1 {dialect usage at:} :arg2]
- bad-command: {invalid command format (extension function)}
+ bad-compression: [{invalid compressed data - problem:} :arg1]
+ dialect: [{incorrect} :arg1 {dialect usage at:} :arg2]
+ bad-command: {invalid command format (extension function)}
+ bad-cast: [{cannot cast} :arg1 {as} :arg2]
+
+ return-archetype: {RETURN called with no generator providing it in use}
+ leave-archetype: {LEAVE called with no generator providing it in use}
- parse-rule: [{PARSE - invalid rule or usage of rule:} :arg1]
- parse-end: [{PARSE - unexpected end of rule after:} :arg1]
- parse-variable: [{PARSE - expected a variable, not:} :arg1]
- parse-command: [{PARSE - command cannot be used as variable:} :arg1]
- parse-series: [{PARSE - input must be a series:} :arg1]
+ parse-rule: {PARSE - invalid rule or usage of rule}
+ parse-end: {PARSE - unexpected end of rule}
+ parse-variable: [{PARSE - expected a variable, not:} :arg1]
+ parse-command: [{PARSE - command cannot be used as variable:} :arg1]
+ parse-series: [{PARSE - input must be a series:} :arg1]
+ not-ffi-build: {This Rebol build wasn't linked with libffi features}
+ not-tcc-build: {This Rebol build wasn't linked with libtcc features}
+ bad-library: {bad library (already closed?)}
+ only-callback-ptr: {Only callback functions may be passed by FFI pointer}
+ free-needs-routine: {Function to destroy struct storage must be routine}
+
+ block-skip-wrong: {Block is not even multiple of skip size}
; bad-prompt: [{Error executing prompt block}]
; bad-port-action: [{Cannot use} :arg1 {on this type port}]
; face-error: [{Invalid graphics face object}]
; face-reused: [{Face object reused (in more than one pane):} :arg1]
+
+ frame-already-used: [{Frame currently in use by a function call} :arg1]
+ frame-not-on-stack: {Frame is no longer running on the stack}
+
+ recursive-varargs: {VARARGS! chained into itself (maybe try ?)}
+ varargs-no-stack: {Call originating VARARGS! has finished running}
+ varargs-make-only: {MAKE *shared* BLOCK! supported on VARARGS! (not TO)}
+ varargs-no-look: {VARARGS! may only lookahead by 1 if "hard quoted"}
+ varargs-take-last: {VARARGS! does not support TAKE-ing only /LAST item}
+
+ void-vararg-array: {Can't MAKE ANY-ARRAY! from VARARGS! that allow }
+ void-object-block: {Can't create block from object if it has void values}
+
+ map-key-unlocked: [{key must be LOCK-ed to add to MAP!} :arg1]
+ tcc-not-supported-opt: [{Option} :arg1 {is not supported}]
+ tcc-expect-word: [{Option expecting a word:} :arg1]
+ tcc-invalid-include: [{Include expects a block or a path:} :arg1]
+ tcc-invalid-options: [{Options expect string} :arg1]
+ tcc-invalid-library: [{Library expects a block or a path:} :arg1]
+ tcc-invalid-library-path: [{Library path expects a block or a path:} :arg1]
+ tcc-invalid-runtime-path: [{Runtime library path expects a block or a path:} :arg1]
+ tcc-empty-spec: {Spec for natives must not be empty}
+ tcc-empty-source: {Source for natives must not be empty}
+ tcc-construction: {TCC failed to create a TCC context}
+ tcc-set-options: {TCC failed to set TCC options}
+ tcc-include: [{TCC failed to add include path:} :arg1]
+ tcc-library: [{TCC failed to add library:} :arg1]
+ tcc-library-path: [{TCC failed to add library path:} :arg1]
+ tcc-runtime-path: [{TCC failed to add runtime library path:} :arg1]
+ tcc-output-type: {TCC failed to set output to memory}
+ tcc-compile: [{TCC failed to compile the code} :arg1]
+ tcc-relocate: {TCC failed to relocate the code}
+ tcc-invalid-name: [{C name must be a string:} :arg1]
+ tcc-sym-not-found: [{TCC failed to find symbol:} :arg1]
+ tcc-error-warn: [{TCC reported error/warnings. Fix error/warnings, or use '-w' to disable all of the warnings:} :arg1]
+
+ block-conditional: [{Literal block used as conditional} :arg1]
+ block-switch: [{Literal block used as switch value} :arg1]
+
+ non-unloadable-native: [{Not an unloadable native:} :arg1]
+ native-unloaded: [{Native has been unloaded:} :arg1]
+ fail-to-quit-extension: [{Failed to quit the extension:} :arg1]
]
Math: [
- code: 400
- type: "math error"
- zero-divide: {attempt to divide by zero}
- overflow: {math or number overflow}
- positive: {positive number required}
+ code: 4000
+ type: "math error"
+
+ zero-divide: {attempt to divide by zero}
+ overflow: {math or number overflow}
+ positive: {positive number required}
+
+ type-limit: [:arg1 {overflow/underflow}]
+ size-limit: [{maximum limit reached:} :arg1]
+ out-of-range: [{value out of range:} :arg1]
]
Access: [
- code: 500
- type: "access error"
+ code: 5000
+ type: "access error"
+
+ protected-word: [{variable} :arg1 {locked by PROTECT (see UNPROTECT)}]
+
+ series-protected: {series read-only due to PROTECT (see UNPROTECT)}
+ series-frozen: {series is source or permanently locked, can't modify}
+ series-running: {series temporarily read-only for running (DO, PARSE)}
+
+ hidden: {not allowed - would expose or modify hidden values}
- cannot-open: [{cannot open:} :arg1 {reason:} :arg2]
- not-open: [{port is not open:} :arg1]
- already-open: [{port is already open:} :arg1]
+ cannot-open: [{cannot open:} :arg1 {reason:} :arg2]
+ not-open: [{port is not open:} :arg1]
+ already-open: [{port is already open:} :arg1]
; already-closed: [{port} :arg1 {already closed}]
- no-connect: [{cannot connect:} :arg1 {reason:} :arg2]
- not-connected: [{port is not connected:} :arg1]
+ no-connect: [{cannot connect:} :arg1 {reason:} :arg2]
+ not-connected: [{port is not connected:} :arg1]
; socket-open: [{error opening socket:} :arg1]
- no-script: [{script not found:} :arg1]
-
- no-scheme-name: [{new scheme must have a name:} :arg1]
- no-scheme: [{missing port scheme:} :arg1]
-
- invalid-spec: [{invalid spec or options:} :arg1]
- invalid-port: [{invalid port object (invalid field values)}]
- invalid-actor: [{invalid port actor (must be native or object)}]
- invalid-port-arg: [{invalid port argument:} arg1]
- no-port-action: [{this port does not support:} :arg1]
- protocol: [{protocol error:} :arg1]
- invalid-check: [{invalid checksum (tampered file):} :arg1]
-
- write-error: [{write failed:} :arg1 {reason:} :arg2]
- read-error: [{read failed:} :arg1 {reason:} :arg2]
- read-only: [{read-only - write not allowed:} :arg1]
- no-buffer: [{port has no data buffer:} :arg1]
- timeout: [{port action timed out:} :arg1]
-
- no-create: [{cannot create:} :arg1]
- no-delete: [{cannot delete:} :arg1]
- no-rename: [{cannot rename:} :arg1]
- bad-file-path: [{bad file path:} :arg1]
- bad-file-mode: [{bad file mode:} :arg1]
+ no-script: [{script not found:} :arg1]
+
+ no-scheme-name: {Scheme has no `name:` field (must be WORD!)}
+ no-scheme: [{missing port scheme:} :arg1]
+
+ invalid-spec: [{invalid spec or options:} :arg1]
+ invalid-port: [{invalid port object (invalid field values)}]
+ invalid-actor: [{invalid port actor (must be native or object)}]
+ invalid-port-arg: [{invalid port argument:} :arg1]
+ no-port-action: [{this port does not support:} :arg1]
+ protocol: [{protocol error:} :arg1]
+ invalid-check: [{invalid checksum (tampered file):} :arg1]
+
+ write-error: [{write failed:} :arg1 {reason:} :arg2]
+ read-error: [{read failed:} :arg1 {reason:} :arg2]
+ read-only: [{read-only - write not allowed:} :arg1]
+ timeout: [{port action timed out:} :arg1]
+
+ no-create: [{cannot create:} :arg1]
+ no-delete: [{cannot delete:} :arg1]
+ no-rename: [{cannot rename:} :arg1]
+ bad-file-path: [{bad file path:} :arg1]
+ bad-file-mode: [{bad file mode:} :arg1]
; protocol: [{protocol error} :arg1]
security: [{security violation:} :arg1 { (refer to SECURE function)}]
security-level: [{attempt to lower security to} :arg1]
security-error: [{invalid} :arg1 {security policy:} :arg2]
- no-codec: [{cannot decode or encode (no codec):} :arg1]
- bad-media: [{bad media data (corrupt image, sound, video)}]
+ no-codec: [{cannot decode or encode (no codec):} :arg1]
+ bad-media: [{bad media data (corrupt image, sound, video)}]
; would-block: [{operation on port} :arg1 {would block}]
; no-action: [{this type of port does not support the} :arg1 {action}]
; serial-timeout: {serial port timeout}
- no-extension: [{cannot open extension:} :arg1]
- bad-extension: [{invalid extension format:} :arg1]
- extension-init: [{extension cannot be initialized (check version):} :arg1]
+ no-extension: [{cannot open extension:} :arg1]
+ bad-extension: [{invalid extension format:} :arg1]
+ extension-init: [{extension cannot be initialized (check version):} :arg1]
- call-fail: [{external process failed:} :arg1]
+ call-fail: [{external process failed:} :arg1]
+ symbol-not-found: [{symbol not found:} :arg1]
+ bad-memory: [{non-accessible memory at} :arg1 {in} :arg2]
+ no-external-storage: [{no external storage in the series}]
+ already-destroyed: [{storage at} :arg1 {already destroyed}]
]
Command: [
- code: 600
- type: "command error"
+ code: 6000
+ type: "command error"
+ bad-cmd-args: ["Bad command arguments"]
+ no-cmd: ["No command"]
; fmt-too-short: {Format string is too short}
; fmt-no-struct-size: [{Missing size spec for struct at arg#} :arg1]
; fmt-no-struct-align: [{Missing align spec for struct at arg#} :arg1]
@@ -203,32 +341,10 @@ Command: [
; cant-free: [{Cannot free} :arg1]
; nothing-to-free: {Nothing to free}
; ssl-error: [{SSL Error: } :arg1]
+ command-fail: ["Command failed"]
]
-resv700: [
- code: 700
- type: "reserved"
-]
-
-User: [
- code: 800
- type: "user error"
- message: [:arg1]
-]
+; If new category added, be sure to update RE_MAX in %make-boot.r
+; (currently RE_COMMAND_MAX because `Command: [...]` is the last category)
-Internal: [
- code: 900
- type: "internal error"
- bad-path: [{bad path:} arg1]
- not-here: [arg1 {not supported on your system}]
- no-memory: {not enough memory}
- stack-overflow: {stack overflow}
- globals-full: {no more global variable space}
- max-natives: {too many natives}
- bad-series: {invalid series}
- limit-hit: [{internal limit reached:} :arg1]
- bad-sys-func: [{invalid or missing system function:} :arg1]
- feature-na: {feature not available}
- not-done: {reserved for future use (or not yet implemented)}
- invalid-error: {error object or fields were not valid}
-]
+; Note that MAX_I32 is the hardcoded constant in %make-boot.r used for RE_USER
diff --git a/src/boot/graphics.r b/src/boot/graphics.r
deleted file mode 100644
index b592db5e95..0000000000
--- a/src/boot/graphics.r
+++ /dev/null
@@ -1,87 +0,0 @@
-REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "REBOL Graphics"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Name: graphics
- Type: extension
- Exports: [] ; added by make-host-ext.r
- Note: "Run make-host-ext.r to convert"
-]
-
-words: [
- ;gui-metric
- screen-size
- border-size
- border-fixed
- title-size
- work-origin
- work-size
-]
-
-;temp hack - will be removed later
-init-words: command [
- words [block!]
-]
-
-init-words words
-
-init: command [
- "Initialize graphics subsystem."
- gob [gob!] "The screen gob (root gob)"
-]
-
-caret-to-offset: command [
- "Returns the xy offset (pair) for a specific string position in a graphics object."
- gob [gob!]
- element [integer! block!] "The position of the string in the richtext block"
- position [integer! string!] "The position within the string"
-]
-
-cursor: command [
- "Changes the mouse cursor image."
- image [integer! image! none!]
-]
-
-offset-to-caret: command [ ;returns pair! instead of the block..needs to be fixed
- "Returns the richtext block at the string position for an XY offset in the graphics object."
- gob [gob!]
- position [pair!]
-]
-
-show: command [
- "Display or update a graphical object or block of them."
- gob [gob! none!]
-]
-
-size-text: command [
- "Returns the size of text rendered by a graphics object."
- gob [gob!]
-]
-
-draw: command [
- "Renders draw dialect (scalable vector graphics) to an image (returned)."
- image [image! pair!] "Image or size of image"
- commands [block!] "Draw commands"
-]
-
-gui-metric: command [
- "Returns specific gui related metric setting."
- keyword [word!] "Available keywords: SCREEN-SIZE, BORDER-SIZE, BORDER-FIXED, TITLE-SIZE, WORK-ORIGIN and WORK-SIZE."
-]
-
-;#not-yet-used [
-;
-;effect: command [
-; "Renders effect dialect to an image (returned)."
-; image [image! pair!] "Image or size of image"
-; commands [block!] "Effect commands"
-;]
-;
-;]
diff --git a/src/boot/modes.r b/src/boot/modes.r
index e4c01f5384..c6cd4b2c9c 100644
--- a/src/boot/modes.r
+++ b/src/boot/modes.r
@@ -1,14 +1,14 @@
REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Port modes"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
+ System: "REBOL [R3] Language Interpreter and Run-time Environment"
+ Title: "Port modes"
+ Rights: {
+ Copyright 2012 REBOL Technologies
+ REBOL is a trademark of REBOL Technologies
+ }
+ License: {
+ Licensed under the Apache License, Version 2.0.
+ See: http://www.apache.org/licenses/LICENSE-2.0
+ }
]
owner-read
diff --git a/src/boot/natives.r b/src/boot/natives.r
deleted file mode 100644
index 5e1b1c8ac9..0000000000
--- a/src/boot/natives.r
+++ /dev/null
@@ -1,1082 +0,0 @@
-REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Native function specs"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Note: [
- "Used to generates C enums and tables"
- "Boot bind attributes are SET and not DEEP"
- "Todo: before beta release remove extra/unused refinements"
- ]
-]
-
-;-- Control Natives - nat_control.c
-
-ajoin: native [
- {Reduces and joins a block of values into a new string.}
- block [block!]
-]
-
-also: native [
- {Returns the first value, but also evaluates the second.}
- value1 [any-type!]
- value2 [any-type!]
-]
-
-all: native [
- {Shortcut AND. Evaluates and returns at the first FALSE or NONE.}
- block [block!] {Block of expressions}
-]
-
-any: native [
- {Shortcut OR. Evaluates and returns the first value that is not FALSE or NONE.}
- block [block!] {Block of expressions}
-]
-
-apply: native [
- {Apply a function to a reduced block of arguments.}
- func [any-function!] "Function value to apply"
- block [block!] "Block of args, reduced first (unless /only)"
- /only "Use arg values as-is, do not reduce the block"
-]
-
-assert: native [
- "Assert that condition is true, else cause an assertion error."
- conditions [block!]
- /type "Safely check datatypes of variables (words and paths)"
-]
-
-attempt: native [
- "Tries to evaluate a block and returns result or NONE on error."
- block [block!]
-]
-
-break: native [
- {Breaks out of a loop, while, until, repeat, foreach, etc.}
- /return {Forces the loop function to return a value}
- value [any-type!]
-]
-
-case: native [
- {Evaluates each condition, and when true, evaluates what follows it.}
- block [block!] {Block of cases (conditions followed by values)}
- /all {Evaluate all cases (do not stop at first true case)}
-]
-
-catch: native [
- {Catches a throw from a block and returns its value.}
- block [block!] {Block to evaluate}
- /name {Catches a named throw}
- word [word! block!] {One or more names}
- /quit {Special catch for QUIT native}
-]
-
-;cause: native [
-; {Force error processing on an error value.}
-; error [error!]
-;]
-
-comment: native [
- {Ignores the argument value and returns nothing.}
- value {A string, block, file, etc.}
-]
-
-compose: native [
- {Evaluates a block of expressions, only evaluating parens, and returns a block.}
- value "Block to compose"
- /deep "Compose nested blocks"
- /only {Insert a block as a single value (not the contents of the block)}
- /into {Output results into a block with no intermediate storage}
- out [any-block!]
-]
-
-context: native [
- {Creates an object.}
- spec ; [block!] -- no check required, we know it is correct
-]
-
-continue: native [
- {Throws control back to top of loop.}
-]
-
-;dir?: native [
-; {Returns true if file is a directory.}
-; file [any-string! none!]
-; /any {Allow * or ? wildcards for directory}
-;]
-
-;disarm: native [
-; {(Deprecated - not needed) Converts error to an object. Other types not modified.}
-; error [any-type!]
-;]
-
-do: native [
- {Evaluates a block, file, URL, function, word, or any other value.}
- value [any-type!] "Normally a file name, URL, or block"
- /args "If value is a script, this will set its system/script/args"
- arg "Args passed to a script (normally a string)"
- /next "Do next expression only, return it, update block variable"
- var [word!] "Variable updated with new block position"
-]
-
-;eval: native [
-; {Evaluates a block, file, URL, function, word, or any other value.}
-; value "Normally a file name, URL, or block"
-;]
-
-either: native [
- {If TRUE condition return first arg, else second; evaluate blocks by default.}
- condition
- true-branch
- false-branch
- /only "Suppress evaluation of block args."
-]
-
-exit: native [
- {Exits a function, returning no value.}
-]
-
-find-script: native [
- {Find a script header within a binary string. Returns starting position.}
- script [binary!]
-]
-
-for: native [
- {Evaluate a block over a range of values. (See also: REPEAT)}
- 'word [word!] "Variable to hold current value"
- start [series! number!] "Starting value"
- end [series! number!] "Ending value"
- bump [number!] "Amount to skip each time"
- body [block!] "Block to evaluate"
-]
-
-forall: native [
- "Evaluates a block for every value in a series."
- 'word [word!] {Word that refers to the series, set to each position in series}
- body [block!] "Block to evaluate each time"
-]
-
-forever: native [
- {Evaluates a block endlessly.}
- body [block!] {Block to evaluate each time}
-]
-
-foreach: native [
- {Evaluates a block for each value(s) in a series.}
- 'word [word! block!] {Word or block of words to set each time (local)}
- data [series! any-object! map! none!] {The series to traverse}
- body [block!] {Block to evaluate each time}
-]
-
-forskip: native [
- "Evaluates a block for periodic values in a series."
- 'word [word!] {Word that refers to the series, set to each position in series}
- size [integer! decimal!] "Number of positions to skip each time"
- body [block!] "Block to evaluate each time"
- /local orig result
-]
-
-halt: native [
- {Stops evaluation and returns to the input prompt.}
-]
-
-if: native [
- {If TRUE condition, return arg; evaluate blocks by default.}
- condition
- true-branch
- /only "Return block arg instead of evaluating it."
-]
-
-loop: native [
- {Evaluates a block a specified number of times.}
- count [number!] {Number of repetitions}
- block [block!] {Block to evaluate}
-]
-
-map-each: native [
- {Evaluates a block for each value(s) in a series and returns them as a block.}
- 'word [word! block!] {Word or block of words to set each time (local)}
- data [block! vector!] {The series to traverse}
- body [block!] {Block to evaluate each time}
-]
-
-;replace-all: native [
-; "Search and replace multiple values with a series; returns a new series."
-; target [block! string! binary!]
-; values [block!] "A block of [old new] search/replace pairs"
-;]
-
-quit: native [
- {Stops evaluation and exits the interpreter.}
- /return {Returns a value (to prior script or command shell)}
- value {Note: use integers for command shell}
- /now {Quit immediately}
-]
-
-protect: native [
- "Protect a series or a variable from being modified."
- value [word! series! bitset! map! object! module!]
- /deep "Protect all sub-series/objects as well"
- /words "Process list as words (and path words)"
- /values "Process list of values (implied GET)"
- /hide "Hide variables (avoid binding and lookup)"
-]
-
-unprotect: native [
- "Unprotect a series or a variable (it can again be modified)."
- value [word! series! bitset! map! object! module!]
- /deep "Protect all sub-series as well"
- /words "Block is a list of words"
- /values "Process list of values (implied GET)"
-]
-
-recycle: native [
- {Recycles unused memory.}
- /off {Disable auto-recycling}
- /on {Enable auto-recycling}
- /ballast {Trigger for auto-recycle (memory used)}
- size [integer!]
- /torture {Constant recycle (for internal debugging)}
-]
-
-reduce: native [
- {Evaluates expressions and returns multiple results.}
- value
- /no-set {Keep set-words as-is. Do not set them.}
- /only {Only evaluate words and paths, not functions}
- words [block! none!] {Optional words that are not evaluated (keywords)}
- /into {Output results into a block with no intermediate storage}
- out [any-block!]
-]
-
-repeat: native [
- {Evaluates a block a number of times or over a series.}
- 'word [word!] {Word to set each time}
- value [number! series! none!] {Maximum number or series to traverse}
- body [block!] {Block to evaluate each time}
-]
-
-remove-each: native [
- {Removes values for each block that returns true; returns removal count.}
- 'word [word! block!] {Word or block of words to set each time (local)}
- data [series!] {The series to traverse (modified)}
- body [block!] {Block to evaluate (return TRUE to remove)}
-]
-
-return: native [
- {Returns a value from a function.}
- value [any-type!]
-]
-
-switch: native [
- "Selects a choice and evaluates the block that follows it."
- value "Target value"
- cases [block!] "Block of cases to check"
- /default case "Default case if no others found"
- /all "Evaluate all matches (not just first one)"
-]
-
-throw: native [
- {Throws control back to a previous catch.}
- value [any-type!] {Value returned from catch}
- /name {Throws to a named catch}
- word [word!]
-]
-
-trace: native [
- {Enables and disables evaluation tracing and backtrace.}
- mode [integer! logic!]
- /back {Set mode ON to enable or integer for lines to display}
- /function {Traces functions only (less output)}
-; /stack {Show stack index}
-]
-
-try: native [
- {Tries to DO a block and returns its value or an error.}
- block [block!]
- /except "On exception, evaluate this code block"
- code [block! any-function!]
-]
-
-unless: native [
- {If FALSE condition, return arg; evaluate blocks by default.}
- condition
- false-branch
- /only "Return block arg instead of evaluating it."
-]
-
-until: native [
- {Evaluates a block until it is TRUE. }
- block [block!]
-]
-
-while: native [
- {While a condition block is TRUE, evaluates another block.}
- cond-block [block!]
- body-block [block!]
-]
-
-;-- Data Natives - nat_data.c
-
-;alias: native [
-; See CC#1835
-; {Creates an alternate spelling for a word.}
-; word [word!] {Word to alias}
-; name [string!] {Name of alias}
-;]
-
-;as-binary: native [
-; {Coerces any type of string into a binary! datatype without copying it.}
-; string [any-string!]
-;]
-;
-;as-string: native [
-; {Coerces any type of string into a string! datatype without copying it.}
-; string [any-string!]
-;]
-
-bind: native [
- {Binds words to the specified context.}
- word [block! any-word!] {A word or block (modified) (returned)}
- context [any-word! any-object!] {A reference to the target context}
- /copy {Bind and return a deep copy of a block, don't modify original}
- /only {Bind only first block (not deep)}
- /new {Add to context any new words found}
- /set {Add to context any new set-words found}
-]
-
-unbind: native [
- {Unbinds words from context.}
- word [block! any-word!] {A word or block (modified) (returned)}
- /deep "Process nested blocks"
-]
-
-bound?: native [
- {Returns the context in which a word is bound.}
- word [any-word!]
-]
-
-collect-words: native [
- "Collect unique words used in a block (used for context construction)."
- block [block!]
- /deep "Include nested blocks"
- /set "Only include set-words"
- /ignore "Ignore prior words"
- words [any-object! block! none!] "Words to ignore"
-]
-
-checksum: native [
- {Computes a checksum, CRC, or hash.}
- data [binary!] {Bytes to checksum}
- /part length {Length of data}
- /tcp {Returns an Internet TCP 16-bit checksum}
- /secure {Returns a cryptographically secure checksum}
- /hash {Returns a hash value}
- size [integer!] {Size of the hash table}
- /method {Method to use}
- word [word!] {Methods: SHA1 MD5 CRC32}
- /key {Returns keyed HMAC value}
- key-value [any-string!] {Key to use}
-]
-
-compress: native [
- {Compresses a string series and returns it.}
- data [binary! string!] {If string, it will be UTF8 encoded}
- /part length {Length of data (elements)}
- /gzip {Use GZIP checksum}
-]
-
-decompress: native [
- {Decompresses data. Result is binary.}
- data [binary!] {Data to decompress}
- /part length {Length of compressed data (must match end marker)}
- /gzip {Use GZIP checksum}
- /limit size {Error out if result is larger than this}
-]
-
-construct: native [
- {Creates an object with scant (safe) evaluation.}
- block [block! string! binary!] "Specification (modified)"
- /with "Default object" object [object!]
- /only "Values are kept as-is"
-]
-
-debase: native [
- {Decodes binary-coded string (BASE-64 default) to binary value.}
- value [binary! string!] {The string to decode}
- /base {Binary base to use}
- base-value [integer!] {The base to convert from: 64, 16, or 2}
-]
-
-enbase: native [
- {Encodes a string into a binary-coded string (BASE-64 default).}
- value [binary! string!] {If string, will be UTF8 encoded}
- /base {Binary base to use}
- base-value [integer!] {The base to convert to: 64, 16, or 2}
-]
-
-decloak: native [
- {Decodes a binary string scrambled previously by encloak.}
- data [binary!] "Binary series to descramble (modified)"
- key [string! binary! integer!] "Encryption key or pass phrase"
- /with "Use a string! key as-is (do not generate hash)"
-]
-
-encloak: native [
- {Scrambles a binary string based on a key.}
- data [binary!] "Binary series to scramble (modified)"
- key [string! binary! integer!] "Encryption key or pass phrase"
- /with "Use a string! key as-is (do not generate hash)"
-]
-
-deline: native [
- "Converts string terminators to standard format, e.g. CRLF to LF."
- string [any-string!] {(modified)}
- /lines "Return block of lines (works for LF, CR, CR-LF endings) (no modify)"
-]
-
-enline: native [
- "Converts string terminators to native OS format, e.g. LF to CRLF."
- series [any-string! block!] {(modified)}
-]
-
-detab: native [
- "Converts tabs to spaces (default tab size is 4)."
- string [any-string!] {(modified)}
- /size "Specifies the number of spaces per tab"
- number [integer!]
-]
-
-entab: native [
- "Converts spaces to tabs (default tab size is 4)."
- string [any-string!] {(modified)}
- /size "Specifies the number of spaces per tab"
- number [integer!]
-]
-
-delect: native [
- "Parses a common form of dialects. Returns updated input block."
- dialect [object!] "Describes the words and datatypes of the dialect"
- input [block!] "Input stream to parse"
- output [block!] "Resulting values, ordered as defined (modified)"
- /in "Search for var words in specific objects (contexts)"
- where [block!] "Block of objects to search (non objects ignored)"
- /all "Parse entire block, not just one command at a time"
-]
-
-difference: native [
- {Returns the special difference of two values.}
- set1 [block! string! binary! bitset! date! typeset!] "First data set"
- set2 [block! string! binary! bitset! date! typeset!] "Second data set"
- /case {Uses case-sensitive comparison}
- /skip {Treat the series as records of fixed size}
- size [integer!]
-]
-
-exclude: native [
- {Returns the first data set less the second data set.}
- set1 [block! string! binary! bitset! typeset!] "First data set"
- set2 [block! string! binary! bitset! typeset!] "Second data set"
- /case {Uses case-sensitive comparison}
- /skip {Treat the series as records of fixed size}
- size [integer!]
-]
-
-intersect: native [
- {Returns the intersection of two data sets.}
- set1 [block! string! binary! bitset! typeset!] "first set"
- set2 [block! string! binary! bitset! typeset!] "second set"
- /case {Uses case-sensitive comparison}
- /skip {Treat the series as records of fixed size}
- size [integer!]
-]
-
-union: native [
- {Returns the union of two data sets.}
- set1 [block! string! binary! bitset! typeset!] "first set"
- set2 [block! string! binary! bitset! typeset!] "second set"
- /case {Use case-sensitive comparison}
- /skip {Treat the series as records of fixed size}
- size [integer!]
-]
-
-unique: native [
- {Returns the data set with duplicates removed.}
- set1 [block! string! binary! bitset! typeset!]
- /case {Use case-sensitive comparison (except bitsets)}
- /skip {Treat the series as records of fixed size}
- size [integer!]
-]
-
-lowercase: native [
- "Converts string of characters to lowercase."
- string [any-string! char!] {(modified if series)}
- /part {Limits to a given length or position}
- length [number! any-string!]
-]
-
-uppercase: native [
- "Converts string of characters to uppercase."
- string [any-string! char!] {(modified if series)}
- /part {Limits to a given length or position}
- length [number! any-string!]
-]
-
-dehex: native [
- {Converts URL-style hex encoded (%xx) strings.}
- value [any-string!] {The string to dehex}
-]
-
-get: native [
- {Gets the value of a word or path, or values of an object.}
- word {Word, path, object to get}
- /any {Allows word to have no value (allows unset)}
-]
-
-in: native [
- {Returns the word or block in the object's context.}
- object [any-object! block!]
- word [any-word! block! paren!] {(modified if series)}
-]
-
-parse: native [
- {Parses a string or block series according to grammar rules.}
- input [series!] {Input series to parse}
- rules [block! string! char! none!] {Rules to parse by (none = ",;")}
- /all {For simple rules (not blocks) parse all chars including whitespace}
- /case {Uses case-sensitive comparison}
-]
-
-set: native [
- {Sets a word, path, block of words, or object to specified value(s).}
- word [any-word! any-path! block! object!] {Word, block of words, path, or object to be set (modified)}
- value [any-type!] {Value or block of values}
- /any {Allows setting words to any value, including unset}
- /pad {For objects, if block is too short, remaining words are set to NONE}
-]
-
-to-hex: native [
- {Converts numeric value to a hex issue! datatype (with leading # and 0's).}
- value [integer! tuple!] {Value to be converted}
- /size {Specify number of hex digits in result}
- len [integer!]
-]
-
-type?: native [
- {Returns the datatype of a value.}
- value [any-type!]
- /word {Returns the datatype as a word}
-]
-
-unset: native [
- {Unsets the value of a word (in its current context.)}
- word [word! block!] {Word or block of words}
-]
-
-utf?: native [
- {Returns UTF BOM (byte order marker) encoding; + for BE, - for LE.}
- data [binary!]
-]
-
-invalid-utf?: native [
- {Checks UTF encoding; if correct, returns none else position of error.}
- data [binary!]
- /utf "Check encodings other than UTF-8"
- num [integer!] "Bit size - positive for BE negative for LE"
-]
-
-value?: native [
- {Returns TRUE if the word has a value.}
- value
-]
-
-;-- IO Natives - nat_io.c
-
-print: native [
- {Outputs a value followed by a line break.}
- value [any-type!] {The value to print}
-]
-
-prin: native [
- {Outputs a value with no line break.}
- value [any-type!]
-]
-
-mold: native [
- {Converts a value to a REBOL-readable string.}
- value [any-type!] {The value to mold}
- /only {For a block value, mold only its contents, no outer []}
- /all {Use construction syntax}
- /flat {No indentation}
-]
-
-form: native [
- {Converts a value to a human-readable string.}
- value [any-type!] {The value to form}
-]
-
-new-line: native [
- {Sets or clears the new-line marker within a block or paren.}
- position [block! paren!] {Position to change marker (modified)}
- value {Set TRUE for newline}
- /all {Set/clear marker to end of series}
- /skip {Set/clear marker periodically to the end of the series}
- size [integer!]
-]
-
-new-line?: native [
- {Returns the state of the new-line marker within a block or paren.}
- position [block! paren!] {Position to check marker}
-]
-
-to-local-file: native [
- {Converts a REBOL file path to the local system file path.}
- path [file! string!]
- /full "Prepends current dir for full path (for relative paths only)"
-]
-
-to-rebol-file: native [
- {Converts a local system file path to a REBOL file path.}
- path [file! string!]
-]
-
-transcode: native [
- {Translates UTF-8 binary source to values. Returns [value binary].}
- source [binary!] "Must be Unicode UTF-8 encoded"
- /next "Translate next complete value (blocks as single value)"
- /only "Translate only a single value (blocks dissected)"
- /error "Do not cause errors - return error object as value in place"
-]
-
-echo: native [
- {Copies console output to a file.}
- target [file! none! logic!]
-]
-
-now: native [
- {Returns date and time.}
- /year {Returns year only}
- /month {Returns month only}
- /day {Returns day of the month only}
- /time {Returns time only}
- /zone {Returns time zone offset from UCT (GMT) only}
- /date {Returns date only}
- /weekday {Returns day of the week as integer (Monday is day 1)}
- /yearday {Returns day of the year (Julian)}
- /precise {High precision time}
- /utc {Universal time (no zone)}
-]
-
-wait: native [
- {Waits for a duration, port, or both.}
- value [number! time! port! block! none!]
- /all {Returns all in a block}
-]
-
-wake-up: native [
- {Awake and update a port with event.}
- port [port!]
- event [event!]
-]
-
-what-dir: native ["Returns the current directory path."]
-
-change-dir: native [
- "Changes the current directory path."
- path [file!]
-]
-
-;-- Series Natives
-
-first: native [
- {Returns the first value of a series.}
- value
-]
-
-second: native [
- {Returns the second value of a series.}
- value
-]
-
-third: native [
- {Returns the third value of a series.}
- value
-]
-
-fourth: native [
- {Returns the fourth value of a series.}
- value
-]
-
-fifth: native [
- {Returns the fifth value of a series.}
- value
-]
-
-sixth: native [
- {Returns the sixth value of a series.}
- value
-]
-
-seventh: native [
- {Returns the seventh value of a series.}
- value
-]
-
-eighth: native [
- {Returns the eighth value of a series.}
- value
-]
-
-ninth: native [
- {Returns the ninth value of a series.}
- value
-]
-
-tenth: native [
- {Returns the tenth value of a series.}
- value
-]
-
-last: native [
- {Returns the last value of a series.}
- value [series! tuple! gob!]
-]
-
-;-- Math Natives - nat_math.c
-
-cosine: native [
- {Returns the trigonometric cosine.}
- value [number!] {In degrees by default}
- /radians {Value is specified in radians}
-]
-
-sine: native [
- {Returns the trigonometric sine.}
- value [number!] {In degrees by default}
- /radians {Value is specified in radians}
-]
-
-tangent: native [
- {Returns the trigonometric tangent.}
- value [number!] {In degrees by default}
- /radians {Value is specified in radians}
-]
-
-arccosine: native [
- {Returns the trigonometric arccosine (in degrees by default).}
- value [number!]
- /radians {Returns result in radians}
-]
-
-arcsine: native [
- {Returns the trigonometric arcsine (in degrees by default).}
- value [number!]
- /radians {Returns result in radians}
-]
-
-arctangent: native [
- {Returns the trigonometric arctangent (in degrees by default).}
- value [number!]
- /radians {Returns result in radians}
-]
-
-exp: native [
- {Raises E (the base of natural logarithm) to the power specified}
- power [number!]
-]
-
-log-10: native [
- {Returns the base-10 logarithm.}
- value [number!]
-]
-
-log-2: native [
- {Return the base-2 logarithm.}
- value [number!]
-]
-
-log-e: native [
- {Returns the natural (base-E) logarithm of the given value}
- value [number!]
-]
-
-not: native [
- {Returns the logic complement.}
- value {(Only FALSE and NONE return TRUE)}
-]
-
-square-root: native [
- {Returns the square root of a number.}
- value [number!]
-]
-
-shift: native [
- {Shifts an integer left or right by a number of bits.}
- value [integer!]
- bits [integer!] "Positive for left shift, negative for right shift"
- /logical "Logical shift (sign bit ignored)"
-]
-
-;-- New, hackish stuff:
-
-++: native [
- {Increment an integer or series index. Return its prior value.}
- 'word [word!] "Integer or series variable"
-]
-
---: native [
- {Decrement an integer or series index. Return its prior value.}
- 'word [word!] "Integer or series variable"
-]
-
-first+: native [
- {Return the FIRST of a series then increment the series index.}
- 'word [word!] "Word must refer to a series"
-]
-
-stack: native [
- {Returns stack backtrace or other values.}
- offset [integer!] "Relative backward offset"
- /block "Block evaluation position"
- /word "Function or object name, if known"
- /func "Function value"
- /args "Block of args (may be modified)"
- /size "Current stack size (in value units)"
- /depth "Stack depth (frames)"
- /limit "Stack bounds (auto expanding)"
-]
-
-resolve: native [
- {Copy context by setting values in the target from those in the source.}
- target [any-object!] {(modified)}
- source [any-object!]
- /only from [block! integer!] "Only specific words (exports) or new words in target (index to tail)"
- /all "Set all words, even those in the target that already have a value"
- /extend "Add source words to the target if necessary"
-]
-
-;in-context: native [
-; {Set the default context for global words.}
-; context [object!]
-;]
-
-get-env: native [
- {Returns the value of an OS environment variable (for current process).}
- var [any-string! any-word!]
-]
-
-set-env: native [
- {Sets the value of an operating system environment variable (for current process).}
- var [any-string! any-word!] "Variable to set"
- value [string! none!] "Value to set, or NONE to unset it"
-]
-
-list-env: native [
- {Returns a map of OS environment variables (for current process).}
-]
-
-call: native [
- {Run another program; return immediately.}
- command [string!] "An OS-local command line, quoted as necessary"
- /wait "Wait for command to terminate before returning"
-]
-
-browse: native [
- {Open web browser to a URL or local file.}
- url [url! file! none!]
-]
-
-evoke: native [
- {Special guru meditations. (Not for beginners.)}
- chant [word! block! integer!] "Single or block of words ('? to list)"
-]
-
-request-file: native [
- {Asks user to select a file and returns full file path (or block of paths).}
- /save "File save mode"
- /multi "Allows multiple file selection, returned as a block"
- /file name [file!] "Default file name or directory"
- /title text [string!] "Window title"
- /filter list [block!] "Block of filters (filter-name filter)"
-]
-
-ascii?: native [
- {Returns TRUE if value or string is in ASCII character range (below 128).}
- value [any-string! char! integer!]
-]
-
-latin1?: native [
- {Returns TRUE if value or string is in Latin-1 character range (below 256).}
- value [any-string! char! integer!]
-]
-
-; Temps...
-
-stats: native [
- {Provides status and statistics information about the interpreter.}
- /show {Print formatted results to console}
- /profile {Returns profiler object}
- /timer {High resolution time difference from start}
- /evals {Number of values evaluated by interpreter}
-]
-
-do-codec: native [
- {Evaluate a CODEC function to encode or decode media types.}
- handle [handle!] "Internal link to codec"
- action [word!] "Decode, encode, identify"
- data [binary! image!]
-]
-
-set-scheme: native [
- "Low-level port scheme actor initialization."
- scheme [object!]
-]
-
-load-extension: native [
- "Low level extension module loader (for DLLs)."
- name [file! binary!] "DLL file or UTF-8 source"
- /dispatch "Specify native command dispatch (from hosted extensions)"
- function [handle!] "Command dispatcher (native)"
-]
-
-do-commands: native [
- "Evaluate a block of extension module command functions (special evaluation rules.)"
- commands [block!] "Series of commands and their arguments"
-]
-
-ds: native ["Temporary stack debug"]
-dump: native ["Temporary debug dump" v]
-check: native ["Temporary series debug check" val [series!]]
-
-do-callback: native [
- "Internal function to process callback events."
- event [event!] "Callback event"
-]
-
-
-limit-usage: native [
- "Set a usage limit only once (used for SECURE)."
- field [word!] "eval (count) or memory (bytes)"
- limit [number!]
-]
-
-selfless?: native [
- "Returns true if the context doesn't bind 'self."
- context [any-word! any-object!] "A reference to the target context"
-]
-
-map-event: native [
- "Returns event with inner-most graphical object and coordinate."
- event [event!]
-]
-
-map-gob-offset: native [
- "Translates a gob and offset to the deepest gob and offset in it, returned as a block."
- gob [gob!] "Starting object"
- xy [pair!] "Staring offset"
- /reverse "Translate from deeper gob to top gob."
-]
-
-as-pair: native [
- "Combine X and Y values into a pair."
- x [number!]
- y [number!]
-]
-
-;read-file: native [f [file!]]
-
-equal?: native [
- {Returns TRUE if the values are equal.}
- value1 [any-type!]
- value2 [any-type!]
-]
-
-not-equal?: native [
- {Returns TRUE if the values are not equal.}
- value1 [any-type!]
- value2 [any-type!]
-]
-
-equiv?: native [
- {Returns TRUE if the values are equivalent.}
- value1 [any-type!]
- value2 [any-type!]
-]
-
-not-equiv?: native [
- {Returns TRUE if the values are not equivalent.}
- value1 [any-type!]
- value2 [any-type!]
-]
-
-strict-equal?: native [
- {Returns TRUE if the values are strictly equal.}
- value1 [any-type!]
- value2 [any-type!]
-]
-
-strict-not-equal?: native [
- {Returns TRUE if the values are not strictly equal.}
- value1 [any-type!]
- value2 [any-type!]
-]
-
-same?: native [
- {Returns TRUE if the values are identical.}
- value1 [any-type!]
- value2 [any-type!]
-]
-
-greater?: native [ ; Note: some datatypes expect >, <, >=, <= to be in this order.
- {Returns TRUE if the first value is greater than the second value.}
- value1 value2
-]
-
-greater-or-equal?: native [
- {Returns TRUE if the first value is greater than or equal to the second value.}
- value1 value2
-]
-
-lesser?: native [
- {Returns TRUE if the first value is less than the second value.}
- value1 value2
-]
-
-lesser-or-equal?: native [
- {Returns TRUE if the first value is less than or equal to the second value.}
- value1 value2
-]
-
-minimum: native [
- {Returns the lesser of the two values.}
- value1 [scalar! date! series!]
- value2 [scalar! date! series!]
-]
-
-maximum: native [ ; Note: Some datatypes expect all binary ops to be <= this
- {Returns the greater of the two values.}
- value1 [scalar! date! series!]
- value2 [scalar! date! series!]
-]
-
-negative?: native [
- {Returns TRUE if the number is negative.}
- number [number! money! time! pair!]
-]
-
-positive?: native [
- {Returns TRUE if the value is positive.}
- number [number! money! time! pair!]
-]
-
-zero?: native [
- {Returns TRUE if the value is zero (for its datatype).}
- value
-]
diff --git a/src/boot/ops.r b/src/boot/ops.r
deleted file mode 100644
index a2b016ab14..0000000000
--- a/src/boot/ops.r
+++ /dev/null
@@ -1,37 +0,0 @@
-REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Infix operator symbol definitions"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- This table maps infix operator symbols to function names.
- }
-]
-
-+ add
-- subtract
-* multiply
-/ divide
-// remainder
-** power
-= equal?
-=? same?
-== strict-equal?
-!= not-equal?
-<> not-equal?
-!== strict-not-equal?
-< lesser?
-<= lesser-or-equal?
-> greater?
->= greater-or-equal?
-& and~
-| or~
-and and~
-or or~
-xor xor~
diff --git a/src/boot/platforms.r b/src/boot/platforms.r
index c4f454fbcc..196c27b739 100644
--- a/src/boot/platforms.r
+++ b/src/boot/platforms.r
@@ -1,31 +1,102 @@
REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Platform definitions"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- Platform identification found in system object.
- }
-]
-
-Amiga [1 m68k20+ 2 m68k 3 ppc]
-Macintosh [1 mac-ppc 2 mac-m68k 3 mac-misc 4 osx-ppc 5 osx-x86]
-Windows [1 win32-x86 2 dec-alpha]
-Linux [1 libc5-x86 2 libc6-2-3-x86 3 libc6-2-5-x86 4 libc6-2-11-x86 10 libc6-ppc 20 libc6-arm 21 bionic-arm 30 libc6-mips]
-Haiku [75 x86-32]
-BSDi [1 x86]
-FreeBSD [1 x86 2 elf-x86]
-NetBSD [1 x86 2 ppc 3 m68k 4 dec-alpha 5 sparc]
-OpenBSD [1 x86 2 ppc 3 m68k 4 elf-x86 5 sparc]
-Sun [1 sparc]
-SGI []
-HP []
-Android [1 arm]
-free-slot []
-WindowsCE [1 sh3 2 mips 5 arm 6 sh4]
+ System: "REBOL [R3] Language Interpreter and Run-time Environment"
+ Title: "Platform definitions"
+ Rights: {
+ Copyright 2012 REBOL Technologies
+ REBOL is a trademark of REBOL Technologies
+ }
+ License: {
+ Licensed under the Apache License, Version 2.0.
+ See: http://www.apache.org/licenses/LICENSE-2.0
+ }
+ Purpose: {
+ Platform identification found in system object.
+ }
+]
+
+1 Amiga [
+ 1 m68k20+
+ 2 m68k
+ 3 ppc
+]
+
+2 Macintosh [
+ 1 mac-ppc
+ 2 mac-m68k
+ 3 mac-misc
+ 4 osx-ppc
+ 5 osx-x86
+]
+
+3 Windows [
+ 1 win32-x86
+ 2 dec-alpha
+ 40 win32-x64
+]
+
+4 Linux [
+ 1 libc5-x86
+ 2 libc6-2-3-x86
+ 3 libc6-2-5-x86
+ 4 libc6-2-11-x86
+ 10 libc6-ppc
+ 11 libc6-ppc64
+ 20 libc6-arm
+ 22 libc6-aarch64
+ 30 libc6-mips
+ 31 libc6-mips32be
+ 40 libc-x64
+ 60 dec-alpha
+ 61 libc-ia64
+]
+
+5 Haiku [
+ 75 x86-32
+]
+
+6 BSDi [
+ 1 x86
+]
+
+7 FreeBSD [
+ 1 x86
+ 2 elf-x86
+]
+
+8 NetBSD [
+ 1 x86
+ 2 ppc
+ 3 m68k
+ 4 dec-alpha
+ 5 sparc
+]
+
+9 OpenBSD [
+ 1 x86
+ 2 ppc
+ 3 m68k
+ 4 elf-x86
+ 5 sparc
+ 40 elf-x64
+]
+
+10 Sun [
+ 1 sparc
+]
+
+11 SGI []
+
+12 HP []
+
+13 Android [
+ 1 arm
+]
+
+14 free-slot []
+
+15 WindowsCE [
+ 1 sh3
+ 2 mips
+ 5 arm
+ 6 sh4
+]
diff --git a/src/boot/root.r b/src/boot/root.r
index b617cffc80..eec43d485b 100644
--- a/src/boot/root.r
+++ b/src/boot/root.r
@@ -1,31 +1,40 @@
REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Root context"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- Root system values. This context is hand-made very early at boot time
- to allow it to hold key system values during boot up. Most of these
- are put here to prevent them from being garbage collected.
- }
- Note: "See Task Context for per-task globals"
+ System: "REBOL [R3] Language Interpreter and Run-time Environment"
+ Title: "Root context"
+ Rights: {
+ Copyright 2012 REBOL Technologies
+ REBOL is a trademark of REBOL Technologies
+ }
+ License: {
+ Licensed under the Apache License, Version 2.0.
+ See: http://www.apache.org/licenses/LICENSE-2.0
+ }
+ Purpose: {
+ Root system values. This context is hand-made very early at boot time
+ to allow it to hold key system values during boot up. Most of these
+ are put here to prevent them from being garbage collected.
+ }
+ Note: "See Task Context for per-task globals"
]
-self ; (hand-built CONTEXT! value - but, has no WORD table!)
-root ; the root context as a block (for GC protection)
+system ; system object
+typesets ; block of TYPESETs used by system; expandable
+empty-block ; a value that is an empty BLOCK!
+empty-string ; a value that is an empty STRING!
-system ; system object
-errobj ; error object template
-strings ; low-level strings accessed via Boot_Strs[] (GC protection)
-typesets ; block of TYPESETs used by system; expandable
-noneval ; NONE value
-noname ; noname function word
+space-char ; a value that is a space CHAR!
+newline-char ; a value that is a newline CHAR!
-boot ; boot block defined in boot.r (GC'd after boot is done)
+;; Tags used in the native-optimized versions of user-function-generators
+;; FUNC and PROC
+with-tag ; for no locals gather (disables RETURN/LEAVE in FUNC)
+ellipsis-tag ; FUNC+PROC use as alternative to [[]] to mark varargs
+opt-tag ; FUNC+PROC use as alternative to _ to mark optional void? args
+end-tag ; FUNC+PROC use as alternative to | to mark endable args
+local-tag ; marks the beginning of a list of "pure locals"
+durable-tag ; !!! In progress - argument word lookup survives call ending
+
+;; !!! See notes on FUNCTION-META in %sysobj.r
+
+function-meta
diff --git a/src/boot/shape.r b/src/boot/shape.r
deleted file mode 100644
index dd3e100eef..0000000000
--- a/src/boot/shape.r
+++ /dev/null
@@ -1,137 +0,0 @@
-REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "REBOL Graphics - SHAPE commands"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Name: shape
- Type: extension
- Exports: none
- Note: "Run make-host-ext.r to convert"
-]
-
-;don't change order of already defined words unless you know what you are doing
-
-words: [
- ;arc
- negative
- positive
- small
- large
-]
-
-;temp hack - will be removed later
-init-words: command [
- words [block!]
-]
-
-init-words words
-
-;please alphabetize the order of commands so it easier to lookup things
-
-arc: command [
- "Draws an elliptical arc from the current point."
- end-point [pair!]
- radius [pair!]
- angle [number!]
- 'sweep-flag [word!] "The arc will be drawn in POSITIVE or NEGATIVE angle direction"
- 'arc-flag [word!] "User SMALL or LARGE arc sweep"
-]
-
-arc': command [
- "Draws an elliptical arc from the current point.(uses relative coordinates)"
- end-point [pair!]
- radius [pair!]
- angle [number!]
- 'sweep-flag [word!] "The arc will be drawn in POSITIVE or NEGATIVE angle direction"
- 'arc-flag [word!] "User SMALL or LARGE arc sweep"
-]
-
-close: command [
- "Closes previously defined set of lines in the SHAPE block."
-]
-
-curv: command [
- "Draws a cubic Bezier curve or polybezier using two points."
- points [block!] "Block of point pairs (2nd control point, end point)"
-]
-
-curv': command [
- "Draws a cubic Bezier curve or polybezier using two points.(uses relative coordinates)"
- points [block!] "Block of point pairs (2nd control point, end point)"
-]
-
-curve: command [
- "Draws a cubic Bezier curve or polybezier using three points."
- points [block!] "Block of point triplets (1st control point, 2nd control point, end point)"
-]
-
-curve': command [
- "Draws a cubic Bezier curve or polybezier using three points.(uses relative coordinates)"
- points [block!] "Block of point triplets (1st control point, 2nd control point, end point)"
-]
-
-hline: command [
- "Draws a horizontal line from the current point."
- end-x [number!]
-]
-
-hline': command [
- "Draws a horizontal line from the current point.(uses relative coordinates)"
- end-x [number!]
-]
-
-line: command [
- "Draws a line from the current point through the given points."
- points [pair! block!]
-]
-
-line': command [
- "Draws a line from the current point through the given points.(uses relative coordinates)"
- points [pair! block!]
-]
-
-move: command [
- "Set's the starting point for a new path without drawing anything."
- point [pair!]
-]
-
-move': command [
- "Set's the starting point for a new path without drawing anything.(uses relative coordinates)"
- point [pair!]
-]
-
-qcurv: command [
- "Draws a quadratic Bezier curve from the current point to end point."
- end-point [pair!]
-]
-
-qcurv': command [
- "Draws a quadratic Bezier curve from the current point to end point.(uses relative coordinates)"
- end-point [pair!]
-]
-
-qcurve: command [
- "Draws a quadratic Bezier curve using two points."
- points [block!] "Block of point pairs (control point, end point)"
-]
-
-qcurve': command [
- "Draws a quadratic Bezier curve using two points.(uses relative coordinates)"
- points [block!] "Block of point pairs (control point, end point)"
-]
-
-vline: command [
- "Draws a vertical line from the current point."
- end-y [number!]
-]
-
-vline': command [
- "Draws a vertical line from the current point.(uses relative coordinates)"
- end-y [number!]
-]
diff --git a/src/boot/strings.r b/src/boot/strings.r
deleted file mode 100644
index 1afae127b8..0000000000
--- a/src/boot/strings.r
+++ /dev/null
@@ -1,149 +0,0 @@
-REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Low-level strings"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- This section holds lower-level C strings used in various parts
- of the system. This section is unique, because it constructs a
- single C string that contains all the specified strings below.
- This is done to eliminate series headers required for normal
- REBOL strings. The strings are referenced using Boot_Strs[RS_*]
- where * is the set-word (and is zero based). For example:
- RS_SCAN+3 refers to "end-of-paren"
- }
-]
-
-scan: ; Used by scanner. Keep in sync with Value_Types in scan.h file!
- "end-of-script"
- "line"
- "end-of-block"
- "end-of-paren"
- "word"
- "word-set"
- "word-get"
- "word-lit"
- "none"
- "logic"
- "integer"
- "decimal"
- "percent"
- "money"
- "time"
- "date"
- "char"
- "block"
- "paren"
- "string"
- "binary"
- "pair"
- "tuple"
- "file"
- "email"
- "url"
- "issue"
- "tag"
- "path"
- "refine"
- "construct"
-
-info:
- "Booting..."
-
-;secure:
-; "Script requests permission to "
-; "Script requests permission to lower security level"
-; "REBOL - Security Violation"
-; "unknown"
-
-;secopts:
-; "open a port for read only on: "
-; "open a port for read/write on: "
-; "delete: "
-; "rename: "
-; "make a directory named: "
-; "lower security"
-; "execute a system shell command: "
-
-trace:
- "trace"
- "%-02d: %50r"
- " : %50r"
- " : %s %50m"
- " : %s"
- "--> %s"
- "<-- %s =="
- "Parse match: %r"
- "Parse input: %s"
- "Parse back: %r"
- "**: error : %r %r" ; 10
-
-stack:
- "STACK Expanded - DSP: %d MAX: %d"
- "^/STACK[%d] %s[%d] %s"
-
-dump:
- "^/--REBOL Kernel Dump--"
- "Evaluator:"
- " Cycles: %d" ; only lower bits
- " Counter: %d"
- " Dose: %d"
- " Signals: %x"
- " Sigmask: %x"
- " DSP: %d"
- " DSF: %d"
- "Memory/GC:"
- " Ballast: %d"
- " Disable: %d"
- " Protect: %d"
- " Infants: %d"
-
-;stats:
-; "Stats: bad series value: %d in: %x offset: %d size: %d"
-
-error:
- "out of memory (req %d bytes)"
- "invalid series width %d got %d type %d"
-; "error catalog object out of range"
-; "error num in category out of range"
- "error already caught"
- "stack overflow"
- "I/O error"
- "too many words"
- "word list buffer in use"
- "locked series"
- "error recycled"
- "top level error not caught"
- "error state underflow"
- "event queue overflow (WAIT recursion?)"
- "not available (NA)"
-
-errs:
- " error: "
- "(improperly formatted error)"
- "** Where: "
- "** Near: "
-
-watch:
- "RECYCLING: "
- "%d series"
- "obj-copy: %d %m"
-
-extension:
- "RX_Init"
- "RX_Quit"
- "RX_Call"
-
-;plugin:
-; "cannot open"
-; "missing function"
-; "wrong version"
-; "no header"
-; "bad header"
-; "boot code failed"
diff --git a/src/boot/sysobj.r b/src/boot/sysobj.r
index 7bab968b3f..65178ab8fc 100644
--- a/src/boot/sysobj.r
+++ b/src/boot/sysobj.r
@@ -1,27 +1,28 @@
REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "System object"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- Defines the system object. This is a special block that is evaluted
- such that its words do not get put into the current context.
- }
- Note: "Remove older/unused fields before beta release"
+ System: "REBOL [R3] Language Interpreter and Run-time Environment"
+ Title: "System object"
+ Rights: {
+ Copyright 2012 REBOL Technologies
+ REBOL is a trademark of REBOL Technologies
+ }
+ License: {
+ Licensed under the Apache License, Version 2.0.
+ See: http://www.apache.org/licenses/LICENSE-2.0
+ }
+ Purpose: {
+ Defines the system object. This is a special block that is evaluted
+ such that its words do not get put into the current context.
+ }
+ Note: "Remove older/unused fields before beta release"
]
-product: 'core
-
-; Next three fields are updated during build:
+; Next five fields are updated during build:
version: 0.0.0
build: 1
-platform: none
+platform: _
+commit: _
+
+product: _ ;-- assigned by startup of the host ('core, 'view, 'ren-garden...)
license: {Copyright 2012 REBOL Technologies
REBOL is a trademark of REBOL Technologies
@@ -29,488 +30,634 @@ Licensed under the Apache License, Version 2.0.
See: http://www.apache.org/licenses/LICENSE-2.0
}
-catalog: context [
- ; Static (non-changing) values, blocks, objects
- datatypes: []
- actions: none
- natives: none
- errors: none
- reflectors: [spec body words values types title]
- ; Official list of system/options/flags that can appear.
- ; Must match host reb-args.h enum!
- boot-flags: [
- script args do import version debug secure
- help vers quiet verbose
- secure-min secure-max trace halt cgi boot-level no-window
- ]
+; !!! HAS is defined later, so this uses CONSTRUCT [] [body] instead.
+; MAKE OBJECT! is not used because that is too low-level (no evaluation or
+; collection of fields). Reconsider if base-funcs should be loaded before
+; the system object here, or if it should be able to work with just the
+; low level MAKE OBJECT! and not use things like `x: y: z: none` etc.
+
+catalog: construct [] [
+ ;
+ ; These catalogs are filled in by Init_System_Object()
+ ;
+ datatypes: _
+ actions: _
+ natives: _
+ errors: _
]
-contexts: context [
- root:
- sys:
- lib:
- user:
- none
+contexts: construct [] [
+ root:
+ sys:
+ lib:
+ user:
+ _
]
-state: context [
- ; Mutable system state variables
- note: "contains protected hidden fields"
- policies: context [ ; Security policies
- file: ; file access
- net: ; network access
- eval: ; evaluation limit
- memory: ; memory limit
- secure: ; secure changes
- protect: ; protect function
- debug: ; debugging features
- envr: ; read/write
- call: ; execute only
- browse: ; execute only
- 0.0.0
- extension: 2.2.2 ; execute only
- ]
- last-error: none ; used by WHY?
+state: construct [] [
+ ; Mutable system state variables
+ note: "contains protected hidden fields"
+ policies: construct [] [ ; Security policies
+ file: ; file access
+ net: ; network access
+ eval: ; evaluation limit
+ memory: ; memory limit
+ secure: ; secure changes
+ protect: ; protect function
+ debug: ; debugging features
+ envr: ; read/write
+ call: ; execute only
+ browse: ; execute only
+ 0.0.0
+ extension: 2.2.2 ; execute only
+ ]
+ last-error: _ ; used by WHY?
]
-modules: []
+modules: [] ;loaded modules
+extensions: [] ;loaded extensions
-codecs: context []
-
-dialects: context [
- secure:
- draw:
- effect:
- text:
- rebcode:
- none
-]
+codecs: make object! [[][]]
-schemes: context []
+schemes: make object! [[][]]
-ports: context [
- wait-list: [] ; List of ports to add to 'wait
- input: ; Port for user input.
- output: ; Port for user output
- echo: ; Port for echoing output
- system: ; Port for system events
- callback: none ; Port for callback events
-; serial: none ; serial device name block
+ports: construct [] [
+ wait-list: [] ; List of ports to add to 'wait
+ input: ; Port for user input.
+ output: ; Port for user output
+ system: ; Port for system events
+ callback: _ ; Port for callback events
+; serial: _ ; serial device name block
]
-locale: context [
- language: ; Human language locale
- language*:
- locale:
- locale*: none
- months: [
- "January" "February" "March" "April" "May" "June"
- "July" "August" "September" "October" "November" "December"
- ]
- days: [
- "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"
- ]
+locale: construct [] [
+ language: ; Human language locale
+ language*: _
+ library: _ ;make object! [modules: utilities: https://raw.githubusercontent.com/r3n/renclib/master/usermodules.reb]
+ locale:
+ locale*: _
+ months: [
+ "January" "February" "March" "April" "May" "June"
+ "July" "August" "September" "October" "November" "December"
+ ]
+ days: [
+ "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"
+ ]
]
-options: context [ ; Options supplied to REBOL during startup
- boot: ; The path to the executable
- home: ; Path of home directory
- path: ; Where script was started or the startup dir
- none
-
- flags: ; Boot flag bits (see system/catalog/boot-flags)
- script: ; Filename of script to evaluate
- args: ; Command line arguments passed to script
- do-arg: ; Set to a block if --do was specified
- import: ; imported modules
- debug: ; debug flags
- secure: ; security policy
- version: ; script version needed
- boot-level: ; how far to boot up
- none
-
- quiet: false ; do not show startup info (compatibility)
-
- binary-base: 16 ; Default base for FORMed binary values (64, 16, 2)
- decimal-digits: 15 ; Max number of decimal digits to print.
- module-paths: [%./]
- default-suffix: %.reb ; Used by IMPORT if no suffix is provided
- file-types: []
- result-types: none
+set in locale 'library construct [][
+ modules: https://raw.githubusercontent.com/r3n/renclib/master/usermodules.reb
+ utilities: https://raw.githubusercontent.com/r3n/renclib/master/userutils.reb
+]
+
+options: construct [] [ ; Options supplied to REBOL during startup
+ bin: _ ; Path to directory where Rebol executable binary lives
+ boot: _ ; Path of executable, ie. system/options/bin/r3-exe
+ home: _ ; Path of home directory
+ resources: _ ; users resources directory (for %user.r, skins, modules etc)
+ suppress: _ ; block of user --suppress items, eg [%rebol.r %user.r %console-skin.reb]
+ loaded: [] ; block with full paths to loaded start-up scripts
+ path: _ ; Where script was started or the startup dir
+
+ current-path: _ ; Current URL! or FILE! path to use for relative lookups
+
+ encap: _ ; The encapping data extracted
+ script: _ ; Filename of script to evaluate
+ args: _ ; Command line arguments passed to script
+ debug: _ ; debug flags
+ secure: _ ; security policy
+ version: _ ; script version needed
+
+ dump-size: 68 ; used by dump
+
+ quiet: false ; do not show startup info (compatibility)
+ about: false ; do not show full banner (about) on start-up
+ cgi: false
+ no-window: false
+ verbose: false
+
+ binary-base: 16 ; Default base for FORMed binary values (64, 16, 2)
+ decimal-digits: 15 ; Max number of decimal digits to print.
+ module-paths: [%./]
+ default-suffix: %.reb ; Used by IMPORT if no suffix is provided
+ file-types: []
+ result-types: _
+
+ ; Legacy Behaviors Options (paid attention to only by debug builds)
+
+ lit-word-decay: false
+ exit-functions-only: false
+ broken-case-semantics: false
+ refinements-blank: false
+ forever-64-bit-ints: false
+ print-forms-everything: false
+ break-with-overrides: false
+ none-instead-of-voids: false
+ dont-exit-natives: false
+ paren-instead-of-group: false
+ get-will-get-anything: false
+ no-reduce-nested-print: false
+ unlocked-source: false
+
+ ; These option will only apply if the function which is currently executing
+ ; was created after legacy mode was enabled, and if refinements-blank is
+ ; set (because that's what marks functions as "legacy" or not")
+ ;
+ no-switch-evals: false
+ no-switch-fallthrough: false
]
-script: context [
- title: ; Title string of script
- header: ; Script header as evaluated
- parent: ; Script that loaded the current one
- path: ; Location of the script being evaluated
- args: ; args passed to script
- none
+script: construct [] [
+ title: ; Title string of script
+ header: ; Script header as evaluated
+ parent: ; Script that loaded the current one
+ path: ; Location of the script being evaluated
+ args: ; args passed to script
+ _
]
-standard: context [
-
- error: context [ ; Template used for all errors:
- code: 0
- type: 'user
- id: 'message
- arg1:
- arg2:
- arg3:
- near:
- where:
- none
- ]
-
- script: context [
- title:
- header:
- parent:
- path:
- args:
- none
- ]
-
- header: context [
- title: {Untitled}
- name:
- type:
- version:
- date:
- file:
- author:
- needs:
- options:
- checksum:
-; compress:
-; exports:
-; content:
- none
- ]
-
- scheme: context [
- name: ; word of http, ftp, sound, etc.
- title: ; user-friendly title for the scheme
- spec: ; custom spec for scheme (if needed)
- info: ; prototype info object returned from query
-; kind: ; network, file, driver
-; type: ; bytes, integers, objects, values, block
- actor: ; standard action handler for scheme port functions
- awake: ; standard awake handler for this scheme's ports
- none
- ]
-
- port: context [ ; Port specification object
- spec: ; published specification of the port
- scheme: ; scheme object used for this port
- actor: ; port action handler (script driven)
- awake: ; port awake function (event driven)
- state: ; internal state values (private)
- data: ; data buffer (usually binary or block)
- locals: ; user-defined storage of local data
-; stats: ; stats on operation (optional)
- none
- ]
-
- port-spec-head: context [
- title: ; user-friendly title for port
- scheme: ; reference to scheme that defines this port
- ref: ; reference path or url (for errors)
- path: ; used for files
- none ; (extended here)
- ]
-
- port-spec-net: make port-spec-head [
- host: none
- port-id: 80
- none
- ]
-
- file-info: context [
- name:
- size:
- date:
- type:
- none
- ]
-
- net-info: context [
- local-ip:
- local-port:
- remote-ip:
- remote-port:
- none
- ]
-
- extension: context [
- lib-base: ; handle to DLL
- lib-file: ; file name loaded
- lib-boot: ; module header and body
- command: ; command function
- cmd-index: ; command index counter
- words: ; symbol references
- none
- ]
-
- stats: context [ ; port stats
- timer: ; timer (nanos)
- evals: ; evaluations
- eval-natives:
- eval-functions:
- series-made:
- series-freed:
- series-expanded:
- series-bytes:
- series-recycled:
- made-blocks:
- made-objects:
- recycles:
- none
- ]
-
- type-spec: context [
- title:
- type:
- none
- ]
-
- utype: none
- font: none ; mezz-graphics.h
- para: none ; mezz-graphics.h
+standard: construct [] [
+ ; FUNC+PROC implement a native-optimized variant of a function generator.
+ ; This is the body template that it provides as the code *equivalent* of
+ ; what it is doing (via a more specialized/internal method). Though
+ ; the only "real" body stored and used is the one the user provided
+ ; (substituted in #BODY), this template is used to "lie" when asked what
+ ; the BODY-OF the function is.
+ ;
+ ; The substitution location is hardcoded at index 5. It does not "scan"
+ ; to find #BODY, just asserts the position is an ISSUE!.
+ ;
+ func-body: [
+ return: make function! [
+ [{Returns a value from a function.} value [ any-value!]]
+ [exit/from/with (context-of 'return) :value]
+ ]
+ leave: make function! [
+ [{Leaves a function, giving no result to the caller.}]
+ [exit/from (context-of 'leave)]
+ ]
+ #BODY
+ ]
+
+ func-no-leave-body: [
+ return: make function! [
+ [{Returns a value from a function.} value [ any-value!]]
+ [exit/from/with (context-of 'return) :value]
+ ]
+ #BODY
+ ]
+
+ proc-body: [
+ leave: make function! [
+ [{Leaves a procedure, giving no result to the caller.}]
+ [exit/from (context-of 'leave)]
+ ]
+ #BODY
+ comment {No return value.}
+ ]
+
+ ; !!! The PORT! and actor code is deprecated, but this bridges it so
+ ; it doesn't have to build a spec by hand.
+ ;
+ port-actor-spec: [port-actor-parameter [ any-value!]]
+
+ ; !!! The %sysobj.r initialization currently runs natives (notably the
+ ; natives for making objects, and here using COMMENT because it can).
+ ; This means that if the FUNCTION-META information is going to be produced
+ ; from a spec block for natives, it wouldn't be available while the
+ ; natives are getting initialized.
+ ;
+ ; It may be desirable to sort out this dependency by using a construction
+ ; syntax and making this a MAP! or OBJECT! literal. In the meantime,
+ ; the archetypal context has to be created "by hand" for natives to use,
+ ; with this archetype used by the REDESCRIBE Mezzanine.
+ ;
+ function-meta: construct [] [
+ description:
+ return-type:
+ return-note:
+ parameter-types:
+ parameter-notes:
+ _
+ ]
+
+ ; The common case is that derived functions will not need to be
+ ; REDESCRIBE'd besides their title. If they are, then they switch the
+ ; meta archetype to `function-meta` and subset the parameters. Otherwise
+ ; HELP just follows the link (`specializee`, `adaptee`) and gets
+ ; descriptions there.
+ ;
+ ; !!! Due to wanting R3-Alpha to be able to run the bootstrap build,
+ ; these objects can't unset these fields. (make object! [x: ()] fails)
+ ; Hence the code has to overwrite the missing fields with voids.
+
+ specialized-meta: construct [] [
+ description:
+ specializee:
+ specializee-name:
+ _
+ ]
+
+ adapted-meta: construct [] [
+ description:
+ adaptee:
+ adaptee-name:
+ _
+ ]
+
+ chained-meta: construct [] [
+ description:
+ chainees:
+ chainee-names:
+ _
+ ]
+
+ ; !!! This is the template used for all errors, to which extra fields are
+ ; added if the error has parameters. It likely makes sense to put this
+ ; information into the META-OF of the error, so that parameterizing the
+ ; error does not require a keylist expansion...and also so that fields
+ ; like FILE and LINE would not conflict with parameters.
+ ;
+ error: construct [] [
+ code: _
+ type: _
+ id: _
+ message: _ ; a BLOCK! template with arg substitution or just a STRING!
+ near: _
+ where: _
+ file: _
+ line: _
+
+ ; Arguments will be allocated in the context at creation time if
+ ; necessary (errors with no arguments will just have a message)
+ ]
+
+ script: construct [] [
+ title:
+ header:
+ parent:
+ path:
+ args:
+ _
+ ]
+
+ header: construct [] [
+ title: {Untitled}
+ name:
+ type:
+ version:
+ date:
+ file:
+ author:
+ needs:
+ options:
+ checksum:
+; compress:
+; exports:
+; content:
+ _
+ ]
+
+ scheme: construct [] [
+ name: ; word of http, ftp, sound, etc.
+ title: ; user-friendly title for the scheme
+ spec: ; custom spec for scheme (if needed)
+ info: ; prototype info object returned from query
+; kind: ; network, file, driver
+; type: ; bytes, integers, objects, values, block
+ actor: ; standard action handler for scheme port functions
+ awake: ; standard awake handler for this scheme's ports
+ _
+ ]
+
+ port: construct [] [ ; Port specification object
+ spec: ; published specification of the port
+ scheme: ; scheme object used for this port
+ actor: ; port action handler (script driven)
+ awake: ; port awake function (event driven)
+ state: ; internal state values (private)
+ data: ; data buffer (usually binary or block)
+ locals: ; user-defined storage of local data
+; stats: ; stats on operation (optional)
+ _
+ ]
+
+ port-spec-head: construct [] [
+ title: ; user-friendly title for port
+ scheme: ; reference to scheme that defines this port
+ ref: ; reference path or url (for errors)
+ path: ; used for files
+ _ ; (extended here)
+ ]
+
+ port-spec-net: construct port-spec-head [
+ host: _
+ port-id: 80
+ ]
+
+ port-spec-serial: construct port-spec-head [
+ speed: 115200
+ data-size: 8
+ parity: _
+ stop-bits: 1
+ flow-control: _ ;not supported on all systems
+ ]
+
+ port-spec-signal: construct port-spec-head [
+ mask: [all]
+ ]
+
+ file-info: construct [] [
+ name:
+ size:
+ date:
+ type:
+ _
+ ]
+
+ net-info: construct [] [
+ local-ip:
+ local-port:
+ remote-ip:
+ remote-port:
+ _
+ ]
+
+ extension: construct [] [
+ header: ; extension hader: name, version, etc.
+ script: ; script to run after the extension is loaded. Could be
+ ; string! (uncompressed code) or binary! (compressed code).
+ ; Could be folded into "header", because it's only used to
+ ; pass script from the extension to LOAD-EXTENSION, and
+ ; cleared once the extensino is loaded. But keeping it
+ ; separate makes its purpose clear...
+ lib-base: ; handle to DLL
+ lib-file: ; file name loaded
+ modules:
+ _
+ ]
+
+ stats: construct [] [ ; port stats
+ timer: ; timer (nanos)
+ evals: ; evaluations
+ eval-natives:
+ eval-functions:
+ series-made:
+ series-freed:
+ series-expanded:
+ series-bytes:
+ series-recycled:
+ made-blocks:
+ made-objects:
+ recycles:
+ _
+ ]
+
+ type-spec: construct [] [
+ title:
+ type:
+ _
+ ]
+
+ utype: _
+ font: _ ; mezz-graphics.h
+ para: _ ; mezz-graphics.h
]
-view: context [
- screen-gob: none
- handler: none
- event-port: none
- metrics: context [
- screen-size: 0x0
- border-size: 0x0
- border-fixed: 0x0
- title-size: 0x0
- work-origin: 0x0
- work-size: 0x0
- ]
- event-types: [
- ; Event types. Order dependent for C and REBOL.
- ; Due to fixed C constants, this list cannot be reordered after release!
- ignore ; ignore event (0)
- interrupt ; user interrupt
- device ; misc device request
- callback ; callback event
- custom ; custom events
- error
- init
-
- open
- close
- connect
- accept
- read
- write
- wrote
- lookup
-
- ready
- done
- time
-
- show
- hide
- offset
- resize
- active
- inactive
- minimize
- maximize
- restore
-
- move
- down
- up
- alt-down
- alt-up
- aux-down
- aux-up
- key
- key-up ; Move above when version changes!!!
-
- scroll-line
- scroll-page
-
- drop-file
- ]
- event-keys: [
- ; Event types. Order dependent for C and REBOL.
- ; Due to fixed C constants, this list cannot be reordered after release!
- page-up
- page-down
- end
- home
- left
- up
- right
- down
- insert
- delete
- f1
- f2
- f3
- f4
- f5
- f6
- f7
- f8
- f9
- f10
- f11
- f12
- ]
+view: construct [] [
+ screen-gob: _
+ handler: _
+ event-port: _
+ event-types: [
+ ; Event types. Order dependent for C and REBOL.
+ ; Due to fixed C constants, this list cannot be reordered after release!
+ ignore ; ignore event (0)
+ interrupt ; user interrupt
+ device ; misc device request
+ callback ; callback event
+ custom ; custom events
+ error
+ init
+
+ open
+ close
+ connect
+ accept
+ read
+ write
+ wrote
+ lookup
+
+ ready
+ done
+ time
+
+ show
+ hide
+ offset
+ resize
+ rotate
+ active
+ inactive
+ minimize
+ maximize
+ restore
+
+ move
+ down
+ up
+ alt-down
+ alt-up
+ aux-down
+ aux-up
+ key
+ key-up ; Move above when version changes!!!
+
+ scroll-line
+ scroll-page
+
+ drop-file
+ ]
+ event-keys: [
+ ; Event types. Order dependent for C and REBOL.
+ ; Due to fixed C constants, this list cannot be reordered after release!
+ page-up
+ page-down
+ end
+ home
+ left
+ up
+ right
+ down
+ insert
+ delete
+ f1
+ f2
+ f3
+ f4
+ f5
+ f6
+ f7
+ f8
+ f9
+ f10
+ f11
+ f12
+ ]
]
-;;stats: none
+;;stats: _
;user-license: context [
-; name:
-; email:
-; id:
-; message:
-; none
+; name:
+; email:
+; id:
+; message:
+; _
;]
; (returns value)
-; model: ; Network, File, Driver
-; type: ; bytes, integers, values
-; user: ; User data
-
-; host:
-; port-id:
-; user:
-; pass:
-; target:
-; path:
-; proxy:
-; access:
-; allow:
-; buffer-size:
-; limit:
-; handler:
-; status:
-; size:
-; date:
-; sub-port:
-; locals:
-; state:
-; timeout:
-; local-ip:
-; local-service:
-; remote-service:
-; last-remote-service:
-; direction:
-; key:
-; strength:
-; algorithm:
-; block-chaining:
-; init-vector:
-; padding:
-; async-modes:
-; remote-ip:
-; local-port:
-; remote-port:
-; backlog:
-; device:
-; speed:
-; data-bits:
-; parity:
-; stop-bits:
-; none
-; rts-cts: true
-; user-data:
-; awake:
-
-; port-flags: context [
-; direct:
-; pass-thru:
-; open-append:
-; open-new:
-; none
-; ]
-
-; email: context [ ; Email header object
-; To:
-; CC:
-; BCC:
-; From:
-; Reply-To:
-; Date:
-; Subject:
-; Return-Path:
-; Organization:
-; Message-Id:
-; Comment:
-; X-REBOL:
-; MIME-Version:
-; Content-Type:
-; Content:
-; none
-; ]
-
-;user: context [
-; name: ; User's name
-; email: ; User's default email address
-; home: ; The HOME environment variable
-; words: none
-;]
+; model: ; Network, File, Driver
+; type: ; bytes, integers, values
+; user: ; User data
+
+; host:
+; port-id:
+; user:
+; pass:
+; target:
+; path:
+; proxy:
+; access:
+; allow:
+; buffer-size:
+; limit:
+; handler:
+; status:
+; size:
+; date:
+; sub-port:
+; locals:
+; state:
+; timeout:
+; local-ip:
+; local-service:
+; remote-service:
+; last-remote-service:
+; direction:
+; key:
+; strength:
+; algorithm:
+; block-chaining:
+; init-vector:
+; padding:
+; async-modes:
+; remote-ip:
+; local-port:
+; remote-port:
+; backlog:
+; device:
+; speed:
+; data-bits:
+; parity:
+; stop-bits:
+; _
+; rts-cts: true
+; user-data:
+; awake:
+
+; port-flags: construct [] [
+; direct:
+; pass-thru:
+; open-append:
+; open-new:
+; _
+; ]
+
+; email: construct [] [ ; Email header object
+; To:
+; CC:
+; BCC:
+; From:
+; Reply-To:
+; Date:
+; Subject:
+; Return-Path:
+; Organization:
+; Message-Id:
+; Comment:
+; X-REBOL:
+; MIME-Version:
+; Content-Type:
+; Content:
+; _
+; ]
+
+user: construct [] [
+ name: ; User's name
+ home: ; The HOME environment variable
+ words: _
+ identity: construct [][email: smtp: pop3: esmtp-user: esmtp-pass: fqdn: _]
+ identities: []
+]
-;network: context [
-; host: "" ; Host name of the user's computer
-; host-address: 0.0.0.0 ; Host computer's TCP-IP address
-; trace: none
+;network: construct [] [
+; host: "" ; Host name of the user's computer
+; host-address: 0.0.0.0 ; Host computer's TCP-IP address
+; trace: _
;]
-;console: context [
-; hide-types: none ; types not to print
-; history: ; Log of user inputs
-; keys: none ; Keymap for special key
-; prompt: {>> } ; Specifies the prompt
-; result: {== } ; Specifies result
-; escape: {(escape)} ; Indicates an escape
-; busy: {|/-\} ; Spinner for network progress
-; tab-size: 4 ; default tab size
-; break: true ; whether escape breaks or not
+console: _ ;; console (repl) object created in host-start (os/host-start.r)
+
+; Below is original console construct (unused and comment-out in r3/ren-c)
+; Left here for reference (for future development)
+;
+;console: construct [] [
+; hide-types: _ ; types not to print
+; history: _ ; Log of user inputs
+; keys: _ ; Keymap for special key
+; prompt: {>> } ; Specifies the prompt
+; result: {== } ; Specifies result
+; escape: {(escape)} ; Indicates an escape
+; busy: {|/-\} ; Spinner for network progress
+; tab-size: 4 ; default tab size
+; break: true ; whether escape breaks or not
;]
-; decimal: #"." ; The character used as the decimal point in decimal and money vals
-; sig-digits: none ; Significant digits to use for decimals ; none for normal printing
-; date-sep: #"-" ; The character used as the date separator
-; date-month-num: false ; True if months are displayed as numbers; False for names
-; time-sep: #":" ; The character used as the time separator
-; cgi: context [ ; CGI environment variables
-; server-software:
-; server-name:
-; gateway-interface:
-; server-protocol:
-; server-port:
-; request-method:
-; path-info:
-; path-translated:
-; script-name:
-; query-string:
-; remote-host:
-; remote-addr:
-; auth-type:
-; remote-user:
-; remote-ident:
-; Content-Type: ; cap'd for email header
-; content-length: none
-; other-headers: []
-; ]
-; browser-type: 0
-
-; trace: ; True if the --trace flag was specified
-; help: none ; True if the --help flags was specified
-; halt: none ; halt after script
+; decimal: #"." ; The character used as the decimal point in decimal and money vals
+; sig-digits: _ ; Significant digits to use for decimals ; blank for normal printing
+; date-sep: #"-" ; The character used as the date separator
+; date-month-num: false ; True if months are displayed as numbers; False for names
+; time-sep: #":" ; The character used as the time separator
+
+cgi: construct [] [ ; CGI environment variables
+ server-software:
+ server-name:
+ gateway-interface:
+ server-protocol:
+ server-port:
+ request-method:
+ path-info:
+ path-translated:
+ script-name:
+ query-string:
+ remote-host:
+ remote-addr:
+ auth-type:
+ remote-user:
+ remote-ident:
+ Content-Type: ; cap'd for email header
+ content-length: _
+ other-headers: []
+]
+; browser-type: 0
+
+; trace: ; True if the --trace flag was specified
+; help: _ ; True if the --help flags was specified
+; halt: _ ; halt after script
+;-- Expectation is that evaluation ends with no result, empty GROUP! does that
+()
diff --git a/src/boot/task.r b/src/boot/task.r
index c415b8a84f..bca925a870 100644
--- a/src/boot/task.r
+++ b/src/boot/task.r
@@ -1,34 +1,30 @@
REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Task context"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- Globals used for each task. Prevents GC of these values.
- See also the Root Context (program-wide globals)
- }
+ System: "REBOL [R3] Language Interpreter and Run-time Environment"
+ Title: "Task context"
+ Rights: {
+ Copyright 2012 REBOL Technologies
+ REBOL is a trademark of REBOL Technologies
+ }
+ License: {
+ Licensed under the Apache License, Version 2.0.
+ See: http://www.apache.org/licenses/LICENSE-2.0
+ }
+ Purpose: {
+ Globals used for each task. Prevents GC of these values.
+ See also the Root Vars (program-wide globals)
+ }
]
-self
-stack ; data stack
-ballast ; current memory ballast (used for GC)
-max-ballast ; ballast reset value
-this-error ; current error
-this-value ; for holding an error argument during throw back
-stack-error ; special stack error object
-this-context ; current context
-buf-emit ; temporary emit output block
-buf-words ; temporary word cache
-buf-utf8 ; UTF8 reused buffer
-buf-print ; temporary print output - used by raw print
-buf-form ; temporary form buffer - used by raw print
-buf-mold ; temporary mold buffer - used by mold
-mold-loop ; mold loop detection
-err-temps ; error temporaries
+ballast ; current memory ballast (used for GC)
+max-ballast ; ballast reset value
+
+stack-error ; special stack overlow error object
+halt-error ; special halt error object
+
+buf-collect ; temporary cache for collecting object keys or words
+buf-utf8 ; UTF8 reused buffer
+byte-buf ; temporary byte buffer - used mainly by raw print
+uni-buf ; temporary unicode buffer - used mainly by mold
+
+mold-stack ; mold loop detection
diff --git a/src/boot/text.r b/src/boot/text.r
deleted file mode 100644
index 2e5d2d82e8..0000000000
--- a/src/boot/text.r
+++ /dev/null
@@ -1,156 +0,0 @@
-REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "REBOL Graphics - TEXT commands"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0.
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Name: text
- Type: extension
- Exports: none
- Note: "Run make-host-ext.r to convert"
-]
-
-;don't change order of already defined words unless you know what you are doing
-
-words: [
- aliased
- antialiased
- vectorial
-
- ;font object words
- name
- style
- size
- color
- offset
- space
- shadow
-
- ;para object words
- origin
- margin
- indent
- tabs
- wrap?
- scroll
- align
- valign
-
- ;para/align values
- center
- right
- left
-
- ;para/valign values
- middle
- top
- bottom
-
- ;font/style values
- bold
- italic
- underline
-
- ;caret object words
- caret
- highlight-start
- highlight-end
-]
-
-;temp hack - will be removed later
-init-words: command [
- words [block!]
-]
-
-init-words words
-
-;please alphabetize the order of commands so it easier to lookup things
-
-anti-alias: command [
- "Sets aliasing mode."
- state [logic!]
-]
-
-b: bold: command [
- "Sets font BOLD style."
- state [logic!]
-]
-
-caret: command [
- "Sets paragraph attributes."
- caret-attributes [object!]
-]
-
-center: command [
- "Sets text alignment."
-]
-
-color: command [
- "Sets font color."
- font-color [tuple!]
-]
-
-drop: command [
- "Removes N previous style setting from the stack."
- count [integer!]
-]
-
-font: command [
- "Sets font attributes."
- font-attributes [object!]
-]
-
-i: italic: command [
- "Sets font ITALIC style."
- state [logic!]
-]
-
-left: command [
- "Sets text alignment."
-]
-
-nl: newline: command [
- "Breaks the text line."
-]
-
-para: command [
- "Sets paragraph attributes."
- para-attributes [object!]
-]
-
-right: command [
- "Sets text alignment."
-]
-
-scroll: command [
- "Sets text position."
- offset [pair!]
-]
-
-shadow: command [
- "Enables shadow effect for text."
- offset [pair!]
- color [tuple!]
- spread [integer!]
-]
-
-size: command [
- "Sets font size."
- font-size [integer!]
-]
-
-text: command [
- "Renders text string."
- text [string!]
-]
-
-u: underline: command [
- "Sets font UNDERLINE style."
- state [logic!]
-]
-
diff --git a/src/boot/types-ext.r b/src/boot/types-ext.r
deleted file mode 100644
index 8f5dbc223b..0000000000
--- a/src/boot/types-ext.r
+++ /dev/null
@@ -1,62 +0,0 @@
-REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Extension datatypes"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- Used to build C enums and definitions for extensions.
- }
-]
-
-end 0 0
-unset * null
-none * null
-handle * ptr
-
-logic 4 32
-integer * 64
-decimal * 64
-percent * 64
-
-char 10 32
-pair * 64
-tuple * 64
-time * 64
-date * date
-
-word 16 sym
-set-word * sym
-get-word * sym
-lit-word * sym
-refinement * sym
-issue * sym
-
-string 24 ser
-file * ser
-email * ser
-url * ser
-tag * ser
-
-block 32 ser
-paren * ser
-path * ser
-set-path * ser
-get-path * ser
-lit-path * ser
-
-binary 40 ser
-bitset * ser
-vector * ser
-image * image
-
-gob 47 ser
-
-object 48 ptr
-module * ptr
-
diff --git a/src/boot/types.r b/src/boot/types.r
index 49471eba77..307b833d74 100644
--- a/src/boot/types.r
+++ b/src/boot/types.r
@@ -1,104 +1,125 @@
REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Datatype definitions"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- These words define the REBOL datatypes and their related attributes.
- This table generates a variety of C defines and intialization tables.
- During build, when this file is processed, this section is changed to
- hold just the datatype words - the initial entries the word table.
- }
+ System: "REBOL [R3] Language Interpreter and Run-time Environment"
+ Title: "Datatype definitions"
+ Rights: {
+ Copyright 2012 REBOL Technologies
+ REBOL is a trademark of REBOL Technologies
+ }
+ License: {
+ Licensed under the Apache License, Version 2.0
+ See: http://www.apache.org/licenses/LICENSE-2.0
+ }
+ Purpose: {
+ These words define the REBOL datatypes and their related attributes.
+ This table generates a variety of C defines and intialization tables.
+ During build, when this file is processed, this section is changed to
+ hold just the datatype words - the initial entries the word table.
+
+ name - name of datatype (generates words)
+ class - how type actions are dispatched (T_type), + is extension
+ path - it supports various path forms (* for same as typeclass)
+ make - It can be made with #[datatype] method
+ typesets - what typesets the type belongs to
+
+ Note that if there is `somename` in the class column, that means you
+ will find the ACTION! dispatch for that type in `REBTYPE(Somename)`.
+
+ If the (CLASS) is in a GROUP! that means it has evaluator behavior,
+ vs. being passed through as-is. (e.g. a lit-word is "evaluative")
+ This is used to build the table used for fast lookup of whether the
+ evaluator needs to be called on a given type.
+ }
]
-; Fields:
-; Datatype - name of datatype (generates words)
-; Evaluator - how it is evaluated (by DO)
-; Typeclass - how type actions are dispatched (T_type)
-; Mold - mold format: - self, + type, * typeclass
-; Form - form format: above, and f* for special form functions
-; Path - it supports various path forms (* for same as typeclass)
-; Make - It can be made with #[datatype] method
-
-; Datatype Evaluator Typeclass Mold Form Path Make Typesets
-;------------------------------------------------------------------------------
- end end 0 - - - - -
- unset self none - - - * -
-
- ;Scalars
- none self none + + - * -
- logic self logic * * - * -
- integer self integer * * - - [number scalar]
- decimal self decimal * * - * [number scalar]
- percent self decimal * * - * [number scalar]
- money self money * * - - scalar
- char self char * f* - - scalar
- pair self pair * * * * scalar
- tuple self tuple * * * * scalar
- time self time * * * * scalar
- date self date * * * * -
-
- ;Series
- binary self string + + * * [series]
- string self string + f* * * [series string]
- file self string + f* file * [series string]
- email self string + f* * * [series string]
- url self string + f* file * [series string]
- tag self string + + * * [series string]
-
- bitset self bitset * * * * -
- image self image + + * * series
- vector self vector - - * * series
-
- block self block * f* * * [series block]
- paren paren block * f* * * [series block]
-
- path path block * * * * [series block path]
- set-path path block * * * * [series block path]
- get-path path block * * * * [series block path]
- lit-path lit-path block * * * * [series block path]
-
- map self map + f* * * -
-
- datatype self datatype + f* - * -
- typeset self typeset + f* - * -
-
- ; Order dependent: next few words
- ;symbol invalid word * * - - word
- word word word + * - - word
- set-word set-word word + * - - word
- get-word get-word word + * - - word
- lit-word lit-word word + * - - word
- refinement self word + * - - word
- issue self word + * - - word
-
- native function function * - - * function
- action function function * - - * function
-; routine function routine - - - * function
- rebcode function 0 - - - * function
- command function function - - - * function
-; macro function 0 - - - - function
- op operator function - - - * function
- closure function function * - - * function
- function function function * - - * function
-
- frame invalid frame - - * - -
- object self object * f* * * object
- module self object * f* * * object
- error self object + f+ * * object
- task self object + + * * object
- port self port object object object - object
-
- gob self gob * * * * -
- event self event * * * * -
- handle self 0 - - - - -
- struct invalid 0 - - - - -
- library invalid 0 - - - - -
- utype self utype - - - - -
+[name class path make typesets]
+
+; 0 is not a real data type. It is reserved for internal purposes.
+
+0 0 - - -
+
+; There is only one FUNCTION! type in Ren-C
+
+function function * * -
+
+; ANY-WORD!, order matters (tests like ANY_WORD use >= REB_WORD, <= REB_ISSUE)
+;
+word word - * word
+set-word word - * word
+get-word word - * word
+lit-word word - * word
+refinement word - * word
+issue word - * word
+
+; ANY-ARRAY!, order matters (and contiguous with ANY-SERIES below matters!)
+;
+path array * * [series path array]
+set-path array * * [series path array]
+get-path array * * [series path array]
+lit-path array * * [series path array]
+group array * * [series array]
+block array * * [series array]
+
+; ANY-SERIES!, order matters (and contiguous with ANY-ARRAY above matters!)
+;
+binary string * * [series]
+string string * * [series string]
+file string * * [series string]
+email string * * [series string]
+url string * * [series string]
+tag string * * [series string]
+
+bitset bitset * * -
+image image * * [series]
+vector vector * * [series]
+
+map map * * -
+
+varargs varargs * * -
+
+object context * * context
+frame context * * context
+module context * * context
+error context * * context
+port port context * context
+
+; ^-------- Everything above is a "bindable" type, see Is_Bindable() --------^
+
+; v------- Everything below is an "unbindable" type, see Is_Bindable() ------v
+
+; "unit types" https://en.wikipedia.org/wiki/Unit_type
+
+bar unit - * -
+lit-bar unit - * -
+blank unit - * -
+
+; scalars
+
+logic logic - * -
+integer integer - * [number scalar]
+decimal decimal - * [number scalar]
+percent decimal - * [number scalar]
+money money - * scalar
+char char - * scalar
+pair pair * * scalar
+tuple tuple * * scalar
+time time * * scalar
+date date * * -
+
+; type system
+
+datatype datatype - * -
+typeset typeset - * -
+
+; things likely to become user-defined types or extensions
+
+gob gob * * -
+event event * * -
+handle handle - - -
+struct struct * * -
+library library - * -
+
+; Note that the "void?" state has no associated VOID! datatype. Internally
+; it uses REB_MAX, but like the REB_0 it stays off the type map. (REB_0
+; is used for lookback as opposed to void in order to implement an
+; optimization in Get_Var_Core())
diff --git a/src/boot/typespec.r b/src/boot/typespec.r
index d0608c3d4c..5ceaa9e6f3 100644
--- a/src/boot/typespec.r
+++ b/src/boot/typespec.r
@@ -1,75 +1,68 @@
REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Datatype help spec"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- Provides useful information about datatypes.
- Can be expanded to include info like min-max ranges.
- }
+ System: "REBOL [R3] Language Interpreter and Run-time Environment"
+ Title: "Datatype help spec"
+ Rights: {
+ Copyright 2012 REBOL Technologies
+ REBOL is a trademark of REBOL Technologies
+ }
+ License: {
+ Licensed under the Apache License, Version 2.0
+ See: http://www.apache.org/licenses/LICENSE-2.0
+ }
+ Purpose: {
+ Provides useful information about datatypes.
+ Can be expanded to include info like min-max ranges.
+ }
]
-action ["datatype native function (standard polymorphic)" function]
-binary ["string series of bytes" string]
-bitset ["set of bit flags" string]
-block ["series of values" block]
-char ["8bit and 16bit character" scalar]
-closure ["function with persistent locals (indefinite extent)" function]
-datatype ["type of datatype" symbol]
-date ["day, month, year, time of day, and timezone" scalar]
-decimal ["64bit floating point number (IEEE standard)" scalar]
-email ["email address" string]
-end ["internal marker for end of block" internal]
-error ["errors and throws" object]
-event ["user interface event (efficiently sized)" opt-object]
-file ["file name or path" string]
-frame ["internal context frame" internal]
-function ["interpreted function (user-defined or mezzanine)" function]
-get-path ["the value of a path" block]
-get-word ["the value of a word (variable)" word]
-gob ["graphical object" opt-object]
-handle ["arbitrary internal object or value" internal]
-image ["RGB image with alpha channel" vector]
-integer ["64 bit integer" scalar]
-issue ["identifying marker word" word]
-library ["external library reference" internal]
-lit-path ["literal path value" block]
-lit-word ["literal word value" word]
-logic ["boolean true or false" scalar]
-map ["name-value pairs (hash associative)" block]
-module ["loadable context of code and data" object]
-money ["high precision decimals with denomination (opt)" scalar]
-native ["direct CPU evaluated function" function]
-none ["no value represented" scalar]
-object ["context of names with values" object]
-op ["infix operator (special evaluation exception)" function]
-pair ["two dimensional point or size" scalar]
-paren ["automatically evaluating block" block]
-path ["refinements to functions, objects, files" block]
-percent ["special form of decimals (used mainly for layout)" scalar]
-port ["external series, an I/O channel" object]
-rebcode ["virtual machine function" block]
-refinement ["variation of meaning or location" word]
-command ["special dispatch-based function" function]
-set-path ["definition of a path's value" block]
-set-word ["definition of a word's value" word]
-string ["string series of characters" string]
-struct ["native structure definition" block]
-tag ["markup string (HTML or XML)" string]
-task ["evaluation environment" object]
-time ["time of day or duration" scalar]
-tuple ["sequence of small integers (colors, versions, IP)" scalar]
-typeset ["set of datatypes" opt-object]
-unicode ["string of unicoded characters" string]
-unset ["no value returned or set" internal]
-url ["uniform resource locator or identifier" string]
-utype ["user defined datatype" object]
-vector ["high performance arrays (single datatype)" vector]
-word ["word (symbol or variable)" word]
-
+bar ["expression evaluation barrier" internal]
+binary ["string series of bytes" string]
+bitset ["set of bit flags" string]
+blank ["placeholder unit type which also is conditionally FALSE?" scalar]
+block ["array of values that blocks evaluation unless DO is used" block]
+char ["8bit and 16bit character" scalar]
+datatype ["type of datatype" symbol]
+date ["day, month, year, time of day, and timezone" scalar]
+decimal ["64bit floating point number (IEEE standard)" scalar]
+email ["email address" string]
+error ["errors and throws" context]
+event ["user interface event (efficiently sized)" opt-object]
+file ["file name or path" string]
+frame ["arguments and locals of a specific function invocation" context]
+function ["interpreted function (user-defined or mezzanine)" function]
+get-path ["the value of a path" block]
+get-word ["the value of a word (variable)" word]
+gob ["graphical object" opt-object]
+handle ["arbitrary internal object or value" internal]
+image ["RGB image with alpha channel" vector]
+integer ["64 bit integer" scalar]
+issue ["identifying marker word" word]
+library ["external library reference" internal]
+lit-bar ["literal expression barrier" internal]
+lit-path ["literal path value" block]
+lit-word ["literal word value" word]
+logic ["boolean true or false" scalar]
+map ["name-value pairs (hash associative)" block]
+module ["loadable context of code and data" context]
+money ["high precision decimals with denomination (opt)" scalar]
+object ["context of names with values" context]
+pair ["two dimensional point or size" scalar]
+group ["array that evaluates expressions as an isolated group" block]
+path ["refinements to functions, objects, files" block]
+percent ["special form of decimals (used mainly for layout)" scalar]
+port ["external series, an I/O channel" context]
+refinement ["variation of meaning or location" word]
+set-path ["definition of a path's value" block]
+set-word ["definition of a word's value" word]
+string ["string series of characters" string]
+struct ["native structure definition" block]
+tag ["markup string (HTML or XML)" string]
+time ["time of day or duration" scalar]
+tuple ["sequence of small integers (colors, versions, IP)" scalar]
+typeset ["set of datatypes" opt-object]
+unicode ["string of unicoded characters" string]
+url ["uniform resource locator or identifier" string]
+varargs ["evaluator position for variable numbers of arguments" internal]
+vector ["high performance arrays (single datatype)" vector]
+;-- Note that VOID is not a type of value, and should not be in this list
+word ["word (symbol or variable)" word]
diff --git a/src/boot/version.r b/src/boot/version.r
index dd9096b769..e65b6840d6 100644
--- a/src/boot/version.r
+++ b/src/boot/version.r
@@ -1 +1 @@
-2.101.0.3.1
+2.102.0.0.0
diff --git a/src/boot/words.r b/src/boot/words.r
index 9d9d5db1ba..b252e52b81 100644
--- a/src/boot/words.r
+++ b/src/boot/words.r
@@ -1,53 +1,79 @@
REBOL [
- System: "REBOL [R3] Language Interpreter and Run-time Environment"
- Title: "Canonical words"
- Rights: {
- Copyright 2012 REBOL Technologies
- REBOL is a trademark of REBOL Technologies
- }
- License: {
- Licensed under the Apache License, Version 2.0
- See: http://www.apache.org/licenses/LICENSE-2.0
- }
- Purpose: {
- These words are used internally by REBOL and must have specific canon
- word values in order to be correctly identified.
- }
+ System: "REBOL [R3] Language Interpreter and Run-time Environment"
+ Title: "Canonical words"
+ Rights: {
+ Copyright 2012 REBOL Technologies
+ REBOL is a trademark of REBOL Technologies
+ }
+ License: {
+ Licensed under the Apache License, Version 2.0
+ See: http://www.apache.org/licenses/LICENSE-2.0
+ }
+ Purpose: {
+ These words are used internally by REBOL and must have specific canon
+ word values in order to be correctly identified.
+ }
]
-any-type!
+any-value! ;-- signal typesets start (SYM_ANY_VALUE_X hardcoded reference)
any-word!
any-path!
-any-function!
-number!
-scalar!
-series!
+any-number!
+any-scalar!
+any-series!
any-string!
-any-object!
-any-block!
+any-context!
+any-array! ;-- replacement for ANY-BLOCK! that doesn't conflate with BLOCK!
+
+;-----------------------------------------------------------------------------
+; Signal that every earlier numbered symbol is for a typeset or datatype...
datatypes
+; ...note that the words for types are created programmatically before
+; this list is applied, so you only see typesets in this file.
+;-----------------------------------------------------------------------------
+
+; !!! Kept for functionality of #[none] in the loader for
+none
+
+; For the moment, TO-WORD of a datatype is willing to canonize a datatype
+; as a word. Long term, that specialization is not desirable because it
+; is effectively building keywords deep into the system. Better would be
+; if datatypes could be communicated e.g. by #[()] for "groups" or "parens".
+;
+; Hardcoding in the GROUP! symbol is necessary for a legacy switch to be
+; willing to convert a "group!" into the word GROUP!
+;
+paren!
+
+; The PICK* action was killed in favor of a native that uses the same logic
+; as path processing. Code still remains for processing PICK*, and ports or
+; other mechanics may wind up using it...or path dispatch itself may be
+; rewritten to use the PICK* action (but that would require significiant
+; change for setting and getting paths)
+;
+; Similar story for POKE, which uses the same logic as PICK* to find the
+; location to write the value.
+;
+pick*
+poke
+
native
+action
self
-none
+blank
true
false
on
off
yes
no
-pi
rebol
system
-;boot levels
-base
-sys
-mods
-
;reflectors:
spec
body
@@ -55,6 +81,18 @@ words
values
types
title
+;addr already defined
+
+value ; used by TYPECHECKER to name the argument of the generated function
+
+; !!! See notes on FUNCTION-META and SPECIALIZER-META in %sysobj.r
+description
+return-type
+return-note
+parameter-types
+parameter-notes
+specializee
+specializee-name
x
y
@@ -62,10 +100,7 @@ y
-
*
unsigned
--unnamed- ; lambda (unnamed) functions
--apply- ; apply func
-code ; error field
-delect
+code ; error field
; Secure: (add to system/state/policies object too)
secure
@@ -78,8 +113,8 @@ memory
debug
browse
extension
-;dir - below
-;file - below
+file
+dir
; Time:
hour
@@ -98,11 +133,25 @@ yearday
zone
utc
-; Parse: - These words must not reserved above!!
-parse
-| ; must be first
-; prep words:
-set
+; Used to recognize Rebol2 use of [catch] and [throw] in function specs
+catch
+throw
+
+; Needed for processing of THROW's /NAME words used by system
+; NOTE: may become something more specific than WORD!
+exit
+quit
+;break ;-- covered by parse below
+;return ;-- covered by parse below
+leave ;-- for PROC
+continue
+
+subparse ;-- recursions of parse use this for REBNATIVE(subparse) in backtrace
+
+; PARSE - These words must not be reserved above!! The range of consecutive
+; index numbers are used by PARSE to detect keywords.
+;
+set ; must be first first (SYM_SET referred to by GET_VAR() in %u-parse.c)
copy
some
any
@@ -122,7 +171,8 @@ limit
??
accept
break
-; match words:
+; ^--prep words above
+; v--match words below
skip
to
thru
@@ -130,7 +180,7 @@ quote
do
into
only
-end ; must be last
+end ; must be last (SYM_END referred to by GET_VAR() in %u-parse.c)
; Event:
type
@@ -147,22 +197,61 @@ sha1
md4
md5
crc32
+adler32
; Codec actions
identify
decode
encode
-; Schemes
-console
-file
-dir
-event
-callback
-dns
-tcp
-udp
-clipboard
+; Serial parameters
+; Parity
+odd
+even
+; Control flow
+hardware
+software
+
+; Struct
+uint8
+int8
+uint16
+int16
+uint32
+int32
+uint64
+int64
+float
+;double ;reuse earlier definition
+pointer
+addr
+raw-memory
+raw-size
+extern
+rebval
+
+;routine
+void
+library
+name
+abi
+stdcall
+fastcall
+sysv
+thiscall
+unix64
+ms-cdecl
+win64
+default
+vfp ;arm
+o32; mips abi
+n32; mips abi
+n64; mips abi
+o32-soft-float; mips abi
+n32-soft-float; mips abi
+n64-soft-float; mips abi
+...
+varargs
; Gobs:
gob
@@ -180,6 +269,7 @@ rgb
alpha
data
resize
+rotate
no-title
no-border
dropable
@@ -189,13 +279,76 @@ modal
on-top
hidden
owner
+active
+minimize
+maximize
+restore
+fullscreen
*port-modes*
+; posix signal names
+all
+sigalrm
+sigabrt
+sigbus
+sigchld
+sigcont
+sigfpe
+sighup
+sigill
+sigint
+sigkill
+sigpipe
+sigquit
+sigsegv
+sigstop
+sigterm
+sigtstp
+sigttin
+sigttou
+sigusr1
+sigusr2
+sigpoll
+sigprof
+sigsys
+sigtrap
+sigurg
+sigvtalrm
+sigxcpu
+sigxfsz
+
bits
crash
crash-dump
watch-recycle
-watch-obj-copy
-stack-size
+uid
+euid
+gid
+egid
+pid
+
+;call/info
+id
+exit-code
+
+; used when a function is executed but not looked up through a word binding
+; (product of literal or evaluation) so no name is known for it
+--anonymous--
+
+; used to signal situations where information that would be available in
+; a debug build has been elided
+;
+--optimized-out--
+
+; used to signal a void in a reified va_list call, since voids can't actually
+; appear in user-visible arrays
+;
+--void--
+
+include
+source
+library-path
+runtime-path
+options
diff --git a/src/core/a-constants.c b/src/core/a-constants.c
index 052532c258..c4e44b9a38 100644
--- a/src/core/a-constants.c
+++ b/src/core/a-constants.c
@@ -1,97 +1,178 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: a-constants.c
-** Summary: special global constants and strings
-** Section: environment
-** Author: Carl Sassenrath
-** Notes:
-** Very few strings should be located here. Most strings are
-** put in the compressed embedded boot image. That saves space,
-** reduces tampering, and allows UTF8 encoding. See ../boot dir.
-**
-***********************************************************************/
+//
+// File: %a-constants.c
+// Summary: "special global constants and strings"
+// Section: environment
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Most text strings in Rebol should appear in the bootstrap files as Rebol
+// code. This allows for "internationalization" without needing to update
+// the C code. Other advantages are that the strings are compressed,
+// "reduces tampering", etc.
+//
+// So to keep track of any stray English strings in the executable which make
+// it into the user's view, they should be located here.
+//
+// Note: It's acceptable for hardcoded English strings to appear in the debug
+// build or in other debug settings, as anyone working with the C code itself
+// is basically expected to be able to read English (given the variable names
+// and comments in the C are English).
+//
#include "sys-core.h"
-#define BP (REBYTE*)
-
-const REBYTE Str_Banner[] = "REBOL 3 %d.%d.%d.%d.%d";
-
const char Str_REBOL[] = "REBOL";
-const REBYTE * Str_Stack_Misaligned = {
- BP("!! Stack misaligned: %d")
-};
+// A panic() indicates a serious malfunction, and should not make use of
+// Rebol-structured error message delivery in the release build.
-const REBYTE * const Crash_Msgs[] = {
- BP"REBOL System Error",
- BP"boot failure",
- BP"internal problem",
- BP"assertion failed",
- BP"invalid datatype %d",
- BP"unspecific",
- BP"\n\nProgram terminated abnormally.\nThis should never happen.\nPlease contact www.REBOL.com with details."
-};
+const char Str_Panic_Title[] = "Rebol Internal Error";
-const REBYTE * const Str_Dump[] = {
- BP"%s Series %x \"%s\": wide: %2d size: %6d bias: %d tail: %d rest: %d flags: %x"
+const char Str_Panic_Directions[] = {
+ "If you need to file a bug in the issue tracker, please give thorough\n"
+ "details on how to reproduce the problem:\n"
+ "\n"
+ " https://github.com/metaeducation/ren-c/issues\n"
+ "\n"
+ "Include the following information in the report:\n\n"
};
-const REBYTE * Hex_Digits = BP"0123456789ABCDEF";
+const char * Hex_Digits = "0123456789ABCDEF";
-const REBYTE * const Bad_Ptr = BP"#[BAD-PTR]";
-
-const REBYTE * const Esc_Names[] = {
- // Must match enum REBOL_Esc_Codes!
- BP"line",
- BP"tab",
- BP"page",
- BP"escape",
- BP"esc",
- BP"back",
- BP"del",
- BP"null"
+const char * const Esc_Names[] = {
+ // Must match enum REBOL_Esc_Codes!
+ "line",
+ "tab",
+ "page",
+ "escape",
+ "esc",
+ "back",
+ "del",
+ "null"
};
const REBYTE Esc_Codes[] = {
- // Must match enum REBOL_Esc_Codes!
- 10,
- 9,
- 12,
- 27,
- 27,
- 8,
- 127,
- 0
+ // Must match enum REBOL_Esc_Codes!
+ 10, // line
+ 9, // tab
+ 12, // page
+ 27, // escape
+ 27, // esc
+ 8, // back
+ 127, // del
+ 0 // null
+};
+
+// Zen Point on naming cues: was "Month_Lengths", but said 29 for Feb! --@HF
+const REBYTE Month_Max_Days[12] = {
+ 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31
};
-const REBYTE Month_Lengths[12] = {
- 31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31
+const char * const Month_Names[12] = {
+ "January", "February", "March", "April", "May", "June", "July", "August",
+ "September", "October", "November", "December"
};
-const REBYTE * const Month_Names[12] = {
- BP"January", BP"February", BP"March",
- BP"April", BP"May", BP"June",
- BP"July", BP"August", BP"September",
- BP"October", BP"November", BP"December"
+
+// Used by scanner. Keep in sync with enum Reb_Token in %scan.h file!
+//
+const char * const Token_Names[] = {
+ "end-of-script",
+ "newline",
+ "block-end",
+ "group-end",
+ "word",
+ "set",
+ "get",
+ "lit",
+ "blank",
+ "bar",
+ "lit-bar",
+ "logic",
+ "integer",
+ "decimal",
+ "percent",
+ "money",
+ "time",
+ "date",
+ "char",
+ "block-begin",
+ "group-begin",
+ "string",
+ "binary",
+ "pair",
+ "tuple",
+ "file",
+ "email",
+ "url",
+ "issue",
+ "tag",
+ "path",
+ "refine",
+ "construct",
+ NULL
};
+
+// !!! For now, (R)ebol (M)essages use the historical Debug_Fmt() output
+// method, which is basically like `printf()`. Over the long term, they
+// should use declarations like the (R)ebol (E)rrors do with RE_XXX values
+// loaded during boot.
+//
+// The goal should be that any non-debug-build only strings mentioned from C
+// that can be seen in the course of normal operation should go through this
+// abstraction. Ultimately that would permit internationalization, and the
+// benefit of not needing to ship a release build binary with a string-based
+// format dialect.
+//
+// Switching strings to use this convention should ultimately parallel the
+// `Error()` generation, where the arguments are Rebol values and not C
+// raw memory as parameters. Debug_Fmt() should also just be changed to
+// a normal `Print()` naming.
+//
+const char RM_ERROR_LABEL[] = "Error: ";
+const char RM_BAD_ERROR_FORMAT[] = "(improperly formatted error)";
+const char RM_ERROR_WHERE[] = "** Where: ";
+const char RM_ERROR_NEAR[] = "** Near: ";
+const char RM_ERROR_FILE[] = "** File: ";
+const char RM_ERROR_LINE[] = "** Line: ";
+
+const char RM_WATCH_RECYCLE[] = "RECYCLE: %d series";
+
+const char RM_TRACE_FUNCTION[] = "--> %s";
+const char RM_TRACE_RETURN[] = "<-- %s ==";
+const char RM_TRACE_ERROR[] = "**: error : %r %r";
+
+const char RM_TRACE_PARSE_VALUE[] = "Parse %s: %r";
+const char RM_TRACE_PARSE_INPUT[] = "Parse input: %s";
+
+const char RM_BACKTRACE_NOT_ENABLED[] = "backtrace not enabled";
+
+const char RM_EVOKE_HELP[] = "Evoke values:\n"
+ "[stack-size n] crash-dump delect\n"
+ "watch-recycle watch-obj-copy crash\n"
+ "1: watch expand\n"
+ "2: check memory pools\n"
+ "3: check bind table\n";
diff --git a/src/core/a-globals.c b/src/core/a-globals.c
index b2730c6361..7a22c4a91d 100644
--- a/src/core/a-globals.c
+++ b/src/core/a-globals.c
@@ -1,34 +1,36 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: a-globals.c
-** Summary: global variables
-** Section: environment
-** Author: Carl Sassenrath
-** Notes:
-** There are two types of global variables:
-** process vars - single instance for main process
-** thread vars - duplicated within each R3 task
-**
-***********************************************************************/
+//
+// File: %a-globals.c
+// Summary: "global variables"
+// Section: environment
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// There are two types of global variables:
+// process vars - single instance for main process
+// thread vars - duplicated within each R3 task
+//
/* To do: there are still a few globals in various modules that need to be
** incorporated back into sys-globals.h.
@@ -40,6 +42,6 @@
#undef TVAR
#define PVAR
-#define TVAR THREAD
+#define TVAR
#include "sys-globals.h"
diff --git a/src/core/a-lib.c b/src/core/a-lib.c
index 57833e3706..672c5e7da9 100644
--- a/src/core/a-lib.c
+++ b/src/core/a-lib.c
@@ -1,37 +1,44 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: a-lib.c
-** Summary: exported REBOL library functions
-** Section: environment
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %a-lib.c
+// Summary: "exported REBOL library functions"
+// Section: environment
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#include "reb-dialect.h"
+
+// !!! Most of the Rebol source does not include %reb-ext.h. As a result
+// REBRXT and RXIARG and RXIFRM are not defined when %tmp-funcs.h is being
+// compiled, so the MAKE PREP process doesn't auto-generate prototypes for
+// these functions.
+//
+// Rather than try and define RX* for all of the core to include, assume that
+// the burden of keeping these in sync manually is for the best.
+//
#include "reb-ext.h"
-#include "reb-evtypes.h"
-#include "sys-state.h"
// Linkage back to HOST functions. Needed when we compile as a DLL
// in order to use the OS_* macro functions.
@@ -39,895 +46,617 @@
REBOL_HOST_LIB *Host_Lib;
#endif
-#include "reb-lib.h"
-
-//#define DUMP_INIT_SCRIPT
-#ifdef DUMP_INIT_SCRIPT
-#include
-#include
-#include
-#include
-#endif
-extern const REBYTE Reb_To_RXT[REB_MAX];
-extern RXIARG Value_To_RXI(REBVAL *val); // f-extension.c
-extern void RXI_To_Value(REBVAL *val, RXIARG arg, REBCNT type); // f-extension.c
-extern void RXI_To_Block(RXIFRM *frm, REBVAL *out); // f-extension.c
-extern int Do_Callback(REBSER *obj, u32 name, RXIARG *args, RXIARG *result);
-
-
-/***********************************************************************
-**
-*/ RL_API void RL_Version(REBYTE vers[])
-/*
-** Obtain current REBOL interpreter version information.
-**
-** Returns:
-** A byte array containing version, revision, update, and more.
-** Arguments:
-** vers - a byte array to hold the version info. First byte is length,
-** followed by version, revision, update, system, variation.
-** Notes:
-** This function can be called before any other initialization
-** to determine version compatiblity with the caller.
-**
-***********************************************************************/
+static REBRXT Reb_To_RXT[REB_MAX];
+static enum Reb_Kind RXT_To_Reb[RXT_MAX];
+
+
+#include "reb-lib.h" // forward definitions needed for "extern C" linkage
+
+
+//
+// RL_Version: C
+//
+// Obtain current REBOL interpreter version information.
+//
+// Returns:
+// A byte array containing version, revision, update, and more.
+// Arguments:
+// vers - a byte array to hold the version info. First byte is length,
+// followed by version, revision, update, system, variation.
+// Notes:
+// In the original RL_API, this function was to be called before any other
+// initialization to determine version compatiblity with the caller.
+// With the massive changes in Ren-C and the lack of RL_API clients, this
+// check is low priority. This is how it was originally done:
+//
+// REBYTE vers[8];
+// vers[0] = 5; // len
+// RL_Version(&vers[0]);
+//
+// if (vers[1] != RL_VER || vers[2] != RL_REV)
+// OS_CRASH(cb_cast("Incompatible reb-lib DLL"));
+//
+RL_API void RL_Version(REBYTE vers[])
{
- // [0] is length
- vers[1] = REBOL_VER;
- vers[2] = REBOL_REV;
- vers[3] = REBOL_UPD;
- vers[4] = REBOL_SYS;
- vers[5] = REBOL_VAR;
-}
-
-
-/***********************************************************************
-**
-*/ RL_API int RL_Init(REBARGS *rargs, void *lib)
-/*
-** Initialize the REBOL interpreter.
-**
-** Returns:
-** Zero on success, otherwise an error indicating that the
-** host library is not compatible with this release.
-** Arguments:
-** rargs - REBOL command line args and options structure.
-** See the host-args.c module for details.
-** lib - the host lib (OS_ functions) to be used by REBOL.
-** See host-lib.c for details.
-** Notes:
-** This function will allocate and initialize all memory
-** structures used by the REBOL interpreter. This is an
-** extensive process that takes time.
-**
-***********************************************************************/
-{
- int marker;
- REBCNT bounds;
-
- Host_Lib = lib;
-
- if (Host_Lib->size < HOST_LIB_SIZE) return 1;
- if (((HOST_LIB_VER << 16) + HOST_LIB_SUM) != Host_Lib->ver_sum) return 2;
-
- bounds = OS_CONFIG(1, 0);
- if (bounds == 0) bounds = STACK_BOUNDS;
-
-#ifdef OS_STACK_GROWS_UP
- Stack_Limit = (REBCNT)(&marker) + bounds;
-#else
- if (bounds > (REBCNT)(&marker)) Stack_Limit = 100;
- else Stack_Limit = (REBCNT)(&marker) - bounds;
-#endif
-
- Init_Core(rargs);
- GC_Active = TRUE; // Turn on GC
- if (rargs->options & RO_TRACE) {
- Trace_Level = 9999;
- Trace_Flags = 1;
- }
-
- return 0;
-}
-
-
-/***********************************************************************
-**
-*/ RL_API int RL_Start(REBYTE *bin, REBINT len, REBCNT flags)
-/*
-** Evaluate the default boot function.
-**
-** Returns:
-** Zero on success, otherwise indicates an error occurred.
-** Arguments:
-** bin - optional startup code (compressed), can be null
-** len - length of above bin
-** flags - special flags
-** Notes:
-** This function completes the startup sequence by calling
-** the sys/start function.
-**
-***********************************************************************/
+ // [0] is length
+ vers[1] = REBOL_VER;
+ vers[2] = REBOL_REV;
+ vers[3] = REBOL_UPD;
+ vers[4] = REBOL_SYS;
+ vers[5] = REBOL_VAR;
+}
+
+
+//
+// RL_Init: C
+//
+// Initialize the REBOL interpreter.
+//
+// Returns:
+// Zero on success, otherwise an error indicating that the
+// host library is not compatible with this release.
+// Arguments:
+// lib - the host lib (OS_ functions) to be used by REBOL.
+// See host-lib.c for details.
+// Notes:
+// This function will allocate and initialize all memory
+// structures used by the REBOL interpreter. This is an
+// extensive process that takes time.
+//
+void RL_Init(void *lib)
{
- REBVAL *val;
- REBSER spec = {0};
- REBSER *ser;
-
- if (bin) {
- spec.data = bin;
- spec.tail = len;
- ser = Decompress(&spec, 0, -1, 10000000, 0);
- if (!ser) return 1;
-
- val = BLK_SKIP(Sys_Context, SYS_CTX_BOOT_HOST);
- Set_Binary(val, ser);
- }
-
- return Init_Mezz(0);
-}
-
-
-/***********************************************************************
-**
-*/ RL_API void RL_Reset()
-/*
-** Reset REBOL (not implemented)
-**
-** Returns:
-** nothing
-** Arguments:
-** none
-** Notes:
-** Intended to reset the REBOL interpreter.
-**
-***********************************************************************/
+ // These tables used to be built by overcomplicated Rebol scripts. It's
+ // less hassle to have them built on initialization.
+
+ REBCNT n;
+ for (n = 0; n < REB_MAX; ++n) {
+ //
+ // Though statics are initialized to 0, this makes it more explicit,
+ // as well as deterministic if there's an Init/Shutdown/Init...
+ //
+ Reb_To_RXT[n] = 0; // default that some types have no exported RXT_
+ }
+
+ // REB_BAR unsupported?
+ // REB_LIT_BAR unsupported?
+ Reb_To_RXT[REB_WORD] = RXT_WORD;
+ Reb_To_RXT[REB_SET_WORD] = RXT_SET_WORD;
+ Reb_To_RXT[REB_GET_WORD] = RXT_GET_WORD;
+ Reb_To_RXT[REB_LIT_WORD] = RXT_GET_WORD;
+ Reb_To_RXT[REB_REFINEMENT] = RXT_REFINEMENT;
+ Reb_To_RXT[REB_ISSUE] = RXT_ISSUE;
+ Reb_To_RXT[REB_PATH] = RXT_PATH;
+ Reb_To_RXT[REB_SET_PATH] = RXT_SET_PATH;
+ Reb_To_RXT[REB_GET_PATH] = RXT_GET_PATH;
+ Reb_To_RXT[REB_LIT_PATH] = RXT_LIT_PATH;
+ Reb_To_RXT[REB_GROUP] = RXT_GROUP;
+ Reb_To_RXT[REB_BLOCK] = RXT_BLOCK;
+ Reb_To_RXT[REB_BINARY] = RXT_BINARY;
+ Reb_To_RXT[REB_STRING] = RXT_STRING;
+ Reb_To_RXT[REB_FILE] = RXT_FILE;
+ Reb_To_RXT[REB_EMAIL] = RXT_EMAIL;
+ Reb_To_RXT[REB_URL] = RXT_URL;
+ Reb_To_RXT[REB_BITSET] = RXT_BITSET;
+ Reb_To_RXT[REB_IMAGE] = RXT_IMAGE;
+ Reb_To_RXT[REB_VECTOR] = RXT_VECTOR;
+ Reb_To_RXT[REB_BLANK] = RXT_BLANK;
+ Reb_To_RXT[REB_LOGIC] = RXT_LOGIC;
+ Reb_To_RXT[REB_INTEGER] = RXT_INTEGER;
+ Reb_To_RXT[REB_DECIMAL] = RXT_DECIMAL;
+ Reb_To_RXT[REB_PERCENT] = RXT_PERCENT;
+ // REB_MONEY unsupported?
+ Reb_To_RXT[REB_CHAR] = RXT_CHAR;
+ Reb_To_RXT[REB_PAIR] = RXT_PAIR;
+ Reb_To_RXT[REB_TUPLE] = RXT_TUPLE;
+ Reb_To_RXT[REB_TIME] = RXT_TIME;
+ Reb_To_RXT[REB_DATE] = RXT_DATE;
+ // REB_MAP unsupported?
+ // REB_DATATYPE unsupported?
+ // REB_TYPESET unsupported?
+ // REB_VARARGS unsupported?
+ Reb_To_RXT[REB_OBJECT] = RXT_OBJECT;
+ // REB_FRAME unsupported?
+ Reb_To_RXT[REB_MODULE] = RXT_MODULE;
+ // REB_ERROR unsupported?
+ // REB_PORT unsupported?
+ Reb_To_RXT[REB_GOB] = RXT_GOB;
+ // REB_EVENT unsupported?
+ Reb_To_RXT[REB_HANDLE] = RXT_HANDLE;
+ // REB_STRUCT unsupported?
+ // REB_LIBRARY unsupported?
+
+ for (n = 0; n < REB_MAX; ++n)
+ RXT_To_Reb[Reb_To_RXT[n]] = cast(enum Reb_Kind, n); // reverse lookup
+
+ // The RL_XXX API functions are stored like a C++ vtable, so they are
+ // function pointers inside of a struct. It's not completely obvious
+ // what the applications of this are...theoretically it could be for
+ // namespacing, or using multiple different versions of the API in a
+ // single codebase, etc. But all known clients use macros against a
+ // global "RL" rebol library, so it's not clear what the advantage is
+ // over just exporting C functions.
+
+ Host_Lib = cast(REBOL_HOST_LIB*, lib);
+
+ if (Host_Lib->size < HOST_LIB_SIZE)
+ panic ("Host-lib wrong size");
+
+ if (((HOST_LIB_VER << 16) + HOST_LIB_SUM) != Host_Lib->ver_sum)
+ panic ("Host-lib wrong version/checksum");
+
+ Startup_Core();
+}
+
+
+//
+// RL_Shutdown: C
+//
+// Shut down a Rebol interpreter (that was initialized via RL_Init).
+//
+// Returns:
+// nothing
+// Arguments:
+// clean - whether you want Rebol to release all of its memory
+// accrued since initialization. If you pass false, then it will
+// only do the minimum needed for data integrity (assuming you
+// are planning to exit the process, and hence the OS will
+// automatically reclaim all memory/handles/etc.)
+//
+RL_API void RL_Shutdown(REBOOL clean)
{
- DS_RESET;
-}
-
-
-/***********************************************************************
-**
-*/ RL_API void *RL_Extend(REBYTE *source, RXICAL call)
-/*
-** Appends embedded extension to system/catalog/boot-exts.
-**
-** Returns:
-** A pointer to the REBOL library (see reb-lib.h).
-** Arguments:
-** source - A pointer to a UTF-8 (or ASCII) string that provides
-** extension module header, function definitions, and other
-** related functions and data.
-** call - A pointer to the extension's command dispatcher.
-** Notes:
-** This function simply adds the embedded extension to the
-** boot-exts list. All other processing and initialization
-** happens later during startup. Each embedded extension is
-** queried and init using LOAD-EXTENSION system native.
-** See c:extensions-embedded
-**
-***********************************************************************/
+ // At time of writing, nothing Shutdown_Core() does pertains to
+ // committing unfinished data to disk. So really there is
+ // nothing to do in the case of an "unclean" shutdown...yet.
+
+ if (clean) {
+ #ifdef NDEBUG
+ // Only do the work above this line in an unclean shutdown
+ return;
+ #else
+ // Run a clean shutdown anyway in debug builds--even if the
+ // caller didn't need it--to see if it triggers any alerts.
+ //
+ Shutdown_Core();
+ #endif
+ }
+ else {
+ Shutdown_Core();
+ }
+}
+
+
+//
+// RL_Escape: C
+//
+// Signal that code evaluation needs to be interrupted.
+//
+// Returns:
+// nothing
+// Notes:
+// This function set's a signal that is checked during evaluation
+// and will cause the interpreter to begin processing an escape
+// trap. Note that control must be passed back to REBOL for the
+// signal to be recognized and handled.
+//
+RL_API void RL_Escape(void)
{
- REBVAL *value;
- REBSER *ser;
-
- value = BLK_SKIP(Sys_Context, SYS_CTX_BOOT_EXTS);
- if (IS_BLOCK(value)) ser = VAL_SERIES(value);
- else {
- ser = Make_Block(2);
- Set_Block(value, ser);
- }
- value = Append_Value(ser);
- Set_Binary(value, Copy_Bytes(source, -1)); // UTF-8
- value = Append_Value(ser);
- SET_HANDLE(value, call);
-
- return Extension_Lib();
-}
-
-
-/***********************************************************************
-**
-*/ RL_API void RL_Escape(REBINT reserved)
-/*
-** Signal that code evaluation needs to be interrupted.
-**
-** Returns:
-** nothing
-** Arguments:
-** reserved - must be set to zero.
-** Notes:
-** This function set's a signal that is checked during evaluation
-** and will cause the interpreter to begin processing an escape
-** trap. Note that control must be passed back to REBOL for the
-** signal to be recognized and handled.
-**
-***********************************************************************/
+ // How should HALT vs. BREAKPOINT be decided? When does a Ctrl-C want
+ // to quit entirely vs. begin an interactive debugging session?
+ //
+ // !!! For now default to halting, but use SIG_INTERRUPT when a decision
+ // is made about how to debug break.
+ //
+ SET_SIGNAL(SIG_HALT);
+}
+
+
+//
+// RL_Event: C
+//
+// Appends an application event (e.g. GUI) to the event port.
+//
+// Returns:
+// Returns TRUE if queued, or FALSE if event queue is full.
+// Arguments:
+// evt - A properly initialized event structure. The
+// contents of this structure are copied as part of
+// the function, allowing use of locals.
+// Notes:
+// Sets a signal to get REBOL attention for WAIT and awake.
+// To avoid environment problems, this function only appends
+// to the event queue (no auto-expand). So if the queue is full
+//
+// !!! Note to whom it may concern: REBEVT would now be 100% compatible with
+// a REB_EVENT REBVAL if there was a way of setting the header bits in the
+// places that generate them.
+//
+RL_API int RL_Event(REBEVT *evt)
{
- SET_SIGNAL(SIG_ESCAPE);
-}
-
-
-/***********************************************************************
-**
-*/ RL_API int RL_Do_String(REBYTE *text, REBCNT flags, RXIARG *result)
-/*
-** Load a string and evaluate the resulting block.
-**
-** Returns:
-** The datatype of the result.
-** Arguments:
-** text - A null terminated UTF-8 (or ASCII) string to transcode
-** into a block and evaluate.
-** flags - set to zero for now
-** result - value returned from evaluation.
-**
-***********************************************************************/
+ REBVAL *event = Append_Event(); // sets signal
+
+ if (event) { // null if no room left in series
+ VAL_RESET_HEADER(event, REB_EVENT); // has more space, if needed
+ event->extra.eventee = evt->eventee;
+ event->payload.event.type = evt->type;
+ event->payload.event.flags = evt->flags;
+ event->payload.event.win = evt->win;
+ event->payload.event.model = evt->model;
+ event->payload.event.data = evt->data;
+ return 1;
+ }
+
+ return 0;
+}
+
+
+//
+// RL_Update_Event: C
+//
+// Updates an application event (e.g. GUI) to the event port.
+//
+// Returns:
+// Returns 1 if updated, or 0 if event appended, and -1 if full.
+// Arguments:
+// evt - A properly initialized event structure. The
+// model and type of the event are used to address
+// the unhandled event in the queue, when it is found,
+// it will be replaced with this one
+//
+RL_API int RL_Update_Event(REBEVT *evt)
{
- REBVAL *val;
-
- val = Do_String(text, 0);
-
- if (result) {
- *result = Value_To_RXI(val);
- return Reb_To_RXT[VAL_TYPE(val)];
- }
- return 0;
-}
-
-
-/***********************************************************************
-**
-*/ RL_API int RL_Do_Binary(REBYTE *bin, REBINT length, REBCNT flags, REBCNT key, RXIARG *result)
-/*
-** Evaluate an encoded binary script such as compressed text.
-**
-** Returns:
-** The datatype of the result or zero if error in the encoding.
-** Arguments:
-** bin - by default, a REBOL compressed UTF-8 (or ASCII) script.
-** length - the length of the data.
-** flags - special flags (set to zero at this time).
-** key - encoding, encryption, or signature key.
-** result - value returned from evaluation.
-** Notes:
-** As of A104, only compressed scripts are supported, however,
-** rebin, cloaked, signed, and encrypted formats will be supported.
-**
-***********************************************************************/
+ REBVAL *event = Find_Last_Event(evt->model, evt->type);
+
+ if (event) {
+ event->extra.eventee = evt->eventee;
+ event->payload.event.type = evt->type;
+ event->payload.event.flags = evt->flags;
+ event->payload.event.win = evt->win;
+ event->payload.event.model = evt->model;
+ event->payload.event.data = evt->data;
+ return 1;
+ }
+
+ return RL_Event(evt) - 1;
+}
+
+
+//
+// RL_Find_Event: C
+//
+// Find an application event (e.g. GUI) to the event port.
+//
+// Returns:
+// A pointer to the find event
+// Arguments:
+// model - event model
+// type - event type
+//
+RL_API REBEVT *RL_Find_Event (REBINT model, REBINT type)
{
- REBSER spec = {0};
- REBSER *text;
- REBVAL *val;
-#ifdef DUMP_INIT_SCRIPT
- int f;
-#endif
+ REBVAL * val = Find_Last_Event(model, type);
+ if (val != NULL) {
+ return cast(REBEVT*, val); // should be compatible!
+ }
+ return NULL;
+}
- //Cloak(TRUE, code, NAT_SPEC_SIZE, &key[0], 20, TRUE);
- spec.data = bin;
- spec.tail = length;
- text = Decompress(&spec, 0, -1, 10000000, 0);
- if (!text) return FALSE;
- Append_Byte(text, 0);
-
-#ifdef DUMP_INIT_SCRIPT
- f = _open("host-boot.r", _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE );
- _write(f, STR_HEAD(text), LEN_BYTES(STR_HEAD(text)));
- _close(f);
-#endif
- SAVE_SERIES(text);
- val = Do_String(text->data, flags);
- UNSAVE_SERIES(text);
- if (IS_ERROR(val)) // && (VAL_ERR_NUM(val) != RE_QUIT)) {
- Print_Value(val, 1000, FALSE);
-
- if (result) {
- *result = Value_To_RXI(val);
- return Reb_To_RXT[VAL_TYPE(val)];
- }
- return 0;
-}
-
-
-/***********************************************************************
-**
-*/ RL_API int RL_Do_Block(REBSER *blk, REBCNT flags, RXIARG *result)
-/*
-** Evaluate a block. (not implemented)
-**
-** Returns:
-** The datatype of the result or zero if error in the encoding.
-** Arguments:
-** blk - A pointer to the block series
-** flags - set to zero for now
-** result - value returned from evaluation
-** Notes:
-** Not implemented. Contact Carl on R3 Chat if you think you
-** could use it for something.
-**
-***********************************************************************/
-{
- return 0;
-}
-
-
-/***********************************************************************
-**
-*/ RL_API void RL_Do_Commands(REBSER *blk, REBCNT flags, REBCEC *context)
-/*
-** Evaluate a block of extension commands at high speed.
-**
-** Returns:
-** Nothing
-** Arguments:
-** blk - a pointer to the block series
-** flags - set to zero for now
-** context - command evaluation context struct or zero if not used.
-** Notes:
-** For command blocks only, not for other blocks.
-** The context allows passing to each command a struct that is
-** used for back-referencing your environment data or for tracking
-** the evaluation block and its index.
-**
-***********************************************************************/
-{
- Do_Commands(blk, context);
-}
-
-
-/***********************************************************************
-**
-*/ RL_API void RL_Print(REBYTE *fmt, ...)
-/*
-** Low level print of formatted data to the console.
-**
-** Returns:
-** nothing
-** Arguments:
-** fmt - A format string similar but not identical to printf.
-** Special options are available.
-** ... - Values to be formatted.
-** Notes:
-** This function is low level and handles only a few C datatypes
-** at this time.
-**
-***********************************************************************/
-{
- va_list args;
- va_start(args, fmt);
- Debug_Buf(fmt, args); // Limits line size
- va_end(args);
-}
-
-
-/***********************************************************************
-**
-*/ RL_API void RL_Print_TOS(REBCNT flags, REBYTE *marker)
-/*
-** Print top REBOL stack value to the console. (pending changes)
-**
-** Returns:
-** Nothing
-** Arguments:
-** flags - special flags (set to zero at this time).
-** marker - placed at beginning of line to indicate output.
-** Notes:
-** This function is used for the main console evaluation
-** input loop to print the results of evaluation from stack.
-** The REBOL data stack is an abstract structure that can
-** change between releases. This function allows the host
-** to print the result of processed functions.
-** Note that what is printed is actually TOS+1.
-** Marker is usually "==" to show output.
-** The system/options/result-types determine which values
-** are automatically printed.
-**
-***********************************************************************/
-{
- REBINT dsp = DSP;
- REBVAL *top = DS_VALUE(dsp+1);
- REBOL_STATE state;
- REBVAL *types;
-
- if (dsp != 0) Debug_Fmt(Str_Stack_Misaligned, dsp);
-
- PUSH_STATE(state, Saved_State);
- if (SET_JUMP(state)) {
- POP_STATE(state, Saved_State);
- Catch_Error(DS_NEXT); // Stores error value here
- Out_Value(DS_NEXT, 0, FALSE, 0); // error
- DSP = 0;
- return;
- }
- SET_STATE(state, Saved_State);
-
- if (!IS_UNSET(top)) {
- if (!IS_ERROR(top)) {
- types = Get_System(SYS_OPTIONS, OPTIONS_RESULT_TYPES);
- if (IS_TYPESET(types) && TYPE_CHECK(types, VAL_TYPE(top))) {
- if (marker) Out_Str(marker, 0);
- Out_Value(top, 500, TRUE, 1); // limit, molded
- }
-// else {
-// Out_Str(Get_Type_Name(top), 1);
-// }
- } else {
- if (VAL_ERR_NUM(top) != RE_HALT) {
- Out_Value(top, 640, FALSE, 0); // error FORMed
-// if (VAL_ERR_NUM(top) > RE_THROW_MAX) {
-// Out_Str("** Note: use WHY? for more about this error", 1);
-// }
- }
- }
- }
-
- POP_STATE(state, Saved_State);
- DSP = 0;
-}
-
-
-/***********************************************************************
-**
-*/ RL_API int RL_Event(REBEVT *evt)
-/*
-** Appends an application event (e.g. GUI) to the event port.
-**
-** Returns:
-** Returns TRUE if queued, or FALSE if event queue is full.
-** Arguments:
-** evt - A properly initialized event structure. The
-** contents of this structure are copied as part of
-** the function, allowing use of locals.
-** Notes:
-** Sets a signal to get REBOL attention for WAIT and awake.
-** To avoid environment problems, this function only appends
-** to the event queue (no auto-expand). So if the queue is full
-**
-***********************************************************************/
-{
- REBVAL *event = Append_Event(); // sets signal
-
- if (event) { // null if no room left in series
- VAL_SET(event, REB_EVENT); // (has more space, if we need it)
- event->data.event = *evt;
- return 1;
- }
-
- return 0;
-}
-
-
-RL_API void *RL_Make_Block(u32 size)
-/*
-** Allocate a new block.
-**
-** Returns:
-** A pointer to a block series.
-** Arguments:
-** size - the length of the block. The system will add one extra
-** for the end-of-block marker.
-** Notes:
-** Blocks are allocated with REBOL's internal memory manager.
-** Internal structures may change, so NO assumptions should be made!
-** Blocks are automatically garbage collected if there are
-** no references to them from REBOL code (C code does nothing.)
-** However, you can lock blocks to prevent deallocation. (?? default)
-*/
-{
- return Make_Block(size);
-}
-
-RL_API void *RL_Make_String(u32 size, int unicode)
-/*
-** Allocate a new string or binary series.
-**
-** Returns:
-** A pointer to a string or binary series.
-** Arguments:
-** size - the length of the string. The system will add one extra
-** for a null terminator (not strictly required, but good for C.)
-** unicode - set FALSE for ASCII/Latin1 strings, set TRUE for Unicode.
-** Notes:
-** Strings can be REBYTE or REBCHR sized (depends on R3 config.)
-** Strings are allocated with REBOL's internal memory manager.
-** Internal structures may change, so NO assumptions should be made!
-** Strings are automatically garbage collected if there are
-** no references to them from REBOL code (C code does nothing.)
-** However, you can lock strings to prevent deallocation. (?? default)
-*/
-{
- return unicode ? Make_Unicode(size) : Make_Binary(size);
-}
-
-RL_API void *RL_Make_Image(u32 width, u32 height)
-/*
-** Allocate a new image of the given size.
-**
-** Returns:
-** A pointer to an image series, or zero if size is too large.
-** Arguments:
-** width - the width of the image in pixels
-** height - the height of the image in lines
-** Notes:
-** Images are allocated with REBOL's internal memory manager.
-** Image are automatically garbage collected if there are
-** no references to them from REBOL code (C code does nothing.)
-*/
+//
+// RL_Gob_Head: C
+//
+RL_API REBGOB** RL_Gob_Head(REBGOB *gob)
{
- return Make_Image(width, height, FALSE);
-}
-
-RL_API void RL_Protect_GC(REBSER *series, u32 flags)
-/*
-** Protect memory from garbage collection.
-**
-** Returns:
-** nothing
-** Arguments:
-** series - a series to protect (block, string, image, ...)
-** flags - set to 1 to protect, 0 to unprotect
-** Notes:
-** You should only use this function when absolutely necessary,
-** because it bypasses garbage collection for the specified series.
-** Meaning: if you protect a series, it will never be freed.
-** Also, you only need this function if you allocate several series
-** such as strings, blocks, images, etc. within the same command
-** and you don't store those references somewhere where the GC can
-** find them, such as in an existing block or object (variable).
-*/
-{
- (flags == 1) ? SERIES_SET_FLAG(series, SER_KEEP) : SERIES_CLR_FLAG(series, SER_KEEP);
-}
-
-RL_API int RL_Get_String(REBSER *series, u32 index, void **str)
-/*
-** Obtain a pointer into a string (bytes or unicode).
-**
-** Returns:
-** The length and type of string. When len > 0, string is unicode.
-** When len < 0, string is bytes.
-** Arguments:
-** series - string series pointer
-** index - index from beginning (zero-based)
-** str - pointer to first character
-** Notes:
-** If the len is less than zero, then the string is optimized to
-** codepoints (chars) 255 or less for ASCII and LATIN-1 charsets.
-** Strings are allowed to move in memory. Therefore, you will want
-** to make a copy of the string if needed.
-*/
-{ // ret: len or -len
- int len = (index >= series->tail) ? 0 : series->tail - index;
-
- if (BYTE_SIZE(series)) {
- *str = BIN_SKIP(series, index);
- len = -len;
- }
- else {
- *str = UNI_SKIP(series, index);
- }
-
- return len;
-}
-
-RL_API u32 RL_Map_Word(REBYTE *string)
-/*
-** Given a word as a string, return its global word identifier.
-**
-** Returns:
-** The word identifier that matches the string.
-** Arguments:
-** string - a valid word as a UTF-8 encoded string.
-** Notes:
-** Word identifiers are persistent, and you can use them anytime.
-** If the word is new (not found in master symbol table)
-** it will be added and the new word identifier is returned.
-*/
-{
- return Make_Word(string, 0);
-}
-
-RL_API u32 *RL_Map_Words(REBSER *series)
-/*
-** Given a block of word values, return an array of word ids.
-**
-** Returns:
-** An array of global word identifiers (integers). The [0] value is the size.
-** Arguments:
-** series - block of words as values (from REBOL blocks, not strings.)
-** Notes:
-** Word identifiers are persistent, and you can use them anytime.
-** The block can include any kind of word, including set-words, lit-words, etc.
-** If the input block contains non-words, they will be skipped.
-** The array is allocated with OS_MAKE and you can OS_FREE it any time.
-*/
-{
- REBCNT i = 1;
- u32 *words;
- REBVAL *val = BLK_HEAD(series);
-
- words = OS_MAKE((series->tail+2) * sizeof(u32));
-
- for (; NOT_END(val); val++) {
- if (ANY_WORD(val)) words[i++] = VAL_WORD_CANON(val);
- }
-
- words[0] = i;
- words[i] = 0;
-
- return words;
-}
-
-RL_API REBYTE *RL_Word_String(u32 word)
-/*
-** Return a string related to a given global word identifier.
-**
-** Returns:
-** A copy of the word string, null terminated.
-** Arguments:
-** word - a global word identifier
-** Notes:
-** The result is a null terminated copy of the name for your own use.
-** The string is always UTF-8 encoded (chars > 127 are encoded.)
-** In this API, word identifiers are always canonical. Therefore,
-** the returned string may have different spelling/casing than expected.
-** The string is allocated with OS_MAKE and you can OS_FREE it any time.
-*/
-{
- REBYTE *s1, *s2;
- // !!This code should use a function from c-words.c (but nothing perfect yet.)
- if (word == 0 || word >= PG_Word_Table.series->tail) return 0;
- s1 = VAL_SYM_NAME(BLK_SKIP(PG_Word_Table.series, word));
- s2 = OS_MAKE(strlen(s1));
- strcpy(s2, s1);
- return s2;
-}
-
-RL_API u32 RL_Find_Word(u32 *words, u32 word)
-/*
-** Given an array of word ids, return the index of the given word.
-**
-** Returns:
-** The index of the given word or zero.
-** Arguments:
-** words - a word array like that returned from MAP_WORDS (first element is size)
-** word - a word id
-** Notes:
-** The first element of the word array is the length of the array.
-*/
-{
- REBCNT n = 0;
-
- if (words == 0) return 0;
-
- for (n = 1; n < words[0]; n++) {
- if (words[n] == word) return n;
- }
- return 0;
-}
-
-RL_API int RL_Series(REBSER *series, REBCNT what)
-/*
-** Get series information.
-**
-** Returns:
-** Returns information related to a series.
-** Arguments:
-** series - any series pointer (string or block)
-** what - indicates what information to return (see RXI_SER enum)
-** Notes:
-** Invalid what arg nums will return zero.
-*/
-{
- switch (what) {
- case RXI_SER_DATA: return (int)SERIES_DATA(series); // problem for 64 bit !!
- case RXI_SER_TAIL: return SERIES_TAIL(series);
- case RXI_SER_LEFT: return SERIES_AVAIL(series);
- case RXI_SER_SIZE: return SERIES_REST(series);
- case RXI_SER_WIDE: return SERIES_WIDE(series);
- }
- return 0;
-}
-
-RL_API int RL_Get_Char(REBSER *series, u32 index)
-/*
-** Get a character from byte or unicode string.
-**
-** Returns:
-** A Unicode character point from string. If index is
-** at or past the tail, a -1 is returned.
-** Arguments:
-** series - string series pointer
-** index - zero based index of character
-** Notes:
-** This function works for byte and unicoded strings.
-** The maximum size of a Unicode char is determined by
-** R3 build options. The default is 16 bits.
-*/
-{
- if (index >= series->tail) return -1;
- return GET_ANY_CHAR(series, index);
-}
-
-RL_API u32 RL_Set_Char(REBSER *series, u32 index, u32 chr)
-/*
-** Set a character into a byte or unicode string.
-**
-** Returns:
-** The index passed as an argument.
-** Arguments:
-** series - string series pointer
-** index - where to store the character. If past the tail,
-** the string will be auto-expanded by one and the char
-** will be appended.
-*/
-{
- if (index >= series->tail) {
- index = series->tail;
- EXPAND_SERIES_TAIL(series, 1);
- }
- SET_ANY_CHAR(series, index, chr);
- return index;
-}
-
-RL_API int RL_Get_Value(REBSER *series, u32 index, RXIARG *result)
-/*
-** Get a value from a block.
-**
-** Returns:
-** Datatype of value or zero if index is past tail.
-** Arguments:
-** series - block series pointer
-** index - index of the value in the block (zero based)
-** result - set to the value of the field
-*/
-{
- REBVAL *value;
- if (index >= series->tail) return 0;
- value = BLK_SKIP(series, index);
- *result = Value_To_RXI(value);
- return Reb_To_RXT[VAL_TYPE(value)];
-}
-
-RL_API int RL_Set_Value(REBSER *series, u32 index, RXIARG val, int type)
-/*
-** Set a value in a block.
-**
-** Returns:
-** TRUE if index past end and value was appended to tail of block.
-** Arguments:
-** series - block series pointer
-** index - index of the value in the block (zero based)
-** val - new value for field
-** type - datatype of value
-*/
-{
- REBVAL value = {0};
- RXI_To_Value(&value, val, type);
- if (index >= series->tail) {
- Append_Val(series, &value);
- return TRUE;
- }
- *BLK_SKIP(series, index) = value;
- return FALSE;
-}
-
-RL_API u32 *RL_Words_Of_Object(REBSER *obj)
-/*
-** Returns information about the object.
-**
-** Returns:
-** Returns an array of words used as fields of the object.
-** Arguments:
-** obj - object pointer (e.g. from RXA_OBJECT)
-** Notes:
-** Returns a word array similar to MAP_WORDS().
-** The array is allocated with OS_MAKE. You can OS_FREE it any time.
-*/
-{
- REBCNT index;
- u32 *words;
- REBVAL *syms;
-
- syms = FRM_WORD(obj, 1);
- words = OS_MAKE(obj->tail * sizeof(u32)); // One less, because SELF not included.
- for (index = 0; index < (obj->tail-1); syms++, index++) {
- words[index] = VAL_BIND_CANON(syms);
- }
- words[index] = 0;
- return words;
-}
-
-RL_API int RL_Get_Field(REBSER *obj, u32 word, RXIARG *result)
-/*
-** Get a field value (context variable) of an object.
-**
-** Returns:
-** Datatype of value or zero if word is not found in the object.
-** Arguments:
-** obj - object pointer (e.g. from RXA_OBJECT)
-** word - global word identifier (integer)
-** result - gets set to the value of the field
-*/
-{
- REBVAL *value;
- if (!(word = Find_Word_Index(obj, word, FALSE))) return 0;
- value = BLK_SKIP(obj, word);
- *result = Value_To_RXI(value);
- return Reb_To_RXT[VAL_TYPE(value)];
-}
-
-RL_API int RL_Set_Field(REBSER *obj, u32 word, RXIARG val, int type)
-/*
-** Set a field (context variable) of an object.
-**
-** Returns:
-** The type arg, or zero if word not found in object or if field is protected.
-** Arguments:
-** obj - object pointer (e.g. from RXA_OBJECT)
-** word - global word identifier (integer)
-** val - new value for field
-** type - datatype of value
-*/
-{
- REBVAL value = {0};
- if (!(word = Find_Word_Index(obj, word, FALSE))) return 0;
- if (VAL_PROTECTED(FRM_WORDS(obj)+word)) return 0; // Trap1(RE_LOCKED_WORD, word);
- RXI_To_Value(FRM_VALUES(obj)+word, val, type);
- return type;
-}
-
-RL_API int RL_Callback(RXICBI *cbi)
-/*
-** Evaluate a REBOL callback function, either synchronous or asynchronous.
-**
-** Returns:
-** Sync callback: type of the result; async callback: true if queued
-** Arguments:
-** cbi - callback information including special option flags,
-** object pointer (where function is located), function name
-** as global word identifier (within above object), argument list
-** passed to callback (see notes below), and result value.
-** Notes:
-** The flag value will determine the type of callback. It can be either
-** synchronous, where the code will re-enter the interpreter environment
-** and call the specified function, or asynchronous where an EVT_CALLBACK
-** event is queued, and the callback will be evaluated later when events
-** are processed within the interpreter's environment.
-** For asynchronous callbacks, the cbi and the args array must be managed
-** because the data isn't processed until the callback event is
-** handled. Therefore, these cannot be allocated locally on
-** the C stack; they should be dynamic (or global if so desired.)
-** See c:extensions-callbacks
-*/
-{
- REBEVT evt;
-
- // Synchronous callback?
- if (!GET_FLAG(cbi->flags, RXC_ASYNC)) {
- return Do_Callback(cbi->obj, cbi->word, cbi->args, &(cbi->result));
- }
+ return SER_HEAD(REBGOB*, GOB_PANE(gob));
+}
- CLEARS(&evt);
- evt.type = EVT_CALLBACK;
- evt.model = EVM_CALLBACK;
- evt.ser = (void*)cbi;
- SET_FLAG(cbi->flags, RXC_QUEUED);
- return RL_Event(&evt); // (returns 0 if queue is full, ignored)
+//
+// RL_Gob_String: C
+//
+RL_API REBYTE* RL_Gob_String(REBGOB *gob)
+{
+ return BIN_HEAD(GOB_CONTENT(gob));
}
+//
+// RL_Gob_Len: C
+//
+RL_API REBCNT RL_Gob_Len(REBGOB *gob)
+{
+ return SER_LEN(GOB_PANE(gob));
+}
+
+
+//
+// RL_Encode_UTF8: C
+//
+// Encode the unicode into UTF8 byte string.
+//
+// Returns:
+// Number of dst bytes used.
+//
+// Arguments:
+// dst - destination for encoded UTF8 bytes
+// max - maximum size of the result in bytes
+// src - source array of bytes or wide characters
+// len - input is source length, updated to reflect src chars used
+// unicode - true if src is in wide character format
+// crlf_to_lf - convert carriage-return + linefeed into just linefeed
+//
+// Notes:
+// Does not add a terminator.
+//
+// !!! Host code is not supposed to call any Rebol routines except
+// for those in the RL_Api. This exposes Rebol's internal UTF8
+// length routine, as it was being used by the Linux host code by
+// Atronix. Should be reviewed along with the rest of the RL_Api.
+//
+RL_API REBCNT RL_Encode_UTF8(
+ REBYTE *dst,
+ REBINT max,
+ const void *src,
+ REBCNT *len,
+ REBOOL unicode,
+ REBOOL crlf_to_lf
+) {
+ return Encode_UTF8(
+ dst,
+ max,
+ src,
+ len,
+ (unicode ? OPT_ENC_UNISRC : 0) | (crlf_to_lf ? OPT_ENC_CRLF : 0)
+ );
+}
+
+
+//
+// !!! These routines are exports of the macros and inline functions which
+// rely upon internal definitions that RL_XXX clients are not expected to have
+// available. While this implementation file can see inside the definitions
+// of `struct Reb_Value`, the caller has an opaque definition.
+//
+// These are transitional as part of trying to get rid of RXIARG, RXIFRM, and
+// COMMAND! in general. Though it is not a good "API design" to just take
+// any internal function you find yourself needing in a client and export it
+// here with "RL_" in front of the name, it's at least understandable--and
+// not really introducing any routines that don't already have to exist and
+// be tested.
+//
+// However, long term the external "C" user API will not speak about REBSERs.
+// It will operate purely on the level of REBVAL*, where those values will
+// either be individually managed (as "pairings" under GC control) or have
+// their lifetime controlled other ways. That layer of API is of secondary
+// importance to refining the internal API (also used by "user natives")
+// as well as the Ren-Cpp API...although it will use several of the same
+// mechanisms that Ren-Cpp does to achieve its goals.
+//
+
+inline static REBFRM *Extract_Live_Rebfrm_May_Fail(const REBVAL *frame) {
+ if (!IS_FRAME(frame))
+ fail ("Not a FRAME!");
+
+ REBCTX *frame_ctx = VAL_CONTEXT(frame);
+ REBFRM *f = CTX_FRAME_IF_ON_STACK(frame_ctx);
+ if (f == NULL)
+ fail ("FRAME! is no longer on stack.");
+
+ assert(Is_Any_Function_Frame(f));
+ assert(NOT(Is_Function_Frame_Fulfilling(f)));
+ return f;
+}
+
+
+//
+// RL_Frm_Num_Args: C
+//
+RL_API REBCNT RL_Frm_Num_Args(const REBVAL *frame) {
+ REBFRM *f = Extract_Live_Rebfrm_May_Fail(frame);
+ return FRM_NUM_ARGS(f);
+}
+
+//
+// RL_Frm_Arg: C
+//
+RL_API REBVAL *RL_Frm_Arg(const REBVAL *frame, REBCNT n) {
+ REBFRM *f = Extract_Live_Rebfrm_May_Fail(frame);
+ return FRM_ARG(f, n);
+}
+
+//
+// RL_Val_Logic: C
+//
+RL_API REBOOL RL_Val_Logic(const REBVAL *v) {
+ return VAL_LOGIC(v);
+}
+
+//
+// RL_Val_Type: C
+//
+// !!! Among the few concepts from the original host kit API that may make
+// sense, it could be a good idea to abstract numbers for datatypes from the
+// REB_XXX numbering scheme. So for the moment, REBRXT is being kept as is.
+//
+RL_API REBRXT RL_Val_Type(const REBVAL *v) {
+ return IS_VOID(v)
+ ? 0
+ : Reb_To_RXT[VAL_TYPE(v)];
+}
+
+
+//
+// RL_Val_Update_Header: C
+//
+RL_API void RL_Val_Update_Header(REBVAL *v, REBRXT rxt) {
+ if (rxt == 0)
+ Init_Void(v);
+ else
+ VAL_RESET_HEADER(v, RXT_To_Reb[rxt]);
+}
+
+
+//
+// RL_Val_Int64: C
+//
+RL_API REBI64 RL_Val_Int64(const REBVAL *v) {
+ return VAL_INT64(v);
+}
+
+//
+// RL_Val_Int32: C
+//
+RL_API REBINT RL_Val_Int32(const REBVAL *v) {
+ return VAL_INT32(v);
+}
+
+//
+// RL_Val_Decimal: C
+//
+RL_API REBDEC RL_Val_Decimal(const REBVAL *v) {
+ return VAL_DECIMAL(v);
+}
+
+//
+// RL_Val_Char: C
+//
+RL_API REBUNI RL_Val_Char(const REBVAL *v) {
+ return VAL_CHAR(v);
+}
+
+//
+// RL_Val_Time: C
+//
+RL_API REBI64 RL_Val_Time(const REBVAL *v) {
+ return VAL_NANO(v);
+}
+
+//
+// RL_Val_Date: C
+//
+RL_API REBINT RL_Val_Date(const REBVAL *v) {
+ return VAL_DATE(v).bits; // !!! Is this right?
+}
+
+//
+// RL_Val_Tuple_Data: C
+//
+RL_API REBYTE *RL_Val_Tuple_Data(const REBVAL *v) {
+ return VAL_TUPLE_DATA(m_cast(REBVAL*, v));
+}
+
+//
+// RL_Val_Index: C
+//
+RL_API REBCNT RL_Val_Index(const REBVAL *v) {
+ return VAL_INDEX(v);
+}
+
+//
+// RL_Init_Val_Index: C
+//
+RL_API void RL_Init_Val_Index(REBVAL *v, REBCNT i) {
+ VAL_INDEX(v) = i;
+}
+
+//
+// RL_Val_Handle_Pointer: C
+//
+RL_API void *RL_Val_Handle_Pointer(const REBVAL *v) {
+ return VAL_HANDLE_POINTER(void, v);
+}
+
+//
+// RL_Set_Handle_Pointer: C
+//
+RL_API void RL_Set_Handle_Pointer(REBVAL *v, void *p) {
+ v->extra.singular = NULL; // !!! only support "dumb" handles for now
+ SET_HANDLE_POINTER(v, p);
+}
+
+//
+// RL_Val_Image_Wide: C
+//
+RL_API REBCNT RL_Val_Image_Wide(const REBVAL *v) {
+ return VAL_IMAGE_WIDE(v);
+}
+
+//
+// RL_Val_Image_High: C
+//
+RL_API REBCNT RL_Val_Image_High(const REBVAL *v) {
+ return VAL_IMAGE_HIGH(v);
+}
+
+//
+// RL_Val_Pair_X_Float: C
+//
+// !!! Pairs in R3-Alpha were not actually pairs of arbitrary values; but
+// they were pairs of floats. This meant their precision did not match either
+// 64-bit integers or 64-bit decimals, because you can't fit two of those in
+// one REBVAL and still have room for a header. Ren-C changed the mechanics
+// so that two actual values were efficiently stored in a PAIR! via a special
+// kind of GC-able series node (with no further allocation). Hence you can
+// tell the difference between 1x2, 1.0x2.0, 1x2.0, 1.0x2, etc.
+//
+// Yet the R3-Alpha external interface did not make this distinction, so this
+// API is for compatibility with those extracting floats.
+//
+RL_API float RL_Val_Pair_X_Float(const REBVAL *v) {
+ return VAL_PAIR_X(v);
+}
+
+//
+// RL_Val_Pair_Y_Float: C
+//
+// !!! See notes on RL_Val_Pair_X_Float
+//
+RL_API float RL_Val_Pair_Y_Float(const REBVAL *v) {
+ return VAL_PAIR_Y(v);
+}
+
+//
+// RL_Init_Date: C
+//
+// There was a data structure called a REBOL_DAT in R3-Alpha which was defined
+// in %reb-defs.h, and it appeared in the host callbacks to be used in
+// `os_get_time()` and `os_file_time()`. This allowed the host to pass back
+// date information without actually knowing how to construct a date REBVAL.
+//
+// Today "host code" (which may all become "port code") is expected to either
+// be able to speak in terms of Rebol values through linkage to the internal
+// API or the more minimal RL_Api. Either way, it should be able to make
+// REBVALs corresponding to dates...even if that means making a string of
+// the date to load and then RL_Do_String() to produce the value.
+//
+// This routine is a quick replacement for the format of the struct, as a
+// temporary measure while it is considered whether things like os_get_time()
+// will have access to the full internal API or not.
+//
+RL_API void RL_Init_Date(
+ REBVAL *out,
+ int year,
+ int month,
+ int day,
+ int seconds,
+ int nano,
+ int zone
+) {
+ VAL_RESET_HEADER(out, REB_DATE);
+ VAL_YEAR(out) = year;
+ VAL_MONTH(out) = month;
+ VAL_DAY(out) = day;
+ VAL_ZONE(out) = zone / ZONE_MINS;
+ VAL_NANO(out) = SECS_TO_NANO(seconds) + nano;
+}
+
#include "reb-lib-lib.h"
-/***********************************************************************
-**
-*/ void *Extension_Lib(void)
-/*
-***********************************************************************/
+//
+// Extension_Lib: C
+//
+void *Extension_Lib(void)
{
- return &Ext_Lib;
+ return &Ext_Lib;
}
diff --git a/src/core/a-lib2.c b/src/core/a-lib2.c
deleted file mode 100644
index ec1647196e..0000000000
--- a/src/core/a-lib2.c
+++ /dev/null
@@ -1,127 +0,0 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: a-lib2.c
-** Summary: skip
-** Section: environment
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-
-#include "sys-core.h"
-#include "reb-dialect.h"
-#include "reb-ext.h"
-#include "sys-state.h"
-
-
-// Load this to verify function prototypes:
-#include "rebol-lib.h"
-
-/***********************************************************************
-**
-x*/ REBOL_API REBINT Reb_Dialect(REBINT dialect, REBSER *block, REBCNT *index, REBSER **arglist)
-/*
-** Process a standard dialect.
-**
-** The index points to the next value to interpret and is updated
-** on return (for next loop or error). The system/dialect
-** object is used for the dialect specification.
-**
-** A block is returned with the arguments, ordered according
-** to the dialect specification for the command. Note that the
-** returned block is reset and reused with each command. (To
-** minimize GC trash.). The cmd arg returns the command number
-** or error number (when result is zero).
-**
-** A zero is returned for errors and end-of-block. For the former
-** an error is returned in cmd. For the latter, cmd is zero.
-**
-***********************************************************************/
-{
- REBVAL *val = Get_System(SYS_DIALECTS, 0);
-
- if (!IS_OBJECT(val)
- || dialect <= 0
- || dialect >= (REBINT)SERIES_TAIL(VAL_OBJ_FRAME(val))
- ) {
- return -REB_DIALECT_MISSING;
- }
-
- val = Get_System(SYS_DIALECTS, dialect);
- if (!IS_OBJECT(val)) return -REB_DIALECT_MISSING;;
- return Do_Dialect(VAL_OBJ_FRAME(val), block, index, arglist);
-}
-
-
-/***********************************************************************
-**
-x*/ REBOL_API void Reb_Set_Var(void *var, void *value)
-/*
-***********************************************************************/
-{
- Set_Var(var, value); // Check context, index, range
-}
-
-
-/***********************************************************************
-**
-x*/ REBOL_API REBINT Reb_Map_Words(REBYTE **names, REBCNT *symbols)
-/*
-** Given null terminated list of word names, supply the
-** symbol values for those words. Return length.
-** The names must be UTF8 valid.
-**
-***********************************************************************/
-{
- REBINT count = 0;
-
- for (; *names; names++, count++) {
- *symbols++ = Make_Word(*names, 0);
- }
- *symbols++ = 0;
-
- return count;
-}
-
-
-/***********************************************************************
-**
-x*/ REBOL_API REBINT Reb_Find_Word(REBCNT sym, REBCNT *symbols, REBINT limit)
-/*
-** Search a symbol list for a word, and return the index for it.
-** Return -1 if not found. Limit can be used to control how many
-** words in the symbol list will be compared.
-**
-***********************************************************************/
-{
- REBINT index;
-
- if (sym >= SERIES_TAIL(PG_Word_Table.series)) return -1;
- if (limit == 0) limit = 100000;
-
- for (index = 0; limit > 0 && symbols[index]; limit--, index++) {
- if (sym == symbols[index] || SYMBOL_TO_CANON(sym) == SYMBOL_TO_CANON(symbols[index]))
- return index;
- }
-
- return -1;
-}
diff --git a/src/core/a-stubs.c b/src/core/a-stubs.c
deleted file mode 100644
index ddf435b0ae..0000000000
--- a/src/core/a-stubs.c
+++ /dev/null
@@ -1,30 +0,0 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: a-stubs.c
-** Summary: function stubs
-** Section: environment
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-
-#include "sys-core.h"
diff --git a/src/core/b-init.c b/src/core/b-init.c
index 1978ae0a7e..6d108704c5 100644
--- a/src/core/b-init.c
+++ b/src/core/b-init.c
@@ -1,990 +1,1466 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: b-init.c
-** Summary: initialization functions
-** Section: bootstrap
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %b-init.c
+// Summary: "initialization functions"
+// Section: bootstrap
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// The primary routine for starting up Rebol is Startup_Core(). It runs the
+// bootstrap in phases, based on processing various portions of the data in
+// %tmp-boot-block.r (which is the aggregated code from the %mezz/*.r files,
+// packed into one file as part of the build preparation).
+//
+// As part of an effort to lock down the memory usage, Ren-C added a parallel
+// Shutdown_Core() routine which would gracefully exit Rebol, with assurances
+// that all accounting was done correctly. This includes being sure that the
+// number used to track memory usage for triggering garbage collections would
+// balance back out to exactly zero.
+//
+// (Release builds can instead close only vital resources like files, and
+// trust the OS exit() to reclaim memory more quickly. However Ren-C's goal
+// is to be usable as a library that may be initialized and shutdown within
+// a process that's not exiting, so the ability to clean up is important.)
+//
+
#include "sys-core.h"
-#include "sys-state.h"
+#include "mem-pools.h"
#define EVAL_DOSE 10000
-// Boot Vars used locally:
-static REBCNT Native_Count;
-static REBCNT Native_Limit;
-static REBCNT Action_Count;
-static REBCNT Action_Marker;
-static REBFUN *Native_Functions;
-static BOOT_BLK *Boot_Block;
-
-extern const REBYTE Str_Banner[];
-#ifdef WATCH_BOOT
-#define DOUT(s) puts(s)
+//
+// Assert_Basics: C
+//
+static void Assert_Basics(void)
+{
+#if !defined(NDEBUG) && defined(SHOW_SIZEOFS)
+ //
+ // For debugging ports to some systems
+ //
+#if defined(__LP64__) || defined(__LLP64__)
+ const char *fmt = "%lu %s\n";
#else
-#define DOUT(s)
+ const char *fmt = "%u %s\n";
#endif
-
-/***********************************************************************
-**
-*/ static void Assert_Basics()
-/*
-***********************************************************************/
-{
- REBVAL val;
-
- VAL_SET(&val, 123);
-#ifdef WATCH_BOOT
- printf("TYPE(123)=%d val=%d dat=%d gob=%d\n",
- VAL_TYPE(&val), sizeof(REBVAL), sizeof(REBDAT), sizeof(REBGOB));
+ union Reb_Value_Payload *dummy_payload;
+
+ printf(fmt, sizeof(dummy_payload->any_word), "any_word");
+ printf(fmt, sizeof(dummy_payload->any_series), "any_series");
+ printf(fmt, sizeof(dummy_payload->integer), "integer");
+ printf(fmt, sizeof(dummy_payload->decimal), "decimal");
+ printf(fmt, sizeof(dummy_payload->character), "char");
+ printf(fmt, sizeof(dummy_payload->datatype), "datatype");
+ printf(fmt, sizeof(dummy_payload->typeset), "typeset");
+ printf(fmt, sizeof(dummy_payload->time), "time");
+ printf(fmt, sizeof(dummy_payload->tuple), "tuple");
+ printf(fmt, sizeof(dummy_payload->function), "function");
+ printf(fmt, sizeof(dummy_payload->any_context), "any_context");
+ printf(fmt, sizeof(dummy_payload->pair), "pair");
+ printf(fmt, sizeof(dummy_payload->event), "event");
+ printf(fmt, sizeof(dummy_payload->library), "library");
+ printf(fmt, sizeof(dummy_payload->structure), "struct");
+ printf(fmt, sizeof(dummy_payload->gob), "gob");
+ printf(fmt, sizeof(dummy_payload->money), "money");
+ printf(fmt, sizeof(dummy_payload->handle), "handle");
+ printf(fmt, sizeof(dummy_payload->all), "all");
+ fflush(stdout);
#endif
-#ifdef SHOW_SIZEOFS
- // For debugging ports to some systems:
- printf("%d %s\n", sizeof(REBWRD), "word");
- printf("%d %s\n", sizeof(REBSRI), "series");
- printf("%d %s\n", sizeof(REBCNT), "logic");
- printf("%d %s\n", sizeof(REBI64), "integer");
- printf("%d %s\n", sizeof(REBU64), "unteger");
- printf("%d %s\n", sizeof(REBINT), "int32");
- printf("%d %s\n", sizeof(REBDEC), "decimal");
- printf("%d %s\n", sizeof(REBUNI), "uchar");
- printf("%d %s\n", sizeof(REBERR), "error");
- printf("%d %s\n", sizeof(REBTYP), "datatype");
- printf("%d %s\n", sizeof(REBFRM), "frame");
- printf("%d %s\n", sizeof(REBWRS), "wordspec");
- printf("%d %s\n", sizeof(REBTYS), "typeset");
- printf("%d %s\n", sizeof(REBSYM), "symbol");
- printf("%d %s\n", sizeof(REBTIM), "time");
- printf("%d %s\n", sizeof(REBTUP), "tuple");
- printf("%d %s\n", sizeof(REBFCN), "func");
- printf("%d %s\n", sizeof(REBOBJ), "object");
- printf("%d %s\n", sizeof(REBXYF), "pair");
- printf("%d %s\n", sizeof(REBEVT), "event");
- printf("%d %s\n", sizeof(REBLIB), "library");
- printf("%d %s\n", sizeof(REBROT), "routine");
- printf("%d %s\n", sizeof(REBSTU), "structure");
- printf("%d %s\n", sizeof(REBGBO), "gob");
- printf("%d %s\n", sizeof(REBUDT), "utype");
- printf("%d %s\n", sizeof(REBDCI), "deci");
- printf("%d %s\n", sizeof(REBHAN), "handle");
- printf("%d %s\n", sizeof(REBALL), "all");
+#if !defined(NDEBUG)
+ //
+ // Sanity check the platform byte-ordering sensitive flag macros
+ //
+ REBUPT flags;
+
+ flags = FLAGIT_LEFT(0);
+ unsigned char *ch = (unsigned char*)&flags;
+ if (*ch != 128) {
+ printf("Expected 128, got %d\n", *ch);
+ panic ("Bad leftmost bit setting of platform unsigned integer.");
+ }
+
+ flags = FLAGIT_LEFT(0) | FLAGIT_LEFT(1) | FLAGBYTE_RIGHT(13);
+
+ unsigned int left = LEFT_N_BITS(flags, 3); // == 6 (binary `110`)
+ unsigned int right = RIGHT_N_BITS(flags, 3); // == 5 (binary `101`)
+ if (left != 6 || right != 5) {
+ printf("Expected 6 and 5, got %u and %u\n", left, right);
+ panic ("Bad composed integer assignment for byte-ordering macro.");
+ }
#endif
- ASSERT(VAL_TYPE(&val) == 123, RP_REBVAL_ALIGNMENT);
- ASSERT(sizeof(REBVAL) == 16, RP_REBVAL_ALIGNMENT);
- ASSERT1(sizeof(REBDAT) == 4, RP_BAD_SIZE);
- ASSERT1(sizeof(REBGOB) == 64, RP_BAD_SIZE);
+ // Although the system is designed to be able to function with REBVAL at
+ // any size, the optimization of it being 4x(32-bit) on 32-bit platforms
+ // and 4x(64-bit) on 64-bit platforms is a rather important performance
+ // point. For the moment we consider it to be essential enough to the
+ // intended function of the system that it refuses to run if not true.
+ //
+ // But if someone is in an odd situation and understands why the size did
+ // not work out as designed, it *should* be possible to comment this out
+ // and keep running.
+ //
+ if (sizeof(REBVAL) != sizeof(void*) * 4)
+ panic ("size of REBVAL is not sizeof(void*) * 4");
+
+ assert(sizeof(REBEVT) == sizeof(REBVAL));
+
+ // The REBSER is designed to place the `info` bits exactly after a REBVAL
+ // so they can do double-duty as also a terminator for that REBVAL when
+ // enumerated as an ARRAY.
+ //
+ if (
+ offsetof(REBSER, info) - offsetof(REBSER, content) != sizeof(REBVAL)
+ ){
+ panic ("bad structure alignment for internal array termination");
+ }
+
+ // Void cells currently use REB_MAX for the type bits, and the debug
+ // build uses REB_MAX + 1 for signaling "trash". At most 64 "Reb_Kind"
+ // types are used at the moment, yet the type is a byte for efficient
+ // reading, so there's little danger of hitting this unless there's
+ // a big change.
+ //
+ assert(REB_MAX + 1 < 256);
+
+ // Make sure tricks for "internal END markers" are lined up as expected.
+ //
+ assert(SERIES_INFO_0_IS_TRUE == NODE_FLAG_NODE);
+ assert(SERIES_INFO_1_IS_FALSE == NODE_FLAG_FREE);
+ assert(SERIES_INFO_4_IS_TRUE == NODE_FLAG_END);
+ assert(SERIES_INFO_7_IS_FALSE == NODE_FLAG_CELL);
+
+ assert(DO_FLAG_0_IS_TRUE == NODE_FLAG_NODE);
+ assert(DO_FLAG_1_IS_FALSE == NODE_FLAG_FREE);
+ assert(DO_FLAG_4_IS_TRUE == NODE_FLAG_END);
+ assert(DO_FLAG_7_IS_FALSE == NODE_FLAG_CELL);
}
-/***********************************************************************
-**
-*/ static void Print_Banner(REBARGS *rargs)
-/*
-***********************************************************************/
+//
+// Startup_Base: C
+//
+// The code in "base" is the lowest level of Rebol initialization written as
+// Rebol code. This is where things like `+` being an infix form of ADD is
+// set up, or FIRST being a specialization of PICK. It's also where the
+// definition of the locals-gathering FUNCTION currently lives.
+//
+static void Startup_Base(REBARR *boot_base)
{
- if (rargs->options & RO_VERS) {
- Debug_Fmt((REBYTE*)Str_Banner, REBOL_VER, REBOL_REV, REBOL_UPD, REBOL_SYS, REBOL_VAR);
- OS_EXIT(0);
- }
+ RELVAL *head = ARR_HEAD(boot_base);
+
+ // By this point, the Lib_Context contains basic definitions for things
+ // like true, false, the natives, and the actions. But before deeply
+ // binding the code in the base block to those definitions, add all the
+ // top-level SET-WORD! in the base block to Lib_Context as well.
+ //
+ // Without this shallow walk looking for set words, an assignment like
+ // `function: func [...] [...]` would not have a slot in the Lib_Context
+ // for FUNCTION to bind to. So FUNCTION: would be an unbound SET-WORD!,
+ // and give an error on the assignment.
+ //
+ Bind_Values_Set_Midstream_Shallow(head, Lib_Context);
+
+ // With the base block's definitions added to the mix, deep bind the code
+ // and execute it. As a sanity check, it's expected the base block will
+ // return no value when executed...hence it should end in `()`.
+
+ Bind_Values_Deep(head, Lib_Context);
+
+ DECLARE_LOCAL (result);
+ if (Do_At_Throws(result, boot_base, 0, SPECIFIED))
+ panic (result);
+
+ if (!IS_VOID(result))
+ panic (result);
}
-/***********************************************************************
-**
-*/ static void Do_Global_Block(REBSER *block, REBINT rebind)
-/*
-** Bind and evaluate a global block.
-** Rebind:
-** 0: bind set into sys or lib
-** -1: bind shallow into sys (for NATIVE and ACTION)
-** 1: add new words to LIB, bind/deep to LIB
-** 2: add new words to SYS, bind/deep to LIB
-** A single result is left on top of data stack (may be an error).
-**
-***********************************************************************/
-{
- Bind_Block(rebind > 1 ? Sys_Context : Lib_Context, BLK_HEAD(block), BIND_SET);
- if (rebind < 0) Bind_Block(Sys_Context, BLK_HEAD(block), 0);
- if (rebind > 0) Bind_Block(Lib_Context, BLK_HEAD(block), BIND_DEEP);
- if (rebind > 1) Bind_Block(Sys_Context, BLK_HEAD(block), BIND_DEEP);
- Do_Blk(block, 0);
+//
+// Startup_Sys: C
+//
+// The SYS context contains supporting Rebol code for implementing "system"
+// features. The code has natives, actions, and the definitions from
+// Startup_Base() available for its implementation.
+//
+// (Note: The SYS context should not be confused with "the system object",
+// which is a different thing.)
+//
+// The sys context has a #define constant for the index of every definition
+// inside of it. That means that you can access it from the C code for the
+// core. Any work the core C needs to have done that would be more easily
+// done by delegating it to Rebol can use a function in sys as a service.
+//
+static void Startup_Sys(REBARR *boot_sys) {
+ RELVAL *head = ARR_HEAD(boot_sys);
+
+ // Add all new top-level SET-WORD! found in the sys boot-block to Lib,
+ // and then bind deeply all words to Lib and Sys. See Startup_Base() notes
+ // for why the top-level walk is needed first.
+ //
+ Bind_Values_Set_Midstream_Shallow(head, Sys_Context);
+ Bind_Values_Deep(head, Lib_Context);
+ Bind_Values_Deep(head, Sys_Context);
+
+ DECLARE_LOCAL (result);
+ if (Do_At_Throws(result, boot_sys, 0, SPECIFIED))
+ panic (result);
+
+ if (!IS_VOID(result))
+ panic (result);
}
-/***********************************************************************
-**
-*/ static void Load_Boot(void)
-/*
-** Decompress and scan in the boot block structure. Can
-** only be called at the correct point because it will
-** create new symbols.
-**
-***********************************************************************/
+//
+// Startup_Datatypes: C
+//
+// Create library words for each type, (e.g. make INTEGER! correspond to
+// the integer datatype value). Returns an array of words for the added
+// datatypes to use in SYSTEM/CATALOG/DATATYPES
+//
+// Note the type enum starts at 1 (REB_FUNCTION), given that REB_0 is used
+// for special purposes and not correspond to a user-visible type. REB_MAX is
+// used for void, and also not value type. Hence the total number of types is
+// REB_MAX - 1.
+//
+static REBARR *Startup_Datatypes(REBARR *boot_types, REBARR *boot_typespecs)
{
- REBSER *boot;
-
- // Decompress binary data in Native_Specs to get the textual source
- // of the function specs of the native routines. (This compressed
- // array lives in b-boot.c which is generated by make-boot.r)
- // Then load that into a Rebol series as `boot`. Note that the
- // first four bytes of Native_Specs is a little-endian 32-bit
- // length of the uncompressed spec data.
- {
- REBSER spec;
- REBSER *text;
- REBINT textlen;
-
- // REVIEW: This is a nasty casting away of a const. But there's
- // nothing that can be done about it as long as Decompress takes
- // a REBSER, as the data field is not const
- spec.data = ((REBYTE*)Native_Specs) + 4;
- spec.tail = NAT_SPEC_SIZE;
-
- textlen = Bytes_To_Long(Native_Specs);
- text = Decompress(&spec, 0, -1, textlen, 0);
- if (!text || (STR_LEN(text) != textlen)) Crash(RP_BOOT_DATA);
- boot = Scan_Source(STR_HEAD(text), textlen);
- //Dump_Block_Raw(boot, 0, 2);
- Free_Series(text);
- }
-
- Set_Root_Series(ROOT_BOOT, boot, "boot block"); // Do not let it get GC'd
-
- Boot_Block = (BOOT_BLK *)VAL_BLK(BLK_HEAD(boot));
-
- ASSERT(VAL_TAIL(&Boot_Block->types) == REB_MAX, RP_BAD_BOOT_TYPE_BLOCK);
- ASSERT(VAL_WORD_SYM(VAL_BLK(&Boot_Block->types)) == SYM_END_TYPE, RP_BAD_END_TYPE_WORD);
-
- // Create low-level string pointers (used by RS_ constants):
- {
- REBYTE *cp;
- REBINT i;
-
- PG_Boot_Strs = (REBYTE **)Make_Mem(RS_MAX * sizeof(REBYTE *));
- *ROOT_STRINGS = Boot_Block->strings;
- cp = VAL_BIN(ROOT_STRINGS);
- for (i = 0; i < RS_MAX; i++) {
- BOOT_STR(i,0) = cp;
- while (*cp++);
- }
- }
-
- ASSERT(!CMP_BYTES("end!", Get_Sym_Name(SYM_END_TYPE)), RP_BAD_END_CANON_WORD);
- ASSERT(!CMP_BYTES("true", Get_Sym_Name(SYM_TRUE)), RP_BAD_TRUE_CANON_WORD);
- ASSERT(!CMP_BYTES("line", BOOT_STR(RS_SCAN,1)), RP_BAD_BOOT_STRING);
-}
+ if (ARR_LEN(boot_types) != REB_MAX - 1)
+ panic (boot_types); // Every REB_XXX but REB_0 should have a WORD!
+ RELVAL *word = ARR_HEAD(boot_types);
-/***********************************************************************
-**
-*/ static void Init_Datatypes(void)
-/*
-** Create the datatypes.
-**
-***********************************************************************/
-{
- REBVAL *word = VAL_BLK(&Boot_Block->types);
- REBSER *specs = VAL_SERIES(&Boot_Block->typespecs);
- REBVAL *value;
- REBINT n;
-
- for (n = 0; NOT_END(word); word++, n++) {
- value = Append_Frame(Lib_Context, word, 0);
- VAL_SET(value, REB_DATATYPE);
- VAL_DATATYPE(value) = n;
- VAL_TYPE_SPEC(value) = VAL_SERIES(BLK_SKIP(specs, n));
- }
-}
-
-
-/***********************************************************************
-**
-*/ static void Init_Datatype_Checks(void)
-/*
-** Create datatype test functions (e.g. integer?, time?, etc)
-** Must be done after typesets are initialized, so this cannot
-** be merged with the above.
-**
-***********************************************************************/
-{
- REBVAL *word = VAL_BLK(&Boot_Block->types);
- REBVAL *value;
- REBSER *spec;
- REBCNT sym;
- REBINT n = 1;
- REBYTE str[32];
-
- spec = VAL_SERIES(VAL_BLK(&Boot_Block->booters));
-
- for (word++; NOT_END(word); word++, n++) {
- COPY_BYTES(str, Get_Word_Name(word), 32);
- str[LEN_BYTES(str)-1] = '?';
- sym = Make_Word(str, 0);
- //Print("sym: %s", Get_Sym_Name(sym));
- value = Append_Frame(Lib_Context, 0, sym);
- VAL_INT64(BLK_LAST(spec)) = n; // special datatype id location
- Make_Native(value, Copy_Block(spec, 0), (REBFUN)A_TYPE, REB_ACTION);
- }
-
- value = Append_Frame(Lib_Context, 0, SYM_DATATYPES);
- *value = Boot_Block->types;
-}
+ if (VAL_WORD_SYM(word) != SYM_FUNCTION_X)
+ panic (word); // First type should be FUNCTION!
+ REBARR *catalog = Make_Array(REB_MAX - 1);
-/***********************************************************************
-**
-*/ static void Init_Constants(void)
-/*
-** Init constant words.
-**
-** WARNING: Do not create direct pointers into the Lib_Context
-** because it may get expanded and the pointers will be invalid.
-**
-***********************************************************************/
-{
- REBVAL *value;
- extern const double pi1;
+ REBINT n;
+ for (n = 1; NOT_END(word); word++, n++) {
+ assert(n < REB_MAX);
- value = Append_Frame(Lib_Context, 0, SYM_NONE);
- SET_NONE(value);
+ REBVAL *value = Append_Context(Lib_Context, KNOWN(word), NULL);
+ VAL_RESET_HEADER(value, REB_DATATYPE);
+ VAL_TYPE_KIND(value) = cast(enum Reb_Kind, n);
+ VAL_TYPE_SPEC(value) = VAL_ARRAY(ARR_AT(boot_typespecs, n - 1));
- value = Append_Frame(Lib_Context, 0, SYM_TRUE);
- SET_LOGIC(value, TRUE);
+ // !!! The system depends on these definitions, as they are used by
+ // Get_Type and Type_Of. Lock it for safety...though consider an
+ // alternative like using the returned types catalog and locking
+ // that. (It would be hard to rewrite lib to safely change a type
+ // definition, given the code doing the rewriting would likely depend
+ // on lib...but it could still be technically possible, even in
+ // a limited sense.)
+ //
+ assert(value == Get_Type(cast(enum Reb_Kind, n)));
+ SET_VAL_FLAG(CTX_VAR(Lib_Context, n), VALUE_FLAG_PROTECTED);
- value = Append_Frame(Lib_Context, 0, SYM_FALSE);
- SET_LOGIC(value, FALSE);
+ Append_Value(catalog, KNOWN(word));
+ }
- value = Append_Frame(Lib_Context, 0, SYM_PI);
- SET_DECIMAL(value, pi1);
+ return catalog;
}
-/***********************************************************************
-**
-*/ void Use_Natives(REBFUN *funcs, REBCNT limit)
-/*
-** Setup to use NATIVE function. If limit == 0, then the
-** native function table will be zero terminated (N_native).
-**
-***********************************************************************/
+//
+// Startup_True_And_False: C
+//
+// !!! Rebol is firm on TRUE and FALSE being WORD!s, as opposed to the literal
+// forms of logical true and false. Not only does this frequently lead to
+// confusion, but there's not consensus on what a good literal form would be.
+// R3-Alpha used #[true] and #[false] (but often molded them as looking like
+// the words true and false anyway). $true and $false have been proposed,
+// but would not be backward compatible in files read by bootstrap.
+//
+// Since no good literal form exists, the %sysobj.r file uses the words. They
+// have to be defined before the point that it runs (along with the natives).
+//
+static void Startup_True_And_False(void)
{
- Native_Count = 0;
- Native_Limit = limit;
- Native_Functions = funcs;
+ REBVAL *true_value = Append_Context(Lib_Context, 0, Canon(SYM_TRUE));
+ Init_Logic(true_value, TRUE);
+ assert(VAL_LOGIC(true_value) == TRUE);
+ assert(IS_CONDITIONAL_TRUE(true_value));
+
+ REBVAL *false_value = Append_Context(Lib_Context, 0, Canon(SYM_FALSE));
+ Init_Logic(false_value, FALSE);
+ assert(VAL_LOGIC(false_value) == FALSE);
+ assert(IS_CONDITIONAL_FALSE(false_value));
}
-/***********************************************************************
-**
-*/ REBNATIVE(native)
-/*
-***********************************************************************/
+//
+// action: native [
+//
+// {Creates datatype action (for internal usage only).}
+//
+// return: [function!]
+// :verb [set-word! word!]
+// spec [block!]
+// ]
+//
+REBNATIVE(action)
+//
+// The `action` native is searched for explicitly by %make-natives.r and put
+// in second place for initialization (after the `native` native).
+//
+// It is designed to be a lookback binding that quotes its first argument,
+// so when you write FOO: ACTION [...], the FOO: gets quoted to be the verb.
+// The SET/LOOKBACK is done by the bootstrap, after the natives are loaded.
{
- if ((Native_Limit == 0 && *Native_Functions) || (Native_Count < Native_Limit))
- Make_Native(ds, VAL_SERIES(D_ARG(1)), *Native_Functions++, REB_NATIVE);
- else Trap0(RE_MAX_NATIVES);
- Native_Count++;
- return R_RET;
+ INCLUDE_PARAMS_OF_ACTION;
+
+ REBVAL *spec = ARG(spec);
+
+ // We only want to check the return type in the debug build. In the
+ // release build, we want to have as few argument slots as possible...
+ // especially to get the optimization for 1 argument to go in the cell
+ // and not need to push arguments.
+ //
+ REBFLGS flags = MKF_KEYWORDS | MKF_FAKE_RETURN;
+
+ REBFUN *fun = Make_Function(
+ Make_Paramlist_Managed_May_Fail(spec, flags),
+ &Action_Dispatcher,
+ NULL, // no underlying function--this is fundamental
+ NULL // not providing a specialization
+ );
+
+ Move_Value(FUNC_BODY(fun), ARG(verb));
+
+ // A lookback quoting function that quotes a SET-WORD! on its left is
+ // responsible for setting the value if it wants it to change since the
+ // SET-WORD! is not actually active. But if something *looks* like an
+ // assignment, it's good practice to evaluate the whole expression to
+ // the result the SET-WORD! was set to, so `x: y: op z` makes `x = y`.
+ //
+ Move_Value(Sink_Var_May_Fail(ARG(verb), SPECIFIED), FUNC_VALUE(fun));
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+
+ // !!! A very hacky (yet less hacky than R3-Alpha) re-dispatch of APPEND
+ // as WRITE/APPEND on ports requires knowing what the WRITE action is.
+ // Rather than track an entire table of all the actions in order to
+ // support that and thus endorse this hack being used other places, just
+ // save the write action into a global.
+ //
+ if (VAL_WORD_SYM(ARG(verb)) == SYM_WRITE) {
+ INIT_CELL(&PG_Write_Action);
+ Move_Value(&PG_Write_Action, D_OUT);
+ }
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(action)
-/*
-***********************************************************************/
+//
+// Add_Lib_Keys_R3Alpha_Cant_Make: C
+//
+// In order for the bootstrap to assign values to library words, they have to
+// exist in the bootstrap context. The way they get into the context is by
+// a scan for top-level SET-WORD!s in the %sys-xxx.r and %mezz-xxx.r files.
+//
+// However, R3-Alpha doesn't allow set-words like /: and <=: The words can
+// be gotten with `pick [/] 1` or similar, but they cannot be SET because
+// there's nothing in the context to bind them to...since no SET-WORD! was
+// picked up in the scan.
+//
+// As a workaround, this just adds the words to the context manually. Then,
+// however the words are created, it will be possible to bind them and set
+// them to things.
+//
+// !!! Even as Ren-C becomes more permissive in letting SET-WORDs for these
+// items be created, they should not be seen by %make-boot.r so long as the
+// code expects to be bootstrapped with R3-Alpha. This is because as part
+// of the bootstrap, the code is loaded/processed and molded out as one
+// giant file. Ren-C being able to read `=>:` would not be able to help
+// retroactively make old R3-Alphas read it too.
+//
+static void Add_Lib_Keys_R3Alpha_Cant_Make(void)
{
- Action_Count++;
- if (Action_Count >= A_MAX_ACTION) Crash(RP_ACTION_OVERFLOW);
- Make_Native(ds, VAL_SERIES(D_ARG(1)), (REBFUN)Action_Count, REB_ACTION);
- return R_RET;
-}
+ const char *names[] = {
+ "<",
+ ">",
+ "<=", // less than or equal to
+ "=>", // no current system meaning
-/***********************************************************************
-**
-*/ REBNATIVE(context)
-/*
-** The spec block has already been bound to Lib_Context, to
-** allow any embedded values and functions to evaluate.
-**
-***********************************************************************/
-{
- REBVAL *spec = D_ARG(1);
-
- SET_OBJECT(ds, Make_Object(0, VAL_BLK(spec)));
- Bind_Block(VAL_OBJ_FRAME(ds), VAL_BLK(spec), BIND_ONLY); // not deep
- Do_Blk(VAL_SERIES(spec), 0); // result ignored
- return R_RET;
-}
+ ">=", // greater than or equal to
+ "=<",
+ "<>", // may ultimately be targeted for empty tag in Ren-C
-/***********************************************************************
-**
-*/ static void Init_Ops(void)
-/*
-***********************************************************************/
-{
- REBVAL *word;
- REBVAL *func;
- REBVAL *val;
-
- for (word = VAL_BLK(&Boot_Block->ops); NOT_END(word); word+=2) {
- // Append the operator name to the lib frame:
- val = Append_Frame(Lib_Context, word, 0);
- // Find the related function:
- func = Find_Word_Value(Lib_Context, VAL_WORD_SYM(word+1));
- if (!func) Crash(9912);
- *val = *func;
- VAL_SET(val, REB_OP);
- VAL_SET_EXT(val, VAL_TYPE(func));
- }
-}
+ "->", // FUNCTION-style lambda ("reaches in")
+ "<-", // FUNC-style lambda ("reaches out"),
+ "|>", // Evaluate to next single expression, but do ones afterward
+ "<|", // Evaluate to previous expression, but do rest (like ALSO)
-/***********************************************************************
-**
-*/ static void Init_Natives(void)
-/*
-** Create native functions.
-**
-***********************************************************************/
-{
- REBVAL *word;
- REBVAL *val;
-
- Action_Count = 0;
- Use_Natives((REBFUN *)Native_Funcs, MAX_NATS);
-
- // Construct the first native, which is the NATIVE function creator itself:
- // native: native [spec [block!]]
- word = VAL_BLK_SKIP(&Boot_Block->booters, 1);
- ASSERT2(IS_SET_WORD(word) && VAL_WORD_SYM(word) == SYM_NATIVE, RE_NATIVE_BOOT);
- //val = BLK_SKIP(Sys_Context, SYS_CTX_NATIVE);
- val = Append_Frame(Lib_Context, word, 0);
- Make_Native(val, VAL_SERIES(word+2), Native_Functions[0], REB_NATIVE);
-
- word += 3; // action: native []
- //val = BLK_SKIP(Sys_Context, SYS_CTX_ACTION);
- val = Append_Frame(Lib_Context, word, 0);
- Make_Native(val, VAL_SERIES(word+2), Native_Functions[1], REB_NATIVE);
- Native_Count = 2;
- Native_Functions += 2;
-
- Action_Marker = SERIES_TAIL(Lib_Context)-1; // Save index for action words.
- Do_Global_Block(VAL_SERIES(&Boot_Block->actions), -1);
- Do_Global_Block(VAL_SERIES(&Boot_Block->natives), -1);
-}
+ "/",
+ "//", // is remainder in R3-Alpha, not ideal
+ NULL
+ };
-/***********************************************************************
-**
-*/ REBVAL *Get_Action_Word(REBCNT action)
-/*
-** Return the word symbol for a given Action number.
-**
-***********************************************************************/
-{
- return FRM_WORD(Lib_Context, Action_Marker+action);
+ REBINT i = 0;
+ while (names[i]) {
+ REBSTR *str = Intern_UTF8_Managed(cb_cast(names[i]), strlen(names[i]));
+ REBVAL *val = Append_Context(Lib_Context, NULL, str);
+ Init_Void(val); // functions will fill in (no-op, since void already)
+ ++i;
+ }
}
-/***********************************************************************
-**
-*/ REBVAL *Get_Action_Value(REBCNT action)
-/*
-** Return the value (function) for a given Action number.
-**
-***********************************************************************/
+//
+// Init_Function_Tag: C
+//
+// !!! It didn't seem there was a "compare UTF8 byte array to arbitrary
+// decoded REB_TAG which may or may not be REBUNI" routine, but there was
+// an easy way to compare tags to each other. So pre-fabricating these was
+// quick, but a better solution should be reviewed in terms of an overall
+// string and UTF8 rethinking.
+//
+static void Init_Function_Tag(const char *name, REBVAL *slot)
{
- return FRM_VALUE(Lib_Context, Action_Marker+action);
+ Init_Tag(slot, Make_UTF8_May_Fail(name));
+ Freeze_Sequence(VAL_SERIES(slot));
}
-/***********************************************************************
-**
-*/ void Init_UType_Proto()
-/*
-** Create prototype func object for UTypes.
-**
-***********************************************************************/
+//
+// Init_Function_Tags: C
+//
+// FUNC and PROC search for these tags, like and . They are
+// natives and run during bootstrap, so these string comparisons are
+// needed. This routine does not use a table directly, because the slots
+// it initializes are not constants...and older TCCs don't support local
+// struct arrays of that form.
+//
+static void Init_Function_Tags(void)
{
- REBSER *frm = Make_Frame(A_MAX_ACTION-1);
- REBVAL *obj;
- REBINT n;
-
- Insert_Series(FRM_WORD_SERIES(frm), 1, (REBYTE*)FRM_WORD(Lib_Context, Action_Marker+1), A_MAX_ACTION);
-
- SERIES_TAIL(frm) = A_MAX_ACTION;
- for (n = 1; n < A_MAX_ACTION; n++)
- SET_NONE(BLK_SKIP(frm, n));
- BLK_TERM(frm);
-
- obj = Get_System(SYS_STANDARD, STD_UTYPE);
- SET_OBJECT(obj, frm);
+ Init_Function_Tag("with", ROOT_WITH_TAG);
+ Init_Function_Tag("...", ROOT_ELLIPSIS_TAG);
+ Init_Function_Tag("opt", ROOT_OPT_TAG);
+ Init_Function_Tag("end", ROOT_END_TAG);
+ Init_Function_Tag("local", ROOT_LOCAL_TAG);
+ Init_Function_Tag("durable", ROOT_DURABLE_TAG);
}
-/***********************************************************************
-**
-*/ static void Init_Data_Stack(REBCNT size)
-/*
-***********************************************************************/
-{
- DS_Series = Make_Block(size);
- Set_Root_Series(TASK_STACK, DS_Series, "data stack"); // uses special GC
- DS_Base = BLK_HEAD(DS_Series);
- DSP = DSF = 0;
- SET_NONE(DS_TOP); // avoids it being set to END (GC problem)
+//
+// Init_Function_Meta_Shim: C
+//
+// Make_Paramlist_Managed_May_Fail() needs the object archetype FUNCTION-META
+// from %sysobj.r, to have the keylist to use in generating the info used
+// by HELP for the natives. However, natives themselves are used in order
+// to run the object construction in %sysobj.r
+//
+// To break this Catch-22, this code builds a field-compatible version of
+// FUNCTION-META. After %sysobj.r is loaded, an assert checks to make sure
+// that this manual construction actually matches the definition in the file.
+//
+static void Init_Function_Meta_Shim(void) {
+ REBSYM field_syms[6] = {
+ SYM_SELF, SYM_DESCRIPTION, SYM_RETURN_TYPE, SYM_RETURN_NOTE,
+ SYM_PARAMETER_TYPES, SYM_PARAMETER_NOTES
+ };
+ REBCTX *function_meta = Alloc_Context(REB_OBJECT, 6);
+ REBCNT i = 1;
+ for (; i <= 6; ++i) {
+ //
+ // BLANK! is used for the fields instead of void (required for
+ // R3-Alpha compatibility to load the object)
+ //
+ Init_Blank(
+ Append_Context(function_meta, NULL, Canon(field_syms[i - 1]))
+ );
+ }
+
+ Init_Object(CTX_VAR(function_meta, 1), function_meta); // it's "selfish"
+
+ Init_Object(ROOT_FUNCTION_META, function_meta);
}
-/***********************************************************************
-**
-*/ static void Init_Root_Context(void)
-/*
-** Hand-build the root context where special REBOL values are
-** stored. Called early, so it cannot depend on any other
-** system structures or values.
-**
-** Note that the Root_Context's word table is unset!
-** None of its values are exported.
-**
-***********************************************************************/
+//
+// Startup_Natives: C
+//
+// Create native functions. In R3-Alpha this would go as far as actually
+// creating a NATIVE native by hand, and then run code that would call that
+// native for each function. Ren-C depends on having the native table
+// initialized to run the evaluator (for instance to test functions against
+// the EXIT native's FUNC signature in definitional returns). So it
+// "fakes it" just by calling a C function for each item...and there is no
+// actual "native native".
+//
+// If there *were* a REBNATIVE(native) this would be its spec:
+//
+// native: native [
+// spec [block!]
+// /body
+// {Body of user code matching native's behavior (for documentation)}
+// code [block!]
+// ]
+//
+// Returns an array of words bound to natives for SYSTEM/CATALOG/NATIVES
+//
+static REBARR *Startup_Natives(REBARR *boot_natives)
{
- REBVAL *value;
- REBINT n;
- REBSER *frame;
-
- frame = Make_Block(ROOT_MAX); // Only half the context! (No words)
- KEEP_SERIES(frame, "root context");
- LOCK_SERIES(frame);
- Root_Context = (ROOT_CTX*)(frame->data);
-
- // Get first value (the SELF for the context):
- value = ROOT_SELF;
- SET_FRAME(value, 0, 0); // No words or spec (at first)
-
- // Set all other values to NONE:
- for (n = 1; n < ROOT_MAX; n++) SET_NONE(value+n);
- SET_END(value+ROOT_MAX);
- SERIES_TAIL(frame) = ROOT_MAX;
-
- // Initialize a few fields:
- Set_Block(ROOT_ROOT, frame);
- Init_Word(ROOT_NONAME, SYM__UNNAMED_);
+ // Must be called before first use of Make_Paramlist_Managed_May_Fail()
+ //
+ Init_Function_Meta_Shim();
+
+ RELVAL *item = ARR_HEAD(boot_natives);
+
+ // Although the natives are not being "executed", there are typesets
+ // being built from the specs. So to process `foo: native [x [integer!]]`
+ // the INTEGER! word must be bound to its datatype. Deep walk the
+ // natives in order to bind these datatypes.
+ //
+ Bind_Values_Deep(item, Lib_Context);
+
+ REBARR *catalog = Make_Array(NUM_NATIVES);
+
+ REBCNT n = 0;
+ REBVAL *action_word = NULL;
+
+ while (NOT_END(item)) {
+ if (n >= NUM_NATIVES)
+ panic (item);
+
+ // Each entry should be one of these forms:
+ //
+ // some-name: native [spec content]
+ //
+ // some-name: native/body [spec content] [equivalent user code]
+ //
+ // If more refinements are added, this code will have to be made
+ // more sophisticated.
+ //
+ // Though the manual building of this table is not as nice as running
+ // the evaluator, the evaluator makes comparisons against native
+ // values. Having all natives loaded fully before ever running
+ // Do_Core() helps with stability and invariants.
+
+ // Get the name the native will be started at with in Lib_Context
+ //
+ if (!IS_SET_WORD(item))
+ panic (item);
+
+ REBVAL *name = KNOWN(item);
+ ++item;
+
+ // See if it's being invoked with NATIVE or NATIVE/BODY
+ //
+ REBOOL has_body;
+ if (IS_WORD(item)) {
+ if (VAL_WORD_SYM(item) != SYM_NATIVE)
+ panic (item);
+ has_body = FALSE;
+ }
+ else {
+ if (
+ !IS_PATH(item)
+ || VAL_LEN_HEAD(item) != 2
+ || !IS_WORD(ARR_HEAD(VAL_ARRAY(item)))
+ || VAL_WORD_SYM(ARR_HEAD(VAL_ARRAY(item))) != SYM_NATIVE
+ || !IS_WORD(ARR_AT(VAL_ARRAY(item), 1))
+ || VAL_WORD_SYM(ARR_AT(VAL_ARRAY(item), 1)) != SYM_BODY
+ ) {
+ panic (item);
+ }
+ has_body = TRUE;
+ }
+ ++item;
+
+ REBVAL *spec = KNOWN(item);
+ ++item;
+ if (!IS_BLOCK(spec))
+ panic (spec);
+
+ // With the components extracted, generate the native and add it to
+ // the Natives table. The associated C function is provided by a
+ // table built in the bootstrap scripts, `Native_C_Funcs`.
+
+ // We only want to check the return type in the debug build. In the
+ // release build, we want to have as few argument slots as possible...
+ // especially to get the optimization for 1 argument to go in the cell
+ // and not need to push arguments.
+ //
+ REBFLGS flags = MKF_KEYWORDS | MKF_FAKE_RETURN;
+
+ REBFUN *fun = Make_Function(
+ Make_Paramlist_Managed_May_Fail(KNOWN(spec), flags),
+ Native_C_Funcs[n], // "dispatcher" is unique to this "native"
+ NULL, // no underlying function, this is fundamental
+ NULL // not providing a specialization
+ );
+
+ // If a user-equivalent body was provided, we save it in the native's
+ // REBVAL for later lookup.
+ //
+ if (has_body) {
+ REBVAL *body = KNOWN(item); // !!! handle relative?
+ ++item;
+ if (!IS_BLOCK(body))
+ panic (body);
+ *FUNC_BODY(fun) = *body;
+ }
+
+ Prep_Global_Cell(&Natives[n]);
+ Move_Value(&Natives[n], FUNC_VALUE(fun));
+
+ // Append the native to the Lib_Context under the name given.
+ //
+ REBVAL *var = Append_Context(Lib_Context, name, 0);
+ Move_Value(var, &Natives[n]);
+
+ // Do special case SET/LOOKBACK=TRUE so that SOME-ACTION: ACTION [...]
+ // allows ACTION to see the SOME-ACTION symbol, and know to use it.
+ //
+ if (VAL_WORD_SYM(name) == SYM_ACTION) {
+ SET_VAL_FLAG(var, VALUE_FLAG_ENFIXED);
+ action_word = name;
+ }
+
+ REBVAL *catalog_item = Alloc_Tail_Array(catalog);
+ Move_Value(catalog_item, name);
+ VAL_SET_TYPE_BITS(catalog_item, REB_WORD);
+
+ ++n;
+ }
+
+ if (n != NUM_NATIVES)
+ panic ("Incorrect number of natives found during processing");
+
+ if (action_word == NULL)
+ panic ("ACTION native not found during boot block processing");
+
+ return catalog;
}
-/***********************************************************************
-**
-*/ void Set_Root_Series(REBVAL *value, REBSER *ser, REBYTE *label)
-/*
-** Used to set block and string values in the ROOT context.
-**
-***********************************************************************/
+//
+// Startup_Actions: C
+//
+// Returns an array of words bound to actions for SYSTEM/CATALOG/ACTIONS
+//
+static REBARR *Startup_Actions(REBARR *boot_actions)
{
- LABEL_SERIES(ser, label);
-
- if (SERIES_WIDE(ser) == sizeof(REBVAL))
- Set_Block(value, ser); // VAL_SET(value, REB_BLOCK);
- else
- Set_String(value, ser); //VAL_SET(value, REB_STRING);
+ RELVAL *head = ARR_HEAD(boot_actions);
+
+ // Add SET-WORD!s that are top-level in the actions block to the lib
+ // context, so there is a variable for each action. This means that the
+ // assignments can execute.
+ //
+ Bind_Values_Set_Midstream_Shallow(head, Lib_Context);
+
+ // The above code actually does bind the ACTION word to the ACTION native,
+ // since the action word is found in the top-level of the block. But as
+ // with the natives, in order to process `foo: action [x [integer!]]` the
+ // INTEGER! word must be bound to its datatype. Deep bind the code in
+ // order to bind the words for these datatypes.
+ //
+ Bind_Values_Deep(head, Lib_Context);
+
+ DECLARE_LOCAL (result);
+ if (Do_At_Throws(result, boot_actions, 0, SPECIFIED))
+ panic (result);
+
+ if (!IS_VOID(result))
+ panic (result);
+
+ // Sanity check the symbol transformation
+ //
+ if (0 != strcmp("open", cs_cast(STR_HEAD(Canon(SYM_OPEN)))))
+ panic (Canon(SYM_OPEN));
+
+ REBDSP dsp_orig = DSP;
+
+ RELVAL *item = head;
+ for (; NOT_END(item); ++item)
+ if (IS_SET_WORD(item)) {
+ DS_PUSH_RELVAL(item, SPECIFIED);
+ VAL_SET_TYPE_BITS(DS_TOP, REB_WORD); // change pushed to WORD!
+ }
+
+ return Pop_Stack_Values(dsp_orig); // catalog of actions
}
-/***********************************************************************
-**
-*/ static void Init_Task_Context(void)
-/*
-** See above notes (same as root context, except for tasks)
-**
-***********************************************************************/
+//
+// Init_Root_Vars: C
+//
+// Hand-build the root array where special REBOL values are stored, and can
+// be garbage collected.
+//
+// This is called early, so it cannot depend on any other system structures
+// or values.
+//
+// !!! Efficiency note: does not need to be a heap allocated array, which
+// causes double dereferencing to access its values. Could just be global.
+//
+static void Init_Root_Vars(void)
{
- REBVAL *value;
- REBINT n;
- REBSER *frame;
-
- //Print_Str("Task Context");
-
- Task_Series = frame = Make_Block(TASK_MAX);
- KEEP_SERIES(frame, "task context");
- LOCK_SERIES(frame);
- Task_Context = (TASK_CTX*)(frame->data);
-
- // Get first value (the SELF for the context):
- value = TASK_SELF;
- SET_FRAME(value, 0, 0); // No words or spec (at first)
-
- // Set all other values to NONE:
- for (n = 1; n < TASK_MAX; n++) SET_NONE(value+n);
- SET_END(value+TASK_MAX);
- SERIES_TAIL(frame) = TASK_MAX;
-
- // Initialize a few fields:
- SET_INTEGER(TASK_BALLAST, MEM_BALLAST);
- SET_INTEGER(TASK_MAX_BALLAST, MEM_BALLAST);
+ REBARR *root = Make_Array_Core(
+ ROOT_MAX, SERIES_FLAG_FIXED_SIZE | NODE_FLAG_ROOT
+ );
+
+ PG_Root_Array = root;
+ Root_Vars = cast(ROOT_VARS*, ARR_HEAD(root));
+
+ // These values are simple isolated VOID, NONE, TRUE, and FALSE values
+ // that can be used in lieu of initializing them. They are initialized
+ // as two-element series in order to ensure that their address is not
+ // treated as an array.
+ //
+ // They should only be accessed by macros which retrieve their values
+ // as `const`, to avoid the risk of accidentally changing them. (This
+ // rule is broken by some special system code which `m_cast`s them for
+ // the purpose of using them as directly recognizable pointers which
+ // also look like values.)
+ //
+ // It is presumed that these types will never need to have GC behavior,
+ // and thus can be stored safely in program globals without mention in
+ // the root set. Should that change, they could be explicitly added
+ // to the GC's root set.
+
+ Prep_Global_Cell(&PG_Void_Cell[0]);
+ Prep_Global_Cell(&PG_Void_Cell[1]);
+ Init_Void(&PG_Void_Cell[0]);
+ TRASH_CELL_IF_DEBUG(&PG_Void_Cell[1]);
+
+ Prep_Global_Cell(&PG_Blank_Value[0]);
+ Prep_Global_Cell(&PG_Blank_Value[1]);
+ Init_Blank(&PG_Blank_Value[0]);
+ TRASH_CELL_IF_DEBUG(&PG_Blank_Value[1]);
+
+ Prep_Global_Cell(&PG_Bar_Value[0]);
+ Prep_Global_Cell(&PG_Bar_Value[1]);
+ Init_Bar(&PG_Bar_Value[0]);
+ TRASH_CELL_IF_DEBUG(&PG_Bar_Value[1]);
+
+ Prep_Global_Cell(&PG_False_Value[0]);
+ Prep_Global_Cell(&PG_False_Value[1]);
+ Init_Logic(&PG_False_Value[0], FALSE);
+ TRASH_CELL_IF_DEBUG(&PG_False_Value[1]);
+
+ Prep_Global_Cell(&PG_True_Value[0]);
+ Prep_Global_Cell(&PG_True_Value[1]);
+ Init_Logic(&PG_True_Value[0], TRUE);
+ TRASH_CELL_IF_DEBUG(&PG_True_Value[1]);
+
+ Prep_Global_Cell(&PG_Va_List_Pending);
+
+ // We can't actually put an end value in the middle of a block, so we poke
+ // this one into a program global. It is not legal to bit-copy an
+ // END (you always use SET_END), so we can make it unwritable.
+ //
+ Init_Endlike_Header(&PG_End_Node.header, 0); // mutate to read-only end
+#if !defined(NDEBUG)
+ Set_Track_Payload_Debug(&PG_End_Node, __FILE__, __LINE__);
+#endif
+ assert(IS_END(END)); // sanity check that it took
+ assert(VAL_TYPE_RAW(END) == REB_0); // this implicit END marker has this
+
+ // The EMPTY_BLOCK provides EMPTY_ARRAY. It is locked for protection.
+ //
+ Init_Block(ROOT_EMPTY_BLOCK, Make_Array(0));
+ Deep_Freeze_Array(VAL_ARRAY(ROOT_EMPTY_BLOCK));
+
+ REBSER *empty_series = Make_Binary(1);
+ *BIN_AT(empty_series, 0) = '\0';
+ Init_String(ROOT_EMPTY_STRING, empty_series);
+ Freeze_Sequence(VAL_SERIES(ROOT_EMPTY_STRING));
+
+ Init_Char(ROOT_SPACE_CHAR, ' ');
+ Init_Char(ROOT_NEWLINE_CHAR, '\n');
+
+ // BUF_UTF8 not initialized, can't init function tags yet
+ //(at least not how Init_Function_Tags() is written)
+ //
+ SET_UNREADABLE_BLANK(ROOT_WITH_TAG);
+ SET_UNREADABLE_BLANK(ROOT_ELLIPSIS_TAG);
+ SET_UNREADABLE_BLANK(ROOT_OPT_TAG);
+ SET_UNREADABLE_BLANK(ROOT_END_TAG);
+ SET_UNREADABLE_BLANK(ROOT_LOCAL_TAG);
+ SET_UNREADABLE_BLANK(ROOT_DURABLE_TAG);
+
+ // Evaluator not initialized, can't do system construction yet
+ //
+ SET_UNREADABLE_BLANK(ROOT_SYSTEM);
+
+ // Data stack not initialized, can't do typeset construction yet
+ // (at least not how Startup_Typesets() is written)
+ //
+ SET_UNREADABLE_BLANK(ROOT_TYPESETS);
+
+ // Symbols system not initialized, can't init the function meta shim yet
+ //
+ SET_UNREADABLE_BLANK(ROOT_FUNCTION_META);
+
+ TERM_ARRAY_LEN(root, ROOT_MAX);
+ ASSERT_ARRAY(root);
+ MANAGE_ARRAY(root);
}
-/***********************************************************************
-**
-*/ static void Init_System_Object()
-/*
-** The system object is defined in boot.r.
-**
-***********************************************************************/
-{
- REBSER *frame;
- REBVAL *value;
- REBCNT n;
-
- // Evaluate the system object and create the global SYSTEM word.
- // We do not BIND_ALL here to keep the internal system words out
- // of the global context. See also N_context() which creates the
- // subobjects of the system object.
-
- // Create the system object from the sysobj block:
- value = VAL_BLK(&Boot_Block->sysobj);
- frame = Make_Object(0, value);
-
- // Bind it so CONTEXT native will work and bind its fields:
- Bind_Block(Lib_Context, value, BIND_DEEP);
- Bind_Block(frame, value, BIND_ONLY); // No need to go deeper
-
- // Evaluate the block (will eval FRAMEs within):
- Do_Blk(VAL_SERIES(&Boot_Block->sysobj), 0);
-
- // Create a global value for it:
- value = Append_Frame(Lib_Context, 0, SYM_SYSTEM);
- SET_OBJECT(value, frame);
- SET_OBJECT(ROOT_SYSTEM, frame);
-
- // Create system/datatypes block:
-// value = Get_System(SYS_DATATYPES, 0);
- value = Get_System(SYS_CATALOG, CAT_DATATYPES);
- frame = VAL_SERIES(value);
- Extend_Series(frame, REB_MAX-1);
- for (n = 1; n <= REB_MAX; n++) {
- Append_Val(frame, FRM_VALUES(Lib_Context) + n);
- }
-
- // Create system/catalog/datatypes block:
-// value = Get_System(SYS_CATALOG, CAT_DATATYPES);
-// Set_Block(value, Copy_Blk(VAL_SERIES(&Boot_Block->types)));
-
- // Create system/catalog/actions block:
- value = Get_System(SYS_CATALOG, CAT_ACTIONS);
- Set_Block(value, Collect_Set_Words(VAL_BLK(&Boot_Block->actions)));
-
- // Create system/catalog/actions block:
- value = Get_System(SYS_CATALOG, CAT_NATIVES);
- Set_Block(value, Collect_Set_Words(VAL_BLK(&Boot_Block->natives)));
-
- // Create system/codecs object:
- value = Get_System(SYS_CODECS, 0);
- frame = Make_Frame(10);
- SET_OBJECT(value, frame);
-
- // Set system/words to be the main context:
-// value = Get_System(SYS_WORDS, 0);
-// SET_OBJECT(value, Lib_Context);
-
- Init_UType_Proto();
+//
+// Init_System_Object: C
+//
+// Evaluate the system object and create the global SYSTEM word. We do not
+// BIND_ALL here to keep the internal system words out of the global context.
+// (See also N_context() which creates the subobjects of the system object.)
+//
+static void Init_System_Object(
+ REBARR *boot_sysobj_spec,
+ REBARR *datatypes_catalog,
+ REBARR *natives_catalog,
+ REBARR *actions_catalog,
+ REBCTX *errors_catalog
+) {
+ RELVAL *spec_head = ARR_HEAD(boot_sysobj_spec);
+
+ // Create the system object from the sysobj block (defined in %sysobj.r)
+ //
+ REBCTX *system = Make_Selfish_Context_Detect(
+ REB_OBJECT, // type
+ spec_head, // scan for toplevel set-words
+ NULL // parent
+ );
+
+ Bind_Values_Deep(spec_head, Lib_Context);
+
+ // Bind it so CONTEXT native will work (only used at topmost depth)
+ //
+ Bind_Values_Shallow(spec_head, system);
+
+ // Evaluate the block (will eval CONTEXTs within). Expects void result.
+ //
+ DECLARE_LOCAL (result);
+ if (Do_At_Throws(result, boot_sysobj_spec, 0, SPECIFIED))
+ panic (result);
+ if (!IS_VOID(result))
+ panic (result);
+
+ // Create a global value for it. (This is why we are able to say `system`
+ // and have it bound in lines like `sys: system/contexts/sys`)
+ //
+ Init_Object(
+ Append_Context(Lib_Context, NULL, Canon(SYM_SYSTEM)),
+ system
+ );
+
+ // We also add the system object under the root, to ensure it can't be
+ // garbage collected and be able to access it from the C code. (Someone
+ // could say `system: blank` in the Lib_Context and then it would be a
+ // candidate for garbage collection otherwise!)
+ //
+ Init_Object(ROOT_SYSTEM, system);
+
+ // Init_Function_Meta_Shim() made ROOT_FUNCTION_META as a bootstrap hack
+ // since it needed to make function meta information for natives before
+ // %sysobj.r's code could run using those natives. But make sure what it
+ // made is actually identical to the definition in %sysobj.r.
+ //
+ assert(
+ 0 == CT_Context(
+ Get_System(SYS_STANDARD, STD_FUNCTION_META),
+ ROOT_FUNCTION_META,
+ TRUE
+ )
+ );
+
+ // Create system/catalog/* for datatypes, natives, actions, errors
+ //
+ Init_Block(Get_System(SYS_CATALOG, CAT_DATATYPES), datatypes_catalog);
+ Init_Block(Get_System(SYS_CATALOG, CAT_NATIVES), natives_catalog);
+ Init_Block(Get_System(SYS_CATALOG, CAT_ACTIONS), actions_catalog);
+ Init_Object(Get_System(SYS_CATALOG, CAT_ERRORS), errors_catalog);
+
+ // Create system/codecs object
+ //
+ {
+ REBCTX *codecs = Alloc_Context(REB_OBJECT, 10);
+ VAL_RESET_HEADER(CTX_VALUE(codecs), REB_OBJECT);
+ CTX_VALUE(codecs)->extra.binding = NULL;
+ CTX_VALUE(codecs)->payload.any_context.phase = NULL;
+ Init_Object(Get_System(SYS_CODECS, 0), codecs);
+ }
}
-/***********************************************************************
-**
-*/ static void Init_Contexts_Object()
-/*
-***********************************************************************/
+//
+// Init_Contexts_Object: C
+//
+// This sets up the system/contexts object.
+//
+// !!! One of the critical areas in R3-Alpha that was not hammered out
+// completely was the question of how the binding process gets started, and
+// how contexts might inherit or relate.
+//
+// However, the basic model for bootstrap is that the "user context" is the
+// default area for new code evaluation. It starts out as a copy of an
+// initial state set up in the lib context. When native routines or other
+// content gets overwritten in the user context, it can be borrowed back
+// from `system/contexts/lib` (typically aliased as "lib" in the user context).
+//
+static void Init_Contexts_Object(void)
{
- REBVAL *value;
-// REBSER *frame;
-
- value = Get_System(SYS_CONTEXTS, CTX_SYS);
- SET_OBJECT(value, Sys_Context);
+ DROP_GUARD_CONTEXT(Sys_Context);
+ Init_Object(Get_System(SYS_CONTEXTS, CTX_SYS), Sys_Context);
- value = Get_System(SYS_CONTEXTS, CTX_LIB);
- SET_OBJECT(value, Lib_Context);
-
- value = Get_System(SYS_CONTEXTS, CTX_USER); // default for new code evaluation
- SET_OBJECT(value, Lib_Context);
-
- // Make the boot context - used to store values created
- // during boot, but processed in REBOL code (e.g. codecs)
-// value = Get_System(SYS_CONTEXTS, CTX_BOOT);
-// frame = Make_Frame(4);
-// SET_OBJECT(value, frame);
+ DROP_GUARD_CONTEXT(Lib_Context);
+ Init_Object(Get_System(SYS_CONTEXTS, CTX_LIB), Lib_Context);
+ Init_Object(Get_System(SYS_CONTEXTS, CTX_USER), Lib_Context);
}
-/***********************************************************************
-**
-*/ REBINT Codec_Text(REBCDI *codi)
-/*
-***********************************************************************/
+
+//
+// Startup_Task: C
+//
+// !!! Prior to the release of R3-Alpha, there had apparently been some amount
+// of effort to take single-threaded assumptions and globals, and move to a
+// concept where thread-local storage was used for some previously assumed
+// globals. This would be a prerequisite for concurrency but not enough: the
+// memory pools would need protection from one thread to share any series with
+// others, due to contention between reading and writing.
+//
+// Ren-C kept the separation, but if threading were to be a priority it would
+// likely be approached a different way. A nearer short-term feature would be
+// "isolates", where independent interpreters can be loaded in the same
+// process, just not sharing objects with each other.
+//
+void Startup_Task(void)
{
- codi->error = 0;
+ REBARR *task = Make_Array_Core(
+ TASK_MAX,
+ SERIES_FLAG_FIXED_SIZE | NODE_FLAG_ROOT
+ );
+
+ TG_Task_Array = task;
+ Task_Vars = cast(TASK_VARS*, ARR_HEAD(task));
+
+ Trace_Level = 0;
+ Saved_State = 0;
+
+ Eval_Cycles = 0;
+ Eval_Dose = EVAL_DOSE;
+ Eval_Count = Eval_Dose;
+ Eval_Signals = 0;
+ Eval_Sigmask = ALL_BITS;
+ Eval_Limit = 0;
+
+ Startup_Stacks(STACK_MIN/4);
+
+ // Initialize a few fields:
+ Init_Integer(TASK_BALLAST, MEM_BALLAST);
+ Init_Integer(TASK_MAX_BALLAST, MEM_BALLAST);
+
+ // The thrown arg is not intended to ever be around long enough to be
+ // seen by the GC.
+ //
+ Prep_Global_Cell(&TG_Thrown_Arg);
+ SET_UNREADABLE_BLANK(&TG_Thrown_Arg);
+
+ Startup_Raw_Print();
+ Startup_Scanner();
+ Startup_Mold(MIN_COMMON/4);
+ Startup_Collector();
+
+ // Symbols system not initialized, can't init the errors just yet
+ //
+ SET_UNREADABLE_BLANK(TASK_HALT_ERROR);
+ SET_UNREADABLE_BLANK(TASK_STACK_ERROR);
+
+ TERM_ARRAY_LEN(task, TASK_MAX);
+ ASSERT_ARRAY(task);
+ MANAGE_ARRAY(task);
+}
- if (codi->action == CODI_IDENTIFY) {
- return CODI_CHECK; // error code is inverted result
- }
- if (codi->action == CODI_DECODE) {
- return CODI_TEXT;
- }
+//
+// Startup_Core: C
+//
+// Initialize the interpreter core.
+//
+// !!! This will either succeed or "panic". Panic currently triggers an exit
+// to the OS. The code is not currently written to be able to cleanly shut
+// down from a partial initialization. (It should be.)
+//
+// The phases of initialization are tracked by PG_Boot_Phase. Some system
+// functions are unavailable at certain phases.
+//
+// Though most of the initialization is run as C code, some portions are run
+// in Rebol. For instance, ACTION is a function registered very early on in
+// the boot process, which is run from within a block to register more
+// functions.
+//
+// At the tail of the initialization, `finish-init-core` is run. This Rebol
+// function lives in %sys-start.r. It should be "host agnostic" and not
+// assume things about command-line switches (or even that there is a command
+// line!) Converting the code that made such assumptions ongoing.
+//
+void Startup_Core(void)
+{
- if (codi->action == CODI_ENCODE) {
- return CODI_BINARY;
- }
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// INITIALIZE STACK MARKER METRICS
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ // See C_STACK_OVERFLOWING for remarks on this **non-standard** technique
+ // of stack overflow detection. Note that each thread would have its
+ // own stack address limits, so this has to be updated for threading.
+ //
+ // Note that R3-Alpha tried to use a trick (which it got wrong) to
+ // determine whether the stack grew up or down. This doesn't work, and
+ // the solutions that might actually work are too wacky to justify using:
+ //
+ // http://stackoverflow.com/a/33222085/211160
+ //
+ // So it's better to go with a build configuration #define. Note that
+ // stacks growing up is uncommon (e.g. Debian hppa architecture)
+
+ REBUPT bounds;
+ bounds = cast(REBUPT, OS_CONFIG(1, 0));
+ if (bounds == 0)
+ bounds = cast(REBUPT, STACK_BOUNDS);
+
+#ifdef OS_STACK_GROWS_UP
+ Stack_Limit = cast(REBUPT, &bounds) + bounds;
+#else
+ Stack_Limit = cast(REBUPT, &bounds) - bounds;
+#endif
- codi->error = CODI_ERR_NA;
- return CODI_ERROR;
-}
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// TEST EARLY BOOT PANIC AND FAIL
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ // It should be legal to panic at any time (especially given that the
+ // low bar for behavior is "crash out"). fail() is more complex since it
+ // uses error objects which require the system to be initialized, so it
+ // should fall back to being a panic at early boot phases.
+
+#if defined(TEST_EARLY_BOOT_PANIC)
+ panic ("early panic test");
+#elif defined(TEST_EARLY_BOOT_FAIL)
+ fail (Error_No_Value_Raw(BLANK_VALUE));
+#endif
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// INITIALIZE BASIC DIAGNOSTICS
+//
+//==//////////////////////////////////////////////////////////////////////==//
-/***********************************************************************
-**
-*/ REBINT Codec_Markup(REBCDI *codi)
-/*
-***********************************************************************/
-{
- codi->error = 0;
+#ifndef NDEBUG
+ PG_Always_Malloc = FALSE;
+#endif
- if (codi->action == CODI_IDENTIFY) {
- return CODI_CHECK; // error code is inverted result
- }
+ // Globals
+ PG_Boot_Phase = BOOT_START;
+ PG_Boot_Level = BOOT_LEVEL_FULL;
+ PG_Mem_Usage = 0;
+ PG_Mem_Limit = 0;
+ Reb_Opts = ALLOC(REB_OPTS);
+ CLEAR(Reb_Opts, sizeof(REB_OPTS));
+ Saved_State = NULL;
+
+ Startup_StdIO();
+
+ Assert_Basics();
+ PG_Boot_Time = OS_DELTA_TIME(0, 0);
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// INITIALIZE MEMORY AND ALLOCATORS
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ Startup_Pools(0); // Memory allocator
+ Startup_GC();
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// CREATE GLOBAL OBJECTS
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ Init_Root_Vars(); // Special REBOL values per program
+ Init_Char_Cases();
+ Startup_CRC(); // For word hashing
+ Set_Random(0);
+ Startup_Interning();
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// INITIALIZE (SINGULAR) TASK
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ Startup_Task();
+
+ // !!! REVIEW: Init_Function_Tags() uses BUF_UTF8, not
+ // available untilthis point in time.
+ //
+ Init_Function_Tags();
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// LOAD BOOT BLOCK
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ // The %make-boot.r process takes all the various definitions and
+ // mezzanine code and packs it into one compressed string in
+ // %tmp-boot-block.c which gets embedded into the executable. This
+ // includes the type list, word list, error message templates, system
+ // object, mezzanines, etc.
+
+ REBSER *utf8 = Decompress(
+ Native_Specs, NAT_COMPRESSED_SIZE, NAT_UNCOMPRESSED_SIZE, FALSE, FALSE
+ );
+ if (utf8 == NULL || SER_LEN(utf8) != NAT_UNCOMPRESSED_SIZE)
+ panic ("decompressed native specs size mismatch (try `make clean`)");
+
+ const char *tmp_boot_utf8 = "tmp-boot.r";
+ REBSTR *tmp_boot_filename = Intern_UTF8_Managed(
+ cb_cast(tmp_boot_utf8), strlen(tmp_boot_utf8)
+ );
+ REBARR *boot_array = Scan_UTF8_Managed(
+ BIN_HEAD(utf8), NAT_UNCOMPRESSED_SIZE, tmp_boot_filename
+ );
+ PUSH_GUARD_ARRAY(boot_array); // managed, so must be guarded
+
+ Free_Series(utf8); // don't need decompressed text after it's scanned
+
+ BOOT_BLK *boot = cast(BOOT_BLK*, VAL_ARRAY_HEAD(ARR_HEAD(boot_array)));
+
+ Startup_Symbols(VAL_ARRAY(&boot->words));
+
+ // STR_SYMBOL(), VAL_WORD_SYM() and Canon(SYM_XXX) now available
+
+ PG_Boot_Phase = BOOT_LOADED;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// CREATE BASIC VALUES
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ // Before any code can start running (even simple bootstrap code), some
+ // basic words need to be defined. For instance: You can't run %sysobj.r
+ // unless `true` and `false` have been added to the Lib_Context--they'd be
+ // undefined. And while analyzing the function specs during the
+ // definition of natives, things like the tag are needed as a basis
+ // for comparison to see if a usage matches that.
+
+ // !!! Have MAKE-BOOT compute # of words
+ //
+ Lib_Context = Alloc_Context(REB_OBJECT, 600);
+ MANAGE_ARRAY(CTX_VARLIST(Lib_Context));
+ PUSH_GUARD_CONTEXT(Lib_Context);
+
+ Sys_Context = Alloc_Context(REB_OBJECT, 50);
+ MANAGE_ARRAY(CTX_VARLIST(Sys_Context));
+ PUSH_GUARD_CONTEXT(Sys_Context);
+
+ REBARR *datatypes_catalog = Startup_Datatypes(
+ VAL_ARRAY(&boot->types), VAL_ARRAY(&boot->typespecs)
+ );
+ MANAGE_ARRAY(datatypes_catalog);
+ PUSH_GUARD_ARRAY(datatypes_catalog);
+
+ // !!! REVIEW: Startup_Typesets() uses symbols, data stack, and
+ // adds words to lib--not available untilthis point in time.
+ //
+ Startup_Typesets();
+
+ Startup_True_And_False();
+ Add_Lib_Keys_R3Alpha_Cant_Make();
+
+ Prep_Global_Cell(&Callback_Error);
+ SET_UNREADABLE_BLANK(&Callback_Error);
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// RUN CODE BEFORE ERROR HANDLING INITIALIZED
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ // boot->natives is from the automatically gathered list of natives found
+ // by scanning comments in the C sources for `native: ...` declarations.
+ //
+ REBARR *natives_catalog = Startup_Natives(VAL_ARRAY(&boot->natives));
+ MANAGE_ARRAY(natives_catalog);
+ PUSH_GUARD_ARRAY(natives_catalog);
+
+ // boot->actions is the list in %actions.r
+ //
+ REBARR *actions_catalog = Startup_Actions(VAL_ARRAY(&boot->actions));
+ MANAGE_ARRAY(actions_catalog);
+ PUSH_GUARD_ARRAY(actions_catalog);
+
+ // boot->errors is the error definition list from %errors.r
+ //
+ REBCTX *errors_catalog = Startup_Errors(VAL_ARRAY(&boot->errors));
+ PUSH_GUARD_CONTEXT(errors_catalog);
+
+ Init_System_Object(
+ VAL_ARRAY(&boot->sysobj),
+ datatypes_catalog,
+ natives_catalog,
+ actions_catalog,
+ errors_catalog
+ );
+
+ DROP_GUARD_CONTEXT(errors_catalog);
+ DROP_GUARD_ARRAY(actions_catalog);
+ DROP_GUARD_ARRAY(natives_catalog);
+ DROP_GUARD_ARRAY(datatypes_catalog);
+
+ Init_Contexts_Object();
+
+ PG_Boot_Phase = BOOT_ERRORS;
+
+#if defined(TEST_MID_BOOT_PANIC)
+ //
+ // At this point panics should be able to do a reasonable job of giving
+ // details on Rebol types.
+ //
+ panic (EMPTY_ARRAY);
+#elif defined(TEST_MID_BOOT_FAIL)
+ //
+ // With no PUSH_TRAP yet, fail should give a localized assert in a debug
+ // build, and panic the release build.
+ //
+ fail (Error_No_Value_Raw(BLANK_VALUE));
+#endif
- if (codi->action == CODI_DECODE) {
- codi->other = (void*)Load_Markup(codi->data, codi->len);
- return CODI_BLOCK;
- }
+ // Special pre-made errors:
+ Init_Error(TASK_STACK_ERROR, Error_Stack_Overflow_Raw());
+ Init_Error(TASK_HALT_ERROR, Error_Halt_Raw());
+
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// RUN MEZZANINE CODE NOW THAT ERROR HANDLING IS INITIALIZED
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ PG_Boot_Phase = BOOT_MEZZ;
+
+ assert(DSP == 0 && FS_TOP == NULL);
+
+ REBCTX *error = Startup_Mezzanine(&boot->base, &boot->sys, &boot->mezz);
+ if (error != NULL) {
+ //
+ // There is theoretically some level of error recovery that could
+ // be done here. e.g. the evaluator works, it just doesn't have
+ // many functions you would expect. How bad it is depends on
+ // whether base and sys ran, so perhaps only errors running "mezz"
+ // should be returned.
+ //
+ // For now, assume any failure to declare the functions in those
+ // sections is a critical one. It may be desirable to tell the
+ // caller that the user halted (quitting may not be appropriate if
+ // the app is more than just the interpreter)
+ //
+ // !!! If halt cannot be handled cleanly, it should be set up so
+ // that the user isn't even *able* to request a halt at this boot
+ // phase.
+
+ #ifdef RETURN_ERRORS_FROM_INIT_CORE
+ REBCNT err_num = ERR_NUM(error);
+ Shutdown_Core(); // In good enough state to shutdown cleanly by now
+ return err_num;
+ #endif
+
+ assert(ERR_NUM(error) != RE_HALT);
+
+ panic (error);
+ }
+
+ assert(DSP == 0 && FS_TOP == NULL);
+
+ DROP_GUARD_ARRAY(boot_array);
+
+ PG_Boot_Phase = BOOT_DONE;
+
+#if !defined(NDEBUG)
+ //
+ // This memory check from R3-Alpha is somewhat superfluous, but include a
+ // call to it during Init in the debug build, because otherwise no one
+ // will think to keep it up to date and working.
+ //
+ Check_Memory_Debug();
+
+ // We can only do a check of the pointer detection service after the
+ // system is somewhat initialized.
+ //
+ Assert_Pointer_Detection_Working();
+#endif
- codi->error = CODI_ERR_NA;
- return CODI_ERROR;
+ Recycle(); // necessary?
}
-/***********************************************************************
-**
-*/ void Register_Codec(REBYTE *name, codo dispatcher)
-/*
-** Internal function for adding a codec.
-**
-***********************************************************************/
-{
- REBVAL *value = Get_System(SYS_CODECS, 0);
- REBCNT sym = Make_Word(name, 0);
-
- value = Append_Frame(VAL_OBJ_FRAME(value), 0, sym);
- SET_HANDLE(value, dispatcher);
+//
+// Startup_Mezzanine: C
+//
+// For boring technical reasons, the `boot` variable might be "clobbered"
+// by a longjmp in Startup_Core(). The easiest way to work around this is
+// by taking the code that setjmp/longjmps (e.g. PUSH_TRAP, fail()) and
+// putting it into a separate function.
+//
+// http://stackoverflow.com/a/2105840/211160
+//
+// Returns error from finalizing or NULL.
+//
+REBCTX *Startup_Mezzanine(
+ REBVAL *base_block,
+ REBVAL *sys_block,
+ REBVAL *mezz_block
+) {
+ REBCTX *error;
+ struct Reb_State state;
+
+ // With error trapping enabled, set up to catch them if they happen.
+ PUSH_UNHALTABLE_TRAP(&error, &state);
+
+// The first time through the following code 'error' will be NULL, but...
+// `fail` can longjmp here, so 'error' won't be NULL *if* that happens!
+
+ if (error)
+ return error;
+
+ Startup_Base(VAL_ARRAY(base_block));
+
+ Startup_Sys(VAL_ARRAY(sys_block));
+
+ // The FINISH-INIT-CORE function should likely do very little. But right
+ // now it is where the user context is created from the lib context (a
+ // copy with some omissions), and where the mezzanine definitions are
+ // bound to the lib context and DO'd.
+ //
+ DECLARE_LOCAL (result);
+ if (Apply_Only_Throws(
+ result,
+ TRUE, // generate error if all arguments aren't consumed
+ Sys_Func(SYS_CTX_FINISH_INIT_CORE), // %sys-start.r function to call
+ mezz_block, // boot-mezz argument
+ END
+ )) {
+ return Error_No_Catch_For_Throw(result);
+ }
+
+ if (!IS_VOID(result)) {
+ //
+ // !!! `finish-init-core` Rebol code should return void, but it may be
+ // that more graceful error delivery than a panic should be given if
+ // it does not. It may be that fairly legitimate circumstances which
+ // the user could fix would cause a more ordinary message delivery.
+ // For the moment, though, we panic on any non-void return result.
+ //
+ panic (result);
+ }
+
+ DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
+
+ return NULL;
}
-/***********************************************************************
-**
-*/ static void Init_Codecs()
-/*
-***********************************************************************/
+//
+// Shutdown_Core: C
+//
+// The goal of Shutdown_Core() is to release all memory and resources that the
+// interpreter has accrued since Startup_Core(). This is a good "sanity check"
+// that there aren't unaccounted-for leaks (or semantic errors which such
+// leaks may indicate).
+//
+// Also, being able to clean up is important for a library...which might be
+// initialized and shut down multiple times in the same program run. But
+// clients wishing a speedy exit may force an exit to the OS instead of doing
+// a clean shut down. (Note: There still might be some system resources
+// that need to be waited on, such as asynchronous writes.)
+//
+// While some leaks are detected by the debug build during shutdown, even more
+// can be found with a tool like Valgrind or Address Sanitizer.
+//
+void Shutdown_Core(void)
{
- Register_Codec((REBYTE*)"text", Codec_Text);
- Register_Codec((REBYTE*)"markup", Codec_Markup);
- Init_BMP_Codec();
- Init_GIF_Codec();
- Init_PNG_Codec();
- Init_JPEG_Codec();
-}
+#if !defined(NDEBUG)
+ //
+ // This memory check from R3-Alpha is somewhat superfluous, but include a
+ // call to it during Shutdown in the debug build, because otherwise no one
+ // will think to keep it up to date and working.
+ //
+ Check_Memory_Debug();
+#endif
+ assert(!Saved_State);
-static void Set_Option_String(REBCHR *str, REBCNT field)
-{
- REBVAL *val;
- if (str) {
- val = Get_System(SYS_OPTIONS, field);
- Set_String(val, Copy_OS_Str(str, LEN_STR(str)));
- }
-}
+ Shutdown_Stacks();
-static REBCNT Set_Option_Word(REBCHR *str, REBCNT field)
-{
- REBVAL *val;
- REBYTE *bp;
- REBYTE buf[40]; // option words always short ASCII strings
- REBCNT n = 0;
-
- if (str) {
- n = LEN_STR(str); // WC correct
- if (n > 38) return 0;
- bp = &buf[0];
- while ((*bp++ = (REBYTE)*str++)); // clips unicode
- n = Make_Word(buf, n);
- val = Get_System(SYS_OPTIONS, field);
- Init_Word(val, n);
- }
- return n;
-}
+ // Run Recycle, but the TRUE flag indicates we want every series
+ // that is managed to be freed. (Only unmanaged should be left.)
+ // We remove the only two root contexts that the Startup_Core process added
+ // -however- there may be other roots. But by this point, the roots
+ // created by Alloc_Pairing() with an owning context should be freed.
+ //
+ CLEAR_SER_FLAG(PG_Root_Array, NODE_FLAG_ROOT);
+ CLEAR_SER_FLAG(TG_Task_Array, NODE_FLAG_ROOT);
-/***********************************************************************
-**
-*/ static void Init_Main_Args(REBARGS *rargs)
-/*
-** The system object is defined in boot.r.
-**
-***********************************************************************/
-{
- REBVAL *val;
- REBSER *ser;
- REBCHR *data;
- REBCNT n;
-
-
- ser = Make_Block(3);
- n = 2; // skip first flag (ROF_EXT)
- val = Get_System(SYS_CATALOG, CAT_BOOT_FLAGS);
- for (val = VAL_BLK(val); NOT_END(val); val++) {
- VAL_CLR_LINE(val);
- if (rargs->options & n) Append_Val(ser, val);
- n <<= 1;
- }
- val = Append_Value(ser);
- SET_TRUE(val);
- val = Get_System(SYS_OPTIONS, OPTIONS_FLAGS);
- Set_Block(val, ser);
-
- // For compatibility:
- if (rargs->options & RO_QUIET) {
- val = Get_System(SYS_OPTIONS, OPTIONS_QUIET);
- SET_TRUE(val);
- }
-
- // Print("script: %s", rargs->script);
- if (rargs->script) {
- ser = To_REBOL_Path(rargs->script, 0, OS_WIDE, 0);
- val = Get_System(SYS_OPTIONS, OPTIONS_SCRIPT);
- Set_Series(REB_FILE, val, ser);
- }
-
- if (rargs->exe_path) {
- ser = To_REBOL_Path(rargs->exe_path, 0, OS_WIDE, 0);
- val = Get_System(SYS_OPTIONS, OPTIONS_BOOT);
- Set_Series(REB_FILE, val, ser);
- }
-
- // Print("home: %s", rargs->home_dir);
- if (rargs->home_dir) {
- ser = To_REBOL_Path(rargs->home_dir, 0, OS_WIDE, TRUE);
- val = Get_System(SYS_OPTIONS, OPTIONS_HOME);
- Set_Series(REB_FILE, val, ser);
- }
-
- n = Set_Option_Word(rargs->boot, OPTIONS_BOOT_LEVEL);
- if (n >= SYM_BASE && n <= SYM_MODS)
- PG_Boot_Level = n - SYM_BASE; // 0 - 3
-
- Set_Option_String(rargs->args, OPTIONS_ARGS);
- Set_Option_String(rargs->do_arg, OPTIONS_DO_ARG);
- Set_Option_String(rargs->debug, OPTIONS_DEBUG);
- Set_Option_String(rargs->version, OPTIONS_VERSION);
- Set_Option_String(rargs->import, OPTIONS_IMPORT);
-
- Set_Option_Word(rargs->secure, OPTIONS_SECURE);
-
- if (NZ(data = OS_GET_LOCALE(0))) {
- val = Get_System(SYS_LOCALE, LOCALE_LANGUAGE);
- Set_String(val, Copy_OS_Str(data, LEN_STR(data)));
- }
-
- if (NZ(data = OS_GET_LOCALE(1))) {
- val = Get_System(SYS_LOCALE, LOCALE_LANGUAGE_P);
- Set_String(val, Copy_OS_Str(data, LEN_STR(data)));
- }
-
- if (NZ(data = OS_GET_LOCALE(2))) {
- val = Get_System(SYS_LOCALE, LOCALE_LOCALE);
- Set_String(val, Copy_OS_Str(data, LEN_STR(data)));
- }
-
- if (NZ(data = OS_GET_LOCALE(3))) {
- val = Get_System(SYS_LOCALE, LOCALE_LOCALE_P);
- Set_String(val, Copy_OS_Str(data, LEN_STR(data)));
- }
-}
+ Recycle_Core(TRUE, NULL);
+ Shutdown_Event_Scheme();
+ Shutdown_CRC();
+ Shutdown_Mold();
+ Shutdown_Scanner();
+ Shutdown_Char_Cases();
-/***********************************************************************
-**
-*/ void Init_Task(void)
-/*
-***********************************************************************/
-{
- // Thread locals:
- Trace_Level = 0;
- Saved_State = 0;
-
- Eval_Cycles = 0;
- Eval_Dose = EVAL_DOSE;
- Eval_Signals = 0;
- Eval_Sigmask = ALL_BITS;
-
- // errors? problem with PG_Boot_Phase shared?
-
- Init_Memory(-4);
- Init_Task_Context(); // Special REBOL values per task
-
- Init_Raw_Print();
- Init_Words(TRUE);
- Init_Data_Stack(STACK_MIN/4);
- Init_Scanner();
- Init_Mold(MIN_COMMON/4);
- Init_Frame();
- //Inspect_Series(0);
-}
+ Shutdown_Symbols();
+ Shutdown_Interning();
+ Shutdown_GC();
-/***********************************************************************
-**
-*/ void Init_Year(void)
-/*
-***********************************************************************/
-{
- REBOL_DAT dat;
+ // !!! Need to review the relationship between Open_StdIO (which the host
+ // does) and Startup_StdIO...they both open, and both close.
- OS_GET_TIME(&dat);
- Current_Year = dat.year;
-}
+ Shutdown_StdIO();
+ FREE(REB_OPTS, Reb_Opts);
-/***********************************************************************
-**
-*/ void Init_Core(REBARGS *rargs)
-/*
-** GC is disabled during all init code, so these functions
-** need not protect themselves.
-**
-***********************************************************************/
-{
- REBSER *ser;
- DOUT("Main init");
-
- // Globals
- PG_Boot_Phase = BOOT_START;
- PG_Boot_Level = BOOT_LEVEL_FULL;
- PG_Mem_Usage = 0;
- PG_Mem_Limit = 0;
- PG_Reb_Stats = Make_Mem(sizeof(*PG_Reb_Stats));
- Reb_Opts = Make_Mem(sizeof(*Reb_Opts));
-
- // Thread locals:
- Trace_Level = 0;
- Saved_State = 0;
- Eval_Dose = EVAL_DOSE;
- Eval_Limit = 0;
- Eval_Signals = 0;
- Eval_Sigmask = ALL_BITS; /// dups Init_Task
-
- Init_StdIO();
-
- Assert_Basics();
- PG_Boot_Time = OS_DELTA_TIME(0, 0);
-
- DOUT("Level 0");
- Init_Memory(0); // Memory allocator
- Init_Root_Context(); // Special REBOL values per program
- Init_Task_Context(); // Special REBOL values per task
-
- Init_Raw_Print(); // Low level output (Print)
-
- Print_Banner(rargs);
-
- DOUT("Level 1");
- Init_Char_Cases();
- Init_CRC(); // For word hashing
- Set_Random(0);
- Init_Words(FALSE); // Symbol table
- Init_Data_Stack(STACK_MIN*4);
- Init_Scanner();
- Init_Mold(MIN_COMMON); // Output buffer
- Init_Frame(); // Frames
-
- Lib_Context = Make_Frame(600); // !! Have MAKE-BOOT compute # of words
- Sys_Context = Make_Frame(50);
-
- DOUT("Level 2");
- Load_Boot(); // Protected strings now available
- PG_Boot_Phase = BOOT_LOADED;
- //Debug_Str(BOOT_STR(RS_INFO,0)); // Booting...
-
- // Get the words of the ROOT context (to avoid it being an exception case):
- PG_Root_Words = Collect_Frame(BIND_ALL, 0, VAL_BLK(&Boot_Block->root));
- VAL_FRM_WORDS(ROOT_SELF) = PG_Root_Words;
-
- // Create main values:
- DOUT("Level 3");
- Init_Datatypes(); // Create REBOL datatypes
- Init_Typesets(); // Create standard typesets
- Init_Datatype_Checks(); // The TYPE? checks
- Init_Constants(); // Constant values
-
- // Run actual code:
- DOUT("Level 4");
- Init_Natives(); // Built-in native functions
- Init_Ops(); // Built-in operators
- Init_System_Object();
- Init_Contexts_Object();
- Init_Main_Args(rargs);
- Init_Ports();
- Init_Codecs();
- Init_Errors(&Boot_Block->errors); // Needs system/standard/error object
- PG_Boot_Phase = BOOT_ERRORS;
-
- Init_Year();
-
- // Special pre-made error:
- ser = Make_Error(RE_STACK_OVERFLOW, 0, 0, 0);
- SET_ERROR(TASK_STACK_ERROR, RE_STACK_OVERFLOW, ser);
-
- // Initialize mezzanine functions:
- DOUT("Level 5");
- if (PG_Boot_Level >= BOOT_LEVEL_SYS) {
- Do_Global_Block(VAL_SERIES(&Boot_Block->base), 1);
- Do_Global_Block(VAL_SERIES(&Boot_Block->sys), 2);
- }
-
- *FRM_VALUE(Sys_Context, SYS_CTX_BOOT_MEZZ) = Boot_Block->mezz;
- *FRM_VALUE(Sys_Context, SYS_CTX_BOOT_PROT) = Boot_Block->protocols;
-
- // No longer needs protecting:
- SET_NONE(ROOT_BOOT);
- Boot_Block = NULL;
- PG_Boot_Phase = BOOT_MEZZ;
- DS_RESET;
-
- DOUT("Boot done");
+ // Shutting down the memory manager must be done after all the Free_Mem
+ // calls have been made to balance their Alloc_Mem calls.
+ //
+ Shutdown_Pools();
}
diff --git a/src/core/b-main.c b/src/core/b-main.c
deleted file mode 100644
index 5b2ee98bb2..0000000000
--- a/src/core/b-main.c
+++ /dev/null
@@ -1,80 +0,0 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: b-main.c
-** Summary: skip
-** Section: bootstrap
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-#include "sys-core.h"
-
-static REBARGS Main_Args; // Not multi-threaded
-
-/***********************************************************************
-**
-*/ char *Prompt_User()
-/*
-***********************************************************************/
-{
- char *text;
-
- Prin("DSP: %d Mem: %d >> ", DSP, PG_Mem_Usage);
- text = Input_Str();
- if (*text == '\n') exit(0);
- return text;
-}
-
-
-/***********************************************************************
-**
-*/ int main(int argc, char **argv)
-/*
-***********************************************************************/
-{
- char *cmd;
-
- // Parse command line arguments. Done early. May affect REBOL boot.
- Parse_Args(argc, argv, &Main_Args);
-
- Print_Str("REBOL 3.0\n");
-
- REBOL_Init(&Main_Args);
-
- // Evaluate user input:
- while (TRUE) {
- cmd = Prompt_User();
- REBOL_Do_String(cmd);
- if (!IS_UNSET(DS_TOP)) {
- //if (DSP > 0) {
- if (!IS_ERROR(DS_TOP)) {
- Prin("== ");
- Print_Value(DS_TOP, 0, TRUE);
- } else
- Print_Value(DS_TOP, 0, FALSE);
- //}
- }
- //DS_DROP; // result
- }
-
- return 0;
-}
diff --git a/src/core/c-bind.c b/src/core/c-bind.c
new file mode 100644
index 0000000000..460ef7abd3
--- /dev/null
+++ b/src/core/c-bind.c
@@ -0,0 +1,359 @@
+//
+// File: %c-bind.c
+// Summary: "Word Binding Routines"
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Binding relates a word to a context. Every word can be either bound,
+// specifically bound to a particular context, or bound relatively to a
+// function (where additional information is needed in order to find the
+// specific instance of the variable for that word as a key).
+//
+
+#include "sys-core.h"
+
+
+//
+// Bind_Values_Inner_Loop: C
+//
+// Bind_Values_Core() sets up the binding table and then calls
+// this recursive routine to do the actual binding.
+//
+static void Bind_Values_Inner_Loop(
+ struct Reb_Binder *binder,
+ RELVAL head[],
+ REBCTX *context,
+ REBU64 bind_types, // !!! REVIEW: force word types low enough for 32-bit?
+ REBU64 add_midstream_types,
+ REBFLGS flags
+) {
+ RELVAL *value = head;
+ for (; NOT_END(value); value++) {
+ REBU64 type_bit = FLAGIT_KIND(VAL_TYPE(value));
+
+ if (type_bit & bind_types) {
+ REBSTR *canon = VAL_WORD_CANON(value);
+ REBCNT n = Try_Get_Binder_Index(binder, canon);
+ if (n != 0) {
+ assert(n <= CTX_LEN(context));
+
+ // We're overwriting any previous binding, which may have
+ // been relative.
+ //
+ CLEAR_VAL_FLAG(value, VALUE_FLAG_RELATIVE);
+
+ SET_VAL_FLAG(value, WORD_FLAG_BOUND);
+ INIT_WORD_CONTEXT(value, context);
+ INIT_WORD_INDEX(value, n);
+ }
+ else if (type_bit & add_midstream_types) {
+ //
+ // Word is not in context, so add it if option is specified
+ //
+ Expand_Context(context, 1);
+ Append_Context(context, value, 0);
+ Add_Binder_Index(binder, canon, VAL_WORD_INDEX(value));
+ }
+ }
+ else if (ANY_ARRAY(value) && (flags & BIND_DEEP)) {
+ Bind_Values_Inner_Loop(
+ binder,
+ VAL_ARRAY_AT(value),
+ context,
+ bind_types,
+ add_midstream_types,
+ flags
+ );
+ }
+ else if (
+ IS_FUNCTION(value)
+ && IS_FUNCTION_INTERPRETED(value)
+ && (flags & BIND_FUNC)
+ ) {
+ // !!! Likely-to-be deprecated functionality--rebinding inside the
+ // content of an already formed function. :-/
+ //
+ Bind_Values_Inner_Loop(
+ binder,
+ VAL_FUNC_BODY(value),
+ context,
+ bind_types,
+ add_midstream_types,
+ flags
+ );
+ }
+ }
+}
+
+
+//
+// Bind_Values_Core: C
+//
+// Bind words in an array of values terminated with END
+// to a specified context. See warnings on the functions like
+// Bind_Values_Deep() about not passing just a singular REBVAL.
+//
+// NOTE: If types are added, then they will be added in "midstream". Only
+// bindings that come after the added value is seen will be bound.
+//
+void Bind_Values_Core(
+ RELVAL head[],
+ REBCTX *context,
+ REBU64 bind_types,
+ REBU64 add_midstream_types,
+ REBFLGS flags // see %sys-core.h for BIND_DEEP, etc.
+) {
+ struct Reb_Binder binder;
+ INIT_BINDER(&binder);
+
+ // Via the global hash table, each spelling of the word can find the
+ // canon form of the word. Associate that with an index number to signal
+ // a binding should be created to this context (at that index.)
+
+ REBCNT index = 1;
+ REBVAL *key = CTX_KEYS_HEAD(context);
+ for (; index <= CTX_LEN(context); key++, index++)
+ if (NOT_VAL_FLAG(key, TYPESET_FLAG_UNBINDABLE))
+ Add_Binder_Index(&binder, VAL_KEY_CANON(key), index);
+
+ Bind_Values_Inner_Loop(
+ &binder, head, context, bind_types, add_midstream_types, flags
+ );
+
+ // Reset all the binder indices to zero, balancing out what was added.
+
+ key = CTX_KEYS_HEAD(context);
+ for (; NOT_END(key); key++)
+ Remove_Binder_Index(&binder, VAL_KEY_CANON(key));
+
+ SHUTDOWN_BINDER(&binder);
+}
+
+
+//
+// Unbind_Values_Core: C
+//
+// Unbind words in a block, optionally unbinding those which are
+// bound to a particular target (if target is NULL, then all
+// words will be unbound regardless of their VAL_WORD_CONTEXT).
+//
+void Unbind_Values_Core(RELVAL head[], REBCTX *context, REBOOL deep)
+{
+ RELVAL *value = head;
+ for (; NOT_END(value); value++) {
+ if (
+ ANY_WORD(value)
+ && (
+ !context
+ || (
+ IS_WORD_BOUND(value)
+ && !IS_RELATIVE(value)
+ && VAL_WORD_CONTEXT(KNOWN(value)) == context
+ )
+ )
+ ) {
+ Unbind_Any_Word(value);
+ }
+ else if (ANY_ARRAY(value) && deep)
+ Unbind_Values_Core(VAL_ARRAY_AT(value), context, TRUE);
+ }
+}
+
+
+//
+// Try_Bind_Word: C
+//
+// Binds a word to a context. If word is not part of the context.
+//
+REBCNT Try_Bind_Word(REBCTX *context, REBVAL *word)
+{
+ REBCNT n = Find_Canon_In_Context(context, VAL_WORD_CANON(word), FALSE);
+ if (n != 0) {
+ //
+ // Previously may have been bound relative, remove flag.
+ //
+ CLEAR_VAL_FLAG(word, VALUE_FLAG_RELATIVE);
+
+ SET_VAL_FLAG(word, WORD_FLAG_BOUND);
+ INIT_WORD_CONTEXT(word, context);
+ INIT_WORD_INDEX(word, n);
+ }
+ return n;
+}
+
+
+//
+// Bind_Relative_Inner_Loop: C
+//
+// Recursive function for relative function word binding. Returns TRUE if
+// any relative bindings were made.
+//
+static void Bind_Relative_Inner_Loop(
+ struct Reb_Binder *binder,
+ RELVAL head[],
+ REBARR *paramlist,
+ REBU64 bind_types
+) {
+ RELVAL *value = head;
+
+ for (; NOT_END(value); value++) {
+ REBU64 type_bit = FLAGIT_KIND(VAL_TYPE(value));
+
+ // The two-pass copy-and-then-bind should have gotten rid of all the
+ // relative values to other functions during the copy.
+ //
+ // !!! Long term, in a single pass copy, this would have to deal
+ // with relative values and run them through the specification
+ // process if they were not just getting overwritten.
+ //
+ assert(!IS_RELATIVE(value));
+
+ if (type_bit & bind_types) {
+ REBINT n = Try_Get_Binder_Index(binder, VAL_WORD_CANON(value));
+ if (n != 0) {
+ //
+ // Word's canon symbol is in frame. Relatively bind it.
+ // (clear out existing binding flags first).
+ //
+ Unbind_Any_Word(value);
+ SET_VAL_FLAGS(value, WORD_FLAG_BOUND | VALUE_FLAG_RELATIVE);
+ INIT_WORD_FUNC(value, AS_FUNC(paramlist)); // incomplete func
+ INIT_WORD_INDEX(value, n);
+ }
+ }
+ else if (ANY_ARRAY(value)) {
+ Bind_Relative_Inner_Loop(
+ binder, VAL_ARRAY_AT(value), paramlist, bind_types
+ );
+
+ // Set the bits in the ANY-ARRAY! REBVAL to indicate that it is
+ // relative to the function.
+ //
+ // !!! Technically speaking it is not necessary for an array to
+ // be marked relative if it doesn't contain any relative words
+ // under it. However, for uniformity in the near term, it's
+ // easiest to debug if there is a clear mark on arrays that are
+ // part of a deep copy of a function body either way.
+ //
+ SET_VAL_FLAG(value, VALUE_FLAG_RELATIVE);
+ INIT_RELATIVE(value, AS_FUNC(paramlist)); // incomplete func
+ }
+ }
+}
+
+
+//
+// Copy_And_Bind_Relative_Deep_Managed: C
+//
+// This routine is called by Make_Function in order to take the raw material
+// given as a function body, and de-relativize any IS_RELATIVE(value)s that
+// happen to be in it already (as any Copy does). But it also needs to make
+// new relative references to ANY-WORD! that are referencing function
+// parameters, as well as to relativize the copies of ANY-ARRAY! that contain
+// these relative words...so that they refer to the archetypal function
+// to which they should be relative.
+//
+REBARR *Copy_And_Bind_Relative_Deep_Managed(
+ const REBVAL *body,
+ REBARR *paramlist, // body of function is not actually ready yet
+ REBU64 bind_types
+) {
+ // !!! Currently this is done in two phases, because the historical code
+ // would use the generic copying code and then do a bind phase afterward.
+ // Both phases are folded into this routine to make it easier to make
+ // a one-pass version when time permits.
+ //
+ REBARR *copy = COPY_ANY_ARRAY_AT_DEEP_MANAGED(body);
+
+ struct Reb_Binder binder;
+ INIT_BINDER(&binder);
+
+ // Setup binding table from the argument word list
+ //
+ REBCNT index = 1;
+ RELVAL *param = ARR_AT(paramlist, 1); // [0] is FUNCTION! value
+ for (; NOT_END(param); param++, index++)
+ Add_Binder_Index(&binder, VAL_KEY_CANON(param), index);
+
+ Bind_Relative_Inner_Loop(&binder, ARR_HEAD(copy), paramlist, bind_types);
+
+ // Reset binding table
+ //
+ param = ARR_AT(paramlist, 1); // [0] is FUNCTION! value
+ for (; NOT_END(param); param++)
+ Remove_Binder_Index(&binder, VAL_KEY_CANON(param));
+
+ SHUTDOWN_BINDER(&binder);
+ return copy;
+}
+
+
+//
+// Rebind_Values_Deep: C
+//
+// Rebind all words that reference src target to dst target.
+// Rebind is always deep.
+//
+void Rebind_Values_Deep(
+ REBCTX *src,
+ REBCTX *dst,
+ RELVAL head[],
+ struct Reb_Binder *opt_binder
+) {
+ RELVAL *value = head;
+ for (; NOT_END(value); value++) {
+ if (ANY_ARRAY(value)) {
+ Rebind_Values_Deep(src, dst, VAL_ARRAY_AT(value), opt_binder);
+ }
+ else if (
+ ANY_WORD(value)
+ && GET_VAL_FLAG(value, WORD_FLAG_BOUND)
+ && NOT_VAL_FLAG(value, VALUE_FLAG_RELATIVE)
+ && VAL_WORD_CONTEXT(KNOWN(value)) == src
+ ) {
+ INIT_WORD_CONTEXT(value, dst);
+
+ if (opt_binder != NULL) {
+ INIT_WORD_INDEX(
+ value,
+ Try_Get_Binder_Index(opt_binder, VAL_WORD_CANON(value))
+ );
+ }
+ }
+ else if (IS_FUNCTION(value) && IS_FUNCTION_INTERPRETED(value)) {
+ //
+ // !!! Extremely questionable feature--walking into function
+ // bodies and changing them. This R3-Alpha concept was largely
+ // broken (didn't work for closures) and created a lot of extra
+ // garbage (inheriting an object's methods meant making deep
+ // copies of all that object's method bodies...each time).
+ // Ren-C has a different idea in the works.
+ //
+ Rebind_Values_Deep(
+ src, dst, VAL_FUNC_BODY(value), opt_binder
+ );
+ }
+ }
+}
diff --git a/src/core/c-context.c b/src/core/c-context.c
new file mode 100755
index 0000000000..b88d5c9a54
--- /dev/null
+++ b/src/core/c-context.c
@@ -0,0 +1,1451 @@
+//
+// File: %c-context.c
+// Summary: "Management routines for ANY-CONTEXT! key/value storage"
+// Section: core
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Contexts are two arrays of equal length, which are linked together to
+// describe "object-like" things (lists of TYPESET! keys and corresponding
+// variable values). They are used by OBJECT!, PORT!, FRAME!, etc.
+//
+// The REBCTX* is how contexts are passed around as a single pointer. This
+// pointer is actually just an array REBSER which represents the variable
+// values. The keylist can be reached through the ->link field of that
+// REBSER, and the [0] value of the variable array is a "canon instance" of
+// whatever kind of REBVAL the context represents.
+//
+//
+// VARLIST ARRAY: ---Link-> KEYLIST ARRAY:
+// +----------------------------+ +----------------------------+
+// + "ROOTVAR" | | "ROOTKEY" |
+// | Canon ANY-CONTEXT! Value | | Canon FUNCTION!, or blank |
+// +----------------------------+ +----------------------------+
+// | Value 1 | | Typeset w/symbol 1 |
+// +----------------------------+ +----------------------------+
+// | Value 2 | | Typeset w/symbol 2 |
+// +----------------------------+ +----------------------------+
+// | Value ... | | Typeset w/symbol 3 ... |
+// +----------------------------+ +----------------------------+
+//
+// While R3-Alpha used a special kind of WORD! known as an "unword" for the
+// keys, Ren-C uses a special kind of TYPESET! which can also hold a symbol.
+// The reason is that keylists are common to function paramlists and objects,
+// and typesets are more complex than words (and destined to become even
+// moreso with user defined types). So it's better to take the small detail
+// of storing a symbol in a typeset rather than try and enhance words to have
+// typeset features.
+//
+// Keylists can be shared between objects, and if the context represents a
+// call FRAME! then the keylist is actually the paramlist of that function
+// being called. If the keylist is not for a function, then the [0] cell
+// (a.k.a. "ROOTKEY") is currently not used--and set to a BLANK!.
+//
+
+#include "sys-core.h"
+
+
+//
+// Alloc_Context: C
+//
+// Create context of a given size, allocating space for both words and values.
+//
+// This context will not have its ANY-OBJECT! REBVAL in the [0] position fully
+// configured, hence this is an "Alloc" instead of a "Make" (because there
+// is still work to be done before it will pass ASSERT_CONTEXT).
+//
+REBCTX *Alloc_Context(enum Reb_Kind kind, REBCNT capacity)
+{
+ REBARR *varlist = Make_Array_Core(
+ capacity + 1, // size + room for ROOTVAR
+ ARRAY_FLAG_VARLIST
+ );
+
+ // varlist[0] is a value instance of the OBJECT!/MODULE!/PORT!/ERROR! we
+ // are building which contains this context.
+
+ REBVAL *rootvar = Alloc_Tail_Array(varlist);
+ VAL_RESET_HEADER(rootvar, kind);
+ rootvar->payload.any_context.varlist = varlist;
+ rootvar->payload.any_context.phase = NULL;
+ rootvar->extra.binding = NULL;
+
+ // keylist[0] is the "rootkey" which we currently initialize to BLANK
+
+ REBARR *keylist = Make_Array_Core(
+ capacity + 1, // size + room for ROOTKEY
+ 0 // No keylist flag, but we don't want line numbers
+ );
+ Init_Blank(Alloc_Tail_Array(keylist));
+ SER(keylist)->link.meta = NULL; // GC sees meta object, must init
+
+ // varlists link keylists via REBSER.misc field, sharable hence managed
+
+ INIT_CTX_KEYLIST_UNIQUE(CTX(varlist), keylist);
+ MANAGE_ARRAY(keylist);
+
+ return CTX(varlist); // varlist pointer is context handle
+}
+
+
+//
+// Expand_Context_Keylist_Core: C
+//
+// Returns whether or not the expansion invalidated existing keys.
+//
+REBOOL Expand_Context_Keylist_Core(REBCTX *context, REBCNT delta)
+{
+ REBARR *keylist = CTX_KEYLIST(context);
+
+ // can't expand or unshare a FRAME!'s list
+ //
+ assert(NOT_SER_FLAG(keylist, ARRAY_FLAG_PARAMLIST));
+
+ if (GET_SER_INFO(keylist, SERIES_INFO_SHARED_KEYLIST)) {
+ //
+ // INIT_CTX_KEYLIST_SHARED was used to set the flag that indicates
+ // this keylist is shared with one or more other contexts. Can't
+ // expand the shared copy without impacting the others, so break away
+ // from the sharing group by making a new copy.
+ //
+ // (If all shared copies break away in this fashion, then the last
+ // copy of the dangling keylist will be GC'd.)
+ //
+ // Keylists are only typesets, so no need for a specifier.
+
+ REBCTX *meta = SER(keylist)->link.meta; // preserve meta object
+
+ keylist = Copy_Array_Extra_Shallow(keylist, SPECIFIED, delta);
+
+ SER(keylist)->link.meta = meta;
+
+ MANAGE_ARRAY(keylist);
+ INIT_CTX_KEYLIST_UNIQUE(context, keylist);
+
+ return TRUE;
+ }
+
+ if (delta == 0) return FALSE;
+
+ // INIT_CTX_KEYLIST_UNIQUE was used to set this keylist in the
+ // context, and no INIT_CTX_KEYLIST_SHARED was used by another context
+ // to mark the flag indicating it's shared. Extend it directly.
+
+ Extend_Series(SER(keylist), delta);
+ TERM_ARRAY_LEN(keylist, ARR_LEN(keylist));
+
+ return FALSE;
+}
+
+
+//
+// Expand_Context: C
+//
+// Expand a context. Copy words if keylist is not unique.
+//
+void Expand_Context(REBCTX *context, REBCNT delta)
+{
+ // varlist is unique to each object--expand without making a copy.
+ //
+ Extend_Series(SER(CTX_VARLIST(context)), delta);
+ TERM_ARRAY_LEN(CTX_VARLIST(context), ARR_LEN(CTX_VARLIST(context)));
+
+ Expand_Context_Keylist_Core(context, delta);
+}
+
+
+//
+// Append_Context: C
+//
+// Append a word to the context word list. Expands the list if necessary.
+// Returns the value cell for the word. The new variable is unset by default.
+//
+// !!! Review if it would make more sense to use TRASH.
+//
+// If word is not NULL, use the word sym and bind the word value, otherwise
+// use sym. When using a word, it will be modified to be specifically bound
+// to this context after the operation.
+//
+// !!! Should there be a clearer hint in the interface, with a REBVAL* out,
+// to give a fully bound value as a result? Given that the caller passed
+// in the context and can get the index out of a relatively bound word,
+// they usually likely don't need the result directly.
+//
+REBVAL *Append_Context(
+ REBCTX *context,
+ RELVAL *opt_any_word,
+ REBSTR *opt_name
+) {
+ REBARR *keylist = CTX_KEYLIST(context);
+
+ // Add the key to key list
+ //
+ EXPAND_SERIES_TAIL(SER(keylist), 1);
+ REBVAL *key = SINK(ARR_LAST(keylist));
+ Init_Typeset(
+ key,
+ ALL_64,
+ opt_any_word != NULL ? VAL_WORD_SPELLING(opt_any_word) : opt_name
+ );
+ TERM_ARRAY_LEN(keylist, ARR_LEN(keylist));
+
+ // Add an unset value to var list
+ //
+ EXPAND_SERIES_TAIL(SER(CTX_VARLIST(context)), 1);
+ REBVAL *value = SINK(ARR_LAST(CTX_VARLIST(context)));
+ Init_Void(value);
+ TERM_ARRAY_LEN(CTX_VARLIST(context), ARR_LEN(CTX_VARLIST(context)));
+
+ if (opt_any_word) {
+ REBCNT len = CTX_LEN(context);
+
+ // We want to not just add a key/value pairing to the context, but we
+ // want to bind a word while we are at it. Make sure symbol is valid.
+ //
+ assert(opt_name == NULL);
+
+ // When a binding is made to an ordinary context, the value list is
+ // used as the target and the index is a positive number. Note that
+ // for stack-relative bindings, the index will be negative and the
+ // target will be a function's PARAMLIST series.
+ //
+ assert(NOT_VAL_FLAG(opt_any_word, VALUE_FLAG_RELATIVE));
+ SET_VAL_FLAG(opt_any_word, WORD_FLAG_BOUND);
+ INIT_WORD_CONTEXT(opt_any_word, context);
+ INIT_WORD_INDEX(opt_any_word, len); // length we just bumped
+ }
+ else
+ assert(opt_name != NULL);
+
+ // The variable value location for the key we just added. It's currently
+ // unset (maybe trash someday?) but in either case, known to not be
+ // a relative any-word or any-array
+ //
+ return value;
+}
+
+
+//
+// Copy_Context_Shallow_Extra: C
+//
+// Makes a copy of a context. If no extra storage space is requested, then
+// the same keylist will be used.
+//
+REBCTX *Copy_Context_Shallow_Extra(REBCTX *src, REBCNT extra) {
+ assert(GET_SER_FLAG(CTX_VARLIST(src), ARRAY_FLAG_VARLIST));
+ ASSERT_ARRAY_MANAGED(CTX_KEYLIST(src));
+
+ REBCTX *meta = CTX_META(src); // preserve meta object (if any)
+
+ // Note that keylists contain only typesets (hence no relative values),
+ // and no varlist is part of a function body. All the values here should
+ // be fully specified.
+ //
+ REBCTX *dest;
+ if (extra == 0) {
+ REBARR *varlist = Copy_Array_Shallow(CTX_VARLIST(src), SPECIFIED);
+ SET_SER_FLAG(varlist, ARRAY_FLAG_VARLIST);
+
+ dest = CTX(varlist);
+ INIT_CTX_KEYLIST_SHARED(dest, CTX_KEYLIST(src));
+ }
+ else {
+ REBARR *keylist = Copy_Array_Extra_Shallow(
+ CTX_KEYLIST(src), SPECIFIED, extra
+ );
+ REBARR *varlist = Copy_Array_Extra_Shallow(
+ CTX_VARLIST(src), SPECIFIED, extra
+ );
+ SET_SER_FLAG(varlist, ARRAY_FLAG_VARLIST);
+
+ dest = CTX(varlist);
+ INIT_CTX_KEYLIST_UNIQUE(dest, keylist);
+ MANAGE_ARRAY(CTX_KEYLIST(dest));
+ }
+
+ CTX_VALUE(dest)->payload.any_context.varlist = CTX_VARLIST(dest);
+
+ INIT_CONTEXT_META(dest, meta); // will be placed on new keylist
+
+ return dest;
+}
+
+
+//
+// Collect_Keys_Start: C
+//
+// Use the Bind_Table to start collecting new keys for a context.
+// Use Collect_Keys_End() when done.
+//
+// WARNING: This routine uses the shared BUF_COLLECT rather than
+// targeting a new series directly. This way a context can be
+// allocated at exactly the right length when contents are copied.
+// Therefore do not call code that might call BIND or otherwise
+// make use of the Bind_Table or BUF_COLLECT.
+//
+void Collect_Keys_Start(REBFLGS flags)
+{
+ assert(ARR_LEN(BUF_COLLECT) == 0); // should be empty
+ if (flags & COLLECT_ANY_WORD) {
+ NOOP; // flags not paid attention to for now
+ }
+
+ // Leave the [0] slot blank while collecting. This will become the
+ // "rootparam" in function paramlists (where the FUNCTION! archetype
+ // value goes), the [0] slot in varlists (where the ANY-CONTEXT! archetype
+ // goes), and the [0] slot in keylists (which sometimes are FUNCTION! if
+ // it's a FRAME! context...and not yet used in other context types)
+ //
+ // The reason it is set to an unreadable blank is because if it were trash
+ // then the copy routine that grabs the varlist as a copy of this array would
+ // have to support copying trash--which they do not allow.
+ //
+ SET_UNREADABLE_BLANK(ARR_HEAD(BUF_COLLECT));
+ SET_ARRAY_LEN_NOTERM(BUF_COLLECT, 1);
+}
+
+
+//
+// Grab_Collected_Keylist_Managed: C
+//
+// The BUF_COLLECT is used to gather keys, which may wind up not requiring any
+// new keys from the `prior` that was passed in. If this is the case, then
+// that prior keylist is returned...otherwise a new one is created.
+//
+// !!! "Grab" is used because "Copy_Or_Reuse" is long, and is picked to draw
+// attention to look at the meaning. Better short communicative name?
+//
+REBARR *Grab_Collected_Keylist_Managed(REBCTX *prior)
+{
+ REBARR *keylist;
+
+ // We didn't terminate as we were collecting, so terminate now.
+ //
+ assert(ARR_LEN(BUF_COLLECT) >= 1); // always at least [0] for rootkey
+ TERM_ARRAY_LEN(BUF_COLLECT, ARR_LEN(BUF_COLLECT));
+
+#if !defined(NDEBUG)
+ //
+ // When the key collecting is done, we may be asked to give back a keylist
+ // and when we do, if nothing was added beyond the `prior` then that will
+ // be handed back. The array handed back will always be managed, so if
+ // we create it then it will be, and if we reuse the prior it will be.
+ //
+ if (prior) ASSERT_ARRAY_MANAGED(CTX_KEYLIST(prior));
+#endif
+
+ // If no new words, prior context. Note length must include the slot
+ // for the rootkey...and note also this means the rootkey cell *may*
+ // be shared between all keylists when you pass in a prior.
+ //
+ if (prior && ARR_LEN(BUF_COLLECT) == CTX_LEN(prior) + 1) {
+ keylist = CTX_KEYLIST(prior);
+ }
+ else {
+ // The BUF_COLLECT should contain only typesets, so no relative values
+ //
+ keylist = Copy_Array_Shallow(BUF_COLLECT, SPECIFIED);
+ MANAGE_ARRAY(keylist);
+ }
+
+ SER(keylist)->link.meta = NULL; // clear meta object (GC sees this)
+
+ return keylist;
+}
+
+
+//
+// Collect_Keys_End: C
+//
+// Free the Bind_Table for reuse and empty the BUF_COLLECT.
+//
+void Collect_Keys_End(struct Reb_Binder *binder)
+{
+ // We didn't terminate as we were collecting, so terminate now.
+ //
+ assert(ARR_LEN(BUF_COLLECT) >= 1); // always at least [0] for rootkey
+ TERM_ARRAY_LEN(BUF_COLLECT, ARR_LEN(BUF_COLLECT));
+
+ // Reset binding table (note BUF_COLLECT may have expanded)
+ //
+ RELVAL *key;
+ for (key = ARR_HEAD(BUF_COLLECT) + 1; NOT_END(key); key++) {
+ REBSTR *canon = VAL_KEY_CANON(key);
+
+ if (binder != NULL) {
+ Remove_Binder_Index(binder, canon);
+ continue;
+ }
+
+ // !!! This doesn't have a "binder" available to clear out the
+ // keys with. The nature of handling error states means that if
+ // a thread-safe binding system was implemented, we'd have to know
+ // which thread had the error to roll back any binding structures.
+ // For now just zero it out based on the collect buffer.
+ //
+ assert(
+ canon->misc.bind_index.high != 0
+ || canon->misc.bind_index.low != 0
+ );
+ canon->misc.bind_index.high = 0;
+ canon->misc.bind_index.low = 0;
+ }
+
+ SET_ARRAY_LEN_NOTERM(BUF_COLLECT, 0);
+}
+
+
+//
+// Collect_Context_Keys: C
+//
+// Collect words from a prior context. If `check_dups` is passed in then
+// there is a check for duplicates, otherwise the keys are assumed to
+// be unique and copied in using `memcpy` as an optimization.
+//
+void Collect_Context_Keys(
+ struct Reb_Binder *binder,
+ REBCTX *context,
+ REBOOL check_dups
+) {
+ REBVAL *key = CTX_KEYS_HEAD(context);
+ REBINT bind_index = ARR_LEN(BUF_COLLECT);
+ RELVAL *collect; // can't set until after potential expansion...
+
+ // The BUF_COLLECT buffer should at least have the SYM_0 in its first slot
+ // to use as a "rootkey" in the generated keylist (and also that the first
+ // binding index we give out is at least 1, since 0 is used in the
+ // Bind_Table to mean "word not collected yet").
+ //
+ assert(bind_index >= 1);
+
+ // this is necessary for memcpy below to not overwrite memory BUF_COLLECT
+ // does not own. (It may make the buffer capacity bigger than necessary
+ // if duplicates are found, but the actual buffer length will be set
+ // correctly by the end.)
+ //
+ EXPAND_SERIES_TAIL(SER(BUF_COLLECT), CTX_LEN(context));
+
+ // EXPAND_SERIES_TAIL will increase the ARR_LEN, even though we intend
+ // to overwrite it with a possibly shorter length. Put the length back
+ // and now that the expansion is done, get the pointer to where we want
+ // to start collecting new typesets.
+ //
+ SET_ARRAY_LEN_NOTERM(BUF_COLLECT, bind_index);
+ collect = ARR_TAIL(BUF_COLLECT);
+
+ if (check_dups) {
+ // We're adding onto the end of the collect buffer and need to
+ // check for duplicates of what's already there.
+ //
+ for (; NOT_END(key); key++) {
+ REBSTR *canon = VAL_KEY_CANON(key);
+ if (NOT(Try_Add_Binder_Index(binder, canon, bind_index))) {
+ //
+ // If we found the typeset's symbol in the bind table already
+ // then don't collect it in the buffer again.
+ //
+ continue;
+ }
+
+ ++bind_index;
+
+ // !!! At the moment objects do not heed the typesets in the
+ // keys. If they did, what sort of rule should the typesets
+ // have when being inherited?
+ //
+ *collect = *key;
+ ++collect;
+ }
+
+ // Increase the length of BUF_COLLLECT by how far `collect` advanced
+ // (would be 0 if all the keys were duplicates...)
+ //
+ SET_ARRAY_LEN_NOTERM(
+ BUF_COLLECT,
+ ARR_LEN(BUF_COLLECT) + (collect - ARR_TAIL(BUF_COLLECT))
+ );
+ }
+ else {
+ // Optimized copy of the keys. We can use `memcpy` because these are
+ // typesets that are just 64-bit bitsets plus a symbol ID; there is
+ // no need to clone the REBVALs to give the copies new identity.
+ //
+ // Add the keys and bump the length of the collect buffer after
+ // (prior to that, the tail should be on the END marker of
+ // the existing content--if any)
+ //
+ memcpy(collect, key, CTX_LEN(context) * sizeof(REBVAL));
+ SET_ARRAY_LEN_NOTERM(
+ BUF_COLLECT, ARR_LEN(BUF_COLLECT) + CTX_LEN(context)
+ );
+
+ for (; NOT_END(key); ++key, ++bind_index)
+ Add_Binder_Index(binder, VAL_KEY_CANON(key), bind_index);
+ }
+
+ // BUF_COLLECT doesn't get terminated as its being built, but it gets
+ // terminated in Collect_Keys_End()
+}
+
+
+//
+// Collect_Context_Inner_Loop: C
+//
+// The inner recursive loop used for Collect_Context function below.
+//
+static void Collect_Context_Inner_Loop(
+ struct Reb_Binder *binder,
+ const RELVAL head[],
+ REBFLGS flags
+) {
+ const RELVAL *value = head;
+ for (; NOT_END(value); value++) {
+ if (ANY_WORD(value)) {
+ REBSTR *canon = VAL_WORD_CANON(value);
+ if (Try_Get_Binder_Index(binder, canon) == 0) {
+ // once per word
+ if (IS_SET_WORD(value) || (flags & COLLECT_ANY_WORD)) {
+ Add_Binder_Index(binder, canon, ARR_LEN(BUF_COLLECT));
+ EXPAND_SERIES_TAIL(SER(BUF_COLLECT), 1);
+ Init_Typeset(
+ ARR_LAST(BUF_COLLECT),
+ // Allow all datatypes but no void (initially):
+ ~FLAGIT_KIND(REB_MAX_VOID),
+ VAL_WORD_SPELLING(value)
+ );
+ }
+ }
+ else { // Word is duplicated
+ if (flags & COLLECT_NO_DUP)
+ fail (Error_Dup_Vars_Raw(value)); // cleans binding table
+ }
+ continue;
+ }
+ // Recurse into sub-blocks:
+ if (ANY_EVAL_BLOCK(value) && (flags & COLLECT_DEEP))
+ Collect_Context_Inner_Loop(binder, VAL_ARRAY_AT(value), flags);
+ }
+}
+
+
+//
+// Collect_Keylist_Managed: C
+//
+// Scans a block for words to extract and make into typeset keys to go in
+// a context. The Bind_Table is used to quickly determine duplicate entries.
+//
+// A `prior` context can be provided to serve as a basis; all the keys in
+// the prior will be returned, with only new entries contributed by the
+// data coming from the head[] array. If no new values are needed (the
+// array has no relevant words, or all were just duplicates of words already
+// in prior) then then `prior`'s keylist may be returned. The result is
+// always pre-managed, because it may not be legal to free prior's keylist.
+//
+// Returns:
+// A block of typesets that can be used for a context keylist.
+// If no new words, the prior list is returned.
+//
+// !!! There was previously an optimization in object creation which bypassed
+// key collection in the case where head[] was empty. Revisit if it is worth
+// the complexity to move handling for that case in this routine.
+//
+REBARR *Collect_Keylist_Managed(
+ REBCNT *self_index_out, // which context index SELF is in (if COLLECT_SELF)
+ const RELVAL head[],
+ REBCTX *prior,
+ REBFLGS flags // see %sys-core.h for COLLECT_ANY_WORD, etc.
+) {
+ struct Reb_Binder binder;
+ INIT_BINDER(&binder);
+
+ Collect_Keys_Start(flags);
+
+ if (flags & COLLECT_ENSURE_SELF) {
+ if (
+ !prior
+ || (
+ (*self_index_out = Find_Canon_In_Context(
+ prior, Canon(SYM_SELF), TRUE)
+ )
+ == 0
+ )
+ ) {
+ // No prior or no SELF in prior, so we'll add it as the first key
+ //
+ RELVAL *self_key = ARR_AT(BUF_COLLECT, 1);
+ Init_Typeset(self_key, ALL_64, Canon(SYM_SELF));
+
+ // !!! See notes on the flags about why SELF is set hidden but
+ // not unbindable with TYPESET_FLAG_UNBINDABLE.
+ //
+ SET_VAL_FLAG(self_key, TYPESET_FLAG_HIDDEN);
+
+ Add_Binder_Index(&binder, VAL_KEY_CANON(self_key), 1);
+ *self_index_out = 1;
+ SET_ARRAY_LEN_NOTERM(BUF_COLLECT, 2); // [0] rootkey, plus SELF
+ }
+ else {
+ // No need to add SELF if it's going to be added via the `prior`
+ // so just return the `self_index_out` as-is.
+ }
+ }
+ else {
+ assert(self_index_out == NULL);
+ }
+
+ // Setup binding table with existing words, no need to check duplicates
+ //
+ if (prior) Collect_Context_Keys(&binder, prior, FALSE);
+
+ // Scan for words, adding them to BUF_COLLECT and bind table:
+ Collect_Context_Inner_Loop(&binder, head, flags);
+
+ // Grab the keylist, and set its rootkey in [0] to BLANK! (CTX_KEY and
+ // CTX_VAR indexing start at 1, and [0] for the variables is an instance
+ // of the ANY-CONTEXT! value itself).
+ //
+ // !!! Usages of the rootkey for non-FRAME! contexts is open for future.
+ //
+ REBARR *keylist = Grab_Collected_Keylist_Managed(prior);
+
+ Collect_Keys_End(&binder);
+
+ SHUTDOWN_BINDER(&binder);
+ return keylist;
+}
+
+
+//
+// Collect_Words_Inner_Loop: C
+//
+// Used for Collect_Words() after the binds table has
+// been set up.
+//
+static void Collect_Words_Inner_Loop(
+ struct Reb_Binder *binder,
+ const RELVAL head[],
+ REBFLGS flags
+) {
+ const RELVAL *value = head;
+ for (; NOT_END(value); value++) {
+ if (ANY_WORD(value)
+ && Try_Get_Binder_Index(binder, VAL_WORD_CANON(value)) == 0
+ && (IS_SET_WORD(value) || (flags & COLLECT_ANY_WORD))
+ ){
+ Add_Binder_Index(binder, VAL_WORD_CANON(value), 1);
+
+ REBVAL *word = Alloc_Tail_Array(BUF_COLLECT);
+ Init_Word(word, VAL_WORD_SPELLING(value));
+ }
+ else if (ANY_EVAL_BLOCK(value) && (flags & COLLECT_DEEP))
+ Collect_Words_Inner_Loop(binder, VAL_ARRAY_AT(value), flags);
+ }
+}
+
+
+//
+// Collect_Words: C
+//
+// Collect words from a prior block and new block.
+//
+REBARR *Collect_Words(
+ const RELVAL head[],
+ RELVAL *opt_prior_head,
+ REBFLGS flags
+) {
+ struct Reb_Binder binder;
+ INIT_BINDER(&binder);
+
+ assert(ARR_LEN(BUF_COLLECT) == 0); // should be empty
+
+ if (opt_prior_head)
+ Collect_Words_Inner_Loop(&binder, opt_prior_head, COLLECT_ANY_WORD);
+
+ REBCNT start = ARR_LEN(BUF_COLLECT);
+ Collect_Words_Inner_Loop(&binder, head, flags);
+ TERM_ARRAY_LEN(BUF_COLLECT, ARR_LEN(BUF_COLLECT));
+
+ // Reset word markers:
+ //
+ RELVAL *word;
+ for (word = ARR_HEAD(BUF_COLLECT); NOT_END(word); word++)
+ Remove_Binder_Index(&binder, VAL_WORD_CANON(word));
+
+ // The words in BUF_COLLECT are newly created, and should not be bound
+ // at all... hence fully specified with no relative words
+ //
+ REBARR *array = Copy_Array_At_Max_Shallow(
+ BUF_COLLECT, start, SPECIFIED, ARR_LEN(BUF_COLLECT) - start
+ );
+ SET_ARRAY_LEN_NOTERM(BUF_COLLECT, 0);
+
+ SHUTDOWN_BINDER(&binder);
+ return array;
+}
+
+
+//
+// Rebind_Context_Deep: C
+//
+// Clone old context to new context knowing
+// which types of values need to be copied, deep copied, and rebound.
+//
+void Rebind_Context_Deep(
+ REBCTX *source,
+ REBCTX *dest,
+ struct Reb_Binder *opt_binder
+) {
+ Rebind_Values_Deep(source, dest, CTX_VARS_HEAD(dest), opt_binder);
+}
+
+
+//
+// Make_Selfish_Context_Detect: C
+//
+// Create a context by detecting top-level set-words in an array of values.
+// So if the values were the contents of the block `[a: 10 b: 20]` then the
+// resulting context would be for two words, `a` and `b`.
+//
+// Optionally a parent context may be passed in, which will contribute its
+// keylist of words to the result if provided.
+//
+// The resulting context will have a SELF: defined as a hidden key (will not
+// show up in `words-of` but will be bound during creation). As part of
+// the migration away from SELF being a keyword, the logic for adding and
+// managing SELF has been confined to this function (called by `make object!`
+// and some other context-creating routines). This will ultimately turn
+// into something paralleling the non-keyword definitional RETURN:, where
+// the generators (like OBJECT) will be taking responsibility for it.
+//
+// This routine will *always* make a context with a SELF. This lacks the
+// nuance that is expected of the generators, which will have an equivalent
+// to ` return` or ` leave` to suppress it.
+//
+REBCTX *Make_Selfish_Context_Detect(
+ enum Reb_Kind kind,
+ const RELVAL head[],
+ REBCTX *opt_parent
+) {
+ REBCNT self_index;
+ REBARR *keylist = Collect_Keylist_Managed(
+ &self_index,
+ head,
+ opt_parent,
+ COLLECT_ONLY_SET_WORDS | COLLECT_ENSURE_SELF
+ );
+
+ REBCNT len = ARR_LEN(keylist);
+
+ // Make a context of same size as keylist (END already accounted for)
+ //
+ REBARR *varlist = Make_Array_Core(len, ARRAY_FLAG_VARLIST);
+ TERM_ARRAY_LEN(varlist, len);
+
+ REBCTX *context = CTX(varlist);
+
+ // !!! We actually don't know if the keylist coming back from
+ // Collect_Keylist_Managed was created new or reused. Err on the safe
+ // side for now, but it could also return a result so we could know
+ // if it would be legal to call INIT_CTX_KEYLIST_UNIQUE.
+ //
+ INIT_CTX_KEYLIST_SHARED(context, keylist);
+
+ // context[0] is an instance value of the OBJECT!/PORT!/ERROR!/MODULE!
+ //
+ REBVAL *var = KNOWN(ARR_HEAD(varlist));
+ VAL_RESET_HEADER(var, kind);
+ var->payload.any_context.varlist = varlist;
+ var->payload.any_context.phase = NULL;
+ var->extra.binding = NULL;
+
+ ++var;
+
+ // !!! For Ren-C we probably want to go with void default intead of
+ // blanks. Also the filling of parent vars will overwrite the work here.
+ //
+ for (; len > 1; --len, ++var) // 1 is rootvar (context), already done
+ Init_Blank(var);
+
+ if (opt_parent) {
+ //
+ // Bitwise copy parent values (will have bits fixed by Clonify).
+ // None of these should be relative, because they came from object
+ // vars (that were not part of the deep copy of a function body)
+ //
+ memcpy(
+ CTX_VARS_HEAD(context),
+ CTX_VARS_HEAD(opt_parent),
+ (CTX_LEN(opt_parent)) * sizeof(REBVAL)
+ );
+
+ // For values we copied that were blocks and strings, replace
+ // their series components with deep copies of themselves:
+ //
+ Clonify_Values_Len_Managed(
+ CTX_VARS_HEAD(context),
+ SPECIFIED,
+ CTX_LEN(context),
+ TRUE,
+ TS_CLONE
+ );
+ }
+
+ // We should have a SELF key in all cases here. Set it to be a copy of
+ // the object we just created. (It is indeed a copy of the [0] element,
+ // but it doesn't need to be protected because the user overwriting it
+ // won't destroy the integrity of the context.)
+ //
+ assert(CTX_KEY_SYM(context, self_index) == SYM_SELF);
+ Move_Value(CTX_VAR(context, self_index), CTX_VALUE(context));
+
+ // !!! In Ren-C, the idea that functions are rebound when a context is
+ // inherited is being deprecated. It simply isn't viable for objects
+ // with N methods to have those N methods permanently cloned in the
+ // copies and have their bodies rebound to the new object. A more
+ // conventional method of `this->method()` access is needed with
+ // cooperation from the evaluator, and that is slated to be `/method`
+ // as a practical use of paths that implicitly start from "wherever
+ // you dispatched from"
+ //
+ // Temporarily the old behavior is kept, so we deep copy and rebind.
+ //
+ if (opt_parent)
+ Rebind_Context_Deep(opt_parent, context, NULL); // NULL=no more binds
+
+ ASSERT_CONTEXT(context);
+
+#if !defined(NDEBUG)
+ PG_Reb_Stats->Objects++;
+#endif
+
+ return context;
+}
+
+
+//
+// Construct_Context: C
+//
+// Construct an object without evaluation.
+// Parent can be null. Values are rebound.
+//
+// In R3-Alpha the CONSTRUCT native supported a mode where the following:
+//
+// [a: b: 1 + 2 d: a e:]
+//
+// ...would have `a` and `b` will be set to 1, while `+` and `2` will be
+// ignored, `d` will be the word `a` (where it knows to be bound to the a
+// of the object) and `e` would be left as it was.
+//
+// Ren-C retakes the name CONSTRUCT to be the arity-2 object creation
+// function with evaluation, and makes "raw" construction (via /ONLY on both
+// 1-arity HAS and CONSTRUCT) more regimented. The requirement for a raw
+// construct is that the fields alternate SET-WORD! and then value, with
+// no evaluation--hence it is possible to use any value type (a GROUP! or
+// another SET-WORD!, for instance) as the value.
+//
+// !!! Because this is a work in progress, set-words would be gathered if
+// they were used as values, so they are not currently permitted.
+//
+REBCTX *Construct_Context(
+ enum Reb_Kind kind,
+ RELVAL head[], // !!! Warning: modified binding
+ REBSPC *specifier,
+ REBCTX *opt_parent
+) {
+ REBCTX *context = Make_Selfish_Context_Detect(
+ kind, // type
+ head, // values to scan for toplevel set-words
+ opt_parent // parent
+ );
+
+ if (head == NULL)
+ return context;
+
+ Bind_Values_Shallow(head, context);
+
+ const RELVAL *value = head;
+ for (; NOT_END(value); value += 2) {
+ if (!IS_SET_WORD(value))
+ fail (Error_Invalid_Type(VAL_TYPE(value)));
+
+ if (IS_END(value + 1))
+ fail ("Unexpected end in context spec block.");
+
+ if (IS_SET_WORD(value + 1))
+ fail (Error_Invalid_Type(VAL_TYPE(value + 1))); // TBD: support
+
+ REBVAL *var = Sink_Var_May_Fail(value, specifier);
+ Derelativize(var, value + 1, specifier);
+ }
+
+ return context;
+}
+
+
+//
+// Context_To_Array: C
+//
+// Return a block containing words, values, or set-word: value
+// pairs for the given object. Note: words are bound to original
+// object.
+//
+// Modes:
+// 1 for word
+// 2 for value
+// 3 for words and values
+//
+REBARR *Context_To_Array(REBCTX *context, REBINT mode)
+{
+ REBVAL *key = CTX_KEYS_HEAD(context);
+ REBVAL *var = CTX_VARS_HEAD(context);
+
+ assert(!(mode & 4));
+
+ REBARR *block = Make_Array(CTX_LEN(context) * (mode == 3 ? 2 : 1));
+
+ REBCNT n = 1;
+ for (; NOT_END(key); n++, key++, var++) {
+ if (NOT_VAL_FLAG(key, TYPESET_FLAG_HIDDEN)) {
+ if (mode & 1) {
+ REBVAL *value = Alloc_Tail_Array(block);
+ Init_Any_Word_Bound(
+ value,
+ (mode & 2) ? REB_SET_WORD : REB_WORD,
+ VAL_KEY_SPELLING(key),
+ context,
+ n
+ );
+ if (mode & 2)
+ SET_VAL_FLAG(value, VALUE_FLAG_LINE);
+ }
+ if (mode & 2) {
+ //
+ // Context might have voids, which denote the value have not
+ // been set. These contexts cannot be converted to blocks,
+ // since user arrays may not contain void.
+ //
+ if (IS_VOID(var))
+ fail (Error_Void_Object_Block_Raw());
+
+ Append_Value(block, var);
+ }
+ }
+ }
+
+ return block;
+}
+
+
+//
+// Merge_Contexts_Selfish: C
+//
+// Create a child context from two parent contexts. Merge common fields.
+// Values from the second parent take precedence.
+//
+// Deep copy and rebind the child.
+//
+REBCTX *Merge_Contexts_Selfish(REBCTX *parent1, REBCTX *parent2)
+{
+ struct Reb_Binder binder;
+ INIT_BINDER(&binder);
+
+ assert(CTX_TYPE(parent1) == CTX_TYPE(parent2));
+
+ // Merge parent1 and parent2 words.
+ // Keep the binding table.
+ Collect_Keys_Start(COLLECT_ANY_WORD | COLLECT_ENSURE_SELF);
+
+ // Setup binding table and BUF_COLLECT with parent1 words. Don't bother
+ // checking for duplicates, buffer is empty.
+ //
+ Collect_Context_Keys(&binder, parent1, FALSE);
+
+ // Add parent2 words to binding table and BUF_COLLECT, and since we know
+ // BUF_COLLECT isn't empty then *do* check for duplicates.
+ //
+ Collect_Context_Keys(&binder, parent2, TRUE);
+
+ // Collect_Keys_End() terminates, but Collect_Context_Inner_Loop() doesn't.
+ //
+ TERM_ARRAY_LEN(BUF_COLLECT, ARR_LEN(BUF_COLLECT));
+
+ // Allocate child (now that we know the correct size). Obey invariant
+ // that keylists are always managed. The BUF_COLLECT contains only
+ // typesets, so no need for a specifier in the copy.
+ //
+ // !!! Review: should child start fresh with no meta information, or get
+ // the meta information held by parents?
+ //
+ REBARR *keylist = Copy_Array_Shallow(BUF_COLLECT, SPECIFIED);
+ MANAGE_ARRAY(keylist);
+ Init_Blank(ARR_HEAD(keylist)); // Currently no rootkey usage
+ SER(keylist)->link.meta = NULL;
+
+ REBARR *varlist = Make_Array_Core(ARR_LEN(keylist), ARRAY_FLAG_VARLIST);
+ REBCTX *merged = CTX(varlist);
+ INIT_CTX_KEYLIST_UNIQUE(merged, keylist);
+
+ // !!! Currently we assume the child will be of the same type as the
+ // parent...so if the parent was an OBJECT! so will the child be, if
+ // the parent was an ERROR! so will the child be. This is a new idea,
+ // so review consequences.
+ //
+ REBVAL *rootvar = SINK(ARR_HEAD(varlist));
+ VAL_RESET_HEADER(rootvar, CTX_TYPE(parent1));
+ rootvar->payload.any_context.varlist = varlist;
+ rootvar->payload.any_context.phase = NULL;
+ rootvar->extra.binding = NULL;
+
+ // Copy parent1 values:
+ memcpy(
+ CTX_VARS_HEAD(merged),
+ CTX_VARS_HEAD(parent1),
+ CTX_LEN(parent1) * sizeof(REBVAL)
+ );
+
+ // Update the child tail before making calls to CTX_VAR(), because the
+ // debug build does a length check.
+ //
+ TERM_ARRAY_LEN(CTX_VARLIST(merged), ARR_LEN(keylist));
+
+ // Copy parent2 values:
+ REBVAL *key = CTX_KEYS_HEAD(parent2);
+ REBVAL *value = CTX_VARS_HEAD(parent2);
+ for (; NOT_END(key); key++, value++) {
+ // no need to search when the binding table is available
+ REBINT n = Try_Get_Binder_Index(&binder, VAL_KEY_CANON(key));
+ assert(n != 0);
+ Move_Value(CTX_VAR(merged, n), value);
+ }
+
+ // Deep copy the child. Context vars are REBVALs, already fully specified
+ //
+ Clonify_Values_Len_Managed(
+ CTX_VARS_HEAD(merged),
+ SPECIFIED,
+ CTX_LEN(merged),
+ TRUE,
+ TS_CLONE
+ );
+
+ // Rebind the child
+ Rebind_Context_Deep(parent1, merged, NULL);
+ Rebind_Context_Deep(parent2, merged, &binder);
+
+ // release the bind table
+ Collect_Keys_End(&binder);
+
+ // We should have gotten a SELF in the results, one way or another.
+ {
+ REBCNT self_index = Find_Canon_In_Context(merged, Canon(SYM_SELF), TRUE);
+ assert(self_index != 0);
+ assert(CTX_KEY_SYM(merged, self_index) == SYM_SELF);
+ Move_Value(CTX_VAR(merged, self_index), CTX_VALUE(merged));
+ }
+
+ SHUTDOWN_BINDER(&binder);
+ return merged;
+}
+
+
+//
+// Resolve_Context: C
+//
+// Only_words can be a block of words or an index in the target
+// (for new words).
+//
+void Resolve_Context(
+ REBCTX *target,
+ REBCTX *source,
+ REBVAL *only_words,
+ REBOOL all,
+ REBOOL expand
+) {
+ FAIL_IF_READ_ONLY_CONTEXT(target);
+
+ REBCNT i;
+ if (IS_INTEGER(only_words)) { // Must be: 0 < i <= tail
+ i = VAL_INT32(only_words);
+ if (i == 0)
+ i = 1;
+ if (i > CTX_LEN(target))
+ return;
+ }
+ else
+ i = 0;
+
+ struct Reb_Binder binder;
+ INIT_BINDER(&binder);
+
+ REBVAL *key;
+ REBVAL *var;
+
+ // !!! This function does its own version of resetting the bind table
+ // and hence the Collect_Keys_End that would be performed in the case of
+ // a `fail (Error(...))` will not properly reset it. Because the code
+ // does array expansion it cannot guarantee a fail won't happen, hence
+ // the method needs to be reviewed to something that could properly
+ // reset in the case of an out of memory error.
+ //
+ Collect_Keys_Start(COLLECT_ONLY_SET_WORDS);
+
+ REBINT n = 0;
+
+ // If limited resolve, tag the word ids that need to be copied:
+ if (i != 0) {
+ // Only the new words of the target:
+ for (key = CTX_KEY(target, i); NOT_END(key); key++)
+ Add_Binder_Index(&binder, VAL_KEY_CANON(key), -1);
+ n = CTX_LEN(target);
+ }
+ else if (IS_BLOCK(only_words)) {
+ // Limit exports to only these words:
+ RELVAL *word = VAL_ARRAY_AT(only_words);
+ for (; NOT_END(word); word++) {
+ if (IS_WORD(word) || IS_SET_WORD(word)) {
+ Add_Binder_Index(&binder, VAL_WORD_CANON(word), -1);
+ n++;
+ }
+ else {
+ // !!! There was no error here. :-/ Should it be one?
+ }
+ }
+ }
+
+ // Expand target as needed:
+ if (expand && n > 0) {
+ // Determine how many new words to add:
+ for (key = CTX_KEYS_HEAD(target); NOT_END(key); key++)
+ if (Try_Get_Binder_Index(&binder, VAL_KEY_CANON(key)) != 0)
+ --n;
+
+ // Expand context by the amount required:
+ if (n > 0)
+ Expand_Context(target, n);
+ else
+ expand = FALSE;
+ }
+
+ // Maps a word to its value index in the source context.
+ // Done by marking all source words (in bind table):
+ key = CTX_KEYS_HEAD(source);
+ for (n = 1; NOT_END(key); n++, key++) {
+ REBSTR *canon = VAL_KEY_CANON(key);
+ if (IS_VOID(only_words))
+ Add_Binder_Index(&binder, canon, n);
+ else {
+ if (Try_Get_Binder_Index(&binder, canon) != 0) {
+ Remove_Binder_Index(&binder, canon);
+ Add_Binder_Index(&binder, canon, n);
+ }
+ }
+ }
+
+ // Foreach word in target, copy the correct value from source:
+ //
+ var = i != 0 ? CTX_VAR(target, i) : CTX_VARS_HEAD(target);
+ key = i != 0 ? CTX_KEY(target, i) : CTX_KEYS_HEAD(target);
+ for (; NOT_END(key); key++, var++) {
+ REBINT m = Try_Remove_Binder_Index(&binder, VAL_KEY_CANON(key));
+ if (m != 0) {
+ // "the remove succeeded, so it's marked as set now" (old comment)
+ if (
+ NOT_VAL_FLAG(var, VALUE_FLAG_PROTECTED)
+ && (all || IS_VOID(var))
+ ) {
+ if (m < 0) Init_Void(var); // no value in source context
+ else {
+ Move_Value(var, CTX_VAR(source, m));
+
+ // Need to also copy if the binding is lookahead (e.g.
+ // would be an infix call).
+ //
+ if (GET_VAL_FLAG(CTX_VAR(source, m), VALUE_FLAG_ENFIXED))
+ SET_VAL_FLAG(var, VALUE_FLAG_ENFIXED);
+ }
+ }
+ }
+ }
+
+ // Add any new words and values:
+ if (expand) {
+ key = CTX_KEYS_HEAD(source);
+ for (n = 1; NOT_END(key); n++, key++) {
+ REBSTR *canon = VAL_KEY_CANON(key);
+ if (Try_Remove_Binder_Index(&binder, canon) != 0) {
+ //
+ // Note: no protect check is needed here
+ //
+ var = Append_Context(target, 0, canon);
+ Move_Value(var, CTX_VAR(source, n));
+
+ // Need to also copy if the binding is lookahead (e.g.
+ // would be an infix call).
+ //
+ if (GET_VAL_FLAG(CTX_VAR(source, n), VALUE_FLAG_ENFIXED))
+ SET_VAL_FLAG(var, VALUE_FLAG_ENFIXED);
+ }
+ }
+ }
+ else {
+ // Reset bind table (do not use Collect_End):
+ if (i != 0) {
+ for (key = CTX_KEY(target, i); NOT_END(key); key++)
+ Try_Remove_Binder_Index(&binder, VAL_KEY_CANON(key));
+ }
+ else if (IS_BLOCK(only_words)) {
+ RELVAL *word = VAL_ARRAY_AT(only_words);
+ for (; NOT_END(word); word++) {
+ if (IS_WORD(word) || IS_SET_WORD(word))
+ Try_Remove_Binder_Index(&binder, VAL_WORD_CANON(word));
+ }
+ }
+ else {
+ for (key = CTX_KEYS_HEAD(source); NOT_END(key); key++)
+ Try_Remove_Binder_Index(&binder, VAL_KEY_CANON(key));
+ }
+ }
+
+ // !!! Note we explicitly do *not* use Collect_Keys_End(). See warning
+ // about errors, out of memory issues, etc. at Collect_Keys_Start()
+ //
+ SET_SERIES_LEN(SER(BUF_COLLECT), 0); // allow reuse, no terminator
+
+ SHUTDOWN_BINDER(&binder);
+}
+
+
+//
+// Find_Canon_In_Context: C
+//
+// Search a context looking for the given canon symbol. Return the index or
+// 0 if not found.
+//
+REBCNT Find_Canon_In_Context(REBCTX *context, REBSTR *canon, REBOOL always)
+{
+ assert(GET_SER_INFO(canon, STRING_INFO_CANON));
+
+ REBVAL *key = CTX_KEYS_HEAD(context);
+ REBCNT len = CTX_LEN(context);
+
+ REBCNT n;
+ for (n = 1; n <= len; n++, key++) {
+ if (canon == VAL_KEY_CANON(key))
+ return (!always && GET_VAL_FLAG(key, TYPESET_FLAG_HIDDEN)) ? 0 : n;
+ }
+
+ // !!! Should this be changed to NOT_FOUND?
+ return 0;
+}
+
+
+//
+// Select_Canon_In_Context: C
+//
+// Search a frame looking for the given word symbol and
+// return the value for the word. Locate it by matching
+// the canon word identifiers. Return NULL if not found.
+//
+REBVAL *Select_Canon_In_Context(REBCTX *context, REBSTR *sym)
+{
+ REBCNT n = Find_Canon_In_Context(context, sym, FALSE);
+ if (n == 0) return NULL;
+
+ return CTX_VAR(context, n);
+}
+
+
+//
+// Find_Word_In_Array: C
+//
+// Find word (of any type) in an array of values with linear search.
+//
+REBCNT Find_Word_In_Array(REBARR *array, REBCNT index, REBSTR *sym)
+{
+ RELVAL *value;
+
+ for (; index < ARR_LEN(array); index++) {
+ value = ARR_AT(array, index);
+ if (ANY_WORD(value) && sym == VAL_WORD_CANON(value))
+ return index;
+ }
+
+ return NOT_FOUND;
+}
+
+
+//
+// Obj_Value: C
+//
+// Return pointer to the nth VALUE of an object.
+// Return zero if the index is not valid.
+//
+REBVAL *Obj_Value(REBVAL *value, REBCNT index)
+{
+ REBCTX *context = VAL_CONTEXT(value);
+
+ if (index > CTX_LEN(context)) return 0;
+ return CTX_VAR(context, index);
+}
+
+
+//
+// Startup_Collector: C
+//
+void Startup_Collector(void)
+{
+ // Temporary block used while scanning for frame words:
+ // "just holds typesets, no GC behavior" (!!! until typeset symbols or
+ // embedded tyeps are GC'd...!)
+ //
+ // Note that the logic inside Collect_Keylist managed assumes it's at
+ // least 2 long to hold the rootkey (SYM_0) and a possible SYM_SELF
+ // hidden actual key.
+ //
+ Init_Block(TASK_BUF_COLLECT, Make_Array_Core(2 + 98, 0));
+}
+
+
+#ifndef NDEBUG
+
+//
+// Assert_Context_Core: C
+//
+void Assert_Context_Core(REBCTX *c)
+{
+ REBARR *varlist = CTX_VARLIST(c);
+
+ if (NOT_SER_FLAG(varlist, ARRAY_FLAG_VARLIST))
+ panic (varlist);
+
+ REBARR *keylist = CTX_KEYLIST(c);
+
+ if (!CTX_KEYLIST(c))
+ panic (c);
+
+ if (GET_SER_INFO(keylist, CONTEXT_INFO_STACK))
+ panic (keylist);
+
+ REBVAL *rootvar = CTX_VALUE(c);
+ if (!ANY_CONTEXT(rootvar))
+ panic (rootvar);
+
+ REBCNT keys_len = ARR_LEN(keylist);
+ REBCNT vars_len = ARR_LEN(varlist);
+
+ if (keys_len < 1)
+ panic (keylist);
+
+ if (GET_SER_INFO(CTX_VARLIST(c), CONTEXT_INFO_STACK)) {
+ if (vars_len != 1)
+ panic (varlist);
+ }
+ else {
+ if (keys_len != vars_len)
+ panic (c);
+ }
+
+ if (rootvar->payload.any_context.varlist != varlist)
+ panic (rootvar);
+
+ if (CTX_VARS_UNAVAILABLE(c)) {
+ //
+ // !!! For the moment, don't check inaccessible stack frames any
+ // further. This includes varless reified frames and those reified
+ // frames that are no longer on the stack.
+ //
+ return;
+ }
+
+ REBVAL *rootkey = CTX_ROOTKEY(c);
+ if (IS_BLANK_RAW(rootkey)) {
+ //
+ // Note that in the future the rootkey for ordinary OBJECT! or ERROR!
+ // PORT! etc. may be more interesting than BLANK. But it uses that
+ // for now--unreadable.
+ //
+ if (IS_FRAME(rootvar))
+ panic (c);
+ }
+ else if (IS_FUNCTION(rootkey)) {
+ //
+ // At the moment, only FRAME! is able to reuse a FUNCTION!'s keylist.
+ // There may be reason to relax this, if you wanted to make an
+ // ordinary object that was a copy of a FRAME! but not a FRAME!.
+ //
+ if (!IS_FRAME(rootvar))
+ panic (rootvar);
+
+ // !!! Temporary disablement of an important check!
+ //
+ // Currently MAKE FRAME! of a FUNCTION! makes the keylist for the
+ // function itself, and not the underlying one. This is buggy, and
+ // needs to be fixed. It will require some major changes, though.
+ //
+ /*REBFRM *f = CTX_FRAME_IF_ON_STACK(c);
+ if (f != NULL) {
+ REBFUN *rootkey_fun = VAL_FUNC(rootkey);
+ REBFUN *frame_fun = FRM_UNDERLYING(f);
+
+ if (rootkey_fun != frame_fun) {
+ printf("FRAME! context function doesn't match its REBFRM");
+ panic (frame_fun);
+ }
+ }*/
+ }
+ else
+ panic (rootkey);
+
+ REBVAL *key = CTX_KEYS_HEAD(c);
+ REBVAL *var = CTX_VARS_HEAD(c);
+
+ REBCNT n;
+ for (n = 1; n < keys_len; n++, var++, key++) {
+ if (IS_END(key)) {
+ printf("** Early key end at index: %d\n", cast(int, n));
+ panic (c);
+ }
+
+ if (!IS_TYPESET(key))
+ panic (key);
+
+ if (IS_END(var)) {
+ printf("** Early var end at index: %d\n", cast(int, n));
+ panic (c);
+ }
+ }
+
+ if (NOT_END(key)) {
+ printf("** Missing key end at index: %d\n", cast(int, n));
+ panic (key);
+ }
+
+ if (NOT_END(var)) {
+ printf("** Missing var end at index: %d\n", cast(int, n));
+ panic (var);
+ }
+}
+
+#endif
diff --git a/src/core/c-do.c b/src/core/c-do.c
old mode 100644
new mode 100755
index 481476d891..66064543f5
--- a/src/core/c-do.c
+++ b/src/core/c-do.c
@@ -1,2218 +1,38 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: c-do.c
-** Summary: the core interpreter - the heart of REBOL
-** Section: core
-** Author: Carl Sassenrath
-** Notes:
-** WARNING WARNING WARNING
-** This is highly tuned code that should only be modified by experts
-** who fully understand its design. It is very easy to create odd
-** side effects so please be careful and extensively test all changes!
-**
-***********************************************************************/
+//
+// File: %c-do.c
+// Summary: "DO Evaluator Wrappers"
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// These are the "slightly more user-friendly" interfaces to the evaluator
+// from %c-eval.c. These routines will do the setup of the Reb_Frame state
+// for you.
+//
+// Even "friendlier" interfaces are available as macros on top of these.
+// See %sys-do.h for Do_Any_Array_At_Throws() and similar macros.
+//
#include "sys-core.h"
-#include
-#include "sys-state.h"
-enum Eval_Types {
- ET_INVALID, // not valid to evaluate
- ET_WORD,
- ET_SELF, // returns itself
- ET_FUNCTION,
- ET_OPERATOR,
- ET_PAREN,
- ET_SET_WORD,
- ET_LIT_WORD,
- ET_GET_WORD,
- ET_PATH,
- ET_LIT_PATH,
- ET_END // end of block
-};
-
-static jmp_buf *Halt_State = 0; //!!!!!!!!!! global?
-
-/*
-void T_Error(REBCNT n) {;}
-
-// Deferred:
-void T_Series(REBCNT n) {;} // image
-void T_List(REBCNT n) {;} // list
-*/
-
-void Do_Rebcode(REBVAL *v) {;}
-
-#include "tmp-evaltypes.h"
-
-#define EVAL_TYPE(val) (Eval_Type_Map[VAL_TYPE(val)])
-
-#define PUSH_ERROR(v, a)
-#define PUSH_FUNC(v, w, s)
-#define PUSH_BLOCK(b)
-
-static REBVAL *Func_Word(REBINT dsf)
-{
- static REBVAL val; // Safe: Lifetime is limited to passage to error object.
- Init_Word(&val, VAL_WORD_SYM(DSF_WORD(dsf)));
- return &val;
-}
-
-
-/***********************************************************************
-**
-*/ void Do_Op(REBVAL *func)
-/*
-** A trampoline.
-**
-***********************************************************************/
-{
- Func_Dispatch[VAL_GET_EXT(func) - REB_NATIVE](func);
-}
-
-
-/***********************************************************************
-**
-*/ void Expand_Stack(REBCNT amount)
-/*
-** Expand the datastack. Invalidates any references to stack
-** values, so code should generally use stack index integers,
-** not pointers into the stack.
-**
-***********************************************************************/
-{
- if (SERIES_REST(DS_Series) >= STACK_LIMIT) Trap0(RE_STACK_OVERFLOW);
- DS_Series->tail = DSP+1;
- Extend_Series(DS_Series, amount);
- DS_Base = BLK_HEAD(DS_Series);
- Debug_Fmt(BOOT_STR(RS_STACK, 0), DSP, SERIES_REST(DS_Series));
-}
-
-
-/***********************************************************************
-**
-*/ void DS_Ret_Int(REBINT n)
-/*
-** Memsaver: set integer as return result on data stack.
-**
-***********************************************************************/
-{
- DS_RET_INT(n);
-}
-
-
-/***********************************************************************
-**
-*/ void DS_Ret_Val(REBVAL *value)
-/*
-** Memsaver: set any value as return result on data stack.
-**
-***********************************************************************/
-{
- *DS_RETURN = *value;
-}
-
-
-/***********************************************************************
-**
-*/ REBINT Eval_Depth()
-/*
-***********************************************************************/
-{
- REBINT depth = 0;
- REBINT dsf;
-
- for (dsf = DSF; dsf > 0; dsf = PRIOR_DSF(dsf), depth++);
- return depth;
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Stack_Frame(REBCNT n)
-/*
-***********************************************************************/
-{
- REBCNT dsf = DSF;
-
- for (dsf = DSF; dsf > 0; dsf = PRIOR_DSF(dsf)) {
- if (n-- <= 0) return DS_VALUE(dsf);
- }
-
- return 0;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(trace)
-/*
-***********************************************************************/
-{
- REBVAL *arg = D_ARG(1);
-
- Check_Security(SYM_DEBUG, POL_READ, 0);
-
- // The /back option: ON and OFF, or INTEGER! for # of lines:
- if (D_REF(2)) { // /back
- if (IS_LOGIC(arg)) {
- Enable_Backtrace(IS_TRUE(arg));
- }
- else if (IS_INTEGER(arg)) {
- Trace_Flags = 0;
- Display_Backtrace(Int32(arg));
- return R_UNSET;
- }
- }
- else Enable_Backtrace(FALSE);
-
- // Set the trace level:
- if (IS_LOGIC(arg)) {
- Trace_Level = IS_TRUE(arg) ? 100000 : 0;
- }
- else Trace_Level = Int32(arg);
-
- if (Trace_Level) {
- Trace_Flags = 1;
- if (D_REF(3)) SET_FLAG(Trace_Flags, 1); // function
- Trace_Depth = Eval_Depth() - 1; // subtract current TRACE frame
- }
- else Trace_Flags = 0;
-
- return R_UNSET;
-}
-
-static REBINT Init_Depth(void)
-{
- // Check the trace depth is ok:
- int depth = Eval_Depth() - Trace_Depth;
- if (depth < 0 || depth >= Trace_Level) return -1;
- if (depth > 10) depth = 10;
- Debug_Space(4 * depth);
- return depth;
-}
-
-#define CHECK_DEPTH(d) if ((d = Init_Depth()) < 0) return;\
-
-void Trace_Line(REBSER *block, REBINT index, REBVAL *value)
-{
- int depth;
-
- if (GET_FLAG(Trace_Flags, 1)) return; // function
- if (ANY_FUNC(value)) return;
-
- CHECK_DEPTH(depth);
-
- Debug_Fmt_(BOOT_STR(RS_TRACE,1), index+1, value);
- if (IS_WORD(value) || IS_GET_WORD(value)) {
- value = Get_Var(value);
- if (VAL_TYPE(value) < REB_NATIVE)
- Debug_Fmt_(BOOT_STR(RS_TRACE,2), value);
- else if (VAL_TYPE(value) >= REB_NATIVE && VAL_TYPE(value) <= REB_FUNCTION)
- Debug_Fmt_(BOOT_STR(RS_TRACE,3), Get_Type_Name(value), List_Func_Words(value));
- else
- Debug_Fmt_(BOOT_STR(RS_TRACE,4), Get_Type_Name(value));
- }
- /*if (ANY_WORD(value)) {
- word = value;
- if (IS_WORD(value)) value = Get_Var(word);
- Debug_Fmt_(BOOT_STR(RS_TRACE,2), VAL_WORD_FRAME(word), VAL_WORD_INDEX(word), Get_Type_Name(value));
- }
- if (Trace_Stack) Debug_Fmt(BOOT_STR(RS_TRACE,3), DSP, DSF);
- else
- */
- Debug_Line();
-}
-
-void Trace_Func(REBVAL *word, REBVAL *value)
-{
- int depth;
- CHECK_DEPTH(depth);
- Debug_Fmt_(BOOT_STR(RS_TRACE,5), Get_Word_Name(word), Get_Type_Name(value));
- if (GET_FLAG(Trace_Flags, 1)) Debug_Values(DS_GET(DS_ARG_BASE+1), DS_ARGC, 20);
- else Debug_Line();
-}
-
-void Trace_Return(REBVAL *word, REBVAL *value)
-{
- int depth;
- CHECK_DEPTH(depth);
- Debug_Fmt_(BOOT_STR(RS_TRACE,6), Get_Word_Name(word));
- Debug_Values(value, 1, 50);
-}
-
-void Trace_Arg(REBINT num, REBVAL *arg, REBVAL *path)
-{
- int depth;
- if (IS_REFINEMENT(arg) && (!path || IS_END(path))) return;
- CHECK_DEPTH(depth);
- Debug_Fmt(BOOT_STR(RS_TRACE,6), num+1, arg);
-}
-
-
-/***********************************************************************
-**
-*/ void Trace_Value(REBINT n, REBVAL *value)
-/*
-***********************************************************************/
-{
- int depth;
- CHECK_DEPTH(depth);
- Debug_Fmt(BOOT_STR(RS_TRACE,n), value);
-}
-
-/***********************************************************************
-**
-*/ void Trace_String(REBINT n, REBYTE *str, REBINT limit)
-/*
-***********************************************************************/
-{
- static char tracebuf[64];
- int depth;
- CHECK_DEPTH(depth);
- memcpy(tracebuf, str, MIN(60, limit));
- Debug_Fmt(BOOT_STR(RS_TRACE,n), tracebuf);
-}
-
-
-/***********************************************************************
-**
-*/ void Trace_Error(REBVAL *value)
-/*
-***********************************************************************/
-{
- int depth;
- CHECK_DEPTH(depth);
- Debug_Fmt(BOOT_STR(RS_TRACE, 10), &VAL_ERR_VALUES(value)->type, &VAL_ERR_VALUES(value)->id);
-}
-
-
-/***********************************************************************
-**
-*/ REBCNT Push_Func(REBFLG keep, REBSER *block, REBCNT index, REBCNT word, REBVAL *func)
-/*
-** Push on stack a function call frame as defined in stack.h.
-** Optimized to reduce usage of thread globals (TLS).
-** Block value must not be NULL (otherwise will cause GC fault).
-**
-** keep: use current top of stack as the return value; do not push
-** a new value for the return.
-**
-** returns: the stack index for the return value.
-**
-***********************************************************************/
-{
- REBCNT dsp = DSP;
- REBVAL *tos = DS_VALUE(dsp);
- REBVAL *ret;
-
- // Set RETURN slot to its default value:
- if (keep) ret = 0, dsp--;
- else ret = ++tos; // don't unset it until bottom of this func
-
- // Save BLOCK current evaluation position and prior DSF;
- tos++;
- VAL_SET(tos, REB_BLOCK);
- VAL_SERIES(tos) = block;
- VAL_INDEX(tos) = index;
- VAL_BACK(tos) = DSF;
-
- // Save WORD for function and fake frame for relative arg lookup:
- tos++;
- VAL_SET(tos, REB_HANDLE); // Was REB_WORD, but GC does not like bad fields.
- VAL_WORD_SYM(tos) = word ? word : SYM__APPLY_;
- VAL_WORD_INDEX(tos) = -1; // avoid GC access to invalid FRAME above
- if (func) {
- VAL_WORD_FRAME(tos) = VAL_FUNC_ARGS(func);
- // Save FUNC value for safety (spec, args, code):
- tos++;
- *tos = *func; // the DSF_FUNC
- } else {
- VAL_WORD_FRAME(tos) = 0;
- tos++;
- SET_NONE(tos); // the DSF_FUNC
- }
-
- if (ret) SET_UNSET(ret);
-
- DSP = dsp + DSF_BIAS;
- return dsp + 1;
-}
-
-
-/***********************************************************************
-**
-*/ void Next_Path(REBPVS *pvs)
-/*
-** Evaluate next part of a path.
-**
-***********************************************************************/
-{
- REBVAL *path;
- REBPEF func;
-
- // Path must have dispatcher, else return:
- func = Path_Dispatch[VAL_TYPE(pvs->value)];
- if (!func) return; // unwind, then check for errors
-
- pvs->path++;
-
- //Debug_Fmt("Next_Path: %r/%r", pvs->path-1, pvs->path);
-
- // object/:field case:
- if (IS_GET_WORD(path = pvs->path)) {
- pvs->select = Get_Var(path);
- if (IS_UNSET(pvs->select)) Trap1(RE_NO_VALUE, path);
- }
- // object/(expr) case:
- else if (IS_PAREN(path)) {
- // ?? GC protect stuff !!!!!! stack could expand!
- pvs->select = Do_Blk(VAL_SERIES(path), 0);
- }
- else // object/word and object/value case:
- pvs->select = path;
-
- // Uses selector on the value.
- // .path - must be advanced as path is used (modified by func)
- // .value - holds currently evaluated path value (modified by func)
- // .select - selector on value
- // .store - storage (usually TOS) for constructed values
- // .setval - non-zero for SET-PATH (set to zero after SET is done)
- // .orig - original path for error messages
- switch (func(pvs)) {
- case PE_OK:
- break;
- case PE_SET: // only sets if end of path
- if (pvs->setval && IS_END(pvs->path+1)) {
- *pvs->value = *pvs->setval;
- pvs->setval = 0;
- }
- break;
- case PE_NONE:
- SET_NONE(pvs->store);
- case PE_USE:
- pvs->value = pvs->store;
- break;
- case PE_BAD_SELECT:
- Trap2(RE_INVALID_PATH, pvs->orig, pvs->path);
- case PE_BAD_SET:
- Trap2(RE_BAD_PATH_SET, pvs->orig, pvs->path);
- case PE_BAD_RANGE:
- Trap_Range(pvs->path);
- case PE_BAD_SET_TYPE:
- Trap2(RE_BAD_FIELD_SET, pvs->path, Of_Type(pvs->setval));
- }
-
- if (NOT_END(pvs->path+1)) Next_Path(pvs);
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Do_Path(REBVAL **path_val, REBVAL *val)
-/*
-** Evaluate a path value. Path_val is updated so
-** result can be used for function refinements.
-** If val is not zero, then this is a SET-PATH.
-** Returns value only if result is a function,
-** otherwise the result is on TOS.
-**
-***********************************************************************/
-{
- REBPVS pvs;
-
- if (val && THROWN(val)) {
- // If unwind/throw value is not coming from TOS, push it.
- if (val != DS_TOP) DS_PUSH(val);
- return 0;
- }
-
- pvs.setval = val; // Set to this new value
- DS_PUSH_NONE;
- pvs.store = DS_TOP; // Temp space for constructed results
-
- // Get first block value:
- pvs.path = VAL_BLK_DATA(pvs.orig = *path_val);
-
- // Lookup the value of the variable:
- if (IS_WORD(pvs.path)) {
- pvs.value = Get_Var(pvs.path);
- if (IS_UNSET(pvs.value)) Trap1(RE_NO_VALUE, pvs.path);
- } else pvs.value = pvs.path; //Trap2(RE_INVALID_PATH, pvs.orig, pvs.path);
-
- // Start evaluation of path:
- if (Path_Dispatch[VAL_TYPE(pvs.value)]) {
- Next_Path(&pvs);
- // Check for errors:
- if (NOT_END(pvs.path+1) && !ANY_FUNC(pvs.value)) {
- // Only function refinements should get by this line:
- Trap2(RE_INVALID_PATH, pvs.orig, pvs.path);
- }
- }
- else if (NOT_END(pvs.path+1) && !ANY_FUNC(pvs.value))
- Trap2(RE_BAD_PATH_TYPE, pvs.orig, Of_Type(pvs.value));
-
- // If SET then we can drop result storage created above.
- if (val) {
- DS_DROP; // on SET, we do not care about returned value
- return 0;
- } else {
- //if (ANY_FUNC(pvs.value) && IS_GET_PATH(pvs.orig)) Debug_Fmt("FUNC %r %r", pvs.orig, pvs.path);
- // If TOS was not used, then copy final value back to it:
- if (pvs.value != pvs.store) *pvs.store = *pvs.value;
- // Return 0 if not function or is :path/word...
- if (!ANY_FUNC(pvs.value) || IS_GET_PATH(pvs.orig)) return 0;
- *path_val = pvs.path; // return new path (for func refinements)
- return pvs.value; // only used for functions
- }
-}
-
-
-/***********************************************************************
-**
-*/ void Pick_Path(REBVAL *value, REBVAL *selector, REBVAL *val)
-/*
-** Lightweight version of Do_Path used for A_PICK actions.
-** Result on TOS.
-**
-***********************************************************************/
-{
- REBPVS pvs;
- REBPEF func;
-
- pvs.value = value;
- pvs.path = 0;
- pvs.select = selector;
- pvs.setval = val;
- DS_PUSH_NONE;
- pvs.store = DS_TOP; // Temp space for constructed results
-
- // Path must have dispatcher, else return:
- func = Path_Dispatch[VAL_TYPE(value)];
- if (!func) return; // unwind, then check for errors
-
- switch (func(&pvs)) {
- case PE_OK:
- break;
- case PE_SET: // only sets if end of path
- if (pvs.setval) *pvs.value = *pvs.setval;
- break;
- case PE_NONE:
- SET_NONE(pvs.store);
- case PE_USE:
- pvs.value = pvs.store;
- break;
- case PE_BAD_SELECT:
- Trap2(RE_INVALID_PATH, pvs.value, pvs.select);
- case PE_BAD_SET:
- Trap2(RE_BAD_PATH_SET, pvs.value, pvs.select);
- break;
- }
-}
-
-
-#ifdef removed_func
-/***********************************************************************
-**
-x*/ static REBINT Do_Args_Light(REBVAL *func, REBVAL *path, REBSER *block, REBCNT index)
-/*
-** Evaluate code block according to the function arg spec.
-** Args are pushed onto the data stack in the same order
-** as the function frame. Args not evaluated.
-**
-***********************************************************************/
-{
- REBVAL *args;
- REBSER *words;
- REBINT ds = 0; // stack argument position
- REBINT dsp = DSP + 1; // stack base
- REBINT dsf = dsp - DSF_BIAS;
- REBVAL *tos;
- REBVAL *val;
-
- if ((dsp + 100) > (REBINT)SERIES_REST(DS_Series))
- Trap0(RE_STACK_OVERFLOW); //Expand_Stack();
-
- // If closure, get args from object context:
- words = VAL_FUNC_WORDS(func);
- //if (IS_CLOSURE(func)) words = FRM_WORD_SERIES(words);
- args = BLK_SKIP(words, 1);
-
- // Fill stack variables with default values:
- ds = SERIES_TAIL(words)-1; // length of stack fill below
- tos = DS_NEXT;
- DSP += ds;
- for (; ds > 0; ds--) SET_NONE(tos++);
-
- // Go thru the word list args:
- ds = dsp;
- for (; NOT_END(args); args++, ds++) {
-
- if (index >= BLK_LEN(block)) {
- if (!IS_REFINEMENT(args))
- Trap2(RE_NO_ARG, Func_Word(dsf), args);
- break;
- }
-
- // Process each argument according to the argument block:
- switch (VAL_TYPE(args)) {
- case REB_WORD:
- case REB_LIT_WORD:
- case REB_GET_WORD:
- DS_Base[ds] = *BLK_SKIP(block, index);
- index++;
- break;
- case REB_REFINEMENT:
- val = BLK_SKIP(block, index);
- index++;
- if (IS_NONE(val) || IS_FALSE(val)) SET_NONE(&DS_Base[ds]);
- else if (IS_LOGIC(val) && VAL_LOGIC(val)) SET_TRUE(&DS_Base[ds]);
- else Trap1(RE_BAD_REFINE, args);
- break;
- }
-
- // If word words is typed, verify correct argument datatype:
- if (!TYPE_CHECK(args, VAL_TYPE(DS_VALUE(ds))))
- Trap3(RE_EXPECT_ARG, Func_Word(dsf), args, Of_Type(DS_VALUE(ds)));
- }
-
- if (path && NOT_END(path))
- Trap2(RE_NO_REFINE, Func_Word(dsf), path);
-
- return index;
-}
-#endif
-
-
-/***********************************************************************
-**
-*/ static REBINT Do_Args(REBVAL *func, REBVAL *path, REBSER *block, REBCNT index)
-/*
-** Evaluate code block according to the function arg spec.
-** Args are pushed onto the data stack in the same order
-** as the function frame.
-**
-** func: function or path value
-** path: refinements or object/function path
-** block: current evaluation block
-** index: current evaluation index
-**
-***********************************************************************/
-{
- REBVAL *value;
- REBVAL *args;
- REBSER *words;
- REBINT ds = 0; // stack argument position
- REBINT dsp = DSP + 1; // stack base
- REBINT dsf = dsp - DSF_BIAS;
- REBVAL *tos;
-
- if (IS_OP(func)) dsf--; // adjust for extra arg
-
- if ((dsp + 100) > (REBINT)SERIES_REST(DS_Series))
- Trap0(RE_STACK_OVERFLOW); //Expand_Stack();
-
- // Get list of words:
- words = VAL_FUNC_WORDS(func);
- args = BLK_SKIP(words, 1);
- ds = SERIES_TAIL(words)-1; // length of stack fill below
- //Debug_Fmt("Args: %z", VAL_FUNC_ARGS(func));
-
- // If func is operator, first arg is already on stack:
- if (IS_OP(func)) {
- //if (!TYPE_CHECK(args, VAL_TYPE(DS_VALUE(DSP))))
- // Trap3(RE_EXPECT_ARG, Func_Word(dsf), args, Of_Type(DS_VALUE(ds)));
- args++; // skip evaluation, but continue with type check
- ds--; // shorten stack fill below
- }
-
- // Fill stack variables with default values:
- tos = DS_NEXT;
- DSP += ds;
- for (; ds > 0; ds--) SET_NONE(tos++);
-
- // Go thru the word list args:
- ds = dsp;
- for (; NOT_END(args); args++, ds++) {
-
- //if (Trace_Flags) Trace_Arg(ds - dsp, args, path);
-
- // Process each formal argument:
- switch (VAL_TYPE(args)) {
-
- case REB_WORD: // WORD - Evaluate next value
- index = Do_Next(block, index, IS_OP(func));
- // THROWN is handled after the switch.
- if (index == END_FLAG) Trap2(RE_NO_ARG, Func_Word(dsf), args);
- DS_Base[ds] = *DS_POP;
- break;
-
- case REB_LIT_WORD: // 'WORD - Just get next value
- if (index < BLK_LEN(block)) {
- value = BLK_SKIP(block, index);
- if (IS_PAREN(value) || IS_GET_WORD(value) || IS_GET_PATH(value)) {
- index = Do_Next(block, index, IS_OP(func));
- // THROWN is handled after the switch.
- DS_Base[ds] = *DS_POP;
- }
- else {
- index++;
- DS_Base[ds] = *value;
- }
- } else
- SET_UNSET(&DS_Base[ds]); // allowed to be none
- break;
-
- case REB_GET_WORD: // :WORD - Get value
- if (index < BLK_LEN(block)) {
- DS_Base[ds] = *BLK_SKIP(block, index);
- index++;
- } else
- SET_UNSET(&DS_Base[ds]); // allowed to be none
- break;
-/*
- value = BLK_SKIP(block, index);
- index++;
- if (IS_WORD(value) && VAL_WORD_FRAME(value)) value = Get_Var(value);
- DS_Base[ds] = *value;
-*/
- case REB_REFINEMENT: // /WORD - Function refinement
- if (!path || IS_END(path)) return index;
- if (IS_WORD(path)) {
- // Optimize, if the refinement is the next arg:
- if (SAME_SYM(path, args)) {
- SET_TRUE(DS_VALUE(ds)); // set refinement stack value true
- path++; // remove processed refinement
- continue;
- }
- // Refinement out of sequence, resequence arg order:
-more_path:
- ds = dsp;
- args = BLK_SKIP(words, 1);
- for (; NOT_END(args); args++, ds++) {
- if (IS_REFINEMENT(args) && VAL_WORD_CANON(args) == VAL_WORD_CANON(path)) {
- SET_TRUE(DS_VALUE(ds)); // set refinement stack value true
- path++; // remove processed refinement
- break;
- }
- }
- // Was refinement found? If not, error:
- if (IS_END(args)) Trap2(RE_NO_REFINE, Func_Word(dsf), path);
- continue;
- }
- else Trap1(RE_BAD_REFINE, path);
- break;
-
- case REB_SET_WORD: // WORD: - reserved for special features
- default:
- Trap_Arg(args);
- }
-
- if (THROWN(DS_VALUE(ds))) {
- // Store THROWN value in TOS, so that Do_Next can handle it.
- *DS_TOP = *DS_VALUE(ds);
- return index;
- }
-
- // If word is typed, verify correct argument datatype:
- if (!TYPE_CHECK(args, VAL_TYPE(DS_VALUE(ds))))
- Trap3(RE_EXPECT_ARG, Func_Word(dsf), args, Of_Type(DS_VALUE(ds)));
- }
-
- // Hack to process remaining path:
- if (path && NOT_END(path)) goto more_path;
- // Trap2(RE_NO_REFINE, Func_Word(dsf), path);
-
- return index;
-}
-
-
-/***********************************************************************
-**
-*/ void Do_Signals(void)
-/*
-** Special events to process during evaluation.
-** Search for SET_SIGNAL to find them.
-**
-***********************************************************************/
-{
- REBCNT sigs;
- REBCNT mask;
-
- // Accumulate evaluation counter and reset countdown:
- if (Eval_Count <= 0) {
- //Debug_Num("Poll:", (REBINT) Eval_Cycles);
- Eval_Cycles += Eval_Dose - Eval_Count;
- Eval_Count = Eval_Dose;
- if (Eval_Limit != 0 && Eval_Cycles > Eval_Limit)
- Check_Security(SYM_EVAL, POL_EXEC, 0);
- }
-
- if (!(Eval_Signals & Eval_Sigmask)) return;
-
- // Be careful of signal loops! EG: do not PRINT from here.
- sigs = Eval_Signals & (mask = Eval_Sigmask);
- Eval_Sigmask = 0; // avoid infinite loop
- //Debug_Num("Signals:", Eval_Signals);
-
- // Check for recycle signal:
- if (GET_FLAG(sigs, SIG_RECYCLE)) {
- CLR_SIGNAL(SIG_RECYCLE);
- Recycle();
- }
-
-#ifdef NOT_USED_INVESTIGATE
- if (GET_FLAG(sigs, SIG_EVENT_PORT)) { // !!! Why not used?
- CLR_SIGNAL(SIG_EVENT_PORT);
- Awake_Event_Port();
- }
-#endif
-
- // Escape only allowed after MEZZ boot (no handlers):
- if (GET_FLAG(sigs, SIG_ESCAPE) && PG_Boot_Phase >= BOOT_MEZZ) {
- CLR_SIGNAL(SIG_ESCAPE);
- Eval_Sigmask = mask;
- Halt_Code(RE_HALT, 0); // Throws!
- }
-
- Eval_Sigmask = mask;
-}
-
-
-/***********************************************************************
-**
-*/ REBCNT Do_Next(REBSER *block, REBCNT index, REBFLG op)
-/*
-** Evaluate the code block until we have:
-** 1. An irreducible value (return next index)
-** 2. Reached the end of the block (return END_FLAG)
-** 3. Encountered an error
-**
-** Index is a zero-based index into the block.
-** Op indicates infix operator is being evaluated (precedence);
-** The value (or error) is placed on top of the data stack.
-**
-***********************************************************************/
-{
- REBVAL *value;
- REBVAL *word = 0;
- REBINT ftype;
- REBCNT dsf;
-
- //CHECK_MEMORY(1);
- CHECK_STACK(&value);
- if ((DSP + 20) > (REBINT)SERIES_REST(DS_Series)) Expand_Stack(STACK_MIN); //Trap0(RE_STACK_OVERFLOW);
- if (--Eval_Count <= 0 || Eval_Signals) Do_Signals();
-
- value = BLK_SKIP(block, index);
- //if (Trace_Flags) Trace_Eval(block, index);
-
-reval:
- if (Trace_Flags) Trace_Line(block, index, value);
-
- //getchar();
- switch (EVAL_TYPE(value)) {
-
- case ET_WORD:
- value = Get_Var(word = value);
- if (IS_UNSET(value)) Trap1(RE_NO_VALUE, word);
- if (VAL_TYPE(value) >= REB_NATIVE && VAL_TYPE(value) <= REB_FUNCTION) goto reval; // || IS_LIT_PATH(value)
- DS_PUSH(value);
- if (IS_LIT_WORD(value)) VAL_SET(DS_TOP, REB_WORD);
- if (IS_FRAME(value)) Init_Obj_Value(DS_TOP, VAL_WORD_FRAME(word));
- index++;
- break;
-
- case ET_SELF:
- DS_PUSH(value);
- index++;
- break;
-
- case ET_SET_WORD:
- word = value;
- //if (!VAL_WORD_FRAME(word)) Trap1(RE_NOT_DEFINED, word); (checked in set_var)
- index = Do_Next(block, index+1, 0);
- // THROWN is handled in Set_Var.
- if (index == END_FLAG || VAL_TYPE(DS_TOP) <= REB_UNSET) Trap1(RE_NEED_VALUE, word);
- Set_Var(word, DS_TOP);
- //Set_Word(word, DS_TOP); // (value stays on stack)
- //Dump_Frame(Main_Frame);
- break;
-
- case ET_FUNCTION:
-eval_func0:
- ftype = VAL_TYPE(value) - REB_NATIVE; // function type
- if (!word) word = ROOT_NONAME;
- dsf = Push_Func(FALSE, block, index, VAL_WORD_SYM(word), value);
-eval_func:
- value = DSF_FUNC(dsf); // a safe copy of function
- if (VAL_TYPE(value) < REB_NATIVE) {
- Debug_Value(word, 4, 0);
- Dump_Values(value, 4);
- }
- index = Do_Args(value, 0, block, index+1); // uses old DSF, updates DSP
-eval_func2:
- // Evaluate the function:
- DSF = dsf; // Set new DSF
- if (!THROWN(DS_TOP)) {
- if (Trace_Flags) Trace_Func(word, value);
- Func_Dispatch[ftype](value);
- }
- else {
- *DS_RETURN = *DS_TOP;
- }
-
- // Reset the stack to prior function frame, but keep the
- // return value (function result) on the top of the stack.
- DSP = dsf;
- DSF = PRIOR_DSF(dsf);
- if (Trace_Flags) Trace_Return(word, DS_TOP);
-
- // The return value is a FUNC that needs to be re-evaluated.
- if (VAL_GET_OPT(DS_TOP, OPTS_REVAL) && ANY_FUNC(DS_TOP)) {
- value = DS_POP; // WARNING: value is volatile on TOS1 !
- word = Get_Type_Word(VAL_TYPE(value));
- index--; // Backup block index to re-evaluate.
- if (IS_OP(value)) Trap_Type(value); // not allowed
- goto eval_func0;
- }
- break;
-
- case ET_OPERATOR:
- // An operator can be native or function, so its true evaluation
- // datatype is stored in the extended flags part of the value.
- if (!word) word = ROOT_NONAME;
- if (DSP <= 0 || index == 0) Trap1(RE_NO_OP_ARG, word);
- ftype = VAL_GET_EXT(value) - REB_NATIVE;
- dsf = Push_Func(TRUE, block, index, VAL_WORD_SYM(word), value); // TOS has first arg
- DS_PUSH(DS_VALUE(dsf)); // Copy prior to first argument
- goto eval_func;
-
- case ET_PATH: // PATH, SET_PATH
- ftype = VAL_TYPE(value);
- word = value; // a path
- //index++; // now done below with +1
-
- //Debug_Fmt("t: %r", value);
- if (ftype == REB_SET_PATH) {
- index = Do_Next(block, index+1, 0);
- // THROWN is handled in Do_Path.
- if (index == END_FLAG || VAL_TYPE(DS_TOP) <= REB_UNSET) Trap1(RE_NEED_VALUE, word);
- Do_Path(&word, DS_TOP);
- } else {
- // Can be a path or get-path:
- value = Do_Path(&word, 0); // returns in word the path item, DS_TOP has value
- //Debug_Fmt("v: %r", value);
- // Value returned only for functions that need evaluation (but not GET_PATH):
- if (value && ANY_FUNC(value)) {
- if (IS_OP(value)) Trap_Type(value); // (because prior value is wiped out above)
- // Can be object/func or func/refinements or object/func/refinement:
- dsf = Push_Func(TRUE, block, index, VAL_WORD_SYM(word), value); // Do not unset TOS1 (it is the value)
- value = DS_TOP;
- index = Do_Args(value, word+1, block, index+1);
- ftype = VAL_TYPE(value)-REB_NATIVE;
- goto eval_func2;
- } else
- index++;
- }
- break;
-
- case ET_PAREN:
- DO_BLK(value);
- DSP++; // keep it on top
- index++;
- break;
-
- case ET_LIT_WORD:
- DS_PUSH(value);
- VAL_SET(DS_TOP, REB_WORD);
- index++;
- break;
-
- case ET_GET_WORD:
- DS_PUSH(Get_Var(value));
- index++;
- break;
-
- case ET_LIT_PATH:
- DS_PUSH(value);
- VAL_SET(DS_TOP, REB_PATH);
- index++;
- break;
-
- case ET_END:
- return END_FLAG;
-
- default:
- //Debug_Fmt("Bad eval: %d %s", VAL_TYPE(value), Get_Type_Name(value));
- Crash(RP_BAD_EVALTYPE, VAL_TYPE(value));
- //return -index;
- }
-
- // If normal eval (not higher precedence of infix op), check for op:
- if (!op) {
- value = BLK_SKIP(block, index);
- if (IS_WORD(value) && VAL_WORD_FRAME(value) && IS_OP(Get_Var(value)))
- goto reval;
- }
-
- return index;
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Do_Blk(REBSER *block, REBCNT index)
-/*
-** Evaluate a block from the index position specified.
-** Return the result (a pointer to TOS+1).
-**
-***********************************************************************/
-{
- REBVAL *tos = 0;
-#if (ALEVEL>1)
- REBINT start = DSP;
-// REBCNT gcd = GC_Disabled;
-#endif
-
- CHECK_MEMORY(4); // Be sure we don't go far with a problem.
-
- ASSERT1(block->info, RP_GC_OF_BLOCK);
-
- while (index < BLK_LEN(block)) {
- index = Do_Next(block, index, 0);
- tos = DS_POP;
- if (THROWN(tos)) break;
- }
- // If block was empty:
- if (!tos) {tos = DS_NEXT; SET_UNSET(tos);}
-
- if (start != DSP || tos != &DS_Base[start+1]) Trap0(RE_MISSING_ARG);
-
-// ASSERT2(gcd == GC_Disabled, RP_GC_STUCK);
-
- // Restore data stack and return value:
-// ASSERT2((tos == 0 || (start == DSP && tos == &DS_Base[start+1])), RP_TOS_DRIFT);
-// if (!tos) {tos = DS_NEXT; SET_UNSET(tos);}
- return tos;
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Do_Block_Value_Throw(REBVAL *block)
-/*
-** A common form of Do_Blk(). Takes block value. Handles throw.
-**
-***********************************************************************/
-{
- REBSER *series = VAL_SERIES(block);
- REBCNT index = VAL_INDEX(block);
- REBVAL *tos = 0;
- REBINT start = DSP;
-
- while (index < BLK_LEN(series)) {
- index = Do_Next(series, index, 0);
- tos = DS_POP;
- if (THROWN(tos)) Throw_Break(tos);
- }
- // If series was empty:
- if (!tos) {tos = DS_NEXT; SET_UNSET(tos);}
-
- if (start != DSP || tos != &DS_Base[start+1]) Trap0(RE_MISSING_ARG);
-
- return tos;
-}
-
-
-/***********************************************************************
-**
-*/ REBFLG Try_Block(REBSER *block, REBCNT index)
-/*
-** Evaluate a block from the index position specified in the value.
-** TOS+1 holds the result.
-**
-***********************************************************************/
-{
- REBOL_STATE state;
- REBVAL *tos;
-
- PUSH_STATE(state, Saved_State);
- if (SET_JUMP(state)) {
- POP_STATE(state, Saved_State);
- Catch_Error(DS_NEXT); // Stores error value here
- return TRUE;
- }
- SET_STATE(state, Saved_State);
-
- tos = 0;
- while (index < BLK_LEN(block)) {
- index = Do_Next(block, index, 0);
- tos = DS_POP;
- if (THROWN(tos)) break;
- }
- if (!tos) {tos = DS_NEXT; SET_UNSET(tos);}
-
- // Restore data stack and return value at TOS+1:
- DS_Base[state.dsp+1] = *tos;
- POP_STATE(state, Saved_State);
-
- return FALSE;
-}
-
-
-/***********************************************************************
-**
-*/ void Reduce_Block(REBSER *block, REBCNT index, REBVAL *into)
-/*
-** Reduce block from the index position specified in the value.
-** Collect all values from stack and make them a block.
-**
-***********************************************************************/
-{
- REBINT start = DSP + 1;
-
- while (index < BLK_LEN(block)) {
- index = Do_Next(block, index, 0);
- if (THROWN(DS_TOP)) return;
- }
-
- Copy_Stack_Values(start, into);
-}
-
-
-/***********************************************************************
-**
-*/ void Reduce_Only(REBSER *block, REBCNT index, REBVAL *words, REBVAL *into)
-/*
-** Reduce only words and paths not found in word list.
-**
-***********************************************************************/
-{
- REBINT start = DSP + 1;
- REBVAL *val;
- REBVAL *v;
- REBSER *ser = 0;
- REBCNT idx = 0;
-
- if (IS_BLOCK(words)) {
- ser = VAL_SERIES(words);
- idx = VAL_INDEX(words);
- }
-
- for (val = BLK_SKIP(block, index); NOT_END(val); val++) {
- if (IS_WORD(val)) {
- // Check for keyword:
- if (ser && NOT_FOUND != Find_Word(ser, idx, VAL_WORD_CANON(val))) {
- DS_PUSH(val);
- continue;
- }
- v = Get_Var(val);
- DS_PUSH(v);
- }
- else if (IS_PATH(val)) {
- if (ser) {
- // Check for keyword/path:
- v = VAL_BLK_DATA(val);
- if (IS_WORD(v)) {
- if (NOT_FOUND != Find_Word(ser, idx, VAL_WORD_CANON(v))) {
- DS_PUSH(val);
- continue;
- }
- }
- }
- v = val;
- Do_Path(&v, 0); // pushes val on stack
- }
- else DS_PUSH(val);
- // No need to check for unwinds (THROWN) here, because unwinds should
- // never be accessible via words or paths.
- }
-
- Copy_Stack_Values(start, into);
-}
-
-
-/***********************************************************************
-**
-*/ void Reduce_Block_No_Set(REBSER *block, REBCNT index, REBVAL *into)
-/*
-***********************************************************************/
-{
- REBINT start = DSP + 1;
- REBVAL *val;
-
- while (index < BLK_LEN(block)) {
- if (IS_SET_WORD(val = BLK_SKIP(block, index))) {
- DS_PUSH(val);
- index++;
- } else
- index = Do_Next(block, index, 0);
- if (THROWN(DS_TOP)) return;
- }
-
- Copy_Stack_Values(start, into);
-}
-
-
-/***********************************************************************
-**
-*/ void Reduce_Type_Stack(REBSER *block, REBCNT index, REBCNT type)
-/*
-** Reduce a block of words/paths that are of the specified type.
-** Return them on the stack. The change in TOS is the length.
-**
-***********************************************************************/
-{
- //REBINT start = DSP + 1;
- REBVAL *val;
- REBVAL *v;
-
- // Lookup words and paths and push values on stack:
- for (val = BLK_SKIP(block, index); NOT_END(val); val++) {
- if (IS_WORD(val)) {
- v = Get_Var(val);
- if (VAL_TYPE(v) == type) DS_PUSH(v);
- }
- else if (IS_PATH(val)) {
- v = val;
- if (!Do_Path(&v, 0)) { // pushes val on stack
- if (VAL_TYPE(DS_TOP) != type) DS_DROP;
- }
- }
- else if (VAL_TYPE(val) == type) DS_PUSH(val);
- // !!! check stack size
- }
- SET_END(&DS_Base[++DSP]); // in case caller needs it
-
- //block = Copy_Values(DS_Base + start, DSP - start + 1);
- //DSP = start;
- //return block;
-}
-
-
-/***********************************************************************
-**
-*/ void Reduce_In_Frame(REBSER *frame, REBVAL *values)
-/*
-** Reduce a block with simple lookup in the context.
-** Only words in that context are valid (e.g. error object).
-** All values are left on the stack. No copy is made.
-**
-***********************************************************************/
-{
- REBVAL *val;
-
- for (; NOT_END(values); values++) {
- switch (VAL_TYPE(values)) {
- case REB_WORD:
- case REB_SET_WORD:
- case REB_GET_WORD:
- if (NZ(val = Find_Word_Value(frame, VAL_WORD_SYM(values)))) {
- DS_PUSH(val);
- break;
- } // Unknown in context, fall below, use word as value.
- case REB_LIT_WORD:
- DS_PUSH(values);
- VAL_SET(DS_TOP, REB_WORD);
- break;
- default:
- DS_PUSH(values);
- }
- }
-}
-
-
-/***********************************************************************
-**
-*/ void Compose_Block(REBVAL *block, REBFLG deep, REBFLG only, REBVAL *into)
-/*
-** Compose a block from a block of un-evaluated values and
-** paren blocks that are evaluated. Stack holds temp values,
-** which also protects them from GC along the way.
-**
-** deep - recurse into sub-blocks
-** only - parens that return blocks are kept as blocks
-**
-** Returns result as a block on top of stack.
-**
-***********************************************************************/
-{
- REBVAL *value;
- REBINT start = DSP + 1;
-
- for (value = VAL_BLK_DATA(block); NOT_END(value); value++) {
- if (IS_PAREN(value)) {
- // Eval the paren, and leave result on the stack:
- DO_BLK(value);
- DSP++; // !!!DSP temp
- if (THROWN(DS_TOP)) return;
-
- // If result is a block, and not /only, insert its contents:
- if (IS_BLOCK(DS_TOP) && !only) {
- // Append series to the stack:
- SERIES_TAIL(DS_Series) = DSP; // overwrites TOP value
- Append_Series(DS_Series, (REBYTE *)VAL_BLK_DATA(DS_TOP), VAL_BLK_LEN(DS_TOP));
- DSP = SERIES_TAIL(DS_Series) - 1;
- // Note: stack may have moved
- }
- else if (IS_UNSET(DS_TOP)) DS_DROP; // remove unset values
- }
- else if (deep) {
- if (IS_BLOCK(value)) Compose_Block(value, TRUE, only, 0);
- else {
- DS_PUSH(value);
- if (ANY_BLOCK(value)) // Include PATHS
- VAL_SERIES(DS_TOP) = Copy_Block(VAL_SERIES(value), 0);
- }
- }
- else DS_PUSH(value);
- }
-
- Copy_Stack_Values(start, into);
-}
-
-
-/***********************************************************************
-**
-*/ void Apply_Block(REBVAL *func, REBVAL *args, REBFLG reduce)
-/*
-** Result is on top of stack.
-**
-***********************************************************************/
-{
- REBINT ftype = VAL_TYPE(func) - REB_NATIVE; // function type
- REBSER *block = VAL_SERIES(args);
- REBCNT index = VAL_INDEX(args);
- REBCNT dsf;
-
- REBSER *words;
- REBINT len;
- REBINT n;
- REBINT start;
- REBVAL *val;
-
- if (index > SERIES_TAIL(block)) index = SERIES_TAIL(block);
-
- // Push function frame:
- dsf = Push_Func(0, block, index, 0, func);
- func = DSF_FUNC(dsf); // for safety
-
- // Determine total number of args:
- words = VAL_FUNC_WORDS(func);
- len = words ? SERIES_TAIL(words)-1 : 0;
- start = DSP+1;
-
- // Gather arguments:
- if (reduce) {
- // Reduce block contents to stack:
- n = 0;
- while (index < BLK_LEN(block)) {
- index = Do_Next(block, index, 0);
- if (THROWN(DS_TOP)) return;
- n++;
- }
- if (n > len) DSP = start + len;
- }
- else {
- // Copy block contents to stack:
- n = VAL_BLK_LEN(args);
- if (len < n) n = len;
- memcpy(&DS_Base[start], BLK_SKIP(block, index), n * sizeof(REBVAL));
- DSP = start + n - 1;
- }
-
- // Pad out missing args:
- for (; n < len; n++) DS_PUSH_NONE;
-
- // Validate arguments:
- if (words) {
- val = DS_Base + start;
- for (args = BLK_SKIP(words, 1); NOT_END(args);) {
- // If arg is refinement, determine its state:
- if (IS_REFINEMENT(args)) {
- if (IS_FALSE(val)) {
- SET_NONE(val); // ++ ok for none
- while (TRUE) {
- val++;
- args++;
- if (IS_END(args) || IS_REFINEMENT(args)) break;
- SET_NONE(val);
- }
- continue;
- }
- SET_TRUE(val);
- }
- // If arg is typed, verify correct argument datatype:
- if (!TYPE_CHECK(args, VAL_TYPE(val)))
- Trap3(RE_EXPECT_ARG, Func_Word(dsf), args, Of_Type(val));
- args++;
- val++;
- }
- }
-
- // Evaluate the function:
- DSF = dsf;
- Func_Dispatch[ftype](func);
- DSP = dsf;
- DSF = PRIOR_DSF(dsf);
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Apply_Function(REBSER *wblk, REBCNT widx, REBVAL *func, va_list args)
-/*
-** Applies function from args provided by C call. Zero terminated.
-** Result is EXTREMELY VOLATILE - a stack value above the DSP.
-**
-** wblk - where block (where we were called)
-** widx - where index (position in above block)
-** func - function to call
-** args - list of function args (null terminated)
-**
-***********************************************************************/
-{
- REBCNT dsf;
- REBSER *words;
- REBCNT ds;
- REBVAL *arg;
-
- dsf = Push_Func(0, wblk, widx, 0, func);
- func = DSF_FUNC(dsf); // for safety
- words = VAL_FUNC_WORDS(func);
- ds = SERIES_TAIL(words)-1; // length of stack fill below
-
- // Gather arguments from C stack:
- for (; ds > 0; ds--) {
- arg = va_arg(args, REBVAL*); // get value
- if (arg) DS_PUSH(arg); // push it; no type check
- else break;
- }
- for (; ds > 0; ds--) DS_PUSH_NONE; // unused slots
-
- // Evaluate the function:
- DSF = dsf;
- Func_Dispatch[VAL_TYPE(func) - REB_NATIVE](func);
- DSF = PRIOR_DSF(dsf);
- DSP = dsf-1;
-
- // Return resulting value from TOS1. But note:
- // EXTREMELY VOLATILE - use or copy quickly
- // before next evaluation, GC, or anything else!
- return DS_VALUE(dsf);
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Apply_Func(REBSER *where, REBVAL *func, ...)
-/*
-** Applies function from args provided by C call. Zero terminated.
-** Result is EXTREMELY VOLATILE - a stack value above the DSP.
-**
-***********************************************************************/
-{
- REBVAL *value;
- va_list args;
-
- if (!ANY_FUNC(func)) Trap_Arg(func);
- if (!where) where = VAL_FUNC_BODY(func); // something/anything ?!!
-
- va_start(args, func);
- value = Apply_Function(where, 0, func, args);
- va_end(args);
-
- return value;
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Do_Sys_Func(REBCNT inum, ...)
-/*
-** Evaluates a SYS function and TOS1 contains
-** the result (VOLATILE). Uses current stack frame location
-** as the next location (e.g. for error output).
-**
-***********************************************************************/
-{
- REBVAL *value;
- va_list args;
- REBSER *blk = 0;
- REBCNT idx = 0;
-
- if (DSF) {
- value = DSF_BACK(DSF);
- blk = VAL_SERIES(value);
- idx = VAL_INDEX(value);
- }
-
- value = FRM_VALUE(Sys_Context, inum);
- if (!ANY_FUNC(value)) Trap1(RE_BAD_SYS_FUNC, value);
- if (!DSF) blk = VAL_FUNC_BODY(value);
-
- va_start(args, inum);
- value = Apply_Function(blk, idx, value, args);
- va_end(args);
-
- return value;
-}
-
-
-/***********************************************************************
-**
-*/ void Do_Construct(REBVAL *value)
-/*
-** Do a block with minimal evaluation and no evaluation of
-** functions. Used for things like script headers where security
-** is important.
-**
-** Handles cascading set words: word1: word2: value
-**
-***********************************************************************/
-{
- REBVAL *temp;
- REBINT ssp; // starting stack pointer
-
- DS_PUSH_NONE;
- temp = DS_TOP;
- ssp = DSP;
-
- for (; NOT_END(value); value++) {
- if (IS_SET_WORD(value)) {
- // Next line not needed, because SET words are ALWAYS in frame.
- //if (VAL_WORD_INDEX(value) > 0 && VAL_WORD_FRAME(value) == frame)
- DS_PUSH(value);
- } else {
- // Get value:
- if (IS_WORD(value)) {
- switch (VAL_WORD_CANON(value)) {
- case SYM_NONE:
- SET_NONE(temp);
- break;
- case SYM_TRUE:
- case SYM_ON:
- case SYM_YES:
- SET_TRUE(temp);
- break;
- case SYM_FALSE:
- case SYM_OFF:
- case SYM_NO:
- SET_FALSE(temp);
- break;
- default:
- *temp = *value;
- VAL_SET(temp, REB_WORD);
- }
- }
- else if (IS_LIT_WORD(value)) {
- *temp = *value;
- VAL_SET(temp, REB_WORD);
- }
- else if (IS_LIT_PATH(value)) {
- *temp = *value;
- VAL_SET(temp, REB_PATH);
- }
- else if (VAL_TYPE(value) >= REB_NONE) { // all valid values
- *temp = *value;
- }
- else
- SET_NONE(temp);
-
- // Set prior set-words:
- while (DSP > ssp) {
- Set_Var(DS_TOP, temp);
- DS_DROP;
- }
- }
- }
- DS_DROP; // temp
-}
-
-
-/***********************************************************************
-**
-*/ void Do_Min_Construct(REBVAL *value)
-/*
-** Do no evaluation of the set values.
-**
-***********************************************************************/
-{
- REBVAL *temp;
- REBINT ssp; // starting stack pointer
-
- DS_PUSH_NONE;
- temp = DS_TOP;
- ssp = DSP;
-
- for (; NOT_END(value); value++) {
- if (IS_SET_WORD(value)) {
- // Next line not needed, because SET words are ALWAYS in frame.
- //if (VAL_WORD_INDEX(value) > 0 && VAL_WORD_FRAME(value) == frame)
- DS_PUSH(value);
- } else {
- // Get value:
- *temp = *value;
- // Set prior set-words:
- while (DSP > ssp) {
- Set_Var(DS_TOP, temp);
- DS_DROP;
- }
- }
- }
- DS_DROP; // temp
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Do_Bind_Block(REBSER *frame, REBVAL *block)
-/*
-** Bind deep and evaluate a block value in a given context.
-** Result is left on top of data stack (may be an error).
-**
-***********************************************************************/
-{
- Bind_Block(frame, VAL_BLK_DATA(block), BIND_DEEP);
- return DO_BLK(block);
-}
-
-
-/***********************************************************************
-**
-*/ void Reduce_Bind_Block(REBSER *frame, REBVAL *block, REBCNT binding)
-/*
-** Bind deep and reduce a block value in a given context.
-** Result is left on top of data stack (may be an error).
-**
-***********************************************************************/
-{
- Bind_Block(frame, VAL_BLK_DATA(block), binding);
- Reduce_Block(VAL_SERIES(block), VAL_INDEX(block), 0);
-}
-
-
-/***********************************************************************
-**
-*/ REBOOL Try_Block_Halt(REBSER *block, REBCNT index)
-/*
-** Evaluate a block from the index position specified in the value,
-** with a handler for quit conditions (QUIT, HALT) set up.
-**
-***********************************************************************/
-{
- REBOL_STATE state;
- REBVAL *val;
-// static D = 0;
-// int depth = D++;
-
-// Debug_Fmt("Set Halt %d", depth);
-
- PUSH_STATE(state, Halt_State);
- if (SET_JUMP(state)) {
-// Debug_Fmt("Throw Halt %d", depth);
- POP_STATE(state, Halt_State);
- Catch_Error(DS_NEXT); // Stores error value here
- return TRUE;
- }
- SET_STATE(state, Halt_State);
-
- SAVE_SERIES(block);
- val = Do_Blk(block, index);
- UNSAVE_SERIES(block);
-
- DS_Base[state.dsp+1] = *val;
- POP_STATE(state, Halt_State);
-
-// Debug_Fmt("Ret Halt %d", depth);
-
- return FALSE;
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Do_String(REBYTE *text, REBCNT flags)
-/*
-** Do a string. Convert it to code, then evaluate it with
-** the ability to catch errors and also alow HALT if needed.
-**
-***********************************************************************/
-{
- REBOL_STATE state;
- REBSER *code;
- REBVAL *val;
- REBSER *rc;
- REBCNT len;
- REBVAL vali;
-
- PUSH_STATE(state, Halt_State);
- if (SET_JUMP(state)) {
- POP_STATE(state, Halt_State);
- Saved_State = Halt_State;
- Catch_Error(DS_NEXT); // Stores error value here
- val = Get_System(SYS_STATE, STATE_LAST_ERROR); // Save it for EXPLAIN
- *val = *DS_NEXT;
- if (VAL_ERR_NUM(val) == RE_QUIT) {
- OS_EXIT(VAL_INT32(VAL_ERR_VALUE(DS_NEXT))); // console quit
- }
- return val;
- }
- SET_STATE(state, Halt_State);
- // Use this handler for both, halt conditions (QUIT, HALT) and error
- // conditions. As this is a top-level handler, simply overwriting
- // Saved_State is safe.
- Saved_State = Halt_State;
-
- code = Scan_Source(text, LEN_BYTES(text));
- SAVE_SERIES(code);
-
- // Bind into lib or user spaces?
- if (flags) {
- // Top words will be added to lib:
- Bind_Block(Lib_Context, BLK_HEAD(code), BIND_SET);
- Bind_Block(Lib_Context, BLK_HEAD(code), BIND_DEEP);
- }
- else {
- rc = VAL_OBJ_FRAME(Get_System(SYS_CONTEXTS, CTX_USER));
- len = rc->tail;
- Bind_Block(rc, BLK_HEAD(code), BIND_ALL | BIND_DEEP);
- SET_INTEGER(&vali, len);
- Resolve_Context(rc, Lib_Context, &vali, FALSE, 0);
- }
-
- Do_Blk(code, 0);
- UNSAVE_SERIES(code);
-
- POP_STATE(state, Halt_State);
- Saved_State = Halt_State;
-
- return DS_NEXT; // result is volatile
-}
-
-
-/***********************************************************************
-**
-*/ void Halt_Code(REBINT kind, REBVAL *arg)
-/*
-** Halts execution by throwing back to the above Do_String.
-** Kind is RE_HALT or RE_QUIT
-** Arg is the optional return value.
-**
-** Future versions may not reset the stack, but leave it as is
-** to allow for examination and a RESUME operation.
-**
-***********************************************************************/
-{
- REBVAL *err = TASK_THIS_ERROR;
-
- if (!Halt_State) return;
-
- if (arg) {
- if (IS_NONE(arg)) {
- SET_INTEGER(TASK_THIS_VALUE, 0);
- } else
- *TASK_THIS_VALUE = *arg; // save the value
- } else {
- SET_NONE(TASK_THIS_VALUE);
- }
-
- VAL_SET(err, REB_ERROR);
- VAL_ERR_NUM(err) = kind;
- VAL_ERR_VALUE(err) = TASK_THIS_VALUE;
- VAL_ERR_SYM(err) = 0;
-
- longjmp(*Halt_State, 1);
-}
-
-
-/***********************************************************************
-**
-*/ void Call_Func(REBVAL *func_val)
-/*
-** Calls a REBOL function from C code.
-**
-** Setup:
-** Before calling this, the caller must setup the stack and
-** provide the function arguments on the stack. Any missing
-** args will be set to NONE.
-**
-** Return:
-** On return, the stack remains as-is. The caller must reset
-** the DSP and DSF values.
-**
-***********************************************************************/
-{
- REBINT n;
-
- // Caller must: Prep_Func + Args above
- VAL_WORD_FRAME(DSF_WORD(DSF)) = VAL_FUNC_ARGS(func_val);
- n = DS_ARGC - (SERIES_TAIL(VAL_FUNC_WORDS(func_val)) - 1);
- for (; n > 0; n--) DS_PUSH_NONE;
- Func_Dispatch[VAL_TYPE(func_val)-REB_NATIVE](func_val);
- // Caller must: pop stack back
-}
-
-
-/***********************************************************************
-**
-*/ void Redo_Func(REBVAL *func_val)
-/*
-** Trampoline a function, restacking arguments as needed.
-**
-** Setup:
-** The source for arguments is the existing stack frame,
-** or a prior stack frame. (Prep_Func + Args)
-**
-** Return:
-** On return, the stack remains as-is. The caller must reset
-** the DSP and DSF values.
-**
-***********************************************************************/
-{
- REBSER *wsrc; // words of source func
- REBSER *wnew; // words of target func
- REBCNT isrc; // index position in source frame
- REBCNT inew; // index position in target frame
- REBVAL *word;
- REBVAL *word2;
-
- //!!! NEEDS to check stack for overflow
- //!!! Should check datatypes for new arg passing!
-
- wsrc = VAL_FUNC_WORDS(DSF_FUNC(DSF));
- wnew = VAL_FUNC_WORDS(func_val);
-
- // Foreach arg of the target, copy to source until refinement.
- for (isrc = inew = 1; inew < BLK_LEN(wnew); inew++, isrc++) {
- word = BLK_SKIP(wnew, inew);
- if (isrc > BLK_LEN(wsrc)) isrc = BLK_LEN(wsrc);
-
- switch (VAL_TYPE(word)) {
- case REB_WORD:
- case REB_LIT_WORD:
- case REB_GET_WORD:
- if (VAL_TYPE(word) == VAL_TYPE(BLK_SKIP(wsrc, isrc))) break;
- DS_PUSH_NONE;
- continue;
- //Trap_Arg(word);
-
- // At refinement, search for it in source, then continue with words.
- case REB_REFINEMENT:
- // Are we aligned on the refinement already? (a common case)
- word2 = BLK_SKIP(wsrc, isrc);
- if (!(IS_REFINEMENT(word2) && VAL_BIND_CANON(word2) == VAL_BIND_CANON(word))) {
- // No, we need to search for it:
- for (isrc = 1; isrc < BLK_LEN(wsrc); isrc++) {
- word2 = BLK_SKIP(wsrc, isrc);
- if (IS_REFINEMENT(word2) && VAL_BIND_CANON(word2) == VAL_BIND_CANON(word)) goto push_arg;
- }
- DS_PUSH_NONE;
- continue;
- //if (isrc >= BLK_LEN(wsrc)) Trap_Arg(word);
- }
- break;
-
- default:
- ASSERT1(FALSE, RP_ASSERTS);
- }
-push_arg:
- DS_PUSH(DSF_ARGS(DSF, isrc));
- //Debug_Fmt("Arg %d -> %d", isrc, inew);
- }
-
- // Copy values to prior location:
- inew--;
- // memory areas may overlap, so use memmove and not memcpy!
- memmove(DS_ARG(1), DS_TOP-(inew-1), inew * sizeof(REBVAL));
- DSP = DS_ARG_BASE + inew; // new TOS
- //Dump_Block(DS_ARG(1), inew);
- VAL_WORD_FRAME(DSF_WORD(DSF)) = VAL_FUNC_ARGS(func_val);
- *DSF_FUNC(DSF) = *func_val;
- Func_Dispatch[VAL_TYPE(func_val)-REB_NATIVE](func_val);
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Get_Simple_Value(REBVAL *val)
-/*
-** Does easy lookup, else just returns the value as is.
-** Note for paths value is left on stack.
-**
-***********************************************************************/
-{
- if (IS_WORD(val) || IS_GET_WORD(val))
- val = Get_Var(val);
- else if (IS_PATH(val) || IS_GET_PATH(val)) { //val = Get_Path_Var(val);
- REBVAL *v = val;
- DS_PUSH_NONE;
- Do_Path(&v, 0);
- val = DS_TOP;
- }
-
- return val;
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Resolve_Path(REBVAL *path, REBCNT *index)
-/*
-** Given a path, return a context and index for its terminal.
-**
-***********************************************************************/
-{
- REBVAL *sel; // selector
- REBVAL *val;
- REBSER *blk;
- REBCNT i;
-
- if (VAL_TAIL(path) < 2) return 0;
- blk = VAL_SERIES(path);
- sel = BLK_HEAD(blk);
- if (!ANY_WORD(sel)) return 0;
- val = Get_Var(sel);
-
- sel = BLK_SKIP(blk, 1);
- while (TRUE) {
- if (!ANY_OBJECT(val) || !IS_WORD(sel)) return 0;
- i = Find_Word_Index(VAL_OBJ_FRAME(val), VAL_WORD_SYM(sel), FALSE);
- sel++;
- if (IS_END(sel)) {
- *index = i;
- return VAL_OBJ_FRAME(val);
- }
- }
-
- return 0; // never happens
-}
-
-
-#ifdef obsolete
-/***********************************************************************
-**
-xx*/ REBVAL *Call_Action(REBVAL *word, REBVAL *data, REBCNT act, REBSER *blk, REBCNT i)
-/*
-** Calls datatype action with a value and argument.
-** Value is saved on top of stack.
-**
-***********************************************************************/
-{
- REBVAL *ds;
-
- DSF = Push_Func(TRUE, blk, i, VAL_WORD_SYM(word), 0);
- DS_RELOAD(ds);
- *D_ARG(1) = *data;
- *D_ARG(2) = *BLK_SKIP(blk, i);
- Do_Act(D_RET, VAL_TYPE(data), act); // (properly handles returns)
- DSP = DSF;
- DSF = VAL_BACK(DS_NEXT);
- return DS_TOP;
-}
-
-
-/***********************************************************************
-**
-xx*/ REBVAL *Get_Path_Var(REBVAL *path)
-/*
-** Leaves result on top of stack.
-**
-***********************************************************************/
-{
- REBVAL *word;
- REBVAL *val;
- REBSER *blk;
- REBCNT i;
-
- if (VAL_TAIL(path) < 2) Trap1(RE_INVALID_PATH, path); // empty path
-
- blk = VAL_SERIES(path);
- word = BLK_HEAD(blk);
- if (!ANY_WORD(word)) Trap1(RE_INVALID_PATH, path);
-
- val = Get_Var(word);
-
- for (i = 1; i < blk->tail; i++) {
- val = Call_Action(word, val, A_PATH, blk, i); // result is on TOS
- }
-
- return val;
-}
-
-
-/***********************************************************************
-**
-x*/ REBVAL *Do_Path(REBVAL **ppath, REBSER *block, REBCNT *index)
-/*
-** Evaluate a path.
-**
-***********************************************************************/
-{
- REBVAL *path = *ppath;
- REBVAL *orig = *ppath;
- REBVAL *value;
- REBVAL *selector;
- REBINT dsp;
- REBINT act;
- REBVAL *ds;
-
- if (VAL_TAIL(path) == 0) Trap1(RE_INVALID_PATH, path); // empty path
- path = *ppath = VAL_BLK_DATA(path);
- if (!ANY_WORD(path)) Trap1(RE_INVALID_PATH, orig);
- value = Get_Var(path);
- if (IS_UNSET(value)) Trap1(RE_NO_VALUE, path);
- if (ANY_FUNC(value)) {
- DS_PUSH(value);
- value = DS_TOP;
- return value;
- }
-
- // Call the PATH action for the datatype.
- if (!index) act = 0, index = &act; // Fudge a reference
- DSF = Push_Func(FALSE, block ? block : VAL_SERIES(*ppath), *index, VAL_WORD_SYM(path), 0);
- DS_PUSH_NONE; // Path dispatch value (from earlier evaluation)
- DS_PUSH_NONE; // Argument to A_PATH action
- dsp = DSP;
-
- // Note: above, the backtrace word should not be bound, or it could
- // cause Get_Var() to use the wrong frame for relative values. So,
- // to avoid that, we remove the frame from that word.
-
- for (path++; NOT_END(path); path++) {
-
- DSP = dsp; // Be sure stack does not grow
- act = A_PATH;
-
- // word/:field case
- if (IS_GET_WORD(path)) {
- // !!! need to add word/:field: case
- selector = Get_Var(path); // The object/:word case
- }
- // word/field: case
- else if (IS_SET_PATH(orig) && IS_END(path+1)) {
- if (!block) break; // evaluating singular path (e.g. in PARSE)
- //if (!IS_END(path+1)) Trap1(RE_INVALID_PATH, orig);
- selector = path;
- act = A_PATH_SET;
- *index = Do_Next(block, *index, 0);
- if (IS_UNSET(DS_TOP)) Trap1(RE_NEED_VALUE, orig);
- if (THROWN(DS_TOP)) {
- value = DS_TOP; // stop, return !!! protected?
- break;
- }
- // Leave value on top of stack for PATH SET.
- }
- // word/(expr) case
- else if (IS_PAREN(path)) {
- if (!block) Trap1(RE_NEED_VALUE, orig); // !!! not correct error
- selector = DO_BLK(path);
- }
- // The object/word and object/value default case:
- else selector = path;
-
- // Special case for BLOCK access:
- DS_RELOAD(ds);
- if (ANY_BLOCK(value)) {
- value = Pick_Block(value, selector);
- if (!value) {
- if (act == A_PATH_SET) Trap_Range(selector);
- SET_NONE(D_RET);
- value = D_RET;
- }
- if (act == A_PATH_SET) {
- *D_RET = *value = *D_ARG(3); // !!!! must check PROTECT flag!!!!!!!!!!
- value = D_RET;
- }
- }
- else {
- // Call the A_PATH action for the given value:
- *D_ARG(1) = *value;
- *D_ARG(2) = *selector;
- // D_ARG(3) too when PATH SET.
- Do_Act(ds, VAL_TYPE(value), act); // (properly handles returns)
- DS_RELOAD(ds);
- // All scalars must be written back to their storage areas:
- if (IS_SET_PATH(orig) && (IS_SCALAR(value) || IS_EVENT(value))) { //act == A_PATH_SET
- *value = *D_RET; // !!!! must check PROTECT flag!!!!!!!!!!
- *D_RET = *D_ARG(3); // return the value of the set
- }
- value = D_RET; // not GC protected after stack restore
- }
- if (ANY_FUNC(value)) break; // evaluate
- }
-
- //ASSERT(DSF == dsf);
- DSP = DSF;
- DSF = VAL_BACK(DS_NEXT);
-
- *ppath = path;
- *DS_TOP = *value; // should not be needed!
- return value;
-}
-
-/***********************************************************************
-**
-xx*/ REBVAL *Do_Path(REBVAL **path_val, REBVAL *val)
-/*
-** Evaluate a path value.
-** If val is not zero, set path to that new value.
-**
-** Args to PD_* func:
-** Data: refernce value - can be modified
-** Sel: any value
-** Val: 0 or temp value on stack
-**
-** Stack:
-** TOS-1: val (or not used)
-** TOS: none
-**
-** Call the PD_function
-**
-** Result code:
-** tos (tos has value)
-** none
-** error - invalid path
-**
-***********************************************************************/
-{
- REBVAL *orig = *path_val;
- REBVAL *path;
- REBVAL *value;
- REBVAL *selector;
- REBPEF func;
-
- // Get first block value:
- *path_val = path = VAL_BLK_DATA(orig);
- if (!ANY_WORD(path)) Trap1(RE_INVALID_PATH, orig, path);
-
- // Lookup the value of the variable:
- value = Get_Var(path);
- if (IS_UNSET(value)) Trap1(RE_NO_VALUE, path);
- *DS_TOP = *value;
-
- // Foreach value in path:
- while (TRUE) {
-
- // It is a function, return now:
- if (ANY_FUNC(value)) {
- if (IS_GET_PATH(orig)) return 0;
- *path_val = path; // return the function name
- return DS_TOP;
- }
-
- if (IS_END(++path)) return 0;
-
- // object/:field case:
- if (IS_GET_WORD(path)) {
- selector = Get_Var(path);
- if (IS_UNSET(selector)) Trap1(RE_NO_VALUE, path);
- }
- // object/(expr) case:
- else if (IS_PAREN(path)) {
- selector = Do_Blk(VAL_SERIES(path), 0);
- }
- else // object/word and object/value case:
- selector = path;
-
- func = Path_Dispatch[VAL_TYPE(value)];
- if (!func) Trap1(RE_BAD_PATH, orig);
-
- if (NOT_END(path+1)) {
- // Call datatype value with the given selector.
- // It may return an object to continue.
- value = func(value, selector, 0); // can modify DS_TOP
- if (!value) Trap1(RE_INVALID_PATH, orig, path);
- } else {
- // This is the last field of the path. If val is
- // given then the func sets the value of the field.
- value = func(value, selector, val); // val can be zero
- if (!value) break; // done (field was set)
- *DS_TOP = *value;
- if (!ANY_FUNC(value)) break; // done
- // Now, use code at top of loop for FUNC
- }
- }
-
- return 0;
-}
-
-#endif
-
-/***********************************************************************
-**
-*/ REBINT Init_Mezz(REBINT reserved)
-/*
-***********************************************************************/
-{
- REBINT result = 0;
- //REBVAL *val;
- REBOL_STATE state;
- REBVAL *val;
- int MERGE_WITH_Do_String;
-// static D = 0;
-// int depth = D++;
-
- //Debug_Fmt("Set Halt");
-
- if (PG_Boot_Level >= BOOT_LEVEL_MODS) {
-
- PUSH_STATE(state, Halt_State);
- if (SET_JUMP(state)) {
- //Debug_Fmt("Throw Halt");
- POP_STATE(state, Halt_State);
- Saved_State = Halt_State;
- Catch_Error(val = DS_NEXT); // Stores error value here
- if (IS_ERROR(val)) { // (what else could it be?)
- val = Get_System(SYS_STATE, STATE_LAST_ERROR); // Save it for EXPLAIN
- *val = *DS_NEXT;
- if (VAL_ERR_NUM(val) == RE_QUIT) {
- //Debug_Fmt("Quit(init)");
- OS_EXIT(VAL_INT32(VAL_ERR_VALUE(val))); // console quit
- }
- if (VAL_ERR_NUM(val) >= RE_THROW_MAX)
- Print_Value(val, 1000, FALSE);
- }
- return -1;
- }
- SET_STATE(state, Halt_State);
- // Use this handler for both, halt conditions (QUIT, HALT) and error
- // conditions. As this is a top-level handler, simply overwriting
- // Saved_State is safe.
- Saved_State = Halt_State;
-
- val = Do_Sys_Func(SYS_CTX_START, 0); // what if script contains a HALT?
-
- if (IS_INTEGER(val)) result = VAL_INT32(val);
- //if (Try_Block_Halt(VAL_SERIES(ROOT_SCRIPT), 0)) {
-
- //DS_Base[state.dsp+1] = *val;
- POP_STATE(state, Halt_State);
- Saved_State = Halt_State;
- }
-
- // Cleanup stack and memory:
- DS_RESET;
- Recycle();
- return 0; //result;
-}
diff --git a/src/core/c-error.c b/src/core/c-error.c
index d2acdee33a..166854275a 100644
--- a/src/core/c-error.c
+++ b/src/core/c-error.c
@@ -1,835 +1,1692 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: c-error.c
-** Summary: error handling
-** Section: core
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-/*
- The Trap() functions are used for errors within the C code.
-
- TrapN() provides simple trampoline to the var-arg Make_Error()
- that constructs a new error object.
-
- The Make_Error function uses the error category objects to
- convert from an error code (integer) to error words and strings.
- Other important state information such as location of error
- and function context are also saved at this point.
-
- Throw_Error is called to throw the error back to a prior catch.
- A catch is defined using a set of C-macros. During the throw
- the error object is stored in a global: This_Error (because we
- cannot be sure that the longjmp value is able to hold a pointer
- on 64bit CPUs.)
-
- On the catch side, the Catch_Error function takes the error
- object and stores it into the value provided (normally on the
- DStack).
-
- Catch_Error can be extended to provide a debugging breakpoint
- for examining the call trace and context frames on the stack.
-*/
-/*
-
- Error Handling
-
- Errors occur in two places:
-
- 1. evaluation of natives and actions
- 2. evaluation of a block
-
- When an error occurs, an error object is built and thrown back to
- the nearest prior catch function. The catch is a longjmp that was
- set by a TRY or similar native. At that point the interpreter stack
- can be either examined (for debugging) or restored to the current
- catch state.
-
- The error is returned from the catch as a disarmed error object. At
- that point, the error can be passed around and accessed as a normal
- object (although its datatype is ERROR!). The DISARM function
- becomes unnecessary and will simply copy the fields to a normal
- OBJECT! type.
-
- Using the new CAUSE native with the error object will re-activate
- the error and throw the error back further to the prior catch.
-
- The error object will include a new TRACE field that provides a back
- trace of the interpreter stack. This is a block of block pointers
- and may be clipped at some reasonable size (perhaps 10).
-
- When C code hits an error condition, it calls Trap(id, arg1, arg2, ...).
- This function takes a variable number of arguments.
-
- BREAK and RETURN
-
- TRY/RECOVER/EXCEPT.
-
- try [block]
- try/recover [block] [block]
-
- TRACE f1, :path/f1, or [f1 f2 f3]
- foo: func [[trace] ...]
-
-*/
+//
+// File: %c-error.c
+// Summary: "error handling"
+// Section: core
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#include "sys-state.h"
-// Globals or Threaded???
-static REBOL_STATE Top_State; // Boot var: holds error state during boot
+//
+// Snap_State_Core: C
+//
+// Used by SNAP_STATE, PUSH_TRAP, and PUSH_UNHALTABLE_TRAP.
+//
+// **Note:** Modifying this routine likely means a necessary modification to
+// both `Assert_State_Balanced_Debug()` and `Trapped_Helper_Halted()`.
+//
+void Snap_State_Core(struct Reb_State *s)
+{
+ s->dsp = DSP;
+ s->top_chunk = TG_Top_Chunk;
+ // There should not be a Collect_Keys in progress. (We use a non-zero
+ // length of the collect buffer to tell if a later fail() happens in
+ // the middle of a Collect_Keys.)
+ //
+ assert(ARR_LEN(BUF_COLLECT) == 0);
-/***********************************************************************
-**
-*/ void Check_Stack(void)
-/*
-***********************************************************************/
-{
- if ((DSP + 100) > (REBINT)SERIES_REST(DS_Series))
- Trap0(RE_STACK_OVERFLOW);
+ s->guarded_len = SER_LEN(GC_Guarded);
+ s->frame = FS_TOP;
+
+ s->manuals_len = SER_LEN(GC_Manuals);
+ s->uni_buf_len = SER_LEN(UNI_BUF);
+ s->mold_loop_tail = ARR_LEN(MOLD_STACK);
+
+ // !!! Is this initialization necessary?
+ s->error = NULL;
}
-/***********************************************************************
-**
-*/ void Catch_Error(REBVAL *value)
-/*
-** Gets the current error and stores it as a value.
-** Normally the value is on the stack and is returned.
-**
-***********************************************************************/
+#if !defined(NDEBUG)
+
+//
+// Assert_State_Balanced_Debug: C
+//
+// Check that all variables in `state` have returned to what they were at
+// the time of snapshot.
+//
+void Assert_State_Balanced_Debug(
+ struct Reb_State *s,
+ const char *file,
+ int line
+) {
+ if (s->dsp != DSP) {
+ printf(
+ "DS_PUSH()x%d without DS_POP/DS_DROP\n",
+ DSP - s->dsp
+ );
+ panic_at (NULL, file, line);
+ }
+
+ assert(s->top_chunk == TG_Top_Chunk);
+
+ assert(s->frame == FS_TOP);
+
+ assert(ARR_LEN(BUF_COLLECT) == 0);
+
+ if (s->guarded_len != SER_LEN(GC_Guarded)) {
+ printf(
+ "PUSH_GUARD()x%d without DROP_GUARD()\n",
+ cast(int, SER_LEN(GC_Guarded) - s->guarded_len)
+ );
+ REBNOD *guarded = *SER_AT(
+ REBNOD*,
+ GC_Guarded,
+ SER_LEN(GC_Guarded) - 1
+ );
+ panic_at (guarded, file, line);
+ }
+
+ // !!! Note that this inherits a test that uses GC_Manuals->content.xxx
+ // instead of SER_LEN(). The idea being that although some series
+ // are able to fit in the series node, the GC_Manuals wouldn't ever
+ // pay for that check because it would always be known not to. Review
+ // this in general for things that may not need "series" overhead,
+ // e.g. a contiguous pointer stack.
+ //
+ if (s->manuals_len > SER_LEN(GC_Manuals)) {
+ //
+ // Note: Should this ever actually happen, panic() on the series won't
+ // do any real good in helping debug it. You'll probably need to
+ // add additional checking in the Manage_Series and Free_Series
+ // routines that checks against the caller's manuals_len.
+ //
+ panic_at ("manual series freed outside checkpoint", file, line);
+ }
+ else if (s->manuals_len < SER_LEN(GC_Manuals)) {
+ printf(
+ "Make_Series()x%d without Free_Series or MANAGE_SERIES\n",
+ cast(int, SER_LEN(GC_Manuals) - s->manuals_len)
+ );
+ REBSER *manual = *(SER_AT(
+ REBSER*,
+ GC_Manuals,
+ SER_LEN(GC_Manuals) - 1
+ ));
+ panic_at (manual, file, line);
+ }
+
+ assert(s->uni_buf_len == SER_LEN(UNI_BUF));
+ assert(s->mold_loop_tail == ARR_LEN(MOLD_STACK));
+
+ assert(s->error == NULL); // !!! necessary?
+}
+
+#endif
+
+
+//
+// Trapped_Helper_Halted: C
+//
+// This is used by both PUSH_TRAP and PUSH_UNHALTABLE_TRAP to do the work of
+// responding to a longjmp. (Hence it is run when setjmp returns TRUE.) Its
+// job is to safely recover from a sudden interruption, though the list of
+// things which can be safely recovered from is finite.
+//
+// (Among the countless things that are not handled automatically would be a
+// memory allocation via malloc().)
+//
+// Note: This is a crucial difference between C and C++, as C++ will walk up
+// the stack at each level and make sure any constructors have their
+// associated destructors run. *Much* safer for large systems, though not
+// without cost. Rebol's greater concern is not so much the cost of setup for
+// stack unwinding, but being written without requiring a C++ compiler.
+//
+// Returns whether the trapped error was a RE_HALT or not.
+//
+REBOOL Trapped_Helper_Halted(struct Reb_State *s)
{
- if (IS_NONE(TASK_THIS_ERROR)) Crash(RP_ERROR_CATCH);
- *value = *TASK_THIS_ERROR;
-// Print("CE: %r", value);
- SET_NONE(TASK_THIS_ERROR);
- //!!! Reset or ENABLE_GC;
+ ASSERT_CONTEXT(s->error);
+ assert(CTX_TYPE(s->error) == REB_ERROR);
+
+ REBOOL halted = LOGICAL(ERR_NUM(s->error) == RE_HALT);
+
+ // Restore Rebol data stack pointer at time of Push_Trap
+ //
+ DS_DROP_TO(s->dsp);
+
+ // Drop to the chunk state at the time of Push_Trap
+ //
+ while (TG_Top_Chunk != s->top_chunk)
+ Drop_Chunk_Of_Values(NULL);
+
+ // If we were in the middle of a Collect_Keys and an error occurs, then
+ // the binding lookup table has entries in it that need to be zeroed out.
+ // We can tell if that's necessary by whether there is anything
+ // accumulated in the collect buffer.
+ //
+ if (ARR_LEN(BUF_COLLECT) != 0)
+ Collect_Keys_End(NULL); // !!! No binder, review implications
+
+ // Free any manual series that were extant at the time of the error
+ // (that were created since this PUSH_TRAP started). This includes
+ // any arglist series in call frames that have been wiped off the stack.
+ // (Closure series will be managed.)
+ //
+ assert(SER_LEN(GC_Manuals) >= s->manuals_len);
+ while (SER_LEN(GC_Manuals) != s->manuals_len) {
+ // Freeing the series will update the tail...
+ Free_Series(
+ *SER_AT(REBSER*, GC_Manuals, SER_LEN(GC_Manuals) - 1)
+ );
+ }
+
+ SET_SERIES_LEN(GC_Guarded, s->guarded_len);
+ TG_Frame_Stack = s->frame;
+ TERM_SEQUENCE_LEN(UNI_BUF, s->uni_buf_len);
+
+#if !defined(NDEBUG)
+ //
+ // Because reporting errors in the actual Push_Mold process leads to
+ // recursion, this debug flag helps make it clearer what happens if
+ // that does happen... and can land on the right comment. But if there's
+ // a fail of some kind, the flag for the warning needs to be cleared.
+ //
+ TG_Pushing_Mold = FALSE;
+#endif
+
+ TERM_ARRAY_LEN(MOLD_STACK, s->mold_loop_tail);
+
+ Saved_State = s->last_state;
+
+ return halted;
}
-/***********************************************************************
-**
-*/ void Throw_Error(REBSER *err)
-/*
-** Throw the C stack.
-**
-***********************************************************************/
+//
+// Fail_Core: C
+//
+// Cause a "trap" of an error by longjmp'ing to the enclosing PUSH_TRAP (or
+// PUSH_UNHALTABLE_TRAP). Note that these failures interrupt code mid-stream,
+// so if a Rebol function is running it will not make it to the point of
+// returning the result value. This distinguishes the "fail" mechanic from
+// the "throw" mechanic, which has to bubble up a THROWN() value through
+// D_OUT (used to implement BREAK, CONTINUE, RETURN, LEAVE...)
+//
+// The function will auto-detect if the pointer it is given is an ERROR!'s
+// REBCTX*, a REBVAL*, or a UTF-8 string. If it's a string, an error will be
+// created from it automatically. If it's a value, then it is turned into
+// the ubiquitous (and kind of lame) "Invalid Arg" error.
+//
+// Note: Over the long term, one does not want to hard-code error strings in
+// the executable. That makes them more difficult to hook with translations,
+// or to identify systemically with some kind of "error code". However,
+// it's a realistic quick-and-dirty way of delivering a more meaningful
+// error than just using a RE_MISC error code, and can be found just as easily
+// to clean up later.
+//
+ATTRIBUTE_NO_RETURN void Fail_Core(const void *p)
{
- if (!Saved_State) Crash(RP_NO_SAVED_STATE);
- SET_ERROR(TASK_THIS_ERROR, ERR_NUM(err), err);
- if (Trace_Level) Trace_Error(TASK_THIS_ERROR);
- longjmp(*Saved_State, 1);
+ REBCTX *error;
+
+ switch (Detect_Rebol_Pointer(p)) {
+ case DETECTED_AS_UTF8: {
+ DECLARE_LOCAL (string);
+ Init_String(string, Make_UTF8_May_Fail(cast(const char*, p)));
+ error = Error(RE_USER, string, END);
+ break; }
+
+ case DETECTED_AS_SERIES: {
+ REBSER *s = m_cast(REBSER*, cast(const REBSER*, p)); // don't mutate
+ if (NOT_SER_FLAG(s, ARRAY_FLAG_VARLIST))
+ panic (s);
+ error = CTX(s);
+ break; }
+
+ case DETECTED_AS_VALUE: {
+ const REBVAL *v = cast(const REBVAL*, p);
+ error = Error(RE_INVALID_ARG, v, END);
+ break; }
+
+ default:
+ panic (p); // suppress compiler error from non-smart compilers
+ }
+
+ ASSERT_CONTEXT(error);
+ assert(CTX_TYPE(error) == REB_ERROR);
+
+#if !defined(NDEBUG)
+ //
+ // All calls to Fail_Core should originate from the `fail` macro,
+ // which in the debug build sets TG_Erroring_C_File and TG_Erroring_C_Line.
+ // Any error creations as arguments to that fail should have picked
+ // it up, and we now need to NULL it out so other Make_Error calls
+ // that are not inside of a fail invocation don't get confused and
+ // have the wrong information
+ //
+ assert(TG_Erroring_C_File != NULL);
+ TG_Erroring_C_File = NULL;
+#endif
+
+ // If we raise the error we'll lose the stack, and if it's an early
+ // error we always want to see it (do not use ATTEMPT or TRY on
+ // purpose in Startup_Core()...)
+ //
+ if (PG_Boot_Phase < BOOT_DONE)
+ panic (error);
+
+ // There should be a PUSH_TRAP of some kind in effect if a `fail` can
+ // ever be run.
+ //
+ if (Saved_State == NULL)
+ panic (error);
+
+ // The information for the Rebol call frames generally is held in stack
+ // variables, so the data will go bad in the longjmp. We have to free
+ // the data *before* the jump. Be careful not to let this code get too
+ // recursive or do other things that would be bad news if we're responding
+ // to C_STACK_OVERFLOWING. (See notes on the sketchiness in general of
+ // the way R3-Alpha handles stack overflows, and alternative plans.)
+ //
+ REBFRM *f = FS_TOP;
+ while (f != Saved_State->frame) {
+ if (Is_Any_Function_Frame(f))
+ Drop_Function_Args_For_Frame_Core(f, FALSE); // don't drop chunks
+
+ // See notes in Do_Va_Core() about how it is required by C standard
+ // to call va_end() after va_start(). If we longjmp past the point
+ // that called va_start(), we have to clean up the va_list else there
+ // could be undefined behavior.
+ //
+ if (FRM_IS_VALIST(f))
+ va_end(*f->source.vaptr);
+
+ REBFRM *prior = f->prior;
+ Drop_Frame_Core(f);
+ f = prior;
+ }
+
+ TG_Frame_Stack = f; // TG_Frame_Stack is writable FS_TOP
+
+ Saved_State->error = error;
+
+ // If a THROWN() was being processed up the stack when the error was
+ // raised, then it had the thrown argument set. Trash it in debug
+ // builds. (The value will not be kept alive, it is not seen by GC)
+ //
+ SET_UNREADABLE_BLANK(&TG_Thrown_Arg);
+
+ LONG_JUMP(Saved_State->cpu_state, 1);
}
-/***********************************************************************
-**
-*/ void Throw_Break(REBVAL *val)
-/*
-** Throw a break or return style error (for special cases
-** where we do not want to unwind the stack).
-**
-***********************************************************************/
+//
+// Stack_Depth: C
+//
+REBCNT Stack_Depth(void)
{
- if (!Saved_State) Crash(RP_NO_SAVED_STATE);
- *TASK_THIS_ERROR = *val;
- longjmp(*Saved_State, 1);
+ REBCNT depth = 0;
+
+ REBFRM *f = FS_TOP;
+ while (f) {
+ if (Is_Any_Function_Frame(f))
+ if (NOT(Is_Function_Frame_Fulfilling(f))) {
+ //
+ // We only count invoked functions (not group or path
+ // evaluations or "pending" functions that are building their
+ // arguments but have not been formally invoked yet)
+ //
+ ++depth;
+ }
+
+ f = FRM_PRIOR(f);
+ }
+
+ return depth;
}
-/***********************************************************************
-**
-*/ void Throw_Return_Series(REBCNT type, REBSER *series)
-/*
-** Throws a series value using error temp values.
-**
-***********************************************************************/
+//
+// Find_Error_For_Code: C
+//
+// Find the id word, the error type (category) word, and the error
+// message template block-or-string for a given error number.
+//
+// This scans the data which is loaded into the boot file by
+// processing %errors.r
+//
+// If the message is not found, return NULL. Will not write to
+// `id_out` or `type_out` unless returning a non-NULL pointer.
+//
+const REBVAL *Find_Error_For_Code(REBVAL *id_out, REBVAL *type_out, REBCNT code)
{
- REBVAL *val;
- REBVAL *err;
- REBSER *blk = VAL_SERIES(TASK_ERR_TEMPS);
+ REBCNT n;
+
+ // See %errors.r for the list of data which is loaded into the boot
+ // file as objects for the "error catalog"
+ //
+ REBCTX *categories = VAL_CONTEXT(Get_System(SYS_CATALOG, CAT_ERRORS));
+ assert(CTX_KEY_SYM(categories, 1) == SYM_SELF);
+
+ // Find the correct catalog category
+ n = code / RE_CATEGORY_SIZE; // 0 for Special, 1 for Internal...
+ if (SELFISH(n + 1) > CTX_LEN(categories)) // 1-based, not 0 based
+ return NULL;
+
+ // Get context of object representing the elements of the category itself
+ if (!IS_OBJECT(CTX_VAR(categories, SELFISH(n + 1)))) {
+ assert(FALSE);
+ return NULL;
+ }
+
+ REBCTX *category = VAL_CONTEXT(CTX_VAR(categories, SELFISH(n + 1)));
+ assert(CTX_KEY_SYM(category, 1) == SYM_SELF);
+
+ // Find the correct template in the catalog category (see %errors.r)
+ n = code % RE_CATEGORY_SIZE; // 0-based order within category
+ if (SELFISH(n + 2) > CTX_LEN(category)) // 1-based (CODE: TYPE:)
+ return NULL;
+
+ // Sanity check CODE: field of category object
+ if (!IS_INTEGER(CTX_VAR(category, SELFISH(1)))) {
+ assert(FALSE);
+ return NULL;
+ }
+ assert(
+ (code / RE_CATEGORY_SIZE) * RE_CATEGORY_SIZE
+ == cast(REBCNT, VAL_INT32(CTX_VAR(category, SELFISH(1))))
+ );
+
+ // Sanity check TYPE: field of category object
+ // !!! Same spelling as what we set in VAL_WORD_SYM(type_out))?
+ if (!IS_STRING(CTX_VAR(category, SELFISH(2)))) {
+ assert(FALSE);
+ return NULL;
+ }
+
+ REBVAL *message = CTX_VAR(category, SELFISH(n + 3));
+
+ // Error message template must be string or block
+ assert(IS_BLOCK(message) || IS_STRING(message));
+
+ // Success! Write category word from the category list context key sym,
+ // and specific error ID word from the context key sym within category
+ //
+ Init_Word(
+ type_out,
+ CTX_KEY_SPELLING(categories, SELFISH((code / RE_CATEGORY_SIZE) + 1))
+ );
+ Init_Word(
+ id_out,
+ CTX_KEY_SPELLING(category, SELFISH((code % RE_CATEGORY_SIZE) + 3))
+ );
+
+ return message;
+}
- RESET_SERIES(blk);
- val = Append_Value(blk);
- Set_Series(type, val, series);
- err = Append_Value(blk);
- SET_THROW(err, RE_RETURN, val);
- VAL_ERR_SYM(err) = SYM_RETURN; // indicates it is "virtual" (parse return)
- Throw_Break(err);
+
+//
+// Set_Location_Of_Error: C
+//
+// Since errors are generally raised to stack levels above their origin, the
+// stack levels causing the error are no longer running by the time the
+// error object is inspected. A limited snapshot of context information is
+// captured in the WHERE and NEAR fields, and some amount of file and line
+// information may be captured as well.
+//
+// The information is derived from the current execution position and stack
+// depth of a running frame. Also, if running from a C fail() call, the
+// file and line information can be captured in the debug build.
+//
+void Set_Location_Of_Error(
+ REBCTX *error,
+ REBFRM *where // must be valid and executing on the stack
+) {
+ assert(where != NULL);
+
+ REBDSP dsp_orig = DSP;
+
+ ERROR_VARS *vars = ERR_VARS(error);
+
+ // WHERE is a backtrace in the form of a block of label words, that start
+ // from the top of stack and go downward.
+ //
+ REBFRM *f = where;
+ for (; f != NULL; f = f->prior) {
+ //
+ // Only invoked functions (not pending functions, groups, etc.)
+ //
+ if (NOT(Is_Any_Function_Frame(f)))
+ continue;
+ if (Is_Function_Frame_Fulfilling(f))
+ continue;
+
+ DS_PUSH_TRASH;
+ Init_Word(DS_TOP, FRM_LABEL(f));
+ }
+ Init_Block(&vars->where, Pop_Stack_Values(dsp_orig));
+
+ // Nearby location of the error. Reify any valist that is running,
+ // so that the error has an array to present.
+ //
+ if (FRM_IS_VALIST(where)) {
+ const REBOOL truncated = TRUE;
+ Reify_Va_To_Array_In_Frame(where, truncated);
+ }
+
+ // Get at most 6 values out of the array. Ideally 3 before and after
+ // the error point. If truncating either the head or tail of the
+ // values, put ellipses.
+
+ REBINT start = FRM_INDEX(where) - 3;
+ if (start < 0) {
+ DS_PUSH_TRASH;
+ Init_Word(DS_TOP, Canon(SYM_ELLIPSIS));
+
+ start = 0;
+ }
+
+ REBCNT count = 0;
+ RELVAL *item = ARR_AT(FRM_ARRAY(where), start);
+ while (NOT_END(item) && count++ < 6) {
+ DS_PUSH_RELVAL(item, where->specifier);
+ if (count == FRM_INDEX(where) - start) {
+ //
+ // Leave a marker at the point of the error (currently `??`)
+ //
+ // Note: something like `=>ERROR=>` would be better, but have to
+ // insert a today-legal WORD!
+ //
+ DS_PUSH_TRASH;
+ Init_Word(DS_TOP, Canon(SYM__Q_Q));
+ }
+ ++item;
+ }
+
+ if (NOT_END(item)) {
+ DS_PUSH_TRASH;
+ Init_Word(DS_TOP, Canon(SYM_ELLIPSIS));
+ }
+
+ Init_Block(&vars->nearest, Pop_Stack_Values(dsp_orig));
+
+#if !defined(NDEBUG)
+ if (TG_Erroring_C_File) {
+ //
+ // !!! Note that a WORD! is used because FILE! strings cannot be
+ // interned at this time, and the general mechanism for storing
+ // filenames in usermode blocks wants to avoid generating a lot
+ // of copies of the same string, given that the total number of
+ // files one is working with is probably a limited set.
+ //
+ Init_Word(
+ &vars->file,
+ Intern_UTF8_Managed(
+ cb_cast(TG_Erroring_C_File), strlen(TG_Erroring_C_File)
+ )
+ );
+ Init_Integer(&vars->line, TG_Erroring_C_Line);
+ }
+ else
+#endif
+ { // ^-- mind the ELSE
+ // Try to fill in the file and line information of the error from the
+ // stack, looking for arrays with SERIES_FLAG_FILE_LINE.
+ //
+ f = where;
+ for (; f != NULL; f = f->prior) {
+ if (FRM_IS_VALIST(f))
+ continue;
+ if (NOT(GET_SER_FLAG(f->source.array, SERIES_FLAG_FILE_LINE)))
+ continue;
+ break;
+ }
+ if (f != NULL) {
+ Init_Word(&vars->file, SER(f->source.array)->link.filename);
+ Init_Integer(&vars->line, SER(f->source.array)->misc.line);
+ }
+ }
}
-/***********************************************************************
-**
-*/ void Throw_Return_Value(REBVAL *value)
-/*
-** Throws a series value using error temp values.
-**
-***********************************************************************/
+//
+// Make_Error_Object_Throws: C
+//
+// Creates an error object from arg and puts it in value.
+// The arg can be a string or an object body block.
+//
+// Returns TRUE if a THROWN() value is made during evaluation.
+//
+// This function is called by MAKE ERROR!. Note that most often
+// system errors from %errors.r are thrown by C code using
+// Make_Error(), but this routine accommodates verification of
+// errors created through user code...which may be mezzanine
+// Rebol itself. A goal is to not allow any such errors to
+// be formed differently than the C code would have made them,
+// and to cross through the point of R3-Alpha error compatibility,
+// which makes this a rather tortured routine. However, it
+// maps out the existing landscape so that if it is to be changed
+// then it can be seen exactly what is changing.
+//
+REBOOL Make_Error_Object_Throws(
+ REBVAL *out, // output location **MUST BE GC SAFE**!
+ const REBVAL *arg
+) {
+ // Frame from the error object template defined in %sysobj.r
+ //
+ REBCTX *root_error = VAL_CONTEXT(Get_System(SYS_STANDARD, STD_ERROR));
+
+ REBCTX *error;
+ ERROR_VARS *vars; // C struct mirroring fixed portion of error fields
+
+ if (IS_ERROR(arg) || IS_OBJECT(arg)) {
+ // Create a new error object from another object, including any
+ // non-standard fields. WHERE: and NEAR: will be overridden if
+ // used. If ID:, TYPE:, or CODE: were used in a way that would
+ // be inconsistent with a Rebol system error, an error will be
+ // raised later in the routine.
+
+ error = Merge_Contexts_Selfish(root_error, VAL_CONTEXT(arg));
+ vars = ERR_VARS(error);
+ }
+ else if (IS_BLOCK(arg)) {
+ // If a block, then effectively MAKE OBJECT! on it. Afterward,
+ // apply the same logic as if an OBJECT! had been passed in above.
+
+ // Bind and do an evaluation step (as with MAKE OBJECT! with A_MAKE
+ // code in REBTYPE(Context) and code in REBNATIVE(construct))
+
+ error = Make_Selfish_Context_Detect(
+ REB_ERROR, // type
+ VAL_ARRAY_AT(arg), // values to scan for toplevel set-words
+ root_error // parent
+ );
+
+ // Protect the error from GC by putting into out, which must be
+ // passed in as a GC-protecting value slot.
+ //
+ Init_Error(out, error);
+
+ Rebind_Context_Deep(root_error, error, NULL); // NULL=>no more binds
+ Bind_Values_Deep(VAL_ARRAY_AT(arg), error);
+
+ DECLARE_LOCAL (evaluated);
+ if (Do_Any_Array_At_Throws(evaluated, arg)) {
+ Move_Value(out, evaluated);
+ return TRUE;
+ }
+
+ vars = ERR_VARS(error);
+ }
+ else if (IS_STRING(arg)) {
+ //
+ // String argument to MAKE ERROR! makes a custom error from user:
+ //
+ // code: _ ;-- default is blank
+ // type: _
+ // id: _
+ // message: "whatever the string was"
+ //
+ // Minus the message, this is the default state of root_error.
+
+ error = Copy_Context_Shallow(root_error);
+
+ // !!! fix in Startup_Errors()?
+ //
+ VAL_RESET_HEADER(CTX_VALUE(error), REB_ERROR);
+
+ vars = ERR_VARS(error);
+ assert(IS_BLANK(&vars->code));
+ assert(IS_BLANK(&vars->type));
+ assert(IS_BLANK(&vars->id));
+
+ Init_String(&vars->message, Copy_Sequence_At_Position(arg));
+ }
+ else {
+ // No other argument types are handled by this routine at this time.
+
+ fail (Error_Invalid_Error_Raw(arg));
+ }
+
+ // Validate the error contents, and reconcile message template and ID
+ // information with any data in the object. Do this for the IS_STRING
+ // creation case just to make sure the rules are followed there too.
+
+ // !!! Note that this code is very cautious because the goal isn't to do
+ // this as efficiently as possible, rather to put up lots of alarms and
+ // traffic cones to make it easy to pick and choose what parts to excise
+ // or tighten in an error enhancement upgrade.
+
+ if (IS_INTEGER(&vars->code)) {
+ assert(VAL_INT32(&vars->code) != RE_USER); // not real code, use blank
+
+ // Users can make up anything for error codes allocated to them,
+ // but Rebol's historical default is to "own" error codes less
+ // than RE_USER. If a code is used in the sub-RE_USER range then
+ // make sure any id or type provided do not conflict.
+
+ if (!IS_BLANK(&vars->message)) // assume a MESSAGE: is wrong
+ fail (Error_Invalid_Error_Raw(arg));
+
+ DECLARE_LOCAL (id);
+ DECLARE_LOCAL (type);
+ const REBVAL *message = Find_Error_For_Code(
+ id,
+ type,
+ cast(REBCNT, VAL_INT32(&vars->code))
+ );
+
+ if (message == NULL)
+ fail (Error_Invalid_Error_Raw(arg));
+
+ Move_Value(&vars->message, message);
+
+ if (!IS_BLANK(&vars->id)) {
+ if (
+ !IS_WORD(&vars->id)
+ || VAL_WORD_CANON(&vars->id) != VAL_WORD_CANON(id)
+ ){
+ fail (Error_Invalid_Error_Raw(arg));
+ }
+ }
+ Move_Value(&vars->id, id); // binding and case normalized
+
+ if (!IS_BLANK(&vars->type)) {
+ if (
+ !IS_WORD(&vars->id)
+ || VAL_WORD_CANON(&vars->type) != VAL_WORD_CANON(type)
+ ){
+ fail (Error_Invalid_Error_Raw(arg));
+ }
+ }
+ Move_Value(&vars->type, type); // binding and case normalized
+
+ // !!! TBD: Check that all arguments were provided!
+ }
+ else if (IS_WORD(&vars->type) && IS_WORD(&vars->id)) {
+ // If there was no CODE: supplied but there was a TYPE: and ID: then
+ // this may overlap a combination used by Rebol where we wish to
+ // fill in the code. (No fast lookup for this, must search.)
+
+ REBCTX *categories = VAL_CONTEXT(Get_System(SYS_CATALOG, CAT_ERRORS));
+
+ assert(IS_BLANK(&vars->code));
+
+ // Find correct category for TYPE: (if any)
+ REBVAL *category
+ = Select_Canon_In_Context(categories, VAL_WORD_CANON(&vars->type));
+
+ if (category) {
+ assert(IS_OBJECT(category));
+ assert(VAL_CONTEXT_KEY_SYM(category, 1) == SYM_SELF);
+ assert(VAL_CONTEXT_KEY_SYM(category, SELFISH(1)) == SYM_CODE);
+ assert(IS_INTEGER(VAL_CONTEXT_VAR(category, SELFISH(1))));
+
+ REBCNT code = cast(REBCNT,
+ VAL_INT32(VAL_CONTEXT_VAR(category, SELFISH(1)))
+ );
+
+ assert(VAL_CONTEXT_KEY_SYM(category, SELFISH(2)) == SYM_TYPE);
+ assert(IS_STRING(VAL_CONTEXT_VAR(category, SELFISH(2))));
+
+ // Find correct message for ID: (if any)
+
+ REBVAL *message = Select_Canon_In_Context(
+ VAL_CONTEXT(category), VAL_WORD_CANON(&vars->id)
+ );
+
+ if (message) {
+ assert(IS_STRING(message) || IS_BLOCK(message));
+
+ if (!IS_BLANK(&vars->message))
+ fail (Error_Invalid_Error_Raw(arg));
+
+ Move_Value(&vars->message, message);
+
+ Init_Integer(&vars->code,
+ code
+ + Find_Canon_In_Context(
+ error, VAL_WORD_CANON(&vars->id), FALSE
+ )
+ - Find_Canon_In_Context(error, Canon(SYM_TYPE), FALSE)
+ - 1
+ );
+ }
+ else {
+ // At the moment, we don't let the user make a user-ID'd
+ // error using a category from the internal list just
+ // because there was no id from that category. In effect
+ // all the category words have been "reserved"
+
+ // !!! Again, remember this is all here just to show compliance
+ // with what the test suite tested for, it disallowed e.g.
+ // it expected the following to be an illegal error because
+ // the `script` category had no `set-self` error ID.
+ //
+ // make error! [type: 'script id: 'set-self]
+
+ fail (Error_Invalid_Error_Raw(arg));
+ }
+ assert(IS_INTEGER(&vars->code));
+ }
+ else {
+ // The type and category picked did not overlap any existing one
+ // so let it be a user error.
+ //
+ assert(IS_BLANK(&vars->code));
+ Init_Blank(&vars->code);
+ }
+ }
+ else {
+ // It's either a user-created error or otherwise. It may
+ // have bad ID, TYPE, or message fields, or a completely
+ // strange code #. The question of how non-standard to
+ // tolerate is an open one.
+
+ // For now we just write blank into the error code field, if that was
+ // not already there.
+
+ if (NOT(IS_BLANK(&vars->code)))
+ fail (Error_Invalid_Error_Raw(arg));
+
+ // !!! Because we will experience crashes in the molding logic,
+ // we put some level of requirement besides "code # not 0".
+ // This is conservative logic and not good for general purposes.
+
+ if (
+ !(IS_WORD(&vars->id) || IS_BLANK(&vars->id))
+ || !(IS_WORD(&vars->type) || IS_BLANK(&vars->type))
+ || !(
+ IS_BLOCK(&vars->message)
+ || IS_STRING(&vars->message)
+ || IS_BLANK(&vars->message)
+ )
+ ) {
+ fail (Error_Invalid_Error_Raw(arg));
+ }
+ }
+
+ // There might be no Rebol code running when the error is created (e.g.
+ // the static creation of the stack overflow error before any code runs)
+ //
+ if (FS_TOP != NULL)
+ Set_Location_Of_Error(error, FS_TOP);
+
+ Init_Error(out, error);
+ return FALSE;
+}
+
+
+//
+// Make_Error_Managed_Core: C
+//
+// (WARNING va_list by pointer: http://stackoverflow.com/a/3369762/211160)
+//
+// Create and init a new error object based on a C va_list and an error code.
+// It knows how many arguments the error particular error ID requires based
+// on the templates defined in %errors.r.
+//
+// If the error code RE_USER is used, then the error will have
+//
+// This routine should either succeed and return to the caller, or panic()
+// and crash if there is a problem (such as running out of memory, or that
+// %errors.r has not been loaded). Hence the caller can assume it will
+// regain control to properly call va_end with no longjmp to skip it.
+//
+REBCTX *Make_Error_Managed_Core(REBCNT code, va_list *vaptr)
+{
+ assert(code != 0);
+
+ if (PG_Boot_Phase < BOOT_ERRORS) { // no STD_ERROR or template table yet
+ #if !defined(NDEBUG)
+ printf(
+ "fail() before object table initialized, code = %d\n",
+ cast(int, code)
+ );
+ #endif
+
+ DECLARE_LOCAL (code_value);
+ Init_Integer(code_value, code);
+
+ panic (code_value);
+ }
+
+ REBCTX *root_error = VAL_CONTEXT(Get_System(SYS_STANDARD, STD_ERROR));
+
+ DECLARE_LOCAL (id);
+ DECLARE_LOCAL (type);
+ const REBVAL *message;
+ if (code == RE_USER) {
+ Init_Blank(id);
+ Init_Blank(type);
+ message = va_arg(*vaptr, const REBVAL*);
+ }
+ else
+ message = Find_Error_For_Code(id, type, code);
+
+ assert(message != NULL);
+
+ REBCNT expected_args = 0;
+ if (IS_BLOCK(message)) { // GET-WORD!s in template should match va_list
+ RELVAL *temp = VAL_ARRAY_HEAD(message);
+ for (; NOT_END(temp); ++temp) {
+ if (IS_GET_WORD(temp))
+ ++expected_args;
+ else
+ assert(IS_STRING(temp));
+ }
+ }
+ else // Just a string, no arguments expected.
+ assert(IS_STRING(message));
+
+ REBCTX *error;
+ if (expected_args == 0) {
+ // If there are no arguments, we don't need to make a new keylist...
+ // just a new varlist to hold this instance's settings. (root
+ // error keylist is already managed)
+
+ error = Copy_Context_Shallow(root_error);
+
+ // !!! Should tweak root error during boot so it actually is an ERROR!
+ // (or use literal error construction syntax, if it worked?)
+ //
+ VAL_RESET_HEADER(CTX_VALUE(error), REB_ERROR);
+ }
+ else {
+ // !!! See remarks on how the modern way to handle this may be to
+ // put error arguments in the error object, and then have the META-OF
+ // hold the generic error parameters. Investigate how this ties in
+ // with user-defined types.
+
+ REBCNT root_len = CTX_LEN(root_error);
+
+ // Should the error be well-formed, we'll need room for the new
+ // expected values *and* their new keys in the keylist.
+ //
+ error = Copy_Context_Shallow_Extra(root_error, expected_args);
+
+ // !!! Should tweak root error during boot so it actually is an ERROR!
+ // (or use literal error construction syntax, if it worked?)
+ //
+ VAL_RESET_HEADER(CTX_VALUE(error), REB_ERROR);
+
+ // Fix up the tail first so CTX_KEY and CTX_VAR don't complain
+ // in the debug build that they're accessing beyond the error length
+ //
+ TERM_ARRAY_LEN(CTX_VARLIST(error), root_len + expected_args + 1);
+ TERM_ARRAY_LEN(CTX_KEYLIST(error), root_len + expected_args + 1);
+
+ REBVAL *key = CTX_KEY(error, root_len) + 1;
+ REBVAL *value = CTX_VAR(error, root_len) + 1;
+
+ #ifdef NDEBUG
+ const RELVAL *temp = VAL_ARRAY_HEAD(message);
+ #else
+ // Will get here even for a parameterless string due to throwing in
+ // the extra "arguments" of the __FILE__ and __LINE__
+ //
+ const RELVAL *temp =
+ IS_STRING(message)
+ ? cast(const RELVAL*, END) // needed by gcc/g++ 2.95 (bug)
+ : VAL_ARRAY_HEAD(message);
+ #endif
+
+ for (; NOT_END(temp); ++temp) {
+ if (IS_GET_WORD(temp)) {
+ const REBVAL *arg = va_arg(*vaptr, const REBVAL*);
+
+ // NULL is 0 in C, and so passing NULL to a va_arg list and
+ // reading it as a pointer is not legal (because it will just
+ // be an integer). One would have to use `(REBVAL*)NULL`, so
+ // END is used instead (consistent w/variadic Do_XXX)
+ //
+ assert(arg != NULL);
+
+ if (IS_END(arg)) {
+ // Terminating with an end marker is optional but can help
+ // catch errors here of too few args passed when the
+ // template expected more substitutions.
+
+ #ifdef NDEBUG
+ // If the C code passed too few args in a debug build,
+ // prevent a crash in the release build by filling it.
+ // No perfect answer if you're going to keep running...
+ // something like ISSUE! #404 could be an homage:
+ //
+ // http://www.room404.com/page.php?pg=homepage
+ //
+ // But we'll just use NONE. Debug build asserts here.
+
+ arg = BLANK_VALUE;
+ #else
+ printf(
+ "too few args passed for error code %d at %s line %d",
+ cast(int, code),
+ TG_Erroring_C_File ? TG_Erroring_C_File : "",
+ TG_Erroring_C_File ? TG_Erroring_C_Line : -1
+ );
+ assert(FALSE);
+
+ // !!! Note that we have no way of checking for too *many*
+ // args with C's va_list machinery
+ #endif
+ }
+
+ #if !defined(NDEBUG)
+ if (GET_VAL_FLAG(arg, VALUE_FLAG_RELATIVE)) {
+ //
+ // Make_Error doesn't have any way to pass in a specifier,
+ // so only specific values should be used.
+ //
+ printf("Relative value passed to Make_Error()\n");
+ panic (arg);
+ }
+ #endif
+
+ ASSERT_VALUE_MANAGED(arg);
+
+ Init_Typeset(key, ALL_64, VAL_WORD_SPELLING(temp));
+ Move_Value(value, arg);
+
+ key++;
+ value++;
+ }
+ }
+
+ assert(IS_END(key)); // set above by TERM_ARRAY_LEN
+ assert(IS_END(value)); // ...same
+ }
+
+ // C struct mirroring fixed portion of error fields
+ //
+ ERROR_VARS *vars = ERR_VARS(error);
+
+ if (code == RE_USER)
+ assert(IS_BLANK(&vars->code)); // no error number
+ else
+ Init_Integer(&vars->code, code);
+
+ Move_Value(&vars->message, message);
+ Move_Value(&vars->id, id);
+ Move_Value(&vars->type, type);
+
+ // There might be no Rebol code running when the error is created (e.g.
+ // the static creation of the stack overflow error before any code runs)
+ //
+ if (FS_TOP != NULL)
+ Set_Location_Of_Error(error, FS_TOP);
+
+ // !!! We create errors and then fail() on them without ever putting them
+ // into a REBVAL. This means that if left unmanaged, they would count as
+ // manual memory that the fail() needed to clean up...but the fail()
+ // plans on reporting this error (!). In these cases the GC doesn't run
+ // but the cleanup does, so for now manage the error in the hopes it
+ // will be used up quickly.
+ //
+ MANAGE_ARRAY(CTX_VARLIST(error));
+ return error;
+}
+
+
+//
+// Error: C
+//
+// This variadic function takes a number of REBVAL* arguments appropriate for
+// the error number passed. It is commonly used with fail():
+//
+// fail (Error(RE_SOMETHING, arg1, arg2, ...));
+//
+// Note that in C, variadic functions don't know how many arguments they were
+// passed. Make_Error_Managed_Core() knows how many arguments are in an
+// error's template in %errors.r for a given error id, so that is the number
+// of arguments it will *attempt* to use--reading invalid memory if wrong.
+//
+// (All C variadics have this problem, e.g. `printf("%d %d", 12);`)
+//
+// But the risk of mistakes is reduced by creating wrapper functions, with a
+// fixed number of arguments specific to each error...and the wrappers can
+// also do additional argument processing:
+//
+// fail (Error_Something(arg1, thing_processed_to_make_arg2));
+//
+// But to make variadic calls *slightly* safer, a caller can pass END
+// after the last argument for a double-check that won't try reading invalid
+// memory if too few arguments are given:
+//
+// fail (Error(RE_SOMETHING, arg1, arg2, END));
+//
+REBCTX *Error(REBCNT num, ... /* REBVAL *arg1, REBVAL *arg2, ... */)
{
- REBVAL *val;
- REBVAL *err;
- REBSER *blk = VAL_SERIES(TASK_ERR_TEMPS);
+ va_list va;
+ REBCTX *error;
- RESET_SERIES(blk);
- val = Append_Value(blk);
- *val = *value;
- err = Append_Value(blk);
- SET_THROW(err, RE_RETURN, val);
- VAL_ERR_SYM(err) = SYM_RETURN; // indicates it is "virtual" (parse return)
- Throw_Break(err);
+ va_start(va, num);
+ error = Make_Error_Managed_Core(num, &va);
+ va_end(va);
+
+ return error;
}
-/***********************************************************************
-**
-*/ void Trap_Stack()
-/*
-***********************************************************************/
+//
+// Error_Lookback_Quote_Too_Late: C
+//
+REBCTX *Error_Lookback_Quote_Too_Late(const RELVAL *word, REBSPC *specifier) {
+ assert(IS_WORD(word));
+
+ DECLARE_LOCAL (specific);
+ Derelativize(specific, word, specifier);
+
+ fail (Error_Enfix_Quote_Late_Raw(specific));
+}
+
+
+//
+// Error_Non_Logic_Refinement: C
+//
+// Ren-C allows functions to be specialized, such that a function's frame can
+// be filled (or partially filled) by an example frame. The variables
+// corresponding to refinements must be canonized to either TRUE or FALSE
+// by these specializations, because that's what the called function expects.
+//
+REBCTX *Error_Non_Logic_Refinement(REBFRM *f) {
+ DECLARE_LOCAL (word);
+ Init_Word(word, VAL_PARAM_SPELLING(f->param));
+ fail (Error_Non_Logic_Refine_Raw(word, Type_Of(f->arg)));
+}
+
+
+//
+// Error_Bad_Func_Def: C
+//
+REBCTX *Error_Bad_Func_Def(const REBVAL *spec, const REBVAL *body)
{
- if (IS_INTEGER(TASK_THIS_ERROR)) return; // composing prior error.
+ // !!! Improve this error; it's simply a direct emulation of arity-1
+ // error that existed before refactoring code out of MAKE_Function().
- if (!Saved_State) Crash(RP_NO_SAVED_STATE);
+ REBARR *array = Make_Array(2);
+ Append_Value(array, spec);
+ Append_Value(array, body);
- *TASK_THIS_ERROR = *TASK_STACK_ERROR; // pre-allocated
+ DECLARE_LOCAL (def);
- longjmp(*Saved_State, 1);
+ Init_Block(def, array);
+ return Error_Bad_Func_Def_Raw(def);
}
-/***********************************************************************
-**
-*/ REBCNT Stack_Depth()
-/*
-***********************************************************************/
+//
+// Error_No_Arg: C
+//
+REBCTX *Error_No_Arg(REBSTR *label, const RELVAL *param)
{
- REBCNT dsf = DSF;
- REBCNT count = 0;
+ assert(IS_TYPESET(param));
+
+ DECLARE_LOCAL (param_word);
+ Init_Word(param_word, VAL_PARAM_SPELLING(param));
- for (dsf = DSF; dsf > 0; dsf = PRIOR_DSF(dsf)) {
- count++;
- }
+ DECLARE_LOCAL (label_word);
+ Init_Word(label_word, label);
- return count;
+ return Error_No_Arg_Raw(label_word, param_word);
}
-/***********************************************************************
-**
-*/ REBSER *Make_Backtrace(REBINT start)
-/*
-** Return a block of backtrace words.
-**
-***********************************************************************/
+//
+// Error_Invalid_Datatype: C
+//
+REBCTX *Error_Invalid_Datatype(REBCNT id)
{
- REBCNT depth = Stack_Depth();
- REBSER *blk = Make_Block(depth-start);
- REBINT dsf;
- REBVAL *val;
+ DECLARE_LOCAL (id_value);
+
+ Init_Integer(id_value, id);
+ return Error_Invalid_Datatype_Raw(id_value);
+}
+
+
+//
+// Error_No_Memory: C
+//
+REBCTX *Error_No_Memory(REBCNT bytes)
+{
+ DECLARE_LOCAL (bytes_value);
+
+ Init_Integer(bytes_value, bytes);
+ return Error_No_Memory_Raw(bytes_value);
+}
+
- for (dsf = DSF; dsf > 0; dsf = PRIOR_DSF(dsf)) {
- if (start-- <= 0) {
- val = Append_Value(blk);
- Init_Word(val, VAL_WORD_SYM(DSF_WORD(dsf)));
- }
- }
+//
+// Error_Invalid_Arg_Core: C
+//
+// This error is pretty vague...it's just "invalid argument"
+// and the value with no further commentary or context. It
+// becomes a catch all for "unexpected input" when a more
+// specific error would be more useful.
+//
+// Note that just `fail (value)` on REBVAL* will generate this error, this
+// variant is used on RELVAL*.
+//
+REBCTX *Error_Invalid_Arg_Core(const RELVAL *value, REBSPC *specifier)
+{
+ DECLARE_LOCAL (specific);
+ Derelativize(specific, value, specifier);
- return blk;
+ return Error_Invalid_Arg_Raw(specific);
}
-
-/***********************************************************************
-**
-*/ void Set_Error_Type(ERROR_OBJ *error)
-/*
-** Sets error type and id fields based on code number.
-**
-***********************************************************************/
-{
- REBSER *cats; // Error catalog object
- REBSER *cat; // Error category object
- REBCNT n; // Word symbol number
- REBCNT code;
-
- code = VAL_INT32(&error->code);
-
- // Set error category:
- n = code / 100 + 1;
- cats = VAL_OBJ_FRAME(Get_System(SYS_CATALOG, CAT_ERRORS));
-
- if (code >= 0 && n < SERIES_TAIL(cats) &&
- NZ(cat = VAL_SERIES(BLK_SKIP(cats, n)))
- ) {
- Set_Word(&error->type, FRM_WORD_SYM(cats, n), cats, n);
-
- // Find word related to the error itself:
-
- n = code % 100 + 3;
- if (n < SERIES_TAIL(cat))
- Set_Word(&error->id, FRM_WORD_SYM(cat, n), cat, n);
- }
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Find_Error_Info(ERROR_OBJ *error, REBINT *num)
-/*
-** Return the error message needed to print an error.
-** Must scan the error catalog and its error lists.
-** Note that the error type and id words no longer need
-** to be bound to the error catalog context.
-** If the message is not found, return null.
-**
-***********************************************************************/
-{
- REBSER *frame;
- REBVAL *obj1;
- REBVAL *obj2;
-
- if (!IS_WORD(&error->type) || !IS_WORD(&error->id)) return 0;
-
- // Find the correct error type object in the catalog:
- frame = VAL_OBJ_FRAME(Get_System(SYS_CATALOG, CAT_ERRORS));
- obj1 = Find_Word_Value(frame, VAL_WORD_SYM(&error->type));
- if (!obj1) return 0;
-
- // Now find the correct error message for that type:
- frame = VAL_OBJ_FRAME(obj1);
- obj2 = Find_Word_Value(frame, VAL_WORD_SYM(&error->id));
- if (!obj2) return 0;
-
- if (num) {
- obj1 = Find_Word_Value(frame, SYM_CODE);
- *num = VAL_INT32(obj1)
- + Find_Word_Index(frame, VAL_WORD_SYM(&error->id), FALSE)
- - Find_Word_Index(frame, SYM_TYPE, FALSE) - 1;
- }
-
- return obj2;
-}
-
-
-/***********************************************************************
-**
-*/ void Make_Error_Object(REBVAL *arg, REBVAL *value)
-/*
-** Creates an error object from arg and puts it in value.
-** The arg can be a string or an object body block.
-** This function is called by MAKE ERROR!.
-**
-***********************************************************************/
-{
- REBSER *err; // Error object
- ERROR_OBJ *error; // Error object values
- REBINT code = 0;
-
- // Create a new error object from another object, including any non-standard fields:
- if (IS_ERROR(arg) || IS_OBJECT(arg)) {
- err = Merge_Frames(VAL_OBJ_FRAME(ROOT_ERROBJ),
- IS_ERROR(arg) ? VAL_OBJ_FRAME(arg) : VAL_ERR_OBJECT(arg));
- error = ERR_VALUES(err);
-// if (!IS_INTEGER(&error->code)) {
- if (!Find_Error_Info(error, &code)) code = RE_INVALID_ERROR;
- SET_INTEGER(&error->code, code);
-// }
- SET_ERROR(value, VAL_INT32(&error->code), err);
- return;
- }
-
- // Make a copy of the error object template:
- err = CLONE_OBJECT(VAL_OBJ_FRAME(ROOT_ERROBJ));
- error = ERR_VALUES(err);
- SET_NONE(&error->id);
- SET_ERROR(value, 0, err);
-
- // If block arg, evaluate object values (checking done later):
- // If user set error code, use it to setup type and id fields.
- if (IS_BLOCK(arg)) {
- DISABLE_GC;
- Do_Bind_Block(err, arg); // GC-OK (disabled)
- ENABLE_GC;
- if (IS_INTEGER(&error->code) && VAL_INT64(&error->code)) {
- Set_Error_Type(error);
- } else {
- if (Find_Error_Info(error, &code)) {
- SET_INTEGER(&error->code, code);
- }
- }
- // The error code is not valid:
- if (IS_NONE(&error->id)) {
- SET_INTEGER(&error->code, RE_INVALID_ERROR);
- Set_Error_Type(error);
- }
- if (VAL_INT64(&error->code) < 100 || VAL_INT64(&error->code) > 1000)
- Trap_Arg(arg);
- }
-
- // If string arg, setup other fields
- else if (IS_STRING(arg)) {
- SET_INTEGER(&error->code, RE_USER); // user error
- Set_String(&error->arg1, Copy_Series_Value(arg));
- Set_Error_Type(error);
- }
-
-// No longer allowed:
-// else if (IS_INTEGER(arg)) {
-// error->code = *arg;
-// Set_Error_Type(error);
-// }
- else
- Trap_Arg(arg);
-
- if (!(VAL_ERR_NUM(value) = VAL_INT32(&error->code))) {
- Trap_Arg(arg);
- }
+
+//
+// Error_Bad_Func_Def_Core: C
+//
+REBCTX *Error_Bad_Func_Def_Core(const RELVAL *item, REBSPC *specifier)
+{
+ DECLARE_LOCAL (specific);
+ Derelativize(specific, item, specifier);
+ return Error_Bad_Func_Def_Raw(specific);
}
-/***********************************************************************
-**
-*/ REBSER *Make_Error(REBINT code, REBVAL *arg1, REBVAL *arg2, REBVAL *arg3)
-/*
-** Create and init a new error object.
-**
-***********************************************************************/
+//
+// Error_Bad_Refine_Revoke: C
+//
+// We may have to search for the refinement, so we always do (speed of error
+// creation not considered that relevant to the evaluator, being overshadowed
+// by the error handling). See the remarks about the state of f->refine in
+// the Reb_Frame definition.
+//
+REBCTX *Error_Bad_Refine_Revoke(REBFRM *f)
{
- REBSER *err; // Error object
- ERROR_OBJ *error; // Error object values
+ assert(IS_TYPESET(f->param));
- if (PG_Boot_Phase < BOOT_ERRORS) Crash(RP_EARLY_ERROR, code); // Not far enough!
+ DECLARE_LOCAL (param_name);
+ Init_Word(param_name, VAL_PARAM_SPELLING(f->param));
- // Make a copy of the error object template:
- err = CLONE_OBJECT(VAL_OBJ_FRAME(ROOT_ERROBJ));
- error = ERR_VALUES(err);
+ while (VAL_PARAM_CLASS(f->param) != PARAM_CLASS_REFINEMENT)
+ --f->param;
- // Set error number:
- SET_INTEGER(&error->code, (REBINT)code);
- Set_Error_Type(error);
+ DECLARE_LOCAL (refine_name);
+ Init_Refinement(refine_name, VAL_PARAM_SPELLING(f->param));
- // Set error argument values:
- if (arg1) error->arg1 = *arg1;
- if (arg2) error->arg2 = *arg2;
- if (arg3) error->arg3 = *arg3;
+ if (IS_VOID(f->arg)) // was void and shouldn't have been
+ return Error_Bad_Refine_Revoke_Raw(refine_name, param_name);
+
+ // wasn't void and should have been
+ //
+ return Error_Argument_Revoked_Raw(refine_name, param_name);
+}
- // Set backtrace and location information:
- if (DSF > 0) {
- // Where (what function) is the error:
- Set_Block(&error->where, Make_Backtrace(0));
- // Nearby location of the error (in block being evaluated):
- error->nearest = *DSF_BACK(DSF);
- }
- return err;
+//
+// Error_No_Value_Core: C
+//
+REBCTX *Error_No_Value_Core(const RELVAL *target, REBSPC *specifier) {
+ DECLARE_LOCAL (specified);
+ Derelativize(specified, target, specifier);
+
+ return Error_No_Value_Raw(specified);
}
-/***********************************************************************
-**
-*/ void Trap0(REBCNT num)
-/*
-***********************************************************************/
+//
+// Error_Partial_Lookback: C
+//
+REBCTX *Error_Partial_Lookback(REBFRM *f)
{
- Throw_Error(Make_Error(num, 0, 0, 0));
+ DECLARE_LOCAL (label);
+ Init_Word(label, FRM_LABEL(f));
+
+ DECLARE_LOCAL (param_name);
+ Init_Word(param_name, VAL_PARAM_SPELLING(f->param));
+
+ return Error_Partial_Lookback_Raw(label, param_name);
}
-/***********************************************************************
-**
-*/ void Trap1(REBCNT num, REBVAL *arg1)
-/*
-***********************************************************************/
+//
+// Error_No_Value: C
+//
+REBCTX *Error_No_Value(const REBVAL *target) {
+ return Error_No_Value_Core(target, SPECIFIED);
+}
+
+
+//
+// Error_No_Catch_For_Throw: C
+//
+REBCTX *Error_No_Catch_For_Throw(REBVAL *thrown)
{
- Throw_Error(Make_Error(num, arg1, 0, 0));
+ DECLARE_LOCAL (arg);
+
+ assert(THROWN(thrown));
+ CATCH_THROWN(arg, thrown); // clears bit
+
+ if (IS_BLANK(thrown))
+ return Error_No_Catch_Raw(arg);
+
+ return Error_No_Catch_Named_Raw(arg, thrown);
}
-/***********************************************************************
-**
-*/ void Trap2(REBCNT num, REBVAL *arg1, REBVAL *arg2)
-/*
-***********************************************************************/
+//
+// Error_Invalid_Type: C
+//
+// type is not allowed here.
+//
+REBCTX *Error_Invalid_Type(enum Reb_Kind kind)
{
- Throw_Error(Make_Error(num, arg1, arg2, 0));
+ return Error_Invalid_Type_Raw(Get_Type(kind));
}
-/***********************************************************************
-**
-*/ void Trap3(REBCNT num, REBVAL *arg1, REBVAL *arg2, REBVAL *arg3)
-/*
-***********************************************************************/
+//
+// Error_Out_Of_Range: C
+//
+// value out of range:
+//
+REBCTX *Error_Out_Of_Range(const REBVAL *arg)
{
- Throw_Error(Make_Error(num, arg1, arg2, arg3));
+ return Error_Out_Of_Range_Raw(arg);
}
-/***********************************************************************
-**
-*/ void Trap_Arg(REBVAL *arg)
-/*
-***********************************************************************/
+//
+// Error_Protected_Key: C
+//
+REBCTX *Error_Protected_Key(REBVAL *key)
{
- Trap1(RE_INVALID_ARG, arg);
+ assert(IS_TYPESET(key));
+
+ DECLARE_LOCAL (key_name);
+ Init_Word(key_name, VAL_KEY_SPELLING(key));
+
+ return Error_Protected_Word_Raw(key_name);
}
-/***********************************************************************
-**
-*/ void Trap_Type(REBVAL *arg)
-/*
-** type is not allowed here
-**
-***********************************************************************/
+//
+// Error_Illegal_Action: C
+//
+REBCTX *Error_Illegal_Action(enum Reb_Kind type, REBSYM action)
{
- Trap1(RE_INVALID_TYPE, Of_Type(arg));
+ DECLARE_LOCAL (action_word);
+ Init_Word(action_word, Canon(action));
+
+ return Error_Cannot_Use_Raw(action_word, Get_Type(type));
}
-/***********************************************************************
-**
-*/ void Trap_Range(REBVAL *arg)
-/*
-** value out of range:
-**
-***********************************************************************/
+//
+// Error_Math_Args: C
+//
+REBCTX *Error_Math_Args(enum Reb_Kind type, REBSYM action)
{
- Trap1(RE_OUT_OF_RANGE, arg);
+ DECLARE_LOCAL (action_word);
+ Init_Word(action_word, Canon(action));
+
+ return Error_Not_Related_Raw(action_word, Get_Type(type));
}
-/***********************************************************************
-**
-*/ void Trap_Word(REBCNT num, REBCNT sym, REBVAL *arg)
-/*
-***********************************************************************/
+//
+// Error_Unexpected_Type: C
+//
+REBCTX *Error_Unexpected_Type(enum Reb_Kind expected, enum Reb_Kind actual)
{
- Init_Word(DS_TOP, sym);
- if (arg) Trap2(num, DS_TOP, arg);
- else Trap1(num, DS_TOP);
+ assert(expected < REB_MAX);
+ assert(actual < REB_MAX);
+
+ return Error_Expect_Val_Raw(
+ Get_Type(expected),
+ Get_Type(actual)
+ );
+}
+
+
+//
+// Error_Arg_Type: C
+//
+// Function in frame of `call` expected parameter `param` to be
+// a type different than the arg given (which had `arg_type`)
+//
+REBCTX *Error_Arg_Type(
+ REBSTR *label,
+ const RELVAL *param,
+ enum Reb_Kind kind
+) {
+ assert(IS_TYPESET(param));
+
+ DECLARE_LOCAL (param_word);
+ Init_Word(param_word, VAL_PARAM_SPELLING(param));
+
+ DECLARE_LOCAL (label_word);
+ Init_Word(label_word, label);
+
+ if (kind != REB_MAX_VOID) {
+ assert(kind != REB_0);
+ REBVAL *datatype = Get_Type(kind);
+ assert(IS_DATATYPE(datatype));
+
+ return Error_Expect_Arg_Raw(
+ label_word,
+ datatype,
+ param_word
+ );
+ }
+
+ // Although REB_MAX_VOID is not a type, the typeset bits are used
+ // to check it. Since Get_Type() will fail, use another error.
+ //
+ return Error_Arg_Required_Raw(
+ label_word,
+ param_word
+ );
+}
+
+
+//
+// Error_Bad_Return_Type: C
+//
+REBCTX *Error_Bad_Return_Type(REBSTR *label, enum Reb_Kind kind) {
+ DECLARE_LOCAL (label_word);
+ Init_Word(label_word, label);
+
+ if (kind == REB_MAX_VOID)
+ return Error_Needs_Return_Value_Raw(label_word);
+
+ REBVAL *datatype = Get_Type(kind);
+ assert(IS_DATATYPE(datatype));
+ return Error_Bad_Return_Type_Raw(label_word, datatype);
}
-/***********************************************************************
-**
-*/ void Trap_Action(REBCNT type, REBCNT action)
-/*
-***********************************************************************/
+//
+// Error_Bad_Make: C
+//
+REBCTX *Error_Bad_Make(enum Reb_Kind type, const REBVAL *spec)
{
- Trap2(RE_CANNOT_USE, Get_Action_Word(action), Get_Type(type));
+ return Error_Bad_Make_Arg_Raw(Get_Type(type), spec);
}
-/***********************************************************************
-**
-*/ void Trap_Math_Args(REBCNT type, REBCNT action)
-/*
-***********************************************************************/
+//
+// Error_Cannot_Reflect: C
+//
+REBCTX *Error_Cannot_Reflect(enum Reb_Kind type, const REBVAL *arg)
{
- Trap2(RE_NOT_RELATED, Get_Action_Word(action), Get_Type(type));
+ return Error_Cannot_Use_Raw(arg, Get_Type(type));
}
-/***********************************************************************
-**
-*/ void Trap_Types(REBCNT errnum, REBCNT type1, REBCNT type2)
-/*
-***********************************************************************/
+//
+// Error_On_Port: C
+//
+REBCTX *Error_On_Port(REBCNT errnum, REBCTX *port, REBINT err_code)
{
- if (type2 != 0) Trap2(errnum, Get_Type(type1), Get_Type(type2));
- Trap1(errnum, Get_Type(type1));
+ REBVAL *spec = CTX_VAR(port, STD_PORT_SPEC);
+ if (!IS_OBJECT(spec))
+ fail (Error_Invalid_Port_Raw());
+
+ REBVAL *val = VAL_CONTEXT_VAR(spec, STD_PORT_SPEC_HEAD_REF); // informative
+ if (IS_BLANK(val))
+ val = VAL_CONTEXT_VAR(spec, STD_PORT_SPEC_HEAD_TITLE); // less info
+
+ DECLARE_LOCAL (err_code_value);
+ Init_Integer(err_code_value, err_code);
+
+ return Error(errnum, val, err_code_value, END);
}
-/***********************************************************************
-**
-*/ void Trap_Expect(REBVAL *object, REBCNT index, REBCNT type)
-/*
-** Object field is not of expected type.
-** PORT expected SCHEME of OBJECT type
-**
-***********************************************************************/
+//
+// Exit_Status_From_Value: C
+//
+// This routine's job is to turn an arbitrary value into an
+// operating system exit status:
+//
+// https://en.wikipedia.org/wiki/Exit_status
+//
+int Exit_Status_From_Value(REBVAL *value)
{
- Trap3(RE_EXPECT_TYPE, Of_Type(object), Obj_Word(object, index), Get_Type(type));
+ assert(!THROWN(value));
+
+ if (IS_INTEGER(value)) {
+ // Fairly obviously, an integer should return an integer
+ // result. But Rebol integers are 64 bit and signed, while
+ // exit statuses don't go that large.
+ //
+ return VAL_INT32(value);
+ }
+ else if (IS_VOID(value) || IS_BLANK(value)) {
+ // An unset would happen with just QUIT or EXIT and no /WITH,
+ // so treating that as a 0 for success makes sense. A NONE!
+ // seems like nothing to report as well, for instance:
+ //
+ // exit/with if badthing [badthing-code]
+ //
+ return 0;
+ }
+ else if (IS_ERROR(value)) {
+ // Rebol errors do have an error number in them, and if your
+ // program tries to return a Rebol error it seems it wouldn't
+ // hurt to try using that. They may be out of range for
+ // platforms using byte-sized error codes, however...but if
+ // that causes bad things OS_EXIT() should be graceful about it.
+ //
+ return VAL_ERR_NUM(value);
+ }
+
+ // Just 1 otherwise.
+ //
+ return 1;
}
-/***********************************************************************
-**
-*/ void Trap_Make(REBCNT type, REBVAL *spec)
-/*
-***********************************************************************/
+//
+// Startup_Errors: C
+//
+// Create error objects and error type objects
+//
+REBCTX *Startup_Errors(REBARR *boot_errors)
{
- Trap2(RE_BAD_MAKE_ARG, Get_Type(type), spec);
+ REBCTX *catalog = Construct_Context(
+ REB_OBJECT,
+ ARR_HEAD(boot_errors),
+ SPECIFIED, // we're confident source array isn't in a function body
+ NULL
+ );
+
+ // Create objects for all error types (CAT_ERRORS is "selfish", currently
+ // so self is in slot 1 and the actual errors start at context slot 2)
+ //
+ REBVAL *val;
+ for (val = CTX_VAR(catalog, SELFISH(1)); NOT_END(val); val++) {
+ REBCTX *error = Construct_Context(
+ REB_OBJECT,
+ VAL_ARRAY_HEAD(val),
+ SPECIFIED, // source array not in a function body
+ NULL
+ );
+ Init_Object(val, error);
+ }
+
+ return catalog;
}
-/***********************************************************************
-**
-*/ void Trap_Num(REBCNT err, REBCNT num)
-/*
-***********************************************************************/
+//
+// Security_Policy: C
+//
+// Given a security symbol (like FILE) and a value (like the file
+// path) returns the security policy (RWX) allowed for it.
+//
+// Args:
+//
+// sym: word that represents the type ['file 'net]
+// name: file or path value
+//
+// Returns BTYE array of flags for the policy class:
+//
+// flags: [rrrr wwww xxxx ----]
+//
+// Where each byte is:
+// 0: SEC_ALLOW
+// 1: SEC_ASK
+// 2: SEC_THROW
+// 3: SEC_QUIT
+//
+// The secuity is defined by the system/state/policies object, that
+// is of the form:
+//
+// [
+// file: [%file1 tuple-flags %file2 ... default tuple-flags]
+// net: [...]
+// call: tuple-flags
+// stack: tuple-flags
+// eval: integer (limit)
+// ]
+//
+REBYTE *Security_Policy(REBSTR *spelling, REBVAL *name)
{
- DS_PUSH_INTEGER(num);
- Trap1(err, DS_TOP);
+ REBVAL *policy = Get_System(SYS_STATE, STATE_POLICIES);
+ REBYTE *flags;
+ REBCNT len;
+ REBCNT errcode = RE_SECURITY_ERROR;
+
+ if (!IS_OBJECT(policy)) goto error;
+
+ // Find the security class in the block: (file net call...)
+ policy = Select_Canon_In_Context(VAL_CONTEXT(policy), STR_CANON(spelling));
+ if (!policy) goto error;
+
+ // Obtain the policies for it:
+ // Check for a master tuple: [file rrrr.wwww.xxxx]
+ if (IS_TUPLE(policy)) return VAL_TUPLE(policy); // non-aligned
+ // removed A90: if (IS_INTEGER(policy)) return (REBYTE*)VAL_INT64(policy); // probably not used
+
+ // Only other form is detailed block:
+ if (!IS_BLOCK(policy)) goto error;
+
+ // Scan block of policies for the class: [file [allow read quit write]]
+ len = 0; // file or url length
+ flags = 0; // policy flags
+
+ policy = KNOWN(VAL_ARRAY_HEAD(policy)); // no relatives in STATE_POLICIES
+
+ for (; NOT_END(policy); policy += 2) {
+
+ // Must be a policy tuple:
+ if (!IS_TUPLE(policy+1)) goto error;
+
+ // Is it a policy word:
+ if (IS_WORD(policy)) { // any word works here
+ // If no strings found, use the default:
+ if (len == 0) flags = VAL_TUPLE(policy+1); // non-aligned
+ }
+
+ // Is it a string (file or URL):
+ else if (ANY_BINSTR(policy) && name) {
+ if (Match_Sub_Path(VAL_SERIES(policy), VAL_SERIES(name))) {
+ // Is the match adequate?
+ if (VAL_LEN_HEAD(name) >= len) {
+ len = VAL_LEN_HEAD(name);
+ flags = VAL_TUPLE(policy+1); // non-aligned
+ }
+ }
+ }
+ else goto error;
+ }
+
+ if (!flags) {
+ errcode = RE_SECURITY;
+ policy = name ? name : 0;
+
+ error:
+ ; // need statement
+ DECLARE_LOCAL (temp);
+ if (!policy) {
+ Init_Word(temp, spelling);
+ policy = temp;
+ }
+ fail (Error(errcode, policy));
+ }
+
+ return flags;
}
-/***********************************************************************
-**
-*/ void Trap_Reflect(REBCNT type, REBVAL *arg)
-/*
-***********************************************************************/
+//
+// Trap_Security: C
+//
+// Take action on the policy flags provided. The sym and value
+// are provided for error message purposes only.
+//
+void Trap_Security(REBCNT flag, REBSTR *sym, REBVAL *value)
{
- Trap_Arg(arg);
+ if (flag == SEC_THROW) {
+ if (!value) {
+ Init_Word(DS_TOP, sym);
+ value = DS_TOP;
+ }
+ fail (Error_Security_Raw(value));
+ }
+ else if (flag == SEC_QUIT) OS_EXIT(101);
}
-/***********************************************************************
-**
-*/ void Trap_Port(REBCNT errnum, REBSER *port, REBINT err_code)
-/*
-***********************************************************************/
+//
+// Check_Security: C
+//
+// A helper function that fetches the security flags for
+// a given symbol (FILE) and value (path), and then tests
+// that they are allowed.
+//
+void Check_Security(REBSTR *sym, REBCNT policy, REBVAL *value)
{
- REBVAL *spec = OFV(port, STD_PORT_SPEC);
- REBVAL *val;
+ REBYTE *flags;
+
+ flags = Security_Policy(sym, value);
+ Trap_Security(flags[policy], sym, value);
+}
- if (!IS_OBJECT(spec)) Trap0(RE_INVALID_PORT);
- val = Get_Object(spec, STD_PORT_SPEC_HEAD_REF); // most informative
- if (IS_NONE(val)) val = Get_Object(spec, STD_PORT_SPEC_HEAD_TITLE);
+//
+// Make_OS_Error: C
+//
+void Make_OS_Error(REBVAL *out, int errnum)
+{
+ REBCHR str[100];
- DS_PUSH_INTEGER(err_code);
- Trap2(errnum, val, DS_TOP);
+ OS_FORM_ERROR(errnum, str, 100);
+ Init_String(out, Copy_OS_Str(str, OS_STRLEN(str)));
}
-/***********************************************************************
-**
-*/ REBINT Check_Error(REBVAL *val)
-/*
-** Process a loop exceptions. Pass in the TOS value, returns:
-**
-** 2 - if break/return, change val to that set by break
-** 1 - if break
-** -1 - if continue, change val to unset
-** 0 - if not break or continue
-** else: error if not an ERROR value
-**
-***********************************************************************/
+//
+// Find_Next_Error_Base_Code: C
+//
+// Find in system/catalog/errors the next error base (used by extensions)
+//
+REBINT Find_Next_Error_Base_Code(void)
{
- // It's UNSET, not an error:
- if (!IS_ERROR(val))
- Trap0(RE_NO_RETURN); //!!! change to special msg
-
- // If it's a BREAK, check for /return value:
- if (IS_BREAK(val)) {
- if (VAL_ERR_VALUE(val)) {
- *val = *VAL_ERR_VALUE(val);
- return 2;
- } else {
- SET_UNSET(val);
- return 1;
- }
- }
-
- if (IS_CONTINUE(val)) {
- SET_UNSET(val);
- return -1;
- }
-
- return 0;
- // Else: Let all other errors return as values.
-}
-
-
-/***********************************************************************
-**
-*/ void Init_Errors(REBVAL *errors)
-/*
-***********************************************************************/
-{
- REBSER *errs;
- REBVAL *val;
-
- // Create error objects and error type objects:
- *ROOT_ERROBJ = *Get_System(SYS_STANDARD, STD_ERROR);
- errs = Construct_Object(0, VAL_BLK(errors), 0);
- Set_Object(Get_System(SYS_CATALOG, CAT_ERRORS), errs);
-
- Set_Root_Series(TASK_ERR_TEMPS, Make_Block(3), "task errors");
-
- // Create objects for all error types:
- for (val = BLK_SKIP(errs, 1); NOT_END(val); val++) {
- errs = Construct_Object(0, VAL_BLK(val), 0);
- SET_OBJECT(val, errs);
- }
-
- // Catch top level errors, to provide decent output:
- PUSH_STATE(Top_State, Saved_State);
- if (SET_JUMP(Top_State)) {
- POP_STATE(Top_State, Saved_State);
- DSP++; // Room for return value
- Catch_Error(DS_TOP); // Stores error value here
- Print_Value(DS_TOP, 0, FALSE);
- Crash(RP_NO_CATCH);
- }
- SET_STATE(Top_State, Saved_State);
-}
-
-
-/***********************************************************************
-**
-*/ REBYTE *Security_Policy(REBCNT sym, REBVAL *name)
-/*
-** Given a security symbol (like FILE) and a value (like the file
-** path) returns the security policy (RWX) allowed for it.
-**
-** Args:
-**
-** sym: word that represents the type ['file 'net]
-** name: file or path value
-**
-** Returns BTYE array of flags for the policy class:
-**
-** flags: [rrrr wwww xxxx ----]
-**
-** Where each byte is:
-** 0: SEC_ALLOW
-** 1: SEC_ASK
-** 2: SEC_THROW
-** 3: SEC_QUIT
-**
-** The secuity is defined by the system/state/policies object, that
-** is of the form:
-**
-** [
-** file: [%file1 tuple-flags %file2 ... default tuple-flags]
-** net: [...]
-** call: tuple-flags
-** stack: tuple-flags
-** eval: integer (limit)
-** ]
-**
-***********************************************************************/
-{
- REBVAL *policy = Get_System(SYS_STATE, STATE_POLICIES);
- REBYTE *flags;
- REBCNT len;
- REBCNT errcode = RE_SECURITY_ERROR;
-
- if (!IS_OBJECT(policy)) goto error;
-
- // Find the security class in the block: (file net call...)
- policy = Find_Word_Value(VAL_OBJ_FRAME(policy), sym);
- if (!policy) goto error;
-
- // Obtain the policies for it:
- // Check for a master tuple: [file rrrr.wwww.xxxx]
- if (IS_TUPLE(policy)) return VAL_TUPLE(policy); // non-aligned
- // removed A90: if (IS_INTEGER(policy)) return (REBYTE*)VAL_INT64(policy); // probably not used
-
- // Only other form is detailed block:
- if (!IS_BLOCK(policy)) goto error;
-
- // Scan block of policies for the class: [file [allow read quit write]]
- len = 0; // file or url length
- flags = 0; // policy flags
- for (policy = VAL_BLK(policy); NOT_END(policy); policy += 2) {
-
- // Must be a policy tuple:
- if (!IS_TUPLE(policy+1)) goto error;
-
- // Is it a policy word:
- if (IS_WORD(policy)) { // any word works here
- // If no strings found, use the default:
- if (len == 0) flags = VAL_TUPLE(policy+1); // non-aligned
- }
-
- // Is it a string (file or URL):
- else if (ANY_BINSTR(policy) && name) {
- //Debug_Fmt("sec: %r %r", policy, name);
- if (Match_Sub_Path(VAL_SERIES(policy), VAL_SERIES(name))) {
- // Is the match adequate?
- if (VAL_TAIL(name) >= len) {
- len = VAL_TAIL(name);
- flags = VAL_TUPLE(policy+1); // non-aligned
- }
- }
- }
- else goto error;
- }
-
- if (!flags) {
- errcode = RE_SECURITY;
- policy = name ? name : 0;
-error:
- if (!policy) {
- Init_Word(DS_TOP, sym);
- policy = DS_TOP;
- }
- Trap1(errcode, policy);
- }
-
- return flags;
-}
-
-
-/***********************************************************************
-**
-*/ void Trap_Security(REBCNT flag, REBCNT sym, REBVAL *value)
-/*
-** Take action on the policy flags provided. The sym and value
-** are provided for error message purposes only.
-**
-***********************************************************************/
-{
- if (flag == SEC_THROW) {
- if (!value) {
- Init_Word(DS_TOP, sym);
- value = DS_TOP;
- }
- Trap1(RE_SECURITY, value);
- }
- else if (flag == SEC_QUIT) OS_EXIT(101);
-}
-
-
-/***********************************************************************
-**
-*/ void Check_Security(REBCNT sym, REBCNT policy, REBVAL *value)
-/*
-** A helper function that fetches the security flags for
-** a given symbol (FILE) and value (path), and then tests
-** that they are allowed.
-**
-***********************************************************************/
-{
- REBYTE *flags;
-
- flags = Security_Policy(sym, value);
- Trap_Security(flags[policy], sym, value);
+ REBCTX * categories = VAL_CONTEXT(Get_System(SYS_CATALOG, CAT_ERRORS));
+ if (CTX_LEN(categories) > RE_USER / RE_CATEGORY_SIZE)
+ fail (Error_Out_Of_Error_Numbers_Raw());
+ return (CTX_LEN(categories) - 1) * RE_CATEGORY_SIZE;
}
diff --git a/src/core/c-eval.c b/src/core/c-eval.c
new file mode 100644
index 0000000000..0ab889a9c4
--- /dev/null
+++ b/src/core/c-eval.c
@@ -0,0 +1,2087 @@
+//
+// File: %c-eval.c
+// Summary: "Central Interpreter Evaluator"
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// This file contains `Do_Core()`, which is the central evaluator which
+// is behind DO. It can execute single evaluation steps (e.g. a DO/NEXT)
+// or it can run the array to the end of its content. A flag controls that
+// behavior, and there are DO_FLAG_XXX for controlling other behaviors.
+//
+// For comprehensive notes on the input parameters, output parameters, and
+// internal state variables...see %sys-rebfrm.h.
+//
+// NOTES:
+//
+// * Do_Core() is a very long routine. That is largely on purpose, because it
+// doesn't contain repeated portions. If it were broken into functions that
+// would add overhead for little benefit, and prevent interesting tricks
+// and optimizations. Note that it is separated into sections, and
+// the invariants in each section are made clear with comments and asserts.
+//
+// * The evaluator only moves forward, and it consumes exactly one element
+// from the input at a time. This input may be a source where the index
+// needs to be tracked and care taken to contain the index within its
+// boundaries in the face of change (e.g. a mutable ARRAY). Or it may be
+// an entity which tracks its own position on each fetch (e.g. a C va_list)
+//
+
+#include "sys-core.h"
+
+
+#if !defined(NDEBUG)
+ //
+ // The `do_count` should be visible in the C debugger watchlist as a
+ // local variable in Do_Core() for each stack level. So if a fail()
+ // happens at a deterministic moment in a run, capture the number from
+ // the level of interest and recompile with it here to get a breakpoint
+ // at that tick.
+ //
+ // Notice also that in debug builds, frames carry this value in them.
+ // *Plus* you can get the initialization tick for void cells, BLANK!s,
+ // LOGIC!s, and most end markers by looking at the `track` payload of
+ // the REBVAL cell. And series contain the do_count where they were
+ // created as well.
+ //
+ // *** DON'T COMMIT THIS v-- KEEP IT AT ZERO! ***
+ #define DO_COUNT_BREAKPOINT 0
+ // *** DON'T COMMIT THIS --^ KEEP IT AT ZERO! ***
+ //
+ // Note: Taking this number on the command line sounds convenient, though
+ // with command line processing in usermode it would throw the number off
+ // between runs.
+ //
+ // Note also there is `Dump_Frame_Location()` if there's a trouble spot
+ // and you want to see what the state is. It will reify C va_list
+ // input for you, so you can see what the C caller passed as an array.
+ //
+#endif
+
+
+static inline REBOOL Start_New_Expression_Throws(REBFRM *f) {
+ assert(Eval_Count >= 0);
+ if (--Eval_Count == 0) {
+ //
+ // Note that Do_Signals_Throws() may do a recycle step of the GC, or
+ // it may spawn an entire interactive debugging session via
+ // breakpoint before it returns. It may also FAIL and longjmp out.
+ //
+ SET_END(&f->cell);
+ if (Do_Signals_Throws(&f->cell)) {
+ Move_Value(f->out, &f->cell);
+ return TRUE;
+ }
+
+ assert(IS_END(&f->cell));
+ }
+
+ UPDATE_EXPRESSION_START(f); // !!! See FRM_INDEX() for caveats
+ if (Trace_Flags)
+ Trace_Line(f);
+
+ return FALSE;
+}
+
+#define START_NEW_EXPRESSION_MAY_THROW_COMMON(f,g) \
+ if (Start_New_Expression_Throws(f)) \
+ g; \
+ args_evaluate = NOT((f)->flags.bits & DO_FLAG_NO_ARGS_EVALUATE); \
+
+#ifdef NDEBUG
+ #define START_NEW_EXPRESSION_MAY_THROW(f,g) \
+ START_NEW_EXPRESSION_MAY_THROW_COMMON(f, g)
+#else
+ // Macro is used to mutate local do_count variable in Do_Core (for easier
+ // browsing in the watchlist) as well as to not be in a deeper stack level
+ // than Do_Core when a DO_COUNT_BREAKPOINT is hit.
+ //
+ #define START_NEW_EXPRESSION_MAY_THROW(f,g) \
+ do { \
+ START_NEW_EXPRESSION_MAY_THROW_COMMON(f, g); \
+ do_count = Do_Core_Expression_Checks_Debug(f); \
+ if (do_count == DO_COUNT_BREAKPOINT) { \
+ Debug_Fmt("DO_COUNT_BREAKPOINT at %d", f->do_count_debug); \
+ Dump_Frame_Location(f); \
+ debug_break(); /* see %debug_break.h */ \
+ } \
+ } while (FALSE)
+#endif
+
+static inline void Drop_Function_Args_For_Frame(REBFRM *f) {
+ Drop_Function_Args_For_Frame_Core(f, TRUE);
+}
+
+static inline void Abort_Function_Args_For_Frame(REBFRM *f) {
+ Drop_Function_Args_For_Frame(f);
+
+ // If a function call is aborted, there may be pending refinements (if
+ // in the gathering phase) or functions (if running a chainer) on the
+ // data stack. They must be dropped to balance.
+ //
+ DS_DROP_TO(f->dsp_orig);
+}
+
+static inline void Link_Vararg_Param_To_Frame(REBFRM *f, REBOOL make) {
+ assert(GET_VAL_FLAG(f->param, TYPESET_FLAG_VARIADIC));
+
+ // Note that this varlist is to a context with bad cells in
+ // any unfilled arg slots. Because of this, there needs to
+ // be special handling in the GC that knows *not* to try
+ // and walk these incomplete arrays sitting in the argument
+ // slots if they're not ready...
+ //
+ if (
+ f->varlist == NULL
+ || NOT_SER_FLAG(f->varlist, ARRAY_FLAG_VARLIST)
+ ){
+ // Don't use ordinary call to Context_For_Frame_May_Reify
+ // because this special case allows reification even
+ // though the frame is pending.
+ //
+ Reify_Frame_Context_Maybe_Fulfilling(f);
+ }
+ f->arg->extra.binding = f->varlist;
+
+ // Store the offset so that both the f->arg and f->param locations can
+ // be quickly recovered, while using only a single slot in the REBVAL.
+ //
+ f->arg->payload.varargs.param_offset = f->arg - f->args_head;
+
+ // The data feed doesn't necessarily come from the frame
+ // that has the parameter and the argument. A varlist may be
+ // chained such that its data came from another frame, or just
+ // an ordinary array.
+ //
+ if (make) {
+ VAL_RESET_HEADER(f->arg, REB_VARARGS);
+ f->arg->payload.varargs.feed = f->varlist;
+ }
+ else
+ assert(VAL_TYPE(f->arg) == REB_VARARGS);
+
+ assert(GET_SER_FLAG(f->arg->payload.varargs.feed, SERIES_FLAG_ARRAY));
+}
+
+
+//
+// f->refine is a bit tricky. If it IS_LOGIC() and TRUE, then this means that
+// a refinement is active but revokable, having its arguments gathered. So
+// it actually points to the f->arg of the active refinement slot. If
+// evaluation of an argument in this state produces no value, the refinement
+// must be revoked, and its value mutated to be FALSE.
+//
+// But all the other values that f->refine can hold are read-only pointers
+// that signal something about the argument gathering state:
+//
+// * If VOID_CELL, then refinements are being skipped and the arguments
+// that follow should not be written to.
+//
+// * If BLANK_VALUE, this is an arg to a refinement that was not used in
+// the invocation. No consumption should be performed, arguments should
+// be written as unset, and any non-unset specializations of arguments
+// should trigger an error.
+//
+// * If FALSE_VALUE, this is an arg to a refinement that was used in the
+// invocation but has been *revoked*. It still consumes expressions
+// from the callsite for each remaining argument, but those expressions
+// must not evaluate to any value.
+//
+// * If EMPTY_BLOCK, it's an ordinary arg...and not a refinement. It will
+// be evaluated normally but is not involved with revocation.
+//
+// * If EMPTY_STRING, the evaluator's next argument fulfillment is the
+// left-hand argument of a lookback operation. After that fulfillment,
+// it will be transitioned to EMPTY_BLOCK.
+//
+// Because of how this lays out, IS_CONDITIONAL_TRUE() can be used to
+// determine if an argument should be type checked normally...while
+// IS_CONDITIONAL_FALSE() means that the arg's bits must be set to void.
+//
+// These special values are all pointers to read-only cells, but are cast to
+// mutable in order to be held in the same pointer that might write to a
+// refinement to revoke it. Note that since literal pointers are used, tests
+// like `f->refine == BLANK_VALUE` are faster than `IS_BLANK(f->refine)`.
+//
+#define SKIPPING_REFINEMENT_ARGS m_cast(REBVAL*, VOID_CELL)
+#define ARG_TO_UNUSED_REFINEMENT m_cast(REBVAL*, BLANK_VALUE)
+#define ARG_TO_REVOKED_REFINEMENT m_cast(REBVAL*, FALSE_VALUE)
+#define ORDINARY_ARG m_cast(REBVAL*, EMPTY_BLOCK)
+#define LOOKBACK_ARG m_cast(REBVAL*, EMPTY_STRING)
+
+
+//
+// Do_Core: C
+//
+// While this routine looks very complex, it's actually not that difficult
+// to step through. A lot of it is assertions, debug tracking, and comments.
+//
+// Comments on the definition of Reb_Frame are a good place to start looking
+// to understand what's going on. See %sys-rebfrm.h for full details.
+//
+// These fields are required upon initialization:
+//
+// f->out*
+// REBVAL pointer to which the evaluation's result should be written,
+// must point to initialized bits, and that needs to be an END marker,
+// unless it's in lookback mode, in which case it must be the REBVAL to
+// use as first argument (infix/postfix/"enfixed" functions)
+//
+// f->value
+// Fetched first value to execute (cannot be an END marker)
+//
+// f->source
+// Contains the REBARR* or C va_list of subsequent values to fetch
+//
+// f->index
+// Needed if f->source is an array (can be garbage if it's a C va_list)
+//
+// f->pending
+// Must be VA_LIST_PENDING if source is a va_list, else starts out NULL
+//
+// f->specifier
+// Resolver for bindings of values in f->source, SPECIFIED if all resolved
+//
+// f->gotten
+// Must be either be the Get_Var() lookup of f->value, or NULL
+//
+// More detailed assertions of the preconditions, postconditions, and state
+// at each evaluation step are contained in %d-eval.c
+//
+void Do_Core(REBFRM * const f)
+{
+#if !defined(NDEBUG)
+ REBUPT do_count = f->do_count_debug = TG_Do_Count; // snapshot start tick
+#endif
+
+ REBOOL args_evaluate; // set on every iteration (varargs do, EVAL/ONLY...)
+
+ // APPLY and a DO of a FRAME! both use this same code path.
+ //
+ if (f->flags.bits & DO_FLAG_APPLYING) {
+ f->eval_type = REB_FUNCTION;
+ args_evaluate = NOT(f->flags.bits & DO_FLAG_NO_ARGS_EVALUATE);
+ f->refine = ORDINARY_ARG; // "APPLY infix" not supported
+ goto do_function_arglist_in_progress;
+ }
+
+ // Some initialized bit pattern is needed to check to see if a
+ // function call is actually in progress, or if eval_type is just
+ // REB_FUNCTION but doesn't have valid args/state. The label is a
+ // good choice because it is only affected by the function call case,
+ // see Is_Function_Frame_Fulfilling().
+ //
+ f->label = NULL;
+ f->eval_type = VAL_TYPE(f->value);
+
+#if !defined(NDEBUG)
+ SNAP_STATE(&f->state_debug); // to make sure stack balances, etc.
+ Do_Core_Entry_Checks_Debug(f); // run once per Do_Core()
+#endif
+
+ // This is an important guarantee...the out slot needs to have some form
+ // of initialization to allow GC. END is chosen because that is what
+ // natives can count on the f->out slot to be, but lookback arguments
+ // also are passed by way of the out slot.
+ //
+ assert(NOT(IS_TRASH_DEBUG(f->out)));
+
+ // Capture the data stack pointer on entry (used by debug checks, but
+ // also refinements are pushed to stack and need to be checked if there
+ // are any that are not processed)
+ //
+ f->dsp_orig = DSP;
+
+do_next:;
+
+ START_NEW_EXPRESSION_MAY_THROW(f, goto finished);
+ // ^-- sets args_evaluate, do_count, Ctrl-C may abort
+
+reevaluate:;
+ //
+ // ^-- doesn't advance expression index, so `eval x` starts with `eval`
+ // also EVAL/ONLY may change args_evaluate to FALSE for a cycle
+
+ //==////////////////////////////////////////////////////////////////==//
+ //
+ // LOOKAHEAD TO ENABLE ENFIXED FUNCTIONS THAT QUOTE THEIR LEFT ARG
+ //
+ //==////////////////////////////////////////////////////////////////==//
+
+ // Ren-C has an additional lookahead step *before* an evaluation in order
+ // to take care of this scenario. To do this, it pre-emptively feeds the
+ // frame one unit that f->value is the *next* value, and a local variable
+ // called "current" holds the current head of the expression that the
+ // switch will be processing.
+ //
+ // Additionally, it attempts to reuse any lookahead fetching done with
+ // Get_Var. In the general case, this is not going to be possible, e.g.:
+ //
+ // obj: make object! [x: 10]
+ // foo: does [append obj [y: 20]]
+ // do in obj [foo x]
+ //
+ // Consider the lookahead fetch for `foo x`. It will get x to f->gotten,
+ // and see that it is not a lookback function. But then when it runs foo,
+ // the memory location where x had been found before may have moved due
+ // to expansion. Basically any function call invalidates f->gotten, as
+ // does obviously any Fetch_Next_In_Frame (because the position changes)
+ //
+ // !!! Review how often gotten has hits vs. misses, and what the benefit
+ // of the feature actually is.
+
+ const RELVAL *current;
+ const REBVAL *current_gotten;
+
+ current = f->value; // <-- DO_COUNT_BREAKPOINT landing spot
+ current_gotten = f->gotten;
+ f->gotten = END;
+ Fetch_Next_In_Frame(f);
+
+ // !!! We never want to do infix processing if the args aren't evaluating
+ // (e.g. arguments in a va_list from a C function calling into Rebol)
+ // But this is distinct from DO_FLAG_NO_LOOKAHEAD (which Apply_Only also
+ // sets), which really controls the after lookahead step. Consider this
+ // edge case.
+ //
+ if (NOT_END(f->value) && IS_WORD(f->value) && args_evaluate) {
+ //
+ // While the next item may be a WORD! that looks up to an enfixed
+ // function, and it may want to quote what's on its left...there
+ // could be a conflict. This happens if the current item is also
+ // a WORD!, but one that looks up to a prefix function that wants
+ // to quote what's on its right!
+ //
+ if (f->eval_type == REB_WORD) {
+ if (current_gotten == END)
+ current_gotten = Get_Opt_Var_Else_End(current, f->specifier);
+ else
+ assert(
+ current_gotten
+ == Get_Opt_Var_Else_End(current, f->specifier)
+ );
+
+ if (
+ VAL_TYPE_OR_0(current_gotten) == REB_FUNCTION // END is REB_0
+ && NOT_VAL_FLAG(current_gotten, VALUE_FLAG_ENFIXED)
+ && GET_VAL_FLAG(current_gotten, FUNC_FLAG_QUOTES_FIRST_ARG)
+ ){
+ // Yup, it quotes. We could look for a conflict and call
+ // it an error, but instead give the left hand side precedence
+ // over the right. This means something like:
+ //
+ // foo: quote -> [print quote]
+ //
+ // Would be interpreted as:
+ //
+ // foo: (quote ->) [print quote]
+ //
+ // This is a good argument for not making enfixed operations
+ // that hard-quote things that can dispatch functions. A
+ // soft-quote would give more flexibility to override the
+ // left hand side's precedence, e.g. the user writes:
+ //
+ // foo: ('quote) -> [print quote]
+ //
+ f->eval_type = REB_FUNCTION;
+ SET_FRAME_LABEL(f, VAL_WORD_SPELLING(current));
+ f->refine = ORDINARY_ARG;
+ goto do_function_in_current_gotten;
+ }
+ }
+
+ f->gotten = Get_Opt_Var_Else_End(f->value, f->specifier);
+
+ if (
+ VAL_TYPE_OR_0(f->gotten) == REB_FUNCTION // END is REB_0
+ && ALL_VAL_FLAGS(
+ f->gotten, VALUE_FLAG_ENFIXED | FUNC_FLAG_QUOTES_FIRST_ARG
+ )
+ ){
+ f->eval_type = REB_FUNCTION;
+ SET_FRAME_LABEL(f, VAL_WORD_SPELLING(f->value));
+
+ // The protocol for lookback is that the lookback argument is
+ // consumed from the f->out slot. It will ultimately wind up
+ // moved into the frame, so having the quoting cases get
+ // it there by way of the f->out is *slightly* inefficient. But
+ // since evaluative cases do wind up with the value in f->out,
+ // and are much more common, it's not worth worrying about.
+ //
+ f->refine = LOOKBACK_ARG;
+ Derelativize(f->out, current, f->specifier);
+
+ #if !defined(NDEBUG)
+ //
+ // Since the value is going to be copied into an arg slot anyway,
+ // setting the unevaluated flag here isn't necessary. However,
+ // it allows for an added debug check that if an enfixed parameter
+ // is hard or soft quoted, it *probably* came from here.
+ //
+ SET_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ #endif
+
+ current_gotten = f->gotten; // the function
+
+ // We don't want the WORD! that invoked the function to act like
+ // an argument, so we have to advance the frame once more.
+ //
+ f->gotten = END;
+ Fetch_Next_In_Frame(f);
+
+ goto do_function_in_current_gotten;
+ }
+ }
+
+ //==////////////////////////////////////////////////////////////////==//
+ //
+ // BEGIN MAIN SWITCH STATEMENT
+ //
+ //==////////////////////////////////////////////////////////////////==//
+
+ // This switch is done via contiguous REB_XXX values, in order to
+ // facilitate use of a "jump table optimization":
+ //
+ // http://stackoverflow.com/questions/17061967/c-switch-and-jump-tables
+
+ switch (f->eval_type) {
+
+ case REB_0:
+ assert(FALSE); // internal type.
+ break;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [FUNCTION!] (lookback or non-lookback)
+//
+// If a function makes it to the SWITCH statement, that means it is either
+// literally a function value in the array (`do compose [(:+) 1 2]`) or is
+// being retriggered via EVAL
+//
+// Most function evaluations are triggered from a SWITCH on a WORD! or PATH!,
+// which jumps in at the `do_function_in_current_gotten` label.
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_FUNCTION: // literal function in a block
+ current_gotten = const_KNOWN(current);
+ SET_FRAME_LABEL(f, Canon(SYM___ANONYMOUS__)); // nameless literal
+
+ if (GET_VAL_FLAG(current_gotten, VALUE_FLAG_ENFIXED)) {
+ //
+ // f->out can't be trash, but it can be an END.
+ //
+ f->refine = LOOKBACK_ARG;
+ }
+ else {
+ SET_END(f->out); // clear out previous result (needs GC-safe data)
+ f->refine = ORDINARY_ARG;
+ }
+
+ do_function_in_current_gotten:
+ assert(IS_FUNCTION(current_gotten));
+ assert(f->eval_type == REB_FUNCTION);
+ TRASH_POINTER_IF_DEBUG(current); // shouldn't be used below
+
+ // There may be refinements pushed to the data stack to process, if
+ // the call originated from a path dispatch.
+ //
+ assert(DSP >= f->dsp_orig);
+
+ //==////////////////////////////////////////////////////////////////==//
+ //
+ // FUNCTION! NORMAL ARGUMENT FULFILLMENT PROCESS
+ //
+ //==////////////////////////////////////////////////////////////////==//
+
+ // We assume you can enumerate both the formal parameters (in the
+ // spec) and the actual arguments (in the call frame) using pointer
+ // incrementation, that they are both terminated by END, and
+ // that there are an equal number of values in both.
+ //
+ // Push_Or_Alloc_Args sets the frame's function, sets args_head...
+ //
+ Push_Or_Alloc_Args_For_Underlying_Func(f, current_gotten);
+
+ do_function_arglist_in_progress:
+
+ assert(f->label != NULL); // must be something (even "anonymous")
+ #if !defined(NDEBUG)
+ assert(f->label_debug != NULL); // SET_FRAME_LABEL sets (C debugging)
+ #endif
+
+ Eval_Functions++; // this isn't free...is it worth tracking?
+
+ // Now that we have extracted f->phase, we do not have to worry that
+ // f->value might have lived in f->cell.eval. We can't overwrite
+ // f->out during the argument evaluations, in case that is holding the
+ // first argument to an infix function, so f->cell gets used for
+ // temporary evaluations up until the point the function gets called.
+
+ assert(f->refine == ORDINARY_ARG || f->refine == LOOKBACK_ARG);
+
+ f->arg = f->args_head;
+ f->param = FUNC_FACADE_HEAD(f->phase);
+ // f->special is END, f->args_head, or first specialized value
+
+ // Same as check before switch. (do_function_arglist_in_progress:
+ // might have a goto from another point, so we check it again here)
+ //
+ assert(IS_END(f->out) || f->refine == LOOKBACK_ARG);
+
+ //==////////////////////////////////////////////////////////////////==//
+ //
+ // FUNCTION! NORMAL ARGUMENT FULFILLMENT LOOP
+ //
+ //==////////////////////////////////////////////////////////////////==//
+
+ // This loop goes through the parameter and argument slots. Though
+ // the argument slots must be protected from garbage collection once
+ // they are filled, they start out uninitialized. (The GC has access
+ // to the frame list, so it can examine f->arg and avoid trying to
+ // protect slots that come after it.)
+ //
+ // Based on the parameter type, it may be necessary to "consume" an
+ // expression from values that come after the invocation point. But
+ // not all params will consume arguments for all calls.
+ //
+ // This one body of code to is able to handle both function
+ // specialization and ordinary invocation. f->special is used to
+ // either step through a list of specialized values (with void as a
+ // signal of no specialization), to step through the arguments if
+ // they are just being type checked, or END otherwise.
+
+ enum Reb_Param_Class pclass; // gotos would cross it if inside loop
+
+ f->doing_pickups = FALSE; // still looking for way to encode in refine
+
+ while (NOT_END(f->param)) {
+ pclass = VAL_PARAM_CLASS(f->param);
+
+ //=//// A /REFINEMENT ARG /////////////////////////////////////////////=//
+
+ // Refinements are checked first for a reason. This is to
+ // short-circuit based on the `doing_pickups` flag before redoing
+ // fulfillments on arguments that have already been handled.
+ //
+ // The reason an argument might have already been handled is
+ // that some refinements have to reach back and be revisited after
+ // the original parameter walk. They can't be fulfilled in a
+ // single pass because these two calls mean different things:
+ //
+ // foo: func [a /b c /d e] [...]
+ //
+ // foo/b/d (1 + 2) (3 + 4) (5 + 6)
+ // foo/d/b (1 + 2) (3 + 4) (5 + 6)
+ //
+ // The order of refinements in the definition (b d) may not match
+ // what order the refinements are invoked in the path. This means
+ // the "visitation order" of the parameters while walking across
+ // parameters in the array might not match the "consumption order"
+ // of the expressions that are being fetched from the callsite.
+ //
+ // Hence refinements are targeted to be revisited by "pickups"
+ // after the initial parameter walk. An out-of-order refinement
+ // makes a note in the stack about a parameter and arg position
+ // it sees that it will need to come back to. A REB_0_PICKUP
+ // is used to track this (it holds a cache of the parameter and
+ // argument position).
+
+ if (pclass == PARAM_CLASS_REFINEMENT) {
+
+ if (f->doing_pickups) {
+ f->param = END; // !Is_Function_Frame_Fulfilling
+ #if !defined(NDEBUG)
+ f->arg = m_cast(REBVAL*, END); // checked after
+ #endif
+ break;
+ }
+
+ if (f->special != END) {
+ if (f->special == f->arg) {
+ //
+ // We're just checking the values already in the
+ // frame, so fall through and test the arg slot.
+ // However, offer a special tolerance here for void
+ // since MAKE FRAME! fills all arg slots with void.
+ //
+ if (IS_VOID(f->arg))
+ Init_Logic(f->arg, FALSE);
+ }
+ else {
+ // Voids in specializations mean something different,
+ // that the refinement is left up to the caller.
+ //
+ if (IS_VOID(f->special)) {
+ ++f->special;
+ goto unspecialized_refinement;
+ }
+
+ Move_Value(f->arg, f->special);
+ }
+
+ if (!IS_LOGIC(f->arg))
+ fail (Error_Non_Logic_Refinement(f));
+
+ if (IS_CONDITIONAL_TRUE(f->arg))
+ f->refine = f->arg; // remember so we can revoke!
+ else
+ f->refine = ARG_TO_UNUSED_REFINEMENT; // (read-only)
+
+ ++f->special;
+ goto continue_arg_loop;
+ }
+
+ //=//// UNSPECIALIZED REFINEMENT SLOT (no consumption) ////////////////=//
+
+ unspecialized_refinement:
+
+ if (f->dsp_orig == DSP) { // no refinements left on stack
+ Init_Logic(f->arg, FALSE);
+ f->refine = ARG_TO_UNUSED_REFINEMENT; // "don't consume"
+ goto continue_arg_loop;
+ }
+
+ f->refine = DS_TOP;
+
+ if (
+ IS_WORD(f->refine) &&
+ (
+ VAL_WORD_SPELLING(f->refine) // canon when pushed
+ == VAL_PARAM_CANON(f->param) // #2258
+ )
+ ){
+ DS_DROP; // we're lucky: this was next refinement used
+
+ Init_Logic(f->arg, TRUE); // marks refinement used
+ f->refine = f->arg; // "consume args (can be revoked)"
+ goto continue_arg_loop;
+ }
+
+ --f->refine; // not lucky: if in use, this is out of order
+
+ for (; f->refine > DS_AT(f->dsp_orig); --f->refine) {
+ if (!IS_WORD(f->refine)) continue; // non-refinement
+ if (
+ VAL_WORD_SPELLING(f->refine) // canon when pushed
+ == VAL_PARAM_CANON(f->param) // #2258
+ ){
+ // The call uses this refinement but we'll have to
+ // come back to it when the expression index to
+ // consume lines up. Make a note of the param
+ // and arg and poke them into the stack value.
+ //
+ f->refine->header.bits &= CELL_MASK_RESET;
+ f->refine->header.bits |= HEADERIZE_KIND(REB_0_PICKUP);
+ f->refine->payload.pickup.param
+ = const_KNOWN(f->param);
+ f->refine->payload.pickup.arg = f->arg;
+
+ Init_Logic(f->arg, TRUE); // marks refinement used
+ // "consume args later" (promise not to change)
+ f->refine = SKIPPING_REFINEMENT_ARGS;
+ goto continue_arg_loop;
+ }
+ }
+
+ // Wasn't in the path and not specialized, so not present
+ //
+ Init_Logic(f->arg, FALSE);
+ f->refine = ARG_TO_UNUSED_REFINEMENT; // "don't consume"
+ goto continue_arg_loop;
+ }
+
+ //=//// "PURE" LOCAL: ARG /////////////////////////////////////////////=//
+
+ // This takes care of locals, including "magic" RETURN and LEAVE
+ // cells that need to be pre-filled. Notice that although the
+ // parameter list may have RETURN and LEAVE slots, that parameter
+ // list may be reused by an "adapter" or "hijacker" which would
+ // technically happen *before* the "magic" (if the user had
+ // implemented the definitinal returns themselves inside the
+ // function body). Hence they are not always filled.
+ //
+ // Also note that while it might seem intuitive to take care of
+ // these "easy" fills before refinement checking--checking for
+ // refinement pickups ending prevents double-doing this work.
+
+ switch (pclass) {
+ case PARAM_CLASS_LOCAL:
+ Init_Void(f->arg); // faster than checking bad specializations
+ if (f->special != END)
+ ++f->special;
+ goto continue_arg_loop;
+
+ case PARAM_CLASS_RETURN:
+ assert(VAL_PARAM_SYM(f->param) == SYM_RETURN);
+
+ if (NOT_VAL_FLAG(FUNC_VALUE(f->phase), FUNC_FLAG_RETURN)) {
+ Init_Void(f->arg);
+ goto continue_arg_loop;
+ }
+
+ Move_Value(f->arg, NAT_VALUE(return));
+
+ if (f->varlist) // !!! in specific binding, always for Plain
+ f->arg->extra.binding = f->varlist;
+ else
+ f->arg->extra.binding = FUNC_PARAMLIST(FRM_UNDERLYING(f));
+
+ if (f->special != END)
+ ++f->special; // specialization being overwritten is right
+ goto continue_arg_loop;
+
+ case PARAM_CLASS_LEAVE:
+ assert(VAL_PARAM_SYM(f->param) == SYM_LEAVE);
+
+ if (NOT_VAL_FLAG(FUNC_VALUE(f->phase), FUNC_FLAG_LEAVE)) {
+ Init_Void(f->arg);
+ goto continue_arg_loop;
+ }
+
+ Move_Value(f->arg, NAT_VALUE(leave));
+
+ if (f->varlist) // !!! in specific binding, always for Plain
+ f->arg->extra.binding = f->varlist;
+ else
+ f->arg->extra.binding = FUNC_PARAMLIST(FRM_UNDERLYING(f));
+
+ if (f->special != END)
+ ++f->special; // specialization being overwritten is right
+ goto continue_arg_loop;
+
+ default:
+ break;
+ }
+
+ //=//// IF COMING BACK TO REFINEMENT ARGS LATER, MOVE ON FOR NOW //////=//
+
+ if (f->refine == SKIPPING_REFINEMENT_ARGS) {
+ //
+ // The GC will protect values up through how far we have
+ // enumerated, so the argument slot cannot be uninitialized
+ // bits once we pass it. Use a safe trash so that the debug
+ // build will be able to tell if we don't come back and
+ // overwrite it correctly during the pickups phase.
+ //
+ SET_UNREADABLE_BLANK(f->arg);
+
+ if (f->special != END)
+ ++f->special;
+ goto continue_arg_loop;
+ }
+
+ if (f->special != END) {
+ if (f->special == f->arg) {
+ //
+ // Just running the loop to verify arguments/refinements...
+ //
+ ++f->special;
+ goto check_arg;
+ }
+
+ //=//// SPECIALIZED ARG (already filled, so does not consume) /////////=//
+
+ if (IS_VOID(f->special)) {
+ //
+ // A void specialized value means this particular argument
+ // is not specialized. Still must increment the pointer
+ // before falling through to ordinary fulfillment.
+ //
+ ++f->special;
+ }
+ else {
+ Move_Value(f->arg, f->special);
+
+ ++f->special;
+ goto check_arg; // normal checking, handles errors also
+ }
+ }
+
+ //=//// IF UNSPECIALIZED ARG IS INACTIVE, SET VOID AND MOVE ON ////////=//
+
+ // Unspecialized arguments that do not consume do not need any
+ // further processing or checking. void will always be fine.
+ //
+ if (f->refine == ARG_TO_UNUSED_REFINEMENT) {
+ Init_Void(f->arg);
+ goto continue_arg_loop;
+ }
+
+ //=//// IF LOOKBACK, THEN USE PREVIOUS EXPRESSION RESULT FOR ARG //////=//
+
+ if (f->refine == LOOKBACK_ARG) {
+ //
+ // Switch to ordinary arg up front, so gotos below are good to
+ // go for the next argument
+ //
+ f->refine = ORDINARY_ARG;
+
+ // !!! Can a variadic lookback argument be meaningful?
+ // Arguably, if you have an arity-1 function which is variadic
+ // and you enfix it, then giving it a feed of either 0 or 1
+ // values and only letting it take from the left would make
+ // sense. But if it's arity-2 (e.g. multiple variadic taps)
+ // does that make any sense?
+ //
+ // It may be too wacky to worry about, and SET/LOOKBACK should
+ // just prohibit it.
+ //
+ assert(NOT_VAL_FLAG(f->param, TYPESET_FLAG_VARIADIC));
+
+ if (IS_END(f->out)) {
+ //
+ // Seeing an END in the output slot could mean that there
+ // was really "nothing" to the left, or it could be a
+ // consequence of a frame being in an argument gathering
+ // mode, e.g.
+ //
+ // if 1 then [2] ;-- error, THEN can't complete `if 1`
+ //
+ // The difference can be told by the frame flag.
+
+ if (f->flags.bits & DO_FLAG_FULFILLING_ARG)
+ fail (Error_Partial_Lookback(f));
+
+ if (NOT_VAL_FLAG(f->param, TYPESET_FLAG_ENDABLE))
+ fail (Error_No_Arg(FRM_LABEL(f), f->param));
+
+ Init_Void(f->arg);
+ goto continue_arg_loop;
+ }
+
+ switch (pclass) {
+ case PARAM_CLASS_NORMAL:
+ //
+ // The deferment of arguments for normal parameters means
+ // this situation should not happen--only an END marker
+ // should be in f->out if fulfilling an argument.
+ //
+ assert(NOT(f->flags.bits & DO_FLAG_FULFILLING_ARG));
+ Move_Value(f->arg, f->out);
+ break;
+
+ case PARAM_CLASS_TIGHT:
+ Move_Value(f->arg, f->out);
+ break;
+
+ case PARAM_CLASS_HARD_QUOTE:
+ #if !defined(NDEBUG)
+ //
+ // Only in debug builds, the before-switch lookahead sets
+ // this flag to help indicate that's where it came from.
+ //
+ assert(GET_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED));
+ #endif
+
+ Move_Value(f->arg, f->out);
+ SET_VAL_FLAG(f->arg, VALUE_FLAG_UNEVALUATED);
+ break;
+
+ case PARAM_CLASS_SOFT_QUOTE:
+ #if !defined(NDEBUG)
+ //
+ // Only in debug builds, the before-switch lookahead sets
+ // this flag to help indicate that's where it came from.
+ //
+ assert(GET_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED));
+ #endif
+
+ if (IS_QUOTABLY_SOFT(f->out)) {
+ if (Eval_Value_Throws(f->arg, f->out)) {
+ Move_Value(f->out, f->arg);
+ Abort_Function_Args_For_Frame(f);
+ goto finished;
+ }
+ }
+ else {
+ Move_Value(f->arg, f->out);
+ SET_VAL_FLAG(f->arg, VALUE_FLAG_UNEVALUATED);
+ }
+ break;
+
+ default:
+ assert(FALSE);
+ }
+
+ SET_END(f->out);
+ goto check_arg;
+ }
+
+ //=//// VARIADIC ARG (doesn't consume anything *yet*) /////////////////=//
+
+ // Evaluation argument "hook" parameters (marked in MAKE FUNCTION!
+ // by a `[[]]` in the spec, and in FUNC by `<...>`). They point
+ // back to this call through a reified FRAME!, and are able to
+ // consume additional arguments during the function run.
+ //
+ if (GET_VAL_FLAG(f->param, TYPESET_FLAG_VARIADIC)) {
+ const REBOOL make = TRUE;
+ Link_Vararg_Param_To_Frame(f, make);
+ goto continue_arg_loop; // new value, type guaranteed correct
+ }
+
+ //=//// AFTER THIS, PARAMS CONSUME FROM CALLSITE IF NOT APPLY ////////=//
+
+ assert(
+ f->refine == ORDINARY_ARG
+ || (IS_LOGIC(f->refine) && IS_CONDITIONAL_TRUE(f->refine))
+ );
+
+ //=//// ERROR ON END MARKER, BAR! IF APPLICABLE //////////////////////=//
+
+ if (IS_END(f->value)) {
+ if (NOT_VAL_FLAG(f->param, TYPESET_FLAG_ENDABLE))
+ fail (Error_No_Arg(FRM_LABEL(f), f->param));
+
+ Init_Void(f->arg);
+ goto continue_arg_loop;
+ }
+
+ //=//// IF EVAL/ONLY SEMANTICS, TAKE NEXT ARG WITHOUT EVALUATION //////=//
+
+ if (NOT(args_evaluate)) {
+ Quote_Next_In_Frame(f->arg, f); // has VALUE_FLAG_UNEVALUATED
+ goto check_arg;
+ }
+
+ //=//// IF EVAL SEMANTICS, DISALLOW LITERAL EXPRESSION BARRIERS ///////=//
+
+ if (IS_BAR(f->value) && pclass != PARAM_CLASS_HARD_QUOTE) {
+ //
+ // Only legal if arg is *hard quoted*. Else, it must come via
+ // other means (e.g. literal as `'|` or `first [|]`)
+
+ if (NOT_VAL_FLAG(f->param, TYPESET_FLAG_ENDABLE))
+ fail (Error_Expression_Barrier_Raw());
+
+ Init_Void(f->arg);
+ goto continue_arg_loop;
+ }
+
+ switch (pclass) {
+
+ //=//// REGULAR ARG-OR-REFINEMENT-ARG (consumes a DO/NEXT's worth) ////=//
+
+ case PARAM_CLASS_NORMAL:
+ if (Do_Next_In_Subframe_Throws(
+ f->arg,
+ f,
+ DO_FLAG_FULFILLING_ARG
+ )){
+ Move_Value(f->out, f->arg);
+ Abort_Function_Args_For_Frame(f);
+ goto finished;
+ }
+ break;
+
+ case PARAM_CLASS_TIGHT:
+ //
+ // The default for evaluated parameters is to do normal
+ // infix lookahead, e.g. `square 1 + 2` would pass 3
+ // to a single-arity function "square". But if the
+ // argument to square is declared #tight, it will act as
+ // `(square 1) + 2`, by not applying lookahead to
+ // see the + during the argument evaluation.
+ //
+ if (Do_Next_In_Subframe_Throws(
+ f->arg,
+ f,
+ DO_FLAG_NO_LOOKAHEAD | DO_FLAG_FULFILLING_ARG
+ )){
+ Move_Value(f->out, f->arg);
+ Abort_Function_Args_For_Frame(f);
+ goto finished;
+ }
+ break;
+
+ //=//// HARD QUOTED ARG-OR-REFINEMENT-ARG /////////////////////////////=//
+
+ case PARAM_CLASS_HARD_QUOTE: {
+ Quote_Next_In_Frame(f->arg, f); // has VALUE_FLAG_UNEVALUATED
+ break; }
+
+ //=//// SOFT QUOTED ARG-OR-REFINEMENT-ARG ////////////////////////////=//
+
+ case PARAM_CLASS_SOFT_QUOTE:
+ if (!IS_QUOTABLY_SOFT(f->value)) {
+ Quote_Next_In_Frame(f->arg, f); // VALUE_FLAG_UNEVALUATED
+ goto check_arg;
+ }
+
+ if (Eval_Value_Core_Throws(f->arg, f->value, f->specifier)) {
+ Move_Value(f->out, f->arg);
+ Abort_Function_Args_For_Frame(f);
+ goto finished;
+ }
+
+ Fetch_Next_In_Frame(f);
+ break;
+
+ default:
+ assert(FALSE);
+ }
+
+ //=//// TYPE CHECKING FOR (MOST) ARGS AT END OF ARG LOOP //////////////=//
+
+ check_arg:;
+
+ // Some arguments can be fulfilled and skip type checking or
+ // take care of it themselves. But normal args pass through
+ // this code which checks the typeset and also handles it when
+ // a void arg signals the revocation of a refinement usage.
+
+ ASSERT_VALUE_MANAGED(f->arg);
+ assert(pclass != PARAM_CLASS_REFINEMENT);
+ assert(pclass != PARAM_CLASS_LOCAL);
+
+ // f->refine may point to the applicable refinement slot for the
+ // current arg being fulfilled, or it might just be a signal of
+ // information about the mode (see `Reb_Frame.refine` in %sys-do.h)
+ //
+ assert(
+ f->refine == ORDINARY_ARG ||
+ f->refine == LOOKBACK_ARG ||
+ f->refine == ARG_TO_UNUSED_REFINEMENT ||
+ f->refine == ARG_TO_REVOKED_REFINEMENT ||
+ (IS_LOGIC(f->refine) && IS_CONDITIONAL_TRUE(f->refine)) // used
+ );
+
+ if (IS_VOID(f->arg)) {
+ if (IS_LOGIC(f->refine)) {
+ //
+ // We can only revoke the refinement if this is the 1st
+ // refinement arg. If it's a later arg, then the first
+ // didn't trigger revocation, or refine wouldn't be logic.
+ //
+ if (f->refine + 1 != f->arg)
+ fail (Error_Bad_Refine_Revoke(f));
+
+ Init_Logic(f->refine, FALSE); // can't re-enable...
+ f->refine = ARG_TO_REVOKED_REFINEMENT;
+ goto continue_arg_loop; // don't type check for optionality
+ }
+ else if (IS_CONDITIONAL_FALSE(f->refine)) {
+ //
+ // FALSE means the refinement has already been revoked so
+ // the void is okay. BLANK! means the refinement was
+ // never in use in the first place. Don't type check.
+ //
+ goto continue_arg_loop;
+ }
+ else {
+ // fall through to check arg for if is ok
+ //
+ assert(
+ f->refine == ORDINARY_ARG
+ || f->refine == LOOKBACK_ARG
+ );
+ }
+ }
+ else {
+ // If the argument is set, then the refinement shouldn't be
+ // in a revoked or unused state.
+ //
+ if (IS_CONDITIONAL_FALSE(f->refine))
+ fail (Error_Bad_Refine_Revoke(f));
+ }
+
+ if (NOT_VAL_FLAG(f->param, TYPESET_FLAG_VARIADIC)) {
+ if (NOT(TYPE_CHECK(f->param, VAL_TYPE(f->arg))))
+ fail (Error_Arg_Type(
+ FRM_LABEL(f), f->param, VAL_TYPE(f->arg))
+ );
+ }
+ else {
+ // Varargs are odd, because the type checking doesn't
+ // actually check the type of the parameter--it's always
+ // a VARARGS!. Also since the "types accepted" are a lie
+ // (an [integer! <...>] takes VARARGS!, not INTEGER!) then
+ // an "honest" parameter has to be made to give the error.
+ //
+ if (!IS_VARARGS(f->arg)) {
+ DECLARE_LOCAL (honest_param);
+ Init_Typeset(
+ honest_param,
+ FLAGIT_KIND(REB_VARARGS), // actually expected
+ VAL_PARAM_SPELLING(f->param)
+ );
+
+ fail (Error_Arg_Type(
+ FRM_LABEL(f), honest_param, VAL_TYPE(f->arg))
+ );
+ }
+
+ // While "checking" the variadic argument we actually re-stamp
+ // it with this parameter and frame's signature. It reuses
+ // whatever the original data feed was (this frame, another
+ // frame, or just an array from MAKE VARARGS!)
+ //
+ const REBOOL make = FALSE; // reuse feed in f->arg
+ Link_Vararg_Param_To_Frame(f, make);
+ }
+
+ continue_arg_loop: // `continue` might bind to the wrong scope
+ ++f->param;
+ ++f->arg;
+ // f->special is incremented while already testing it for END
+ }
+
+ // If there was a specialization of the arguments, it should have
+ // been marched to an end cell...or just be the unwritable canon END
+ // node to start with
+ //
+ assert(IS_END(f->special));
+
+ // While having the rule that arg terminates isn't strictly necessary,
+ // it is a useful tool...and implicit termination makes it as cheap
+ // as not doing it.
+ //
+ assert(IS_END(f->arg));
+
+ // There may have been refinements that were skipped because the
+ // order of definition did not match the order of usage. They were
+ // left on the stack with a pointer to the `param` and `arg` after
+ // them for later fulfillment.
+ //
+ // Note that there may be functions on the stack if this is the
+ // second time through, and we were just jumping up to check the
+ // parameters in response to a R_REDO_CHECKED; if so, skip this.
+ //
+ if (DSP != f->dsp_orig) {
+ if (IS_WORD(DS_TOP)) {
+ //
+ // The walk through the arguments didn't fill in any
+ // information for this word, so it was either a duplicate of
+ // one that was fulfilled or not a refinement the function
+ // has at all.
+ //
+ assert(IS_WORD(DS_TOP));
+ fail (Error_Bad_Refine_Raw(DS_TOP));
+ }
+
+ if (VAL_TYPE(DS_TOP) == REB_0_PICKUP) {
+ assert(f->special == END); // no specialization "pickups"
+ f->param = DS_TOP->payload.pickup.param;
+ f->refine = f->arg = DS_TOP->payload.pickup.arg;
+ assert(IS_LOGIC(f->refine) && VAL_LOGIC(f->refine));
+ DS_DROP;
+ f->doing_pickups = TRUE;
+ goto continue_arg_loop; // leaves refine, but bumps param+arg
+ }
+
+ // chains push functions, and R_REDO_CHECKED
+ assert(IS_FUNCTION(DS_TOP));
+ }
+
+ #if !defined(NDEBUG)
+ if (GET_VAL_FLAG(FUNC_VALUE(f->phase), FUNC_FLAG_LEGACY_DEBUG))
+ Legacy_Convert_Function_Args(f); // BLANK!+NONE! vs. FALSE+UNSET!
+ #endif
+
+ //==////////////////////////////////////////////////////////////////==//
+ //
+ // FUNCTION! ARGUMENTS NOW GATHERED, DISPATCH CALL
+ //
+ //==////////////////////////////////////////////////////////////////==//
+
+ redo_unchecked:
+ assert(IS_END(f->param));
+ // refine can be anything.
+ assert(
+ IS_END(f->value)
+ || (f->flags.bits & DO_FLAG_VA_LIST)
+ || IS_VALUE_IN_ARRAY_DEBUG(f->source.array, f->value)
+ );
+
+ if (Trace_Flags)
+ Trace_Func(FRM_LABEL(f));
+
+ // The out slot needs initialization for GC safety during the function
+ // run. Choosing an END marker should be legal because places that
+ // you can use as output targets can't be visible to the GC (that
+ // includes argument arrays being fulfilled). This offers extra
+ // perks, because it means a recycle/torture will catch you if you
+ // try to Do_Core into movable memory...*and* a native can tell if it
+ // has written the out slot yet or not (e.g. WHILE/? refinement).
+ //
+ assert(IS_END(f->out));
+
+ // Running arbitrary native code can manipulate the bindings or cache
+ // of a variable. It's very conservative to say this, but any word
+ // fetches that were done for lookahead are potentially invalidated
+ // by every function call.
+ //
+ f->gotten = END;
+
+ // Cases should be in enum order for jump-table optimization
+ // (R_FALSE first, R_TRUE second, etc.)
+ //
+ // The dispatcher may push functions to the data stack which will be
+ // used to process the return result after the switch.
+ //
+ REBNAT dispatcher; // goto would cross initialization
+ dispatcher = FUNC_DISPATCHER(f->phase);
+ switch (dispatcher(f)) {
+ case R_FALSE:
+ Init_Logic(f->out, FALSE); // no VALUE_FLAG_UNEVALUATED
+ break;
+
+ case R_TRUE:
+ Init_Logic(f->out, TRUE); // no VALUE_FLAG_UNEVALUATED
+ break;
+
+ case R_VOID:
+ Init_Void(f->out); // no VALUE_FLAG_UNEVALUATED
+ break;
+
+ case R_BLANK:
+ Init_Blank(f->out); // no VALUE_FLAG_UNEVALUATED
+ break;
+
+ case R_BAR:
+ Init_Bar(f->out); // no VALUE_FLAG_UNEVALUATED
+ break;
+
+ case R_OUT:
+ CLEAR_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ break; // checked as NOT_END() after switch()
+
+ case R_OUT_UNEVALUATED: // returned by QUOTE and SEMIQUOTE
+ SET_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ break;
+
+ case R_OUT_IS_THROWN: {
+ assert(THROWN(f->out));
+
+ if (!IS_FUNCTION(f->out) || VAL_FUNC(f->out) != NAT_FUNC(exit)) {
+ //
+ // Do_Core only catches "definitional exits" to current frame
+ //
+ Abort_Function_Args_For_Frame(f);
+ goto finished;
+ }
+
+ ASSERT_ARRAY(VAL_BINDING(f->out));
+
+ if (VAL_BINDING(f->out) == FUNC_PARAMLIST(FRM_UNDERLYING(f))) {
+ //
+ // The most recent instance of a function on the stack (if
+ // any) will catch a FUNCTION! style exit.
+ //
+ CATCH_THROWN(f->out, f->out);
+ assert(NOT_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED));
+ }
+ else if (VAL_BINDING(f->out) == f->varlist) {
+ //
+ // This identifies an exit from a *specific* function
+ // invocation. We'll only match it if we have a reified
+ // frame context. (Note f->varlist may be null here.)
+ //
+ CATCH_THROWN(f->out, f->out);
+ }
+ else {
+ Abort_Function_Args_For_Frame(f);
+ goto finished; // stay THROWN and try to exit frames above...
+ }
+ CLEAR_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ break; }
+
+ case R_OUT_TRUE_IF_WRITTEN:
+ if (IS_END(f->out))
+ Init_Logic(f->out, FALSE); // no VALUE_FLAG_UNEVALUATED
+ else
+ Init_Logic(f->out, TRUE); // no VALUE_FLAG_UNEVALUATED
+ break;
+
+ case R_OUT_VOID_IF_UNWRITTEN:
+ if (IS_END(f->out))
+ Init_Void(f->out); // no VALUE_FLAG_UNEVALUATED
+ else
+ CLEAR_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ break;
+
+ case R_OUT_VOID_IF_UNWRITTEN_TRUTHIFY:
+ if (IS_END(f->out))
+ Init_Void(f->out);
+ else if (IS_VOID(f->out) || IS_CONDITIONAL_FALSE(f->out))
+ Init_Bar(f->out);
+ else
+ CLEAR_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ break;
+
+ case R_OUT_BLANK_IF_VOID:
+ if (IS_VOID(f->out))
+ Init_Blank(f->out);
+ else
+ CLEAR_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ break;
+
+ case R_OUT_VOID_IF_UNWRITTEN_BLANK_IF_VOID:
+ if (IS_END(f->out))
+ Init_Void(f->out);
+ else if (IS_VOID(f->out))
+ Init_Blank(f->out);
+ else
+ CLEAR_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ break;
+
+ case R_REDO_CHECKED:
+ SET_END(f->out);
+ f->special = f->args_head;
+ f->refine = ORDINARY_ARG; // no gathering, but need for assert
+ goto do_function_arglist_in_progress;
+
+ case R_REDO_UNCHECKED:
+ //
+ // This instruction represents the idea that it is desired to
+ // run the f->phase again. The dispatcher may have changed the
+ // value of what f->phase is, for instance.
+ //
+ SET_END(f->out);
+ goto redo_unchecked;
+
+ case R_REEVALUATE:
+ args_evaluate = TRUE; // unnecessary?
+ Drop_Function_Args_For_Frame(f);
+ CLEAR_FRAME_LABEL(f);
+ goto reevaluate; // we don't move index!
+
+ case R_REEVALUATE_ONLY:
+ args_evaluate = FALSE;
+ Drop_Function_Args_For_Frame(f);
+ CLEAR_FRAME_LABEL(f);
+ goto reevaluate; // we don't move index!
+
+ case R_UNHANDLED: // internal use only, shouldn't be returned
+ assert(FALSE);
+
+ default:
+ assert(FALSE);
+ }
+
+ assert(NOT_END(f->out)); // should have overwritten
+ assert(NOT(THROWN(f->out))); // throws must be R_OUT_IS_THROWN
+
+ assert(f->eval_type == REB_FUNCTION); // shouldn't have changed
+
+ //==////////////////////////////////////////////////////////////////==//
+ //
+ // DEBUG CHECK RETURN OF ALL FUNCTIONS (not just user functions)
+ //
+ //==////////////////////////////////////////////////////////////////==//
+
+ // Here we know the function finished and did not throw or exit.
+ // Generally the return type is validated by the Returner_Dispatcher()
+ // with everything else assumed to return the correct type. But this
+ // double checks any function marked with RETURN in the debug build.
+
+#if !defined(NDEBUG)
+ if (GET_VAL_FLAG(FUNC_VALUE(f->phase), FUNC_FLAG_RETURN)) {
+ REBVAL *typeset = FUNC_PARAM(f->phase, FUNC_NUM_PARAMS(f->phase));
+ assert(VAL_PARAM_SYM(typeset) == SYM_RETURN);
+ if (!TYPE_CHECK(typeset, VAL_TYPE(f->out)))
+ fail (Error_Bad_Return_Type(f->label, VAL_TYPE(f->out)));
+ }
+#endif
+
+ //==////////////////////////////////////////////////////////////////==//
+ //
+ // FUNCTION! CALL COMPLETION
+ //
+ //==////////////////////////////////////////////////////////////////==//
+
+ // If we have functions pending to run on the outputs, then do so.
+ //
+ while (DSP != f->dsp_orig) {
+ assert(IS_FUNCTION(DS_TOP));
+
+ Move_Value(&f->cell, f->out);
+
+ // Data stack values cannot be used directly in an apply, because
+ // the evaluator uses DS_PUSH, which could relocate the stack
+ // and invalidate the pointer.
+ //
+ DECLARE_LOCAL (fun);
+ Move_Value(fun, DS_TOP);
+
+ if (Apply_Only_Throws(f->out, TRUE, fun, &f->cell, END)) {
+ Abort_Function_Args_For_Frame(f);
+ goto finished;
+ }
+
+ DS_DROP;
+ }
+
+ if (Trace_Flags)
+ Trace_Return(FRM_LABEL(f), f->out);
+
+ // !!! It would technically be possible to drop the arguments before
+ // running chains... and if the chained function were to run *in*
+ // this frame that could be even more optimal. However, having the
+ // original function still on the stack helps make errors clearer.
+ //
+ Drop_Function_Args_For_Frame(f);
+
+ CLEAR_FRAME_LABEL(f);
+ break;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [WORD!]
+//
+// A plain word tries to fetch its value through its binding. It will fail
+// and longjmp out of this stack if the word is unbound (or if the binding is
+// to a variable which is not set). Should the word look up to a function,
+// then that function will be called by jumping to the ANY-FUNCTION! case.
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_WORD:
+ if (current_gotten == END) {
+ current_gotten = Get_Opt_Var_May_Fail(current, f->specifier);
+ goto do_word_in_current_unchecked;
+ }
+
+ do_word_in_current:
+ assert(current_gotten == Get_Opt_Var_May_Fail(current, f->specifier));
+
+ do_word_in_current_unchecked:
+ if (IS_FUNCTION(current_gotten)) { // before IS_VOID() is common case
+ f->eval_type = REB_FUNCTION;
+ SET_FRAME_LABEL(f, VAL_WORD_SPELLING(current));
+
+ if (GET_VAL_FLAG(current_gotten, VALUE_FLAG_ENFIXED)) {
+ f->refine = LOOKBACK_ARG;
+ goto do_function_in_current_gotten;
+ }
+
+ SET_END(f->out);
+ f->refine = ORDINARY_ARG;
+ goto do_function_in_current_gotten;
+ }
+
+ if (IS_VOID(current_gotten)) // need `:x` if `x` is unset
+ fail (Error_No_Value_Core(current, f->specifier));
+
+ Move_Value(f->out, current_gotten); // no copy VALUE_FLAG_UNEVALUATED
+
+ #if !defined(NDEBUG)
+ if (LEGACY(OPTIONS_LIT_WORD_DECAY) && IS_LIT_WORD(f->out))
+ VAL_SET_TYPE_BITS(f->out, REB_WORD); // don't reset full header!
+ #endif
+ break;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [SET-WORD!]
+//
+// A chain of `x: y: z: ...` may happen, so there could be any number of
+// SET-WORD!s before the value to assign is found. Some kind of list needs to
+// be maintained.
+//
+// Recursion into Do_Core() is used, but a new frame is not created. Instead
+// it reuses `f` with a lighter-weight approach. Do_Next_Mid_Frame_Throws()
+// has remarks on how this is done.
+//
+// !!! Note that `10 = 5 + 5` would be an error due to lookahead suppression
+// from `=`, so it reads as `(10 = 5) + 5`. However `10 = x: 5 + 5` will not
+// be an error, as the SET-WORD! causes a recursion in the evaluator. This
+// is unusual, but there are advantages to seeing SET-WORD! as a kind of
+// single-arity function.
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_SET_WORD:
+ assert(IS_SET_WORD(current));
+
+ if (IS_END(f->value)) {
+ DECLARE_LOCAL (specific);
+ Derelativize(specific, current, f->specifier);
+ fail (Error_Need_Value_Raw(specific)); // `do [a:]` is illegal
+ }
+
+ if (NOT(args_evaluate)) { // e.g. `eval/only quote x: 1 + 2`, x => 1
+ Derelativize(f->out, f->value, f->specifier);
+ Move_Value(Sink_Var_May_Fail(current, f->specifier), f->out);
+ }
+ else {
+ // f->value is guarded implicitly by the frame, but `current` is a
+ // transient local pointer that might be to a va_list REBVAL* that
+ // has already been fetched. The bits will stay live until
+ // va_end(), but a GC wouldn't see it.
+ //
+ DS_PUSH_RELVAL(current, f->specifier);
+
+ if (Do_Next_Mid_Frame_Throws(f)) { // lightweight reuse of `f`
+ DS_DROP;
+ goto finished;
+ }
+
+ Move_Value(Sink_Var_May_Fail(DS_TOP, SPECIFIED), f->out);
+
+ DS_DROP;
+ }
+ break;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [GET-WORD!]
+//
+// A GET-WORD! does no checking for unsets, no dispatch on functions, and
+// will return void if the variable is not set.
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_GET_WORD:
+ //
+ // Note: copying values does not copy VALUE_FLAG_UNEVALUATED
+ //
+ Copy_Opt_Var_May_Fail(f->out, current, f->specifier);
+ break;
+
+//==/////////////////////////////////////////////////////////////////////==//
+//
+// [LIT-WORD!]
+//
+// Note we only want to reset the type bits in the header, not the whole
+// header--because header bits contain information like WORD_FLAG_BOUND.
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_LIT_WORD:
+ //
+ // Derelativize will clear VALUE_FLAG_UNEVALUATED
+ //
+ Derelativize(f->out, current, f->specifier);
+ VAL_SET_TYPE_BITS(f->out, REB_WORD);
+ break;
+
+//==//// INERT WORD AND STRING TYPES /////////////////////////////////////==//
+
+ case REB_REFINEMENT:
+ case REB_ISSUE:
+ // ^-- ANY-WORD!
+ goto inert;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [GROUP!]
+//
+// If a GROUP! is seen then it generates another call into Do_Core(). The
+// resulting value for this step will be the outcome of that evaluation.
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_GROUP: {
+ //
+ // If the source array we are processing that is yielding values is
+ // part of the deep copy of a function body, it's possible that this
+ // GROUP! is a "relative ANY-ARRAY!" that needs the specifier to
+ // resolve the relative any-words and other any-arrays inside it...
+ //
+ REBSPC *derived = Derive_Specifier(f->specifier, current);
+ if (Do_At_Throws(
+ f->out,
+ VAL_ARRAY(current), // the GROUP!'s array
+ VAL_INDEX(current), // index in group's REBVAL (may not be head)
+ derived
+ )){
+ goto finished;
+ }
+
+ CLEAR_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ break; }
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [PATH!]
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_PATH: {
+ REBSTR *label;
+ if (Do_Path_Throws_Core(
+ f->out,
+ &label, // requesting label says we run functions (not GET-PATH!)
+ current,
+ f->specifier,
+ NULL // `setval`: null means don't treat as SET-PATH!
+ )){
+ goto finished;
+ }
+
+ if (IS_VOID(f->out)) // need `:x/y` if `y` is unset
+ fail (Error_No_Value_Core(current, f->specifier));
+
+ if (IS_FUNCTION(f->out)) {
+ f->eval_type = REB_FUNCTION;
+ if (label == NULL)
+ SET_FRAME_LABEL(f, Canon(SYM___ANONYMOUS__));
+ else
+ SET_FRAME_LABEL(f, label);
+
+ // object/func or func/refinements or object/func/refinement
+ //
+ // Because we passed in a label symbol, the path evaluator was
+ // willing to assume we are going to invoke a function if it
+ // is one. Hence it left any potential refinements on data stack.
+ //
+ assert(DSP >= f->dsp_orig);
+
+ Move_Value(&f->cell, f->out);
+ current_gotten = &f->cell;
+ SET_END(f->out);
+ f->refine = ORDINARY_ARG; // paths are never enfixed (for now)
+ goto do_function_in_current_gotten;
+ }
+
+ CLEAR_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ break;
+ }
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [SET-PATH!]
+//
+// See notes on SET-WORD! SET-PATH!s are handled in a similar way, by
+// pushing them to the stack, continuing the evaluation via a lightweight
+// reuse of the current frame.
+//
+// !!! The evaluation ordering is dictated by the fact that there isn't a
+// separate "evaluate path to target location" and "set target' step. This
+// is because some targets of assignments (e.g. gob/size/x:) do not correspond
+// to a cell that can be returned; the path operation "encodes as it goes"
+// and requires the value to set as a parameter to Do_Path. Yet it is
+// counterintuitive given the "left-to-right" nature of the language:
+//
+// >> foo: make object! [[bar][bar: 10]]
+//
+// >> foo/(print "left" 'bar): (print "right" 20)
+// right
+// left
+// == 20
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_SET_PATH: {
+ assert(IS_SET_PATH(current));
+
+ if (IS_END(f->value)) {
+ DECLARE_LOCAL (specific);
+ Derelativize(specific, current, f->specifier);
+ fail (Error_Need_Value_Raw(specific)); // `do [a/b:]` is illegal
+ }
+
+ if (NOT(args_evaluate)) {
+ Derelativize(f->out, f->value, f->specifier);
+
+ // !!! Due to the way this is currently designed, throws need to
+ // be written to a location distinct from the path and also
+ // distinct from the value being set. Review.
+ //
+ DECLARE_LOCAL (temp);
+
+ if (Do_Path_Throws_Core(
+ temp, // output location if thrown
+ NULL, // not requesting symbol means refinements not allowed
+ current, // still holding SET-PATH! we got in
+ f->specifier, // specifier for current
+ f->out // value to set (already in f->out)
+ )) {
+ fail (Error_No_Catch_For_Throw(temp));
+ }
+ }
+ else {
+ // f->value is guarded implicitly by the frame, but `current` is a
+ // transient local pointer that might be to a va_list REBVAL* that
+ // has already been fetched. The bits will stay live until
+ // va_end(), but a GC wouldn't see it.
+ //
+ DS_PUSH_RELVAL(current, f->specifier);
+
+ if (Do_Next_Mid_Frame_Throws(f)) { // lighweight reuse of `f`
+ DS_DROP;
+ goto finished;
+ }
+
+ // The path cannot be executed directly from the data stack, so
+ // it has to be popped. This could be changed by making the core
+ // Do_Path_Throws take a VAL_ARRAY, index, and kind. By moving
+ // it into the f->cell, it is guaranteed garbage collected.
+ //
+ Move_Value(&f->cell, DS_TOP);
+ DS_DROP;
+
+ // !!! Due to the way this is currently designed, throws need to
+ // be written to a location distinct from the path and also
+ // distinct from the value being set. Review.
+ //
+ DECLARE_LOCAL (temp);
+
+ if (Do_Path_Throws_Core(
+ temp, // output location if thrown
+ NULL, // not requesting symbol means refinements not allowed
+ &f->cell, // still holding SET-PATH! we got in
+ SPECIFIED, // current derelativized when pushed to DS_TOP
+ f->out // value to set (already in f->out)
+ )) {
+ fail (Error_No_Catch_For_Throw(temp));
+ }
+ }
+
+ break; }
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [GET-PATH!]
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_GET_PATH:
+ //
+ // !!! Should a GET-PATH! be able to call into the evaluator, by
+ // evaluating GROUP!s in the path? It's clear that `get path`
+ // shouldn't be able to evaluate (a GET should not have side effects).
+ // But perhaps source-level GET-PATH!s can be more liberal, as one can
+ // visibly see the GROUP!s.
+ //
+ if (Do_Path_Throws_Core(
+ f->out,
+ NULL, // not requesting symbol means refinements not allowed
+ current,
+ f->specifier,
+ NULL // `setval`: null means don't treat as SET-PATH!
+ )){
+ goto finished;
+ }
+
+ CLEAR_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ break;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [LIT-PATH!]
+//
+// We only set the type, in order to preserve the header bits... (there
+// currently aren't any for ANY-PATH!, but there might be someday.)
+//
+// !!! Aliases a REBSER under two value types, likely bad, see #2233
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_LIT_PATH:
+ //
+ // Derelativize will leave VALUE_FLAG_UNEVALUATED clear
+ //
+ Derelativize(f->out, current, f->specifier);
+ VAL_SET_TYPE_BITS(f->out, REB_PATH);
+ break;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// Treat all the other Is_Bindable() types as inert
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_BLOCK:
+ //
+ case REB_BINARY:
+ case REB_STRING:
+ case REB_FILE:
+ case REB_EMAIL:
+ case REB_URL:
+ case REB_TAG:
+ //
+ case REB_BITSET:
+ case REB_IMAGE:
+ case REB_VECTOR:
+ //
+ case REB_MAP:
+ //
+ case REB_VARARGS:
+ //
+ case REB_OBJECT:
+ case REB_FRAME:
+ case REB_MODULE:
+ case REB_ERROR:
+ case REB_PORT:
+ goto inert;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [BAR!]
+//
+// If an expression barrier is seen in-between expressions (as it will always
+// be if hit in this switch), it evaluates to void. It only errors in
+// argument fulfillment during the switch case for ANY-FUNCTION!.
+//
+// Note that `DO/NEXT [| | | | 1 + 2]` will skip the bars and yield 3. This
+// helps give BAR!s their lightweight character. It also means that code
+// doing DO/NEXTs will not see them as generating voids, which might have
+// a specific meaning to the caller. (They can check for BAR!s explicitly
+// if they want to give BAR!s a meaning.)
+//
+// Note also that natives and dialects frequently do their own interpretation
+// of BAR!--rather than just evaluate it and let it mean something equivalent
+// to an unset. For instance:
+//
+// case [false [print "F"] | true [print ["T"]]
+//
+// If CASE did not specially recognize BAR!, it would complain that the
+// "second condition" had no value. So if you are looking for a BAR! behavior
+// and it's not passing through here, check the construct you are using.
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_BAR:
+ assert(IS_BAR(current));
+
+ if (NOT_END(f->value)) {
+ SET_END(f->out); // skipping the post loop where this is done
+ f->eval_type = VAL_TYPE(f->value);
+ goto do_next; // quickly process next item, no infix test needed
+ }
+
+ Init_Void(f->out); // no VALUE_FLAG_UNEVALUATED
+ break;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [LIT-BAR!]
+//
+// LIT-BAR! decays into an ordinary BAR! if seen here by the evaluator.
+//
+// !!! Considerations of the "lit-bit" proposal would add a literal form
+// for every type, which would make this datatype unnecssary.
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_LIT_BAR:
+ assert(IS_LIT_BAR(current));
+
+ Init_Bar(f->out); // no VALUE_FLAG_UNEVALUATED
+ break;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// Treat all the other NOT(Is_Bindable()) types as inert
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_BLANK:
+ //
+ case REB_LOGIC:
+ case REB_INTEGER:
+ case REB_DECIMAL:
+ case REB_PERCENT:
+ case REB_MONEY:
+ case REB_CHAR:
+ case REB_PAIR:
+ case REB_TUPLE:
+ case REB_TIME:
+ case REB_DATE:
+ //
+ case REB_DATATYPE:
+ case REB_TYPESET:
+ //
+ case REB_GOB:
+ case REB_EVENT:
+ case REB_HANDLE:
+ case REB_STRUCT:
+ case REB_LIBRARY:
+ //
+ inert:
+ Derelativize(f->out, current, f->specifier);
+ SET_VAL_FLAG(f->out, VALUE_FLAG_UNEVALUATED);
+ break;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// [void]
+//
+// Void is not an ANY-VALUE!, and void cells are not allowed in ANY-ARRAY!
+// exposed to the user. So usually, a DO shouldn't be able to see them,
+// unless they are un-evaluated...e.g. `Apply_Only_Throws()` passes in a
+// VOID_CELL as an evaluation-already-accounted-for parameter to a function.
+//
+// The exception case is something like `eval ()`, which is the user
+// deliberately trying to invoke the evaluator on a void. (Not to be confused
+// with `eval quote ()`, which is the evaluation of an empty GROUP!, which
+// produces void, and that's fine). We choose to deliver an error in the void
+// case, which provides a consistency:
+//
+// :foo/bar => pick* foo 'bar (void if not present)
+// foo/bar => eval :foo/bar (should be an error if not present)
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ case REB_MAX_VOID:
+ if (NOT(args_evaluate)) {
+ Init_Void(f->out);
+ }
+ else {
+ // must be EVAL, so the value must be living in the frame cell
+ //
+ assert(current == &f->cell);
+ fail (Error_Evaluate_Void_Raw());
+ }
+ break;
+
+//==//////////////////////////////////////////////////////////////////////==//
+//
+// If garbage, panic on the value to generate more debug information about
+// its origins (what series it lives in, where the cell was assigned...)
+//
+//==//////////////////////////////////////////////////////////////////////==//
+
+ default:
+ panic (current);
+ }
+
+ //==////////////////////////////////////////////////////////////////==//
+ //
+ // END MAIN SWITCH STATEMENT
+ //
+ //==////////////////////////////////////////////////////////////////==//
+
+ assert(!THROWN(f->out)); // should have jumped to exit sooner
+
+ if (IS_END(f->value))
+ goto finished;
+
+ f->eval_type = VAL_TYPE(f->value);
+
+ if (f->flags.bits & DO_FLAG_NO_LOOKAHEAD) {
+ //
+ // Don't do infix lookahead if asked *not* to look. See the
+ // PARAM_CLASS_TIGHT parameter convention for the use of this
+ //
+ assert(NOT(f->flags.bits & DO_FLAG_TO_END));
+ }
+ else if (f->eval_type == REB_WORD) {
+
+ if (f->gotten == END)
+ f->gotten = Get_Opt_Var_Else_End(f->value, f->specifier);
+ else
+ assert(
+ f->gotten == Get_Opt_Var_Else_End(f->value, f->specifier)
+ );
+
+ //=//// DO/NEXT WON'T RUN MORE CODE UNLESS IT'S AN INFIX FUNCTION /////=//
+
+ if (
+ NOT(f->flags.bits & DO_FLAG_TO_END)
+ && (
+ f->gotten == END // could fold the END check in with masking
+ || NOT_VAL_FLAG(f->gotten, VALUE_FLAG_ENFIXED)
+ )
+ ){
+ goto finished;
+ }
+
+ //=//// IT'S INFIX OR WE'RE DOING TO THE END...DISPATCH LIKE WORD /////=//
+
+ START_NEW_EXPRESSION_MAY_THROW(f, goto finished);
+ // ^-- sets args_evaluate, do_count, Ctrl-C may abort
+
+ if (VAL_TYPE_OR_0(f->gotten) != REB_FUNCTION) { // END is REB_0
+ current = f->value;
+ current_gotten = f->gotten; // if END, the word will error
+ f->gotten = END;
+ Fetch_Next_In_Frame(f);
+ goto do_word_in_current;
+ }
+
+ f->eval_type = REB_FUNCTION;
+
+ if (GET_VAL_FLAG(f->gotten, VALUE_FLAG_ENFIXED)) {
+ if (
+ GET_VAL_FLAG(f->gotten, FUNC_FLAG_DEFERS_LOOKBACK)
+ && (f->flags.bits & DO_FLAG_FULFILLING_ARG)
+ ){
+ // This is the special case; we have a lookback function
+ // pending but it wants to defer its first argument as
+ // long as possible--and we're on the last parameter of
+ // some function. Skip the "lookahead" and let whoever
+ // is gathering arguments (or whoever's above them) finish
+ // the expression before taking the pending operation.
+ //
+ assert(NOT(f->flags.bits & DO_FLAG_TO_END));
+ }
+ else if (GET_VAL_FLAG(f->gotten, FUNC_FLAG_QUOTES_FIRST_ARG)) {
+ //
+ // Left-quoting by enfix needs to be done in the lookahead
+ // before an evaluation, not this one that's after. This
+ // error happens in cases like:
+ //
+ // left-quote: enfix func [:value] [:value]
+ // quote left-quote
+ //
+ // !!! Is this the ideal place to be delivering the error?
+ //
+ fail (Error_Lookback_Quote_Too_Late(f->value, f->specifier));
+ }
+ else {
+ // This is a case for an evaluative lookback argument we
+ // don't want to defer, e.g. a #tight argument or a normal
+ // one which is not being requested in the context of
+ // parameter fulfillment. We want to reuse the f->out
+ //
+ SET_FRAME_LABEL(f, VAL_WORD_SPELLING(f->value));
+ f->refine = LOOKBACK_ARG;
+ current = f->value;
+ current_gotten = f->gotten;
+ f->gotten = END;
+ Fetch_Next_In_Frame(f);
+ goto do_function_in_current_gotten;
+ }
+ }
+ else {
+ SET_END(f->out);
+ SET_FRAME_LABEL(f, VAL_WORD_SPELLING(f->value));
+ f->refine = ORDINARY_ARG;
+ current = f->value;
+ current_gotten = f->gotten;
+ f->gotten = END;
+ Fetch_Next_In_Frame(f);
+ goto do_function_in_current_gotten;
+ }
+ }
+
+ // Continue evaluating rest of block if not just a DO/NEXT
+ //
+ if (f->flags.bits & DO_FLAG_TO_END)
+ goto do_next;
+
+finished:;
+
+#if !defined(NDEBUG)
+ Do_Core_Exit_Checks_Debug(f); // will get called unless a fail() longjmps
+#endif
+
+ // All callers must inspect for THROWN(f->out), and most should also
+ // inspect for IS_END(f->value)
+}
diff --git a/src/core/c-frame.c b/src/core/c-frame.c
deleted file mode 100644
index fd571d3fe6..0000000000
--- a/src/core/c-frame.c
+++ /dev/null
@@ -1,1415 +0,0 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: c-frame.c
-** Summary: frame management
-** Section: core
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-/*
- This structure is used for:
-
- 1. Modules
- 2. Objects
- 3. Function frame (arguments)
- 4. Closures
-
- A frame is a block that begins with a special FRAME! value
- (a datatype that links to the frame word list). That value
- (SELF) is followed by the values of the words for the frame.
-
- FRAME BLOCK: WORD LIST:
- +----------------------------+ +----------------------------+
- | Frame Datatype Value |--Series->| SELF word |
- +----------------------------+ +----------------------------+
- | Value 1 | | Word 1 |
- +----------------------------+ +----------------------------+
- | Value 2 | | Word 2 |
- +----------------------------+ +----------------------------+
- | Value ... | | Word ... |
- +----------------------------+ +----------------------------+
-
- The word list holds word datatype values of the structure:
-
- Type: word, 'word, :word, word:, /word
- Symbol: actual symbol
- Canon: canonical symbol
- Typeset: index of the value's typeset, or zero
-
- This list is used for binding, evaluation, type checking, and
- can also be used for molding.
-
- When a frame is cloned, only the value block itself need be
- created. The word list remains the same. For functions, the
- value block can be pushed on the stack.
-
- Frame creation patterns:
-
- 1. Function specification to frame. Spec is scanned for
- words and datatypes, from which the word list is created.
- Closures are identical.
-
- 2. Object specification to frame. Spec is scanned for
- word definitions and merged with parent defintions. An
- option is to allow the words to be typed.
-
- 3. Module words to frame. They are not normally known in
- advance, they are collected during the global binding of a
- newly loaded block. This requires either preallocation of
- the module frame, or some kind of special scan to track
- the new words.
-
- 4. Special frames, such as system natives and actions
- may be created by specific block scans and appending to
- a given frame.
-*/
-
-#include "sys-core.h"
-
-#define CHECK_BIND_TABLE
-
-/***********************************************************************
-**
-*/ void Check_Bind_Table()
-/*
-***********************************************************************/
-{
- REBCNT n;
- REBINT *binds = WORDS_HEAD(Bind_Table);
-
- //Debug_Fmt("Bind Table (Size: %d)", SERIES_TAIL(Bind_Table));
- for (n = 0; n < SERIES_TAIL(Bind_Table); n++) {
- if (binds[n]) {
- Debug_Fmt("Bind table fault: %3d to %3d (%s)", n, binds[n], Get_Sym_Name(n));
- }
- }
-}
-
-/***********************************************************************
-**
-*/ REBSER *Make_Frame(REBINT len)
-/*
-** Create a frame of a given size, allocating space for both
-** words and values. Normally used for global frames.
-**
-** selfless means do not set SELF word
-**
-***********************************************************************/
-{
- REBSER *frame;
- REBSER *words;
- REBVAL *value;
-
- //DISABLE_GC;
- words = Make_Block(len + 1); // size + room for SELF
- BARE_SERIES(words);
- frame = Make_Block(len + 1);
- //ENABLE_GC;
- // Note: cannot use Append_Frame for first word.
- value = Append_Value(frame);
- SET_FRAME(value, 0, words);
- value = Append_Value(words);
- Init_Frame_Word(value, SYM_SELF); // may get unset by selfless frames
-
- return frame;
-}
-
-
-/***********************************************************************
-**
-*/ void Expand_Frame(REBSER *frame, REBCNT delta, REBCNT copy)
-/*
-** Expand a frame. Copy words if flagged.
-**
-***********************************************************************/
-{
- REBSER *words = FRM_WORD_SERIES(frame);
-
- Extend_Series(frame, delta);
- BLK_TERM(frame);
-
- // Expand or copy WORDS block:
- if (copy) {
- FRM_WORD_SERIES(frame) = Copy_Expand_Block(words, delta);
- BARE_SERIES(FRM_WORD_SERIES(frame));
- } else {
- Extend_Series(words, delta);
- BLK_TERM(words);
- }
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Append_Frame(REBSER *frame, REBVAL *word, REBCNT sym)
-/*
-** Append a word to the frame word list. Expands the list
-** if necessary. Returns the value cell for the word. (Set to
-** UNSET by default to avoid GC corruption.)
-**
-** If word is not NULL, use the word sym and bind the word value,
-** otherwise use sym.
-**
-** WARNING: Invalidates pointers to values within the frame
-** because the frame block may get expanded. (Use indexes.)
-**
-***********************************************************************/
-{
- REBSER *words = FRM_WORD_SERIES(frame);
- REBVAL *value;
-
- // Add to word list:
- EXPAND_SERIES_TAIL(words, 1);
- value = BLK_LAST(words);
- if (word) Init_Frame_Word(value, VAL_WORD_SYM(word));
- else Init_Frame_Word(value, sym);
- BLK_TERM(words);
-
- // Bind the word to this frame:
- if (word) {
- VAL_WORD_FRAME(word) = frame;
- VAL_WORD_INDEX(word) = frame->tail;
- }
-
- // Add unset value to frame:
- EXPAND_SERIES_TAIL(frame, 1);
- word = BLK_LAST(frame);
- SET_UNSET(word);
- BLK_TERM(frame);
-
- return word; // The value cell for word.
-}
-
-
-/***********************************************************************
-**
-*/ void Collect_Start(REBCNT modes)
-/*
-** Use the Bind_Table to start collecting new words for
-** a frame. Use Collect_End() when done.
-**
-** WARNING: Do not call code that might call BIND or otherwise
-** make use of the Bind_Table or the Word cache array (BUF_WORDS).
-**
-***********************************************************************/
-{
- REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
-
- CHECK_BIND_TABLE;
-
- // Reuse a global word list block because length of block cannot
- // be known until all words are scanned. Then copy this block.
- if (SERIES_TAIL(BUF_WORDS)) Crash(RP_WORD_LIST); // still in use
-
- // Add the SELF word to slot zero.
- if ((modes = (modes & BIND_NO_SELF)?0:SYM_SELF))
- binds[modes] = -1; // (cannot use zero here)
- Init_Frame_Word(BLK_HEAD(BUF_WORDS), modes);
- SERIES_TAIL(BUF_WORDS) = 1;
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Collect_End(REBSER *prior)
-/*
-** Finish collecting words, and free the Bind_Table for reuse.
-**
-***********************************************************************/
-{
- REBVAL *words;
- REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
-
- // Reset binding table (note BUF_WORDS may have expanded):
- for (words = BLK_HEAD(BUF_WORDS); NOT_END(words); words++)
- binds[VAL_WORD_CANON(words)] = 0;
-
- // If no new words, prior frame:
- if (prior && SERIES_TAIL(BUF_WORDS) == SERIES_TAIL(prior)) {
- RESET_TAIL(BUF_WORDS); // allow reuse
- return FRM_WORD_SERIES(prior);
- }
-
- prior = Copy_Series(BUF_WORDS);
- RESET_TAIL(BUF_WORDS); // allow reuse
- BARE_SERIES(prior); // No GC ever needed for word list
-
- CHECK_BIND_TABLE;
-
- return prior;
-}
-
-
-/***********************************************************************
-**
-*/ void Collect_Object(REBSER *prior)
-/*
-** Collect words from a prior object.
-**
-***********************************************************************/
-{
- REBVAL *words = FRM_WORDS(prior);
- REBINT *binds = WORDS_HEAD(Bind_Table);
- REBINT n;
-
- // this is necessary for COPY_VALUES below
- // to not overwrite memory BUF_WORDS does not own
- RESIZE_SERIES(BUF_WORDS, SERIES_TAIL(prior));
- COPY_VALUES(words, BLK_HEAD(BUF_WORDS), SERIES_TAIL(prior));
- SERIES_TAIL(BUF_WORDS) = SERIES_TAIL(prior);
- for (n = 1, words++; NOT_END(words); words++) // skips first = SELF
- binds[VAL_WORD_CANON(words)] = n++;
-}
-
-
-/***********************************************************************
-**
-*/ void Collect_Words(REBVAL *block, REBFLG modes)
-/*
-** The inner recursive loop used for Collect_Frame function below.
-**
-***********************************************************************/
-{
- REBINT *binds = WORDS_HEAD(Bind_Table);
- REBVAL *word;
- REBVAL *value;
-
- for (; NOT_END(block); block++) {
- value = block;
- //if (modes & BIND_GET && IS_GET_WORD(block)) value = Get_Var(block);
- if (ANY_WORD(value)) {
- if (!binds[VAL_WORD_CANON(value)]) { // only once per word
- if (IS_SET_WORD(value) || modes & BIND_ALL) {
- binds[VAL_WORD_CANON(value)] = SERIES_TAIL(BUF_WORDS);
- EXPAND_SERIES_TAIL(BUF_WORDS, 1);
- word = BLK_LAST(BUF_WORDS);
- VAL_SET(word, VAL_TYPE(value));
- VAL_SET_OPT(word, OPTS_UNWORD);
- VAL_BIND_SYM(word) = VAL_WORD_SYM(value);
- // Allow all datatypes (to start):
- VAL_BIND_TYPESET(word) = ~((TYPESET(REB_END) | TYPESET(REB_UNSET))); // not END or UNSET
- }
- } else {
- // If word duplicated:
- if (modes & BIND_NO_DUP) {
- // Reset binding table (note BUF_WORDS may have expanded):
- for (word = BLK_HEAD(BUF_WORDS); NOT_END(word); word++)
- binds[VAL_WORD_CANON(word)] = 0;
- RESET_TAIL(BUF_WORDS); // allow reuse
- Trap1(RE_DUP_VARS, value);
- }
- }
- continue;
- }
- // Recurse into sub-blocks:
- if (ANY_EVAL_BLOCK(value) && (modes & BIND_DEEP))
- Collect_Words(VAL_BLK_DATA(value), modes);
- // In this mode (foreach native), do not allow non-words:
- //else if (modes & BIND_GET) Trap_Arg(value);
- }
- BLK_TERM(BUF_WORDS);
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Collect_Frame(REBFLG modes, REBSER *prior, REBVAL *block)
-/*
-** Scans a block for words to use in the frame. The list of
-** words can then be used to create a frame. The Bind_Table is
-** used to quickly determine duplicate entries.
-**
-** Returns:
-** A block of words that can be used for a frame word list.
-** If no new words, the prior list is returned.
-**
-** Modes:
-** BIND_ALL - scan all words, or just set words
-** BIND_DEEP - scan sub-blocks too
-** BIND_GET - substitute :word with actual word
-** BIND_NO_SELF - do not add implicit SELF to the frame
-**
-***********************************************************************/
-{
- Collect_Start(modes);
-
- // Setup binding table with existing words:
- if (prior) Collect_Object(prior);
-
- // Scan for words, adding them to BUF_WORDS and bind table:
- Collect_Words(block, modes);
-
- return Collect_End(prior);
-}
-
-
-/***********************************************************************
-**
-*/ void Collect_Simple_Words(REBVAL *block, REBCNT modes)
-/*
-** Used for Collect_Block_Words().
-**
-***********************************************************************/
-{
- REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
- REBVAL *val;
-
- for (; NOT_END(block); block++) {
- if (ANY_WORD(block)
- && !binds[VAL_WORD_CANON(block)]
- && (modes & BIND_ALL || IS_SET_WORD(block))
- ) {
- binds[VAL_WORD_CANON(block)] = 1;
- val = Append_Value(BUF_WORDS);
- Init_Word(val, VAL_WORD_SYM(block));
- }
- else if (ANY_EVAL_BLOCK(block) && (modes & BIND_DEEP))
- Collect_Simple_Words(VAL_BLK_DATA(block), modes);
- }
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Collect_Block_Words(REBVAL *block, REBVAL *prior, REBCNT modes)
-/*
-** Collect words from a prior block and new block.
-**
-***********************************************************************/
-{
- REBSER *series;
- REBCNT start;
- REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
- CHECK_BIND_TABLE;
-
- if (SERIES_TAIL(BUF_WORDS)) Crash(RP_WORD_LIST); // still in use
-
- if (prior)
- Collect_Simple_Words(prior, BIND_ALL);
-
- start = SERIES_TAIL(BUF_WORDS);
- Collect_Simple_Words(block, modes);
-
- // Reset word markers:
- for (block = BLK_HEAD(BUF_WORDS); NOT_END(block); block++)
- binds[VAL_WORD_CANON(block)] = 0;
-
- series = Copy_Series_Part(BUF_WORDS, start, SERIES_TAIL(BUF_WORDS)-start);
- RESET_TAIL(BUF_WORDS); // allow reuse
-
- CHECK_BIND_TABLE;
- return series;
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Create_Frame(REBSER *words, REBSER *spec)
-/*
-** Create a new frame from a word list.
-** The values of the frame are initialized to NONE.
-**
-***********************************************************************/
-{
- REBINT len = SERIES_TAIL(words);
- REBSER *frame = Make_Block(len);
- REBVAL *value = BLK_HEAD(frame);
-
- SET_FRAME(value, spec, words);
-
- SERIES_TAIL(frame) = len;
- for (value++, len--; len > 0; len--, value++) SET_NONE(value); // skip first value (self)
- SET_END(value);
-
- return frame;
-}
-
-
-/***********************************************************************
-**
-*/ void Rebind_Frame(REBSER *src_frame, REBSER *dst_frame)
-/*
-** Clone old src_frame to new dst_frame knowing
-** which types of values need to be copied, deep copied, and rebound.
-**
-***********************************************************************/
-{
- // Rebind all values:
- Rebind_Block(src_frame, dst_frame, BLK_SKIP(dst_frame, 1), REBIND_FUNC);
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Make_Object(REBSER *parent, REBVAL *block)
-/*
-** Create an object from a parent object and a spec block.
-** The words within the resultant object are not bound.
-**
-***********************************************************************/
-{
- REBSER *words;
- REBSER *object;
-
- PG_Reb_Stats->Objects++;
-
- if (!block || IS_END(block)) {
- object = parent ? Copy_Block_Values(parent, 0, SERIES_TAIL(parent), TS_CLONE) : Make_Frame(0);
- } else {
- words = Collect_Frame(BIND_ONLY, parent, block); // GC safe
- object = Create_Frame(words, 0); // GC safe
- if (parent) {
- if (Reb_Opts->watch_obj_copy)
- Debug_Fmt(BOOT_STR(RS_WATCH, 2), SERIES_TAIL(parent) - 1, FRM_WORD_SERIES(object));
- // Copy parent values and deep copy blocks and strings:
- COPY_VALUES(FRM_VALUES(parent)+1, FRM_VALUES(object)+1, SERIES_TAIL(parent) - 1);
- Copy_Deep_Values(object, 1, SERIES_TAIL(object), TS_CLONE);
- }
- }
-
- //Dump_Frame(object);
- return object;
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Construct_Object(REBSER *parent, REBVAL *block, REBFLG asis)
-/*
-** Construct an object (partial evaluation of block).
-** Parent can be null. Block is rebound.
-**
-***********************************************************************/
-{
- REBSER *frame;
-
- frame = Make_Object(parent, block);
- if (NOT_END(block)) Bind_Block(frame, block, BIND_ONLY);
- if (asis) Do_Min_Construct(block);
- else Do_Construct(block);
- return frame;
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Make_Object_Block(REBSER *frame, REBINT mode)
-/*
-** Return a block containing words, values, or set-word: value
-** pairs for the given object. Note: words are bound to original
-** object.
-**
-** Modes:
-** 1 for word
-** 2 for value
-** 3 for words and values
-**
-***********************************************************************/
-{
- REBVAL *words = FRM_WORDS(frame);
- REBVAL *values = FRM_VALUES(frame);
- REBSER *block;
- REBVAL *value;
- REBCNT n;
-
- n = (mode & 4) ? 0 : 1;
- block = Make_Block(SERIES_TAIL(frame) * (n + 1));
-
- for (; n < SERIES_TAIL(frame); n++) {
- if (!VAL_GET_OPT(words+n, OPTS_HIDE)) {
- if (mode & 1) {
- value = Append_Value(block);
- if (mode & 2) {
- VAL_SET(value, REB_SET_WORD);
- VAL_SET_LINE(value);
- }
- else VAL_SET(value, REB_WORD); //VAL_TYPE(words+n));
- VAL_WORD_SYM(value) = VAL_BIND_SYM(words+n);
- VAL_WORD_INDEX(value) = n;
- VAL_WORD_FRAME(value) = frame;
- }
- if (mode & 2) {
- Append_Val(block, values+n);
- }
- }
- }
-
- return block;
-}
-
-
-/***********************************************************************
-**
-*/ void Assert_Public_Object(REBVAL *value)
-/*
-***********************************************************************/
-{
- REBVAL *word = BLK_HEAD(VAL_OBJ_WORDS(value));
-
- for (; NOT_END(word); word++)
- if (VAL_GET_OPT(word, OPTS_HIDE)) Trap0(RE_HIDDEN);
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Make_Module(REBVAL *spec)
-/*
-** Create a module from a spec and an init block.
-** Call the Make_Module function in the system/intrinsic object.
-**
-***********************************************************************/
-{
- REBVAL *value;
-
- value = Do_Sys_Func(SYS_CTX_MAKE_MODULE_P, spec, 0); // volatile
- if (IS_NONE(value)) Trap1(RE_INVALID_SPEC, spec);
-
- return value;
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Make_Module_Spec(REBVAL *block)
-/*
-** Create a module spec object. Holds module name, version,
-** exports, locals, and more. See system/standard/module.
-**
-***********************************************************************/
-{
- REBSER *obj;
- REBSER *frame;
-
- // Build standard module header object:
- obj = VAL_OBJ_FRAME(Get_System(SYS_STANDARD, STD_SCRIPT));
- if (block && IS_BLOCK(block)) frame = Construct_Object(obj, VAL_BLK_DATA(block), 0);
- else frame = CLONE_OBJECT(obj);
-
- return frame;
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Merge_Frames(REBSER *parent1, REBSER *parent2)
-/*
-** Create a child frame from two parent frames. Merge common fields.
-** Values from the second parent take precedence.
-**
-** Deep copy and rebind the child.
-**
-***********************************************************************/
-{
- REBSER *wrds;
- REBSER *child;
- REBVAL *words;
- REBVAL *value;
- REBCNT n;
- REBINT *binds = WORDS_HEAD(Bind_Table);
-
- // Merge parent1 and parent2 words.
- // Keep the binding table.
- Collect_Start(BIND_ALL);
- // Setup binding table and BUF_WORDS with parent1 words:
- if (parent1) Collect_Object(parent1);
- // Add parent2 words to binding table and BUF_WORDS:
- Collect_Words(BLK_SKIP(FRM_WORD_SERIES(parent2), 1), BIND_ALL);
-
- // Allocate child (now that we know the correct size):
- wrds = Copy_Series(BUF_WORDS);
- child = Make_Block(SERIES_TAIL(wrds));
- value = Append_Value(child);
- VAL_SET(value, REB_FRAME);
- VAL_FRM_WORDS(value) = wrds;
- VAL_FRM_SPEC(value) = 0;
-
- // Copy parent1 values:
- COPY_VALUES(FRM_VALUES(parent1)+1, FRM_VALUES(child)+1, SERIES_TAIL(parent1)-1);
-
- // Copy parent2 values:
- words = FRM_WORDS(parent2)+1;
- value = FRM_VALUES(parent2)+1;
- for (; NOT_END(words); words++, value++) {
- // no need to search when the binding table is available
- n = binds[VAL_WORD_CANON(words)];
- BLK_HEAD(child)[n] = *value;
- }
-
- // Terminate the child frame:
- SERIES_TAIL(child) = SERIES_TAIL(wrds);
- BLK_TERM(child);
-
- // Deep copy the child
- Copy_Deep_Values(child, 1, SERIES_TAIL(child), TS_CLONE);
-
- // Rebind the child
- Rebind_Block(parent1, child, BLK_SKIP(child, 1), REBIND_FUNC);
- Rebind_Block(parent2, child, BLK_SKIP(child, 1), REBIND_FUNC | REBIND_TABLE);
-
- // release the bind table
- Collect_End(child);
-
- return child;
-}
-
-
-/***********************************************************************
-**
-*/ void Resolve_Context(REBSER *target, REBSER *source, REBVAL *only_words, REBFLG all, REBFLG expand)
-/*
-** Only_words can be a block of words or an index in the target
-** (for new words).
-**
-***********************************************************************/
-{
- REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
- REBVAL *words;
- REBVAL *vals;
- REBINT n;
- REBINT m;
- REBCNT i = 0;
-
- CHECK_BIND_TABLE;
-
- if (IS_PROTECT_SERIES(target)) Trap0(RE_PROTECTED);
-
- if (IS_INTEGER(only_words)) { // Must be: 0 < i <= tail
- i = VAL_INT32(only_words); // never <= 0
- if (i == 0) i = 1;
- if (i >= target->tail) return;
- }
-
- Collect_Start(BIND_NO_SELF); // DO NOT TRAP IN THIS SECTION
-
- n = 0;
-
- // If limited resolve, tag the word ids that need to be copied:
- if (i) {
- // Only the new words of the target:
- for (words = FRM_WORD(target, i); NOT_END(words); words++)
- binds[VAL_BIND_CANON(words)] = -1;
- n = SERIES_TAIL(target) - 1;
- }
- else if (IS_BLOCK(only_words)) {
- // Limit exports to only these words:
- for (words = VAL_BLK_DATA(only_words); NOT_END(words); words++) {
- if (IS_WORD(words) || IS_SET_WORD(words)) {
- binds[VAL_WORD_CANON(words)] = -1;
- n++;
- }
- }
- }
-
- // Expand target as needed:
- if (expand && n > 0) {
- // Determine how many new words to add:
- for (words = FRM_WORD(target, 1); NOT_END(words); words++)
- if (binds[VAL_BIND_CANON(words)]) n--;
- // Expand frame by the amount required:
- if (n > 0) Expand_Frame(target, n, 0);
- else expand = 0;
- }
-
- // Maps a word to its value index in the source context.
- // Done by marking all source words (in bind table):
- words = FRM_WORDS(source)+1;
- for (n = 1; NOT_END(words); n++, words++) {
- if (IS_NONE(only_words) || binds[VAL_BIND_CANON(words)])
- binds[VAL_WORD_CANON(words)] = n;
- }
-
- // Foreach word in target, copy the correct value from source:
- n = i ? i : 1;
- vals = FRM_VALUE(target, n);
- for (words = FRM_WORD(target, n); NOT_END(words); words++, vals++) {
- if ((m = binds[VAL_BIND_CANON(words)])) {
- binds[VAL_BIND_CANON(words)] = 0; // mark it as set
- if (!VAL_PROTECTED(words) && (all || IS_UNSET(vals))) {
- if (m < 0) SET_UNSET(vals); // no value in source context
- else *vals = *FRM_VALUE(source, m);
- //Debug_Num("type:", VAL_TYPE(vals));
- //Debug_Str(Get_Word_Name(words));
- }
- }
- }
-
- // Add any new words and values:
- if (expand) {
- REBVAL *val;
- words = FRM_WORDS(source)+1;
- for (n = 1; NOT_END(words); n++, words++) {
- if (binds[VAL_BIND_CANON(words)]) {
- // Note: no protect check is needed here
- binds[VAL_BIND_CANON(words)] = 0;
- val = Append_Frame(target, 0, VAL_BIND_SYM(words));
- *val = *FRM_VALUE(source, n);
- }
- }
- }
- else {
- // Reset bind table (do not use Collect_End):
- if (i) {
- for (words = FRM_WORD(target, i); NOT_END(words); words++)
- binds[VAL_BIND_CANON(words)] = 0;
- }
- else if (IS_BLOCK(only_words)) {
- for (words = VAL_BLK_DATA(only_words); NOT_END(words); words++) {
- if (IS_WORD(words) || IS_SET_WORD(words)) binds[VAL_WORD_CANON(words)] = 0;
- }
- }
- else {
- for (words = FRM_WORDS(source)+1; NOT_END(words); words++)
- binds[VAL_BIND_CANON(words)] = 0;
- }
- }
-
- CHECK_BIND_TABLE;
-
- RESET_TAIL(BUF_WORDS); // allow reuse, trapping ok now
-}
-
-
-/***********************************************************************
-**
-*/ static void Bind_Block_Words(REBSER *frame, REBVAL *value, REBCNT mode)
-/*
-** Inner loop of bind block. Modes are:
-**
-** BIND_ONLY Only bind the words found in the frame.
-** BIND_SET Add set-words to the frame during the bind.
-** BIND_ALL Add words to the frame during the bind.
-** BIND_DEEP Recurse into sub-blocks.
-**
-** NOTE: BIND_SET must be used carefully, because it does not
-** bind prior instances of the word before the set-word. That is
-** forward references are not allowed.
-**
-***********************************************************************/
-{
- REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
- REBCNT n;
- REBFLG selfish = !IS_SELFLESS(frame);
-
- for (; NOT_END(value); value++) {
- if (ANY_WORD(value)) {
- //Print("Word: %s", Get_Sym_Name(VAL_WORD_CANON(value)));
- // Is the word found in this frame?
- if (NZ(n = binds[VAL_WORD_CANON(value)])) {
- if (n == NO_RESULT) n = 0; // SELF word
- ASSERT1(n < SERIES_TAIL(frame), RP_BIND_BOUNDS);
- // Word is in frame, bind it:
- VAL_WORD_INDEX(value) = n;
- VAL_WORD_FRAME(value) = frame;
- }
- else if (selfish && VAL_WORD_CANON(value) == SYM_SELF) {
- VAL_WORD_INDEX(value) = 0;
- VAL_WORD_FRAME(value) = frame;
- }
- else {
- // Word is not in frame. Add it if option is specified:
- if ((mode & BIND_ALL) || ((mode & BIND_SET) && (IS_SET_WORD(value)))) {
- Append_Frame(frame, value, 0);
- binds[VAL_WORD_CANON(value)] = VAL_WORD_INDEX(value);
- }
- }
- }
- else if (ANY_BLOCK(value) && (mode & BIND_DEEP))
- Bind_Block_Words(frame, VAL_BLK_DATA(value), mode);
- else if ((IS_FUNCTION(value) || IS_CLOSURE(value)) && (mode & BIND_FUNC))
- Bind_Block_Words(frame, BLK_HEAD(VAL_FUNC_BODY(value)), mode);
- }
-}
-
-
-/***********************************************************************
-**
-*/ void Bind_Block(REBSER *frame, REBVAL *block, REBCNT mode)
-/*
-** Bind the words of a block to a specified frame.
-** Different modes may be applied:
-** BIND_ONLY - Only bind words found in the frame.
-** BIND_ALL - Add words to the frame during the bind.
-** BIND_SET - Add set-words to the frame during the bind.
-** (note: word must not occur before the SET)
-** BIND_DEEP - Recurse into sub-blocks.
-**
-***********************************************************************/
-{
- REBVAL *words;
- REBCNT index;
- REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
-
- CHECK_MEMORY(4);
-
- CHECK_BIND_TABLE;
-
- // Note about optimization: it's not a big win to avoid the
- // binding table for short blocks (size < 4), because testing
- // every block for the rare case adds up.
-
- // Setup binding table:
- index = 1;
- for (index = 1; index < frame->tail; index++) {
- words = FRM_WORD(frame, index);
- if (!VAL_GET_OPT(words, OPTS_HIDE))
- binds[VAL_BIND_CANON(words)] = index;
- }
-
- Bind_Block_Words(frame, block, mode);
-
- // Reset binding table:
- for (words = FRM_WORDS(frame)+1; NOT_END(words); words++)
- binds[VAL_BIND_CANON(words)] = 0;
-
- CHECK_BIND_TABLE;
-}
-
-
-/***********************************************************************
-**
-*/ void Unbind_Block(REBVAL *val, REBCNT deep)
-/*
-***********************************************************************/
-{
- for (; NOT_END(val); val++) {
- if (ANY_WORD(val)) {
- UNBIND(val);
- }
- if (ANY_BLOCK(val) && deep) {
- Unbind_Block(VAL_BLK_DATA(val), TRUE);
- }
- }
-}
-
-
-/***********************************************************************
-**
-*/ REBCNT Bind_Word(REBSER *frame, REBVAL *word)
-/*
-** Binds a word to a frame. If word is not part of the
-** frame, ignore it.
-**
-***********************************************************************/
-{
- REBCNT n;
-
- n = Find_Word_Index(frame, VAL_WORD_SYM(word), FALSE);
- if (n) {
- VAL_WORD_FRAME(word) = frame;
- VAL_WORD_INDEX(word) = n;
- }
- return n;
-}
-
-
-/***********************************************************************
-**
-*/ static void Bind_Relative_Words(REBSER *frame, REBSER *block)
-/*
-** Recursive function for relative function word binding.
-**
-** Note: frame arg points to an identifying series of the function,
-** not a normal frame. This will be used to verify the word fetch.
-**
-***********************************************************************/
-{
- REBVAL *value = BLK_HEAD(block);
- REBINT n;
-
- for (; NOT_END(value); value++) {
- if (ANY_WORD(value)) {
- // Is the word (canon sym) found in this frame?
- if (NZ(n = WORDS_HEAD(Bind_Table)[VAL_WORD_CANON(value)])) {
- // Word is in frame, bind it:
- VAL_WORD_INDEX(value) = n;
- VAL_WORD_FRAME(value) = frame; // func body
- }
- }
- else if (ANY_BLOCK(value))
- Bind_Relative_Words(frame, VAL_SERIES(value));
- }
-}
-
-
-/***********************************************************************
-**
-*/ void Bind_Relative(REBSER *words, REBSER *frame, REBSER *block)
-/*
-** Bind the words of a function block to a stack frame.
-** To indicate the relative nature of the index, it is set to
-** a negative offset.
-**
-** words: VAL_FUNC_ARGS(func)
-** frame: VAL_FUNC_ARGS(func)
-** block: block to bind
-**
-***********************************************************************/
-{
- REBVAL *args;
- REBINT index;
- REBINT *binds = WORDS_HEAD(Bind_Table); // GC safe to do here
-
- args = BLK_SKIP(words, 1);
-
- CHECK_BIND_TABLE;
-
- //Dump_Block(words);
-
- // Setup binding table from the argument word list:
- for (index = 1; NOT_END(args); args++, index++)
- binds[VAL_BIND_CANON(args)] = -index;
-
- Bind_Relative_Words(frame, block);
-
- // Reset binding table:
- for (args = BLK_SKIP(words, 1); NOT_END(args); args++)
- binds[VAL_BIND_CANON(args)] = 0;
-
- CHECK_BIND_TABLE;
-}
-
-
-/***********************************************************************
-**
-*/ void Bind_Stack_Block(REBSER *frame, REBSER *block)
-/*
-***********************************************************************/
-{
- Bind_Relative(frame, frame, block);
-}
-
-
-/***********************************************************************
-**
-*/ void Bind_Stack_Word(REBSER *frame, REBVAL *word)
-/*
-***********************************************************************/
-{
- REBINT index;
-
- index = Find_Arg_Index(frame, VAL_WORD_SYM(word));
- if (!index) Trap1(RE_NOT_IN_CONTEXT, word);
- VAL_WORD_FRAME(word) = frame;
- VAL_WORD_INDEX(word) = -index;
-}
-
-
-/***********************************************************************
-**
-*/ void Rebind_Block(REBSER *src_frame, REBSER *dst_frame, REBVAL *data, REBFLG modes)
-/*
-** Rebind all words that reference src frame to dst frame.
-** Rebind is always deep.
-**
-** There are two types of frames: relative frames and normal frames.
-** When frame_src type and frame_dst type differ,
-** modes must have REBIND_TYPE.
-**
-***********************************************************************/
-{
- REBINT *binds = WORDS_HEAD(Bind_Table);
-
- for (; NOT_END(data); data++) {
- if (ANY_BLOCK(data))
- Rebind_Block(src_frame, dst_frame, VAL_BLK_DATA(data), modes);
- else if (ANY_WORD(data) && VAL_WORD_FRAME(data) == src_frame) {
- VAL_WORD_FRAME(data) = dst_frame;
- if (modes & REBIND_TABLE) VAL_WORD_INDEX(data) = binds[VAL_WORD_CANON(data)];
- if (modes & REBIND_TYPE) VAL_WORD_INDEX(data) = - VAL_WORD_INDEX(data);
- } else if ((modes & REBIND_FUNC) && (IS_FUNCTION(data) || IS_CLOSURE(data)))
- Rebind_Block(src_frame, dst_frame, BLK_HEAD(VAL_FUNC_BODY(data)), modes);
- }
-}
-
-
-/***********************************************************************
-**
-*/ REBCNT Find_Arg_Index(REBSER *args, REBCNT sym)
-/*
-** Find function arg word in function arg "frame".
-**
-***********************************************************************/
-{
- REBCNT n;
- REBCNT s;
- REBVAL *word;
- REBCNT len;
-
- s = SYMBOL_TO_CANON(sym); // always compare to CANON sym
-
- word = BLK_SKIP(args, 1);
- len = SERIES_TAIL(args);
-
- for (n = 1; n < len; n++, word++)
- if (sym == VAL_BIND_SYM(word) || s == VAL_BIND_CANON(word)) return n;
-
- return 0;
-}
-
-
-/***********************************************************************
-**
-*/ REBCNT Find_Word_Index(REBSER *frame, REBCNT sym, REBFLG always)
-/*
-** Search a frame looking for the given word symbol.
-** Return the frame index for a word. Locate it by matching
-** the canon word identifiers. Return 0 if not found.
-**
-***********************************************************************/
-{
- REBCNT len = SERIES_TAIL(FRM_WORD_SERIES(frame));
- REBVAL *word = FRM_WORDS(frame) + 1;
- REBCNT n;
- REBCNT s;
-
- s = SYMBOL_TO_CANON(sym); // always compare to CANON sym
-
- for (n = 1; n < len; n++, word++)
- if (sym == VAL_BIND_SYM(word) || s == VAL_BIND_CANON(word))
- return (!always && VAL_GET_OPT(word, OPTS_HIDE)) ? 0 : n;
-
- return 0;
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Find_Word_Value(REBSER *frame, REBCNT sym)
-/*
-** Search a frame looking for the given word symbol and
-** return the value for the word. Locate it by matching
-** the canon word identifiers. Return NULL if not found.
-**
-***********************************************************************/
-{
- REBINT n;
-
- if (!frame) return 0;
- n = Find_Word_Index(frame, sym, FALSE);
- if (!n) return 0;
- return BLK_SKIP(frame, n);
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Find_In_Contexts(REBCNT sym, REBVAL *where)
-/*
-** Search a block of objects for a given word symbol and
-** return the value for the word. NULL if not found.
-**
-***********************************************************************/
-{
- REBVAL *val;
-
- for (; NOT_END(where); where++) {
- if (IS_WORD(where)) {
- val = Get_Var(where);
- }
- else if (IS_PATH(where)) {
- Do_Path(&where, 0);
- val = DS_TOP; // only safe for short time!
- }
- else
- val = where;
-
- if (IS_OBJECT(val)) {
- val = Find_Word_Value(VAL_OBJ_FRAME(val), sym);
- if (val) return val;
- }
- }
- return 0;
-}
-
-
-/***********************************************************************
-**
-*/ REBCNT Find_Word(REBSER *series, REBCNT index, REBCNT sym)
-/*
-** Find word (of any type) in a block... quickly.
-**
-***********************************************************************/
-{
- REBVAL *value;
-
- for (; index < SERIES_TAIL(series); index++) {
- value = BLK_SKIP(series, index);
- if (ANY_WORD(value) && sym == VAL_WORD_CANON(value))
- return index;
- }
-
- return NOT_FOUND;
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Get_Var(REBVAL *word)
-/*
-** Get the word (variable) value. (Use macro when possible).
-**
-***********************************************************************/
-{
- REBINT index = VAL_WORD_INDEX(word);
- REBSER *frame = VAL_WORD_FRAME(word);
- REBINT dsf;
-
- if (!frame) Trap1(RE_NOT_DEFINED, word);
- if (index >= 0) return FRM_VALUES(frame)+index;
-
- // A negative index indicates that the value is in a frame on
- // the data stack, so now we must find it by walking back the
- // stack looking for the function that the word is bound to.
- dsf = DSF;
- while (frame != VAL_WORD_FRAME(DSF_WORD(dsf))) {
- dsf = PRIOR_DSF(dsf);
- if (dsf <= 0) Trap1(RE_NOT_DEFINED, word); // change error !!!
- }
-// if (Trace_Level) Dump_Stack_Frame(dsf);
- return DSF_ARGS(dsf, -index);
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Get_Var_Safe(REBVAL *word)
-/*
-** Get the word, but check if it will be safe to modify.
-**
-***********************************************************************/
-{
- REBINT index = VAL_WORD_INDEX(word);
- REBSER *frame = VAL_WORD_FRAME(word);
- REBINT dsf;
-
- if (!frame) Trap1(RE_NOT_DEFINED, word);
-
- if (index >= 0) {
- if (VAL_PROTECTED(FRM_WORDS(frame) + index))
- Trap1(RE_LOCKED_WORD, word);
- return FRM_VALUES(frame) + index;
- }
-
- // A negative index indicates that the value is in a frame on
- // the data stack, so now we must find it by walking back the
- // stack looking for the function that the word is bound to.
- dsf = DSF;
- while (frame != VAL_WORD_FRAME(DSF_WORD(dsf))) {
- dsf = PRIOR_DSF(dsf);
- if (dsf <= 0) Trap1(RE_NOT_DEFINED, word); // change error !!!
- }
-// if (Trace_Level) Dump_Stack_Frame(dsf);
- return DSF_ARGS(dsf, -index);
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Get_Var_No_Trap(REBVAL *word)
-/*
-** Same as above, but returns 0 rather than error.
-**
-***********************************************************************/
-{
- REBINT index = VAL_WORD_INDEX(word);
- REBSER *frame = VAL_WORD_FRAME(word);
- REBINT dsf;
-
- if (!frame) return 0;
- if (index >= 0) return FRM_VALUES(frame)+index;
- dsf = DSF;
- while (frame != VAL_WORD_FRAME(DSF_WORD(dsf))) {
- dsf = PRIOR_DSF(dsf);
- if (dsf <= 0) return 0;
- }
- return DSF_ARGS(dsf, -index);
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Get_Any_Var(REBVAL *item)
-/*
-** Works for words and paths. For paths, return value is
-** volatile on top of stack.
-**
-***********************************************************************/
-{
- if (IS_WORD(item)) return Get_Var(item);
- if (IS_PATH(item)) {
- REBVAL *path = item;
- if (Do_Path(&path, 0)) return item; // found a function
- item = DS_TOP;
- }
- return item;
-}
-
-
-/***********************************************************************
-**
-*/ void Set_Var(REBVAL *word, REBVAL *value)
-/*
-** Set the word (variable) value. (Use macro when possible).
-**
-***********************************************************************/
-{
- REBINT index = VAL_WORD_INDEX(word);
- REBINT dsf;
- REBSER *frm;
-
- if (THROWN(value)) return;
-
- if (!HAS_FRAME(word)) Trap1(RE_NOT_DEFINED, word);
-
-// ASSERT(index, RP_BAD_SET_INDEX);
- ASSERT(VAL_WORD_FRAME(word), RP_BAD_SET_CONTEXT);
-// Print("Set %s to %s [frame: %x idx: %d]", Get_Word_Name(word), Get_Type_Name(value), VAL_WORD_FRAME(word), VAL_WORD_INDEX(word));
-
- if (index > 0) {
- frm = VAL_WORD_FRAME(word);
- if (VAL_PROTECTED(FRM_WORDS(frm)+index))
- Trap1(RE_LOCKED_WORD, word);
- FRM_VALUES(frm)[index] = *value;
- return;
- }
- if (index == 0) Trap0(RE_SELF_PROTECTED);
-
- // Find relative value:
- dsf = DSF;
- while (VAL_WORD_FRAME(word) != VAL_WORD_FRAME(DSF_WORD(dsf))) {
- dsf = PRIOR_DSF(dsf);
- if (dsf <= 0) Trap1(RE_NOT_DEFINED, word); // change error !!!
- }
- *DSF_ARGS(dsf, -index) = *value;
-}
-
-
-/***********************************************************************
-**
-*/ void Set_Var_Series(REBVAL *var, REBCNT type, REBSER *series, REBCNT index)
-/*
-** A commonly used helper function to set a variable
-** to a series value.
-**
-***********************************************************************/
-{
- REBVAL value;
-
- VAL_SET(&value, type);
- VAL_SERIES(&value) = series;
- VAL_INDEX(&value) = index;
- VAL_SERIES_SIDE(&value) = 0;
-
- Set_Var(var, &value);
-}
-
-
-/***********************************************************************
-**
-*/ void Set_Var_Basic(REBVAL *var, REBCNT type, ...)
-/*
-** A commonly used helper function to set a variable
-** to a basic value.
-**
-***********************************************************************/
-{
- REBVAL value = {0};
-
- VAL_SET(&value, type);
-
- Set_Var(var, &value);
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Obj_Word(REBVAL *value, REBCNT index)
-/*
-** Return pointer to the nth WORD of an object.
-**
-***********************************************************************/
-{
- REBSER *obj = VAL_OBJ_WORDS(value);
- return BLK_SKIP(obj, index);
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Obj_Value(REBVAL *value, REBCNT index)
-/*
-** Return pointer to the nth VALUE of an object.
-** Return zero if the index is not valid.
-**
-***********************************************************************/
-{
- REBSER *obj = VAL_OBJ_FRAME(value);
-
- if (index >= SERIES_TAIL(obj)) return 0;
- return BLK_SKIP(obj, index);
-}
-
-
-/***********************************************************************
-**
-*/ void Init_Obj_Value(REBVAL *value, REBSER *frame)
-/*
-***********************************************************************/
-{
- ASSERT(frame, RP_BAD_SET_CONTEXT);
- CLEARS(value);
- SET_OBJECT(value, frame);
-}
-
-/***********************************************************************
-**
-*/ void Check_Frame(REBSER *frame)
-/*
-***********************************************************************/
-{
- REBINT n;
- REBVAL *values = FRM_VALUES(frame);
- REBVAL *words = FRM_WORDS(frame);
- REBINT tail = SERIES_TAIL(frame);
-
- for (n = 0; n < tail; n++, values++, words++) {
- if (IS_END(words) || IS_END(values)) {
- Debug_Fmt("** Early %s end at index: %d", IS_END(words) ? "words" : "values", n);
- }
- }
-
- if (NOT_END(words) || NOT_END(values))
- Debug_Fmt("** Missing %s end at index: %d type: %d", NOT_END(words) ? "words" : "values", n, VAL_TYPE(words));
-}
-
-
-/***********************************************************************
-**
-*/ void Init_Frame(void)
-/*
-***********************************************************************/
-{
- // Temporary block used while scanning for frame words:
- Set_Root_Series(TASK_BUF_WORDS, Make_Block(100), "word cache"); // just holds words, no GC
-}
diff --git a/src/core/c-function.c b/src/core/c-function.c
index 293ee21c24..0538a9ce3f 100644
--- a/src/core/c-function.c
+++ b/src/core/c-function.c
@@ -1,471 +1,2163 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: c-function.c
-** Summary: support for functions, actions, and closures
-** Section: core
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-/*
- Structure of functions:
-
- spec - interface spec block
- body - body code
- args - args list (see below)
-
- Args list is a block of word+values:
-
- word - word, 'word, :word, /word
- value - typeset! or none (valid datatypes)
-
- Args list provides:
-
- 1. specifies arg order, arg kind (e.g. 'word)
- 2. specifies valid datatypes (typesets)
- 3. used for word and type in error output
- 4. used for debugging tools (stack dumps)
- 5. not used for MOLD (spec is used)
- 6. used as a (pseudo) frame of function variables
-
-*/
+//
+// File: %c-function.c
+// Summary: "support for functions, actions, and routines"
+// Section: core
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ REBSER *List_Func_Words(REBVAL *func)
-/*
-** Return a block of function words, unbound.
-** Note: skips 0th entry.
-**
-***********************************************************************/
+//
+// List_Func_Words: C
+//
+// Return a block of function words, unbound.
+// Note: skips 0th entry.
+//
+REBARR *List_Func_Words(const RELVAL *func, REBOOL pure_locals)
{
- REBSER *block;
- REBSER *words = VAL_FUNC_WORDS(func);
- REBCNT n;
- REBVAL *value;
- REBVAL *word;
-
- block = Make_Block(SERIES_TAIL(words));
- word = BLK_SKIP(words, 1);
-
- for (n = 1; n < SERIES_TAIL(words); word++, n++) {
- value = Append_Value(block);
- VAL_SET(value, VAL_TYPE(word));
- VAL_WORD_SYM(value) = VAL_BIND_SYM(word);
- UNBIND(value);
- }
-
- return block;
+ REBARR *array = Make_Array(VAL_FUNC_NUM_PARAMS(func));
+ REBVAL *param = VAL_FUNC_PARAMS_HEAD(func);
+
+ for (; NOT_END(param); param++) {
+ enum Reb_Kind kind;
+
+ switch (VAL_PARAM_CLASS(param)) {
+ case PARAM_CLASS_NORMAL:
+ kind = REB_WORD;
+ break;
+
+ case PARAM_CLASS_TIGHT:
+ kind = REB_ISSUE;
+ break;
+
+ case PARAM_CLASS_REFINEMENT:
+ kind = REB_REFINEMENT;
+ break;
+
+ case PARAM_CLASS_HARD_QUOTE:
+ kind = REB_GET_WORD;
+ break;
+
+ case PARAM_CLASS_SOFT_QUOTE:
+ kind = REB_LIT_WORD;
+ break;
+
+ case PARAM_CLASS_LOCAL:
+ case PARAM_CLASS_RETURN: // "magic" local - prefilled invisibly
+ case PARAM_CLASS_LEAVE: // "magic" local - prefilled invisibly
+ if (!pure_locals)
+ continue; // treat as invisible, e.g. for WORDS-OF
+
+ kind = REB_SET_WORD;
+ break;
+
+ default:
+ assert(FALSE);
+ DEAD_END;
+ }
+
+ Init_Any_Word(
+ Alloc_Tail_Array(array), kind, VAL_PARAM_SPELLING(param)
+ );
+ }
+
+ return array;
}
-/***********************************************************************
-**
-*/ REBSER *List_Func_Types(REBVAL *func)
-/*
-** Return a block of function arg types.
-** Note: skips 0th entry.
-**
-***********************************************************************/
+//
+// List_Func_Typesets: C
+//
+// Return a block of function arg typesets.
+// Note: skips 0th entry.
+//
+REBARR *List_Func_Typesets(REBVAL *func)
{
- REBSER *block;
- REBSER *words = VAL_FUNC_WORDS(func);
- REBCNT n;
- REBVAL *value;
- REBVAL *word;
-
- block = Make_Block(SERIES_TAIL(words));
- word = BLK_SKIP(words, 1);
-
- for (n = 1; n < SERIES_TAIL(words); word++, n++) {
- value = Append_Value(block);
- VAL_SET(value, VAL_TYPE(word));
- VAL_WORD_SYM(value) = VAL_BIND_SYM(word);
- UNBIND(value);
- }
-
- return block;
+ REBARR *array = Make_Array(VAL_FUNC_NUM_PARAMS(func));
+ REBVAL *typeset = VAL_FUNC_PARAMS_HEAD(func);
+
+ for (; NOT_END(typeset); typeset++) {
+ assert(IS_TYPESET(typeset));
+
+ REBVAL *value = Alloc_Tail_Array(array);
+ Move_Value(value, typeset);
+
+ // !!! It's already a typeset, but this will clear out the header
+ // bits. This may not be desirable over the long run (what if
+ // a typeset wishes to encode hiddenness, protectedness, etc?)
+ //
+ VAL_RESET_HEADER(value, REB_TYPESET);
+ }
+
+ return array;
+}
+
+
+enum Reb_Spec_Mode {
+ SPEC_MODE_NORMAL, // words are arguments
+ SPEC_MODE_LOCAL, // words are locals
+ SPEC_MODE_WITH // words are "extern"
+};
+
+
+//
+// Make_Paramlist_Managed_May_Fail: C
+//
+// Check function spec of the form:
+//
+// ["description" arg "notes" [type! type2! ...] /ref ...]
+//
+// !!! The spec language was not formalized in R3-Alpha. Strings were left
+// in and it was HELP's job (and any other clients) to make sense of it, e.g.:
+//
+// [foo [type!] {doc string :-)}]
+// [foo {doc string :-/} [type!]]
+// [foo {doc string1 :-/} {doc string2 :-(} [type!]]
+//
+// Ren-C breaks this into two parts: one is the mechanical understanding of
+// MAKE FUNCTION! for parameters in the evaluator. Then it is the job
+// of a generator to tag the resulting function with a "meta object" with any
+// descriptions. As a proxy for the work of a usermode generator, this
+// routine tries to fill in FUNCTION-META (see %sysobj.r) as well as to
+// produce a paramlist suitable for the function.
+//
+// Note a "true local" (indicated by a set-word) is considered to be tacit
+// approval of wanting a definitional return by the generator. This helps
+// because Red's model for specifying returns uses a SET-WORD!
+//
+// func [return: [integer!] {returns an integer}]
+//
+// In Ren/C's case it just means you want a local called return, but the
+// generator will be "initializing it with a definitional return" for you.
+// You don't have to use it if you don't want to...and may overwrite the
+// variable. But it won't be a void at the start.
+//
+REBARR *Make_Paramlist_Managed_May_Fail(
+ const REBVAL *spec,
+ REBFLGS flags
+) {
+ assert(ANY_ARRAY(spec));
+
+ REBUPT header_bits = 0;
+
+#if !defined(NDEBUG)
+ //
+ // Debug builds go ahead and include a RETURN field and hang onto the
+ // typeset for fake returns (e.g. natives). But they make a note that
+ // they are doing this, which helps know what the actual size of the
+ // frame would be in a release build (e.g. for a FRM_CELL() assert)
+ //
+ if (flags & MKF_FAKE_RETURN) {
+ header_bits |= FUNC_FLAG_RETURN_DEBUG;
+ flags &= ~MKF_FAKE_RETURN;
+ assert(NOT(flags & MKF_RETURN));
+ flags |= MKF_RETURN;
+ }
+#endif
+
+ REBOOL durable = FALSE;
+
+ REBDSP dsp_orig = DSP;
+ assert(DS_TOP == DS_AT(dsp_orig));
+
+ REBDSP definitional_return_dsp = 0;
+ REBDSP definitional_leave_dsp = 0;
+
+ // As we go through the spec block, we push TYPESET! BLOCK! STRING! triples.
+ // These will be split out into separate arrays after the process is done.
+ // The first slot of the paramlist needs to be the function canon value,
+ // while the other two first slots need to be rootkeys. Get the process
+ // started right after a BLOCK! so it's willing to take a string for
+ // the function description--it will be extracted from the slot before
+ // it is turned into a rootkey for param_notes.
+ //
+ DS_PUSH_TRASH; // paramlist[0] (will become FUNCTION! canon value)
+ SET_UNREADABLE_BLANK(DS_TOP);
+ DS_PUSH(EMPTY_BLOCK); // param_types[0] (to be OBJECT! canon value, if any)
+ DS_PUSH(EMPTY_STRING); // param_notes[0] (holds description, then canon)
+
+ REBOOL has_description = FALSE;
+ REBOOL has_types = FALSE;
+ REBOOL has_notes = FALSE;
+
+ enum Reb_Spec_Mode mode = SPEC_MODE_NORMAL;
+
+ REBOOL refinement_seen = FALSE;
+
+ DECLARE_FRAME (f);
+ Push_Frame(f, spec);
+
+ while (NOT_END(f->value)) {
+ const RELVAL *item = f->value; // "faked", e.g. => RETURN:
+ Fetch_Next_In_Frame(f); // go ahead and consume next
+
+ //=//// STRING! FOR FUNCTION DESCRIPTION OR PARAMETER NOTE ////////////=//
+
+ if (IS_STRING(item)) {
+ //
+ // Consider `[ some-extern "description of that extern"]` to
+ // be purely commentary for the implementation, and don't include
+ // it in the meta info.
+ //
+ if (mode == SPEC_MODE_WITH)
+ continue;
+
+ if (IS_TYPESET(DS_TOP))
+ DS_PUSH(EMPTY_BLOCK); // need a block to be in position
+
+ if (IS_BLOCK(DS_TOP)) { // we're in right spot to push notes/title
+ DS_PUSH_TRASH;
+ Init_String(
+ DS_TOP,
+ Copy_String_Slimming(VAL_SERIES(item), VAL_INDEX(item), -1)
+ );
+ }
+ else {
+ assert(IS_STRING(DS_TOP));
+
+ // !!! A string was already pushed. Should we append?
+ //
+ Init_String(
+ DS_TOP,
+ Copy_String_Slimming(VAL_SERIES(item), VAL_INDEX(item), -1)
+ );
+ }
+
+ if (DS_TOP == DS_AT(dsp_orig + 3))
+ has_description = TRUE;
+ else
+ has_notes = TRUE;
+
+ continue;
+ }
+
+ //=//// TOP-LEVEL SPEC TAGS LIKE , etc. /////////////////=//
+
+ if (IS_TAG(item) && (flags & MKF_KEYWORDS)) {
+ if (0 == Compare_String_Vals(item, ROOT_WITH_TAG, TRUE)) {
+ mode = SPEC_MODE_WITH;
+ }
+ else if (0 == Compare_String_Vals(item, ROOT_LOCAL_TAG, TRUE)) {
+ mode = SPEC_MODE_LOCAL;
+ }
+ else if (0 == Compare_String_Vals(item, ROOT_DURABLE_TAG, TRUE)) {
+ //
+ // is currently a lesser version of what it
+ // hopes to be, but signals what R3-Alpha called CLOSURE!
+ // semantics. Indicating that a typeset is durable in
+ // the low-level will need to be done with some notation
+ // that doesn't use "keywords"--perhaps a #[true] or a
+ // #[false] picked up on by the typeset.
+ //
+ // !!! Enforce only at the head, if it's going to be
+ // applying to everything??
+ //
+ durable = TRUE;
+ }
+ else
+ fail (Error_Bad_Func_Def_Core(item, VAL_SPECIFIER(spec)));
+
+ continue;
+ }
+
+ //=//// BLOCK! OF TYPES TO MAKE TYPESET FROM (PLUS PARAMETER TAGS) ////=//
+
+ if (IS_BLOCK(item)) {
+ if (IS_BLOCK(DS_TOP)) // two blocks of types!
+ fail (Error_Bad_Func_Def_Core(item, VAL_SPECIFIER(spec)));
+
+ // You currently can't say ` x [integer!]`, because they
+ // are always void when the function runs. You can't say
+ // ` x [integer!]` because "externs" don't have param slots
+ // to store the type in.
+ //
+ // !!! A type constraint on a parameter might be useful,
+ // though--and could be achieved by adding a type checker into
+ // the body of the function. However, that would be more holistic
+ // than this generation of just a paramlist. Consider for future.
+ //
+ if (mode != SPEC_MODE_NORMAL)
+ fail (Error_Bad_Func_Def_Core(item, VAL_SPECIFIER(spec)));
+
+ // Save the block for parameter types.
+ //
+ REBVAL *typeset;
+ if (IS_TYPESET(DS_TOP)) {
+ REBSPC *derived = Derive_Specifier(VAL_SPECIFIER(spec), item);
+ DS_PUSH_TRASH;
+ Init_Block(
+ DS_TOP,
+ Copy_Array_At_Deep_Managed(
+ VAL_ARRAY(item),
+ VAL_INDEX(item),
+ derived
+ )
+ );
+
+ typeset = DS_TOP - 1; // volatile if you DS_PUSH!
+ }
+ else {
+ assert(IS_STRING(DS_TOP)); // !!! are blocks after notes good?
+
+ if (IS_BLANK_RAW(DS_TOP - 2)) {
+ //
+ // No typesets pushed yet, so this is a block before any
+ // parameters have been named. This was legal in Rebol2
+ // for e.g. `func [[catch] x y][...]`, and R3-Alpha
+ // ignored it. Ren-C only tolerates this in ,
+ // (with the tolerance implemented in compatibility FUNC)
+ //
+ fail (Error_Bad_Func_Def_Core(item, VAL_SPECIFIER(spec)));
+ }
+
+ assert(IS_TYPESET(DS_TOP - 2));
+ typeset = DS_TOP - 2;
+
+ assert(IS_BLOCK(DS_TOP - 1));
+ if (VAL_ARRAY(DS_TOP - 1) != EMPTY_ARRAY)
+ fail (Error_Bad_Func_Def_Core(item, VAL_SPECIFIER(spec)));
+
+ REBSPC *derived = Derive_Specifier(VAL_SPECIFIER(spec), item);
+ Init_Block(
+ DS_TOP - 1,
+ Copy_Array_At_Deep_Managed(
+ VAL_ARRAY(item),
+ VAL_INDEX(item),
+ derived
+ )
+ );
+ }
+
+ // Turn block into typeset for parameter at current index.
+ // Leaves VAL_TYPESET_SYM as-is.
+ //
+ REBSPC *derived = Derive_Specifier(VAL_SPECIFIER(spec), item);
+ Update_Typeset_Bits_Core(
+ typeset,
+ VAL_ARRAY_HEAD(item),
+ derived
+ );
+
+ // Refinements and refinement arguments cannot be specified as
+ // . Although refinement arguments may be void, they are
+ // not "passed in" that way...the refinement is inactive.
+ //
+ if (refinement_seen) {
+ if (TYPE_CHECK(typeset, REB_MAX_VOID))
+ fail (Error_Refinement_Arg_Opt_Raw());
+ }
+
+
+ // A hard quote can only get a void if it is an , and that
+ // is not reflected in the typeset but in TYPESET_FLAG_ENDABLE
+ //
+ if (VAL_PARAM_CLASS(typeset) == PARAM_CLASS_HARD_QUOTE) {
+ if (TYPE_CHECK(typeset, REB_MAX_VOID)) {
+ DECLARE_LOCAL (param_name);
+ Init_Word(param_name, VAL_PARAM_SPELLING(typeset));
+ fail (Error_Hard_Quote_Void_Raw(param_name));
+ }
+ }
+
+ has_types = TRUE;
+ continue;
+ }
+
+ //=//// ANY-WORD! PARAMETERS THEMSELVES (MAKE TYPESETS w/SYMBOL) //////=//
+
+ if (!ANY_WORD(item))
+ fail (Error_Bad_Func_Def_Core(item, VAL_SPECIFIER(spec)));
+
+ // !!! If you say [ x /foo y] the terminates and a
+ // refinement is started. Same w/. Is this a good idea?
+ // Note that historically, help hides any refinements that appear
+ // behind a /local, but this feature has no parallel in Ren-C.
+ //
+ if (mode != SPEC_MODE_NORMAL) {
+ if (IS_REFINEMENT(item)) {
+ mode = SPEC_MODE_NORMAL;
+ }
+ else if (!IS_WORD(item) && !IS_SET_WORD(item))
+ fail (Error_Bad_Func_Def_Core(item, VAL_SPECIFIER(spec)));
+ }
+
+ REBSTR *canon = VAL_WORD_CANON(item);
+
+ // In rhythm of TYPESET! BLOCK! STRING! we want to be on a string spot
+ // at the time of the push of each new typeset.
+ //
+ if (IS_TYPESET(DS_TOP))
+ DS_PUSH(EMPTY_BLOCK);
+ if (IS_BLOCK(DS_TOP))
+ DS_PUSH(EMPTY_STRING);
+ assert(IS_STRING(DS_TOP));
+
+ // By default allow "all datatypes but function and void". Note that
+ // since void isn't a "datatype" the use of the REB_MAX_VOID bit is for
+ // expedience. Also that there are two senses of void signal...the
+ // typeset REB_MAX_VOID represents sense, not the sense,
+ // which is encoded by TYPESET_FLAG_ENDABLE.
+ //
+ // We do not canonize the saved symbol in the paramlist, see #2258.
+ //
+ DS_PUSH_TRASH;
+ REBVAL *typeset = DS_TOP; // volatile if you DS_PUSH!
+ Init_Typeset(
+ typeset,
+ (flags & MKF_ANY_VALUE)
+ ? ALL_64
+ : ALL_64 & ~(FLAGIT_KIND(REB_MAX_VOID) | FLAGIT_KIND(REB_FUNCTION)),
+ VAL_WORD_SPELLING(item)
+ );
+
+ // All these would cancel a definitional return (leave has same idea):
+ //
+ // func [return [integer!]]
+ // func [/refinement return]
+ // func [ return]
+ // func [ return]
+ //
+ // ...although `return:` is explicitly tolerated ATM for compatibility
+ // (despite violating the "pure locals are NULL" premise)
+ //
+ if (STR_SYMBOL(canon) == SYM_RETURN && NOT(flags & MKF_LEAVE)) {
+ assert(definitional_return_dsp == 0);
+ if (IS_SET_WORD(item))
+ definitional_return_dsp = DSP; // RETURN: explicitly tolerated
+ else
+ flags &= ~(MKF_RETURN | MKF_FAKE_RETURN);
+ }
+ else if (
+ STR_SYMBOL(canon) == SYM_LEAVE
+ && NOT(flags & (MKF_RETURN | MKF_FAKE_RETURN))
+ ) {
+ assert(definitional_leave_dsp == 0);
+ if (IS_SET_WORD(item))
+ definitional_leave_dsp = DSP; // LEAVE: explicitly tolerated
+ else
+ flags &= ~MKF_LEAVE;
+ }
+
+ if (mode == SPEC_MODE_WITH && !IS_SET_WORD(item)) {
+ //
+ // Because FUNC does not do any locals gathering by default, the
+ // main purpose of is for instructing it not to do the
+ // definitional returns. However, it also makes changing between
+ // FUNC and FUNCTION more fluid.
+ //
+ // !!! If you write something like `func [x x] [...]` that
+ // should be sanity checked with an error...TBD.
+ //
+ DS_DROP; // forge the typeset, used in `definitional_return` case
+ continue;
+ }
+
+ switch (VAL_TYPE(item)) {
+ case REB_WORD:
+ assert(mode != SPEC_MODE_WITH); // should have continued...
+ INIT_VAL_PARAM_CLASS(
+ typeset,
+ (mode == SPEC_MODE_LOCAL)
+ ? PARAM_CLASS_LOCAL
+ : PARAM_CLASS_NORMAL
+ );
+ break;
+
+ case REB_GET_WORD:
+ assert(mode == SPEC_MODE_NORMAL);
+ INIT_VAL_PARAM_CLASS(typeset, PARAM_CLASS_HARD_QUOTE);
+ break;
+
+ case REB_LIT_WORD:
+ assert(mode == SPEC_MODE_NORMAL);
+ INIT_VAL_PARAM_CLASS(typeset, PARAM_CLASS_SOFT_QUOTE);
+ break;
+
+ case REB_REFINEMENT:
+ refinement_seen = TRUE;
+ INIT_VAL_PARAM_CLASS(typeset, PARAM_CLASS_REFINEMENT);
+
+ // !!! The typeset bits of a refinement are not currently used.
+ // They are checked for TRUE or FALSE but this is done literally
+ // by the code. This means that every refinement has some spare
+ // bits available in it for another purpose.
+ break;
+
+ case REB_SET_WORD:
+ // tolerate as-is if in or mode...
+ INIT_VAL_PARAM_CLASS(typeset, PARAM_CLASS_LOCAL);
+ //
+ // !!! Typeset bits of pure locals also not currently used,
+ // though definitional return should be using it for the return
+ // type of the function.
+ //
+ break;
+
+ case REB_ISSUE:
+ //
+ // !!! Because of their role in the preprocessor in Red, and a
+ // likely need for a similar behavior in Rebol, ISSUE! might not
+ // be the ideal choice to mark tight parameters.
+ //
+ assert(mode == SPEC_MODE_NORMAL);
+ INIT_VAL_PARAM_CLASS(typeset, PARAM_CLASS_TIGHT);
+ break;
+
+ default:
+ fail (Error_Bad_Func_Def_Core(item, VAL_SPECIFIER(spec)));
+ }
+
+ // !!! This is a lame way of setting the durability, because it means
+ // that there's no way a user with just `make function!` could do it.
+ // However, it's a step closer to the solution and eliminating the
+ // FUNCTION!/CLOSURE! distinction.
+ //
+ if (durable)
+ SET_VAL_FLAG(typeset, TYPESET_FLAG_DURABLE);
+ }
+
+ Drop_Frame(f);
+
+ // Go ahead and flesh out the TYPESET! BLOCK! STRING! triples.
+ //
+ if (IS_TYPESET(DS_TOP))
+ DS_PUSH(EMPTY_BLOCK);
+ if (IS_BLOCK(DS_TOP))
+ DS_PUSH(EMPTY_STRING);
+ assert((DSP - dsp_orig) % 3 == 0); // must be a multiple of 3
+
+ // Definitional RETURN and LEAVE slots must have their argument values
+ // fulfilled with FUNCTION! values specific to the function being called
+ // on *every instantiation*. They are marked with special parameter
+ // classes to avoid needing to separately do canon comparison of their
+ // symbols to find them. In addition, since RETURN's typeset holds
+ // types that need to be checked at the end of the function run, it
+ // is moved to a predictable location: last slot of the paramlist.
+ //
+ // Note: Trying to take advantage of the "predictable first position"
+ // by swapping is not legal, as the first argument's position matters
+ // in the ordinary arity of calling.
+
+ if (flags & MKF_LEAVE) {
+ if (definitional_leave_dsp == 0) { // no LEAVE: pure local explicit
+ REBSTR *canon_leave = Canon(SYM_LEAVE);
+
+ DS_PUSH_TRASH;
+ Init_Typeset(DS_TOP, FLAGIT_KIND(REB_MAX_VOID), canon_leave);
+ INIT_VAL_PARAM_CLASS(DS_TOP, PARAM_CLASS_LEAVE);
+ definitional_leave_dsp = DSP;
+
+ DS_PUSH(EMPTY_BLOCK);
+ DS_PUSH(EMPTY_STRING);
+ }
+ else {
+ REBVAL *definitional_leave = DS_AT(definitional_leave_dsp);
+ assert(VAL_PARAM_CLASS(definitional_leave) == PARAM_CLASS_LOCAL);
+ INIT_VAL_PARAM_CLASS(definitional_leave, PARAM_CLASS_LEAVE);
+ }
+ header_bits |= FUNC_FLAG_LEAVE;
+ }
+
+ if (flags & MKF_RETURN) {
+ if (definitional_return_dsp == 0) { // no RETURN: pure local explicit
+ REBSTR *canon_return = Canon(SYM_RETURN);
+
+ // !!! The current experiment for dealing with default type
+ // checking on definitional returns is to be somewhat restrictive
+ // if there are *any* documentation notes or typesets on the
+ // function. Hence:
+ //
+ // >> foo: func [x] [] ;-- no error, void return allowed
+ // >> foo: func [{a} x] [] ;-- will error, can't return void
+ //
+ // The idea is that if any effort has been expended on documenting
+ // the interface at all, it has some "public" component...so
+ // problems like leaking arbitrary values (vs. using PROC) are
+ // more likely to be relevant. Whereas no effort indicates a
+ // likely more ad-hoc experimentation.
+ //
+ // (A "strict" mode, selectable per module, could control this and
+ // other settings. But the goal is to attempt to define something
+ // that is as broadly usable as possible.)
+ //
+ DS_PUSH_TRASH;
+ Init_Typeset(
+ DS_TOP,
+ (flags & MKF_ANY_VALUE)
+ || NOT(has_description || has_types || has_notes)
+ ? ALL_64
+ : ALL_64 & ~(
+ FLAGIT_KIND(REB_MAX_VOID) | FLAGIT_KIND(REB_FUNCTION)
+ ),
+ canon_return
+ );
+ INIT_VAL_PARAM_CLASS(DS_TOP, PARAM_CLASS_RETURN);
+ definitional_return_dsp = DSP;
+
+ DS_PUSH(EMPTY_BLOCK);
+ DS_PUSH(EMPTY_STRING);
+ // no need to move it--it's already at the tail position
+ }
+ else {
+ REBVAL *definitional_return = DS_AT(definitional_return_dsp);
+ assert(VAL_PARAM_CLASS(definitional_return) == PARAM_CLASS_LOCAL);
+ INIT_VAL_PARAM_CLASS(definitional_return, PARAM_CLASS_RETURN);
+
+ // definitional_return handled specially when paramlist copied
+ // off of the stack...
+ }
+ header_bits |= FUNC_FLAG_RETURN;
+ }
+
+ // Slots, which is length +1 (includes the rootvar or rootparam)
+ //
+ REBCNT num_slots = (DSP - dsp_orig) / 3;
+
+ // If we pushed a typeset for a return and it's a native, it actually
+ // doesn't want a RETURN: key in the frame in release builds. We'll omit
+ // from the copy.
+ //
+ if (definitional_return_dsp != 0 && (flags & MKF_FAKE_RETURN))
+ --num_slots;
+
+ // There should be no more pushes past this point, so a stable pointer
+ // into the stack for the definitional return can be found.
+ //
+ REBVAL *definitional_return =
+ definitional_return_dsp == 0
+ ? NULL
+ : DS_AT(definitional_return_dsp);
+
+ // Must make the function "paramlist" even if "empty", for identity.
+ // Also make sure the parameter list does not expand.
+ //
+ // !!! Expanding the parameter list might be part of an advanced feature
+ // under the hood in the future, but users should not themselves grow
+ // function frames by appending to them.
+ //
+ REBARR *paramlist = Make_Array_Core(
+ num_slots,
+ ARRAY_FLAG_PARAMLIST | SERIES_FLAG_FIXED_SIZE
+ );
+
+ if (TRUE) {
+ RELVAL *dest = ARR_HEAD(paramlist); // canon function value
+ VAL_RESET_HEADER(dest, REB_FUNCTION);
+ SET_VAL_FLAGS(dest, header_bits);
+ dest->payload.function.paramlist = paramlist;
+ dest->extra.binding = NULL;
+ ++dest;
+
+ // We want to check for duplicates and a Binder can be used for that
+ // purpose--but note that a fail() cannot happen while binders are
+ // in effect UNLESS the BUF_COLLECT contains information to undo it!
+ // There's no BUF_COLLECT here, so don't fail while binder in effect.
+ //
+ // (This is why we wait until the parameter list gathering process
+ // is over to do the duplicate checks--it can fail.)
+ //
+ struct Reb_Binder binder;
+ INIT_BINDER(&binder);
+
+ REBSTR *duplicate = NULL;
+
+ REBVAL *src = DS_AT(dsp_orig + 1) + 3;
+
+ for (; src <= DS_TOP; src += 3) {
+ assert(IS_TYPESET(src));
+ if (!Try_Add_Binder_Index(&binder, VAL_PARAM_CANON(src), 1020))
+ duplicate = VAL_PARAM_SPELLING(src);
+
+ if (definitional_return && src == definitional_return)
+ continue;
+
+ Move_Value(dest, src);
+ ++dest;
+ }
+
+ if (definitional_return) {
+ if (flags & MKF_FAKE_RETURN) {
+ //
+ // This is where you don't actually want a RETURN key in the
+ // function frame (e.g. because it's native code and would be
+ // wasteful and unused).
+ //
+ // !!! The debug build uses real returns, not fake ones.
+ // This means actions and natives have an extra slot.
+ //
+ }
+ else {
+ assert(flags & MKF_RETURN);
+ *dest = *definitional_return;
+ ++dest;
+ }
+ }
+
+ // Must remove binder indexes for all words, even if about to fail
+ //
+ src = DS_AT(dsp_orig + 1) + 3;
+ for (; src <= DS_TOP; src += 3, ++dest) {
+ if (!Try_Remove_Binder_Index(&binder, VAL_PARAM_CANON(src)))
+ assert(duplicate != NULL);
+ }
+
+ SHUTDOWN_BINDER(&binder);
+
+ if (duplicate != NULL) {
+ DECLARE_LOCAL (word);
+ Init_Word(word, duplicate);
+ fail (Error_Dup_Vars_Raw(word));
+ }
+
+ TERM_ARRAY_LEN(paramlist, num_slots);
+ MANAGE_ARRAY(paramlist);
+ }
+
+ //=///////////////////////////////////////////////////////////////////=//
+ //
+ // BUILD META INFORMATION OBJECT (IF NEEDED)
+ //
+ //=///////////////////////////////////////////////////////////////////=//
+
+ // !!! See notes on FUNCTION-META in %sysobj.r
+
+ REBCTX *meta = NULL;
+
+ if (has_description || has_types || has_notes) {
+ meta = Copy_Context_Shallow(VAL_CONTEXT(ROOT_FUNCTION_META));
+ MANAGE_ARRAY(CTX_VARLIST(meta));
+ }
+
+ SER(paramlist)->link.meta = meta;
+
+ // If a description string was gathered, it's sitting in the first string
+ // slot, the third cell we pushed onto the stack. Extract it if so.
+ //
+ if (has_description) {
+ assert(IS_STRING(DS_AT(dsp_orig + 3)));
+ Move_Value(
+ CTX_VAR(meta, STD_FUNCTION_META_DESCRIPTION),
+ DS_AT(dsp_orig + 3)
+ );
+ }
+ else if (meta)
+ Init_Void(CTX_VAR(meta, STD_FUNCTION_META_DESCRIPTION));
+
+ // Only make `parameter-types` if there were blocks in the spec
+ //
+ if (NOT(has_types)) {
+ if (meta) {
+ Init_Void(CTX_VAR(meta, STD_FUNCTION_META_PARAMETER_TYPES));
+ Init_Void(CTX_VAR(meta, STD_FUNCTION_META_RETURN_TYPE));
+ }
+ }
+ else {
+ REBARR *types_varlist = Make_Array_Core(
+ num_slots, ARRAY_FLAG_VARLIST
+ );
+ INIT_CTX_KEYLIST_SHARED(CTX(types_varlist), paramlist);
+
+ REBVAL *dest = SINK(ARR_HEAD(types_varlist)); // "rootvar"
+ VAL_RESET_HEADER(dest, REB_FRAME);
+ dest->payload.any_context.varlist = types_varlist; // canon FRAME!
+ dest->payload.any_context.phase = AS_FUNC(paramlist);
+ dest->extra.binding = NULL;
+ ++dest;
+
+ REBVAL *src = DS_AT(dsp_orig + 2);
+ src += 3;
+ for (; src <= DS_TOP; src += 3) {
+ assert(IS_BLOCK(src));
+ if (definitional_return && src == definitional_return + 1)
+ continue;
+
+ if (VAL_ARRAY_LEN_AT(src) == 0)
+ Init_Void(dest);
+ else
+ Move_Value(dest, src);
+ ++dest;
+ }
+
+ if (definitional_return) {
+ //
+ // We put the return note in the top-level meta information, not
+ // on the local itself (the "return-ness" is a distinct property
+ // of the function from what word is used for RETURN:, and it
+ // is possible to use the word RETURN for a local or refinement
+ // argument while having nothing to do with the exit value of
+ // the function.)
+ //
+ if (VAL_ARRAY_LEN_AT(definitional_return + 1) == 0)
+ Init_Void(CTX_VAR(meta, STD_FUNCTION_META_RETURN_TYPE));
+ else {
+ Move_Value(
+ CTX_VAR(meta, STD_FUNCTION_META_RETURN_TYPE),
+ &definitional_return[1]
+ );
+ }
+
+ if (NOT(flags & MKF_FAKE_RETURN)) {
+ Init_Void(dest); // clear the local RETURN: var's description
+ ++dest;
+ }
+ }
+
+ TERM_ARRAY_LEN(types_varlist, num_slots);
+ MANAGE_ARRAY(types_varlist);
+
+ Init_Any_Context(
+ CTX_VAR(meta, STD_FUNCTION_META_PARAMETER_TYPES),
+ REB_FRAME,
+ CTX(types_varlist)
+ );
+ }
+
+ // Only make `parameter-notes` if there were strings (besides description)
+ //
+ if (NOT(has_notes)) {
+ if (meta) {
+ Init_Void(CTX_VAR(meta, STD_FUNCTION_META_PARAMETER_NOTES));
+ Init_Void(CTX_VAR(meta, STD_FUNCTION_META_RETURN_NOTE));
+ }
+ }
+ else {
+ REBARR *notes_varlist = Make_Array_Core(
+ num_slots, ARRAY_FLAG_VARLIST
+ );
+ INIT_CTX_KEYLIST_SHARED(CTX(notes_varlist), paramlist);
+
+ REBVAL *dest = SINK(ARR_HEAD(notes_varlist)); // "rootvar"
+ VAL_RESET_HEADER(dest, REB_FRAME);
+ dest->payload.any_context.varlist = notes_varlist; // canon FRAME!
+ dest->payload.any_context.phase = AS_FUNC(paramlist);
+ dest->extra.binding = NULL;
+ ++dest;
+
+ REBVAL *src = DS_AT(dsp_orig + 3);
+ src += 3;
+ for (; src <= DS_TOP; src += 3) {
+ assert(IS_STRING(src));
+ if (definitional_return && src == definitional_return + 2)
+ continue;
+
+ if (SER_LEN(VAL_SERIES(src)) == 0)
+ Init_Void(dest);
+ else
+ Move_Value(dest, src);
+ ++dest;
+ }
+
+ if (definitional_return) {
+ //
+ // See remarks on the return type--the RETURN is documented in
+ // the top-level META-OF, not the "incidentally" named RETURN
+ // parameter in the list
+ //
+ if (SER_LEN(VAL_SERIES(definitional_return + 2)) == 0)
+ Init_Void(CTX_VAR(meta, STD_FUNCTION_META_RETURN_NOTE));
+ else {
+ Move_Value(
+ CTX_VAR(meta, STD_FUNCTION_META_RETURN_NOTE),
+ &definitional_return[2]
+ );
+ }
+
+ if (NOT(flags & MKF_FAKE_RETURN)) {
+ Init_Void(dest);
+ ++dest;
+ }
+ }
+
+ TERM_ARRAY_LEN(notes_varlist, num_slots);
+ MANAGE_ARRAY(notes_varlist);
+
+ Init_Any_Context(
+ CTX_VAR(meta, STD_FUNCTION_META_PARAMETER_NOTES),
+ REB_FRAME,
+ CTX(notes_varlist)
+ );
+ }
+
+ // With all the values extracted from stack to array, restore stack pointer
+ //
+ DS_DROP_TO(dsp_orig);
+
+ return paramlist;
+}
+
+
+
+//
+// Find_Param_Index: C
+//
+// Find function param word in function "frame".
+//
+// !!! This is semi-redundant with similar functions for Find_Word_In_Array
+// and key finding for objects, review...
+//
+REBCNT Find_Param_Index(REBARR *paramlist, REBSTR *spelling)
+{
+ REBSTR *canon = STR_CANON(spelling); // don't recalculate each time
+
+ RELVAL *param = ARR_AT(paramlist, 1);
+ REBCNT len = ARR_LEN(paramlist);
+
+ REBCNT n;
+ for (n = 1; n < len; ++n, ++param) {
+ if (
+ spelling == VAL_PARAM_SPELLING(param)
+ || canon == VAL_PARAM_CANON(param)
+ ) {
+ return n;
+ }
+ }
+
+ return 0;
+}
+
+
+//
+// Make_Function: C
+//
+// Create an archetypal form of a function, given C code implementing a
+// dispatcher that will be called by Do_Core. Dispatchers are of the form:
+//
+// REB_R Dispatcher(REBFRM *f) {...}
+//
+// The REBFUN returned is "archetypal" because individual REBVALs which hold
+// the same REBFUN may differ in a per-REBVAL piece of "instance" data.
+// (This is how one RETURN is distinguished from another--the instance
+// data stored in the REBVAL identifies the pointer of the FRAME! to exit).
+//
+// Functions have an associated REBVAL-sized cell of data, accessible via
+// FUNC_BODY(). This is where they can store information that will be
+// available when the dispatcher is called. Despite being called "body", it
+// doesn't have to be an array--it can be any REBVAL.
+//
+REBFUN *Make_Function(
+ REBARR *paramlist,
+ REBNAT dispatcher, // native C function called by Do_Core
+ REBFUN *opt_underlying, // function which has size of actual frame to push
+ REBCTX *opt_exemplar // specialization (or inherit from underlying)
+) {
+ ASSERT_ARRAY_MANAGED(paramlist);
+
+ RELVAL *rootparam = ARR_HEAD(paramlist);
+ assert(IS_FUNCTION(rootparam)); // !!! body not fully formed...
+ assert(rootparam->payload.function.paramlist == paramlist);
+ assert(rootparam->extra.binding == NULL); // archetype
+
+ // Precalculate FUNC_FLAG_DEFERS_LOOKBACK
+ //
+ // Note that this flag is only relevant for *un-refined-calls*. There
+ // are no lookback function calls via PATH! and brancher dispatch is done
+ // from a raw function value. HOWEVER: specialization does come into play
+ // because it may change what the first "real" argument is. But again,
+ // we're only interested in specialization's removal of *non-refinement*
+ // arguments. Looking at the surface interface is good enough--that is
+ // what will be relevant after the specializations are accounted for.
+
+ REBVAL *param = KNOWN(rootparam) + 1;
+ for (; NOT_END(param); ++param) {
+ switch (VAL_PARAM_CLASS(param)) {
+ case PARAM_CLASS_LOCAL:
+ case PARAM_CLASS_RETURN:
+ case PARAM_CLASS_LEAVE:
+ break; // skip.
+
+ case PARAM_CLASS_REFINEMENT:
+ //
+ // hit before hitting any basic args, so not a brancher, and not
+ // a candidate for deferring lookback arguments.
+ //
+ goto done_caching;
+
+ case PARAM_CLASS_NORMAL:
+ //
+ // First argument is not tight, cache flag to report it.
+ //
+ SET_VAL_FLAG(rootparam, FUNC_FLAG_DEFERS_LOOKBACK);
+ goto done_caching;
+
+ // Otherwise, at least one argument but not one that requires the
+ // deferring of lookback.
+
+ case PARAM_CLASS_TIGHT:
+ //
+ // First argument is tight, no flag needed
+ //
+ goto done_caching;
+
+ case PARAM_CLASS_HARD_QUOTE:
+ case PARAM_CLASS_SOFT_QUOTE:
+ SET_VAL_FLAG(rootparam, FUNC_FLAG_QUOTES_FIRST_ARG);
+ goto done_caching;
+
+ default:
+ assert(FALSE);
+ }
+ }
+
+done_caching:;
+
+ // The "body" for a function can be any REBVAL. It doesn't have to be
+ // a block--it's anything that the dispatcher might wish to interpret.
+
+ REBARR *body_holder = Alloc_Singular_Array();
+ Init_Blank(ARR_HEAD(body_holder));
+ MANAGE_ARRAY(body_holder);
+
+ rootparam->payload.function.body_holder = body_holder;
+
+ // The C function pointer is stored inside the REBSER node for the body.
+ // Hence there's no need for a `switch` on a function class in Do_Core,
+ // Having a level of indirection from the REBVAL bits themself also
+ // facilitates the "Hijacker" to change multiple REBVALs behavior.
+
+ SER(body_holder)->misc.dispatcher = dispatcher;
+
+ // When this function is run, it needs to push a stack frame with a
+ // certain number of arguments, and do type checking and parameter class
+ // conventions based on that. This frame must be compatible with the
+ // number of arguments expected by the underlying function, and must not
+ // allow any types to be passed to that underlying function it is not
+ // expecting (e.g. natives written to only take INTEGER! may crash if
+ // they get BLOCK!). But beyond those constraints, the outer function
+ // may have new parameter classes through a "facade". This facade is
+ // initially just the underlying function's paramlist, but may change.
+ //
+ if (opt_underlying) {
+ SER(paramlist)->misc.facade =
+ SER(FUNC_PARAMLIST(opt_underlying))->misc.facade;
+ }
+ else {
+ // To avoid NULL checking when a function is called and looking for
+ // the underlying function, the functions own pointer in if needed
+ //
+ SER(paramlist)->misc.facade = paramlist;
+ }
+
+ if (opt_exemplar) {
+ assert(
+ CTX_LEN(opt_exemplar)
+ == ARR_LEN(SER(paramlist)->misc.facade) - 1
+ );
+
+ SER(body_holder)->link.exemplar = opt_exemplar;
+ }
+ else if (opt_underlying)
+ SER(body_holder)->link.exemplar =
+ SER(
+ FUNC_VALUE(opt_underlying)->payload.function.body_holder
+ )->link.exemplar;
+ else
+ SER(body_holder)->link.exemplar = NULL;
+
+ // The meta information may already be initialized, since the native
+ // version of paramlist construction sets up the FUNCTION-META information
+ // used by HELP. If so, it must be a valid REBCTX*. Otherwise NULL.
+ //
+ assert(
+ SER(paramlist)->link.meta == NULL
+ || GET_SER_FLAG(
+ CTX_VARLIST(SER(paramlist)->link.meta), ARRAY_FLAG_VARLIST
+ )
+ );
+
+ // Note: used to set the keys of natives as read-only so that the debugger
+ // couldn't manipulate the values in a native frame out from under it,
+ // potentially crashing C code (vs. just causing userspace code to
+ // error). That protection is now done to the frame series on reification
+ // in order to be able to MAKE FRAME! and reuse the native's paramlist.
+
+ assert(NOT_SER_FLAG(paramlist, SERIES_FLAG_FILE_LINE));
+ assert(NOT_SER_FLAG(body_holder, SERIES_FLAG_FILE_LINE));
+
+ return AS_FUNC(paramlist);
+}
+
+
+//
+// Make_Expired_Frame_Ctx_Managed: C
+//
+// Function bodies contain relative words and relative arrays. Arrays from
+// this relativized body may only be put into a specified REBVAL once they
+// have been combined with a frame.
+//
+// Reflection asks for function body data, when no instance is called. Hence
+// a REBVAL must be produced somehow. If the body is being copied, then the
+// option exists to convert all the references to unbound...but this isn't
+// representative of the actual connections in the body.
+//
+// There could be an additional "archetype" state for the relative binding
+// machinery. But making a one-off expired frame is an inexpensive option,
+// at least while the specific binding is coming online.
+//
+// !!! To be written...was started for MOLD of function, and realized it's
+// really only needed for the BODY-OF reflector that gives back REBVAL*
+//
+REBCTX *Make_Expired_Frame_Ctx_Managed(REBFUN *func)
+{
+ REBARR *varlist = Alloc_Singular_Array_Core(ARRAY_FLAG_VARLIST);
+ SET_SER_INFO(varlist, CONTEXT_INFO_STACK);
+ Init_Blank(ARR_HEAD(varlist));
+ MANAGE_ARRAY(varlist);
+
+ SET_SER_INFO(varlist, SERIES_INFO_INACCESSIBLE);
+
+ REBCTX *expired = CTX(varlist);
+
+ INIT_CTX_KEYLIST_SHARED(expired, FUNC_PARAMLIST(func));
+
+ CTX_VALUE(expired)->payload.any_context.varlist = varlist;
+
+ // A NULL stored by the misc field of a REB_FRAME context's varlist which
+ // indicates that the frame has finished running. If it is stack-based,
+ // then that also means the data values are unavailable.
+ //
+ SER(varlist)->misc.f = NULL;
+
+ return expired;
}
-/***********************************************************************
-**
-*/ REBSER *Check_Func_Spec(REBSER *block)
-/*
-** Check function spec of the form:
-**
-** ["description" arg "notes" [type! type2! ...] /ref ...]
-**
-** Throw an error for invalid values.
-**
-***********************************************************************/
+//
+// Get_Maybe_Fake_Func_Body: C
+//
+// The FUNC_FLAG_LEAVE and FUNC_FLAG_RETURN tricks used for definitional
+// scoping make it seem like a generator authored more code in the function's
+// body...but the code isn't *actually* there and an optimized internal
+// trick is used.
+//
+// If the body is fake, it needs to be freed by the caller with
+// Free_Series. This means that the body must currently be shallow
+// copied, and the splicing slot must be in the topmost series.
+//
+REBARR *Get_Maybe_Fake_Func_Body(REBOOL *is_fake, const REBVAL *func)
{
- REBVAL *blk;
- REBSER *words;
- REBINT n = 0;
- REBVAL *value;
-
- blk = BLK_HEAD(block);
- words = Collect_Frame(BIND_ALL | BIND_NO_DUP | BIND_NO_SELF, 0, blk);
-
- // !!! needs more checks
- for (; NOT_END(blk); blk++) {
- switch (VAL_TYPE(blk)) {
- case REB_BLOCK:
- // Skip the SPEC block as an arg. Use other blocks as datatypes:
- if (n > 0) Make_Typeset(VAL_BLK(blk), BLK_SKIP(words, n), 0);
- break;
- case REB_STRING:
- case REB_INTEGER: // special case used by datatype test actions
- break;
- case REB_WORD:
- case REB_GET_WORD:
- case REB_LIT_WORD:
- n++;
- break;
- case REB_REFINEMENT:
- // Refinement only allows logic! and none! for its datatype:
- n++;
- value = BLK_SKIP(words, n);
- VAL_TYPESET(value) = (TYPESET(REB_LOGIC) | TYPESET(REB_NONE));
- break;
- case REB_SET_WORD:
- default:
- Trap1(RE_BAD_FUNC_DEF, blk);
- }
- }
-
- return words; //Create_Frame(words, 0);
+ REBARR *fake_body;
+ REBVAL *example = NULL;
+
+ assert(IS_FUNCTION(func) && IS_FUNCTION_INTERPRETED(func));
+
+ REBCNT body_index;
+ if (GET_VAL_FLAG(func, FUNC_FLAG_RETURN)) {
+ if (GET_VAL_FLAG(func, FUNC_FLAG_LEAVE)) {
+ example = Get_System(SYS_STANDARD, STD_FUNC_BODY);
+ body_index = 8;
+ }
+ else {
+ example = Get_System(SYS_STANDARD, STD_FUNC_NO_LEAVE_BODY);
+ body_index = 4;
+ }
+ *is_fake = TRUE;
+ }
+ else if (GET_VAL_FLAG(func, FUNC_FLAG_LEAVE)) {
+ example = Get_System(SYS_STANDARD, STD_PROC_BODY);
+ body_index = 4;
+ *is_fake = TRUE;
+ }
+ else {
+ *is_fake = FALSE;
+ return VAL_ARRAY(VAL_FUNC_BODY(func));
+ }
+
+ // See comments in sysobj.r on standard/func-body and standard/proc-body
+ //
+ fake_body = Copy_Array_Shallow(VAL_ARRAY(example), VAL_SPECIFIER(example));
+
+ // Index 5 (or 4 in zero-based C) should be #BODY, a "real" body. Since
+ // the body has relative words and relative arrays and this is not pairing
+ // that with a frame from any specific invocation, the value must be
+ // marked as relative.
+ {
+ RELVAL *slot = ARR_AT(fake_body, body_index); // #BODY
+ assert(IS_ISSUE(slot));
+
+ VAL_RESET_HEADER(slot, REB_GROUP);
+ SET_VAL_FLAGS(slot, VALUE_FLAG_RELATIVE | VALUE_FLAG_LINE);
+ INIT_VAL_ARRAY(slot, VAL_ARRAY(VAL_FUNC_BODY(func)));
+ VAL_INDEX(slot) = 0;
+ INIT_RELATIVE(slot, VAL_FUNC(func));
+ }
+
+ return fake_body;
+}
+
+
+//
+// Make_Interpreted_Function_May_Fail: C
+//
+// This is the support routine behind `MAKE FUNCTION!`, FUNC, and PROC.
+//
+// Ren/C's schematic for the FUNC and PROC generators is *very* different
+// from R3-Alpha, whose definition of FUNC was simply:
+//
+// make function! copy/deep reduce [spec body]
+//
+// Ren/C's `make function!` doesn't need to copy the spec (it does not save
+// it--parameter descriptions are in a meta object). It also copies the body
+// by virtue of the need to relativize it. They also have "definitional
+// return" constructs so that the body introduces RETURN and LEAVE constructs
+// specific to each function invocation, so the body acts more like:
+//
+// return: make function! [
+// [{Returns a value from a function.} value [ any-value!]]
+// [exit/from/with (context-of 'return) :value]
+// ]
+// (body goes here)
+//
+// This pattern addresses "Definitional Return" in a way that does not
+// technically require building RETURN or LEAVE in as a language keyword in
+// any specific form (in the sense that MAKE FUNCTION! does not itself
+// require it, and one can pretend FUNC and PROC don't exist).
+//
+// FUNC and PROC optimize by not internally building or executing the
+// equivalent body, but giving it back from BODY-OF. This is another benefit
+// of making a copy--since the user cannot access the new root, it makes it
+// possible to "lie" about what the body "above" is. This gives FUNC and PROC
+// the edge to pretend to add containing code and simulate its effects, while
+// really only holding onto the body the caller provided.
+//
+// While MAKE FUNCTION! has no RETURN, all functions still have EXIT as a
+// non-definitional alternative. Ren/C adds a /WITH refinement so it can
+// behave equivalently to old-non-definitonal return. There is even a way to
+// identify specific points up the call stack to exit from via EXIT/FROM, so
+// not having definitional return has several alternate options for generators
+// that wish to use them.
+//
+REBFUN *Make_Interpreted_Function_May_Fail(
+ const REBVAL *spec,
+ const REBVAL *code,
+ REBFLGS mkf_flags // MKF_RETURN, MKF_LEAVE, etc.
+) {
+ assert(IS_BLOCK(spec));
+ assert(IS_BLOCK(code));
+
+ REBFUN *fun = Make_Function(
+ Make_Paramlist_Managed_May_Fail(spec, mkf_flags),
+ &Noop_Dispatcher, // will be overwritten if non-NULL body
+ NULL, // no underlying function, this is fundamental
+ NULL // not providing a specialization
+ );
+
+ // We look at the *actual* function flags; e.g. the person may have used
+ // the FUNC generator (with MKF_RETURN) but then named a parameter RETURN
+ // which overrides it, so the value won't have FUNC_FLAG_RETURN.
+ //
+ REBVAL *value = FUNC_VALUE(fun);
+
+ REBARR *body_array;
+ if (VAL_ARRAY_LEN_AT(code) == 0) {
+ if (GET_VAL_FLAG(value, FUNC_FLAG_RETURN)) {
+ //
+ // Since we're bypassing type checking in the dispatcher for
+ // speed, we need to make sure that the return type allows void
+ // (which is all the Noop dispatcher will return). If not, we
+ // don't want to fail here (it would reveal the optimization)...
+ // just fall back on the Returner_Dispatcher instead.
+ //
+ REBVAL *typeset = FUNC_PARAM(fun, FUNC_NUM_PARAMS(fun));
+ assert(VAL_PARAM_SYM(typeset) == SYM_RETURN);
+ if (!TYPE_CHECK(typeset, REB_MAX_VOID))
+ FUNC_DISPATCHER(fun) = &Returner_Dispatcher;
+ }
+
+ body_array = EMPTY_ARRAY; // just reuse empty array if empty, no copy
+ }
+ else {
+ // Body is not empty, so we need to pick the right dispatcher based
+ // on how the output value is to be handled.
+ //
+ if (GET_VAL_FLAG(value, FUNC_FLAG_RETURN))
+ FUNC_DISPATCHER(fun) = &Returner_Dispatcher; // type checks f->out
+ else if (GET_VAL_FLAG(value, FUNC_FLAG_LEAVE))
+ FUNC_DISPATCHER(fun) = &Voider_Dispatcher; // forces f->out void
+ else
+ FUNC_DISPATCHER(fun) = &Unchecked_Dispatcher; // leaves f->out
+
+ // We need to copy the body in order to relativize its references to
+ // args and locals to refer to the parameter list. Future work
+ // might be able to "image" the bindings virtually, and not require
+ // this to be copied if the input code is read-only.
+ //
+ body_array = Copy_And_Bind_Relative_Deep_Managed(
+ code,
+ FUNC_PARAMLIST(fun),
+ TS_ANY_WORD
+ );
+ }
+
+ // We need to do a raw initialization of this block RELVAL because it is
+ // relative to a function. (Init_Block assumes all specific values)
+ //
+ RELVAL *body = FUNC_BODY(fun);
+ VAL_RESET_HEADER_EXTRA(body, REB_BLOCK, VALUE_FLAG_RELATIVE);
+ INIT_VAL_ARRAY(body, body_array);
+ VAL_INDEX(body) = 0;
+ INIT_RELATIVE(body, fun);
+
+#if !defined(NDEBUG)
+ //
+ // If FUNC or MAKE FUNCTION! are being invoked from an array of code that
+ // has been flagged "legacy" (e.g. the body of a function created after
+ // `do ` has been run) then mark the function with the setting
+ // to make refinements and args blank instead of FALSE/void...if that
+ // option is on.
+ //
+ if (
+ LEGACY_RUNNING(OPTIONS_REFINEMENTS_BLANK)
+ || GET_SER_INFO(VAL_ARRAY(spec), SERIES_INFO_LEGACY_DEBUG)
+ || GET_SER_INFO(VAL_ARRAY(code), SERIES_INFO_LEGACY_DEBUG)
+ ) {
+ SET_VAL_FLAG(FUNC_VALUE(fun), FUNC_FLAG_LEGACY_DEBUG);
+ }
+#endif
+
+ // All the series inside of a function body are "relatively bound". This
+ // means that there's only one copy of the body, but the series handle
+ // is "viewed" differently based on which call it represents. Though
+ // each of these views compares uniquely, there's only one series behind
+ // it...hence the series must be read only to keep modifying a view
+ // that seems to have one identity but then affecting another.
+ //
+#if defined(NDEBUG)
+ Deep_Freeze_Array(VAL_ARRAY(body));
+#else
+ if (!LEGACY(OPTIONS_UNLOCKED_SOURCE))
+ Deep_Freeze_Array(VAL_ARRAY(body));
+#endif
+
+ return fun;
}
-/***********************************************************************
-**
-*/ void Make_Native(REBVAL *value, REBSER *spec, REBFUN func, REBINT type)
-/*
-***********************************************************************/
+//
+// Make_Frame_For_Function: C
+//
+// This creates a *non-stack-allocated* FRAME!, which can be used in function
+// applications or specializations. It reuses the keylist of the function
+// but makes a new varlist.
+//
+REBCTX *Make_Frame_For_Function(const REBVAL *value) {
+ //
+ // Note that this cannot take just a REBFUN* directly, because definitional
+ // RETURN and LEAVE only have their unique `binding` bits in the REBVAL.
+ //
+ REBFUN *func = VAL_FUNC(value);
+
+ // In order to have the frame survive the call to MAKE and be
+ // returned to the user it can't be stack allocated, because it
+ // would immediately become useless. Allocate dynamically.
+ //
+ REBARR *varlist = Make_Array_Core(
+ ARR_LEN(FUNC_PARAMLIST(func)),
+ ARRAY_FLAG_VARLIST | SERIES_FLAG_FIXED_SIZE
+ );
+
+ // Fill in the rootvar information for the context canon REBVAL
+ //
+ REBVAL *var = SINK(ARR_HEAD(varlist));
+ VAL_RESET_HEADER(var, REB_FRAME);
+ var->payload.any_context.varlist = varlist;
+ var->extra.binding = value->extra.binding;
+ var->payload.any_context.phase = func;
+
+ // We can reuse the paramlist we're given, but note in the case of
+ // definitional RETURN and LEAVE we have to stow the `binding` field
+ // in the context, since the single archetype paramlist does not hold
+ // enough information to know where to return *to*.
+ //
+ INIT_CTX_KEYLIST_SHARED(CTX(varlist), FUNC_PARAMLIST(func));
+ ASSERT_ARRAY_MANAGED(CTX_KEYLIST(CTX(varlist)));
+
+ // The current implementation allows that `do frame` of the result
+ // of a `make frame! :fun` will not make a copy of the frame, but use
+ // its values. See notes in DO of FRAME! regarding this.
+ //
+ SER(varlist)->misc.f = NULL;
+
+ ++var;
+
+ // A FRAME! defaults all args and locals to not being set. If the frame
+ // is then used as the storage for a function specialization, unset
+ // vars indicate *unspecialized* arguments...not ones. (This is
+ // a good argument for not making have meaning that is interesting
+ // to APPLY or SPECIALIZE cases, but to revoke the function's effects.
+ //
+ REBCNT n;
+ for (n = 1; n <= FUNC_NUM_PARAMS(func); ++n, ++var)
+ Init_Void(var);
+
+ TERM_ARRAY_LEN(varlist, ARR_LEN(FUNC_PARAMLIST(func)));
+
+ return CTX(varlist);
+}
+
+
+//
+// Specialize_Function_Throws: C
+//
+// This produces a new REBVAL for a function that specializes another. It
+// uses a FRAME! to do this, where the frame intrinsically stores the
+// reference to the function it is specializing.
+//
+REBOOL Specialize_Function_Throws(
+ REBVAL *out,
+ REBVAL *specializee,
+ REBSTR *opt_specializee_name,
+ REBVAL *block // !!! REVIEW: gets binding modified directly (not copied)
+) {
+ assert(out != specializee);
+
+ REBCTX *exemplar = FUNC_EXEMPLAR(VAL_FUNC(specializee));
+ if (exemplar == NULL) {
+ //
+ // An initial specialization is responsible for making a frame out
+ // of the function's paramlist. Frame vars default void.
+ //
+ REBFUN *underlying = FUNC_UNDERLYING(VAL_FUNC(specializee));
+ exemplar = Make_Frame_For_Function(FUNC_VALUE(underlying));
+ MANAGE_ARRAY(CTX_VARLIST(exemplar));
+ }
+ else {
+ // Specializing a specialization is ultimately just a specialization
+ // of the innermost function being specialized. (Imagine specializing
+ // a specialization of APPEND, to the point where it no longer takes
+ // any parameters. Nevertheless, the frame being stored and invoked
+ // needs to have as many parameters as APPEND has. The frame must be
+ // be built for the code ultimately being called--and specializations
+ // have no code of their own.)
+
+ REBARR *varlist = Copy_Array_Deep_Managed(
+ CTX_VARLIST(exemplar), SPECIFIED
+ );
+ SET_SER_FLAG(varlist, ARRAY_FLAG_VARLIST);
+ INIT_CTX_KEYLIST_SHARED(CTX(varlist), CTX_KEYLIST(exemplar));
+
+ exemplar = CTX(varlist); // okay, now make exemplar our copy
+ CTX_VALUE(exemplar)->payload.any_context.varlist = varlist;
+ }
+
+ // Archetypal frame values can't have exit bindings (would write paramlist)
+ //
+ assert(VAL_BINDING(CTX_VALUE(exemplar)) == NULL);
+
+ // Bind all the SET-WORD! in the body that match params in the frame
+ // into the frame. This means `value: value` can very likely have
+ // `value:` bound for assignments into the frame while `value` refers
+ // to whatever value was in the context the specialization is running
+ // in, but this is likely the more useful behavior. Review.
+ //
+ // !!! This binds the actual arg data, not a copy of it--following
+ // OBJECT!'s lead. However, ordinary functions make a copy of the body
+ // they are passed before rebinding. Rethink.
+ //
+ Bind_Values_Core(
+ VAL_ARRAY_AT(block),
+ exemplar,
+ FLAGIT_KIND(REB_SET_WORD), // types to bind (just set-word!)
+ 0, // types to "add midstream" to binding as we go (nothing)
+ BIND_DEEP
+ );
+
+ // Do the block into scratch space--we ignore the result (unless it is
+ // thrown, in which case it must be returned.)
+ {
+ PUSH_GUARD_ARRAY(CTX_VARLIST(exemplar));
+
+ if (Do_Any_Array_At_Throws(out, block)) {
+ DROP_GUARD_ARRAY(CTX_VARLIST(exemplar));
+ return TRUE;
+ }
+
+ DROP_GUARD_ARRAY(CTX_VARLIST(exemplar));
+ }
+
+ // Generate paramlist by way of the data stack. Push inherited value (to
+ // become the function value afterward), then all the args that remain
+ // unspecialized (indicated by being void... is not supported)
+ //
+ REBDSP dsp_orig = DSP;
+ DS_PUSH(FUNC_VALUE(VAL_FUNC(specializee))); // !!! is inheriting good?
+
+ REBVAL *param = CTX_KEYS_HEAD(exemplar);
+ REBVAL *arg = CTX_VARS_HEAD(exemplar);
+ for (; NOT_END(param); ++param, ++arg) {
+ if (IS_VOID(arg))
+ DS_PUSH(param);
+ }
+
+ REBARR *paramlist = Pop_Stack_Values_Core(
+ dsp_orig,
+ ARRAY_FLAG_PARAMLIST | SERIES_FLAG_FIXED_SIZE
+ );
+ MANAGE_ARRAY(paramlist);
+
+ RELVAL *rootparam = ARR_HEAD(paramlist);
+ rootparam->payload.function.paramlist = paramlist;
+
+ // See %sysobj.r for `specialized-meta:` object template
+
+ REBVAL *example = Get_System(SYS_STANDARD, STD_SPECIALIZED_META);
+
+ REBCTX *meta = Copy_Context_Shallow(VAL_CONTEXT(example));
+
+ Init_Void(CTX_VAR(meta, STD_SPECIALIZED_META_DESCRIPTION)); // default
+ Move_Value(
+ CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE),
+ specializee
+ );
+ if (opt_specializee_name == NULL)
+ Init_Void(CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE_NAME));
+ else
+ Init_Word(
+ CTX_VAR(meta, STD_SPECIALIZED_META_SPECIALIZEE_NAME),
+ opt_specializee_name
+ );
+
+ MANAGE_ARRAY(CTX_VARLIST(meta));
+ SER(paramlist)->link.meta = meta;
+
+ REBFUN *fun = Make_Function(
+ paramlist,
+ &Specializer_Dispatcher,
+ VAL_FUNC(specializee), // cache underlying function's facade
+ exemplar // also provide a context of specialization values
+ );
+
+ // !!! The full story behind how FRAME!s remember the function they were
+ // made for is not completely told yet, but it comes from the "phase"
+ // field. System-wide this needs to be honored--all FRAME!s must have
+ // one, eventually. In order to make sure specialization dispatches the
+ // function you specialized and not the one tied to its underlying frame,
+ // we just patch this one in here.
+ //
+ CTX_VALUE(exemplar)->payload.any_context.phase = VAL_FUNC(specializee);
+
+ // The "body" is the FRAME! value of the specialization. Though we may
+ // not be able to touch the keylist of that frame to update the "archetype"
+ // binding, we can patch this cell in the "body array" to hold it.
+ //
+ Move_Value(FUNC_BODY(fun), CTX_VALUE(exemplar));
+ assert(VAL_BINDING(FUNC_BODY(fun)) == VAL_BINDING(specializee));
+
+ Move_Value(out, FUNC_VALUE(fun));
+ assert(VAL_BINDING(out) == NULL);
+
+ return FALSE;
+}
+
+
+//
+// Clonify_Function: C
+//
+// (A "Clonify" interface takes in a raw duplicate value that one wishes to
+// mutate in-place into a full-fledged copy of the value it is a clone of.
+// This interface can be more efficient than a "source in, dest out" copy...
+// and clarifies the dangers when the source and destination are the same.)
+//
+// !!! Function bodies in R3-Alpha were mutable. This meant that you could
+// effectively have static data in cases like:
+//
+// foo: does [static: [] | append static 1]
+//
+// Hence, it was meaningful to be able to COPY a function; because that copy
+// would get any such static state snapshotted at wherever it was in time.
+//
+// Ren-C eliminated this idea. But functions are still copied in the special
+// case of object "member functions", so that each "derived" object will
+// have functions with bindings to its specific context variables. Some
+// plans are in the work to use function REBVAL's `binding` parameter to
+// make a lighter-weight way of connecting methods to objects without actually
+// needing to mutate the archetypal REBFUN to do so ("virtual binding").
+//
+void Clonify_Function(REBVAL *value)
{
- //Print("Make_Native: %s spec %d", Get_Sym_Name(type+1), SERIES_TAIL(spec));
- VAL_FUNC_SPEC(value) = spec;
- VAL_FUNC_ARGS(value) = Check_Func_Spec(spec);
- VAL_FUNC_CODE(value) = func;
- VAL_SET(value, type);
+ assert(IS_FUNCTION(value));
+
+ // Function compositions point downwards through their layers in a linked
+ // list. Each step in the chain has identity, and we need a copied
+ // identity for all steps that require a copy and everything *above* it.
+ // So for instance, although R3-Alpha did not see a need to copy natives,
+ // if you ADAPT a native with code, the adapting Rebol code may need to
+ // take into account new bindings to a derived object...just as the body
+ // to an interpreted function would.
+ //
+ // !!! For the moment, this work is not done...and only functions that
+ // are raw interpreted functions are cloned. That means old code will
+ // stay compatible but new features won't necessarily work the same way
+ // with object binding. All of this needs to be rethought in light of
+ // "virtual binding" anyway!
+ //
+ if (!IS_FUNCTION_INTERPRETED(value))
+ return;
+
+ REBFUN *original_fun = VAL_FUNC(value);
+ REBARR *paramlist = Copy_Array_Shallow(
+ FUNC_PARAMLIST(original_fun),
+ SPECIFIED
+ );
+ SET_SER_FLAG(paramlist, ARRAY_FLAG_PARAMLIST);
+ MANAGE_ARRAY(paramlist);
+ ARR_HEAD(paramlist)->payload.function.paramlist = paramlist;
+
+ // !!! Meta: copy, inherit?
+ //
+ SER(paramlist)->link.meta = FUNC_META(original_fun);
+
+ REBFUN *new_fun = Make_Function(
+ paramlist,
+ FUNC_DISPATCHER(original_fun),
+ NULL, // no underlying function, this is fundamental
+ NULL // not providing a specialization
+ );
+
+ RELVAL *body = FUNC_BODY(new_fun);
+
+ // Since we rebind the body, we need to instruct the interpreted dispatcher
+ // that it's o.k. to tell the frame lookup that it can find variables
+ // under the "new paramlist".
+ //
+ VAL_RESET_HEADER_EXTRA(body, REB_BLOCK, VALUE_FLAG_RELATIVE);
+ INIT_VAL_ARRAY(
+ body,
+ Copy_Rerelativized_Array_Deep_Managed(
+ VAL_ARRAY(FUNC_BODY(original_fun)),
+ original_fun,
+ AS_FUNC(paramlist)
+ )
+ );
+ VAL_INDEX(body) = 0;
+
+ // Remap references in the body from the original function to new
+
+ INIT_RELATIVE(body, AS_FUNC(paramlist));
+
+ Move_Value(value, FUNC_VALUE(new_fun));
}
-/***********************************************************************
-**
-*/ REBFLG Make_Function(REBCNT type, REBVAL *value, REBVAL *def)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+// This handler is used to fail for a type which cannot handle actions.
+//
+// !!! Currently all types have a REBTYPE() handler for either themselves or
+// their class. But having a handler that could be "swapped in" from a
+// default failing case is an idea that could be used as an interim step
+// to allow something like REB_GOB to fail by default, but have the failing
+// type handler swapped out by an extension.
+//
+REBTYPE(Fail)
{
- REBVAL *spec;
- REBVAL *body;
- REBCNT len;
+ UNUSED(frame_);
+ UNUSED(action);
- if (
- !IS_BLOCK(def)
- || (len = VAL_LEN(def)) < 2
- || !IS_BLOCK(spec = VAL_BLK(def))
- ) return FALSE;
+ fail ("Datatype does not have a dispatcher registered.");
+}
- body = VAL_BLK_SKIP(def, 1);
- VAL_FUNC_SPEC(value) = VAL_SERIES(spec);
- VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec));
+//
+// Action_Dispatcher: C
+//
+// "actions" are historically a kind of dispatch based on the first argument's
+// type, and then calling a common function for that type parameterized with
+// a word for the action. e.g. APPEND X [...] would look at the type of X,
+// and call a function based on that parameterized with APPEND and the list
+// of arguments.
+//
+REB_R Action_Dispatcher(REBFRM *f)
+{
+ enum Reb_Kind type = VAL_TYPE(FRM_ARG(f, 1));
+ assert(type < REB_MAX); // actions should not allow void first arguments
+ REBSYM sym = STR_SYMBOL(VAL_WORD_SPELLING(FUNC_BODY(f->phase)));
+ assert(sym != SYM_0);
- if (type != REB_COMMAND) {
- if (len != 2 || !IS_BLOCK(body)) return FALSE;
- VAL_FUNC_BODY(value) = VAL_SERIES(body);
- }
- else
- Make_Command(value, def);
+ REBACT subdispatch = Value_Dispatch[type];
+ return subdispatch(f, sym);
+}
- VAL_SET(value, type);
- if (type == REB_FUNCTION || type == REB_CLOSURE)
- Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value));
+//
+// Noop_Dispatcher: C
+//
+// If a function's body is an empty block, rather than bother running the
+// equivalent of `DO []` and generating a frame for specific binding, this
+// just returns void. What makes this a semi-interesting optimization is
+// for functions like ASSERT whose default implementation is an empty block,
+// but intended to be hijacked in "debug mode" with an implementation. So
+// you can minimize the cost of instrumentation hooks.
+//
+REB_R Noop_Dispatcher(REBFRM *f)
+{
+ UNUSED(f);
+ return R_VOID;
+}
- return TRUE;
+
+//
+// Datatype_Checker_Dispatcher: C
+//
+// Dispatcher used by TYPECHECKER generator for when argument is a datatype.
+//
+REB_R Datatype_Checker_Dispatcher(REBFRM *f)
+{
+ RELVAL *datatype = FUNC_BODY(f->phase);
+ assert(IS_DATATYPE(datatype));
+ if (VAL_TYPE(FRM_ARG(f, 1)) == VAL_TYPE_KIND(datatype))
+ return R_TRUE;
+ return R_FALSE;
}
-/***********************************************************************
-**
-*/ REBFLG Copy_Function(REBVAL *value, REBVAL *args)
-/*
-***********************************************************************/
+//
+// Typeset_Checker_Dispatcher: C
+//
+// Dispatcher used by TYPECHECKER generator for when argument is a typeset.
+//
+REB_R Typeset_Checker_Dispatcher(REBFRM *f)
{
- REBVAL *spec;
- REBVAL *body;
-
- if (!args || ((spec = VAL_BLK(args)) && IS_END(spec))) {
- body = 0;
- if (IS_FUNCTION(value) || IS_CLOSURE(value))
- VAL_FUNC_ARGS(value) = Copy_Block(VAL_FUNC_ARGS(value), 0);
- } else {
- body = VAL_BLK_SKIP(args, 1);
- // Spec given, must be block or *
- if (IS_BLOCK(spec)) {
- VAL_FUNC_SPEC(value) = VAL_SERIES(spec);
- VAL_FUNC_ARGS(value) = Check_Func_Spec(VAL_SERIES(spec));
- } else {
- if (!IS_STAR(spec)) return FALSE;
- VAL_FUNC_ARGS(value) = Copy_Block(VAL_FUNC_ARGS(value), 0);
- }
- }
-
- if (body && !IS_END(body)) {
- if (!IS_FUNCTION(value) && !IS_CLOSURE(value)) return FALSE;
- // Body must be block:
- if (!IS_BLOCK(body)) return FALSE;
- VAL_FUNC_BODY(value) = VAL_SERIES(body);
- }
- // No body, use prototype:
- else if (IS_FUNCTION(value) || IS_CLOSURE(value))
- VAL_FUNC_BODY(value) = Clone_Block(VAL_FUNC_BODY(value));
-
- // Rebind function words:
- if (IS_FUNCTION(value) || IS_CLOSURE(value))
- Bind_Relative(VAL_FUNC_ARGS(value), VAL_FUNC_ARGS(value), VAL_FUNC_BODY(value));
-
- return TRUE;
+ RELVAL *typeset = FUNC_BODY(f->phase);
+ assert(IS_TYPESET(typeset));
+ if (TYPE_CHECK(typeset, VAL_TYPE(FRM_ARG(f, 1))))
+ return R_TRUE;
+ return R_FALSE;
}
-/***********************************************************************
-**
-*/ void Clone_Function(REBVAL *value, REBVAL *func)
-/*
-***********************************************************************/
+//
+// Unchecked_Dispatcher: C
+//
+// This is the default MAKE FUNCTION! dispatcher for interpreted functions
+// (whose body is a block that runs through DO []). There is no return type
+// checking done on these simple functions.
+//
+REB_R Unchecked_Dispatcher(REBFRM *f)
{
- REBSER *src_frame = VAL_FUNC_ARGS(func);
-
- VAL_FUNC_SPEC(value) = VAL_FUNC_SPEC(func);
- VAL_FUNC_BODY(value) = Clone_Block(VAL_FUNC_BODY(func));
- VAL_FUNC_ARGS(value) = Copy_Block(src_frame, 0);
- // VAL_FUNC_BODY(value) = Clone_Block(VAL_FUNC_BODY(func));
- VAL_FUNC_BODY(value) = Copy_Block_Values(VAL_FUNC_BODY(func), 0, SERIES_TAIL(VAL_FUNC_BODY(func)), TS_CLONE);
- Rebind_Block(src_frame, VAL_FUNC_ARGS(value), BLK_HEAD(VAL_FUNC_BODY(value)), 0);
+ RELVAL *body = FUNC_BODY(f->phase);
+ assert(IS_BLOCK(body) && IS_RELATIVE(body) && VAL_INDEX(body) == 0);
+
+ if (Do_At_Throws(
+ f->out,
+ VAL_ARRAY(body),
+ VAL_INDEX(body),
+ AS_SPECIFIER(Context_For_Frame_May_Reify_Managed(f))
+ )){
+ return R_OUT_IS_THROWN;
+ }
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ void Do_Native(REBVAL *func)
-/*
-***********************************************************************/
+//
+// Voider_Dispatcher: C
+//
+// Variant of Unchecked_Dispatcher, except sets the output value to void.
+// Pushing that code into the dispatcher means there's no need to do flag
+// testing in the main loop.
+//
+REB_R Voider_Dispatcher(REBFRM *f)
{
- REBVAL *ds;
- REBINT n;
-#ifdef DEBUGGING
- REBYTE *fname = Get_Word_Name(DSF_WORD(DSF)); // for DEBUG
- Debug_Str(fname);
-#endif
+ RELVAL *body = FUNC_BODY(f->phase);
+ assert(IS_BLOCK(body) && IS_RELATIVE(body) && VAL_INDEX(body) == 0);
+
+ if (Do_At_Throws(
+ f->out,
+ VAL_ARRAY(body),
+ VAL_INDEX(body),
+ AS_SPECIFIER(Context_For_Frame_May_Reify_Managed(f))
+ )){
+ return R_OUT_IS_THROWN;
+ }
+
+ return R_VOID;
+}
- Eval_Natives++;
-
- if (NZ(n = VAL_FUNC_CODE(func)(DS_RETURN))) {
- ds = DS_RETURN;
- switch (n) {
- case R_RET: // for compiler opt
- break;
- case R_TOS:
- *ds = *DS_TOP;
- break;
- case R_TOS1:
- *ds = *DS_NEXT;
- break;
- case R_NONE:
- SET_NONE(ds);
- break;
- case R_UNSET:
- SET_UNSET(ds);
- break;
- case R_TRUE:
- SET_TRUE(ds);
- break;
- case R_FALSE:
- SET_FALSE(ds);
- break;
- case R_ARG1:
- *ds = *D_ARG(1);
- break;
- case R_ARG2:
- *ds = *D_ARG(2);
- break;
- case R_ARG3:
- *ds = *D_ARG(3);
- break;
- }
- }
+
+//
+// Returner_Dispatcher: C
+//
+// Contrasts with the Unchecked_Dispatcher since it ensures the return type is
+// correct. (Note that natives do not get this type checking, and they
+// probably shouldn't pay for it except in the debug build.)
+//
+REB_R Returner_Dispatcher(REBFRM *f)
+{
+ RELVAL *body = FUNC_BODY(f->phase);
+ assert(IS_BLOCK(body) && IS_RELATIVE(body) && VAL_INDEX(body) == 0);
+
+ if (Do_At_Throws(
+ f->out,
+ VAL_ARRAY(body),
+ VAL_INDEX(body),
+ AS_SPECIFIER(Context_For_Frame_May_Reify_Managed(f))
+ )){
+ return R_OUT_IS_THROWN;
+ }
+
+ REBVAL *typeset = FUNC_PARAM(f->phase, FUNC_NUM_PARAMS(f->phase));
+ assert(VAL_PARAM_SYM(typeset) == SYM_RETURN);
+
+ // The type bits of the definitional return are not applicable
+ // to the `return` word being associated with a FUNCTION!
+ // vs. an INTEGER! (for instance). It is where the type
+ // information for the non-existent return function specific
+ // to this call is hidden.
+ //
+ if (!TYPE_CHECK(typeset, VAL_TYPE(f->out)))
+ fail (Error_Bad_Return_Type(f->label, VAL_TYPE(f->out)));
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ void Do_Act(REBVAL *ds, REBCNT type, REBCNT act)
-/*
-***********************************************************************/
+//
+// Specializer_Dispatcher: C
+//
+// The evaluator does not do any special "running" of a specialized frame.
+// All of the contribution that the specialization has to make was taken care
+// of at the time of generating the arguments to the underlying function.
+//
+// Though an attempt is made to use the work of "digging" past specialized
+// frames, some exist deep as chains of specializations etc. These have
+// to just be peeled off when the chain runs.
+//
+REB_R Specializer_Dispatcher(REBFRM *f)
{
- REBACT action;
- REBINT ret;
-
- action = Value_Dispatch[type];
- //ASSERT2(action != 0, RP_NO_ACTION);
- if (!action) Trap_Action(type, act);
- ret = action(ds, act);
- if (ret > 0) {
- ds = DS_RETURN;
- switch (ret) {
- case R_RET: // for compiler opt
- break;
- case R_TOS:
- *ds = *DS_TOP;
- break;
- case R_TOS1:
- *ds = *DS_NEXT;
- break;
- case R_NONE:
- SET_NONE(ds);
- break;
- case R_UNSET:
- SET_UNSET(ds);
- break;
- case R_TRUE:
- SET_TRUE(ds);
- break;
- case R_FALSE:
- SET_FALSE(ds);
- break;
- case R_ARG1:
- *ds = *D_ARG(1);
- break;
- case R_ARG2:
- *ds = *D_ARG(2);
- break;
- case R_ARG3:
- *ds = *D_ARG(3);
- break;
- }
- }
+ REBVAL *exemplar = KNOWN(FUNC_BODY(f->phase));
+ f->phase = exemplar->payload.any_context.phase;
+ f->binding = VAL_BINDING(exemplar);
+
+ return R_REDO_UNCHECKED;
}
-/***********************************************************************
-**
-*/ void Do_Action(REBVAL *func)
-/*
-***********************************************************************/
+//
+// Hijacker_Dispatcher: C
+//
+// A hijacker takes over another function's identity, replacing it with its
+// own implementation, injecting directly into the paramlist and body_holder
+// nodes held onto by all the victim's references.
+//
+// Sometimes the hijacking function has the same underlying function
+// as the victim, in which case there's no need to insert a new dispatcher.
+// The hijacker just takes over the identity. But otherwise it cannot,
+// and a "shim" is needed...since something like an ADAPT or SPECIALIZE
+// or a MAKE FRAME! might depend on the existing paramlist shape.
+//
+REB_R Hijacker_Dispatcher(REBFRM *f)
{
- REBVAL *ds = DS_RETURN;
- REBCNT type = VAL_TYPE(D_ARG(1));
+ RELVAL *hijacker = FUNC_BODY(f->phase);
- Eval_Natives++;
+ // We need to build a new frame compatible with the hijacker, and
+ // transform the parameters we've gathered to be compatible with it.
+ //
+ if (Redo_Func_Throws(f, VAL_FUNC(hijacker)))
+ return R_OUT_IS_THROWN;
- ASSERT1(type < REB_MAX, RP_BAD_TYPE_ACTION);
+ return R_OUT;
+}
- // Handle special datatype test cases (eg. integer?)
- if (VAL_FUNC_ACT(func) == 0) {
- VAL_SET(D_RET, REB_LOGIC);
- VAL_LOGIC(D_RET) = (type == VAL_INT64(BLK_LAST(VAL_FUNC_SPEC(func))));
- return;
- }
- Do_Act(D_RET, type, VAL_FUNC_ACT(func));
+//
+// Adapter_Dispatcher: C
+//
+// Dispatcher used by ADAPT.
+//
+REB_R Adapter_Dispatcher(REBFRM *f)
+{
+ RELVAL *adaptation = FUNC_BODY(f->phase);
+ assert(ARR_LEN(VAL_ARRAY(adaptation)) == 2);
+
+ RELVAL* prelude = VAL_ARRAY_AT_HEAD(adaptation, 0);
+ REBVAL* adaptee = KNOWN(VAL_ARRAY_AT_HEAD(adaptation, 1));
+
+ // The first thing to do is run the prelude code, which may throw. If it
+ // does throw--including a RETURN--that means the adapted function will
+ // not be run.
+ //
+ // (Note that when the adapter was created, the prelude code was bound to
+ // the paramlist of the *underlying* function--because that's what a
+ // compatible frame gets pushed for.)
+ //
+ if (Do_At_Throws(
+ f->out,
+ VAL_ARRAY(prelude),
+ VAL_INDEX(prelude),
+ AS_SPECIFIER(Context_For_Frame_May_Reify_Managed(f))
+ )){
+ return R_OUT_IS_THROWN;
+ }
+
+ f->phase = VAL_FUNC(adaptee);
+ f->binding = VAL_BINDING(adaptee);
+ return R_REDO_CHECKED; // Have Do_Core run the adaptee updated into f->phase
}
-/***********************************************************************
-**
-*/ void Do_Function(REBVAL *func)
-/*
-***********************************************************************/
+//
+// Chainer_Dispatcher: C
+//
+// Dispatcher used by CHAIN.
+//
+REB_R Chainer_Dispatcher(REBFRM *f)
{
- REBVAL *result;
- REBVAL *ds;
-#ifdef DEBUGGING
- REBYTE *name = Get_Word_Name(DSF_WORD(DSF));
-#endif
+ REBVAL *pipeline = KNOWN(FUNC_BODY(f->phase)); // array of functions
+
+ // Before skipping off to find the underlying non-chained function
+ // to kick off the execution, the post-processing pipeline has to
+ // be "pushed" so it is not forgotten. Go in reverse order so
+ // the function to apply last is at the bottom of the stack.
+ //
+ REBVAL *value = KNOWN(ARR_LAST(VAL_ARRAY(pipeline)));
+ while (value != VAL_ARRAY_HEAD(pipeline)) {
+ assert(IS_FUNCTION(value));
+ DS_PUSH(KNOWN(value));
+ --value;
+ }
+
+ // Extract the first function, itself which might be a chain.
+ //
+ f->phase = VAL_FUNC(value);
+ f->binding = VAL_BINDING(value);
+
+ return R_REDO_UNCHECKED; // signatures should match
+}
+
- Eval_Functions++;
-
- //Dump_Block(VAL_FUNC_BODY(func));
- result = Do_Blk(VAL_FUNC_BODY(func), 0);
- ds = DS_RETURN;
-
- if (IS_ERROR(result) && IS_RETURN(result)) {
- // Value below is kept safe from GC because no-allocation is
- // done between point of SET_THROW and here.
- if (VAL_ERR_VALUE(result))
- *ds = *VAL_ERR_VALUE(result);
- else
- SET_UNSET(ds);
- }
- else *ds = *result; // Set return value (atomic)
+//
+// Get_If_Word_Or_Path_Arg: C
+//
+// Some routines like APPLY and SPECIALIZE are willing to take a WORD! or
+// PATH! instead of just the value type they are looking for, and perform
+// the GET for you. By doing the GET inside the function, they are able
+// to preserve the symbol:
+//
+// >> apply 'append [value: 'c]
+// ** Script error: append is missing its series argument
+//
+void Get_If_Word_Or_Path_Arg(
+ REBVAL *out,
+ REBSTR **opt_name_out,
+ const REBVAL *value
+) {
+ DECLARE_LOCAL (adjusted);
+ Move_Value(adjusted, value);
+
+ if (ANY_WORD(value)) {
+ *opt_name_out = VAL_WORD_SPELLING(value);
+ VAL_SET_TYPE_BITS(adjusted, REB_GET_WORD);
+ }
+ else if (ANY_PATH(value)) {
+ //
+ // In theory we could get a symbol here, assuming we only do non
+ // evaluated GETs. Not implemented at the moment.
+ //
+ *opt_name_out = NULL;
+ VAL_SET_TYPE_BITS(adjusted, REB_GET_PATH);
+ }
+ else {
+ *opt_name_out = NULL;
+ Move_Value(out, value);
+ return;
+ }
+
+ if (Eval_Value_Throws(out, adjusted)) {
+ //
+ // !!! GET_PATH should not evaluate GROUP!, and hence shouldn't be
+ // able to throw. TBD.
+ //
+ fail (Error_No_Catch_For_Throw(out));
+ }
}
-/***********************************************************************
-**
-*/ void Do_Closure(REBVAL *func)
-/*
-** Do a closure by cloning its body and rebinding it to
-** a new frame of words/values.
-**
-***********************************************************************/
+//
+// Apply_Frame_Core: C
+//
+// Work in progress to factor out common code used by DO and APPLY. Needs
+// to be streamlined.
+//
+// Expects the following Reb_Frame fields to be preloaded:
+//
+// f->out (just valid pointer, pointed-to value can be garbage)
+// f->phase
+// f->binding
+//
+// If opt_def is NULL, then f->varlist.context must be set
+//
+// !!! Because APPLY is being written as a regular native (and not a
+// special exception case inside of Do_Core) it has to "re-enter" Do_Core
+// and jump to the argument processing. This is the first example of
+// such a re-entry, and is not particularly streamlined yet.
+//
+// This could also be accomplished if function dispatch were a subroutine
+// that would be called both here and from the evaluator loop. But if
+// the subroutine were parameterized with the frame state, it would be
+// basically equivalent to a re-entry. And re-entry is interesting to
+// experiment with for other reasons (e.g. continuations), so that is what
+// is used here.
+//
+REB_R Apply_Frame_Core(REBFRM *f, REBSTR *label, REBVAL *opt_def)
{
- REBSER *body;
- REBSER *frame;
- REBVAL *result;
- REBVAL *ds;
-
- Eval_Functions++;
- //DISABLE_GC;
-
- // Clone the body of the function to allow rebinding to it:
- body = Clone_Block(VAL_FUNC_BODY(func));
-
- // Copy stack frame args as the closure object (one extra at head)
- frame = Copy_Values(BLK_SKIP(DS_Series, DS_ARG_BASE), SERIES_TAIL(VAL_FUNC_ARGS(func)));
- SET_FRAME(BLK_HEAD(frame), 0, VAL_FUNC_ARGS(func));
-
- // Rebind the body to the new context (deeply):
- Rebind_Block(VAL_FUNC_ARGS(func), frame, BLK_HEAD(body), REBIND_TYPE);
-
- ds = DS_RETURN;
- SET_OBJECT(ds, body); // keep it GC safe
- result = Do_Blk(body, 0); // GC-OK - also, result returned on DS stack
- ds = DS_RETURN;
-
- if (IS_ERROR(result) && IS_RETURN(result)) {
- // Value below is kept safe from GC because no-allocation is
- // done between point of SET_THROW and here.
- if (VAL_ERR_VALUE(result))
- *ds = *VAL_ERR_VALUE(result);
- else
- SET_UNSET(ds);
- }
- else *ds = *result; // Set return value (atomic)
+ assert(IS_FUNCTION(f->gotten));
+
+ f->eval_type = REB_FUNCTION;
+ SET_FRAME_LABEL(f, label);
+
+ // We pretend our "input source" has ended.
+ //
+ SET_FRAME_VALUE(f, END);
+ f->index = 0;
+ f->source.array = EMPTY_ARRAY;
+ f->specifier = SPECIFIED;
+ f->pending = NULL;
+
+ f->dsp_orig = DSP;
+
+ Init_Endlike_Header(&f->flags, DO_FLAG_APPLYING);
+
+ // !!! We have to push a call here currently because prior to specific
+ // binding, the stack gets walked to resolve variables. Hence in the
+ // apply case, Do_Core doesn't do its own push to the frame stack.
+ //
+ Push_Frame_Core(f);
+
+#if !defined(NDEBUG)
+ //
+ // We may push a data chunk, which is one of the things the snapshot state
+ // checks. It also checks the top of stack, so that has to be set as well.
+ // So this has to come before Push_Or_Alloc_Vars
+ //
+ SNAP_STATE(&f->state_debug);
+#endif
+
+ f->refine = m_cast(REBVAL*, END);
+
+ if (opt_def)
+ Push_Or_Alloc_Args_For_Underlying_Func(f, f->gotten);
+ else {
+ ASSERT_CONTEXT(CTX(f->varlist)); // underlying must be set
+
+ f->args_head = CTX_VARS_HEAD(CTX(f->varlist));
+
+ REBCTX *exemplar = FUNC_EXEMPLAR(f->phase);
+ if (exemplar)
+ f->special = CTX_VARS_HEAD(exemplar);
+ else
+ f->special = m_cast(REBVAL*, END); // literal pointer tested
+
+ SET_END(&f->cell); // needed for GC safety
+ }
+
+ // Ordinary function dispatch does not pre-fill the arguments; they
+ // are left as garbage until the parameter enumeration gets to them.
+ // (The GC can see f->param to know how far the enumeration has
+ // gotten, and avoid tripping on the garbage.) This helps avoid
+ // double-walking and double-writing.
+ //
+ // However, the user code being run by the APPLY can't get garbage
+ // if it looks at variables in the frame. Also, it's necessary to
+ // know if the user writes them or not...so making them "write-only"
+ // isn't an option either. One has to
+ //
+ f->param = FUNC_FACADE_HEAD(f->phase);
+ f->arg = f->args_head;
+ while (NOT_END(f->param)) {
+ if (f->special != END && !IS_VOID(f->special)) {
+ //
+ // !!! Specialized arguments *should* be invisible to the
+ // binding process of the apply. They have been set and should
+ // not be reset. Removing them from the binding process is
+ // TBD, so for now if you apply a specialization and change
+ // arguments you shouldn't that is a client error.
+ //
+ assert(!THROWN(f->special));
+ Move_Value(f->arg, f->special);
+ ++f->special;
+ }
+ else if (opt_def)
+ Init_Void(f->arg);
+ else {
+ // just leave it alone
+ }
+
+ ++f->arg;
+ ++f->param;
+ }
+ assert(IS_END(f->param));
+
+ if (opt_def) {
+ // In today's implementation, the body must be rebound to the frame.
+ // Ideally if it were read-only (at least), then the opt_def value
+ // should be able to carry a virtual binding into the new context.
+ // That feature is not currently implemented, so this mutates the
+ // bindings on the passed in block...as OBJECTs and other things do
+ //
+ Bind_Values_Core(
+ VAL_ARRAY_AT(opt_def),
+ Context_For_Frame_May_Reify_Managed(f),
+ FLAGIT_KIND(REB_SET_WORD), // types to bind (just set-word!)
+ 0, // types to "add midstream" to binding as we go (nothing)
+ BIND_DEEP
+ );
+
+ // Do the block into scratch space--we ignore the result (unless it is
+ // thrown, in which case it must be returned.)
+ //
+ if (Do_Any_Array_At_Throws(f->out, opt_def)) {
+ Drop_Frame_Core(f);
+ return R_OUT_IS_THROWN;
+ }
+ }
+ else {
+ // !!! This form of execution raises a ton of open questions about
+ // what to do if a frame is used more than once. Function calls
+ // are allowed to destroy their arguments and will contaminate the
+ // pure locals. We need to treat this as a "non-specializing
+ // specialization", and push a frame. The narrow case of frame
+ // reuse needs to be contained to something that a function can only
+ // do to itself--e.g. to facilitate tail recursion, because no caller
+ // but the function itself understands the state of its locals in situ.
+ }
+
+ f->special = f->args_head; // do type/refinement checks on existing data
+
+ SET_END(f->out);
+
+ Do_Core(f);
+
+ Drop_Frame_Core(f);
+
+ if (THROWN(f->out))
+ return R_OUT_IS_THROWN; // prohibits recovery from exits
+
+ assert(IS_END(f->value)); // we started at END_FLAG, can only throw
+
+ return R_OUT;
}
diff --git a/src/core/c-path.c b/src/core/c-path.c
new file mode 100644
index 0000000000..7f1d687fbf
--- /dev/null
+++ b/src/core/c-path.c
@@ -0,0 +1,635 @@
+//
+// File: %c-path.h
+// Summary: "Core Path Dispatching and Chaining"
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// !!! See notes in %sys-path.h regarding the R3-Alpha path dispatch concept
+// and regarding areas that need improvement.
+//
+
+#include "sys-core.h"
+
+
+//
+// PD_Fail: C
+//
+// In order to avoid having to pay for a check for NULL in the path dispatch
+// table for types with no path dispatch, a failing handler is in the slot.
+//
+REBINT PD_Fail(REBPVS *pvs)
+{
+ DECLARE_LOCAL (specified_orig);
+ Derelativize(specified_orig, pvs->orig, pvs->item_specifier);
+
+ DECLARE_LOCAL (specified_item);
+ Derelativize(specified_item, pvs->item, pvs->item_specifier);
+
+ fail (Error_Invalid_Path_Raw(specified_orig, specified_item));
+}
+
+
+//
+// Next_Path_Throws: C
+//
+// Evaluate next part of a path.
+//
+// !!! This is done as a recursive function instead of iterating in a loop due
+// to the unusual nature of some path dispatches that call Next_Path_Throws()
+// inside their implementation.
+//
+REBOOL Next_Path_Throws(REBPVS *pvs)
+{
+ if (IS_VOID(pvs->value))
+ fail (Error_No_Value_Core(pvs->orig, pvs->item_specifier));
+
+ REBPEF dispatcher = Path_Dispatch[VAL_TYPE(pvs->value)];
+ assert(dispatcher != NULL); // &PD_Fail is used instead of NULL
+
+ pvs->item++;
+
+ // Calculate the "picker" into the GC guarded cell.
+ //
+ assert(pvs->picker == &pvs->picker_cell);
+
+ if (IS_GET_WORD(pvs->item)) { // e.g. object/:field
+ Copy_Opt_Var_May_Fail(
+ &pvs->picker_cell, pvs->item, pvs->item_specifier
+ );
+
+ if (IS_VOID(pvs->picker))
+ fail (Error_No_Value_Core(pvs->item, pvs->item_specifier));
+ }
+ else if (IS_GROUP(pvs->item)) { // object/(expr) case:
+ REBSPC *derived = Derive_Specifier(pvs->item_specifier, pvs->item);
+ if (Do_At_Throws(
+ &pvs->picker_cell,
+ VAL_ARRAY(pvs->item),
+ VAL_INDEX(pvs->item),
+ derived
+ )) {
+ Move_Value(pvs->store, &pvs->picker_cell);
+ return TRUE;
+ }
+ }
+ else { // object/word and object/value case:
+ Derelativize(&pvs->picker_cell, pvs->item, pvs->item_specifier);
+ }
+
+ // Disallow voids from being used in path dispatch. This rule seems like
+ // common sense for safety, and also corresponds to voids being illegal
+ // to use in SELECT.
+ //
+ if (IS_VOID(pvs->picker))
+ fail (Error_No_Value_Core(pvs->item, pvs->item_specifier));
+
+ switch (dispatcher(pvs)) {
+ case PE_OK:
+ break;
+
+ case PE_SET_IF_END:
+ if (pvs->opt_setval && IS_END(pvs->item + 1)) {
+ *pvs->value = *pvs->opt_setval;
+ pvs->opt_setval = NULL;
+ }
+ break;
+
+ case PE_NONE:
+ Init_Blank(pvs->store);
+ // falls through
+ case PE_USE_STORE:
+ pvs->value = pvs->store;
+ pvs->value_specifier = SPECIFIED;
+ break;
+
+ default:
+ assert(FALSE);
+ }
+
+ // A function being refined does not actually update pvs->value with
+ // a "more refined" function value, it holds the original function and
+ // accumulates refinement state on the stack. The label should only
+ // be captured the first time the function is seen, otherwise it would
+ // capture the last refinement's name, so check label for non-NULL.
+ //
+ if (IS_FUNCTION(pvs->value) && IS_WORD(pvs->item))
+ if (pvs->label_out != NULL && *pvs->label_out == NULL)
+ *pvs->label_out = VAL_WORD_SPELLING(pvs->item);
+
+ if (NOT_END(pvs->item + 1))
+ return Next_Path_Throws(pvs);
+
+ return FALSE;
+}
+
+
+//
+// Do_Path_Throws_Core: C
+//
+// Evaluate an ANY_PATH! REBVAL, starting from the index position of that
+// path value and continuing to the end.
+//
+// The evaluator may throw because GROUP! is evaluated, e.g. `foo/(throw 1020)`
+//
+// If label_sym is passed in as being non-null, then the caller is implying
+// readiness to process a path which may be a function with refinements.
+// These refinements will be left in order on the data stack in the case
+// that `out` comes back as IS_FUNCTION().
+//
+// If `opt_setval` is given, the path operation will be done as a "SET-PATH!"
+// if the path evaluation did not throw or error. HOWEVER the set value
+// is NOT put into `out`. This provides more flexibility on performance in
+// the evaluator, which may already have the `val` where it wants it, and
+// so the extra assignment would just be overhead.
+//
+// !!! Path evaluation is one of the parts of R3-Alpha that has not been
+// vetted very heavily by Ren-C, and needs a review and overhaul.
+//
+REBOOL Do_Path_Throws_Core(
+ REBVAL *out,
+ REBSTR **label_out,
+ const RELVAL *path,
+ REBSPC *specifier,
+ const REBVAL *opt_setval
+) {
+ // The pvs contains a cell for the picker into which evaluations are
+ // done, e.g. `foo/(1 + 2)`. Because Next_Path() doesn't commit to not
+ // performing any evaluations this cell must be guarded. In the case of
+ // a fail() this guard will be released automatically, but to return
+ // normally use `return_thrown` and `return_not_thrown` which drops guard.
+ //
+ // !!! There was also a strange requirement in some more quirky path
+ // evaluation (GOB!, STRUCT!) that the cell survive between Next_Path()
+ // calls, which may still be relevant to why this can't be a C local.
+ //
+ REBPVS pvs;
+ Prep_Global_Cell(&pvs.picker_cell);
+ SET_END(&pvs.picker_cell);
+ PUSH_GUARD_VALUE(&pvs.picker_cell);
+ pvs.picker = &pvs.picker_cell;
+
+ REBDSP dsp_orig = DSP;
+
+ assert(ANY_PATH(path));
+
+ // !!! There is a bug in the dispatch such that if you are running a
+ // set path, it does not always assign the output, because it "thinks you
+ // aren't going to look at it". This presumably originated from before
+ // parens were allowed in paths, and neglects cases like:
+ //
+ // foo/(throw 1020): value
+ //
+ // We always have to check to see if a throw occurred. Until this is
+ // streamlined, we have to at minimum set it to something that is *not*
+ // thrown so that we aren't testing uninitialized memory. A safe trash
+ // will do, which is unset in release builds.
+ //
+ if (opt_setval)
+ SET_UNREADABLE_BLANK(out);
+
+ // None of the values passed in can live on the data stack, because
+ // they might be relocated during the path evaluation process.
+ //
+ assert(!IN_DATA_STACK_DEBUG(out));
+ assert(!IN_DATA_STACK_DEBUG(path));
+ assert(!opt_setval || !IN_DATA_STACK_DEBUG(opt_setval));
+
+ // Not currently robust for reusing passed in path or value as the output
+ assert(out != path && out != opt_setval);
+
+ assert(!opt_setval || !THROWN(opt_setval));
+
+ // Initialize REBPVS -- see notes in %sys-do.h
+ //
+ pvs.opt_setval = opt_setval;
+ pvs.store = out;
+ pvs.orig = path;
+ pvs.item = VAL_ARRAY_AT(pvs.orig); // may not be starting at head of PATH!
+ pvs.label_out = label_out;
+ if (label_out != NULL)
+ *label_out = NULL; // initial value if no function label found
+
+ // The path value that's coming in may be relative (in which case it
+ // needs to use the specifier passed in). Or it may be specific already,
+ // in which case we should use the specifier in the value to process
+ // its array contents.
+ //
+ pvs.item_specifier = Derive_Specifier(specifier, path);
+
+ // Seed the path evaluation process by looking up the first item (to
+ // get a datatype to dispatch on for the later path items)
+ //
+ if (IS_WORD(pvs.item)) {
+ pvs.value = Get_Mutable_Var_May_Fail(pvs.item, pvs.item_specifier);
+ pvs.value_specifier = SPECIFIED;
+
+ if (IS_VOID(pvs.value))
+ fail (Error_No_Value_Core(pvs.item, pvs.item_specifier));
+
+ if (IS_FUNCTION(pvs.value) && pvs.label_out != NULL)
+ *pvs.label_out = VAL_WORD_SPELLING(pvs.item);
+ }
+ else {
+ // !!! Ideally there would be some way to deal with writes to
+ // temporary locations, like this pvs.value...if a set-path sets
+ // it, then it will be discarded.
+
+ Derelativize(pvs.store, VAL_ARRAY_AT(pvs.orig), pvs.item_specifier);
+ pvs.value = pvs.store;
+ pvs.value_specifier = SPECIFIED;
+ }
+
+ // Start evaluation of path:
+ if (IS_END(pvs.item + 1)) {
+ // If it was a single element path, return the value rather than
+ // try to dispatch it (would cause a crash at time of writing)
+ //
+ // !!! Is this the desired behavior, or should it be an error?
+ }
+ else {
+ REBOOL threw = Next_Path_Throws(&pvs);
+
+ // !!! See comments about why the initialization of out is necessary.
+ // Without it this assertion can change on some things:
+ //
+ // t: now
+ // t/time: 10:20:03
+ //
+ // (It thinks pvs.value has its THROWN bit set when it completed
+ // successfully. It was a PE_USE_STORE case where pvs.value was reset to
+ // pvs.store, and pvs.store has its thrown bit set. Valgrind does not
+ // catch any uninitialized variables.)
+ //
+ // There are other cases that do trip valgrind when omitting the
+ // initialization, though not as clearly reproducible.
+ //
+ assert(threw == THROWN(pvs.value));
+
+ if (threw)
+ goto return_thrown;
+ }
+
+ if (opt_setval) {
+ // If SET then we don't return anything
+ assert(IS_END(pvs.item) + 1);
+ goto return_not_thrown;
+ }
+
+ // If storage was not used, then copy final value back to it:
+ if (pvs.value != pvs.store)
+ Derelativize(pvs.store, pvs.value, pvs.value_specifier);
+
+ assert(!THROWN(out));
+
+ assert(IS_END(pvs.item) + 1);
+
+ // To make things easier for processing, reverse any refinements
+ // pushed to the data stack (we needed to evaluate them
+ // in forward order). This way we can just pop them as we go,
+ // and know if they weren't all consumed if it doesn't get
+ // back to `dsp_orig` by the end.
+ //
+ if (dsp_orig != DSP) {
+ assert(IS_FUNCTION(pvs.store));
+
+ // !!! It should be technically possible to do something like
+ // :append/dup and return a "refined" variant of a function. That
+ // feature is not currently implemented. So if a label wasn't
+ // requested, assume a function is not being run and deliver an
+ // error for that case.
+ //
+ if (label_out == NULL)
+ fail (Error_Too_Long_Raw());
+
+ REBVAL *bottom = DS_AT(dsp_orig + 1);
+ REBVAL *top = DS_TOP;
+ while (top > bottom) {
+ DECLARE_LOCAL (temp);
+ Move_Value(temp, bottom);
+ Move_Value(bottom, top);
+ Move_Value(top, temp);
+
+ top--;
+ bottom++;
+ }
+ }
+
+return_not_thrown:
+ DROP_GUARD_VALUE(&pvs.picker_cell);
+ return FALSE;
+
+return_thrown:
+ DROP_GUARD_VALUE(&pvs.picker_cell);
+ return TRUE;
+}
+
+
+//
+// Error_Bad_Path_Select: C
+//
+REBCTX *Error_Bad_Path_Select(REBPVS *pvs)
+{
+ DECLARE_LOCAL (orig);
+ Derelativize(orig, pvs->orig, pvs->item_specifier);
+
+ DECLARE_LOCAL (item);
+ Derelativize(item, pvs->item, pvs->item_specifier);
+
+ return Error_Invalid_Path_Raw(orig, item);
+}
+
+
+//
+// Error_Bad_Path_Set: C
+//
+REBCTX *Error_Bad_Path_Set(REBPVS *pvs)
+{
+ DECLARE_LOCAL (orig);
+ Derelativize(orig, pvs->orig, pvs->item_specifier);
+
+ DECLARE_LOCAL (item);
+ Derelativize(item, pvs->item, pvs->item_specifier);
+
+ return Error_Bad_Path_Set_Raw(orig, item);
+}
+
+
+//
+// Error_Bad_Path_Range: C
+//
+REBCTX *Error_Bad_Path_Range(REBPVS *pvs)
+{
+ DECLARE_LOCAL (item);
+ Derelativize(item, pvs->item, pvs->item_specifier);
+
+ return Error_Out_Of_Range(item);
+}
+
+
+//
+// Error_Bad_Path_Field_Set: C
+//
+REBCTX *Error_Bad_Path_Field_Set(REBPVS *pvs)
+{
+ DECLARE_LOCAL (item);
+ Derelativize(item, pvs->item, pvs->item_specifier);
+
+ return Error_Bad_Field_Set_Raw(item, Type_Of(pvs->opt_setval));
+}
+
+
+//
+// Get_Simple_Value_Into: C
+//
+// Does easy lookup, else just returns the value as is.
+//
+void Get_Simple_Value_Into(REBVAL *out, const RELVAL *val, REBSPC *specifier)
+{
+ if (IS_WORD(val) || IS_GET_WORD(val)) {
+ Copy_Opt_Var_May_Fail(out, val, specifier);
+ }
+ else if (IS_PATH(val) || IS_GET_PATH(val)) {
+ if (Do_Path_Throws_Core(out, NULL, val, specifier, NULL))
+ fail (Error_No_Catch_For_Throw(out));
+ }
+ else {
+ Derelativize(out, val, specifier);
+ }
+}
+
+
+//
+// Resolve_Path: C
+//
+// Given a path, determine if it is ultimately specifying a selection out
+// of a context...and if it is, return that context. So `a/obj/key` would
+// return the object assocated with obj, while `a/str/1` would return
+// NULL if `str` were a string as it's not an object selection.
+//
+// !!! This routine overlaps the logic of Do_Path, and should potentially
+// be a mode of that instead. It is not very complete, considering that it
+// does not execute GROUP! (and perhaps shouldn't?) and only supports a
+// path that picks contexts out of other contexts, via word selection.
+//
+REBCTX *Resolve_Path(const REBVAL *path, REBCNT *index_out)
+{
+ REBARR *array = VAL_ARRAY(path);
+ RELVAL *picker = ARR_HEAD(array);
+
+ if (IS_END(picker) || !ANY_WORD(picker))
+ return NULL; // !!! only handles heads of paths that are ANY-WORD!
+
+ const RELVAL *var = Get_Opt_Var_May_Fail(picker, VAL_SPECIFIER(path));
+
+ ++picker;
+ if (IS_END(picker))
+ return NULL; // !!! does not handle single-element paths
+
+ while (ANY_CONTEXT(var) && IS_WORD(picker)) {
+ REBCNT i = Find_Canon_In_Context(
+ VAL_CONTEXT(var), VAL_WORD_CANON(picker), FALSE
+ );
+ ++picker;
+ if (IS_END(picker)) {
+ *index_out = i;
+ return VAL_CONTEXT(var);
+ }
+
+ var = CTX_VAR(VAL_CONTEXT(var), i);
+ }
+
+ return NULL;
+}
+
+
+//
+// pick*: native [
+//
+// {Perform a path picking operation, same as `:(:location)/(:picker)`}
+//
+// return: [ any-value!]
+// {Picked value, or void if picker can't fulfill the request}
+// location [any-value!]
+// picker [any-value!]
+// {Index offset, symbol, or other value to use as index}
+// ]
+//
+REBNATIVE(pick_p)
+//
+// In R3-Alpha, PICK was an "action", which dispatched on types through the
+// "action mechanic" for the following types:
+//
+// [any-series! map! gob! pair! date! time! tuple! bitset! port! varargs!]
+//
+// In Ren-C, PICK is rethought to use the same dispatch mechanic as paths,
+// to cut down on the total number of operations the system has to define.
+{
+ INCLUDE_PARAMS_OF_PICK_P;
+
+ REBVAL *location = ARG(location);
+ REBVAL *picker = ARG(picker);
+
+ // PORT!s are kind of a "user defined type" which historically could
+ // react to PICK and POKE, but which could not override path dispatch.
+ // Use a symbol-based call to bounce the frame to the port, which should
+ // be a compatible frame with the historical "action".
+ //
+ if (IS_PORT(location))
+ return Do_Port_Action(frame_, VAL_CONTEXT(location), SYM_PICK_P);
+
+ REBPVS pvs_decl;
+ REBPVS *pvs = &pvs_decl;
+
+ Prep_Global_Cell(&pvs->picker_cell);
+ TRASH_CELL_IF_DEBUG(&pvs->picker_cell); // not used
+ pvs->picker = picker;
+ pvs->store = D_OUT;
+
+ // !!! Sometimes path dispatchers check the item to see if it's at the
+ // end of the path. The entire thing needs review. In the meantime,
+ // take advantage of the implicit termination of the frame cell.
+ //
+ Move_Value(D_CELL, picker);
+ assert(IS_END(D_CELL + 1));
+
+ pvs->item = D_CELL;
+ pvs->item_specifier = SPECIFIED;
+ pvs->value = location;
+ pvs->value_specifier = SPECIFIED;
+
+ pvs->label_out = NULL; // applies to e.g. :append/only returning APPEND
+ pvs->orig = location; // expected to be a PATH! for errors, but tolerant
+ pvs->opt_setval = NULL;
+
+ REBPEF dispatcher = Path_Dispatch[VAL_TYPE(location)];
+ assert(dispatcher != NULL); // &PD_Fail is used instead of NULL
+ switch (dispatcher(pvs)) {
+ case PE_OK:
+ break;
+
+ case PE_SET_IF_END:
+ break;
+
+ case PE_NONE:
+ Init_Blank(pvs->store);
+ // falls through
+ case PE_USE_STORE:
+ pvs->value = pvs->store;
+ pvs->value_specifier = SPECIFIED;
+ break;
+
+ default:
+ assert(FALSE);
+ }
+
+ if (pvs->value != pvs->store)
+ Derelativize(D_OUT, pvs->value, pvs->value_specifier);
+
+ return R_OUT;
+}
+
+
+//
+// poke: native [
+//
+// {Perform a path poking operation, same as `(:location)/(:picker): :value`}
+//
+// return: [ any-value!]
+// {Same as value}
+// location [any-value!]
+// {(modified)}
+// picker
+// {Index offset, symbol, or other value to use as index}
+// value [ any-value!]
+// {The new value}
+// ]
+//
+REBNATIVE(poke)
+//
+// As with PICK*, POKE is changed in Ren-C from its own action to "whatever
+// path-setting (now path-poking) would do".
+{
+ INCLUDE_PARAMS_OF_POKE;
+
+ REBVAL *location = ARG(location);
+ REBVAL *picker = ARG(picker);
+ REBVAL *value = ARG(value);
+
+ // PORT!s are kind of a "user defined type" which historically could
+ // react to PICK and POKE, but which could not override path dispatch.
+ // Use a symbol-based call to bounce the frame to the port, which should
+ // be a compatible frame with the historical "action".
+ //
+ if (IS_PORT(location))
+ return Do_Port_Action(frame_, VAL_CONTEXT(location), SYM_POKE);
+
+ REBPVS pvs_decl;
+ REBPVS *pvs = &pvs_decl;
+
+ Prep_Global_Cell(&pvs->picker_cell);
+ TRASH_CELL_IF_DEBUG(&pvs->picker_cell); // not used
+ pvs->picker = picker;
+ pvs->store = D_OUT;
+
+ // !!! Sometimes the path mechanics do the writes for a poke inside their
+ // dispatcher, vs. delegating via PE_SET_IF_END. They check to see if
+ // the current pvs->item is at the end. All of path dispatch was ad hoc
+ // and needs a review. In the meantime, take advantage of the implicit
+ // termination of the frame cell.
+ //
+ Move_Value(D_CELL, picker);
+ assert(IS_END(D_CELL + 1));
+
+ pvs->item = D_CELL;
+ pvs->item_specifier = SPECIFIED;
+ pvs->value = location;
+ pvs->value_specifier = SPECIFIED;
+
+ pvs->label_out = NULL; // applies to e.g. :append/only returning APPEND
+ pvs->orig = location; // expected to be a PATH! for errors, but tolerant
+ pvs->opt_setval = value;
+
+ REBPEF dispatcher = Path_Dispatch[VAL_TYPE(location)];
+ assert(dispatcher != NULL); // &PD_Fail is used instead of NULL
+ switch (dispatcher(pvs)) {
+ case PE_SET_IF_END:
+ *pvs->value = *pvs->opt_setval;
+ break;
+
+ case PE_OK:
+ // !!! Trust that it wrote? See above notes about D_CELL.
+ break;
+
+ case PE_NONE:
+ case PE_USE_STORE:
+ fail (picker); // Invalid argument
+
+ default:
+ assert(FALSE);
+ }
+
+ Move_Value(D_OUT, value);
+ return R_OUT;
+}
diff --git a/src/core/c-port.c b/src/core/c-port.c
old mode 100644
new mode 100755
index d6a94104db..1113ca74af
--- a/src/core/c-port.c
+++ b/src/core/c-port.c
@@ -1,631 +1,607 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: c-port.c
-** Summary: support for I/O ports
-** Section: core
-** Author: Carl Sassenrath
-** Notes:
-** See comments in Init_Ports for startup.
-** See www.rebol.net/wiki/Event_System for full details.
-**
-***********************************************************************/
+//
+// File: %c-port.c
+// Summary: "support for I/O ports"
+// Section: core
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// See comments in Init_Ports for startup.
+// See www.rebol.net/wiki/Event_System for full details.
+//
#include "sys-core.h"
#define MAX_WAIT_MS 64 // Maximum millsec to sleep
-/***********************************************************************
-**
-*/ REBVAL *Make_Port(REBVAL *spec)
-/*
-** Create a new port. This is done by calling the MAKE_PORT
-** function stored in the system/intrinsic object.
-**
-***********************************************************************/
-{
- REBVAL *value;
-
- value = Do_Sys_Func(SYS_CTX_MAKE_PORT_P, spec, 0); // volatile
- if (IS_NONE(value)) Trap1(RE_INVALID_SPEC, spec);
-
- return value;
-}
-
-/***********************************************************************
-**
-*/ REBFLG Is_Port_Open(REBSER *port)
-/*
-** Standard method for checking if port is open.
-** A convention. Not all ports use this method.
-**
-***********************************************************************/
+//
+// Is_Port_Open: C
+//
+// Standard method for checking if port is open.
+// A convention. Not all ports use this method.
+//
+REBOOL Is_Port_Open(REBCTX *port)
{
- REBVAL *state = BLK_SKIP(port, STD_PORT_STATE);
- if (!IS_BINARY(state)) return FALSE;
- return IS_OPEN(VAL_BIN_DATA(state));
+ REBVAL *state = CTX_VAR(port, STD_PORT_STATE);
+ if (!IS_BINARY(state)) return FALSE;
+ return IS_OPEN(VAL_BIN_AT(state));
}
-/***********************************************************************
-**
-*/ void Set_Port_Open(REBSER *port, REBFLG flag)
-/*
-** Standard method for setting a port open/closed.
-** A convention. Not all ports use this method.
-**
-***********************************************************************/
+//
+// Set_Port_Open: C
+//
+// Standard method for setting a port open/closed.
+// A convention. Not all ports use this method.
+//
+void Set_Port_Open(REBCTX *port, REBOOL open)
{
- REBVAL *state = BLK_SKIP(port, STD_PORT_STATE);
- if (IS_BINARY(state)) {
- if (flag) SET_OPEN(VAL_BIN_DATA(state));
- else SET_CLOSED(VAL_BIN_DATA(state));
- }
+ REBVAL *state = CTX_VAR(port, STD_PORT_STATE);
+ if (IS_BINARY(state)) {
+ if (open) SET_OPEN(VAL_BIN_AT(state));
+ else SET_CLOSED(VAL_BIN_AT(state));
+ }
}
-/***********************************************************************
-**
-*/ void *Use_Port_State(REBSER *port, REBCNT device, REBCNT size)
-/*
-** Use private state area in a port. Create if necessary.
-** The size is that of a binary structure used by
-** the port for storing internal information.
-**
-***********************************************************************/
+//
+// Ensure_Port_State: C
+//
+// Use private state area in a port. Create if necessary.
+// The size is that of a binary structure used by
+// the port for storing internal information.
+//
+REBREQ *Ensure_Port_State(REBCTX *port, REBCNT device)
{
- REBVAL *state = BLK_SKIP(port, STD_PORT_STATE);
-
- // If state is not a binary structure, create it:
- if (!IS_BINARY(state)) {
- REBSER *data = Make_Binary(size);
- REBREQ *req = (REBREQ*)STR_HEAD(data);
- Guard_Series(data); // GC safe if no other references
- req->clen = size;
- CLEAR(STR_HEAD(data), size);
- //data->tail = size; // makes it easier for ACCEPT to clone the port
- SET_FLAG(req->flags, RRF_ALLOC); // not on stack
- req->port = port;
- req->device = device;
- Set_Binary(state, data);
- }
-
- return (void *)VAL_BIN(state);
+ REBVAL *state = CTX_VAR(port, STD_PORT_STATE);
+ REBCNT req_size = OS_DEVREQ_SIZE(device);
+
+ if (!IS_BINARY(state)) {
+ assert(IS_BLANK(state));
+ REBSER *data = Make_Binary(req_size);
+ CLEAR(BIN_HEAD(data), req_size);
+ TERM_BIN_LEN(data, req_size);
+
+ REBREQ *req = cast(REBREQ*, BIN_HEAD(data));
+ SET_FLAG(req->flags, RRF_ALLOC); // not on stack
+ req->port = port;
+ req->device = device;
+ Init_Binary(state, data);
+ }
+ else {
+ assert(VAL_INDEX(state) == 0); // should always be at head
+ assert(VAL_LEN_HEAD(state) == req_size); // should be right size
+ }
+
+ return cast(REBREQ*, VAL_BIN(state));
}
-/***********************************************************************
-**
-*/ void Free_Port_State(REBSER *port)
-/*
-***********************************************************************/
+//
+// Pending_Port: C
+//
+// Return TRUE if port value is pending a signal.
+// Not valid for all ports - requires request struct!!!
+//
+REBOOL Pending_Port(REBVAL *port)
{
- REBVAL *state = BLK_SKIP(port, STD_PORT_STATE);
-
- // ??? check that this is the binary we think it is? !!!
-
- if (IS_BINARY(state)) {
- Loose_Series(VAL_SERIES(state));
- VAL_SET(state, REB_NONE);
- }
+ REBVAL *state;
+ REBREQ *req;
+
+ if (IS_PORT(port)) {
+ state = CTX_VAR(VAL_CONTEXT(port), STD_PORT_STATE);
+ if (IS_BINARY(state)) {
+ req = (REBREQ*)VAL_BIN(state);
+ if (!GET_FLAG(req->flags, RRF_PENDING)) return FALSE;
+ }
+ }
+ return TRUE;
}
-/***********************************************************************
-**
-*/ REBFLG Pending_Port(REBVAL *port)
-/*
-** Return TRUE if port value is pending a signal.
-** Not valid for all ports - requires request struct!!!
-**
-***********************************************************************/
+//
+// Awake_System: C
+//
+// Returns:
+// -1 for errors
+// 0 for nothing to do
+// 1 for wait is satisifed
+//
+REBINT Awake_System(REBARR *ports, REBOOL only)
{
- REBVAL *state;
- REBREQ *req;
-
- if (IS_PORT(port)) {
- state = BLK_SKIP(VAL_PORT(port), STD_PORT_STATE);
- if (IS_BINARY(state)) {
- req = (REBREQ*)VAL_BIN(state);
- if (!GET_FLAG(req->flags, RRF_PENDING)) return FALSE;
- }
- }
- return TRUE;
+ // Get the system port object:
+ REBVAL *port = Get_System(SYS_PORTS, PORTS_SYSTEM);
+ if (!IS_PORT(port))
+ return -10; // verify it is a port object
+
+ // Get wait queue block (the state field):
+ REBVAL *state = VAL_CONTEXT_VAR(port, STD_PORT_STATE);
+ if (!IS_BLOCK(state))
+ return -10;
+
+ // Get waked queue block:
+ REBVAL *waked = VAL_CONTEXT_VAR(port, STD_PORT_DATA);
+ if (!IS_BLOCK(waked))
+ return -10;
+
+ // If there is nothing new to do, return now:
+ if (VAL_LEN_HEAD(state) == 0 && VAL_LEN_HEAD(waked) == 0)
+ return -1;
+
+ // Get the system port AWAKE function:
+ REBVAL *awake = VAL_CONTEXT_VAR(port, STD_PORT_AWAKE);
+ if (!IS_FUNCTION(awake))
+ return -1;
+
+ DECLARE_LOCAL (tmp);
+ if (ports)
+ Init_Block(tmp, ports);
+ else
+ Init_Blank(tmp);
+
+ DECLARE_LOCAL (awake_only);
+ if (only) {
+ //
+ // If we're using /ONLY, we need path AWAKE/ONLY to call. (Ren-C's
+ // va_list API does not support positionally-provided refinements.)
+ //
+ REBARR *array = Make_Array(2);
+ Append_Value(array, awake);
+ Init_Word(Alloc_Tail_Array(array), Canon(SYM_ONLY));
+
+ Init_Path(awake_only, array);
+ }
+
+ // Call the system awake function:
+ //
+ DECLARE_LOCAL (result);
+ if (Apply_Only_Throws(
+ result,
+ TRUE,
+ only ? awake_only : awake,
+ port,
+ tmp,
+ END
+ )) {
+ fail (Error_No_Catch_For_Throw(result));
+ }
+
+ // Awake function returns 1 for end of WAIT:
+ //
+ return (IS_LOGIC(result) && VAL_LOGIC(result)) ? 1 : 0;
}
-/***********************************************************************
-**
-*/ REBINT Awake_System(REBSER *ports)
-/*
-** Returns:
-** -1 for errors
-** 0 for nothing to do
-** 1 for wait is satisifed
-**
-***********************************************************************/
-{
- REBVAL *port;
- REBVAL *state;
- REBVAL *waked;
- REBVAL *awake;
- REBVAL tmp;
- REBVAL *v;
-
- // Get the system port object:
- port = Get_System(SYS_PORTS, PORTS_SYSTEM);
- if (!IS_PORT(port)) return -10; // verify it is a port object
-
- // Get wait queue block (the state field):
- state = VAL_BLK_SKIP(port, STD_PORT_STATE);
- if (!IS_BLOCK(state)) return -10;
- //Debug_Num("S", VAL_TAIL(state));
-
- // Get waked queue block:
- waked = VAL_BLK_SKIP(port, STD_PORT_DATA);
- if (!IS_BLOCK(waked)) return -10;
-
- // If there is nothing new to do, return now:
- if (VAL_TAIL(state) == 0 && VAL_TAIL(waked) == 0) return -1;
-
- //Debug_Num("A", VAL_TAIL(waked));
- // Get the system port AWAKE function:
- awake = VAL_BLK_SKIP(port, STD_PORT_AWAKE);
- if (!ANY_FUNC(awake)) return -1;
- if (ports) Set_Block(&tmp, ports);
- else SET_NONE(&tmp);
-
- // Call the system awake function:
- v = Apply_Func(0, awake, port, &tmp, 0); // ds is return value
-
- // Awake function returns 1 for end of WAIT:
- return (IS_LOGIC(v) && VAL_LOGIC(v)) ? 1 : 0;
-}
-
-
-/***********************************************************************
-**
-*/ REBINT Wait_Ports(REBSER *ports, REBCNT timeout)
-/*
-** Inputs:
-** Ports: a block of ports or zero (on stack to avoid GC).
-** Timeout: milliseconds to wait
-**
-** Returns:
-** TRUE when port action happened, or FALSE for timeout.
-**
-***********************************************************************/
-{
- REBI64 base = OS_DELTA_TIME(0, 0);
- REBCNT time;
- REBINT result;
- REBCNT wt = 1;
- REBCNT res = (timeout >= 1000) ? 0 : 16; // OS dependent?
-
- while (wt) {
- if (GET_SIGNAL(SIG_ESCAPE)) {
- CLR_SIGNAL(SIG_ESCAPE);
- Halt_Code(RE_HALT, 0); // Throws!
- }
-
- // Process any waiting events:
- if ((result = Awake_System(ports)) > 0) return TRUE;
-
- // If activity, use low wait time, otherwise increase it:
- if (result == 0) wt = 1;
- else {
- wt *= 2;
- if (wt > MAX_WAIT_MS) wt = MAX_WAIT_MS;
- }
-
- if (timeout != ALL_BITS) {
- // Figure out how long that (and OS_WAIT) took:
- time = (REBCNT)(OS_DELTA_TIME(base, 0)/1000);
- if (time >= timeout) break; // done (was dt = 0 before)
- else if (wt > timeout - time) // use smaller residual time
- wt = timeout - time;
- }
-
- //printf("%d %d %d\n", dt, time, timeout);
-
- // Wait for events or time to expire:
- //Debug_Num("OSW", wt);
- OS_WAIT(wt, res);
- }
-
- //time = (REBCNT)OS_DELTA_TIME(base, 0);
- //Print("dt: %d", time);
-
- return FALSE; // timeout
-}
-
-#ifdef NDEF
-/***********************************************************************
-**
-xx*/ REBINT Wait_Device(REBREQ *req, REBCNT timeout)
-/*
-** Utility function for waiting on specific device.
-** (Near the main WAIT code above to keep in-sync.)
-** This still lets any GUI events continue.
-** Returns 0 when event occurs, else -1 for error.
-**
-***********************************************************************/
-{
- REBI64 base = OS_DELTA_TIME(0);
- REBCNT time;
- REBCNT dt = DT;
-
- while (dt) {
- // Process any waiting events:
- Awake_System(0);
- if (!GET_FLAG(req->flags, RRF_PENDING)) return TRUE;
-
- // Figure out how long that (and OS_WAIT) took:
- time = (REBCNT)OS_DELTA_TIME(base);
-
- Use above method!
-
- // Did we use all our time?
- if (timeout == ALL_BITS) dt = DT; // infinite time
- else if (time >= timeout) dt = 0; // done
- else if (dt > timeout - time) // residual time
- dt = timeout - time;
-
- // Wait for events or time to expire:
- OS_WAIT(dt);
- }
-
- return FALSE; // timeout
-}
-#endif
-
-/***********************************************************************
-**
-*/ void Sieve_Ports(REBSER *ports)
-/*
-** Remove all ports not found in the WAKE list.
-**
-***********************************************************************/
+//
+// Wait_Ports: C
+//
+// Inputs:
+// Ports: a block of ports or zero (on stack to avoid GC).
+// Timeout: milliseconds to wait
+//
+// Returns:
+// TRUE when port action happened, or FALSE for timeout.
+//
+REBOOL Wait_Ports(REBARR *ports, REBCNT timeout, REBOOL only)
{
- REBVAL *port;
- REBVAL *waked;
- REBVAL *val;
- REBCNT n;
-
- port = Get_System(SYS_PORTS, PORTS_SYSTEM);
- if (!IS_PORT(port)) return;
- waked = VAL_BLK_SKIP(port, STD_PORT_DATA);
- if (!IS_BLOCK(waked)) return;
-
- for (n = 0; n < SERIES_TAIL(ports);) {
- val = BLK_SKIP(ports, n);
- if (IS_PORT(val)) {
- if (VAL_TAIL(waked) != Find_Block_Simple(VAL_SERIES(waked), 0, val)) {
- Remove_Series(VAL_SERIES(waked), n, 1);
- continue;
- }
- }
- n++;
- }
+ REBI64 base = OS_DELTA_TIME(0, 0);
+ REBCNT time;
+ REBCNT wt = 1;
+ REBCNT res = (timeout >= 1000) ? 0 : 16; // OS dependent?
+
+ // Waiting opens the doors to pressing Ctrl-C, which may get this code
+ // to throw an error. There needs to be a state to catch it.
+ //
+ assert(Saved_State != NULL);
+
+ while (wt) {
+ if (GET_SIGNAL(SIG_HALT)) {
+ CLR_SIGNAL(SIG_HALT);
+ fail (VAL_CONTEXT(TASK_HALT_ERROR));
+ }
+
+ if (GET_SIGNAL(SIG_INTERRUPT)) {
+ CLR_SIGNAL(SIG_INTERRUPT);
+
+ DECLARE_LOCAL (result);
+ if (Do_Breakpoint_Throws(result, TRUE, VOID_CELL, FALSE)) {
+ //
+ // !!! Consider Wait_Ports() callsites being re-engineered
+ // to be able to gracefully accept a throw generated by
+ // a RESUME from a breakpoint, e.g. `resume/do [throw 10]`.
+ // This would require having a return result.
+ //
+ fail (Error_No_Catch_For_Throw(result));
+ }
+ if (!IS_VOID(result)) {
+ //
+ // !!! Same as above... if `resume/with 10` is to have any
+ // meaning then there must be a way to deliver that result
+ // up the stack.
+ //
+ fail ("Cannot deliver non-void result from Wait_Ports()");
+ }
+ }
+
+ REBINT ret;
+
+ // Process any waiting events:
+ if ((ret = Awake_System(ports, only)) > 0) return TRUE;
+
+ // If activity, use low wait time, otherwise increase it:
+ if (ret == 0) wt = 1;
+ else {
+ wt *= 2;
+ if (wt > MAX_WAIT_MS) wt = MAX_WAIT_MS;
+ }
+
+ if (timeout != ALL_BITS) {
+ // Figure out how long that (and OS_WAIT) took:
+ time = (REBCNT)(OS_DELTA_TIME(base, 0)/1000);
+ if (time >= timeout) break; // done (was dt = 0 before)
+ else if (wt > timeout - time) // use smaller residual time
+ wt = timeout - time;
+ }
+
+ //printf("%d %d %d\n", dt, time, timeout);
+
+ // Wait for events or time to expire:
+ OS_WAIT(wt, res);
+ }
+
+ //time = (REBCNT)OS_DELTA_TIME(base, 0);
+ //Print("dt: %d", time);
+
+ return FALSE; // timeout
}
-#ifdef not_used
-/***********************************************************************
-**
-*/ REBVAL *Form_Write(REBVAL *arg, REBYTE *newline)
-/*
-** Converts REBOL values to strings to use as data in WRITE.
-** Will also add newlines for conversions of blocks of lines.
-**
-***********************************************************************/
+//
+// Sieve_Ports: C
+//
+// Remove all ports not found in the WAKE list.
+// ports could be NULL, in which case the WAKE list is cleared.
+//
+void Sieve_Ports(REBARR *ports)
{
- REBSER *series;
- REBVAL *val;
- REBCNT n = 0;
- //REB_MOLD mo = {0 --- more here needed};
-
- if (IS_BLOCK(arg)) {
-
- if (newline) n = LEN_BYTES(newline);
-
- mo.series = series = Make_Binary(VAL_BLK_LEN(arg) * 10);
-
- for (val = VAL_BLK_DATA(arg); NOT_END(val); val++) {
- Mold_Value(&mo, val, 0);
- if (newline) Append_Series(series, newline, n);
- }
-
- Set_String(arg, series);
- }
-
- if (!ANY_STRING(arg)) {
- Set_String(arg, Copy_Form_Value(arg, 0));
- }
-
- return arg;
+ REBVAL *port;
+ REBVAL *waked;
+ REBCNT n;
+
+ port = Get_System(SYS_PORTS, PORTS_SYSTEM);
+ if (!IS_PORT(port)) return;
+ waked = VAL_CONTEXT_VAR(port, STD_PORT_DATA);
+ if (!IS_BLOCK(waked)) return;
+
+ for (n = 0; ports && n < ARR_LEN(ports);) {
+ RELVAL *val = ARR_AT(ports, n);
+ if (IS_PORT(val)) {
+ assert(VAL_LEN_HEAD(waked) != 0);
+ if (
+ Find_In_Array_Simple(VAL_ARRAY(waked), 0, val)
+ == VAL_LEN_HEAD(waked) // `=len` means not found
+ ) {
+ Remove_Series(SER(ports), n, 1);
+ continue;
+ }
+ }
+ n++;
+ }
+ //clear waked list
+ RESET_ARRAY(VAL_ARRAY(waked));
}
-#endif
-/***********************************************************************
-**
-*/ REBCNT Find_Action(REBVAL *object, REBCNT action)
-/*
-** Given an action number, return the action's index in
-** the specified object. If not found, a zero is returned.
-**
-***********************************************************************/
+//
+// Find_Action: C
+//
+// Given an action number, return the action's index in
+// the specified object. If not found, a zero is returned.
+//
+REBCNT Find_Action(REBVAL *object, REBSYM action)
{
- return Find_Word_Index(VAL_OBJ_FRAME(object), VAL_BIND_SYM(Get_Action_Word(action)), FALSE);
+ return Find_Canon_In_Context(VAL_CONTEXT(object), Canon(action), FALSE);
}
-/***********************************************************************
-**
-*/ int Do_Port_Action(REBSER *port, REBCNT action)
-/*
-** Call a PORT actor (action) value. Search PORT actor
-** first. If not found, search the PORT scheme actor.
-**
-** NOTE: stack must already be setup correctly for action, and
-** the caller must cleanup the stack.
-**
-***********************************************************************/
+//
+// Redo_Func_Throws: C
+//
+// This code takes a running call frame that has been built for one function
+// and then tries to map its parameters to another call. It is used to
+// dispatch some ACTION!s (an archetypal function spec with no implementation)
+// from a native C invocation to be "bounced" out into user code.
+//
+// In the origins of this function's active usage in R3-Alpha, it was allowed
+// for the target function to have a parameterization that was a superset of
+// the original frame's function (adding refinements, etc.) The greater
+// intentions of how it was supposed to work are not known--as there was
+// little error checking, given there were few instances.
+//
+// !!! Due to the historical brittleness of this function, very rare calls,
+// and need for an additional repetition of dispatch logic from Do_Core,
+// this code has been replaced with a straightforward implementation. It
+// builds a PATH! of the target function and refinements from the original
+// frame. Then it uses this in the DO_FLAG_EVAL_ONLY mode to suppress
+// re-evaluation of the frame's "live" args.
+//
+// !!! This won't stand up in the face of targets that are "adversarial"
+// to the archetype:
+//
+// foo: func [a /b c] [...] => bar: func [/b d e] [...]
+// foo/b 1 2 => bar/b 1 2
+//
+// However, it is still *much* better than the R3-Alpha situation for error
+// checking, and significantly less confusing. A real solution to this kind
+// of dispatch--if it is to be used--seems like it should be a language
+// feature available to users themselves. So leaning on the evaluator in
+// one way or another is the best course to keep this functionality going.
+//
+REBOOL Redo_Func_Throws(REBFRM *f, REBFUN *func_new)
{
- REBVAL *actor;
- REBCNT n = 0;
-
- ASSERT2(action < A_MAX_ACTION, RP_BAD_PORT_ACTION);
-
- // Verify valid port (all of these must be false):
- if (
- // Must be = or larger than std port:
- (SERIES_TAIL(port) < STD_PORT_MAX) ||
- // Must be an object series:
- !IS_FRAME(BLK_HEAD(port)) ||
- // Must have a spec object:
- !IS_OBJECT(BLK_SKIP(port, STD_PORT_SPEC))
- )
- Trap0(RE_INVALID_PORT);
-
- // Get actor for port, if it has one:
- actor = BLK_SKIP(port, STD_PORT_ACTOR);
-
- if (IS_NONE(actor)) return R_NONE;
-
- // If actor is a native function:
- if (IS_NATIVE(actor))
- return ((REBPAF)VAL_FUNC_CODE(actor))(DS_RETURN, port, action);
-
- // actor must be an object:
- if (!IS_OBJECT(actor)) Trap0(RE_INVALID_ACTOR);
-
- // Dispatch object function:
- n = Find_Action(actor, action);
- actor = Obj_Value(actor, n);
- if (!n || !actor || !ANY_FUNC(actor)) {
- Trap1(RE_NO_PORT_ACTION, Get_Action_Word(action));
- }
- Redo_Func(actor);
- return R_RET;
-
- // If not in PORT actor, use the SCHEME actor:
-#ifdef no_longer_used
- if (n == 0) {
- actor = Obj_Value(scheme, STD_SCHEME_actor);
- if (!actor) goto err;
- if (IS_NATIVE(actor)) goto fun;
- if (!IS_OBJECT(actor)) goto err; //Trap_Expect(value, STD_PORT_actor, REB_OBJECT);
- n = Find_Action(actor, action);
- if (n == 0) goto err;
- }
-#endif
-
+ // Upper bound on the length of the args we might need for a redo
+ // invocation is the total number of parameters to the *old* function's
+ // invocation (if it had no refinements or locals).
+ //
+ REBARR *code_array = Make_Array(FUNC_NUM_PARAMS(f->phase));
+ RELVAL *code = ARR_HEAD(code_array);
+
+ // We'll walk through the original functions param and arglist only, and
+ // accept the error-checking the evaluator provides at this time (types,
+ // refinement presence or absence matching).
+ //
+ // !!! See note in function description about arity mismatches.
+ //
+ f->param = FUNC_FACADE_HEAD(f->phase);
+ f->arg = f->args_head;
+ REBOOL ignoring = FALSE;
+
+ // The first element of our path will be the function, followed by its
+ // refinements. It has an upper bound on length that is to consider the
+ // opposite case where it had only refinements and then the function
+ // at the head...
+ //
+ REBARR *path_array = Make_Array(FUNC_NUM_PARAMS(f->phase) + 1);
+ RELVAL *path = ARR_HEAD(path_array);
+
+ Move_Value(path, FUNC_VALUE(func_new));
+ ++path;
+
+ for (; NOT_END(f->param); ++f->param, ++f->arg) {
+ enum Reb_Param_Class pclass = VAL_PARAM_CLASS(f->param);
+
+ if (
+ pclass == PARAM_CLASS_LOCAL
+ || pclass == PARAM_CLASS_LEAVE
+ || pclass == PARAM_CLASS_RETURN
+ ) {
+ continue; // don't add a callsite expression for it (can't)!
+ }
+
+ if (pclass == PARAM_CLASS_REFINEMENT) {
+ if (IS_CONDITIONAL_FALSE(f->arg)) {
+ //
+ // If the refinement is not in use, do not add it and ignore
+ // args until the next refinement.
+ //
+ ignoring = TRUE;
+ continue;
+ }
+
+ // In use--and used refinements must be added to the PATH!
+ //
+ ignoring = FALSE;
+ Init_Word(path, VAL_PARAM_SPELLING(f->param));
+ ++path;
+ continue;
+ }
+
+ // Otherwise it should be a quoted or normal argument. If ignoring
+ // then pass on it, otherwise add the arg to the code as-is.
+ //
+ if (ignoring) continue;
+
+ Move_Value(code, f->arg);
+ ++code;
+ }
+
+ TERM_ARRAY_LEN(code_array, code - ARR_HEAD(code_array));
+ MANAGE_ARRAY(code_array);
+
+ DECLARE_LOCAL (first);
+ TERM_ARRAY_LEN(path_array, path - ARR_HEAD(path_array));
+ Init_Path(first, path_array);
+
+ // Invoke DO with the special mode requesting non-evaluation on all
+ // args, as they were evaluated the first time around.
+ //
+ REBIXO indexor = Do_Array_At_Core(
+ f->out,
+ first, // path not in array, will be "virtual" first element
+ code_array,
+ 0, // index
+ SPECIFIED, // reusing existing REBVAL arguments, no relative values
+ DO_FLAG_NO_ARGS_EVALUATE
+ );
+
+ if (indexor != THROWN_FLAG && indexor != END_FLAG) {
+ //
+ // We may not have stopped the invocation by virtue of the args
+ // all not getting consumed, but we can raise an error now that it
+ // did not.
+ //
+ fail ("Function frame proxying did not consume all arguments");
+ }
+
+ return LOGICAL(indexor == THROWN_FLAG);
}
-/***********************************************************************
-**
-*/ void Secure_Port(REBCNT kind, REBREQ *req, REBVAL *name, REBSER *path)
-/*
-** kind: word that represents the type (e.g. 'file)
-** req: I/O request
-** name: value that holds the original user spec
-** path: the local path to compare with
-**
-***********************************************************************/
+//
+// Do_Port_Action: C
+//
+// Call a PORT actor (action) value. Search PORT actor
+// first. If not found, search the PORT scheme actor.
+//
+// NOTE: stack must already be setup correctly for action, and
+// the caller must cleanup the stack.
+//
+REB_R Do_Port_Action(REBFRM *frame_, REBCTX *port, REBSYM action)
{
- REBYTE *flags;
- REBVAL val;
-
- Set_String(&val, path);
- flags = Security_Policy(kind, &val); // policy flags
-
- // Check policy integer:
- // Mask is [xxxx wwww rrrr] - each holds the action
- if (GET_FLAG(req->modes, RFM_READ)) Trap_Security(flags[POL_READ], kind, name);
- if (GET_FLAG(req->modes, RFM_WRITE)) Trap_Security(flags[POL_WRITE], kind, name);
+ FAIL_IF_BAD_PORT(port);
+
+ REBVAL *actor = CTX_VAR(port, STD_PORT_ACTOR);
+
+ REB_R r;
+
+ // If actor is a HANDLE!, it should be a PAF
+ //
+ // !!! Review how user-defined types could make this better/safer, as if
+ // it's some other kind of handle value this could crash.
+ //
+ if (Is_Native_Port_Actor(actor)) {
+ r = cast(REBPAF, VAL_HANDLE_CFUNC(actor))(frame_, port, action);
+ goto post_process_output;
+ }
+
+ // actor must be an object:
+ if (!IS_OBJECT(actor))
+ fail (Error_Invalid_Actor_Raw());
+
+ // Dispatch object function:
+
+ REBCNT n; // goto would cross initialization
+ n = Find_Action(actor, action);
+ actor = Obj_Value(actor, n);
+ if (!n || !actor || !IS_FUNCTION(actor)) {
+ DECLARE_LOCAL (action_word);
+ Init_Word(action_word, Canon(action));
+
+ fail (Error_No_Port_Action_Raw(action_word));
+ }
+
+ if (Redo_Func_Throws(frame_, VAL_FUNC(actor))) {
+ // The throw name will be in D_OUT, with thrown value in task vars
+ return R_OUT_IS_THROWN;
+ }
+
+ r = R_OUT; // result should be in frame_->out
+
+ // !!! READ's /LINES and /STRING refinements are something that should
+ // work regardless of data source. But R3-Alpha only implemented it in
+ // %p-file.c, so it got ignored. Ren-C caught that it was being ignored,
+ // so the code was moved to here as a quick fix.
+ //
+ // !!! Note this code is incorrect for files read in chunks!!!
+
+post_process_output:
+ if (action == SYM_READ) {
+ INCLUDE_PARAMS_OF_READ;
+
+ UNUSED(PAR(source));
+ UNUSED(PAR(part));
+ UNUSED(PAR(limit));
+ UNUSED(PAR(seek));
+ UNUSED(PAR(index));
+
+ assert(r == R_OUT);
+
+ if ((REF(string) || REF(lines)) && !IS_STRING(D_OUT)) {
+ if (NOT(IS_BINARY(D_OUT)))
+ fail ("/STRING or /LINES used on a non-BINARY!/STRING! read");
+
+ REBSER *decoded = Decode_UTF_String(
+ VAL_BIN_AT(D_OUT),
+ VAL_LEN_AT(D_OUT),
+ -1
+ );
+ if (decoded == NULL)
+ fail (Error_Bad_Utf8_Raw());
+ Init_String(D_OUT, decoded);
+ }
+
+ if (REF(lines)) { // caller wants a BLOCK! of STRING!s, not one string
+ assert(IS_STRING(D_OUT));
+
+ DECLARE_LOCAL (temp);
+ Move_Value(temp, D_OUT);
+ Init_Block(D_OUT, Split_Lines(temp));
+ }
+ }
+
+ return r;
}
-/***********************************************************************
-**
-*/ void Validate_Port(REBSER *port, REBCNT action)
-/*
-** Because port actors are exposed to the user level, we must
-** prevent them from being called with invalid values.
-**
-***********************************************************************/
+//
+// Secure_Port: C
+//
+// kind: word that represents the type (e.g. 'file)
+// req: I/O request
+// name: value that holds the original user spec
+// path: the local path to compare with
+//
+void Secure_Port(REBSYM sym_kind, REBREQ *req, REBVAL *name, REBSER *path)
{
- if (
- action >= A_MAX_ACTION
- || port->tail > 50
- || SERIES_WIDE(port) != sizeof(REBVAL)
- || !IS_FRAME(BLK_HEAD(port))
- || !IS_OBJECT(BLK_SKIP(port, STD_PORT_SPEC))
- )
- Trap0(RE_INVALID_PORT);
-}
+ DECLARE_LOCAL (val);
+ Init_String(val, path);
-/***********************************************************************
-**
-** Scheme Native Action Support
-**
-** This array is used to associate a scheme word with its
-** native action functions.
-**
-** Each native port scheme must be listed here. This list is
-** created by each native scheme calling Register_Scheme()
-** during initialization.
-**
-** Example of defining actions:
-**
-** static const PORT_ACTION File_Actions[] = {
-** A_OPEN, P_open,
-** A_CLOSE, P_close,
-** 0, 0
-** }
-**
-** Register_Scheme(SYM_FILE, &File_Actions[0], 0);
-**
-**
-***********************************************************************/
-
-#define MAX_SCHEMES 10 // max native schemes
-
-typedef struct rebol_scheme_actions {
- REBCNT sym;
- const PORT_ACTION *map;
- REBPAF fun;
-} SCHEME_ACTIONS;
-
-SCHEME_ACTIONS *Scheme_Actions; // Initial Global (not threaded)
-
-
-/***********************************************************************
-**
-*/ void Register_Scheme(REBCNT sym, const PORT_ACTION *map, REBPAF fun)
-/*
-** Associate a scheme word (e.g. FILE) with a set of native
-** scheme actions. This will be used by the Set_Scheme native
-**
-***********************************************************************/
-{
- REBINT n;
+ REBYTE *flags = Security_Policy(Canon(sym_kind), val); // policy flags
- for (n = 0; n < MAX_SCHEMES && Scheme_Actions[n].sym; n++);
- ASSERT2(n < MAX_SCHEMES, RP_MAX_SCHEMES);
+ // Check policy integer:
+ // Mask is [xxxx wwww rrrr] - each holds the action
+ if (GET_FLAG(req->modes, RFM_READ))
+ Trap_Security(flags[POL_READ], Canon(sym_kind), name);
- Scheme_Actions[n].sym = sym;
- Scheme_Actions[n].map = map;
- Scheme_Actions[n].fun = fun;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(set_scheme)
-/*
-***********************************************************************/
-{
- REBVAL *scheme;
- REBVAL *actor;
- REBVAL *func;
- REBVAL *act;
- REBCNT n;
- const PORT_ACTION *map = 0;
-
- scheme = D_ARG(1);
-
- act = Obj_Value(scheme, STD_SCHEME_NAME);
- if (!IS_WORD(act)) return R_NONE;
- actor = Obj_Value(scheme, STD_SCHEME_ACTOR);
- if (!actor) return R_NONE;
-
- // Does this scheme have native actor or actions?
- for (n = 0; Scheme_Actions[n].sym; n++) {
- if (Scheme_Actions[n].sym == VAL_WORD_SYM(act)) break;
- }
- if (!Scheme_Actions[n].sym) return R_NONE;
-
- // The scheme uses a native actor:
- if (Scheme_Actions[n].fun) {
- //Make_Native(actor, Make_Block(0), (REBFUN)(Scheme_Actions[n].fun), REB_NATIVE);
- // Hand build a native function that will be used to reach native scheme actors.
- REBSER *ser = Make_Block(1);
- act = Append_Value(ser);
- Init_Word(act, REB_PORT+1); // any word will do
- VAL_TYPESET(act) = TYPESET(REB_END); // don't let it get called normally
- VAL_FUNC_SPEC(actor) = ser;
- VAL_FUNC_ARGS(actor) = ser;
- VAL_FUNC_CODE(actor) = (REBFUN)(Scheme_Actions[n].fun);
- VAL_SET(actor, REB_NATIVE);
- return R_TRUE;
- }
-
- // The scheme has an array of action natives:
- if (!IS_OBJECT(actor)) return R_NONE;
-
- // Map action natives to scheme actor words:
- for (; map->func; map++) {
- // Find the action in the scheme actor:
- n = Find_Action(actor, map->action);
- if (n) {
- // Get standard action's spec block:
- act = Get_Action_Value(map->action);
-
- // Make native function for action:
- func = Obj_Value(actor, n); // function
- Make_Native(func, VAL_FUNC_SPEC(act), (REBFUN)(map->func), REB_NATIVE);
- }
- }
- return R_TRUE;
+ if (GET_FLAG(req->modes, RFM_WRITE))
+ Trap_Security(flags[POL_WRITE], Canon(sym_kind), name);
}
-/***********************************************************************
-**
-*/ void Init_Ports(void)
-/*
-** Initialize port scheme related subsystems.
-**
-** In order to add a port scheme:
-**
-** In mezz-ports.r add a make-scheme.
-** Add an Init_*_Scheme() here.
-** Be sure host-devices.c has the device enabled.
-**
-***********************************************************************/
+//
+// Make_Port_Actor_Handle: C
+//
+// When users write a "port scheme", they provide an actor...which contains
+// a block of functions with the names of the "verbs" that can be applied to
+// ports. When the name of a port action matches the name of a supplied
+// function, then the matching function is called. Each of these functions
+// may have different numbers and types of arguments and refinements.
+//
+// R3-Alpha provided some native code to handle port actions, but all the
+// port actions were folded into a single function that was able to interpret
+// different function frames. This was similar to how datatypes handled
+// various "action" verbs.
+//
+// In Ren-C, this distinction is taken care of such that when the actor is
+// a HANDLE!, it is assumed to be a pointer to a "REBPAF". But since the
+// registration is done in user code, these handles have to be exposed to
+// that code. In order to make this more distributed, each port action
+// function is exposed through a native that returns it. This is the shared
+// routine used to make a handle out of a REBPAF.
+//
+void Make_Port_Actor_Handle(REBVAL *out, REBPAF paf)
{
- Scheme_Actions = Make_Mem(sizeof(SCHEME_ACTIONS) * MAX_SCHEMES);
-
- Init_Console_Scheme();
- Init_File_Scheme();
- Init_Dir_Scheme();
- Init_Event_Scheme();
- Init_TCP_Scheme();
- Init_DNS_Scheme();
-#ifndef MIN_OS
- Init_Clipboard_Scheme();
-#endif
+ Init_Handle_Cfunc(out, cast(CFUNC*, paf), 0);
}
diff --git a/src/core/c-signal.c b/src/core/c-signal.c
new file mode 100644
index 0000000000..04f2b9b161
--- /dev/null
+++ b/src/core/c-signal.c
@@ -0,0 +1,168 @@
+//
+// File: %c-signal.c
+// Summary: "Evaluator Interrupt Signal Handling"
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// "Signal" refers to special events to process periodically during
+// evaluation. Search for SET_SIGNAL to find them.
+//
+// (Note: Not to be confused with SIGINT and unix "signals", although on
+// unix an evaluator signal can be triggered by a unix signal.)
+//
+// Note in signal dispatch that R3-Alpha did not have a policy articulated on
+// dealing with the interrupt nature of the SIGINT signals sent by Ctrl-C:
+//
+// https://en.wikipedia.org/wiki/Unix_signal
+//
+// Guarding against errors being longjmp'd when an evaluation is in effect
+// isn't the only time these signals are processed. Rebol's Process_Signals
+// currently happens during I/O, such as printing output. As a consequence,
+// a Ctrl-C can be picked up and then triggered during an Out_Value, jumping
+// the stack from there.
+//
+// This means a top-level trap must always be in effect, even though no eval
+// is running. This trap's job is to handle errors that happen *while
+// reporting another error*, with Ctrl-C triggering a HALT being the most
+// likely example if not running an evaluation (though any fail() could
+// cause it)
+//
+
+#include "sys-core.h"
+
+
+//
+// Do_Signals_Throws: C
+//
+// !!! R3-Alpha's evaluator loop had a countdown (Eval_Count) which was
+// decremented on every step. When this counter reached zero, it would call
+// this routine to process any "signals"...which could be requests for
+// garbage collection, network-related, Ctrl-C being hit, etc.
+//
+// It also would check the Eval_Signals mask to see if it was non-zero on
+// every step. If it was, then it would always call this routine--regardless
+// of the Eval_Count.
+//
+// While a broader review of how signals would work in Ren-C is pending, it
+// seems best to avoid checking two things each step. So only the Eval_Count
+// is checked, and places that set Eval_Signals set it to 1...to have the
+// same effect as if it were being checked. Then if the Eval_Signals are
+// not cleared by the end of this routine, it resets the Eval_Count to 1
+// rather than giving it the full EVAL_DOSE of counts until next call.
+//
+// Currently the ability of a signal to THROW comes from the processing of
+// breakpoints. The RESUME instruction is able to execute code with /DO,
+// and that code may escape from a debug interrupt signal (like Ctrl-C).
+//
+REBOOL Do_Signals_Throws(REBVAL *out)
+{
+ assert(IS_END(out)); // incoming must be END, will be END if no throw
+
+ // !!! When it was the case that the only way Do_Signals_Throws would run
+ // due to the Eval_Count reaching the end of an Eval_Dose, this way of
+ // doing "CPU quota" would work. Currently, however, it is inaccurate,
+ // due to the fact that Do_Signals_Throws can be queued to run by setting
+ // the Eval_Count to 1 for a specific signal. Review.
+ //
+ Eval_Cycles += Eval_Dose - Eval_Count;
+ if (Eval_Limit != 0 && Eval_Cycles > Eval_Limit)
+ Check_Security(Canon(SYM_EVAL), POL_EXEC, 0);
+
+ Eval_Count = Eval_Dose;
+
+ REBOOL thrown = FALSE;
+
+ // The signal mask allows the system to disable processing of some
+ // signals. It defaults to ALL_BITS, but during signal processing
+ // itself, the mask is set to 0 to avoid recursion.
+ //
+ // !!! This seems overdesigned considering SIG_EVENT_PORT isn't used.
+ //
+ REBCNT filtered_sigs = Eval_Signals & Eval_Sigmask;
+ REBCNT saved_mask = Eval_Sigmask;
+ Eval_Sigmask = 0;
+
+ // "Be careful of signal loops! EG: do not PRINT from here."
+
+ if (GET_FLAG(filtered_sigs, SIG_RECYCLE)) {
+ CLR_SIGNAL(SIG_RECYCLE);
+ Recycle();
+ }
+
+#ifdef NOT_USED_INVESTIGATE
+ if (GET_FLAG(filtered_sigs, SIG_EVENT_PORT)) { // !!! Why not used?
+ CLR_SIGNAL(SIG_EVENT_PORT);
+ Awake_Event_Port();
+ }
+#endif
+
+ if (GET_FLAG(filtered_sigs, SIG_HALT)) {
+ //
+ // Early in the booting process, it's not possible to handle Ctrl-C
+ // because the error machinery has not been initialized. There must
+ // be at least one PUSH_UNHALTABLE_TRAP() before fail() can work.
+ //
+ if (Saved_State == NULL)
+ panic ("Ctrl-C or other HALT signal with no trap to process it");
+
+ CLR_SIGNAL(SIG_HALT);
+ Eval_Sigmask = saved_mask;
+
+ fail (VAL_CONTEXT(TASK_HALT_ERROR));
+ }
+
+ if (GET_FLAG(filtered_sigs, SIG_INTERRUPT)) {
+ //
+ // Similar to the Ctrl-C halting, the "breakpoint" interrupt request
+ // can't be processed early on. The throw mechanics should panic
+ // all right, but it might make more sense to wait.
+ //
+ CLR_SIGNAL(SIG_INTERRUPT);
+
+ // !!! This can recurse, which may or may not be a bad thing. But
+ // if the garbage collector and such are going to run during this
+ // execution, the signal mask has to be turned back on. Review.
+ //
+ Eval_Sigmask = saved_mask;
+ if (Do_Breakpoint_Throws(out, TRUE, VOID_CELL, FALSE))
+ return TRUE;
+
+ // !!! What to do with something like a Ctrl-C-based breakpoint
+ // session that does something like `resume/with 10`? This gets
+ // called "in-between" evaluations, so that 10 really has no meaning
+ // and is just going to get discarded. FAIL for now to alert the
+ // user that something is off, but perhaps the failure should be
+ // contained in a sandbox and restart the break?
+ //
+ if (NOT(IS_VOID(out)))
+ fail ("Interrupt-based debug session used RESUME/WITH");
+
+ SET_END(out);
+ return FALSE;
+ }
+
+ Eval_Sigmask = saved_mask;
+ return thrown;
+}
diff --git a/src/core/c-task.c b/src/core/c-task.c
deleted file mode 100644
index 2f7f2d0440..0000000000
--- a/src/core/c-task.c
+++ /dev/null
@@ -1,88 +0,0 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: c-task.c
-** Summary: sub-task support
-** Section: core
-** Author: Carl Sassenrath
-** Notes: INCOMPLETE IMPLEMENTATION (partially operational)
-**
-***********************************************************************/
-
-/*
- Making a Task:
-
- 1. Local copies of:
- Main globals
- For data stack
- Interpreter flags
- Memory management
- Root series (all or part?)
- Data stack
- System object (for module)
- C stack (thread provided)
-
- 2. Share copies of:
- Boot strings and values
- System functions (natives and mezzanine)
- Word table
- Various sub-objects of system object
-
- Task Spec is a module definition. Needs new context.
-
- Questions:
- System object is already copied for local user context
- System blocks might hold references to local series (how to GC)
- Can system values (objects and functions) be modified by other
- tasks? How are they protected? Is it good enough that our local
- references to functions refer to the older ones? How can we
- "update" our references?
-*/
-
-#include "sys-core.h"
-
-/***********************************************************************
-**
-*/ static void Launch_Task(REBVAL *task)
-/*
-***********************************************************************/
-{
- REBSER *body;
-
- Debug_Str("Begin Task");
-
- Init_Task();
- body = Clone_Block(VAL_MOD_BODY(task));
- OS_TASK_READY(0);
- Do_Blk(body, 0);
-
- Debug_Str("End Task");
-}
-
-
-/***********************************************************************
-**
-*/ void Do_Task(REBVAL *task)
-/*
-***********************************************************************/
-{
- OS_CREATE_THREAD((void*)Launch_Task, task, 50000);
-}
diff --git a/src/core/c-value.c b/src/core/c-value.c
new file mode 100644
index 0000000000..165fdf3c8e
--- /dev/null
+++ b/src/core/c-value.c
@@ -0,0 +1,237 @@
+//
+// File: %c-value.c
+// Summary: "Generic REBVAL Support Services and Debug Routines"
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2016 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// These are mostly DEBUG-build routines to support the macros and definitions
+// in %sys-value.h.
+//
+// These are not specific to any given type. For the type-specific REBVAL
+// code, see files with names like %t-word.c, %t-logic.c, %t-integer.c...
+//
+
+#include "sys-core.h"
+
+
+#if !defined(NDEBUG)
+
+//
+// Panic_Value_Debug: C
+//
+// This is a debug-only "error generator", which will hunt through all the
+// series allocations and panic on the series that contains the value (if
+// it can find it). This will allow those using Address Sanitizer or
+// Valgrind to know a bit more about where the value came from.
+//
+// Additionally, if it happens to be a void or trash, LOGIC!, BAR!, or NONE!
+// it will dump out where the initialization happened if that information
+// was stored.
+//
+ATTRIBUTE_NO_RETURN void Panic_Value_Debug(const RELVAL *v) {
+ fflush(stdout);
+ fflush(stderr);
+
+ REBSER *containing = Try_Find_Containing_Series_Debug(v);
+
+ switch (VAL_TYPE_RAW(v)) {
+ case REB_MAX_VOID:
+ case REB_BLANK:
+ case REB_LOGIC:
+ case REB_BAR:
+ printf(
+ "REBVAL init on tick #%d at %s:%d\n",
+ cast(unsigned int, v->extra.do_count),
+ v->payload.track.filename,
+ v->payload.track.line
+ );
+ fflush(stdout);
+ break;
+
+ default:
+ break;
+ }
+
+ printf("Kind=%d\n", cast(int, VAL_TYPE_RAW(v)));
+ fflush(stdout);
+
+ if (containing != NULL) {
+ printf("Containing series for value pointer found, panicking it:\n");
+ Panic_Series_Debug(containing);
+ }
+
+ printf("No containing series for value...panicking to make stack dump:\n");
+ Panic_Series_Debug(SER(EMPTY_ARRAY));
+}
+
+
+//
+// VAL_SPECIFIC_Debug: C
+//
+REBCTX *VAL_SPECIFIC_Debug(const REBVAL *v)
+{
+ assert(NOT_VAL_FLAG(v, VALUE_FLAG_RELATIVE));
+ assert(
+ ANY_WORD(v)
+ || ANY_ARRAY(v)
+ || IS_VARARGS(v)
+ || IS_FUNCTION(v)
+ || ANY_CONTEXT(v)
+ );
+
+ REBCTX *specific = VAL_SPECIFIC_COMMON(v);
+
+ if (specific != SPECIFIED) {
+ //
+ // Basic sanity check: make sure it's a context at all
+ //
+ if (NOT_SER_FLAG(CTX_VARLIST(specific), ARRAY_FLAG_VARLIST)) {
+ printf("Non-CONTEXT found as specifier in specific value\n");
+ panic (specific); // may not be a series, either
+ }
+
+ // While an ANY-WORD! can be bound specifically to an arbitrary
+ // object, an ANY-ARRAY! only becomes bound specifically to frames.
+ // The keylist for a frame's context should come from a function's
+ // paramlist, which should have a FUNCTION! value in keylist[0]
+ //
+ if (ANY_ARRAY(v))
+ assert(IS_FUNCTION(CTX_ROOTKEY(specific)));
+ }
+
+ return specific;
+}
+
+
+//
+// Assert_No_Relative: C
+//
+// Check to make sure there are no relative values in an array, maybe deeply.
+//
+// !!! What if you have an ANY-ARRAY! inside your array at a position N,
+// but there is a relative value in the VAL_ARRAY() of that value at an
+// index earlier than N? This currently considers that an error since it
+// checks the whole array...which is more conservative (asserts on more
+// cases). But should there be a flag to ask to honor the index?
+//
+void Assert_No_Relative(REBARR *array, REBOOL deep)
+{
+ RELVAL *item = ARR_HEAD(array);
+ while (NOT_END(item)) {
+ if (IS_RELATIVE(item)) {
+ printf("Array contained relative item and wasn't supposed to\n");
+ panic (item);
+ }
+ if (!IS_UNREADABLE_IF_DEBUG(item) && ANY_ARRAY(item) && deep)
+ Assert_No_Relative(VAL_ARRAY(item), deep);
+ ++item;
+ }
+}
+
+
+//
+// Probe_Core_Debug: C
+//
+void Probe_Core_Debug(
+ const void *p,
+ const char *file,
+ int line
+) {
+ const struct Reb_Header *h = cast(const struct Reb_Header*, p);
+
+ printf("\n** PROBE() ");
+ printf("tick %d %s:%d\n", cast(int, TG_Do_Count), file, line);
+
+ fflush(stdout);
+ fflush(stderr);
+
+ if (h->bits & NODE_FLAG_CELL)
+ Debug_Fmt("%r\n", cast(const REBVAL*, p));
+ else {
+ REBSER *s = m_cast(REBSER*, cast(const REBSER*, p));
+
+ // Invalid series would possibly (but not necessarily) crash the print
+ // routines--which are the same ones used to output a series normally.
+ // Hence don't attempt to print a known malformed series. A more
+ // pointed message will probably come from ASSERT_SERIES, saying
+ // what is wrong rather than just crashing the print code...
+ //
+ ASSERT_SERIES(s);
+
+ if (GET_SER_FLAG(s, ARRAY_FLAG_VARLIST)) {
+ REBCTX *c = CTX(s);
+
+ // Don't use Init_Any_Context, because that can implicitly manage
+ // the context...which we don't want a debug dump routine to do.
+ //
+ DECLARE_LOCAL (temp);
+ VAL_RESET_HEADER(temp, CTX_TYPE(c));
+ temp->extra.binding = NULL;
+ temp->payload.any_context.varlist = CTX_VARLIST(c);
+ temp->payload.any_context.phase = NULL;
+ Debug_Fmt("%r\n", temp);
+ }
+ else {
+ REBOOL disabled = GC_Disabled;
+ GC_Disabled = TRUE;
+
+ // This routine is also a little catalog of the outlying series
+ // types in terms of sizing, just to know what they are.
+
+ if (BYTE_SIZE(s))
+ Debug_Str(s_cast(BIN_HEAD(s)));
+ else if (GET_SER_FLAG(s, SERIES_FLAG_ARRAY)) {
+ //
+ // May not actually be a REB_BLOCK, but we put it in a value
+ // container for now saying it is so we can output it. May
+ // not want to Manage_Series here, so we use a raw
+ // initialization instead of Init_Block.
+ //
+ DECLARE_LOCAL (value);
+ VAL_RESET_HEADER(value, REB_BLOCK);
+ INIT_VAL_ARRAY(value, ARR(s));
+ VAL_INDEX(value) = 0;
+
+ Debug_Fmt("%r", value);
+ }
+ else if (SER_WIDE(s) == sizeof(REBUNI))
+ Debug_Uni(s);
+ else if (s == PG_Canons_By_Hash) {
+ printf("can't probe PG_Canons_By_Hash\n");
+ panic (s);
+ }
+ else if (s == GC_Guarded) {
+ printf("can't probe GC_Guarded\n");
+ panic (s);
+ }
+ else
+ panic (s);
+
+ assert(GC_Disabled == TRUE);
+ GC_Disabled = disabled;
+ }
+ }
+}
+
+#endif
diff --git a/src/core/c-word.c b/src/core/c-word.c
old mode 100644
new mode 100755
index 7bbbc1a8d8..864e7188d1
--- a/src/core/c-word.c
+++ b/src/core/c-word.c
@@ -1,423 +1,641 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: c-word.c
-** Summary: symbol table and word related functions
-** Section: core
-** Author: Carl Sassenrath
-** Notes:
-** Word table is a block composed of symbols, each of which contain
-** a canon word number, alias word number (if it exists), and an
-** index that refers to the string for the text itself.
-**
-** The canon number for a word is unique and is used to compare
-** words. The word table is independent of context frames and
-** words are never garbage collected.
-**
-** The alias is used mainly for upper and lower case equality,
-** but can also be used to create ALIASes.
-**
-** The word strings are stored as a single large string series.
-** NEVER CACHE A WORD NAME POINTER if new words may be added (e.g.
-** LOAD), because the series may get moved in memory.
-**
-***********************************************************************/
+//
+// File: %c-word.c
+// Summary: "symbol table and word related functions"
+// Section: core
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// In R3-Alpha, words were not garbage collected, and their UTF-8 data was
+// kept in a separate table from the REBSERs. In Ren-C, words use REBSERs,
+// and are merely *indexed* by hashes of their canon forms via an external
+// table. This table grows and shrinks as canons are added and removed.
+//
#include "sys-core.h"
-#include
#define WORD_TABLE_SIZE 1024 // initial size in words
-/***********************************************************************
-**
-*/ static REBCNT const Primes[] =
-/*
-** Prime numbers used for hash table sizes. Divide by 2 for
-** number of words that can be held in the symbol table.
-**
-***********************************************************************/
+//
+// Prime numbers used for hash table sizes. Divide by 2 for
+// number of words that can be held in the symbol table.
+//
+static REBCNT const Primes[] =
{
- 251,
- 509,
- 1021,
- 2039,
- 4093,
- 8191,
- 16381,
- 32749,
- 65521,
- 131071,
- 262139,
- 524287,
- 1048573,
- 2097143,
- 4194301,
- 8388593,
- 16777213,
- 33554393,
- 67108859,
- 134217689,
- 268435399,
- 0
+ 7,
+ 13,
+ 31,
+ 61,
+ 127,
+ 251,
+ 509,
+ 1021,
+ 2039,
+ 4093,
+ 8191,
+ 16381,
+ 32749,
+ 65521,
+ 131071,
+ 262139,
+ 524287,
+ 1048573,
+ 2097143,
+ 4194301,
+ 8388593,
+ 16777213,
+ 33554393,
+ 67108859,
+ 134217689,
+ 268435399,
+ 536870909,
+ 1073741789,
+ 2147483647,
+ 0xFFFFFFFB, // 4294967291 = 2^32 - 5 (C89)
+ 0
+// see https://primes.utm.edu/lists/2small/0bit.html
};
-/***********************************************************************
-**
-*/ REBINT Get_Hash_Prime(REBCNT size)
-/*
-** Given a size, return a prime number that is larger.
-**
-***********************************************************************/
+//
+// Get_Hash_Prime: C
+//
+// Given a size, return a prime number that is larger.
+//
+REBINT Get_Hash_Prime(REBCNT size)
{
- REBINT n;
+ REBINT n;
- for (n = 0; Primes[n] && size > Primes[n]; n++);
+ for (n = 0; Primes[n] && size > Primes[n]; n++);
- if (!Primes[n]) return 0;
+ if (!Primes[n]) return 0;
- return Primes[n];
+ return Primes[n];
}
-
-/***********************************************************************
-**
-*/ void Expand_Hash(REBSER *ser)
-/*
-** Expand hash series. Clear it but set its tail.
-**
-***********************************************************************/
-{
- REBSER oser;
- REBSER *nser;
- REBINT pnum;
-
- pnum = Get_Hash_Prime(ser->tail+1);
- if (!pnum) Trap_Num(RE_SIZE_LIMIT, ser->tail+1);
-
- nser = Make_Series(pnum+1, sizeof(REBCNT), TRUE);
- LABEL_SERIES(nser, "hash series");
- oser = *ser;
- *ser = *nser;
- ser->info = oser.info;
- *nser = oser;
-
- Clear_Series(ser);
- ser->tail = pnum;
-
- Free_Series(nser);
-}
-
-
-/***********************************************************************
-**
-*/ static void Expand_Word_Table(void)
-/*
-** Expand the hash table part of the word_table by allocating
-** the next larger table size and rehashing all the words of
-** the current table. Free the old hash array.
-**
-***********************************************************************/
+// Removals from linear probing lists can be complex, because the same
+// overflow slot may be visited through different initial hashes:
+//
+// http://stackoverflow.com/a/279812/211160
+//
+// Since it's not enough to simply NULL out the spot when an interned string
+// is GC'd, a special pointer signaling "deletedness" is used. It does not
+// cause a linear probe to terminate, but it is reused on insertions.
+//
+static REBSTR PG_Deleted_Canon;
+#define DELETED_CANON &PG_Deleted_Canon
+
+
+//
+// Expand_Word_Table: C
+//
+// Expand the hash table part of the word_table by allocating
+// the next larger table size and rehashing all the words of
+// the current table. Free the old hash array.
+//
+static void Expand_Word_Table(void)
{
- REBCNT *hashes;
- REBVAL *word;
- REBINT hash;
- REBCNT size;
- REBINT skip;
- REBCNT n;
-
- // Allocate a new hash table:
- Expand_Hash(PG_Word_Table.hashes);
- // Debug_Fmt("WORD-TABLE: expanded (%d symbols, %d slots)", PG_Word_Table.series->tail, PG_Word_Table.hashes->tail);
-
- // Rehash all the symbols:
- word = BLK_SKIP(PG_Word_Table.series, 1);
- hashes = (REBCNT *)PG_Word_Table.hashes->data;
- size = PG_Word_Table.hashes->tail;
- for (n = 1; n < PG_Word_Table.series->tail; n++, word++) {
- hash = Hash_Word(VAL_SYM_NAME(word), -1);
- skip = (hash & 0x0000FFFF) % size;
- if (skip == 0) skip = 1;
- hash = (hash & 0x00FFFF00) % size;
- while (hashes[hash]) {
- hash += skip;
- if (hash >= (REBINT)size) hash -= size;
- }
- hashes[hash] = n;
- }
+ // The only full list of canon words available is the old hash table.
+ // Hold onto it while creating the new hash table.
+
+ REBCNT old_size = SER_LEN(PG_Canons_By_Hash);
+ REBSTR* *old_canons_by_hash = SER_HEAD(REBSER*, PG_Canons_By_Hash);
+
+ REBCNT new_size = Get_Hash_Prime(old_size + 1);
+ if (new_size == 0) {
+ DECLARE_LOCAL (temp);
+ Init_Integer(temp, old_size + 1);
+ fail (Error_Size_Limit_Raw(temp));
+ }
+
+ assert(SER_WIDE(PG_Canons_By_Hash) == sizeof(REBSTR*));
+
+ REBSER *ser = Make_Series_Core(
+ new_size, sizeof(REBSTR*), SERIES_FLAG_POWER_OF_2
+ );
+ Clear_Series(ser);
+ SET_SERIES_LEN(ser, new_size);
+
+ // Rehash all the symbols:
+
+ REBSTR **new_canons_by_hash = SER_HEAD(REBSER*, ser);
+
+ REBCNT n;
+ for (n = 0; n < old_size; ++n) {
+ REBSTR *canon = old_canons_by_hash[n];
+
+ if (canon == NULL) continue;
+
+ if (canon == DELETED_CANON) { // clean out any deleted canon entries
+ --PG_Num_Canon_Slots_In_Use;
+ #if !defined(NDEBUG)
+ --PG_Num_Canon_Deleteds; // keep track for shutdown assert
+ #endif
+ continue;
+ }
+
+ REBINT hash = Hash_Word(STR_HEAD(canon), STR_NUM_BYTES(canon));
+ REBINT skip = (hash & 0x0000FFFF) % new_size;
+ if (skip == 0) skip = 1;
+ hash = (hash & 0x00FFFF00) % new_size;
+
+ while (new_canons_by_hash[hash] != NULL) {
+ hash += skip;
+ if (hash >= cast(REBINT, new_size))
+ hash -= new_size;
+ }
+ new_canons_by_hash[hash] = canon;
+ }
+
+ Free_Series(PG_Canons_By_Hash);
+ PG_Canons_By_Hash = ser;
}
-/***********************************************************************
-**
-*/ static REBCNT Make_Word_Name(REBYTE *str, REBCNT len)
-/*
-** Allocates and copies the text string of the word.
-**
-***********************************************************************/
+//
+// Intern_UTF8_Managed: C
+//
+// This will "intern" a UTF-8 string, which is to store only one copy of each
+// distinct string value:
+//
+// https://en.wikipedia.org/wiki/String_interning
+//
+// The interning is case-sensitive. But a relationship is set up between
+// instances that are just differently upper-or-lower-"cased". This allows
+// those instances to agree on a single "canon" interning that can be used for
+// fast comparison between them.
+//
+// Interned UTF8 strings are stored as series, and are implicitly managed
+// by the GC (because they are shared). Individual synonyms can be GC'd,
+// including canon forms--in which case the agreed-upon canon for the
+// group will get bumped to one of the other synonyms.
+//
+REBSTR *Intern_UTF8_Managed(const REBYTE *utf8, REBCNT len)
{
- REBCNT pos = SERIES_TAIL(PG_Word_Names);
-
- Append_Mem_Extra(PG_Word_Names, str, len, 1); // so we can do next line...
- PG_Word_Names->tail++; // keep terminator for each string
- return pos;
+ // The hashing technique used is called "linear probing":
+ //
+ // https://en.wikipedia.org/wiki/Linear_probing
+ //
+ // For the hash search to be guaranteed to terminate, the table must be
+ // large enough that we are able to find a NULL if there's a miss. (It's
+ // actually kept larger than that, but to be on the right side of theory,
+ // the table is always checked for expansion needs *before* the search.)
+ //
+ REBCNT size = SER_LEN(PG_Canons_By_Hash);
+ if (PG_Num_Canon_Slots_In_Use > size / 2) {
+ Expand_Word_Table();
+ size = SER_LEN(PG_Canons_By_Hash); // got larger
+ }
+
+ REBSTR* *canons_by_hash = SER_HEAD(REBSER*, PG_Canons_By_Hash);
+
+ // Calculate the starting hash slot to try--and the amount to skip to by
+ // each time a slot is found that is occupied by a non-match.
+ //
+ REBCNT hash = Hash_Word(utf8, len);
+ REBCNT skip = (hash & 0x0000FFFF) % size;
+ if (skip == 0)
+ skip = 1;
+ hash = (hash & 0x00FFFF00) % size;
+
+ REBSTR **deleted_slot = NULL;
+
+ // The hash table only indexes the canon form of each spelling. So when
+ // testing a slot to see if it's a match (or a collision that needs to
+ // be skipped to try again) the search uses a comparison that is
+ // case-insensitive...and returns a value > 0 for a match.
+ //
+ // However, the result also indicates whether it was an *exact* match, by
+ // returning 0 if it is.
+ //
+ REBSTR* canon;
+ while ((canon = canons_by_hash[hash]) != NULL) {
+ if (canon == DELETED_CANON) {
+ deleted_slot = &canons_by_hash[hash];
+ hash += skip;
+ if (hash >= size) hash -= size;
+ continue;
+ }
+
+ assert(GET_SER_INFO(canon, STRING_INFO_CANON));
+
+ // Compare_UTF8 returns 0 when the spelling is a case-sensitive match,
+ // and is the exact interning to return.
+ //
+ REBINT cmp = Compare_UTF8(STR_HEAD(canon), utf8, len);
+ if (cmp == 0) return canon;
+
+ if (cmp < 0) {
+ //
+ // Compare_UTF8 returns less than zero when the canon value in the
+ // slot isn't the same at all. Since it's not a match, skip ahead
+ // to the next candidate slot--wrapping around if necessary
+ //
+ hash += skip;
+ if (hash >= size) hash -= size;
+ continue;
+ }
+
+ // The > 0 result means that the canon word that was found is an
+ // alternate casing ("synonym") for the string we're interning. The
+ // synonyms are attached to the canon form with a circularly linked
+ // list. Walk the list to see if any of the synonyms are a match.
+ //
+ REBSTR *synonym = canon->link.synonym;
+ while (synonym != canon) {
+ assert(synonym->misc.canon == canon);
+ assert(NOT_SER_INFO(synonym, STRING_INFO_CANON));
+
+ // Exact match for a synonym also means no new allocation needed.
+ //
+ cmp = Compare_UTF8(STR_HEAD(synonym), utf8, len);
+ if (cmp == 0) return synonym;
+
+ // Comparison should at least be a synonym, if in this list.
+ // Keep checking for an exact match until a cycle is found.
+ //
+ assert(cmp > 0);
+ synonym = synonym->link.synonym;
+ }
+
+ // If none of the synonyms matched, then this case variation needs
+ // to get its own interning, and point to the canon found.
+
+ assert(canon != NULL);
+ goto new_interning; // break loop, make a new synonym
+ }
+
+ // normal loop fallthrough at canon == NULL - make a new canon form
+ assert(canon == NULL);
+
+new_interning: ; // semicolon needed for statement
+
+ // If possible, the allocation should be fit into a REBSER node with no
+ // separate allocation. Because automatically doing this is a new
+ // feature, double check with an assert that the behavior matches.
+ //
+ REBSTR *intern = Make_Series_Core(
+ len + 1,
+ sizeof(REBYTE),
+ SERIES_FLAG_UTF8_STRING | SERIES_FLAG_FIXED_SIZE
+ );
+
+#if !defined(NDEBUG)
+ if (len + 1 > sizeof(intern->content))
+ assert(GET_SER_INFO(intern, SERIES_INFO_HAS_DYNAMIC));
+ else
+ assert(NOT_SER_INFO(intern, SERIES_INFO_HAS_DYNAMIC));
+#endif
+
+ // The incoming string isn't always null terminated, e.g. if you are
+ // interning `foo` in `foo: bar + 1` it would be colon-terminated.
+ //
+ memcpy(BIN_HEAD(intern), utf8, len);
+ TERM_SEQUENCE_LEN(intern, len);
+
+ if (canon == NULL) {
+ //
+ // There was no canon symbol found, so this interning will be canon.
+ // Add it to the hash table and mark it, reuse deleted slot (if any)
+ //
+ if (deleted_slot) {
+ *deleted_slot = intern; // slot "usage" count stays constant
+
+ #if !defined(NDEBUG)
+ --PG_Num_Canon_Deleteds;
+ #endif
+ }
+ else {
+ canons_by_hash[hash] = intern;
+ ++PG_Num_Canon_Slots_In_Use;
+ }
+
+ SET_SER_INFO(intern, STRING_INFO_CANON);
+
+ intern->link.synonym = intern; // circularly linked list, empty state
+
+ // Canon symbols don't need to cache a canon pointer to themselves.
+ // So instead that slot is reserved for tracking associated information
+ // for the canon word, e.g. the current bind index. Because this
+ // may be used by several threads, it would likely have to be an
+ // atomic pointer that would "pop out" to a structure, but for now
+ // it is just randomized to keep its information in high bits or low
+ // bits as a poor-man's demo that there is an infrastructure in place
+ // for sharing (start with 2, grow to N based on the functions for
+ // 2 being in place)
+ //
+ intern->misc.bind_index.high = 0;
+ intern->misc.bind_index.low = 0;
+
+ // leave header.bits as 0 for SYM_0 as answer to VAL_WORD_SYM()
+ // Startup_Symbols() tags values from %words.r after the fact.
+ }
+ else {
+ // This is a synonym for an existing canon. Link it into the synonyms
+ // circularly linked list, and direct link the canon form.
+ //
+ intern->misc.canon = canon;
+ intern->link.synonym = canon->link.synonym;
+ canon->link.synonym = intern;
+
+ // If the canon form had a SYM_XXX for quick comparison of %words.r
+ // words in C switch statements, the synonym inherits that number.
+ //
+ assert(RIGHT_16_BITS(intern->header.bits) == 0);
+ intern->header.bits |= FLAGUINT16_RIGHT(STR_SYMBOL(canon));
+ }
+
+#if !defined(NDEBUG)
+ REBUPT sym_canon = cast(REBUPT, STR_SYMBOL(STR_CANON(intern)));
+ REBUPT sym = cast(REBUPT, STR_SYMBOL(intern));
+ assert(sym == sym_canon);
+#endif
+
+ // Created series must be managed, because if they were not there could
+ // be no clear contract on the return result--as it wouldn't be possible
+ // to know if a shared instance had been managed by someone else or not.
+ //
+ MANAGE_SERIES(intern);
+ assert(LEFT_N_BITS(intern->header.bits, 4) != 0);
+ return intern;
}
-/***********************************************************************
-**
-*/ REBCNT Make_Word(REBYTE *str, REBCNT len)
-/*
-** Given a string and its length, compute its hash value,
-** search for a match, and if not found, add it to the table.
-** Length of zero indicates you provided a zero terminated string.
-** Return the table index for the word (whether found or new).
-**
-***********************************************************************/
+//
+// GC_Kill_Interning: C
+//
+// Unlink this spelling out of the circularly linked list of synonyms.
+// Further, if it happens to be canon, we need to re-point everything in the
+// chain to a new entry. Choose the synonym as a new canon if so.
+//
+void GC_Kill_Interning(REBSTR *intern)
{
- REBINT hash;
- REBINT size;
- REBINT skip;
- REBINT n;
- REBCNT h;
- REBCNT *hashes;
- REBVAL *words;
- REBVAL *w;
-
- //REBYTE *sss = Get_Sym_Name(1); // (Debugging method)
-
- if (len == 0) len = LEN_BYTES(str);
-
- // If hash part of word table is too dense, expand it:
- if (PG_Word_Table.series->tail > PG_Word_Table.hashes->tail/2)
- Expand_Word_Table();
-
- ASSERT((SERIES_TAIL(PG_Word_Table.series) == SERIES_TAIL(Bind_Table)), RP_BIND_TABLE_SIZE);
-
- // If word symbol part of word table is full, expand it:
- if (SERIES_FULL(PG_Word_Table.series)) {
- Extend_Series(PG_Word_Table.series, 256);
- }
- if (SERIES_FULL(Bind_Table)) {
- Extend_Series(Bind_Table, 256);
- CLEAR_SERIES(Bind_Table);
- }
-
- size = (REBINT)PG_Word_Table.hashes->tail;
- words = BLK_HEAD(PG_Word_Table.series);
- hashes = (REBCNT *)PG_Word_Table.hashes->data;
-
- // Hash the word, including a skip factor for lookup:
- hash = Hash_Word(str, len);
- skip = (hash & 0x0000FFFF) % size;
- if (skip == 0) skip = 1;
- hash = (hash & 0x00FFFF00) % size;
- //Debug_Fmt("%s hash %d skip %d", str, hash, skip);
-
- // Search hash table for word match:
- while (NZ(h = hashes[hash])) {
- while ((n = Compare_UTF8(VAL_SYM_NAME(words+h), str, len)) >= 0) {
- //if (Match_String("script", str, len))
- // Debug_Fmt("---- %s %d %d\n", VAL_SYM_NAME(&words[h]), n, h);
- if (n == 0) return h; // direct hit
- if (VAL_SYM_ALIAS(words+h)) h = VAL_SYM_ALIAS(words+h);
- else goto make_sym; // Create new alias for word
- }
- hash += skip;
- if (hash >= size) hash -= size;
- }
-
-make_sym:
- n = PG_Word_Table.series->tail;
- w = words + n;
- if (h) {
- // Alias word (h = canon word)
- VAL_SYM_ALIAS(words+h) = n;
- VAL_SYM_CANON(w) = VAL_SYM_CANON(words+h);
- } else {
- // Canon (base version of) word (h == 0)
- hashes[hash] = n;
- VAL_SYM_CANON(w) = n;
- }
- VAL_SYM_ALIAS(w) = 0;
- VAL_SYM_NINDEX(w) = Make_Word_Name(str, len);
- VAL_SET(w, REB_HANDLE);
-
- // These are allowed because of the SERIES_FULL checks above which
- // add one extra to the TAIL check comparision. However, their
- // termination values (nulls) will be missing.
- PG_Word_Table.series->tail++;
- Bind_Table->tail++;
-
- return n;
+ REBSER *synonym = intern->link.synonym;
+
+ // Note synonym and intern may be the same here.
+ //
+ REBSER *temp = synonym;
+ while (temp->link.synonym != intern) {
+ if (GET_SER_INFO(intern, STRING_INFO_CANON))
+ temp->misc.canon = synonym;
+ temp = temp->link.synonym;
+ }
+ temp->link.synonym = synonym; // cut intern out of chain (or no-op)
+
+ if (NOT_SER_INFO(intern, STRING_INFO_CANON))
+ return; // for non-canon forms, removing from chain is all you need
+
+ assert(intern->misc.bind_index.high == 0); // shouldn't GC during binds?
+ assert(intern->misc.bind_index.low == 0);
+
+ REBCNT size = SER_LEN(PG_Canons_By_Hash);
+ REBSTR* *canons_by_hash = SER_HEAD(REBSER*, PG_Canons_By_Hash);
+ assert(canons_by_hash != NULL);
+
+ REBCNT len = STR_NUM_BYTES(intern);
+ assert(len == LEN_BYTES(STR_HEAD(intern)));
+
+ REBCNT hash = Hash_Word(STR_HEAD(intern), len);
+ REBCNT skip = (hash & 0x0000FFFF) % size;
+ if (skip == 0) skip = 1;
+ hash = (hash & 0x00FFFF00) % size;
+
+ // We *will* find the canon form in the hash table.
+ //
+ while (canons_by_hash[hash] != intern) {
+ hash += skip;
+ if (hash >= size) hash -= size;
+ }
+
+ if (synonym != intern) {
+ //
+ // If there was a synonym in the circularly linked list distinct from
+ // the canon form, then it gets a promotion to being the canon form.
+ // It should hash the same, and be able to take over the hash slot.
+ //
+ #ifdef SLOW_INTERN_HASH_DOUBLE_CHECK
+ assert(hash == Hash_Word(STR_HEAD(synonym)));
+ #endif
+ canons_by_hash[hash] = synonym;
+ SET_SER_INFO(synonym, STRING_INFO_CANON);
+ synonym->misc.bind_index.low = 0;
+ synonym->misc.bind_index.high = 0;
+ }
+ else {
+ // This canon form must be removed from the hash table. Ripple the
+ // collision slots back until a NULL is found, to reduce search times.
+ //
+ REBCNT previous_hash = hash;
+ while (canons_by_hash[hash] != NULL) {
+ hash += skip;
+ if (hash >= size) hash -= size;
+ canons_by_hash[previous_hash] = canons_by_hash[hash];
+ }
+
+ // Signal that the hash slot is "deleted" via a special pointer.
+ // See notes on DELETED_SLOT for why the final slot in the collision
+ // chain can't just be left NULL:
+ //
+ // http://stackoverflow.com/a/279812/211160
+ //
+ canons_by_hash[previous_hash] = DELETED_CANON;
+
+ #if !defined(NDEBUG)
+ ++PG_Num_Canon_Deleteds; // total use same (PG_Num_Canons_Or_Deleteds)
+ #endif
+ }
}
-/***********************************************************************
-**
-*/ REBCNT Last_Word_Num(void)
-/*
-** Return the number of the last word created. Used to
-** mark a range of canon-words (e.g. operators).
-**
-***********************************************************************/
+//
+// Get_Type_Name: C
+//
+const REBYTE *Get_Type_Name(const RELVAL *value)
{
- return PG_Word_Table.series->tail - 1;
+ return STR_HEAD(Canon(SYM_FROM_KIND(VAL_TYPE(value))));
}
-/***********************************************************************
-**
-*/ void Set_Word(REBVAL *value, REBINT sym, REBSER *frame, REBCNT index)
-/*
-***********************************************************************/
+//
+// Compare_Word: C
+//
+// Compare the names of two words and return the difference.
+// Note that words are kept UTF8 encoded.
+// Positive result if s > t and negative if s < t.
+//
+REBINT Compare_Word(const RELVAL *s, const RELVAL *t, REBOOL strict)
{
- VAL_SET(value, REB_WORD);
- VAL_WORD_SYM(value) = sym;
- VAL_WORD_FRAME(value) = frame;
- VAL_WORD_INDEX(value) = index;
-}
+ const REBYTE *sp = STR_HEAD(VAL_WORD_SPELLING(s));
+ const REBYTE *tp = STR_HEAD(VAL_WORD_SPELLING(t));
+ if (strict)
+ return COMPARE_BYTES(sp, tp); // must match byte-for-byte
-/***********************************************************************
-**
-*/ void Init_Word(REBVAL *value, REBCNT sym)
-/*
-** Initialize a value as a word. Set frame as unbound (no context).
-**
-***********************************************************************/
-{
- VAL_SET(value, REB_WORD);
- VAL_WORD_INDEX(value) = 0;
- VAL_WORD_FRAME(value) = 0;
- VAL_WORD_SYM(value) = sym;
-}
-
-
-/***********************************************************************
-**
-*/ void Init_Frame_Word(REBVAL *value, REBCNT sym)
-/*
-** Initialize as a word list word.
-**
-***********************************************************************/
-{
- VAL_SET(value, REB_WORD);
- VAL_SET_OPT(value, OPTS_UNWORD);
- VAL_BIND_SYM(value) = sym;
- VAL_BIND_TYPESET(value) = ALL_64;
-}
+ if (VAL_WORD_CANON(s) == VAL_WORD_CANON(t))
+ return 0; // equivalent canon forms are considered equal
-
-/***********************************************************************
-**
-*/ REBYTE *Get_Sym_Name(REBCNT num)
-/*
-***********************************************************************/
-{
- if (num == 0 || num >= PG_Word_Table.series->tail) return (REBYTE*)"???";
- return VAL_SYM_NAME(BLK_SKIP(PG_Word_Table.series, num));
+ // They must differ by case....
+ return Compare_UTF8(sp, tp, LEN_BYTES(tp)) + 2;
}
-/***********************************************************************
-**
-*/ REBYTE *Get_Word_Name(REBVAL *value)
-/*
-***********************************************************************/
+//
+// Startup_Interning: C
+//
+// Get the engine ready to do Intern_UTF8_Managed(), which is required to
+// get REBSTR* pointers generated during a scan of ANY-WORD!s. Words of the
+// same spelling currently look up and share the same REBSTR*, this process
+// is referred to as "string interning":
+//
+// https://en.wikipedia.org/wiki/String_interning
+//
+void Startup_Interning(void)
{
- if (value) return Get_Sym_Name(VAL_WORD_SYM(value));
- return (REBYTE*)"(unnamed)";
+ PG_Num_Canon_Slots_In_Use = 0;
+#if !defined(NDEBUG)
+ PG_Num_Canon_Deleteds = 0;
+#endif
+
+ // Start hash table out at a fixed size. When collisions occur, it
+ // causes a skipping pattern that continues until it finds the desired
+ // slot. The method is known as linear probing:
+ //
+ // https://en.wikipedia.org/wiki/Linear_probing
+ //
+ // It must always be at least as big as the total number of words, in order
+ // for it to uniquely be able to locate each symbol pointer. But to
+ // reduce long probing chains, it should be significantly larger than that.
+ // R3-Alpha used a heuristic of 4 times as big as the number of words.
+
+ REBCNT n;
+#if defined(NDEBUG)
+ n = Get_Hash_Prime(WORD_TABLE_SIZE * 4); // extra reduces rehashing
+#else
+ n = 1; // forces exercise of rehashing logic in debug build
+#endif
+
+ PG_Canons_By_Hash = Make_Series_Core(
+ n, sizeof(REBSTR*), SERIES_FLAG_POWER_OF_2
+ );
+ Clear_Series(PG_Canons_By_Hash); // all slots start at NULL
+ SET_SERIES_LEN(PG_Canons_By_Hash, n);
}
-/***********************************************************************
-**
-*/ REBYTE *Get_Type_Name(REBVAL *value)
-/*
-***********************************************************************/
+//
+// Startup_Symbols: C
+//
+// By this point in the boot, the canon words have already been interned for
+// everything in %words.r.
+//
+// This goes through the name series for %words.r words and tags them with
+// SYM_XXX constants. This allows the small number to be quickly extracted to
+// use with VAL_WORD_SYM() in C switch statements. These are the only words
+// that have fixed symbol numbers--others are only managed and compared
+// through their pointers.
+//
+// It also creates a table for mapping from SYM_XXX => REBSTR series. This
+// is used e.g. by Canon(SYM_XXX) to get the string name for a symbol.
+//
+void Startup_Symbols(REBARR *words)
{
- return Get_Sym_Name(VAL_TYPE(value)+1);
+ PG_Symbol_Canons = Make_Series_Core(
+ ARR_LEN(words) + 1, // extra NULL at head for SYM_0
+ sizeof(REBSTR*),
+ SERIES_FLAG_FIXED_SIZE // can't ever add more SYM_XXX lookups
+ );
+
+ // All words that not in %words.r will get back VAL_WORD_SYM(w) == SYM_0
+ // Hence, SYM_0 cannot be canonized. Allowing Canon(SYM_0) to return NULL
+ // and try and use that meaningfully is too risky, so it is simply
+ // prohibited to canonize SYM_0, and trash the REBSTR* in the [0] slot.
+ //
+ REBSYM sym = SYM_0;
+ TRASH_POINTER_IF_DEBUG(
+ *SER_AT(REBSTR*, PG_Symbol_Canons, cast(REBCNT, sym))
+ );
+
+ RELVAL *word = ARR_HEAD(words);
+ for (; NOT_END(word); ++word) {
+ REBSTR *canon = VAL_WORD_CANON(word);
+ assert(GET_SER_INFO(canon, STRING_INFO_CANON));
+
+ sym = cast(REBSYM, cast(REBCNT, sym) + 1);
+ *SER_AT(REBSTR*, PG_Symbol_Canons, cast(REBCNT, sym)) = canon;
+
+ // More code was loaded than just the word list, and it might have
+ // included alternate-case forms of the %words.r words. Walk any
+ // aliases and make sure they have the header bits too.
+
+ REBSTR *name = canon;
+ do {
+ // The low 8 bits of the header are reserved for flags, including
+ // those common between REBSER nodes and REBVALs. The high 8 bits
+ // are used for the size if the series has no dynamic content,
+ // and reserved otherwise. So the shifted-left-by-8 16 bits of
+ // the header are free for the symbol number (could probably use
+ // less than 16 bits, but 8 is insufficient, length %words.r > 256)
+ //
+ assert(RIGHT_16_BITS(name->header.bits) == 0);
+ name->header.bits |= FLAGUINT16_RIGHT(sym);
+ assert(SAME_SYM_NONZERO(STR_SYMBOL(name), sym));
+
+ name = name->link.synonym;
+ } while (name != canon); // circularly linked list, stop on a cycle
+ }
+
+ *SER_AT(REBSTR*, PG_Symbol_Canons, cast(REBCNT, sym)) = NULL; // terminate
+ sym = cast(REBSYM, cast(REBCNT, sym) + 1);
+
+ SET_SERIES_LEN(PG_Symbol_Canons, cast(REBCNT, sym));
+ assert(SER_LEN(PG_Symbol_Canons) == ARR_LEN(words) + 1);
+
+ // Do some sanity checks
+
+ if (COMPARE_BYTES(cb_cast("blank!"), STR_HEAD(Canon(SYM_BLANK_X))) != 0)
+ panic (Canon(SYM_BLANK_X));
+ if (COMPARE_BYTES(cb_cast("true"), STR_HEAD(Canon(SYM_TRUE))) != 0)
+ panic (Canon(SYM_TRUE));
}
-/***********************************************************************
-**
-*/ REBINT Compare_Word(REBVAL *s, REBVAL *t, REBFLG is_case)
-/*
-** Compare the names of two words and return the difference.
-** Note that words are kept UTF8 encoded.
-** Positive result if s > t and negative if s < t.
-**
-***********************************************************************/
+//
+// Shutdown_Symbols: C
+//
+void Shutdown_Symbols(void)
{
- REBYTE *sp = VAL_WORD_NAME(s);
- REBYTE *tp = VAL_WORD_NAME(t);
-
- // Use a more strict comparison than normal:
- if (is_case) return CMP_BYTES(sp, tp);
-
- // They are the equivalent words:
- if (VAL_WORD_CANON(s) == VAL_WORD_CANON(t)) return 0;
-
- // They must be differ by case:
- return Compare_UTF8(sp, tp, LEN_BYTES(tp)) + 2;
+ Free_Series(PG_Symbol_Canons);
}
-/***********************************************************************
-**
-*/ void Init_Words(REBFLG only)
-/*
-** Only flags BIND_Table creation only (for threads).
-**
-***********************************************************************/
+//
+// Shutdown_Interning: C
+//
+void Shutdown_Interning(void)
{
- REBCNT n = Get_Hash_Prime(WORD_TABLE_SIZE * 4); // extra to reduce rehashing
-
- if (!only) {
- // Create the hash for locating words quickly:
- // Note that the TAIL is never changed for this series.
- PG_Word_Table.hashes = Make_Series(n+1, sizeof(REBCNT *), FALSE);
- KEEP_SERIES(PG_Word_Table.hashes, "word hashes"); // pointer array
- Clear_Series(PG_Word_Table.hashes);
- PG_Word_Table.hashes->tail = n;
-
- // The word (symbol) table itself:
- PG_Word_Table.series = Make_Block(WORD_TABLE_SIZE);
- SET_NONE(BLK_HEAD(PG_Word_Table.series)); // Put a NONE at head.
- KEEP_SERIES(PG_Word_Table.series, "word table"); // words are never GC'd
- BARE_SERIES(PG_Word_Table.series); // don't bother to GC scan it
- PG_Word_Table.series->tail = 1; // prevent the zero case
-
- // A normal char array to hold symbol names:
- PG_Word_Names = Make_Binary(6 * WORD_TABLE_SIZE); // average word size
- KEEP_SERIES(PG_Word_Names, "word names");
- }
-
- // The bind table. Used to cache context indexes for given symbols.
- Bind_Table = Make_Series(SERIES_REST(PG_Word_Table.series), 4, FALSE);
- KEEP_SERIES(Bind_Table, "bind table"); // numeric table
- CLEAR_SERIES(Bind_Table);
- Bind_Table->tail = PG_Word_Table.series->tail;
+ assert(PG_Num_Canon_Slots_In_Use - PG_Num_Canon_Deleteds == 0);
+ Free_Series(PG_Canons_By_Hash);
}
diff --git a/src/core/d-break.c b/src/core/d-break.c
new file mode 100644
index 0000000000..4bec92d447
--- /dev/null
+++ b/src/core/d-break.c
@@ -0,0 +1,494 @@
+//
+// Rebol 3 Language Interpreter and Run-time Environment
+// "Ren-C" branch @ https://github.com/metaeducation/ren-c
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Summary: Debug Breaking and Resumption
+// File: %d-break.h
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2015-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// This file contains interactive debugging support for breaking and
+// resuming. The instructions BREAKPOINT and PAUSE are natives which will
+// call a host environment hook which can then begin an interactive debugging
+// session. During that time Rebol functions may continue to be called,
+// though there is a sandbox which prevents the code from throwing or causing
+// errors which will propagate past the breakpoint. The only way to
+// resume normal operation is with a "resume instruction".
+//
+// !!! Interactive debugging is a work in progress, and comments are in the
+// functions below.
+//
+
+#include "sys-core.h"
+
+
+//
+// Index values for the properties in a "resume instruction" (see notes on
+// REBNATIVE(resume))
+//
+enum {
+ RESUME_INST_MODE = 0, // FALSE if /WITH, TRUE if /DO, NONE! if default
+ RESUME_INST_PAYLOAD, // code block to /DO or value of /WITH
+ RESUME_INST_TARGET, // unwind target, NONE! to return from breakpoint
+ RESUME_INST_MAX
+};
+
+
+//
+// Do_Breakpoint_Throws: C
+//
+// A call to Do_Breakpoint_Throws does delegation to a hook in the host, which
+// (if registered) will generally start an interactive session for probing the
+// environment at the break. The RESUME native cooperates by being able to
+// give back a value (or give back code to run to produce a value) that the
+// call to breakpoint returns.
+//
+// RESUME has another feature, which is to be able to actually unwind and
+// simulate a return /AT a function *further up the stack*. (This may be
+// switched to a feature of a "step out" command at some point.)
+//
+REBOOL Do_Breakpoint_Throws(
+ REBVAL *out,
+ REBOOL interrupted, // Ctrl-C (as opposed to a BREAKPOINT)
+ const REBVAL *default_value,
+ REBOOL do_default
+) {
+ const REBVAL *target = BLANK_VALUE;
+
+ if (!PG_Breakpoint_Quitting_Hook) {
+ //
+ // Host did not register any breakpoint handler, so raise an error
+ // about this as early as possible.
+ //
+ fail (Error_Host_No_Breakpoint_Raw());
+ }
+
+ DECLARE_LOCAL (temp);
+
+ // We call the breakpoint hook in a loop, in order to keep running if any
+ // inadvertent FAILs or THROWs occur during the interactive session.
+ // Only a conscious call of RESUME speaks the protocol to break the loop.
+ //
+ while (TRUE) {
+ struct Reb_State state;
+ REBCTX *error;
+
+ push_trap:
+ PUSH_TRAP(&error, &state);
+
+ // The host may return a block of code to execute, but cannot
+ // while evaluating do a THROW or a FAIL that causes an effective
+ // "resumption". Halt is the exception, hence we PUSH_TRAP and
+ // not PUSH_UNHALTABLE_TRAP. QUIT is also an exception, but a
+ // desire to quit is indicated by the return value of the breakpoint
+ // hook (which may or may not decide to request a quit based on the
+ // QUIT command being run).
+ //
+ // The core doesn't want to get involved in presenting UI, so if
+ // an error makes it here and wasn't trapped by the host first that
+ // is a bug in the host. It should have done its own PUSH_TRAP.
+ //
+ if (error) {
+ #if !defined(NDEBUG)
+ printf("Error not trapped during breakpoint\n");
+ panic (error);
+ #endif
+
+ // In release builds, if an error managed to leak out of the
+ // host's breakpoint hook somehow...just re-push the trap state
+ // and try it again.
+ //
+ goto push_trap;
+ }
+
+ // Call the host's breakpoint hook.
+ //
+ // The DECLARE_LOCAL is here and not outside the loop
+ // due to wanting to avoid "longjmp clobbering" warnings
+ // (seen in optimized builds on Android).
+ //
+ DECLARE_LOCAL (inst);
+ if (PG_Breakpoint_Quitting_Hook(inst, interrupted)) {
+ //
+ // If a breakpoint hook returns TRUE that means it wants to quit.
+ // The value should be the /WITH value (as in QUIT/WITH), so
+ // not actually a "resume instruction" in this case.
+ //
+ assert(!THROWN(inst));
+ Move_Value(out, NAT_VALUE(quit));
+ CONVERT_NAME_TO_THROWN(out, inst);
+ return TRUE; // TRUE = threw
+ }
+
+ // If a breakpoint handler returns FALSE, then it should have passed
+ // back a "resume instruction" triggered by a call like:
+ //
+ // resume/do [fail "This is how to fail from a breakpoint"]
+ //
+ // So now that the handler is done, we will allow any code handed back
+ // to do whatever FAIL it likes vs. trapping that here in a loop.
+ //
+ DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
+
+ // Decode and process the "resume instruction"
+
+ #if !defined(NDEBUG)
+ REBOOL found = FALSE;
+ #endif
+
+ assert(IS_GROUP(inst));
+ assert(VAL_LEN_HEAD(inst) == RESUME_INST_MAX);
+
+ // The instruction was built from raw material, non-relative
+ //
+ REBVAL *mode = KNOWN(VAL_ARRAY_AT_HEAD(inst, RESUME_INST_MODE));
+ REBVAL *payload
+ = KNOWN(VAL_ARRAY_AT_HEAD(inst, RESUME_INST_PAYLOAD));
+ target = KNOWN(VAL_ARRAY_AT_HEAD(inst, RESUME_INST_TARGET));
+
+ assert(IS_FRAME(target));
+
+ // The first thing we need to do is determine if the target we
+ // want to return to has another breakpoint sandbox blocking
+ // us. If so, what we need to do is actually retransmit the
+ // resume instruction so it can break that wall, vs. transform
+ // it into an EXIT/FROM that would just get intercepted.
+ //
+ REBFRM *frame;
+ for (frame = FS_TOP; frame != NULL; frame = frame->prior) {
+ if (NOT(Is_Any_Function_Frame(frame)))
+ continue;
+ if (Is_Function_Frame_Fulfilling(frame))
+ continue;
+
+ if (
+ frame != FS_TOP
+ && (
+ FUNC_DISPATCHER(frame->phase) == &N_pause
+ || FUNC_DISPATCHER(frame->phase) == &N_breakpoint
+ )
+ ) {
+ // We hit a breakpoint (that wasn't this call to
+ // breakpoint, at the current FS_TOP) before finding
+ // the sought after target. Retransmit the resume
+ // instruction so that level will get it instead.
+ //
+ Move_Value(out, NAT_VALUE(resume));
+ CONVERT_NAME_TO_THROWN(out, inst);
+ return TRUE; // TRUE = thrown
+ }
+
+ // If the frame were the one we were looking for, it would be
+ // reified (so it would have a context to match)
+ //
+ if (frame->varlist == NULL)
+ continue;
+
+ if (VAL_CONTEXT(target) == CTX(frame->varlist)) {
+ // Found a match before hitting any breakpoints, so no
+ // need to retransmit.
+ //
+ #if !defined(NDEBUG)
+ found = TRUE;
+ #endif
+ break;
+ }
+ }
+
+ // RESUME should not have been willing to use a target that
+ // is not on the stack.
+ //
+ #if !defined(NDEBUG)
+ assert(found);
+ #endif
+
+ if (IS_BLANK(mode)) {
+ //
+ // If the resume instruction had no /DO or /WITH of its own,
+ // then it doesn't override whatever the breakpoint provided
+ // as a default. (If neither the breakpoint nor the resume
+ // provided a /DO or a /WITH, result will be void.)
+ //
+ goto return_default; // heeds `target`
+ }
+
+ assert(IS_LOGIC(mode));
+
+ if (VAL_LOGIC(mode)) {
+ if (Do_Any_Array_At_Throws(temp, payload)) {
+ //
+ // Throwing is not compatible with /AT currently.
+ //
+ if (!IS_BLANK(target))
+ fail (Error_No_Catch_For_Throw(temp));
+
+ // Just act as if the BREAKPOINT call itself threw
+ //
+ Move_Value(out, temp);
+ return TRUE; // TRUE = thrown
+ }
+
+ // Ordinary evaluation result...
+ }
+ else
+ Move_Value(temp, payload);
+
+ // The resume instruction will be GC'd.
+ //
+ goto return_temp;
+ }
+
+ DEAD_END;
+
+return_default:
+
+ if (do_default) {
+ if (Do_Any_Array_At_Throws(temp, default_value)) {
+ //
+ // If the code throws, we're no longer in the sandbox...so we
+ // bubble it up. Note that breakpoint runs this code at its
+ // level... so even if you request a higher target, any throws
+ // will be processed as if they originated at the BREAKPOINT
+ // frame. To do otherwise would require the EXIT/FROM protocol
+ // to add support for DO-ing at the receiving point.
+ //
+ Move_Value(out, temp);
+ return TRUE; // TRUE = thrown
+ }
+ }
+ else
+ Move_Value(temp, default_value); // generally void if no /WITH
+
+return_temp:
+ //
+ // If the target is a function, then we're looking to simulate a return
+ // from something up the stack. This uses the same mechanic as
+ // definitional returns--a throw named by the function or closure frame.
+ //
+ // !!! There is a weak spot in definitional returns for FUNCTION! that
+ // they can only return to the most recent invocation; which is a weak
+ // spot of FUNCTION! in general with stack relative variables. Also,
+ // natives do not currently respond to definitional returns...though
+ // they can do so just as well as FUNCTION! can.
+ //
+ Make_Thrown_Exit_Value(out, target, temp, NULL);
+ return TRUE; // TRUE = thrown
+}
+
+
+//
+// breakpoint: native [
+//
+// "Signal breakpoint to the host (simple variant of PAUSE dialect)"
+//
+// return: [ any-value!]
+// "Returns the value passed to RESUME/WITH (or void by default)"
+// ]
+//
+REBNATIVE(breakpoint)
+//
+// The reason BREAKPOINT needs to exist as a native is to be recognized by
+// BACKTRACE as being a "0" stack level (e.g. probably not interesting to be
+// where you are probing variables). Backtrace should not *always* skip the
+// most recent stack level however, because of a "Ctrl-C"-like debugging
+// break, where the most recent stack level *is* the one to inspect.
+{
+ if (Do_Breakpoint_Throws(
+ D_OUT,
+ FALSE, // not a Ctrl-C, it's an actual BREAKPOINT
+ VOID_CELL, // default result if RESUME does not override
+ FALSE // !execute (don't try to evaluate the VOID_CELL)
+ )) {
+ return R_OUT_IS_THROWN;
+ }
+
+ return R_OUT;
+}
+
+
+//
+// pause: native [
+//
+// "Pause in the debugger before running the provided code"
+//
+// return: [ any-value!]
+// "Result of the code evaluation, or RESUME/WITH value if override"
+// :code [group!] ;-- or LIT-WORD! name or BLOCK! for dialect
+// "Run the given code if breakpoint does not override"
+// ]
+//
+REBNATIVE(pause)
+{
+ INCLUDE_PARAMS_OF_PAUSE;
+
+ if (Do_Breakpoint_Throws(
+ D_OUT,
+ FALSE, // not a Ctrl-C, it's an actual BREAKPOINT
+ ARG(code), // default result if RESUME does not override
+ TRUE // execute (run the GROUP! as code, don't return as-is)
+ )) {
+ return R_OUT_IS_THROWN;
+ }
+
+ return R_OUT;
+}
+
+
+//
+// resume: native [
+//
+// {Resume after a breakpoint, can evaluate code in the breaking context.}
+//
+// /with
+// "Return the given value as return value from BREAKPOINT"
+// value [any-value!]
+// "Value to use"
+// /do
+// "Evaluate given code as return value from BREAKPOINT"
+// code [block!]
+// "Code to evaluate"
+// /at
+// "Return from another call up stack besides the breakpoint"
+// level [frame! function! integer!]
+// "Stack level to target in unwinding (can be BACKTRACE #)"
+// ]
+//
+REBNATIVE(resume)
+//
+// The host breakpoint hook makes a wall to prevent arbitrary THROWs and
+// FAILs from ending the interactive inspection. But RESUME is special, and
+// it makes a very specific instruction (with a throw /NAME of the RESUME
+// native) to signal a desire to end the interactive session.
+//
+// When the BREAKPOINT native gets control back from the hook, it interprets
+// and executes the instruction. This offers the additional benefit that
+// each host doesn't have to rewrite interpretation in the hook--they only
+// need to recognize a RESUME throw and pass the argument back.
+{
+ INCLUDE_PARAMS_OF_RESUME;
+
+ if (REF(with) && REF(do)) {
+ //
+ // /WITH and /DO both dictate a default return result, (/DO evaluates
+ // and /WITH does not) They are mutually exclusive.
+ //
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ // We don't actually want to run the code for a /DO here. If we tried
+ // to run code from this stack level--and it failed or threw without
+ // some special protocol--we'd stay stuck in the breakpoint's sandbox.
+ //
+ // The /DO code we received needs to actually be run by the host's
+ // breakpoint hook, once it knows that non-local jumps to above the break
+ // level (throws, returns, fails) actually intended to be "resuming".
+
+ REBARR *instruction = Make_Array(RESUME_INST_MAX);
+
+ if (REF(with)) {
+ Init_Logic(ARR_AT(instruction, RESUME_INST_MODE), FALSE); // don't DO
+ Move_Value(
+ SINK(ARR_AT(instruction, RESUME_INST_PAYLOAD)), ARG(value)
+ );
+ }
+ else if (REF(do)) {
+ Init_Logic(ARR_AT(instruction, RESUME_INST_MODE), TRUE); // DO value
+ Move_Value(
+ SINK(ARR_AT(instruction, RESUME_INST_PAYLOAD)), ARG(code)
+ );
+ }
+ else {
+ Init_Blank(ARR_AT(instruction, RESUME_INST_MODE)); // use default
+
+ // Even though this slot should be ignored, use BAR! to try and make
+ // any attempts to use it more conspicuous (an unset wouldn't be)
+ //
+ Init_Bar(ARR_AT(instruction, RESUME_INST_PAYLOAD));
+ }
+
+ // We want BREAKPOINT to resume /AT a higher stack level (using the
+ // same machinery that definitionally-scoped return would to do it).
+ // Frames will be reified as necessary.
+ //
+ REBFRM *frame;
+
+ if (REF(at)) {
+ //
+ // `level` is currently allowed to be anything that backtrace can
+ // handle (integers, functions for most recent call, literal FRAME!)
+
+ if (!(frame = Frame_For_Stack_Level(NULL, ARG(level), TRUE)))
+ fail (ARG(level));
+
+ // !!! It's possible to specify a context to return at which is
+ // "underneath" a breakpoint. So being at a breakpoint and doing
+ // `if true [resume/at :if]` would try and specify the IF running
+ // in the interactive breakpoint session. The instruction will
+ // error with no breakpoint to catch the resume...but a better error
+ // could be given here if the case were detected early.
+ }
+ else {
+ // We just want a BREAKPOINT or PAUSE themselves to return, so find
+ // the most recent one (if any, error if none found).
+
+ frame = FS_TOP;
+ for (; frame != NULL; frame = frame->prior) {
+ if (NOT(Is_Any_Function_Frame(frame))) continue;
+ if (Is_Function_Frame_Fulfilling(frame)) continue;
+
+ if (
+ FUNC_DISPATCHER(frame->phase) == &N_pause
+ || FUNC_DISPATCHER(frame->phase) == &N_breakpoint
+ ) {
+ break;
+ }
+ }
+
+ if (frame == NULL)
+ fail (Error_No_Current_Pause_Raw());
+ }
+
+ Init_Any_Context(
+ ARR_AT(instruction, RESUME_INST_TARGET),
+ REB_FRAME,
+ Context_For_Frame_May_Reify_Managed(frame)
+ );
+
+ TERM_ARRAY_LEN(instruction, RESUME_INST_MAX);
+
+ // We put the resume instruction into a GROUP! just to make it a little
+ // bit more unusual than a BLOCK!. More hardened approaches might put
+ // a special symbol as a "magic number" or somehow version the protocol,
+ // but for now we'll assume that the only decoder is BREAKPOINT and it
+ // will be kept in sync.
+ //
+ DECLARE_LOCAL (cell);
+ Init_Group(cell, instruction);
+
+ // Throw the instruction with the name of the RESUME function
+ //
+ Move_Value(D_OUT, NAT_VALUE(resume));
+ CONVERT_NAME_TO_THROWN(D_OUT, cell);
+ return R_OUT_IS_THROWN;
+}
diff --git a/src/core/d-crash.c b/src/core/d-crash.c
index 32d8b44b6c..f2acff671d 100644
--- a/src/core/d-crash.c
+++ b/src/core/d-crash.c
@@ -1,131 +1,175 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: d-crash.c
-** Summary: low level crash output
-** Section: debug
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %d-crash.c
+// Summary: "low level crash output"
+// Section: debug
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#define CRASH_BUF_SIZE 512 // space for crash print string
-
-extern const REBYTE * const Crash_Msgs[];
-
-enum Crash_Msg_Nums {
- // Must align with Crash_Msgs[] array.
- CM_ERROR,
- CM_BOOT,
- CM_INTERNAL,
- CM_ASSERT,
- CM_DATATYPE,
- CM_DEBUG,
- CM_CONTACT
-};
-
-
-/***********************************************************************
-**
-*/ void Crash(REBINT id, ...)
-/*
-** Print a failure message and abort.
-**
-** LATIN1 ONLY!! (For now)
-**
-** The error is identified by id number, which can reference an
-** error message string in the boot strings block.
-**
-** Note that lower level error messages should not attempt to
-** use the %r (mold value) format (uses higher level functions).
-**
-** See panics.h for list of crash errors.
-**
-***********************************************************************/
-{
- va_list args;
- REBYTE buf[CRASH_BUF_SIZE];
- REBYTE *msg;
- REBINT n = 0;
-
- va_start(args, id);
-
- DISABLE_GC;
- if (Reb_Opts->crash_dump) {
- Dump_Info();
- Dump_Stack(0, 0);
- }
-
- // "REBOL PANIC #nnn:"
- COPY_BYTES(buf, Crash_Msgs[CM_ERROR], CRASH_BUF_SIZE);
- APPEND_BYTES(buf, " #", CRASH_BUF_SIZE);
- Form_Int(buf + LEN_BYTES(buf), id);
- APPEND_BYTES(buf, ": ", CRASH_BUF_SIZE);
-
- // "REBOL PANIC #nnn: put error message here"
- // The first few error types only print general error message.
- // Those errors > RP_STR_BASE have specific error messages (from boot.r).
- if (id < RP_BOOT_DATA) n = CM_DEBUG;
- else if (id < RP_INTERNAL) n = CM_BOOT;
- else if (id < RP_ASSERTS) n = CM_INTERNAL;
- else if (id < RP_DATATYPE) n = CM_ASSERT;
- else if (id < RP_STR_BASE) n = CM_DATATYPE;
- else if (id > RP_STR_BASE + RS_MAX - RS_ERROR) n = CM_DEBUG;
-
- // Use the above string or the boot string for the error (in boot.r):
- msg = (REBYTE*)(n >= 0 ? Crash_Msgs[n] : BOOT_STR(RS_ERROR, id - RP_STR_BASE - 1));
- Form_Var_Args(buf + LEN_BYTES(buf), CRASH_BUF_SIZE - 1 - LEN_BYTES(buf), msg, args);
-
- APPEND_BYTES(buf, Crash_Msgs[CM_CONTACT], CRASH_BUF_SIZE);
-
- // Convert to OS-specific char-type:
-#ifdef disable_for_now //OS_WIDE_CHAR /// win98 does not support it
- {
- REBCHR s1[512];
- REBCHR s2[2000];
-
- n = TO_OS_STR(s1, Crash_Msgs[CM_ERROR], LEN_BYTES(Crash_Msgs[CM_ERROR]));
- if (n > 0) s1[n] = 0; // terminate
- else OS_EXIT(200); // bad conversion
-
- n = TO_OS_STR(s2, buf, LEN_BYTES(buf));
- if (n > 0) s2[n] = 0;
- else OS_EXIT(200);
-
- OS_CRASH(s1, s2);
- }
+
+// Size of crash buffers
+#define PANIC_TITLE_BUF_SIZE 80
+#define PANIC_BUF_SIZE 512
+
+
+//
+// Panic_Core: C
+//
+// See comments on `panic (...)` macro, which calls this routine.
+//
+ATTRIBUTE_NO_RETURN void Panic_Core(
+ const void *p, // REBSER* (array, context, etc), REBVAL*, or UTF-8 char*
+ const char *file,
+ int line
+) {
+ if (p == NULL)
+ p = "panic (...) was passed NULL"; // avoid later NULL tests
+
+ // We are crashing, so a legitimate time to be disabling the garbage
+ // collector. (It won't be turned back on.)
+ //
+ GC_Disabled = TRUE;
+
+#if defined(NDEBUG)
+ UNUSED(file);
+ UNUSED(line);
#else
- OS_CRASH(Crash_Msgs[CM_ERROR], buf);
+ //
+ // First thing's first in the debug build, make sure the file and the
+ // line are printed out.
+ //
+ printf("C Source File %s, Line %d\n", file, line);
+
+ // Generally Rebol does not #include , but the debug build does.
+ // It's often used for debug spew--as opposed to Debug_Fmt()--when there
+ // is a danger of causing recursive errors if the problem is being caused
+ // by I/O in the first place. So flush anything lingering in the
+ // standard output or error buffers
+ //
+ fflush(stdout);
+ fflush(stderr);
#endif
-}
-/***********************************************************************
-**
-*/ void NA(void)
-/*
-** Feature not available.
-**
-***********************************************************************/
-{
- Crash(RP_NA);
+ // Because the release build of Rebol does not link to printf or its
+ // support functions, the crash buf is assembled into a buffer for
+ // raw output through the host.
+ //
+ char title[PANIC_TITLE_BUF_SIZE + 1]; // account for null terminator
+ char buf[PANIC_BUF_SIZE + 1]; // "
+
+ title[0] = '\0';
+ buf[0] = '\0';
+
+#if !defined(NDEBUG)
+ if (Reb_Opts && Reb_Opts->crash_dump) {
+ Dump_Info();
+ Dump_Stack(NULL, 0);
+ }
+#endif
+
+ strncat(title, "PANIC()", PANIC_TITLE_BUF_SIZE - 0);
+
+ strncat(buf, Str_Panic_Directions, PANIC_BUF_SIZE - 0);
+
+ strncat(buf, "\n", PANIC_BUF_SIZE - strlen(buf));
+
+ switch (Detect_Rebol_Pointer(p)) {
+ case DETECTED_AS_UTF8: // string might be empty...handle specially?
+ strncat(
+ buf,
+ cast(const char*, p),
+ PANIC_BUF_SIZE - strlen(buf)
+ );
+ break;
+
+ case DETECTED_AS_SERIES: {
+ REBSER *s = m_cast(REBSER*, cast(const REBSER*, p)); // don't mutate
+ #if !defined(NDEBUG)
+ #if 0
+ //
+ // It can sometimes be useful to probe here if the series is
+ // valid, but if it's not valid then that could result in a
+ // recursive call to panic and a stack overflow.
+ //
+ PROBE(s);
+ #endif
+
+ if (GET_SER_FLAG(s, ARRAY_FLAG_VARLIST)) {
+ printf("Series VARLIST detected.\n");
+ REBCTX *context = CTX(s);
+ if (CTX_TYPE(context) == REB_ERROR) {
+ printf("...and that VARLIST is of an ERROR!...");
+ PROBE(context);
+ }
+ }
+ Panic_Series_Debug(cast(REBSER*, s));
+ #else
+ UNUSED(s);
+ strncat(buf, "valid series", PANIC_BUF_SIZE - strlen(buf));
+ #endif
+ break; }
+
+ case DETECTED_AS_FREED_SERIES:
+ #if !defined(NDEBUG)
+ Panic_Series_Debug(m_cast(REBSER*, cast(const REBSER*, p)));
+ #endif
+ strncat(buf, "freed series", PANIC_BUF_SIZE - strlen(buf));
+ break;
+
+ case DETECTED_AS_VALUE:
+ case DETECTED_AS_END:
+ #if !defined(NDEBUG)
+ Panic_Value_Debug(cast(const REBVAL*, p));
+ #else
+ strncat(buf, "value", PANIC_BUF_SIZE - strlen(buf));
+ #endif
+ break;
+
+ case DETECTED_AS_TRASH_CELL:
+ #if !defined(NDEBUG)
+ Panic_Value_Debug(cast(const RELVAL*, p));
+ #endif
+ strncat(buf, "trash cell", PANIC_BUF_SIZE - strlen(buf));
+ break;
+ }
+
+#if !defined(NDEBUG)
+ //
+ // In a debug build, we'd like to try and cause a break so as not to lose
+ // the state of the panic, which would happen if we called out to the
+ // host kit's exit routine...
+ //
+ printf("%s\n", Str_Panic_Title);
+ printf("%s\n", buf);
+ fflush(stdout);
+ debug_break(); // see %debug_break.h
+#endif
+
+ OS_CRASH(cb_cast(Str_Panic_Title), cb_cast(buf));
+
+ DEAD_END;
}
diff --git a/src/core/d-dump.c b/src/core/d-dump.c
index 3e879e0172..d5a5b8905b 100644
--- a/src/core/d-dump.c
+++ b/src/core/d-dump.c
@@ -1,399 +1,320 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: d-dump.c
-** Summary: various debug output functions
-** Section: debug
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %d-dump.c
+// Summary: "various debug output functions"
+// Section: debug
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Most of these low-level debug routines were leftovers from R3-Alpha, which
+// had no DEBUG build (and was perhaps frequently debugged without an IDE
+// debugger). After the open source release, Ren-C's reliance is on a
+// more heavily checked debug build...so these routines were not used.
+//
+// They're being brought up to date to be included in the debug build only
+// version of panic(). That should keep them in working shape.
+//
+// Note: These routines use `printf()`, which is only linked in DEBUG builds.
+// Higher-level Rebol formatting should ultimately be using BLOCK! dialects,
+// as opposed to strings with %s and %d. Bear in mind the "z" modifier in
+// printf is unavailable in C89, so if something might be 32-bit or 64-bit
+// depending, it must be cast to unsigned long:
+//
+// http://stackoverflow.com/q/2125845
+//
#include "sys-core.h"
+#include "mem-series.h" // low-level series memory access
+#if !defined(NDEBUG)
-/***********************************************************************
-**
-*/ void Dump_Series(REBSER *series, REBYTE *memo)
-/*
-***********************************************************************/
-{
- if (!series) return;
- Debug_Fmt(
- Str_Dump[0], //"%s Series %x %s: Wide: %2d Size: %6d - Bias: %d Tail: %d Rest: %d Flags: %x"
- memo,
- series,
- (SERIES_LABEL(series) ? SERIES_LABEL(series) : "-"),
- SERIES_WIDE(series),
- SERIES_TOTAL(series),
- SERIES_BIAS(series),
- SERIES_TAIL(series),
- SERIES_REST(series),
- SERIES_FLAGS(series)
- );
- if (SERIES_WIDE(series) == sizeof(REBVAL))
- Dump_Values(BLK_HEAD(series), SERIES_TAIL(series));
- else
- Dump_Bytes(series->data, (SERIES_TAIL(series)+1) * SERIES_WIDE(series));
-}
+#ifdef _MSC_VER
+#define snprintf _snprintf
+#endif
-/***********************************************************************
-**
-*/ void Dump_Bytes(REBYTE *bp, REBCNT limit)
-/*
-***********************************************************************/
-{
- const max_lines = 120;
- REBYTE buf[2048];
- REBYTE str[40];
- REBYTE *cp, *tp;
- REBYTE c;
- REBCNT l, n;
- REBCNT cnt = 0;
-
- cp = buf;
- for (l = 0; l < max_lines; l++) {
- cp = Form_Hex_Pad(cp, (REBCNT) bp, 8);
-
- *cp++ = ':';
- *cp++ = ' ';
- tp = str;
-
- for (n = 0; n < 16; n++) {
- if (cnt++ >= limit) break;
- c = *bp++;
- cp = Form_Hex2(cp, c);
- if ((n & 3) == 3) *cp++ = ' ';
- if ((c < 32) || (c > 126)) c = '.';
- *tp++ = c;
- }
-
- for (; n < 16; n++) {
- c = ' ';
- *cp++ = c;
- *cp++ = c;
- if ((n & 3) == 3) *cp++ = ' ';
- if ((c < 32) || (c > 126)) c = '.';
- *tp++ = c;
- }
- *tp++ = 0;
-
- for (tp = str; *tp;) *cp++ = *tp++;
-
- *cp = 0;
- Debug_Str(buf);
- if (cnt >= limit) break;
- cp = buf;
- }
-}
-/***********************************************************************
-**
-*/ void Dump_Values(REBVAL *vp, REBCNT count)
-/*
-** Print out values in raw hex; If memory is corrupted
-** this function still needs to work.
-**
-***********************************************************************/
+//
+// Dump_Bytes: C
+//
+void Dump_Bytes(REBYTE *bp, REBCNT limit)
{
- REBYTE buf[2048];
- REBYTE *cp;
- REBCNT l, n;
- REBCNT *bp = (REBCNT*)vp;
- REBYTE *type;
-
- cp = buf;
- for (l = 0; l < count; l++) {
- cp = Form_Hex_Pad(cp, (REBCNT) l, 4);
- *cp++ = ':';
- *cp++ = ' ';
-
- type = Get_Type_Name((REBVAL*)bp);
- for (n = 0; n < 11; n++) {
- if (*type) *cp++ = *type++;
- else *cp++ = ' ';
- }
- *cp++ = ' ';
- for (n = 0; n < 4; n++) {
- cp = Form_Hex_Pad(cp, *bp++, 8);
- *cp++ = ' ';
- }
-
- *cp = 0;
- Debug_Str(buf);
- cp = buf;
- }
-}
+ const REBCNT max_lines = 120;
-#ifdef not_used
-/***********************************************************************
-**
-xx*/ void Dump_Block_Raw(REBSER *series, int depth, int max_depth)
-/*
-***********************************************************************/
-{
- REBVAL *val;
- REBCNT n;
- REBYTE *str;
-
- if (!IS_BLOCK_SERIES(series) || depth > max_depth) return;
-
- for (n = 0, val = BLK_HEAD(series); NOT_END(val); val++, n++) {
- Debug_Chars(' ', depth * 4);
- if (IS_BLOCK(val)) {
- Debug_Fmt("%3d: [%s] len: %d", n, Get_Type_Name(val), VAL_TAIL(val));
- Dump_Block_Raw(VAL_SERIES(val), depth + 1, max_depth);
- } else {
- str = "";
- if (ANY_WORD(val)) str = Get_Word_Name(val);
- Debug_Fmt("%3d: [%s] %s", n, Get_Type_Name(val), str);
- }
- }
- //if (depth == 2) Input_Str();
-}
+ REBCNT total = 0;
-/***********************************************************************
-**
-xx*/ REBSER *Dump_Value(REBVAL *block, REBSER *series)
-/*
-** Dump a values's contents for debugging purposes.
-**
-***********************************************************************/
-{
- REB_MOLD mo = {0};
- mo.digits = 17; // max digits
+ REBYTE buf[2048];
- if (VAL_TYPE(block) >= REB_MAX) Crash(RP_DATATYPE+7, VAL_TYPE(block));
+ REBCNT l = 0;
+ for (; l < max_lines; l++) {
+ REBYTE *cp = buf;
- ASSERT2(series, 9997);
- mo.series = series;
- Emit(&mo, "T: ", block);
+ cp = Form_Hex_Pad(cp, cast(REBUPT, bp), 8);
- Mold_Value(&mo, block, TRUE);
+ *cp++ = ':';
+ *cp++ = ' ';
- if (ANY_WORD(block)) {
- if (!VAL_WORD_FRAME(block)) Append_Bytes(series, " - unbound");
- else if (VAL_WORD_INDEX(block) < 0) Append_Bytes(series, " - relative");
- else Append_Bytes(series, " - absolute");
- }
- return series;
-}
+ REBYTE str[40];
+ REBYTE *tp = str;
+ REBCNT n = 0;
+ for (; n < 16; n++) {
+ if (total++ >= limit)
+ break;
-/***********************************************************************
-**
-xx*/ void Print_Dump_Value(REBVAL *value, REBYTE *label)
-/*
-** Dump a value's contents for debugging purposes.
-**
-***********************************************************************/
-{
- REBSER *series;
- series = Copy_Bytes(label, -1);
- SAVE_SERIES(series);
- series = Dump_Value(value, series);
- Debug_Str(STR_HEAD(series));
- UNSAVE_SERIES(series);
-}
+ REBYTE c = *bp++;
+ cp = Form_Hex2(cp, c);
+ if ((n & 3) == 3)
+ *cp++ = ' ';
+ if ((c < 32) || (c > 126))
+ c = '.';
+ *tp++ = c;
+ }
+ for (; n < 16; n++) {
+ REBYTE c = ' ';
+ *cp++ = c;
+ *cp++ = c;
+ if ((n & 3) == 3)
+ *cp++ = ' ';
+ if ((c < 32) || (c > 126))
+ c = '.';
+ *tp++ = c;
+ }
-/***********************************************************************
-**
-xx*/ void Dump_Block(REBVAL *blk, REBINT len)
-/*
-** Dump a block's contents for debugging purposes.
-**
-***********************************************************************/
-{
- REBSER *series;
- //REBVAL *blk = BLK_HEAD(block);
-
- //Print("BLOCK: %x Tail: %d Size: %d", block, block->tail, block->rest);
- // change to a make string!!! no need to append to a series, this is a debug function
- series = Make_Binary(100);
- Append_Bytes(series, "[\n");
- while (NOT_END(blk) && len-- > 0) {
- Append_Byte(series, '\t');
- Dump_Value(blk, series);
- Append_Byte(series, '\n');
- blk++;
- }
- Append_Byte(series, ']');
- *STR_TAIL(series) = 0;
- Debug_Str(STR_HEAD(series));
-}
+ *tp++ = 0;
+ for (tp = str; *tp;)
+ *cp++ = *tp++;
-/***********************************************************************
-**
-xx*/ void Dump_Frame(REBSER *frame, REBINT limit)
-/*
-***********************************************************************/
-{
- REBINT n;
- REBVAL *values = FRM_VALUES(frame);
- REBVAL *words = FRM_WORDS(frame);
-
- if (limit == -1 || limit > (REBINT)SERIES_TAIL(frame))
- limit = SERIES_TAIL(frame);
-
- Debug_Fmt("Frame: %x len = %d", frame, SERIES_TAIL(frame));
- for (n = 0; n < limit; n++, values++, words++) {
- Debug_Fmt(" %02d: %s (%s) [%s]",
- n,
- Get_Sym_Name(VAL_BIND_SYM(words)),
- Get_Sym_Name(VAL_BIND_CANON(words)),
- Get_Type_Name(values)
- );
- }
-
- if (limit >= (REBINT)SERIES_TAIL(frame) && NOT_END(words))
- Debug_Fmt("** Word list not terminated! Type: %d, Tail: %d", VAL_TYPE(words), SERIES_TAIL(frame));
+ *cp = 0;
+ printf("%s\n", s_cast(buf));
+ fflush(stdout);
+
+ if (total >= limit)
+ break;
+ }
}
-/***********************************************************************
-**
-xx*/ void Dump_Word_Value(REBVAL *word)
-/*
-***********************************************************************/
+//
+// Dump_Series: C
+//
+void Dump_Series(REBSER *s, const char *memo)
{
- Debug_Fmt("Word: %s (Symbol %d Frame %x Index %d)", Get_Word_Name(word),
- VAL_WORD_SYM(word), VAL_WORD_FRAME(word), VAL_WORD_INDEX(word));
+ printf("Dump_Series(%s) @ %p\n", memo, cast(void*, s));
+ fflush(stdout);
+
+ if (s == NULL)
+ return;
+
+ printf(" wide: %d\n", SER_WIDE(s));
+ printf(" size: %ld\n", cast(unsigned long, SER_TOTAL_IF_DYNAMIC(s)));
+ if (GET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC))
+ printf(" bias: %d\n", cast(int, SER_BIAS(s)));
+ printf(" tail: %d\n", cast(int, SER_LEN(s)));
+ printf(" rest: %d\n", cast(int, SER_REST(s)));
+
+ // flags includes len if non-dynamic
+ printf(" flags: %lx\n", cast(unsigned long, s->header.bits));
+
+ // info includes width
+ printf(" info: %lx\n", cast(unsigned long, s->info.bits));
+
+ fflush(stdout);
+
+ if (GET_SER_FLAG(s, SERIES_FLAG_ARRAY))
+ Dump_Values(ARR_HEAD(ARR(s)), SER_LEN(s));
+ else
+ Dump_Bytes(SER_DATA_RAW(s), (SER_LEN(s) + 1) * SER_WIDE(s));
+
+ fflush(stdout);
}
-/***********************************************************************
-**
-xx*/ void Dump_Word_Table()
-/*
-***********************************************************************/
+//
+// Dump_Values: C
+//
+// Print values in raw hex; If memory is corrupted this still needs to work.
+//
+void Dump_Values(RELVAL *vp, REBCNT count)
{
- REBCNT n;
- REBVAL *words = BLK_HEAD(PG_Word_Table.series);
-
- for (n = 1; n < PG_Word_Table.series->tail; n++) {
- Debug_Fmt("%03d: %s = %d (%d)", n, VAL_SYM_NAME(words+n),
- VAL_SYM_CANON(words+n), VAL_SYM_ALIAS(words+n));
-// if ((n % 40) == 0) getchar();
- }
+ REBYTE buf[2048];
+ REBYTE *cp;
+ REBCNT l, n;
+ REBCNT *bp = (REBCNT*)vp;
+ const REBYTE *type;
+
+ cp = buf;
+ for (l = 0; l < count; l++) {
+ REBVAL *val = cast(REBVAL*, bp);
+ if (IS_END(val)) {
+ break;
+ }
+ if (IS_BLANK_RAW(val) || IS_VOID(val)) {
+ bp = cast(REBCNT*, val + 1);
+ continue;
+ }
+
+ cp = Form_Hex_Pad(cp, l, 8);
+
+ *cp++ = ':';
+ *cp++ = ' ';
+
+ type = Get_Type_Name(val);
+ for (n = 0; n < 11; n++) {
+ if (*type) *cp++ = *type++;
+ else *cp++ = ' ';
+ }
+ *cp++ = ' ';
+ for (n = 0; n < sizeof(REBVAL) / sizeof(REBCNT); n++) {
+ cp = Form_Hex_Pad(cp, *bp++, 8);
+ *cp++ = ' ';
+ }
+ n = 0;
+ if (IS_WORD(val) || IS_GET_WORD(val) || IS_SET_WORD(val)) {
+ const REBYTE *name = STR_HEAD(VAL_WORD_SPELLING(val));
+ n = snprintf(
+ s_cast(cp), sizeof(buf) - (cp - buf), " (%s)", cs_cast(name)
+ );
+ }
+
+ *(cp + n) = 0;
+ Debug_Str(s_cast(buf));
+ cp = buf;
+ }
}
-/***********************************************************************
-**
-xx*/ void Dump_Bind_Table()
-/*
-***********************************************************************/
+//
+// Dump_Info: C
+//
+void Dump_Info(void)
{
- REBCNT n;
- REBINT *binds = WORDS_HEAD(Bind_Table);
-
- Debug_Fmt("Bind Table (Size: %d)", SERIES_TAIL(Bind_Table));
- for (n = 1; n < SERIES_TAIL(Bind_Table); n++) {
- if (binds[n])
- Debug_Fmt("Bind: %3d to %3d (%s)", n, binds[n], Get_Sym_Name(n));
- }
+ printf("^/--REBOL Kernel Dump--\n");
+
+ printf("Evaluator:\n");
+ printf(" Cycles: %ld\n", cast(unsigned long, Eval_Cycles));
+ printf(" Counter: %d\n", cast(int, Eval_Count));
+ printf(" Dose: %d\n", cast(int, Eval_Dose));
+ printf(" Signals: %lx\n", cast(unsigned long, Eval_Signals));
+ printf(" Sigmask: %lx\n", cast(unsigned long, Eval_Sigmask));
+ printf(" DSP: %d\n", DSP);
+
+ printf("Memory/GC:\n");
+
+ printf(" Ballast: %d\n", cast(int, GC_Ballast));
+ printf(" Disable: %s\n", GC_Disabled ? "yes" : "no");
+ printf(" Guarded Nodes: %d\n", cast(int, SER_LEN(GC_Guarded)));
+ fflush(stdout);
}
-#endif
-/***********************************************************************
-**
-*/ void Dump_Info(void)
-/*
-***********************************************************************/
+//
+// Dump_Stack: C
+//
+// Prints stack counting levels from the passed in number. Pass 0 to start.
+//
+void Dump_Stack(REBFRM *f, REBCNT level)
{
- REBINT n;
- REBINT nums [] = {
- 0,
- 0,
- (REBINT)Eval_Cycles,
- Eval_Count,
- Eval_Dose,
- Eval_Signals,
- Eval_Sigmask,
- DSP,
- DSF,
- 0,
- GC_Ballast,
- GC_Disabled,
- SERIES_TAIL(GC_Protect),
- GC_Last_Infant,
- };
-
- DISABLE_GC;
- for (n = 0; n < 14; n++) Debug_Fmt(BOOT_STR(RS_DUMP, n), nums[n]);
- ENABLE_GC;
+ printf("\n");
+
+ if (f == NULL)
+ f = FS_TOP;
+
+ if (f == NULL) {
+ printf("*STACK[] - NO FRAMES*\n");
+ fflush(stdout);
+ return;
+ }
+
+ printf(
+ "STACK[%d](%s) - %d\n",
+ cast(int, level),
+ STR_HEAD(FRM_LABEL(f)),
+ f->eval_type // note: this is now an ordinary Reb_Kind, stringify it
+ );
+
+ if (NOT(Is_Any_Function_Frame(f))) {
+ printf("(no function call pending or in progress)\n");
+ fflush(stdout);
+ return;
+ }
+
+ // !!! This is supposed to be a low-level debug routine, but it is
+ // effectively molding arguments. If the stack is known to be in "good
+ // shape" enough for that, it should be dumped by routines using the
+ // Rebol backtrace API.
+
+ fflush(stdout);
+
+ REBINT n = 1;
+ REBVAL *arg = FRM_ARG(f, 1);
+ REBVAL *param = FUNC_PARAMS_HEAD(f->phase);
+
+ for (; NOT_END(param); ++param, ++arg, ++n) {
+ Debug_Fmt(
+ " %s: %72r",
+ STR_HEAD(VAL_PARAM_SPELLING(param)),
+ arg
+ );
+ }
+
+ if (f->prior)
+ Dump_Stack(f->prior, level + 1);
}
-/***********************************************************************
-**
-*/ void Dump_Stack(REBINT dsf, REBINT dsp)
-/*
-***********************************************************************/
+
+#endif // DUMP is picked up by scan regardless of #ifdef, must be defined
+
+
+//
+// dump: native [
+//
+// "Temporary debug dump"
+//
+// value [ any-value!]
+// ]
+//
+REBNATIVE(dump)
{
- REBINT n;
- REBINT m;
- REBVAL *args;
-
- if (dsf == 0) {
- dsf = DSF;
- dsp = DSP;
- }
-
- m = dsp - dsf - DSF_SIZE;
- Debug_Fmt(BOOT_STR(RS_STACK, 1), dsp, Get_Word_Name(DSF_WORD(dsf)), m, Get_Type_Name(DSF_FUNC(dsf)));
-
- if (dsf > 0) {
- if (ANY_FUNC(DSF_FUNC(dsf))) {
- args = BLK_HEAD(VAL_FUNC_ARGS(DSF_FUNC(dsf)));
- m = SERIES_TAIL(VAL_FUNC_ARGS(DSF_FUNC(dsf)));
- for (n = 1; n < m; n++)
- Debug_Fmt("\t%s: %72r", Get_Word_Name(args+n), DSF_ARGS(dsf, n));
- }
- //Debug_Fmt(Str_Stack[2], PRIOR_DSF(dsf));
- if (PRIOR_DSF(dsf) > 0) Dump_Stack(PRIOR_DSF(dsf), dsf-1);
- }
-
- //for (n = 1; n <= 2; n++) {
- // Debug_Fmt(" ARG%d: %s %r", n, Get_Type_Name(DSF_ARGS(dsf, n)), DSF_ARGS(dsf, n));
- //}
-}
+ INCLUDE_PARAMS_OF_DUMP;
-#ifdef TEST_PRINT
- // Simple low-level tests:
- Print("%%d %d", 1234);
- Print("%%d %d", -1234);
- Print("%%d %d", 12345678);
- Print("%%d %d", 0);
- Print("%%6d %6d", 1234);
- Print("%%10d %10d", 123456789);
- Print("%%x %x", 0x1234ABCD);
- Print("%%x %x", -1);
- Print("%%4x %x", 0x1234);
- Print("%%s %s", "test");
- Print("%%s %s", 0);
- Print("%%c %c", (REBINT)'X');
- Print("%s %d %x", "test", 1234, 1234);
- getchar();
+#ifdef NDEBUG
+ UNUSED(ARG(value));
+ fail (Error_Debug_Only_Raw());
+#else
+ REBVAL *value = ARG(value);
+
+ Dump_Stack(frame_, 0);
+
+ if (ANY_SERIES(value))
+ Dump_Series(VAL_SERIES(value), "=>");
+ else
+ Dump_Values(value, 1);
+
+ Move_Value(D_OUT, value);
+ return R_OUT;
#endif
+}
diff --git a/src/core/d-eval.c b/src/core/d-eval.c
new file mode 100644
index 0000000000..93ba42fd4b
--- /dev/null
+++ b/src/core/d-eval.c
@@ -0,0 +1,397 @@
+//
+// File: %d-eval.c
+// Summary: "Debug-Build Checks for the Evaluator"
+// Section: debug
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Due to the length of Do_Core() and how many debug checks it already has,
+// three debug-only routines are separated out:
+//
+// * Do_Core_Entry_Checks_Debug() runs once at the beginning of a Do_Core()
+// call. It verifies that the fields of the frame the caller has to
+// provide have been pre-filled correctly, and snapshots bits of the
+// interpreter state that are supposed to "balance back to zero" by the
+// end of a run (assuming it completes, and doesn't longjmp from fail()ing)
+//
+// * Do_Core_Expression_Checks_Debug() runs before each full "expression"
+// is evaluated, e.g. before each DO/NEXT step. It makes sure the state
+// balanced completely--so no DS_PUSH that wasn't balanced by a DS_POP
+// or DS_DROP (for example). It also trashes variables in the frame which
+// might accidentally carry over from one step to another, so that there
+// will be a crash instead of a casual reuse.
+//
+// * Do_Core_Exit_Checks_Debug() runs if the Do_Core() call makes it to the
+// end without a fail() longjmping out from under it. It also checks to
+// make sure the state has balanced, and that the return result is
+// consistent with the state being returned.
+//
+// Because none of these routines are in the release build, they cannot have
+// any side-effects that affect the interpreter's ordinary operation.
+//
+
+#include "sys-core.h"
+
+#if !defined(NDEBUG)
+
+
+//
+// Dump_Frame_Location: C
+//
+void Dump_Frame_Location(REBFRM *f)
+{
+ DECLARE_LOCAL (dump);
+ Derelativize(dump, f->value, f->specifier);
+
+ printf("Dump_Frame_Location() value\n");
+ PROBE(dump);
+
+ if (f->flags.bits & DO_FLAG_VA_LIST) {
+ //
+ // NOTE: This reifies the va_list in the frame, and hence has
+ // side effects. It may need to be commented out if the
+ // problem you are trapping with DO_COUNT_BREAKPOINT was
+ // specifically with va_list frame processing.
+ //
+ const REBOOL truncated = TRUE;
+ Reify_Va_To_Array_In_Frame(f, truncated);
+ }
+
+ if (f->pending && NOT_END(f->pending)) {
+ assert(IS_SPECIFIC(f->pending));
+ printf("EVAL in progress, so next will be...\n");
+ PROBE(const_KNOWN(f->pending));
+ }
+
+ if (IS_END(f->value)) {
+ printf("...then Dump_Frame_Location() at end of array\n");
+ }
+ else {
+ Init_Any_Series_At_Core(
+ dump,
+ REB_BLOCK,
+ SER(f->source.array),
+ cast(REBCNT, f->index),
+ f->specifier
+ );
+
+ printf("Dump_Frame_Location() next input\n");
+ PROBE(dump);
+ }
+}
+
+
+//
+// Do_Core_Entry_Checks_Debug: C
+//
+void Do_Core_Entry_Checks_Debug(REBFRM *f)
+{
+ // Though we can protect the value written into the target pointer 'out'
+ // from GC during the course of evaluation, we can't protect the
+ // underlying value from relocation. Technically this would be a problem
+ // for any series which might be modified while this call is running, but
+ // most notably it applies to the data stack--where output used to always
+ // be returned.
+ //
+ // !!! A non-contiguous data stack which is not a series is a possibility.
+ //
+#ifdef STRESS_CHECK_DO_OUT_POINTER
+ REBSER *containing = Try_Find_Containing_Series_Debug(f->out);
+
+ if (containing) {
+ if (GET_SER_FLAG(containing, SERIES_FLAG_FIXED_SIZE)) {
+ //
+ // Currently it's considered OK to be writing into a fixed size
+ // series, for instance the durable portion of a function's
+ // arg storage. It's assumed that the memory will not move
+ // during the course of the argument evaluation.
+ //
+ }
+ else {
+ printf("Request for ->out location in movable series memory\n");
+ panic (containing);
+ }
+ }
+#else
+ assert(!IN_DATA_STACK_DEBUG(f->out));
+#endif
+
+ Assert_Cell_Writable(f->out, __FILE__, __LINE__);
+
+ // Caller should have pushed the frame, such that it is the topmost.
+ // This way, repeated calls to Do_Core(), e.g. by routines like ANY []
+ // don't keep pushing and popping on each call.
+ //
+ assert(f == FS_TOP);
+
+ // The arguments to functions in their frame are exposed via FRAME!s
+ // and through WORD!s. This means that if you try to do an evaluation
+ // directly into one of those argument slots, and run arbitrary code
+ // which also *reads* those argument slots...there could be trouble with
+ // reading and writing overlapping locations. So unless a function is
+ // in the argument fulfillment stage (before the variables or frame are
+ // accessible by user code), it's not legal to write directly into an
+ // argument slot. :-/ Note the availability of D_CELL for any functions
+ // that have more than one argument, during their run.
+ //
+ REBFRM *ftemp = FS_TOP->prior;
+ for (; ftemp != NULL; ftemp = ftemp->prior) {
+ if (!Is_Any_Function_Frame(ftemp))
+ continue;
+ if (Is_Function_Frame_Fulfilling(ftemp))
+ continue;
+ assert(
+ f->out < ftemp->args_head ||
+ f->out >= ftemp->args_head + FRM_NUM_ARGS(ftemp)
+ );
+ }
+
+ // The caller must preload ->value with the first value to process. It
+ // may be resident in the array passed that will be used to fetch further
+ // values, or it may not.
+ //
+ assert(f->value);
+
+ assert(f->flags.bits & NODE_FLAG_END);
+ assert(NOT(f->flags.bits & NODE_FLAG_CELL));
+
+ // f->label is set to NULL by Do_Core()
+
+#if !defined(NDEBUG)
+ f->label_debug = NULL;
+
+ if (
+ NOT(FRM_IS_VALIST(f))
+ && GET_SER_FLAG(f->source.array, SERIES_FLAG_FILE_LINE)
+ ){
+ f->file_debug = cast(
+ const char*, STR_HEAD(SER(f->source.array)->link.filename)
+ );
+ f->line_debug = SER(f->source.array)->misc.line;
+ }
+ else {
+ f->file_debug = "(no file info)";
+ f->line_debug = 0;
+ }
+#endif
+
+ // All callers should ensure that the type isn't an END marker before
+ // bothering to invoke Do_Core().
+ //
+ assert(NOT_END(f->value));
+}
+
+
+// These are checks common to Expression and Exit checks (hence also common
+// to the "end of Start" checks, since that runs on the first expression)
+//
+static void Do_Core_Shared_Checks_Debug(REBFRM *f) {
+ //
+ // There shouldn't have been any "accumulated state", in the sense that
+ // we should be back where we started in terms of the data stack, the
+ // mold buffer position, the outstanding manual series allocations, etc.
+ //
+ // Because this check is a bit expensive it is lightened up and used in
+ // the exit case only. But re-enable it to help narrowing down an
+ // imbalanced state discovered on an exit.
+ //
+#ifdef BALANCE_CHECK_EVERY_EVALUATION_STEP
+ ASSERT_STATE_BALANCED(&f->state_debug);
+#endif
+
+ assert(f == FS_TOP);
+ assert(f->state_debug.top_chunk == TG_Top_Chunk);
+ /* assert(DSP == f->dsp_orig); */ // !!! not true now with push SET-WORD!
+
+ if (f->flags.bits & DO_FLAG_VA_LIST)
+ assert(f->index == TRASHED_INDEX);
+ else {
+ assert(
+ f->index != TRASHED_INDEX
+ && f->index != END_FLAG
+ && f->index != THROWN_FLAG
+ && f->index != VA_LIST_FLAG
+ ); // END, THROWN, VA_LIST only used by wrappers
+ }
+
+ // If this fires, it means that Flip_Series_To_White was not called an
+ // equal number of times after Flip_Series_To_Black, which means that
+ // the custom marker on series accumulated.
+ //
+ assert(TG_Num_Black_Series == 0);
+
+ if (f->gotten != END) {
+ assert(IS_WORD(f->value)); // may not match eval_type at this point
+ assert(Get_Opt_Var_May_Fail(f->value, f->specifier) == f->gotten);
+ }
+
+ //=//// ^-- ABOVE CHECKS *ALWAYS* APPLY ///////////////////////////////=//
+
+ if (IS_END(f->value))
+ return;
+
+ if (NOT_END(f->out) && THROWN(f->out))
+ return;
+
+ assert(f->kind_debug == VAL_TYPE(f->value));
+
+ //=//// v-- BELOW CHECKS ONLY APPLY IN EXITS CASE WITH MORE CODE //////=//
+
+ // The eval_type is expected to be calculated already. Should match
+ // f->value, with special exemption for optimized lookback calls
+ // coming from Do_Next_In_Subframe_Throws()
+ //
+ assert(
+ (
+ f->eval_type == REB_FUNCTION
+ && (IS_WORD(f->value) || IS_FUNCTION(f->value))
+ )
+ || f->eval_type == VAL_TYPE(f->value)
+ );
+
+ assert(f->value);
+ assert(NOT_END(f->value));
+ assert(NOT(THROWN(f->value)));
+ ASSERT_VALUE_MANAGED(f->value);
+ assert(f->value != f->out);
+
+ //=//// ^-- ADD CHECKS EARLIER THAN HERE IF THEY SHOULD ALWAYS RUN ////=//
+}
+
+
+//
+// Do_Core_Expression_Checks_Debug: C
+//
+// The iteration preamble takes care of clearing out variables and preparing
+// the state for a new "/NEXT" evaluation. It's a way of ensuring in the
+// debug build that one evaluation does not leak data into the next, and
+// making the code shareable allows code paths that jump to later spots
+// in the switch (vs. starting at the top) to reuse the work.
+//
+REBUPT Do_Core_Expression_Checks_Debug(REBFRM *f) {
+
+ assert(f == FS_TOP); // should be topmost frame, still
+
+ Do_Core_Shared_Checks_Debug(f);
+
+ // Once a throw is started, no new expressions may be evaluated until
+ // that throw gets handled.
+ //
+ assert(IS_UNREADABLE_IF_DEBUG(&TG_Thrown_Arg));
+
+ assert(f->label == NULL); // release build initializes this
+
+#if !defined(NDEBUG)
+ assert(f->label_debug == NULL); // marked debug to point out debug only
+#endif
+
+ // Make sure `cell` is trash in debug build if not doing a `reevaluate`.
+ // It does not have to be GC safe (for reasons explained below). We
+ // also need to reset evaluation to normal vs. a kind of "inline quoting"
+ // in case EVAL/ONLY had enabled that.
+ //
+#if !defined(NDEBUG)
+ if (f->value != &f->cell)
+ TRASH_CELL_IF_DEBUG(&f->cell);
+#endif
+
+ // Trash call variables in debug build to make sure they're not reused.
+ // Note that this call frame will *not* be seen by the GC unless it gets
+ // chained in via a function execution, so it's okay to put "non-GC safe"
+ // trash in at this point...though by the time of that call, they must
+ // hold valid values.
+
+ TRASH_POINTER_IF_DEBUG(f->param);
+ TRASH_POINTER_IF_DEBUG(f->arg);
+ TRASH_POINTER_IF_DEBUG(f->refine);
+
+ TRASH_POINTER_IF_DEBUG(f->args_head);
+ TRASH_POINTER_IF_DEBUG(f->varlist);
+
+ TRASH_POINTER_IF_DEBUG(f->original);
+ TRASH_POINTER_IF_DEBUG(f->phase);
+ TRASH_POINTER_IF_DEBUG(f->binding);
+
+ // Mutate va_list sources into arrays at fairly random moments in the
+ // debug build. It should be able to handle it at any time.
+ //
+ if ((f->flags.bits & DO_FLAG_VA_LIST) && SPORADICALLY(50)) {
+ const REBOOL truncated = TRUE;
+ Reify_Va_To_Array_In_Frame(f, truncated);
+ }
+
+ // We bound the count at the max unsigned 32-bit, since otherwise it would
+ // roll over to zero and print a message that wasn't asked for, which
+ // is annoying even in a debug build. (It's actually a REBUPT, so this
+ // wastes possible bits in the 64-bit build, but there's no MAX_REBUPT.)
+ //
+ if (TG_Do_Count < MAX_U32)
+ f->do_count_debug = ++TG_Do_Count;
+
+ return f->do_count_debug;
+}
+
+
+//
+// Do_Core_Exit_Checks_Debug: C
+//
+void Do_Core_Exit_Checks_Debug(REBFRM *f) {
+ //
+ // To keep from slowing down the debug build too much, this is not put in
+ // the shared checks. But if it fires and it's hard to figure out which
+ // exact cycle caused the problem, re-add it in the shared checks.
+ //
+ ASSERT_STATE_BALANCED(&f->state_debug);
+
+ Do_Core_Shared_Checks_Debug(f);
+
+ if (NOT_END(f->value) && NOT(f->flags.bits & DO_FLAG_VA_LIST)) {
+ assert(
+ (f->index <= ARR_LEN(f->source.array))
+ || (
+ (
+ (f->pending && IS_END(f->pending))
+ || THROWN(f->out)
+ )
+ && f->index == ARR_LEN(f->source.array) + 1
+ )
+ );
+ }
+
+ if (f->flags.bits & DO_FLAG_TO_END)
+ assert(THROWN(f->out) || IS_END(f->value));
+
+ // Function execution should have written *some* actual output value.
+ // checking the VAL_TYPE() is enough to make sure it's not END or trash
+ //
+ assert(VAL_TYPE(f->out) <= REB_MAX_VOID);
+
+ if (NOT(THROWN(f->out))) {
+ assert(f->label == NULL);
+ ASSERT_VALUE_MANAGED(f->out);
+ }
+}
+
+#endif
diff --git a/src/core/d-legacy.c b/src/core/d-legacy.c
new file mode 100644
index 0000000000..a5ea5302a6
--- /dev/null
+++ b/src/core/d-legacy.c
@@ -0,0 +1,137 @@
+//
+// File: %d-legacy.h
+// Summary: "Legacy Support Routines for Debug Builds"
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2016 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// In order to make porting code from R3-Alpha or Rebol2 easier, Ren-C set
+// up several LEGACY() switches and a mode. The switches are
+// intended to only be available in debug builds, so that compatibility for
+// legacy code will not be a runtime cost in the release build. However,
+// they could be enabled by any sufficiently motivated individual who
+// wished to build a version of the interpreter with the old choices in an
+// optimized build as well.
+//
+// Support routines for legacy mode are quarantined here when possible.
+//
+
+#include "sys-core.h"
+
+
+#if !defined(NDEBUG)
+
+//
+// In_Legacy_Function_Debug: C
+//
+// Determine if a legacy function is "in effect" currently. To the extent
+// that compatibility in debug builds or legacy mode with R3-Alpha is
+// "important" this should be used sparingly, because code can be bound and
+// passed around in blocks. So you might be running a legacy function passed
+// new code or new code passed legacy code (e.g. a mezzanine that uses DO)
+//
+REBOOL In_Legacy_Function_Debug(void)
+{
+ // Find the first bit of code that's actually running ordinarily in
+ // the evaluator, and not just dispatching.
+ //
+ REBFRM *f = FS_TOP;
+ for (; f != NULL; f = f->prior) {
+ if (f->flags.bits & DO_FLAG_VA_LIST)
+ return FALSE; // no source array to look at
+
+ break; // whatever's dispatching here, there is a source array
+ }
+
+ if (f == NULL)
+ return FALSE;
+
+ // Check the flag on the source series
+ //
+ if (GET_SER_INFO(f->source.array, SERIES_INFO_LEGACY_DEBUG))
+ return TRUE;
+
+ return FALSE;
+}
+
+
+//
+// Legacy_Convert_Function_Args: C
+//
+// R3-Alpha and Rebol2 used BLANK for unused refinements and arguments to
+// a refinement which is not present. Ren-C uses FALSE for unused refinements
+// and arguments to unused refinements are not set.
+//
+// Could be woven in efficiently, but as it's a debug build only feature it's
+// better to isolate it into a post-phase. This improves the readability of
+// the mainline code.
+//
+// Trigger is when OPTIONS_REFINEMENTS_TRUE is set during function creation,
+// which will give it FUNC_FLAG_LEGACY_DEBUG--leading to this being used.
+//
+void Legacy_Convert_Function_Args(REBFRM *f)
+{
+ REBVAL *param = FUNC_FACADE_HEAD(f->phase);
+ REBVAL *arg = f->args_head;
+
+ REBOOL set_blank = FALSE;
+
+ for (; NOT_END(param); ++param, ++arg) {
+ switch (VAL_PARAM_CLASS(param)) {
+ case PARAM_CLASS_REFINEMENT:
+ if (IS_LOGIC(arg)) {
+ if (VAL_LOGIC(arg))
+ set_blank = FALSE;
+ else {
+ Init_Blank(arg);
+ set_blank = TRUE;
+ }
+ }
+ else assert(FALSE);
+ break;
+
+ case PARAM_CLASS_LOCAL:
+ assert(IS_VOID(arg)); // keep *pure* locals as void, even in legacy
+ break;
+
+ case PARAM_CLASS_RETURN:
+ case PARAM_CLASS_LEAVE:
+ assert(IS_FUNCTION(arg) || IS_VOID(arg));
+ break;
+
+ case PARAM_CLASS_NORMAL:
+ case PARAM_CLASS_HARD_QUOTE:
+ case PARAM_CLASS_SOFT_QUOTE:
+ if (set_blank) {
+ assert(IS_VOID(arg));
+ Init_Blank(arg);
+ }
+ break;
+
+ default:
+ assert(FALSE);
+ }
+ }
+}
+
+#endif
diff --git a/src/core/d-print.c b/src/core/d-print.c
index 06a6137fd0..0004236a79 100644
--- a/src/core/d-print.c
+++ b/src/core/d-print.c
@@ -1,39 +1,41 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: d-print.c
-** Summary: low-level console print interface
-** Section: debug
-** Author: Carl Sassenrath
-** Notes:
-** R3 is intended to run on fairly minimal devices, so this code may
-** duplicate functions found in a typical C lib. That's why output
-** never uses standard clib printf functions.
-**
-***********************************************************************/
-
-/*
- Print_OS... - low level OS output functions
- Out_... - general console output functions
- Debug_... - debug mode (trace) output functions
+//
+// File: %d-print.c
+// Summary: "low-level console print interface"
+// Section: debug
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// R3 is intended to run on fairly minimal devices, so this code may
+// duplicate functions found in a typical C lib. That's why output
+// never uses standard clib printf functions.
+//
+
+/*
+ Print_OS... - low level OS output functions
+ Out_... - general console output functions
+ Debug_... - debug mode (trace) output functions
*/
#include "sys-core.h"
@@ -43,831 +45,752 @@ static REBREQ *Req_SIO;
/***********************************************************************
**
-** Lower Level Print Interface
+** Lower Level Print Interface
**
***********************************************************************/
-/***********************************************************************
-**
-*/ void Init_StdIO(void)
-/*
-***********************************************************************/
+//
+// Startup_StdIO: C
+//
+void Startup_StdIO(void)
{
- //OS_CALL_DEVICE(RDI_STDIO, RDC_INIT);
- Req_SIO = OS_MAKE_DEVREQ(RDI_STDIO);
- if (!Req_SIO) Crash(RP_IO_ERROR);
+ //OS_CALL_DEVICE(RDI_STDIO, RDC_INIT);
+ Req_SIO = OS_MAKE_DEVREQ(RDI_STDIO);
+ if (!Req_SIO)
+ fail (Error_Io_Error_Raw());
- // The device is already open, so this call will just setup
- // the request fields properly.
- OS_DO_DEVICE(Req_SIO, RDC_OPEN);
+ // The device is already open, so this call will just setup
+ // the request fields properly.
+ OS_DO_DEVICE(Req_SIO, RDC_OPEN);
}
-/***********************************************************************
-**
-*/ static void Print_OS_Line(void)
-/*
-** Print a new line.
-**
-***********************************************************************/
+//
+// Shutdown_StdIO: C
+//
+void Shutdown_StdIO(void)
{
- Req_SIO->data = BYTES("\n");
- Req_SIO->length = 1;
- Req_SIO->actual = 0;
-
- OS_DO_DEVICE(Req_SIO, RDC_WRITE);
-
- if (Req_SIO->error) Crash(RP_IO_ERROR);
+ // !!! There is no OS_FREE_DEVREQ. Should there be? Should this
+ // include an OS_ABORT_DEVICE?
+ OS_FREE(Req_SIO);
}
-/***********************************************************************
-**
-*/ static void Prin_OS_String(REBYTE *bp, REBINT len, REBOOL uni)
-/*
-** Print a string, but no line terminator or space.
-**
-** The width of the input is specified by UNI.
-**
-***********************************************************************/
+//
+// Print_OS_Line: C
+//
+// Print a new line.
+//
+void Print_OS_Line(void)
{
- #define BUF_SIZE 1024
- REBYTE buffer[BUF_SIZE]; // on stack
- REBYTE *buf = &buffer[0];
- REBINT n;
- REBCNT len2;
- REBUNI *up = (REBUNI*)bp;
-
- if (!bp) Crash(RP_NO_PRINT_PTR);
-
- // Determine length if not provided:
- if (len == UNKNOWN) len = uni ? wcslen(up) : LEN_BYTES(bp);
-
- SET_FLAG(Req_SIO->flags, RRF_FLUSH);
-
- Req_SIO->actual = 0;
- Req_SIO->data = buf;
- buf[0] = 0; // for debug tracing
-
- while ((len2 = len) > 0) {
-
- Do_Signals();
-
- // returns # of chars, size returns buf bytes output
- n = Encode_UTF8(buf, BUF_SIZE-4, uni ? (void*)up : (void*)bp, &len2, uni, OS_CRLF);
- if (n == 0) break;
+ // !!! Don't put const literal directly into mutable Req_SIO->data
+ static REBYTE newline[] = "\n";
- Req_SIO->length = len2; // byte size of buffer
+ Req_SIO->common.data = newline;
+ Req_SIO->length = 1;
+ Req_SIO->actual = 0;
- if (uni) up += n; else bp += n;
- len -= n;
+ OS_DO_DEVICE(Req_SIO, RDC_WRITE);
- OS_DO_DEVICE(Req_SIO, RDC_WRITE);
- if (Req_SIO->error) Crash(RP_IO_ERROR);
- }
+ if (Req_SIO->error)
+ panic ("IO error in Print_OS_Line"); // !!! could/should this fail()?
}
-/***********************************************************************
-**
-*/ void Out_Value(REBVAL *value, REBCNT limit, REBOOL mold, REBINT lines)
-/*
-***********************************************************************/
-{
- Print_Value(value, limit, mold); // higher level!
- for (; lines > 0; lines--) Print_OS_Line();
-}
-
-
-/***********************************************************************
-**
-*/ void Out_Str(REBYTE *bp, REBINT lines)
-/*
-***********************************************************************/
-{
- Prin_OS_String(bp, UNKNOWN, 0);
- for (; lines > 0; lines--) Print_OS_Line();
-}
-
-
-/***********************************************************************
-**
-** Debug Print Interface
-**
-** If the Trace_Buffer exists, then output goes there,
-** otherwise output goes to OS output.
-**
-***********************************************************************/
-
-
-/***********************************************************************
-**
-*/ void Enable_Backtrace(REBFLG on)
-/*
-***********************************************************************/
+//
+// Prin_OS_String: C
+//
+// Print a string (with no line terminator).
+//
+// The encoding options are OPT_ENC_XXX flags OR'd together.
+//
+void Prin_OS_String(const void *p, REBCNT len, REBFLGS opts)
{
- if (on) {
- if (Trace_Limit == 0) {
- Trace_Limit = 100000;
- Trace_Buffer = Make_Binary(Trace_Limit);
- KEEP_SERIES(Trace_Buffer, "trace-buffer"); // !!! use better way
- }
- }
- else {
- if (Trace_Limit) Free_Series(Trace_Buffer);
- Trace_Limit = 0;
- Trace_Buffer = 0;
- }
-}
+ #define BUF_SIZE 1024
+ REBYTE buffer[BUF_SIZE]; // on stack
+ REBYTE *buf = &buffer[0];
+ REBCNT len2;
+ const REBOOL unicode = LOGICAL(opts & OPT_ENC_UNISRC);
+ const REBYTE *bp = unicode ? NULL : cast(const REBYTE *, p);
+ const REBUNI *up = unicode ? cast(const REBUNI *, p) : NULL;
-/***********************************************************************
-**
-*/ void Display_Backtrace(REBCNT lines)
-/*
-***********************************************************************/
-{
- REBCNT tail;
- REBCNT i;
-
- if (Trace_Limit > 0) {
- tail = Trace_Buffer->tail;
- i = tail - 1;
- for (lines++ ;lines > 0; lines--, i--) {
- i = Find_Str_Char(Trace_Buffer, 0, i, tail, -1, LF, 0);
- if (i == NOT_FOUND || i == 0) {
- i = 0;
- break;
- }
- }
-
- if (lines == 0) i += 2; // start of next line
- Prin_OS_String(BIN_SKIP(Trace_Buffer, i), tail-i, 0);
- //RESET_SERIES(Trace_Buffer);
- }
- else {
- Out_Str("backtrace not enabled", 1);
- }
-}
+ if (p == NULL)
+ fail (Error_No_Print_Ptr_Raw());
+ // Determine length if not provided:
+ if (len == UNKNOWN) len = unicode ? Strlen_Uni(up) : LEN_BYTES(bp);
-/***********************************************************************
-**
-*/ void Debug_String(REBYTE *bp, REBINT len, REBOOL uni, REBINT lines)
-/*
-***********************************************************************/
-{
- REBUNI *up = (REBUNI*)bp;
- REBUNI uc;
-
- if (Trace_Limit > 0) {
- if (Trace_Buffer->tail >= Trace_Limit)
- Remove_Series(Trace_Buffer, 0, 2000);
- if (len == UNKNOWN) len = uni ? wcslen(up) : LEN_BYTES(bp);
- // !!! account for unicode!
- for (; len > 0; len--) {
- uc = uni ? *up++ : *bp++;
- Append_Byte(Trace_Buffer, uc);
- }
- //Append_Bytes_Len(Trace_Buffer, bp, len);
- for (; lines > 0; lines--) Append_Byte(Trace_Buffer, LF);
- }
- else {
- Prin_OS_String(bp, len, uni);
- for (; lines > 0; lines--) Print_OS_Line();
- }
-}
+ SET_FLAG(Req_SIO->flags, RRF_FLUSH);
+ Req_SIO->actual = 0;
+ Req_SIO->common.data = buf;
+ buffer[0] = 0; // for debug tracing
-/***********************************************************************
-**
-*/ void Debug_Line(void)
-/*
-***********************************************************************/
-{
- Debug_String("", UNKNOWN, 0, 1);
-}
+ DECLARE_LOCAL (result);
+ SET_END(result);
+ if (opts & OPT_ENC_RAW) {
+ if (Do_Signals_Throws(result))
+ fail (Error_No_Catch_For_Throw(result));
-/***********************************************************************
-**
-*/ void Debug_Str(REBYTE *str)
-/*
-** Print a string followed by a newline.
-**
-***********************************************************************/
-{
- Debug_String(str, UNKNOWN, 0, 1);
-}
+ assert(IS_END(result));
+ // Used by verbatim terminal output, e.g. print of a BINARY!
+ assert(!unicode);
+ Req_SIO->length = len;
-/***********************************************************************
-**
-*/ void Debug_Uni(REBSER *ser)
-/*
-** Print debug unicode string followed by a newline.
-**
-***********************************************************************/
-{
- REBCNT ul;
- REBCNT bl;
- REBYTE buf[1024];
- REBUNI *up = UNI_HEAD(ser);
- REBINT size = Length_As_UTF8(up, SERIES_TAIL(ser), TRUE, OS_CRLF);
-
- while (size > 0) {
- ul = Encode_UTF8(buf, MIN(size, 1020), up, &bl, TRUE, OS_CRLF);
- Debug_String(buf, bl, 0, 0);
- size -= ul;
- up += ul;
- }
-
- Debug_Line();
-}
+ // Mutability cast, but RDC_WRITE should not be modifying the buffer
+ // (doing so could yield undefined behavior)
+ Req_SIO->common.data = m_cast(REBYTE *, bp);
+ OS_DO_DEVICE(Req_SIO, RDC_WRITE);
+ if (Req_SIO->error)
+ fail (Error_Io_Error_Raw());
+ }
+ else {
+ while ((len2 = len) > 0) {
+ if (Do_Signals_Throws(result))
+ fail (Error_No_Catch_For_Throw(result));
-/***********************************************************************
-**
-*/ void Debug_Series(REBSER *ser)
-/*
-***********************************************************************/
-{
- if (BYTE_SIZE(ser)) Debug_Str(BIN_HEAD(ser));
- else Debug_Uni(ser);
-}
+ assert(IS_END(result));
+ Req_SIO->length = Encode_UTF8(
+ buf,
+ BUF_SIZE - 4,
+ unicode ? cast(const void *, up) : cast(const void *, bp),
+ &len2,
+ opts
+ );
-/***********************************************************************
-**
-*/ void Debug_Num(REBYTE *str, REBINT num)
-/*
-** Print a string followed by a number.
-**
-***********************************************************************/
-{
- REBYTE buf[40];
+ if (unicode) up += len2; else bp += len2;
+ len -= len2;
- Debug_String(str, UNKNOWN, 0, 0);
- Debug_String(" ", 1, 0, 0);
- Form_Hex_Pad(buf, num, 8);
- Debug_Str(buf);
+ OS_DO_DEVICE(Req_SIO, RDC_WRITE);
+ if (Req_SIO->error)
+ fail (Error_Io_Error_Raw());
+ }
+ }
}
-/***********************************************************************
-**
-*/ void Debug_Chars(REBYTE chr, REBCNT num)
-/*
-** Print a number of spaces.
-**
-***********************************************************************/
-{
- REBYTE spaces[100];
-
- memset(spaces, chr, MIN(num, 99));
- spaces[num] = 0;
- Debug_String(spaces, num, 0, 0);
-}
-
/***********************************************************************
**
-*/ void Debug_Space(REBCNT num)
-/*
-** Print a number of spaces.
+** Debug Print Interface
**
-***********************************************************************/
-{
- if (num > 0) Debug_Chars(' ', num);
-}
-
-
-/***********************************************************************
-**
-*/ void Debug_Word(REBVAL *word)
-/*
-** Print a REBOL word.
+** If the Trace_Buffer exists, then output goes there,
+** otherwise output goes to OS output.
**
***********************************************************************/
-{
- Debug_Str(Get_Word_Name(word));
-}
-/***********************************************************************
-**
-*/ void Debug_Type(REBVAL *value)
-/*
-** Print a REBOL datatype name.
-**
-***********************************************************************/
+//
+// Enable_Backtrace: C
+//
+void Enable_Backtrace(REBOOL on)
{
- if (VAL_TYPE(value) < REB_MAX) Debug_Str(Get_Type_Name(value));
- else Debug_Str("TYPE?!");
+ if (on) {
+ if (Trace_Limit == 0) {
+ Trace_Limit = 100000;
+ Trace_Buffer = Make_Binary(Trace_Limit);
+ }
+ }
+ else {
+ if (Trace_Limit) Free_Series(Trace_Buffer);
+ Trace_Limit = 0;
+ Trace_Buffer = 0;
+ }
}
-/***********************************************************************
-**
-*/ void Debug_Value(REBVAL *value, REBCNT limit, REBOOL mold)
-/*
-***********************************************************************/
+//
+// Display_Backtrace: C
+//
+void Display_Backtrace(REBCNT lines)
{
- Print_Value(value, limit, mold); // higher level!
-}
+ REBCNT tail;
+ REBCNT i;
+ if (Trace_Limit > 0) {
+ tail = SER_LEN(Trace_Buffer);
+ i = tail - 1;
+ for (lines++ ;lines > 0; lines--, i--) {
+ i = Find_Str_Char(LF, Trace_Buffer, 0, i, tail, -1, 0);
+ if (i == NOT_FOUND || i == 0) {
+ i = 0;
+ break;
+ }
+ }
-/***********************************************************************
-**
-*/ void Debug_Values(REBVAL *value, REBCNT count, REBCNT limit)
-/*
-***********************************************************************/
-{
- REBSER *out;
- REBCNT i1;
- REBCNT i2;
- REBUNI uc, pc = ' ';
- REBCNT n;
-
- for (n = 0; n < count; n++, value++) {
- Debug_Space(1);
- if (n > 0 && VAL_TYPE(value) <= REB_NONE) Debug_Chars('.', 1);
- else {
- out = Mold_Print_Value(value, limit, TRUE); // shared mold buffer
- for (i1 = i2 = 0; i1 < out->tail; i1++) {
- uc = GET_ANY_CHAR(out, i1);
- if (uc < ' ') uc = ' ';
- if (uc > ' ' || pc > ' ') SET_ANY_CHAR(out, i2++, uc);
- pc = uc;
- }
- SET_ANY_CHAR(out, i2, 0);
- Debug_String(out->data, i2, TRUE, 0);
- }
- }
- Debug_Line();
+ if (lines == 0) i += 2; // start of next line
+ Prin_OS_String(BIN_AT(Trace_Buffer, i), tail - i, OPT_ENC_CRLF_MAYBE);
+ }
+ else {
+ Debug_Fmt(RM_BACKTRACE_NOT_ENABLED);
+ }
}
-/***********************************************************************
-**
-*/ void Debug_Buf(const REBYTE *fmt, va_list args)
-/*
-** Lower level formatted print for debugging purposes.
-**
-** 1. Does not support UNICODE.
-** 2. Does not auto-expand the output buffer.
-** 3. No termination buffering (limited length).
-**
-** Print using a format string and variable number
-** of arguments. All args must be long word aligned
-** (no short or char sized values unless recast to long).
-**
-** Output will be held in series print buffer and
-** will not exceed its max size. No line termination
-** is supplied after the print.
-**
-***********************************************************************/
+//
+// Debug_String: C
+//
+void Debug_String(const void *p, REBCNT len, REBOOL unicode, REBINT lines)
{
- REBSER *buf = BUF_PRINT;
- REBCNT len;
- REBCNT n;
- REBYTE *bp;
- REBCNT tail;
+ REBUNI uni;
+ const REBYTE *bp = unicode ? NULL : cast(const REBYTE *, p);
+ const REBUNI *up = unicode ? cast(const REBUNI *, p) : NULL;
- if (!buf) Crash(RP_NO_BUFFER);
+ REBOOL disabled = GC_Disabled;
+ GC_Disabled = TRUE;
- RESET_SERIES(buf);
+ if (Trace_Limit > 0) {
+ if (SER_LEN(Trace_Buffer) >= Trace_Limit)
+ Remove_Series(Trace_Buffer, 0, 2000);
- // Limits output to size of buffer, will not expand it:
- bp = Form_Var_Args(STR_HEAD(buf), SERIES_REST(buf)-1, fmt, args);
- tail = bp - STR_HEAD(buf);
+ if (len == UNKNOWN) len = unicode ? Strlen_Uni(up) : LEN_BYTES(bp);
- for (n = 0; n < tail; n += len) {
- len = LEN_BYTES(STR_SKIP(buf, n));
- if (len > 1024) len = 1024;
- Debug_String(STR_SKIP(buf, n), len, 0, 0);
- }
-}
+ for (; len > 0; len--) {
+ uni = unicode ? *up++ : *bp++;
+ Append_Codepoint_Raw(Trace_Buffer, uni);
+ }
+ for (; lines > 0; lines--) Append_Codepoint_Raw(Trace_Buffer, LF);
+ /* Append_Unencoded_Len(Trace_Buffer, bp, len); */ // !!! alternative?
+ }
+ else {
+ Prin_OS_String(
+ p, len, (unicode ? OPT_ENC_UNISRC : 0) | OPT_ENC_CRLF_MAYBE
+ );
+ for (; lines > 0; lines--) Print_OS_Line();
+ }
-/***********************************************************************
-**
-*/ void Debug_Fmt_(REBYTE *fmt, ...)
-/*
-** Print using a format string and variable number
-** of arguments. All args must be long word aligned
-** (no short or char sized values unless recast to long).
-** Output will be held in series print buffer and
-** will not exceed its max size. No line termination
-** is supplied after the print.
-**
-***********************************************************************/
-{
- va_list args;
- va_start(args, fmt);
- Debug_Buf(fmt, args);
- va_end(args);
+ assert(GC_Disabled == TRUE);
+ GC_Disabled = disabled;
}
-/***********************************************************************
-**
-*/ void Debug_Fmt(const REBYTE *fmt, ...)
-/*
-** Print using a formatted string and variable number
-** of arguments. All args must be long word aligned
-** (no short or char sized values unless recast to long).
-** Output will be held in a series print buffer and
-** will not exceed its max size. A line termination
-** is supplied after the print.
-**
-***********************************************************************/
+//
+// Debug_Line: C
+//
+void Debug_Line(void)
{
- va_list args;
- va_start(args, fmt);
- Debug_Buf(fmt, args);
- Debug_Line();
- va_end(args);
+ Debug_String(cb_cast(""), UNKNOWN, FALSE, 1);
}
-/***********************************************************************
-**
-*/ REBFLG Echo_File(REBCHR *file)
-/*
-***********************************************************************/
-{
- Req_SIO->file.path = file;
- return (DR_ERROR != OS_DO_DEVICE(Req_SIO, RDC_CREATE));
+//
+// Debug_Str: C
+//
+// Print a string followed by a newline.
+//
+void Debug_Str(const char *str)
+{
+ Debug_String(cb_cast(str), UNKNOWN, FALSE, 1);
}
-#ifdef unused
-/***********************************************************************
-**
-*/ REBYTE *Input_Str(void)
-/*
-** Very simple string input, limited to 255 chars.
-**
-***********************************************************************/
+//
+// Debug_Uni: C
+//
+// Print debug unicode string followed by a newline.
+//
+void Debug_Uni(REBSER *ser)
{
- static REBYTE buffer[256];
- REBINT res;
-
- Req_SIO->data = buffer;
- Req_SIO->length = 255;
- Req_SIO->actual = 0;
- res = OS_DO_DEVICE(Req_SIO, RDC_READ);
- if (Req_SIO->error) Crash(RP_IO_ERROR);
- //if (res > 0) Wait_Device(Req_SIO, 1000); // pending
- //if (res < 0) return 0; // error
-
- return buffer;
-}
-#endif
-
+ const REBFLGS encopts = OPT_ENC_UNISRC | OPT_ENC_CRLF_MAYBE;
+ REBCNT ul;
+ REBCNT bl;
+ REBYTE buf[1024];
+ REBUNI *up = UNI_HEAD(ser);
+ REBCNT size = SER_LEN(ser);
-/***********************************************************************
-**
-*/ REBYTE *Form_Hex_Pad(REBYTE *buf, REBU64 val, REBINT len)
-/*
-** Form an integer hex string in the given buffer with a
-** width padded out with zeros.
-** If len = 0 and val = 0, a null string is formed.
-** Does not insert a #.
-** Make sure you have room in your buffer before calling this!
-**
-***********************************************************************/
+ REBOOL disabled = GC_Disabled;
+ GC_Disabled = TRUE;
+
+ while (size > 0) {
+ ul = size;
+ bl = Encode_UTF8(buf, 1020, up, &ul, encopts);
+ Debug_String(buf, bl, FALSE, 0);
+ size -= ul;
+ up += ul;
+ }
+
+ Debug_Line();
+
+ assert(GC_Disabled == TRUE);
+ GC_Disabled = disabled;
+}
+
+
+//
+// Debug_Chars: C
+//
+// Print a number of spaces.
+//
+void Debug_Chars(REBYTE chr, REBCNT num)
{
- REBYTE buffer[MAX_HEX_LEN+4];
- REBYTE *bp = (REBYTE*)(buffer + MAX_HEX_LEN + 1);
- REBU64 sgn;
-
- sgn = (val < 0) ? -1 : 0;
-
- len = MIN(len, MAX_HEX_LEN);
- *bp-- = 0;
- while (val != sgn && len > 0) {
- *bp-- = Hex_Digits[val & 0xf];
- val >>= 4;
- len--;
- }
- for (; len > 0; len--) *bp-- = (REBYTE)(sgn ? 'F' : '0');
- bp++;
- while (NZ(*buf++ = *bp++));
- return buf-1;
-}
+ REBYTE spaces[100];
+ memset(spaces, chr, MIN(num, 99));
+ spaces[num] = 0;
+ Debug_String(spaces, num, FALSE, 0);
+}
+
+
+//
+// Debug_Space: C
+//
+// Print a number of spaces.
+//
+void Debug_Space(REBCNT num)
+{
+ if (num > 0) Debug_Chars(' ', num);
+}
+
+
+//
+// Debug_Values: C
+//
+void Debug_Values(const RELVAL *value, REBCNT count, REBCNT limit)
+{
+ REBCNT i1;
+ REBCNT i2;
+ REBUNI uc, pc = ' ';
+ REBCNT n;
+
+ for (n = 0; n < count; n++, value++) {
+ Debug_Space(1);
+ if (n > 0 && VAL_TYPE(value) <= REB_BLANK) Debug_Chars('.', 1);
+ else {
+ REB_MOLD mo;
+ CLEARS(&mo);
+ if (limit != 0) {
+ SET_FLAG(mo.opts, MOPT_LIMIT);
+ mo.limit = limit;
+ }
+ Push_Mold(&mo);
+
+ Mold_Value(&mo, value, TRUE);
+ Throttle_Mold(&mo); // not using Pop_Mold(), must do explicitly
+
+ for (i1 = i2 = mo.start; i1 < SER_LEN(mo.series); i1++) {
+ uc = GET_ANY_CHAR(mo.series, i1);
+ if (uc < ' ') uc = ' ';
+ if (uc > ' ' || pc > ' ') SET_ANY_CHAR(mo.series, i2++, uc);
+ pc = uc;
+ }
+ SET_ANY_CHAR(mo.series, i2, '\0');
+ assert(SER_WIDE(mo.series) == sizeof(REBUNI));
+ Debug_String(
+ UNI_AT(mo.series, mo.start),
+ i2 - mo.start,
+ TRUE,
+ 0
+ );
+
+ Drop_Mold(&mo);
+ }
+ }
+ Debug_Line();
+}
+
+
+//
+// Debug_Buf: C
+//
+// (va_list by pointer: http://stackoverflow.com/a/3369762/211160)
+//
+// Lower level formatted print for debugging purposes.
+//
+// 1. Does not support UNICODE.
+// 2. Does not auto-expand the output buffer.
+// 3. No termination buffering (limited length).
+//
+// Print using a format string and variable number
+// of arguments. All args must be long word aligned
+// (no short or char sized values unless recast to long).
+//
+// Output will be held in series print buffer and
+// will not exceed its max size. No line termination
+// is supplied after the print.
+//
+void Debug_Buf(const char *fmt, va_list *vaptr)
+{
+ REBOOL disabled = GC_Disabled;
+ GC_Disabled = TRUE;
+
+ REB_MOLD mo;
+ CLEARS(&mo);
+ Push_Mold(&mo);
+
+ Form_Args_Core(&mo, fmt, vaptr);
+
+ REBSER *bytes = Pop_Molded_UTF8(&mo);
+
+ // Don't send the Debug_String routine more than 1024 bytes at a time,
+ // but chunk it to 1024 byte sections.
+ //
+ // !!! What's the rationale for this?
+ //
+ REBCNT len = SER_LEN(bytes);
+
+ REBCNT n = 0;
+ while (n < len) {
+ REBCNT sub = len - n;
+ if (sub > 1024)
+ sub = 1024;
+ Debug_String(BIN_AT(bytes, n), sub, FALSE, 0);
+ n += sub;
+ }
+
+ Free_Series(bytes);
+
+ assert(GC_Disabled == TRUE);
+ GC_Disabled = disabled;
+}
+
+
+//
+// Debug_Fmt_: C
+//
+// Print using a format string and variable number
+// of arguments. All args must be long word aligned
+// (no short or char sized values unless recast to long).
+// Output will be held in series print buffer and
+// will not exceed its max size. No line termination
+// is supplied after the print.
+//
+void Debug_Fmt_(const char *fmt, ...)
+{
+ va_list va;
+ va_start(va, fmt);
+ Debug_Buf(fmt, &va);
+ va_end(va);
+}
+
+
+//
+// Debug_Fmt: C
+//
+// Print using a formatted string and variable number
+// of arguments. All args must be long word aligned
+// (no short or char sized values unless recast to long).
+// Output will be held in a series print buffer and
+// will not exceed its max size. A line termination
+// is supplied after the print.
+//
+void Debug_Fmt(const char *fmt, ...)
+{
+ va_list args;
+ va_start(args, fmt);
+ Debug_Buf(fmt, &args);
+ Debug_Line();
+ va_end(args);
+}
+
+
+//
+// Form_Hex_Pad: C
+//
+// Form an integer hex string in the given buffer with a
+// width padded out with zeros.
+// If len = 0 and val = 0, a null string is formed.
+// Does not insert a #.
+// Make sure you have room in your buffer before calling this!
+//
+REBYTE *Form_Hex_Pad(REBYTE *buf, REBI64 val, REBINT len)
+{
+ REBYTE buffer[MAX_HEX_LEN+4];
+ REBYTE *bp = buffer + MAX_HEX_LEN + 1;
+ REBI64 sgn;
+
+ // !!! val parameter was REBI64 at one point; changed to REBI64
+ // as this does signed comparisons (val < 0 was never true...)
+ sgn = (val < 0) ? -1 : 0;
+
+ len = MIN(len, MAX_HEX_LEN);
+ *bp-- = 0;
+ while (val != sgn && len > 0) {
+ *bp-- = Hex_Digits[val & 0xf];
+ val >>= 4;
+ len--;
+ }
+ for (; len > 0; len--) *bp-- = (sgn != 0) ? 'F' : '0';
+ bp++;
+ while ((*buf++ = *bp++));
+ return buf-1;
+}
+
+
+//
+// Form_Hex2: C
+//
+// Convert byte-sized int to xx format. Very fast.
+//
+REBYTE *Form_Hex2(REBYTE *bp, REBCNT val)
+{
+ bp[0] = Hex_Digits[(val & 0xf0) >> 4];
+ bp[1] = Hex_Digits[val & 0xf];
+ bp[2] = 0;
+ return bp+2;
+}
+
+
+//
+// Form_Hex2_Uni: C
+//
+// Convert byte-sized int to unicode xx format. Very fast.
+//
+REBUNI *Form_Hex2_Uni(REBUNI *up, REBCNT val)
+{
+ up[0] = Hex_Digits[(val & 0xf0) >> 4];
+ up[1] = Hex_Digits[val & 0xf];
+ up[2] = 0;
+ return up+2;
+}
+
+
+//
+// Form_Hex_Esc_Uni: C
+//
+// Convert byte int to %xx format (in unicode destination)
+//
+REBUNI *Form_Hex_Esc_Uni(REBUNI *up, REBUNI c)
+{
+ up[0] = '%';
+ up[1] = Hex_Digits[(c & 0xf0) >> 4];
+ up[2] = Hex_Digits[c & 0xf];
+ up[3] = 0;
+ return up+3;
+}
+
+
+//
+// Form_RGB_Uni: C
+//
+// Convert 24 bit RGB to xxxxxx format.
+//
+REBUNI *Form_RGB_Uni(REBUNI *up, REBCNT val)
+{
+#ifdef ENDIAN_LITTLE
+ up[0] = Hex_Digits[(val >> 4) & 0xf];
+ up[1] = Hex_Digits[val & 0xf];
+ up[2] = Hex_Digits[(val >> 12) & 0xf];
+ up[3] = Hex_Digits[(val >> 8) & 0xf];
+ up[4] = Hex_Digits[(val >> 20) & 0xf];
+ up[5] = Hex_Digits[(val >> 16) & 0xf];
+#else
+ up[0] = Hex_Digits[(val >> 28) & 0xf];
+ up[1] = Hex_Digits[(val >> 24) & 0xf];
+ up[2] = Hex_Digits[(val >> 20) & 0xf];
+ up[3] = Hex_Digits[(val >> 16) & 0xf];
+ up[4] = Hex_Digits[(val >> 12) & 0xf];
+ up[5] = Hex_Digits[(val >> 8) & 0xf];
+#endif
+ up[6] = 0;
-/***********************************************************************
-**
-*/ REBYTE *Form_Hex2(REBYTE *bp, REBCNT val)
-/*
-** Convert byte-sized int to xx format. Very fast.
-**
-***********************************************************************/
-{
- bp[0] = Hex_Digits[(val & 0xf0) >> 4];
- bp[1] = Hex_Digits[val & 0xf];
- bp[2] = 0;
- return bp+2;
+ return up+6;
}
-/***********************************************************************
-**
-*/ REBUNI *Form_Hex2_Uni(REBUNI *up, REBCNT val)
-/*
-** Convert byte-sized int to unicode xx format. Very fast.
-**
-***********************************************************************/
+//
+// Form_Uni_Hex: C
+//
+// Fast var-length hex output for uni-chars.
+// Returns next position (just past the insert).
+//
+REBUNI *Form_Uni_Hex(REBUNI *out, REBCNT n)
{
- up[0] = Hex_Digits[(val & 0xf0) >> 4];
- up[1] = Hex_Digits[val & 0xf];
- up[2] = 0;
- return up+2;
-}
-
+ REBUNI buffer[10];
+ REBUNI *up = &buffer[10];
-/***********************************************************************
-**
-*/ REBUNI *Form_Hex_Esc_Uni(REBUNI *up, REBUNI c)
-/*
-** Convert byte int to %xx format (in unicode destination)
-**
-***********************************************************************/
-{
- up[0] = '%';
- up[1] = Hex_Digits[(c & 0xf0) >> 4];
- up[2] = Hex_Digits[c & 0xf];
- up[3] = 0;
- return up+3;
-}
+ while (n != 0) {
+ *(--up) = Hex_Digits[n & 0xf];
+ n >>= 4;
+ }
+ while (up < &buffer[10]) *out++ = *up++;
-/***********************************************************************
-**
-*/ REBUNI *Form_RGB_Uni(REBUNI *up, REBCNT val)
-/*
-** Convert 24 bit RGB to xxxxxx format.
-**
-***********************************************************************/
-{
- up[0] = Hex_Digits[(val >> 20) & 0xf];
- up[1] = Hex_Digits[(val >> 16) & 0xf];
- up[2] = Hex_Digits[(val >> 12) & 0xf];
- up[3] = Hex_Digits[(val >> 8) & 0xf];
- up[4] = Hex_Digits[(val >> 4) & 0xf];
- up[5] = Hex_Digits[val & 0xf];
- up[6] = 0;
- return up+6;
+ return out;
}
-/***********************************************************************
-**
-*/ REBUNI *Form_Uni_Hex(REBUNI *out, REBCNT n)
-/*
-** Fast var-length hex output for uni-chars.
-** Returns next position (just past the insert).
-**
-***********************************************************************/
+//
+// Form_Args_Core: C
+//
+// (va_list by pointer: http://stackoverflow.com/a/3369762/211160)
+//
+// This is an internal routine used for debugging, which is something like
+// `printf` (it understands %d, %s, %c) but stripped down in features.
+// It also knows how to show REBVAL* values FORMed (%v) or MOLDed (%r),
+// as well as REBSER* or REBARR* series molded (%m).
+//
+// Initially it was considered to be for low-level debug output only. It
+// was strictly ASCII, and it only supported a fixed-size output destination
+// buffer. The buffer that it used was reused by other routines, and
+// nested calls would erase the content. The choice was made to use the
+// implementation techniques of MOLD and the "mold stack"...allowing nested
+// calls and unicode support. It simplified the code, at the cost of
+// becoming slightly more "bootstrapped".
+//
+void Form_Args_Core(REB_MOLD *mo, const char *fmt, va_list *vaptr)
{
- REBUNI buffer[10];
- REBUNI *up = &buffer[10];
-
- while (n != 0) {
- *(--up) = Hex_Digits[n & 0xf];
- n >>= 4;
- }
-
- while (up < &buffer[10]) *out++ = *up++;
+ REBYTE *cp;
+ REBINT pad;
+ REBYTE desc;
+ REBYTE padding;
+ REBSER *ser = mo->series;
+ REBYTE buf[MAX_SCAN_DECIMAL];
- return out;
-}
-
-
-/***********************************************************************
-**
-*/ REBYTE *Form_Var_Args(REBYTE *bp, REBCNT max, const REBYTE *fmt, va_list args)
-/*
-** Lower level (debugging) value formatter.
-** Can restrict to max char size.
-**
-***********************************************************************/
-{
- REBYTE *cp;
- REBCNT len = 0;
- REBINT pad;
- REBVAL *vp;
- REBYTE desc;
- REBSER *ser;
- REBVAL value;
- REBYTE padding;
- REBINT l;
+ DECLARE_LOCAL (value);
- max--; // adjust for the fact that it adds a NULL at the end.
+ // buffer used for making byte-oriented renderings to add to the REBUNI
+ // mold series. Should be more formally checked as it's used for
+ // integers, hex, eventually perhaps other things.
+ //
+ assert(MAX_SCAN_DECIMAL >= MAX_HEX_LEN);
- //*bp++ = '!'; len++;
+ for (; *fmt != '\0'; fmt++) {
- for (; *fmt && len < max; fmt++) {
+ // Copy format string until next % escape
+ //
+ while ((*fmt != '\0') && (*fmt != '%'))
+ Append_Codepoint_Raw(ser, *fmt++);
- // Copy string until next % escape:
- for (; *fmt && *fmt != '%' && len < max; len++) *bp++ = *fmt++;
- if (*fmt != '%') break;
+ if (*fmt != '%') break;
- pad = 1;
- padding = ' ';
- fmt++; // skip %
+ pad = 1;
+ padding = ' ';
+ fmt++; // skip %
pick:
- switch (desc = *fmt) {
-
- case '0':
- padding = '0';
- case '-':
- case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- fmt = Grab_Int((REBYTE*)fmt, &pad);
- goto pick;
-
- case 'd':
- l = va_arg(args, REBINT);
- cp = Form_Int_Pad(bp, (REBI64)l, max-len, pad, padding);
- len += (REBCNT)(cp - bp);
- bp = cp;
- break;
-
- case 'D':
- cp = Form_Int_Pad(bp, va_arg(args, REBI64), max-len, pad, padding);
- len += (REBCNT)(cp - bp);
- bp = cp;
- break;
-
- case 's':
- cp = va_arg(args, REBYTE *);
- if ((REBCNT)cp < 100) cp = (REBYTE*)Bad_Ptr;
- if (pad == 1) pad = LEN_BYTES(cp);
- if (pad < 0) {
- pad = -pad;
- pad -= LEN_BYTES(cp);
- for (; pad > 0 && len < max; len++, pad--) *bp++ = ' ';
- }
- for (; *cp && len < max && pad > 0; pad--, len++) *bp++ = *cp++;
- for (; pad > 0 && len < max; len++, pad--) *bp++ = ' ';
- break;
-
- case 'r': // use Mold
- case 'v': // use Form
- vp = va_arg(args, REBVAL *);
-mold_value:
- // Form the REBOL value into a reused buffer:
- ser = Mold_Print_Value(vp, 0, desc != 'v');
-
- l = Length_As_UTF8(UNI_HEAD(ser), SERIES_TAIL(ser), TRUE, OS_CRLF);
- if (pad != 1 && l > pad) l = pad;
- if (l+len >= max) l = max-len-1;
-
- Encode_UTF8(bp, l, UNI_HEAD(ser), 0, TRUE, OS_CRLF);
-
- // Filter out CTRL chars:
- for (; l > 0; l--, bp++) if (*bp < ' ') *bp = ' ';
- break;
-
- case 'm': // Mold a series
- ser = va_arg(args, REBSER *);
- Set_Block(&value, ser);
- vp = &value;
- goto mold_value;
-
- case 'c':
- if (len < max) {
- *bp++ = (REBYTE)va_arg(args, REBINT);
- len++;
- }
- break;
-
- case 'x':
- if (len + MAX_HEX_LEN + 1 < max) { // A cheat, but it is safe.
- *bp++ = '#';
- if (pad == 1) pad = 8;
- cp = Form_Hex_Pad(bp, (REBCNT)(va_arg(args, REBYTE*)), pad);
- len += 1 + (REBCNT)(cp - bp);
- bp = cp;
- }
- break;
-
- default:
- *bp++ = *fmt;
- len++;
- }
- }
- *bp = 0;
- return bp;
-}
-
-
-/***********************************************************************
-**
-** User Output Print Interface
-**
-***********************************************************************/
-
-/***********************************************************************
-**
-*/ void Prin_Value(REBVAL *value, REBCNT limit, REBOOL mold)
-/*
-** Print a value or block's contents for user viewing.
-** Can limit output to a given size. Set limit to 0 for full size.
-**
-***********************************************************************/
-{
- REBSER *out = Mold_Print_Value(value, limit, mold);
- Prin_OS_String(out->data, out->tail, TRUE);
-}
-
-
-/***********************************************************************
-**
-*/ void Print_Value(REBVAL *value, REBCNT limit, REBOOL mold)
-/*
-** Print a value or block's contents for user viewing.
-** Can limit output to a given size. Set limit to 0 for full size.
-**
-***********************************************************************/
-{
- Prin_Value(value, limit, mold);
- Print_OS_Line();
-}
-
-
-#ifdef unused
-/***********************************************************************
-**
-*/ static void Prin_Mold_Block(REBVAL *block, REBCNT limit)
-/*
-** Can limit output to a given size. Set limit to 0 for full size.
-**
-***********************************************************************/
-{
- REBCNT n;
-
-// Reset_Mold_Buffer();
- old_Block_Series(block, BUF_MOLD, 0, 0);
-
- // Note: do not need to protect BUF_MOLD
- if (limit != 0 && STR_LEN(BUF_MOLD) > limit) {
- SERIES_TAIL(BUF_MOLD) = limit;
- Append_Bytes(BUF_MOLD, "...");
- }
-
- for (n = 0; n < SERIES_TAIL(BUF_MOLD);) {
- n = Encode_Uni_UTF8(BUF_MOLD, n, BUF_PRINT);
- Prin_OS_String(STR_HEAD(BUF_PRINT), SERIES_TAIL(BUF_PRINT));
- }
-}
-
-
-/***********************************************************************
-**
-*/ void Print_Mold_Block(REBVAL *block, REBCNT limit)
-/*
-** Print a block contents for user viewing.
-** Can limit output to a given size. Set limit to 0 for full size.
-**
-***********************************************************************/
-{
- Prin_Mold_Block(block, limit);
- Out_Line();
-}
-
-/***********************************************************************
-**
-*/ REBYTE *Form_Args(REBYTE *cp, REBCNT limit, REBYTE *fmt, ...)
-/*
-** Format a string into a string buffer up to a maximum length.
-** Used mostly for debugging output.
-**
-***********************************************************************/
-{
- va_list args;
-
- va_start(args, fmt);
- cp = Form_Var_Args(cp, limit, fmt, args);
- va_end(args);
- return cp;
-}
-#endif
-
-
-/***********************************************************************
-**
-*/ void Init_Raw_Print(void)
-/*
-** Initialize print module.
-**
-***********************************************************************/
-{
- Set_Root_Series(TASK_BUF_PRINT, Make_Binary(1000), "print buffer");
- Set_Root_Series(TASK_BUF_FORM, Make_Binary(64), "form buffer");
+ switch (desc = *fmt) {
+
+ case '0':
+ padding = '0';
+ // falls through
+ case '-':
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ fmt = cs_cast(Grab_Int(cb_cast(fmt), &pad));
+ goto pick;
+
+ case 'D':
+ assert(FALSE); // !!! was identical code to "d"...why "D"?
+ case 'd':
+ // All va_arg integer arguments will be coerced to platform 'int'
+ cp = Form_Int_Pad(
+ buf,
+ cast(REBI64, va_arg(*vaptr, int)),
+ MAX_SCAN_DECIMAL,
+ pad,
+ padding
+ );
+ Append_Unencoded_Len(ser, s_cast(buf), cast(REBCNT, cp - buf));
+ break;
+
+ case 's':
+ cp = va_arg(*vaptr, REBYTE *);
+ if (pad == 1) pad = LEN_BYTES(cp);
+ if (pad < 0) {
+ pad = -pad;
+ pad -= LEN_BYTES(cp);
+ for (; pad > 0; pad--) Append_Codepoint_Raw(ser, ' ');
+ }
+ Append_Unencoded(ser, s_cast(cp));
+
+ // !!! see R3-Alpha for original pad logic, this is an attempt
+ // to make the output somewhat match without worrying heavily
+ // about the padding features of this debug routine.
+ //
+ pad -= LEN_BYTES(cp);
+
+ for (; pad > 0; pad--) Append_Codepoint_Raw(ser, ' ');
+ break;
+
+ case 'r': // use Mold
+ case 'v': // use Form
+ Mold_Value(
+ mo,
+ va_arg(*vaptr, const REBVAL*),
+ LOGICAL(desc != 'v')
+ );
+
+ // !!! This used to "filter out ctrl chars", which isn't a bad
+ // idea as a mold option (MOPT_FILTER_CTRL) but it would involve
+ // some doing, as molding doesn't have a real "moment" that
+ // it can always filter...since sometimes the buffer is examined
+ // directly by clients vs. getting handed back.
+ //
+ /* for (; l > 0; l--, bp++) if (*bp < ' ') *bp = ' '; */
+ break;
+
+ case 'm': { // Mold a series
+ // Init_Block would Ensure_Series_Managed, we use a raw
+ // VAL_SET instead.
+ //
+ // !!! Better approach? Can the series be passed directly?
+ //
+ REBSER* temp = va_arg(*vaptr, REBSER*);
+ if (GET_SER_FLAG(temp, SERIES_FLAG_ARRAY)) {
+ VAL_RESET_HEADER(value, REB_BLOCK);
+ INIT_VAL_ARRAY(value, ARR(temp));
+ }
+ else {
+ VAL_RESET_HEADER(value, REB_STRING);
+ INIT_VAL_SERIES(value, temp);
+ }
+ VAL_INDEX(value) = 0;
+ Mold_Value(mo, value, TRUE);
+ break;
+ }
+
+ case 'c':
+ Append_Codepoint_Raw(
+ ser,
+ cast(REBYTE, va_arg(*vaptr, REBINT))
+ );
+ break;
+
+ case 'x':
+ Append_Codepoint_Raw(ser, '#');
+ if (pad == 1) pad = 8;
+ cp = Form_Hex_Pad(
+ buf,
+ cast(REBU64, cast(REBUPT, va_arg(*vaptr, REBYTE*))),
+ pad
+ );
+ Append_Unencoded_Len(ser, s_cast(buf), cp - buf);
+ break;
+
+ default:
+ Append_Codepoint_Raw(ser, *fmt);
+ }
+ }
+
+ TERM_SERIES(ser);
+}
+
+
+//
+// Form_Args: C
+//
+void Form_Args(REB_MOLD *mo, const char *fmt, ...)
+{
+ va_list args;
+
+ va_start(args, fmt);
+ Form_Args_Core(mo, fmt, &args);
+ va_end(args);
+}
+
+
+//
+// Startup_Raw_Print: C
+//
+// Initialize print module.
+//
+void Startup_Raw_Print(void)
+{
+ Init_String(TASK_BYTE_BUF, Make_Binary(1000));
}
diff --git a/src/core/d-stack.c b/src/core/d-stack.c
new file mode 100644
index 0000000000..3ca9129ed1
--- /dev/null
+++ b/src/core/d-stack.c
@@ -0,0 +1,779 @@
+//
+// Rebol 3 Language Interpreter and Run-time Environment
+// "Ren-C" branch @ https://github.com/metaeducation/ren-c
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Summary: Debug Stack Reflection and Querying
+// File: %d-stack.h
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2015-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// This file contains interactive debugging support for examining and
+// interacting with the stack.
+//
+// !!! Interactive debugging is a work in progress, and comments are in the
+// functions below.
+//
+
+#include "sys-core.h"
+
+
+//
+// Collapsify_Array: C
+//
+// This will replace "long" nested blocks with collapsed versions with
+// ellipses to show they have been cut off. It does not change the arrays
+// in question, but replaces them with copies.
+//
+void Collapsify_Array(REBARR *array, REBSPC *specifier, REBCNT limit)
+{
+ RELVAL *item = ARR_HEAD(array);
+ for (; NOT_END(item); ++item) {
+ if (ANY_ARRAY(item) && VAL_LEN_AT(item) > limit) {
+ REBSPC *derived = Derive_Specifier(specifier, item);
+ REBARR *copy = Copy_Array_At_Max_Shallow(
+ VAL_ARRAY(item),
+ VAL_INDEX(item),
+ derived,
+ limit + 1
+ );
+
+ Init_Word(ARR_AT(copy, limit), Canon(SYM_ELLIPSIS));
+
+ Collapsify_Array(
+ copy,
+ SPECIFIED,
+ limit
+ );
+
+ enum Reb_Kind kind = VAL_TYPE(item);
+ Init_Any_Array_At(item, kind, copy, 0); // at 0 now
+ assert(IS_SPECIFIC(item));
+ assert(NOT_VAL_FLAG(item, VALUE_FLAG_LINE)); // should be cleared
+ }
+ }
+}
+
+
+//
+// Make_Where_For_Frame: C
+//
+// Each call frame maintains the array it is executing in, the current index
+// in that array, and the index of where the current expression started.
+// This can be deduced into a segment of code to display in the debug views
+// to indicate roughly "what's running" at that stack level. The code is
+// a shallow copy of the array content.
+//
+// The resulting WHERE information only includes the range of the array being
+// executed up to the point of currently relevant evaluation. It does not
+// go all the way to the tail of the block (where future potential evaluation
+// should be.
+//
+// !!! Unfortunately, Rebol doesn't formalize this very well. There is no
+// lock on segments of blocks during their evaluation (should there be?).
+// It's possible for self-modifying code to scramble the blocks being executed.
+// The DO evaluator is robust in terms of not *crashing*, but the semantics
+// may well suprise users.
+//
+// !!! DO also offers a feature whereby values can be supplied at the start
+// of an evaluation which are not resident in the array. It also can run
+// on an irreversible C va_list of REBVAL*, where these disappear as the
+// evaluation proceeds. A special debug setting would be needed to hang
+// onto these values for the purposes of better error messages (at the cost
+// of performance).
+//
+REBARR *Make_Where_For_Frame(REBFRM *f)
+{
+ if (FRM_IS_VALIST(f)) {
+ //
+ // Traversing a C va_arg, so reify into a (truncated) array.
+ //
+ const REBOOL truncated = TRUE;
+ Reify_Va_To_Array_In_Frame(f, truncated);
+ }
+
+
+ // WARNING: MIN is a C macro and repeats its arguments.
+ //
+ REBCNT start = MIN(ARR_LEN(FRM_ARRAY(f)), FRM_EXPR_INDEX(f));
+ REBCNT end = MIN(ARR_LEN(FRM_ARRAY(f)), FRM_INDEX(f));
+
+ assert(end >= start);
+
+ assert(Is_Any_Function_Frame(f));
+ REBOOL pending = Is_Function_Frame_Fulfilling(f);
+
+ REBCNT dsp_start = DSP;
+
+ // !!! We may be running a function where the value for the function was a
+ // "head" value not in the array. These cases could substitute the symbol
+ // for the currently executing function. Reconsider when such cases
+ // appear and can be studied.
+ /*
+ DS_PUSH_TRASH;
+ Init_Word(DS_TOP, FRM_LABEL(f));
+ */
+
+ REBCNT n;
+ for (n = start; n < end; ++n) {
+ DS_PUSH_TRASH;
+ if (IS_VOID(ARR_AT(FRM_ARRAY(f), n))) {
+ //
+ // If a va_list is used to do a non-evaluative call (something
+ // like R3-Alpha's APPLY/ONLY) then void cells are currently
+ // allowed. Reify_Va_To_Array_In_Frame() may come along and
+ // make a special block containing voids, which we don't want
+ // to expose in a user-visible block. Since this array is just
+ // for display purposes and is "lossy" (as evidenced by the ...)
+ // substitute a placeholder to avoid crashing the GC.
+ //
+ assert(GET_SER_FLAG(FRM_ARRAY(f), ARRAY_FLAG_VOIDS_LEGAL));
+ Init_Word(DS_TOP, Canon(SYM___VOID__));
+ }
+ else
+ Derelativize(DS_TOP, ARR_AT(FRM_ARRAY(f), n), f->specifier);
+
+ if (n == start) {
+ //
+ // Get rid of any newline marker on the first element,
+ // that would visually disrupt the backtrace for no reason.
+ //
+ CLEAR_VAL_FLAG(DS_TOP, VALUE_FLAG_LINE);
+ }
+ }
+
+ // We add an ellipsis to a pending frame to make it a little bit
+ // clearer what is going on. If someone sees a where that looks
+ // like just `* [print]` the asterisk alone doesn't quite send
+ // home the message that print is not running and it is
+ // argument fulfillment that is why it's not "on the stack"
+ // yet, so `* [print ...]` is an attempt to say that better.
+ //
+ // !!! This is in-band, which can be mixed up with literal usage
+ // of ellipsis. Could there be a better "out-of-band" conveyance?
+ // Might the system use colorization in a value option bit?
+ //
+ if (pending) {
+ DS_PUSH_TRASH;
+ Init_Word(DS_TOP, Canon(SYM_ELLIPSIS));
+ }
+
+ REBARR *where = Pop_Stack_Values(dsp_start);
+
+ // Simplify overly-deep blocks embedded in the where so they show (...)
+ // instead of printing out fully.
+ //
+ Collapsify_Array(where, SPECIFIED, 3);
+
+ return where;
+}
+
+
+//
+// where-of: native [
+//
+// "Get execution point summary for a function call (if still on stack)"
+//
+// level [frame! function! integer! blank!]
+// ]
+//
+REBNATIVE(where_of)
+//
+// !!! This routine should probably be used to get the information for the
+// where of an error, which should likely be out-of-band.
+{
+ INCLUDE_PARAMS_OF_WHERE_OF;
+
+ REBFRM *frame = Frame_For_Stack_Level(NULL, ARG(level), TRUE);
+ if (frame == NULL)
+ fail (ARG(level));
+
+ Init_Block(D_OUT, Make_Where_For_Frame(frame));
+ return R_OUT;
+}
+
+
+//
+// label-of: native [
+//
+// "Get word label used to invoke a function call (if still on stack)"
+//
+// level [frame! function! integer!]
+// ]
+//
+REBNATIVE(label_of)
+{
+ INCLUDE_PARAMS_OF_LABEL_OF;
+
+ REBFRM *frame = Frame_For_Stack_Level(NULL, ARG(level), TRUE);
+
+ // Make it slightly easier by returning a NONE! instead of giving an
+ // error for a frame that isn't on the stack.
+ //
+ // !!! Should a function that was invoked by something other than a WORD!
+ // return something like TRUE instead of a fake symbol?
+ //
+ if (frame == NULL)
+ return R_BLANK;
+
+ Init_Word(D_OUT, FRM_LABEL(frame));
+ return R_OUT;
+}
+
+
+//
+// file-of: native [
+//
+// "Get filename of origin for any series"
+//
+// return: [file! url! blank!]
+// series [any-series!]
+// ]
+//
+REBNATIVE(file_of)
+{
+ INCLUDE_PARAMS_OF_FILE_OF;
+
+ REBSER *s = VAL_SERIES(ARG(series));
+
+ if (NOT_SER_FLAG(s, SERIES_FLAG_FILE_LINE))
+ return R_BLANK;
+
+ // !!! How to tell whether it's a URL! or a FILE! ?
+ //
+ Scan_File(D_OUT, STR_HEAD(s->link.filename), SER_LEN(s->link.filename));
+ return R_OUT;
+}
+
+
+//
+// line-of: native [
+//
+// "Get line of origin for any series"
+//
+// return: [integer! blank!]
+// series [any-series!]
+// ]
+//
+REBNATIVE(line_of)
+{
+ INCLUDE_PARAMS_OF_LINE_OF;
+
+ REBSER *s = VAL_SERIES(ARG(series));
+
+ if (NOT_SER_FLAG(s, SERIES_FLAG_FILE_LINE))
+ return R_BLANK;
+
+ Init_Integer(D_OUT, s->misc.line);
+ return R_OUT;
+}
+
+
+//
+// function-of: native [
+//
+// "Get the FUNCTION! for a stack level or frame"
+//
+// return: [function!]
+// level [frame! integer!]
+// ]
+//
+REBNATIVE(function_of)
+{
+ INCLUDE_PARAMS_OF_FUNCTION_OF;
+
+ REBVAL *level = ARG(level);
+
+ if (IS_FRAME(level)) {
+ //
+ // If a FRAME!, then the keylist *should* be the function params,
+ // which should be coercible to a function even when the call is
+ // no longer on the stack.
+ //
+ REBCTX *context = VAL_CONTEXT(level);
+ Move_Value(D_OUT, CTX_FRAME_FUNC_VALUE(context));
+ }
+ else {
+ REBFRM *frame = Frame_For_Stack_Level(NULL, level, TRUE);
+ if (!frame)
+ fail (level);
+
+ Move_Value(D_OUT, FUNC_VALUE(frame->phase));
+ }
+
+ return R_OUT;
+}
+
+
+//
+// backtrace-index: native [
+//
+// "Get the index of a given frame or function as BACKTRACE shows it"
+//
+// level [function! frame!]
+// {The function or frame to get an index for (NONE! if not running)}
+// ]
+//
+REBNATIVE(backtrace_index)
+{
+ INCLUDE_PARAMS_OF_BACKTRACE_INDEX;
+
+ REBCNT number;
+
+ if (NULL != Frame_For_Stack_Level(&number, ARG(level), TRUE)) {
+ Init_Integer(D_OUT, number);
+ return R_OUT;
+ }
+
+ return R_BLANK;
+}
+
+
+//
+// backtrace: native [
+//
+// "Backtrace to find a specific FRAME!, or other queried property."
+//
+// return: [ block! frame!]
+// "Nothing if printing, if specific level a frame! else block"
+// level [ blank! integer! function!]
+// "Stack level to return frame for (blank to list)"
+// /limit
+// "Limit the length of the backtrace"
+// frames [blank! integer!]
+// "Max number of frames (pending and active), blank for no limit"
+// /brief
+// "Do not list depths, just function labels on one line"
+// ]
+//
+REBNATIVE(backtrace)
+{
+ INCLUDE_PARAMS_OF_BACKTRACE;
+
+ Check_Security(Canon(SYM_DEBUG), POL_READ, 0);
+
+ // Note: Running this code path is *intentionally* redundant with
+ // Frame_For_Stack_Level, as a way of keeping the numbers listed in a
+ // backtrace lined up with what that routine returns. This isn't a very
+ // performance-critical routine, so it's good to have the doublecheck.
+ //
+ REBVAL *level = ARG(level);
+ REBOOL get_frame = NOT(IS_VOID(level) || IS_BLANK(level));
+ if (get_frame) {
+ //
+ // /LIMIT assumes that you are returning a list of backtrace items,
+ // while specifying a level gives one. They are mutually exclusive.
+ //
+ if (REF(limit) || REF(brief))
+ fail (Error_Bad_Refines_Raw());
+
+ // See notes on handling of breakpoint below for why 0 is accepted.
+ //
+ if (IS_INTEGER(level) && VAL_INT32(level) < 0)
+ fail (level);
+ }
+
+ REBCNT max_rows; // The "frames" from /LIMIT, plus one (for ellipsis)
+ if (REF(limit)) {
+ if (IS_BLANK(ARG(frames)))
+ max_rows = MAX_U32; // NONE is no limit--as many frames as possible
+ else {
+ if (VAL_INT32(ARG(frames)) < 0)
+ fail (ARG(frames));
+ max_rows = VAL_INT32(ARG(frames)) + 1; // + 1 for ellipsis
+ }
+ }
+ else
+ max_rows = 20; // On an 80x25 terminal leaves room to type afterward
+
+ REBDSP dsp_orig = DSP; // original stack pointer (for gathered backtrace)
+
+ REBCNT row = 0; // row we're on (incl. pending frames and maybe ellipsis)
+ REBCNT number = 0; // level label number in the loop(no pending frames)
+ REBOOL first = TRUE; // special check of first frame for "breakpoint 0"
+
+ REBFRM *f;
+ for (f = FS_TOP->prior; f != NULL; f = f->prior) {
+ //
+ // Only consider invoked or pending functions in the backtrace.
+ //
+ // !!! The pending functions aren't actually being "called" yet,
+ // their frames are in a partial state of construction. However it
+ // gives a fuller picture to see them in the backtrace. It may
+ // be interesting to see GROUP! stack levels that are being
+ // executed as well (as they are something like DO).
+ //
+ if (NOT(Is_Any_Function_Frame(f)))
+ continue;
+
+ REBOOL pending = Is_Function_Frame_Fulfilling(f);
+ if (NOT(pending)) {
+ if (
+ first
+ && (
+ FUNC_DISPATCHER(f->phase) == &N_pause
+ || FUNC_DISPATCHER(f->phase) == &N_breakpoint
+ )
+ ) {
+ // Omitting breakpoints from the list entirely presents a
+ // skewed picture of what's going on. But giving them
+ // "index 1" means that inspecting the frame you're actually
+ // interested in (the one where you put the breakpoint) bumps
+ // to 2, which feels unnatural.
+ //
+ // Compromise by not incrementing the stack numbering for
+ // this case, leaving a leading breakpoint frame at index 0.
+ }
+ else
+ ++number;
+ }
+
+ first = FALSE;
+
+ ++row;
+
+ #if !defined(NDEBUG)
+ //
+ // Try and keep the numbering in sync with query used by host to get
+ // function frames to do binding in the REPL with.
+ //
+ if (!pending) {
+ DECLARE_LOCAL (temp_val);
+ Init_Integer(temp_val, number);
+
+ REBCNT temp_num;
+ if (
+ Frame_For_Stack_Level(&temp_num, temp_val, TRUE) != f
+ || temp_num != number
+ ) {
+ printf(
+ "%d != Frame_For_Stack_Level %d",
+ cast(int, number),
+ cast(int, temp_num)
+ );
+ fflush(stdout);
+ assert(FALSE);
+ }
+ }
+ #endif
+
+ if (get_frame) {
+ if (IS_INTEGER(level)) {
+ if (number != cast(REBCNT, VAL_INT32(level))) // is positive
+ continue;
+ }
+ else {
+ assert(IS_FUNCTION(level));
+ if (f->phase != VAL_FUNC(level))
+ continue;
+ }
+ }
+ else {
+ if (row >= max_rows) {
+ //
+ // If there's more stack levels to be shown than we were asked
+ // to show, then put an `+ ...` in the list and break.
+ //
+ DS_PUSH_TRASH;
+ Init_Word(DS_TOP, Canon(SYM_PLUS));
+
+ if (NOT(REF(brief))) {
+ //
+ // In the non-/ONLY backtrace, the pairing of the ellipsis
+ // with a plus is used in order to keep the "record size"
+ // of the list at an even 2. Asterisk might have been
+ // used but that is taken for "pending frames".
+ //
+ // !!! Review arbitrary symbolic choices.
+ //
+ DS_PUSH_TRASH;
+ Init_Word(DS_TOP, Canon(SYM_ASTERISK));
+ SET_VAL_FLAG(DS_TOP, VALUE_FLAG_LINE); // put on own line
+ }
+ break;
+ }
+ }
+
+ if (get_frame) {
+ //
+ // If we were fetching a single stack level, then our result will
+ // be a FRAME! (which can be queried for further properties via
+ // `where-of`, `label-of`, `function-of`, etc.)
+ //
+ Init_Any_Context(
+ D_OUT,
+ REB_FRAME,
+ Context_For_Frame_May_Reify_Managed(f)
+ );
+ return R_OUT;
+ }
+
+ // !!! Should /BRIEF omit pending frames? Should it have a less
+ // "loaded" name for the refinement?
+ //
+ if (REF(brief)) {
+ DS_PUSH_TRASH;
+ Init_Word(DS_TOP, FRM_LABEL(f));
+ continue;
+ }
+
+ DS_PUSH_TRASH;
+ Init_Block(DS_TOP, Make_Where_For_Frame(f));
+
+ // If building a backtrace, we just keep accumulating results as long
+ // as there are stack levels left and the limit hasn't been hit.
+
+ // The integer identifying the stack level (used to refer to it
+ // in other debugging commands). Since we're going in reverse, we
+ // add it after the props so it will show up before, and give it
+ // the newline break marker.
+ //
+ DS_PUSH_TRASH;
+ if (pending) {
+ //
+ // You cannot (or should not) switch to inspect a pending frame,
+ // as it is partially constructed. It gets a "*" in the list
+ // instead of a number.
+ //
+ // !!! This may be too restrictive; though it is true you can't
+ // resume/from or exit/from a pending frame (due to the index
+ // not knowing how many values it would have consumed if a
+ // call were to complete), inspecting the existing args could
+ // be okay. Disallowing it offers more flexibility in the
+ // dealings with the arguments, however (for instance: not having
+ // to initialize not-yet-filled args could be one thing).
+ //
+ Init_Word(DS_TOP, Canon(SYM_ASTERISK));
+ }
+ else
+ Init_Integer(DS_TOP, number);
+
+ SET_VAL_FLAG(DS_TOP, VALUE_FLAG_LINE);
+ }
+
+ // If we ran out of stack levels before finding the single one requested
+ // via /AT, return a NONE!
+ //
+ // !!! Would it be better to give an error?
+ //
+ if (get_frame)
+ return R_BLANK;
+
+ // Return accumulated backtrace otherwise, in the reverse order pushed
+ //
+ Init_Block(D_OUT, Pop_Stack_Values_Reversed(dsp_orig));
+ return R_OUT;
+}
+
+
+//
+// Frame_For_Stack_Level: C
+//
+// Level can be a void, an INTEGER!, an ANY-FUNCTION!, or a FRAME!. If
+// level is void then it means give whatever the first call found is.
+//
+// Returns NULL if the given level number does not correspond to a running
+// function on the stack.
+//
+// Can optionally give back the index number of the stack level (counting
+// where the most recently pushed stack level is the lowest #)
+//
+// !!! Unfortunate repetition of logic inside of BACKTRACE. Assertions
+// are used to try and keep them in sync, by noticing during backtrace
+// if the stack level numbers being handed out don't line up with what
+// would be given back by this routine. But it would be nice to find a way
+// to unify the logic for omitting things like breakpoint frames, or either
+// considering pending frames or not.
+//
+REBFRM *Frame_For_Stack_Level(
+ REBCNT *number_out,
+ const REBVAL *level,
+ REBOOL skip_current
+) {
+ REBFRM *frame = FS_TOP;
+ REBOOL first = TRUE;
+ REBINT num = 0;
+
+ if (IS_INTEGER(level)) {
+ if (VAL_INT32(level) < 0) {
+ //
+ // !!! fail() here, or just return NULL?
+ //
+ return NULL;
+ }
+ }
+
+ // We may need to skip some number of frames, if there have been stack
+ // levels added since the numeric reference point that "level" was
+ // supposed to refer to has changed. For now that's only allowed to
+ // be one level, because it's rather fuzzy which stack levels to
+ // omit otherwise (pending? parens?)
+ //
+ if (skip_current)
+ frame = frame->prior;
+
+ for (; frame != NULL; frame = frame->prior) {
+ if (NOT(Is_Any_Function_Frame(frame))) {
+ //
+ // Don't consider pending calls, or GROUP!, or any non-invoked
+ // function as a candidate to target.
+ //
+ // !!! The inability to target a GROUP! by number is an artifact
+ // of implementation, in that there's no hook in Do_Core() at
+ // the point of group evaluation to process the return. The
+ // matter is different with a pending function call, because its
+ // arguments are only partially processed--hence something
+ // like a RESUME/AT or an EXIT/FROM would not know which array
+ // index to pick up running from.
+ //
+ continue;
+ }
+
+ REBOOL pending = Is_Function_Frame_Fulfilling(frame);
+ if (NOT(pending)) {
+ if (first) {
+ if (
+ FUNC_DISPATCHER(frame->phase) == &N_pause
+ || FUNC_DISPATCHER(frame->phase) == N_breakpoint
+ ) {
+ // this is considered the "0". Return it only if 0 was requested
+ // specifically (you don't "count down to it");
+ //
+ if (IS_INTEGER(level) && num == VAL_INT32(level))
+ goto return_maybe_set_number_out;
+ else {
+ first = FALSE;
+ continue;
+ }
+ }
+ else {
+ ++num; // bump up from 0
+ }
+ }
+ }
+
+ first = FALSE;
+
+ if (pending) continue;
+
+ if (IS_INTEGER(level) && num == VAL_INT32(level))
+ goto return_maybe_set_number_out;
+
+ if (IS_VOID(level) || IS_BLANK(level)) {
+ //
+ // Take first actual frame if void or blank
+ //
+ goto return_maybe_set_number_out;
+ }
+ else if (IS_INTEGER(level)) {
+ ++num;
+ if (num == VAL_INT32(level))
+ goto return_maybe_set_number_out;
+ }
+ else if (IS_FRAME(level)) {
+ if (frame->varlist == CTX_VARLIST(VAL_CONTEXT(level))) {
+ goto return_maybe_set_number_out;
+ }
+ }
+ else {
+ assert(IS_FUNCTION(level));
+ if (VAL_FUNC(level) == frame->phase)
+ goto return_maybe_set_number_out;
+ }
+ }
+
+ // Didn't find it...
+ //
+ return NULL;
+
+return_maybe_set_number_out:
+ if (number_out)
+ *number_out = num;
+ return frame;
+}
+
+
+//
+// Is_Context_Running_Or_Pending: C
+//
+REBOOL Is_Context_Running_Or_Pending(REBCTX *frame_ctx)
+{
+ REBFRM *f = CTX_FRAME_IF_ON_STACK(frame_ctx);
+ if (f == NULL)
+ return FALSE;
+
+ if (Is_Function_Frame_Fulfilling(f))
+ return FALSE;
+
+ return TRUE;
+}
+
+
+//
+// running?: native [
+//
+// "Returns TRUE if a FRAME! is on the stack and executing (arguments done)."
+//
+// frame [frame!]
+// ]
+//
+REBNATIVE(running_q)
+{
+ INCLUDE_PARAMS_OF_RUNNING_Q;
+
+ REBCTX *frame_ctx = VAL_CONTEXT(ARG(frame));
+
+ REBFRM *f = CTX_FRAME_IF_ON_STACK(frame_ctx);
+ if (f == NULL)
+ return R_FALSE;
+
+ if (Is_Function_Frame_Fulfilling(f))
+ return R_FALSE;
+
+ return R_TRUE;
+}
+
+
+//
+// pending?: native [
+//
+// "Returns TRUE if a FRAME! is on the stack, but is gathering arguments."
+//
+// frame [frame!]
+// ]
+//
+REBNATIVE(pending_q)
+{
+ INCLUDE_PARAMS_OF_PENDING_Q;
+
+ REBCTX *frame_ctx = VAL_CONTEXT(ARG(frame));
+
+ REBFRM *f = CTX_FRAME_IF_ON_STACK(frame_ctx);
+ if (f == NULL)
+ return R_FALSE;
+
+ if (Is_Function_Frame_Fulfilling(f))
+ return R_TRUE;
+
+ return R_FALSE;
+}
diff --git a/src/core/d-trace.c b/src/core/d-trace.c
new file mode 100644
index 0000000000..fa2cd01ace
--- /dev/null
+++ b/src/core/d-trace.c
@@ -0,0 +1,282 @@
+//
+// File: %d-trace.c
+// Summary: "Tracing Debug Routines"
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// TRACE is functionality that was in R3-Alpha for doing low-level tracing.
+// It could be turned on with `trace on` and off with `trace off`. While
+// it was on, it would print out information about the current execution step.
+//
+// Ren-C's goal is to have a fully-featured debugger that should allow a
+// TRACE-like facility to be written and customized by the user. They would
+// be able to get access on each step to the call frame, and control the
+// evaluator from within.
+//
+// A lower-level trace facility may still be interesting even then, for
+// "debugging the debugger". Either way, the routines have been extracted
+// from %c-do.c in order to reduce the total length of that very long file.
+//
+
+#include "sys-core.h"
+
+
+//
+// Eval_Depth: C
+//
+REBINT Eval_Depth(void)
+{
+ REBINT depth = 0;
+ REBFRM *frame = FS_TOP;
+
+ for (; frame != NULL; frame = FRM_PRIOR(frame), depth++)
+ NOOP;
+
+ return depth;
+}
+
+
+//
+// Frame_At_Depth: C
+//
+REBFRM *Frame_At_Depth(REBCNT n)
+{
+ REBFRM *frame = FS_TOP;
+
+ while (frame) {
+ if (n == 0) return frame;
+
+ --n;
+ frame = FRM_PRIOR(frame);
+ }
+
+ return NULL;
+}
+
+
+static REBINT Init_Depth(void)
+{
+ // Check the trace depth is ok:
+ REBINT depth = Eval_Depth() - Trace_Depth;
+ if (depth < 0 || depth >= Trace_Level) return -1;
+ if (depth > 10) depth = 10;
+ Debug_Space(cast(REBCNT, 4 * depth));
+ return depth;
+}
+
+
+#define CHECK_DEPTH(d) if ((d = Init_Depth()) < 0) return;\
+
+
+//
+// Trace_Line: C
+//
+void Trace_Line(REBFRM *f)
+{
+ int depth;
+
+ if (GET_FLAG(Trace_Flags, 1)) return; // function
+ if (IS_FUNCTION(f->value)) return;
+
+ CHECK_DEPTH(depth);
+
+ if (IS_END(f->value)) {
+ Debug_Fmt_("END");
+ }
+ else if (f->flags.bits & DO_FLAG_VA_LIST) {
+ Debug_Fmt_("VA_LIST_FLAG...");
+ }
+ else {
+ Debug_Fmt_("%-02d: %50r", cast(REBINT, f->index), f->value);
+ }
+
+ if (IS_WORD(f->value) || IS_GET_WORD(f->value)) {
+ const RELVAL *var = Get_Opt_Var_May_Fail(f->value, f->specifier);
+ if (VAL_TYPE(var) < REB_FUNCTION)
+ Debug_Fmt_(" : %50r", var);
+ else if (VAL_TYPE(var) == REB_FUNCTION) {
+ REBARR *words = List_Func_Words(var, FALSE); // no locals
+ Debug_Fmt_(" : %s %50m", Get_Type_Name(var), words);
+ Free_Array(words);
+ }
+ else
+ Debug_Fmt_(" : %s", Get_Type_Name(var));
+ }
+ Debug_Line();
+}
+
+
+//
+// Trace_Func: C
+//
+void Trace_Func(REBSTR *label)
+{
+ int depth;
+ CHECK_DEPTH(depth);
+ Debug_Fmt_(RM_TRACE_FUNCTION, STR_HEAD(label));
+ if (GET_FLAG(Trace_Flags, 1))
+ Debug_Values(FRM_ARG(FS_TOP, 1), FRM_NUM_ARGS(FS_TOP), 20);
+ else Debug_Line();
+}
+
+
+//
+// Trace_Return: C
+//
+void Trace_Return(REBSTR *label, const REBVAL *value)
+{
+ int depth;
+ CHECK_DEPTH(depth);
+ Debug_Fmt_(RM_TRACE_RETURN, STR_HEAD(label));
+ Debug_Values(value, 1, 50);
+}
+
+
+//
+// Trace_Value: C
+//
+void Trace_Value(
+ const char* label, // currently "match" or "input"
+ const RELVAL *value
+) {
+ int depth;
+ CHECK_DEPTH(depth);
+ Debug_Fmt(RM_TRACE_PARSE_VALUE, label, value);
+}
+
+
+//
+// Trace_String: C
+//
+void Trace_String(const REBYTE *str, REBINT limit)
+{
+ static char tracebuf[64];
+ int depth;
+ int len = MIN(60, limit);
+ CHECK_DEPTH(depth);
+ memcpy(tracebuf, str, len);
+ tracebuf[len] = '\0';
+ Debug_Fmt(RM_TRACE_PARSE_INPUT, tracebuf);
+}
+
+
+//
+// Trace_Error: C
+//
+void Trace_Error(const REBVAL *value)
+{
+ int depth;
+ CHECK_DEPTH(depth);
+ Debug_Fmt(
+ RM_TRACE_ERROR,
+ &VAL_ERR_VARS(value)->type,
+ &VAL_ERR_VARS(value)->id
+ );
+}
+
+
+//
+// trace: native [
+//
+// {Enables and disables evaluation tracing and backtrace.}
+//
+// return: []
+// mode [integer! logic!]
+// /back
+// {Set mode ON to enable or integer for lines to display}
+// /function
+// "Traces functions only (less output)"
+// ]
+//
+REBNATIVE(trace)
+{
+ INCLUDE_PARAMS_OF_TRACE;
+
+ REBVAL *mode = ARG(mode);
+
+ Check_Security(Canon(SYM_DEBUG), POL_READ, 0);
+
+ // The /back option: ON and OFF, or INTEGER! for # of lines:
+ if (REF(back)) {
+ if (IS_LOGIC(mode)) {
+ Enable_Backtrace(VAL_LOGIC(mode));
+ }
+ else if (IS_INTEGER(mode)) {
+ REBINT lines = Int32(mode);
+ Trace_Flags = 0;
+ if (lines < 0)
+ fail (mode);
+
+ Display_Backtrace(cast(REBCNT, lines));
+ return R_VOID;
+ }
+ }
+ else
+ Enable_Backtrace(FALSE);
+
+ // Set the trace level:
+ if (IS_LOGIC(mode))
+ Trace_Level = VAL_LOGIC(mode) ? 100000 : 0;
+ else
+ Trace_Level = Int32(mode);
+
+ if (Trace_Level) {
+ Trace_Flags = 1;
+ if (REF(function))
+ SET_FLAG(Trace_Flags, 1);
+ Trace_Depth = Eval_Depth() - 1; // subtract current TRACE frame
+ }
+ else
+ Trace_Flags = 0;
+
+ return R_VOID;
+}
+
+
+#if !defined(NDEBUG)
+
+//
+// Trace_Fetch_Debug: C
+//
+// When down to the wire and wanting to debug the evaluator, it can be very
+// useful to see the steps of the states it's going through to see what is
+// wrong. This routine hooks the individual fetch and writes at a more
+// fine-grained level than a breakpoint at each DO/NEXT point.
+//
+void Trace_Fetch_Debug(const char* msg, REBFRM *f, REBOOL after) {
+ Debug_Fmt(
+ "%d - %s : %s",
+ cast(REBCNT, f->index),
+ msg,
+ after ? "AFTER" : "BEFORE"
+ );
+
+ if (IS_END(f->value))
+ Debug_Fmt("f->value is END");
+ else
+ PROBE(f->value);
+}
+
+#endif
diff --git a/src/core/f-blocks.c b/src/core/f-blocks.c
old mode 100644
new mode 100755
index a6040a9ef6..9cb868ddbd
--- a/src/core/f-blocks.c
+++ b/src/core/f-blocks.c
@@ -1,441 +1,567 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: f-blocks.c
-** Summary: primary block series support functions
-** Section: functional
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %f-blocks.c
+// Summary: "primary block series support functions"
+// Section: functional
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ REBSER *Make_Block(REBCNT length)
-/*
-** Make a block series. Add 1 extra for the terminator.
-** Set TAIL to zero and set terminator.
-**
-***********************************************************************/
-{
- REBSER *series = Make_Series(length + 1, sizeof(REBVAL), FALSE);
- SET_END(BLK_HEAD(series));
- PG_Reb_Stats->Blocks++;
- return series;
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Copy_Block(REBSER *block, REBCNT index)
-/*
-** Shallow copy a block from the given index thru the tail.
-**
-***********************************************************************/
-{
- REBCNT len = SERIES_TAIL(block);
- REBSER *series;
-
- if (index > len) return Make_Block(0);
-
- len -= index;
- series = Make_Series(len + 1, sizeof(REBVAL), FALSE);
- COPY_BLK_PART(series, BLK_SKIP(block, index), len);
-
- PG_Reb_Stats->Blocks++;
-
- return series;
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Copy_Block_Len(REBSER *block, REBCNT index, REBCNT len)
-/*
-** Shallow copy a block from the given index for given length.
-**
-***********************************************************************/
-{
- REBSER *series;
-
- if (index > SERIES_TAIL(block)) return Make_Block(0);
- if (index + len > SERIES_TAIL(block)) len = SERIES_TAIL(block) - index;
-
- series = Make_Series(len + 1, sizeof(REBVAL), FALSE);
- COPY_BLK_PART(series, BLK_SKIP(block, index), len);
-
- PG_Reb_Stats->Blocks++;
-
- return series;
+// !!! Currently, callers don't specify if they are copying an array to turn
+// it into a paramlist or varlist, or to use as the kind of array the user
+// might see. If we used plain Make_Array() then it would add a flag saying
+// there were line numbers available, which may compete with the usage of the
+// ->misc and ->link fields of the series node for internal arrays. Pass 0.
+//
+#define Make_Array_For_Copy(a) \
+ Make_Array_Core((a), 0)
+
+
+//
+// Copy_Array_At_Extra_Shallow: C
+//
+// Shallow copy an array from the given index thru the tail.
+// Additional capacity beyond what is required can be added
+// by giving an `extra` count of how many value cells one needs.
+//
+REBARR *Copy_Array_At_Extra_Shallow(
+ REBARR *original,
+ REBCNT index,
+ REBSPC *specifier,
+ REBCNT extra
+) {
+ REBCNT len = ARR_LEN(original);
+
+ if (index > len)
+ return Make_Array_For_Copy(0);
+
+ len -= index;
+
+ REBARR *copy = Make_Array_For_Copy(len + extra + 1);
+
+ if (specifier == SPECIFIED) {
+ //
+ // We can just bit-copy a fully specified array. By its definition
+ // it may not contain any RELVALs. But in the debug build, double
+ // check that...
+ //
+ #if !defined(NDEBUG)
+ RELVAL *check = ARR_AT(original, index);
+ REBCNT count = 0;
+ for (; count < len; ++count)
+ assert(IS_SPECIFIC(check));
+ #endif
+
+ memcpy(ARR_HEAD(copy), ARR_AT(original, index), len * sizeof(REBVAL));
+ }
+ else {
+ // Any RELVALs will have to be handled. Review if a memcpy with
+ // a touch-up phase is faster, or if there is any less naive way.
+ //
+ RELVAL *src = ARR_AT(original, index);
+ REBVAL *dest = KNOWN(ARR_HEAD(copy));
+ REBCNT count = 0;
+ for (; count < len; ++count, ++dest, ++src)
+ Derelativize(dest, src, specifier);
+ }
+
+ TERM_ARRAY_LEN(copy, len);
+
+ return copy;
}
-/***********************************************************************
-**
-*/ REBSER *Copy_Values(REBVAL *blk, REBCNT length)
-/*
-** Shallow copy a block from current value for length values.
-**
-***********************************************************************/
-{
- REBSER *series;
-
- series = Make_Series(length + 1, sizeof(REBVAL), FALSE);
- COPY_BLK_PART(series, blk, length);
-
- PG_Reb_Stats->Blocks++;
-
- return series;
+//
+// Copy_Array_At_Max_Shallow: C
+//
+// Shallow copy an array from the given index for given maximum
+// length (clipping if it exceeds the array length)
+//
+REBARR *Copy_Array_At_Max_Shallow(
+ REBARR *original,
+ REBCNT index,
+ REBSPC *specifier,
+ REBCNT max
+) {
+ if (index > ARR_LEN(original))
+ return Make_Array_For_Copy(0);
+
+ if (index + max > ARR_LEN(original))
+ max = ARR_LEN(original) - index;
+
+ REBARR *copy = Make_Array_For_Copy(max + 1);
+
+ if (specifier == SPECIFIED) {
+ #if !defined(NDEBUG)
+ REBCNT count = 0;
+ const RELVAL *check = ARR_AT(original, index);
+ for (; count < max; ++count, ++check) {
+ assert(IS_SPECIFIC(check));
+ }
+ #endif
+ memcpy(ARR_HEAD(copy), ARR_AT(original, index), max * sizeof(REBVAL));
+ }
+ else {
+ REBCNT count = 0;
+ const RELVAL *src = ARR_AT(original, index);
+ RELVAL *dest = ARR_HEAD(copy);
+ for (; count < max; ++count, ++src, ++dest)
+ Derelativize(dest, src, specifier);
+ }
+
+ TERM_ARRAY_LEN(copy, max);
+
+ return copy;
}
-/***********************************************************************
-**
-*/ void Copy_Deep_Values(REBSER *block, REBCNT index, REBCNT tail, REBU64 types)
-/*
-** Copy the contents of values specified by types. If the
-** DEEP flag is set, recurse into sub-blocks and objects.
-**
-***********************************************************************/
-{
- REBVAL *val;
-
- for (; index < tail; index++) {
-
- val = BLK_SKIP(block, index);
-
- if ((types & TYPESET(VAL_TYPE(val)) & TS_SERIES_OBJ) != 0) {
- // Replace just the series field of the value
- // Note that this should work for objects too (the frame).
- VAL_SERIES(val) = Copy_Series(VAL_SERIES(val));
- if ((types & TYPESET(VAL_TYPE(val)) & TS_BLOCKS_OBJ) != 0) {
- PG_Reb_Stats->Blocks++;
- // If we need to copy recursively (deep):
- if ((types & CP_DEEP) != 0)
- Copy_Deep_Values(VAL_SERIES(val), 0, VAL_TAIL(val), types);
- }
- } else if (types & TYPESET(VAL_TYPE(val)) & TS_FUNCLOS)
- Clone_Function(val, val);
- }
+//
+// Copy_Values_Len_Extra_Skip_Shallow: C
+//
+// Shallow copy the first 'len' values of `head` into a new
+// series created to hold exactly that many entries.
+//
+REBARR *Copy_Values_Len_Extra_Skip_Shallow_Core(
+ const RELVAL head[],
+ REBSPC *specifier,
+ REBCNT len,
+ REBCNT extra,
+ REBINT skip,
+ REBUPT flags
+) {
+ REBARR *array = Make_Array_Core(len + extra + 1, flags);
+
+ if (specifier == SPECIFIED && skip == 1) {
+ #if !defined(NDEBUG)
+ REBCNT count = 0;
+ const RELVAL *check = head;
+ for (; count < len; ++count, ++check) {
+ assert(IS_SPECIFIC(check));
+ }
+ #endif
+ memcpy(ARR_HEAD(array), head, len * sizeof(REBVAL));
+ }
+ else {
+ REBCNT count = 0;
+ const RELVAL *src = head;
+ RELVAL *dest = ARR_HEAD(array);
+ for (; count < len; ++count, src += skip, ++dest)
+ Derelativize(dest, src, specifier);
+ }
+
+ TERM_ARRAY_LEN(array, len);
+
+ return array;
}
-/***********************************************************************
-**
-*/ REBSER *Copy_Block_Values(REBSER *block, REBCNT index, REBCNT tail, REBU64 types)
-/*
-** Copy a block, copy specified values, deeply if indicated.
-**
-***********************************************************************/
-{
- REBSER *series;
-
- if (index > tail) index = tail;
- if (index > SERIES_TAIL(block)) return Make_Block(0);
-
- series = Copy_Values(BLK_SKIP(block, index), tail - index);
-
- if (types != 0) Copy_Deep_Values(series, 0, SERIES_TAIL(series), types);
-
- return series;
+//
+// Clonify_Values_Len_Managed: C
+//
+// Update the first `len` elements of `head[]` to clone the series
+// embedded in them *if* they are in the given set of types (and
+// if "cloning" makes sense for them, e.g. they are not simple
+// scalars). If the `deep` flag is set, recurse into subseries
+// and objects when that type is matched for clonifying.
+//
+// Note: The resulting clones will be managed. The model for
+// lists only allows the topmost level to contain unmanaged
+// values...and we *assume* the values we are operating on here
+// live inside of an array. (We also assume the source values
+// are in an array, and assert that they are managed.)
+//
+void Clonify_Values_Len_Managed(
+ RELVAL head[],
+ REBSPC *specifier,
+ REBCNT len,
+ REBOOL deep,
+ REBU64 types
+) {
+ if (C_STACK_OVERFLOWING(&len)) Trap_Stack_Overflow();
+
+ RELVAL *value = head;
+
+ REBCNT index;
+ for (index = 0; index < len; index++, value++) {
+ //
+ // By the rules, if we need to do a deep copy on the source
+ // series then the values inside it must have already been
+ // marked managed (because they *might* delve another level deep)
+ //
+ ASSERT_VALUE_MANAGED(value);
+
+ if (types & FLAGIT_KIND(VAL_TYPE(value)) & TS_SERIES_OBJ) {
+ #if !defined(NDEBUG)
+ REBOOL legacy = FALSE;
+ #endif
+
+ // Objects and series get shallow copied at minimum
+ //
+ REBSER *series;
+ if (ANY_CONTEXT(value)) {
+ #if !defined(NDEBUG)
+ legacy = GET_SER_INFO(
+ CTX_VARLIST(VAL_CONTEXT(value)),
+ SERIES_INFO_LEGACY_DEBUG
+ );
+ #endif
+
+ assert(!IS_FRAME(value)); // !!! Don't exist yet...
+ value->payload.any_context.varlist =
+ CTX_VARLIST(Copy_Context_Shallow(VAL_CONTEXT(value)));
+ series = SER(CTX_VARLIST(VAL_CONTEXT(value)));
+ }
+ else {
+ if (GET_SER_FLAG(VAL_SERIES(value), SERIES_FLAG_ARRAY)) {
+ #if !defined(NDEBUG)
+ legacy = GET_SER_INFO(
+ VAL_ARRAY(value), SERIES_INFO_LEGACY_DEBUG
+ );
+ #endif
+
+ REBSPC *derived = Derive_Specifier(specifier, value);
+ series = SER(
+ Copy_Array_Shallow(
+ VAL_ARRAY(value),
+ derived
+ )
+ );
+
+ INIT_VAL_ARRAY(value, ARR(series)); // copies args
+
+ // If it was relative, then copying with a specifier
+ // means it isn't relative any more.
+ //
+ INIT_SPECIFIC(value, SPECIFIED);
+ }
+ else {
+ series = Copy_Sequence(VAL_SERIES(value));
+ INIT_VAL_SERIES(value, series);
+ }
+ }
+
+ #if !defined(NDEBUG)
+ if (legacy) // propagate legacy
+ SET_SER_INFO(series, SERIES_INFO_LEGACY_DEBUG);
+ #endif
+
+ MANAGE_SERIES(series);
+
+ if (!deep) continue;
+
+ // If we're going to copy deeply, we go back over the shallow
+ // copied series and "clonify" the values in it.
+ //
+ // Since we had to get rid of the relative bindings in the
+ // shallow copy, we can pass in SPECIFIED here...but the recursion
+ // in Clonify_Values will be threading through any updated specificity
+ // through to the new values.
+ //
+ if (types & FLAGIT_KIND(VAL_TYPE(value)) & TS_ARRAYS_OBJ) {
+ REBSPC *derived = Derive_Specifier(specifier, value);
+ Clonify_Values_Len_Managed(
+ ARR_HEAD(ARR(series)),
+ derived,
+ VAL_LEN_HEAD(value),
+ deep,
+ types
+ );
+ }
+ }
+ else if (
+ types & FLAGIT_KIND(VAL_TYPE(value)) & FLAGIT_KIND(REB_FUNCTION)
+ ) {
+ Clonify_Function(KNOWN(value)); // functions never "relative"
+ }
+ else {
+ // The value is not on our radar as needing to be processed,
+ // so leave it as-is.
+ }
+
+ // Value shouldn't be relative after the above processing.
+ //
+ assert(!IS_RELATIVE(value));
+ }
}
-/***********************************************************************
-**
-*/ REBSER *Clone_Block(REBSER *block)
-/*
-** Deep copy block, including all series (strings and blocks),
-** but not images, bitsets, maps, etc.
-**
-***********************************************************************/
-{
- return Copy_Block_Values(block, 0, SERIES_TAIL(block), TS_CODE);
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Clone_Block_Value(REBVAL *code)
-/*
-** Same as above, but uses a value.
-**
-***********************************************************************/
-{
- // Note: TAIL will be clipped to correct size if INDEX is not zero.
- return Copy_Block_Values(VAL_SERIES(code), VAL_INDEX(code), VAL_TAIL(code), TS_CODE);
-}
-
-
-#ifdef obsolete
-/***********************************************************************
-**
-x*/ REBSER *Copy_Block_Deep(REBSER *block, REBCNT index, REBINT len, REBCNT mode)
-/*
-** A useful function for copying a block and its contents.
-**
-** index - used to indicate the start of the copy.
-** length - can be zero, which means use the series length - index,
-** or it can be any length, which if its less than the length
-** of the series will clip it, or if it's longer will allocate
-** extra space for it.
-** mode - indicates what to copy, how deep to copy.
-**
-***********************************************************************/
-{
- REBSER *series;
- REBVAL *val;
- REBINT maxlen = (REBINT)SERIES_TAIL(block) - index;
-
- CHECK_STACK(&series);
-
- if (mode & COPY_OBJECT) mode |= COPY_STRINGS;
-
- //DISABLE_GC; // Copy deep may trigger recycle
-
- if (maxlen < 0) maxlen = 0;
- if (len == 0 || len > maxlen) len = maxlen; // (clip size)
-
- series = (mode & COPY_SAME) ? block : Copy_Values(BLK_SKIP(block, index), len);
-
- val = BLK_HEAD(series);
- if (mode & COPY_SAME) {
- val += index;
- mode &= ~COPY_SAME;
- }
-
- for (; len > 0; len--, val++) {
- if (
- ((mode & COPY_DEEP) && (ANY_BLOCK(val) || IS_OBJECT(val) || IS_PORT(val)))
- ||
- ((mode & COPY_OBJECT) && ANY_BLOCK(val))
- ) {
- VAL_SERIES(val) = Copy_Block_Deep(VAL_SERIES(val), 0, 0, mode);
- }
- if ((mode & COPY_STRINGS) && ANY_BINSTR(val)) {
- VAL_SERIES(val) = Copy_Series(VAL_SERIES(val));
- }
- }
- //ENABLE_GC;
-
- return series;
-}
+//
+// Copy_Array_Core_Managed: C
+//
+// Copy a block, copy specified values, deeply if indicated.
+//
+// The resulting series will already be under GC management,
+// and hence cannot be freed with Free_Series().
+//
+REBARR *Copy_Array_Core_Managed(
+ REBARR *original,
+ REBCNT index,
+ REBSPC *specifier,
+ REBCNT tail,
+ REBCNT extra,
+ REBOOL deep,
+ REBU64 types
+) {
+ REBARR *copy;
+
+ if (index > tail) index = tail;
+
+ if (index > ARR_LEN(original)) {
+ copy = Make_Array_For_Copy(extra);
+ MANAGE_ARRAY(copy);
+ }
+ else {
+ copy = Copy_Values_Len_Extra_Shallow(
+ ARR_AT(original, index), specifier, tail - index, extra
+ );
+ MANAGE_ARRAY(copy);
+
+ if (types != 0) // the copy above should have specified top level
+ Clonify_Values_Len_Managed(
+ ARR_HEAD(copy), SPECIFIED, ARR_LEN(copy), deep, types
+ );
+ }
+
+#if !defined(NDEBUG)
+ //
+ // Propagate legacy flag, hence if a legacy array was loaded with
+ // `[switch 1 [2]]` in it (for instance) then when that code is used to
+ // make a function body, the `[switch 1 [2]]` in that body will also
+ // be marked legacy. Then if it runs, the SWITCH can dispatch to return
+ // blank instead of the Ren-C behavior of returning `2`.
+ //
+ if (GET_SER_INFO(original, SERIES_INFO_LEGACY_DEBUG))
+ SET_SER_INFO(copy, SERIES_INFO_LEGACY_DEBUG);
#endif
-
-/***********************************************************************
-**
-*/ REBSER *Copy_Expand_Block(REBSER *block, REBCNT extra)
-/*
-** Create an expanded copy of the block, but with same tail.
-**
-***********************************************************************/
-{
- REBCNT len = SERIES_TAIL(block);
- REBSER *series = Make_Series(len + extra + 1, sizeof(REBVAL), FALSE);
- COPY_BLK_PART(series, BLK_HEAD(block), len);
- PG_Reb_Stats->Blocks++;
- return series;
+ ASSERT_NO_RELATIVE(copy, deep);
+ return copy;
}
-/***********************************************************************
-**
-*/ void Copy_Stack_Values(REBINT start, REBVAL *into)
-/*
-** Copy computed values from the stack into the series
-** specified by "into", or if into is NULL then store it as a
-** block on top of the stack. (Also checks to see if into
-** is protected, and will trigger a trap if that is the case.)
-**
-***********************************************************************/
-{
- REBSER *series;
- REBVAL *blk = DS_Base + start;
- REBCNT len = DSP - start + 1;
- REBCNT type;
-
- if (into) {
- type = VAL_TYPE(into);
- series = VAL_SERIES(into);
- if (IS_PROTECT_SERIES(series)) Trap0(RE_PROTECTED);
- len = Insert_Series(series, VAL_INDEX(into), (REBYTE*)blk, len);
- } else {
- series = Make_Series(len + 1, sizeof(REBVAL), FALSE);
- COPY_BLK_PART(series, blk, len);
- len = 0;
- type = REB_BLOCK;
- PG_Reb_Stats->Blocks++;
- }
-
- DSP = start;
- blk = DS_TOP;
- VAL_SET(blk, type);
- VAL_SERIES(blk) = series;
- VAL_INDEX(blk) = len;
- VAL_SERIES_SIDE(blk) = 0;
+//
+// Copy_Array_At_Extra_Deep_Managed: C
+//
+// Deep copy an array, including all series (strings, blocks,
+// parens, objects...) excluding images, bitsets, maps, etc.
+// The set of exclusions is the typeset TS_NOT_COPIED.
+//
+// The resulting array will already be under GC management,
+// and hence cannot be freed with Free_Series().
+//
+// Note: If this were declared as a macro it would use the
+// `array` parameter more than once, and have to be in all-caps
+// to warn against usage with arguments that have side-effects.
+//
+REBARR *Copy_Array_At_Extra_Deep_Managed(
+ REBARR *original,
+ REBCNT index,
+ REBSPC *specifier,
+ REBCNT extra
+) {
+ REBARR *copy = Copy_Array_Core_Managed(
+ original,
+ index, // at
+ specifier,
+ ARR_LEN(original), // tail
+ extra, // extra
+ TRUE, // deep
+ TS_SERIES & ~TS_NOT_COPIED // types
+ );
+
+ return copy;
}
-/***********************************************************************
-**
-*/ REBVAL *Append_Value(REBSER *block)
-/*
-** Append a value to a block series at its tail.
-** Expand it if necessary. Update the termination and tail.
-** Returns the new value for you to initialize.
-**
-***********************************************************************/
-{
- REBVAL *value;
-
- EXPAND_SERIES_TAIL(block, 1);
- value = BLK_TAIL(block);
- SET_END(value);
- value--;
- SET_NONE(value); // Expand_Series leaves a hole here to be filled
- return value;
+//
+// Copy_Rerelativized_Array_Deep_Managed: C
+//
+// The invariant of copying in general is that when you are done with the
+// copy, there are no relative values in that copy. One exception to this
+// is the deep copy required to make a relative function body in the first
+// place (which it currently does in two passes--a normal deep copy followed
+// by a relative binding). The other exception is when a relativized
+// function body is copied to make another relativized function body.
+//
+// This is specialized logic for the latter case. It's constrained enough
+// to be simple (all relative values are known to be relative to the same
+// function), and the feature is questionable anyway. So it's best not to
+// further complicate ordinary copying with a parameterization to copy
+// and change all the relative binding information from one function's
+// paramlist to another.
+//
+REBARR *Copy_Rerelativized_Array_Deep_Managed(
+ REBARR *original,
+ REBFUN *before, // references to `before` will be changed to `after`
+ REBFUN *after
+) {
+ REBARR *copy = Make_Array_For_Copy(ARR_LEN(original));
+ RELVAL *src = ARR_HEAD(original);
+ RELVAL *dest = ARR_HEAD(copy);
+
+ for (; NOT_END(src); ++src, ++dest) {
+ if (!IS_RELATIVE(src)) {
+ *dest = *src;
+ continue;
+ }
+
+ assert(VAL_RELATIVE(src) == before);
+ if (ANY_ARRAY(src)) {
+ *dest = *src; // !!! could copy just fields not overwritten
+ dest->payload.any_series.series = SER(
+ Copy_Rerelativized_Array_Deep_Managed(
+ VAL_ARRAY(src), before, after
+ )
+ );
+ INIT_RELATIVE(dest, after);
+ }
+ else {
+ assert(ANY_WORD(src));
+ *dest = *src; // !!! could copy just fields not overwritten
+ INIT_WORD_FUNC(dest, after);
+ }
+ }
+
+ TERM_ARRAY_LEN(copy, ARR_LEN(original));
+ MANAGE_ARRAY(copy);
+
+ return copy;
}
-#ifdef ndef
-/***********************************************************************
-**
-*/ void Append_Block(REBSER *block, REBSER *added)
-/*
-** Append a block to the tail of a block.
-** Expand it if necessary. Update the termination and tail.
-**
-***********************************************************************/
-{
- Insert_Series(block, block->tail, (void*)BLK_HEAD(added), added->tail);
-}
-#endif
-/***********************************************************************
-**
-*/ void Append_Val(REBSER *block, REBVAL *val)
-/*
-** Append a value to a block series at its tail.
-** Expand it if necessary. Update the termination and tail.
-**
-***********************************************************************/
+//
+// Alloc_Tail_Array: C
+//
+// Append a REBVAL-size slot to Rebol Array series at its tail.
+// Will use existing memory capacity already in the series if it
+// is available, but will expand the series if necessary.
+// Returns the new value for you to initialize.
+//
+// Note: Updates the termination and tail.
+//
+REBVAL *Alloc_Tail_Array(REBARR *a)
{
- REBVAL *value;
-
- EXPAND_SERIES_TAIL(block, 1);
- value = BLK_TAIL(block);
- SET_END(value);
- value--;
- *value = *val;
+ EXPAND_SERIES_TAIL(SER(a), 1);
+ TERM_ARRAY_LEN(a, ARR_LEN(a));
+ return SINK(ARR_LAST(a));
}
-/***********************************************************************
-**
-*/ REBINT Find_Same_Block(REBSER *blk, REBVAL *val)
-/*
-** Scan a block for any values that reference blocks related
-** to the value provided.
-**
-** Defect: only checks certain kinds of values.
-**
-***********************************************************************/
+//
+// Find_Same_Array: C
+//
+// Scan a block for any values that reference blocks related
+// to the value provided.
+//
+// !!! This was used for detection of cycles during MOLD. The idea is that
+// while it is outputting a series, it doesn't want to see that series
+// again. For the moment the only places to worry about with that are
+// context varlists and block series or maps. (Though a function contains
+// series for the spec, body, and paramlist...the spec and body are blocks,
+// and so recursion would be found when the blocks were output.)
+//
+REBCNT Find_Same_Array(REBARR *search_values, const RELVAL *value)
{
- REBVAL *bp;
- REBINT index = 0;
-
- for (bp = BLK_HEAD(blk); NOT_END(bp); bp++, index++) {
-
- if (VAL_TYPE(bp) >= REB_BLOCK &&
- VAL_TYPE(bp) <= REB_MAP &&
- VAL_BLK(bp) == VAL_BLK(val)
- ) return index+1;
-
- if (
- VAL_TYPE(bp) >= REB_OBJECT &&
- VAL_TYPE(bp) <= REB_PORT &&
- VAL_OBJ_FRAME(bp) == VAL_OBJ_FRAME(val)
- ) return index+1;
- }
- return -1;
+ REBCNT index = 0;
+ REBARR *array;
+ RELVAL *other;
+
+ if (ANY_ARRAY(value))
+ array = VAL_ARRAY(value);
+ else if (IS_MAP(value))
+ array = MAP_PAIRLIST(VAL_MAP(value));
+ else if (ANY_CONTEXT(value))
+ array = CTX_VARLIST(VAL_CONTEXT(value));
+ else {
+ // Value being worked with is not a candidate for containing an
+ // array that could form a loop with one of the search_list values
+ //
+ return NOT_FOUND;
+ }
+
+ other = ARR_HEAD(search_values);
+ for (; NOT_END(other); other++, index++) {
+ if (ANY_ARRAY(other)) {
+ if (array == VAL_ARRAY(other))
+ return index;
+ }
+ else if (IS_MAP(other)) {
+ if (array == MAP_PAIRLIST(VAL_MAP(other)))
+ return index;
+ }
+ else if (ANY_CONTEXT(other)) {
+ if (array == CTX_VARLIST(VAL_CONTEXT(other)))
+ return index;
+ }
+ }
+
+ return NOT_FOUND;
}
-#ifdef ndef
-/***********************************************************************
-**
-*/ REBSER *Copy_Side_Series(REBSER *ser)
-/*
-** Copy a hash or list side series
-**
-***********************************************************************/
-{
- REBSER *ret;
-
- ret = Make_Series(ser->tail, SERIES_WIDE(ser), FALSE);
- ret->tail = ser->tail;
- memcpy(ret->data, ser->data, ret->tail * SERIES_WIDE(ret));
- return ret;
-}
-#endif
-/***********************************************************************
-**
-*/ void Clear_Value_Opts(REBSER *ser)
-/*
-** Clear all options for values of a block series.
-**
-***********************************************************************/
+//
+// Uncolor_Array: C
+//
+void Uncolor_Array(REBARR *a)
{
- REBVAL *val = BLK_HEAD(ser);
+ if (Is_Series_White(SER(a)))
+ return; // avoid loop
+
+ Flip_Series_To_White(SER(a));
- for (; NOT_END(val); val++) {
- VAL_OPTS(val) = 0;
- }
+ RELVAL *val;
+ for (val = ARR_HEAD(a); NOT_END(val); ++val)
+ if (ANY_ARRAY(val) || ANY_CONTEXT(val))
+ Uncolor(val);
}
-/***********************************************************************
-**
-*/ void Unmark(REBVAL *val)
-/*
-** Clear the recusion markers for series and object trees.
-**
-** Note: these markers are also used for GC. Functions that
-** call this must not be able to trigger GC!
-**
-***********************************************************************/
+//
+// Uncolor: C
+//
+// Clear the recusion markers for series and object trees.
+//
+void Uncolor(RELVAL *val)
{
- // The next line works because VAL_OBJ_FRAME(val) == VAL_SERIES(val)
- REBSER *series = VAL_SERIES(val);
-
- if (!IS_MARK_SERIES(series)) return; // avoid loop
-
- UNMARK_SERIES(series);
-
- for (val = VAL_BLK(val); NOT_END(val); val++) {
- if (ANY_SERIES(val) || IS_OBJECT(val) || IS_MODULE(val)
- || IS_ERROR(val) || IS_PORT(val))
- Unmark(val);
- }
+ REBARR *array;
+
+ if (ANY_ARRAY(val))
+ array = VAL_ARRAY(val);
+ else if (ANY_CONTEXT(val))
+ array = CTX_VARLIST(VAL_CONTEXT(val));
+ else {
+ // Shouldn't have marked recursively any non-array series (no need)
+ //
+ assert(
+ !ANY_SERIES(val)
+ || Is_Series_White(VAL_SERIES(val))
+ );
+ return;
+ }
+
+ Uncolor_Array(array);
}
diff --git a/src/core/f-deci.c b/src/core/f-deci.c
index f2fb6e974c..9ca430207a 100644
--- a/src/core/f-deci.c
+++ b/src/core/f-deci.c
@@ -1,51 +1,54 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: f-deci.c
-** Summary: extended precision arithmetic functions
-** Section: functional
-** Author: Ladislav Mecir for REBOL Technologies
-** Notes:
-** Deci significands are 87-bit long, unsigned, unnormalized, stored in
-** little endian order. (Maximal deci significand is 1e26 - 1, i.e. 26
-** nines)
-**
-** Sign is one-bit, 1 means nonpositive, 0 means nonnegative.
-**
-** Exponent is 8-bit, unbiased.
-**
-** Functions may be inlined (especially the ones marked by INLINE).
-** 64-bit and/or double arithmetic used where they bring advantage.
-**
-***********************************************************************/
+//
+// File: %f-deci.c
+// Summary: "extended precision arithmetic functions"
+// Section: functional
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Deci significands are 87-bit long, unsigned, unnormalized, stored in
+// little endian order. (Maximal deci significand is 1e26 - 1, i.e. 26
+// nines)
+//
+// Sign is one-bit, 1 means nonpositive, 0 means nonnegative.
+//
+// Exponent is 8-bit, unbiased.
+//
+// 64-bit and/or double arithmetic used where they bring advantage.
+//
+// !!! Inlining was once hinted here, and it may be possible to use
+// the hint to speed up this code. But for the moment, inlining
+// decisions are being left up to the compiler due to it not being
+// a standard feature in C89 and numerous quirks in both C and C++
+// regarding how inline works. A broader review of inline for
+// the whole codebase is required at some later date. --@HF
+//
#include "sys-core.h"
#include "sys-deci-funcs.h"
#include "sys-dec-to-char.h"
-#ifndef TEST_MODE
-#define OVERFLOW_ERROR Trap0(RE_OVERFLOW)
-#define DIVIDE_BY_ZERO_ERROR Trap0(RE_ZERO_DIVIDE)
-#endif
-
#define IS_DIGIT(c) ((c) >= '0' && (c) <= '9')
#define MASK32(i) (REBCNT)(i)
@@ -62,53 +65,53 @@ static const deci deci_minus_one = {1u, 0u, 0u, 1u, 0};
static const REBCNT min_int64_t_as_deci[] = {0u, 0x80000000u, 0u};
/*
- Compare significand a and significand b;
- -1 means a < b;
- 0 means a = b;
- 1 means a > b;
+ Compare significand a and significand b;
+ -1 means a < b;
+ 0 means a = b;
+ 1 means a > b;
*/
-INLINE REBINT m_cmp (REBINT n, const REBCNT a[], const REBCNT b[]) {
- REBINT i;
- for (i = n - 1; i >= 0; i--)
- if (a[i] != b[i]) return a[i] < b[i] ? -1 : 1;
- return 0;
+REBINT m_cmp (REBINT n, const REBCNT a[], const REBCNT b[]) {
+ REBINT i;
+ for (i = n - 1; i >= 0; i--)
+ if (a[i] != b[i]) return a[i] < b[i] ? -1 : 1;
+ return 0;
}
-INLINE REBFLG m_is_zero (REBINT n, const REBCNT a[]) {
- REBINT i;
- for (i = 0; (i < n) && (a[i] == 0); i++);
- return i == n;
+REBOOL m_is_zero (REBINT n, const REBCNT a[]) {
+ REBINT i;
+ for (i = 0; (i < n) && (a[i] == 0); i++);
+ return LOGICAL(i == n);
}
/* unnormalized powers of ten */
static const REBCNT P[][3] = {
- {1u, 0u, 0u}, /* 1e0 */
- {10u, 0u, 0u}, /* 1e1 */
- {100u, 0u, 0u}, /* 1e2 */
- {1000u, 0u, 0u}, /* 1e3 */
- {10000u, 0u, 0u}, /* 1e4 */
- {100000u, 0u, 0u}, /* 1e5 */
- {1000000u, 0u, 0u}, /* 1e6 */
- {10000000u, 0u, 0u}, /* 1e7 */
- {100000000u, 0u, 0u}, /* 1e8 */
- {1000000000u, 0u, 0u}, /* 1e9 */
- {1410065408u, 2u, 0u}, /* 1e10 */
- {1215752192u, 23u, 0u}, /* 1e11 */
- {3567587328u, 232u, 0u}, /* 1e12 */
- {1316134912u, 2328u, 0u}, /* 1e13 */
- {276447232u, 23283u, 0u}, /* 1e14 */
- {2764472320u, 232830u, 0u}, /* 1e15 */
- {1874919424u, 2328306u, 0u}, /* 1e16 */
- {1569325056u, 23283064u, 0u}, /* 1e17 */
- {2808348672u, 232830643u, 0u}, /* 1e18 */
- {2313682944u, 2328306436u, 0u}, /* 1e19 */
- {1661992960u, 1808227885u, 5u}, /* 1e20 */
- {3735027712u, 902409669u, 54u}, /* 1e21 */
- {2990538752u, 434162106u, 542u}, /* 1e22 */
- {4135583744u, 46653770u, 5421u}, /* 1e23 */
- {2701131776u, 466537709u, 54210u}, /* 1e24 */
- {1241513984u, 370409800u, 542101u}, /* 1e25 */
- {3825205248u, 3704098002u, 5421010u} /* 1e26 */
+ {1u, 0u, 0u}, /* 1e0 */
+ {10u, 0u, 0u}, /* 1e1 */
+ {100u, 0u, 0u}, /* 1e2 */
+ {1000u, 0u, 0u}, /* 1e3 */
+ {10000u, 0u, 0u}, /* 1e4 */
+ {100000u, 0u, 0u}, /* 1e5 */
+ {1000000u, 0u, 0u}, /* 1e6 */
+ {10000000u, 0u, 0u}, /* 1e7 */
+ {100000000u, 0u, 0u}, /* 1e8 */
+ {1000000000u, 0u, 0u}, /* 1e9 */
+ {1410065408u, 2u, 0u}, /* 1e10 */
+ {1215752192u, 23u, 0u}, /* 1e11 */
+ {3567587328u, 232u, 0u}, /* 1e12 */
+ {1316134912u, 2328u, 0u}, /* 1e13 */
+ {276447232u, 23283u, 0u}, /* 1e14 */
+ {2764472320u, 232830u, 0u}, /* 1e15 */
+ {1874919424u, 2328306u, 0u}, /* 1e16 */
+ {1569325056u, 23283064u, 0u}, /* 1e17 */
+ {2808348672u, 232830643u, 0u}, /* 1e18 */
+ {2313682944u, 2328306436u, 0u}, /* 1e19 */
+ {1661992960u, 1808227885u, 5u}, /* 1e20 */
+ {3735027712u, 902409669u, 54u}, /* 1e21 */
+ {2990538752u, 434162106u, 542u}, /* 1e22 */
+ {4135583744u, 46653770u, 5421u}, /* 1e23 */
+ {2701131776u, 466537709u, 54210u}, /* 1e24 */
+ {1241513984u, 370409800u, 542101u}, /* 1e25 */
+ {3825205248u, 3704098002u, 5421010u} /* 1e26 */
};
/* 1e26 as double significand */
@@ -117,863 +120,947 @@ static const REBCNT P26[] = {3825205248u, 3704098002u, 5421010u, 0u, 0u, 0u};
static const REBCNT P26_1[] = {3825205247u, 3704098002u, 5421010u};
/*
- Computes max decimal shift left for nonzero significand a with length 3;
- using double arithmetic;
+ Computes max decimal shift left for nonzero significand a with length 3;
+ using double arithmetic;
*/
-INLINE REBINT max_shift_left (const REBCNT a[]) {
+REBINT max_shift_left (const REBCNT a[]) {
REBINT i;
- i = (REBINT)(log10((a[2] * two_to_32 + a[1]) * two_to_32 + a[0]) + 0.5);
+ i = (REBINT)(log10((a[2] * two_to_32 + a[1]) * two_to_32 + a[0]) + 0.5);
return m_cmp (3, P[i], a) <= 0 ? 25 - i : 26 - i;
}
/* limits for "double significand" right shift */
static const REBCNT Q[][6] = {
- {3892314107u, 2681241660u, 54210108u, 0u, 0u, 0u}, /* 1e27-5e0 */
- {268435406u, 1042612833u, 542101086u, 0u, 0u, 0u}, /* 1e28-5e1 */
- {2684354060u, 1836193738u, 1126043566u, 1u, 0u, 0u}, /* 1e29-5e2 */
- {1073736824u, 1182068202u, 2670501072u, 12u, 0u, 0u}, /* 1e30-5e3 */
- {2147433648u, 3230747430u, 935206946u, 126u, 0u, 0u}, /* 1e31-5e4 */
- {4294467296u, 2242703232u, 762134875u, 1262u, 0u, 0u}, /* 1e32-5e5 */
- {4289967296u, 952195849u, 3326381459u, 12621u, 0u, 0u}, /* 1e33-5e6 */
- {4244967296u, 932023907u, 3199043520u, 126217u, 0u, 0u}, /* 1e34-5e7 */
- {3794967296u, 730304487u, 1925664130u, 1262177u, 0u, 0u}, /* 1e35-5e8 */
- {3589934592u, 3008077582u, 2076772117u, 12621774u, 0u, 0u}, /* 1e36-5e9 */
- {1539607552u, 16004756u, 3587851993u, 126217744u, 0u, 0u}, /* 1e37-5e10 */
- {2511173632u, 160047563u, 1518781562u, 1262177448u, 0u, 0u}, /* 1e38-5e11 */
- {3636899840u, 1600475635u, 2302913732u, 4031839891u, 2u, 0u}, /* 1e39-5e12 */
- {2009260032u, 3119854470u, 1554300843u, 1663693251u, 29u, 0u}, /* 1e40-5e13*/
- {2912731136u, 1133773632u, 2658106549u, 3752030625u, 293u, 0u}, /* 1e41-5e14 */
- {3357507584u, 2747801734u, 811261716u, 3160567888u, 2938u, 0u}, /* 1e42-5e15 */
- {3510304768u, 1708213571u, 3817649870u, 1540907809u, 29387u, 0u}, /* 1e43-5e16 */
- {743309312u, 4197233830u, 3816760335u, 2524176210u, 293873u, 0u}, /* 1e44-5e17 */
- {3138125824u, 3317632637u, 3807864991u, 3766925628u, 2938735u, 0u}, /* 1e45-5e18 */
- {1316487168u, 3111555305u, 3718911549u, 3309517920u, 29387358u, 0u}, /* 1e46-5e19 */
- {279969792u, 1050781981u, 2829377129u, 3030408136u, 293873587u, 0u}, /* 1e47-5e20 */
- {2799697920u, 1917885218u, 2523967516u, 239310294u, 2938735877u, 0u}, /* 1e48-5e21 */
- {2227175424u, 1998983002u, 3764838684u, 2393102945u, 3617554994u, 6u}, /* 1e49-5e22 */
- {796917760u, 2809960841u, 3288648476u, 2456192978u, 1815811577u, 68u}, /* 1e50-5e23 */
- {3674210304u, 2329804635u, 2821713694u, 3087093307u, 978246591u, 684u}, /* 1e51-5e24 */
- {2382364672u, 1823209878u, 2447333169u, 806162004u, 1192531325u, 6842u} /* 1e52-5e25 */
+ {3892314107u, 2681241660u, 54210108u, 0u, 0u, 0u}, /* 1e27-5e0 */
+ {268435406u, 1042612833u, 542101086u, 0u, 0u, 0u}, /* 1e28-5e1 */
+ {2684354060u, 1836193738u, 1126043566u, 1u, 0u, 0u}, /* 1e29-5e2 */
+ {1073736824u, 1182068202u, 2670501072u, 12u, 0u, 0u}, /* 1e30-5e3 */
+ {2147433648u, 3230747430u, 935206946u, 126u, 0u, 0u}, /* 1e31-5e4 */
+ {4294467296u, 2242703232u, 762134875u, 1262u, 0u, 0u}, /* 1e32-5e5 */
+ {4289967296u, 952195849u, 3326381459u, 12621u, 0u, 0u}, /* 1e33-5e6 */
+ {4244967296u, 932023907u, 3199043520u, 126217u, 0u, 0u}, /* 1e34-5e7 */
+ {3794967296u, 730304487u, 1925664130u, 1262177u, 0u, 0u}, /* 1e35-5e8 */
+ {3589934592u, 3008077582u, 2076772117u, 12621774u, 0u, 0u}, /* 1e36-5e9 */
+ {1539607552u, 16004756u, 3587851993u, 126217744u, 0u, 0u}, /* 1e37-5e10 */
+ {2511173632u, 160047563u, 1518781562u, 1262177448u, 0u, 0u}, /* 1e38-5e11 */
+ {3636899840u, 1600475635u, 2302913732u, 4031839891u, 2u, 0u}, /* 1e39-5e12 */
+ {2009260032u, 3119854470u, 1554300843u, 1663693251u, 29u, 0u}, /* 1e40-5e13*/
+ {2912731136u, 1133773632u, 2658106549u, 3752030625u, 293u, 0u}, /* 1e41-5e14 */
+ {3357507584u, 2747801734u, 811261716u, 3160567888u, 2938u, 0u}, /* 1e42-5e15 */
+ {3510304768u, 1708213571u, 3817649870u, 1540907809u, 29387u, 0u}, /* 1e43-5e16 */
+ {743309312u, 4197233830u, 3816760335u, 2524176210u, 293873u, 0u}, /* 1e44-5e17 */
+ {3138125824u, 3317632637u, 3807864991u, 3766925628u, 2938735u, 0u}, /* 1e45-5e18 */
+ {1316487168u, 3111555305u, 3718911549u, 3309517920u, 29387358u, 0u}, /* 1e46-5e19 */
+ {279969792u, 1050781981u, 2829377129u, 3030408136u, 293873587u, 0u}, /* 1e47-5e20 */
+ {2799697920u, 1917885218u, 2523967516u, 239310294u, 2938735877u, 0u}, /* 1e48-5e21 */
+ {2227175424u, 1998983002u, 3764838684u, 2393102945u, 3617554994u, 6u}, /* 1e49-5e22 */
+ {796917760u, 2809960841u, 3288648476u, 2456192978u, 1815811577u, 68u}, /* 1e50-5e23 */
+ {3674210304u, 2329804635u, 2821713694u, 3087093307u, 978246591u, 684u}, /* 1e51-5e24 */
+ {2382364672u, 1823209878u, 2447333169u, 806162004u, 1192531325u, 6842u} /* 1e52-5e25 */
};
/*
Computes minimal decimal shift right for "double significand" a with length 6
to fit length 3;
- using double arithmetic;
+ using double arithmetic;
*/
-INLINE REBINT min_shift_right (const REBCNT a[6]) {
+REBINT min_shift_right (const REBCNT a[6]) {
REBINT i;
if (m_cmp (6, a, P26) < 0) return 0;
i = (REBINT) (log10 (
- ((((a[5] * two_to_32 + a[4]) * two_to_32 + a[3]) * two_to_32 + a[2]) * two_to_32 + a[1]) * two_to_32 + a[0]
- ) + 0.5);
- if (i == 26) return 1;
+ ((((a[5] * two_to_32 + a[4]) * two_to_32 + a[3]) * two_to_32 + a[2]) * two_to_32 + a[1]) * two_to_32 + a[0]
+ ) + 0.5);
+ if (i == 26) return 1;
return (m_cmp (6, Q[i - 27], a) <= 0) ? i - 25 : i - 26;
}
/* Finds out if deci a is zero */
-REBFLG deci_is_zero (const deci a) {
- return (a.m0 == 0) && (a.m1 == 0) && (a.m2 == 0);
+REBOOL deci_is_zero (const deci a) {
+ return LOGICAL((a.m0 == 0) && (a.m1 == 0) && (a.m2 == 0));
}
/* Changes the sign of a deci value */
deci deci_negate (deci a) {
- a.s = !a.s;
- return a;
+ a.s = !a.s;
+ return a;
}
/* Returns the absolute value of deci a */
deci deci_abs (deci a) {
- a.s = 0;
- return a;
+ a.s = 0;
+ return a;
}
/*
- Adds unsigned 32-bit value b to significand a;
- a must be "large enough" to contain the sum;
- using 64-bit arithmetic;
+ Adds unsigned 32-bit value b to significand a;
+ a must be "large enough" to contain the sum;
+ using 64-bit arithmetic;
*/
-INLINE void m_add_1 (REBCNT *a, const REBCNT b) {
- REBU64 c = (REBU64) b;
- while (c) {
- c += (REBU64) *a;
- *(a++) = (REBCNT)c;
- c >>= 32;
- }
+void m_add_1 (REBCNT *a, const REBCNT b) {
+ REBU64 c = (REBU64) b;
+ while (c) {
+ c += (REBU64) *a;
+ *(a++) = (REBCNT)c;
+ c >>= 32;
+ }
}
/*
- Subtracts unsigned 32-bit value b from significand a;
- using 64-bit arithmetic;
+ Subtracts unsigned 32-bit value b from significand a;
+ using 64-bit arithmetic;
*/
-INLINE void m_subtract_1 (REBCNT *a, const REBCNT b) {
- REBI64 c = - (REBI64) b;
- while (c) {
- c += 0xffffffffu + (REBI64)*a + 1;
- *(a++) = MASK32(c);
- c = (c >> 32) - 1;
- }
+void m_subtract_1 (REBCNT *a, const REBCNT b) {
+ REBI64 c = - (REBI64) b;
+ while (c) {
+ c += 0xffffffffu + (REBI64)*a + 1;
+ *(a++) = MASK32(c);
+ c = (c >> 32) - 1;
+ }
}
/*
- Adds significand b to significand a yielding sum s;
- using 64-bit arithmetic;
+ Adds significand b to significand a yielding sum s;
+ using 64-bit arithmetic;
*/
-INLINE void m_add (REBINT n, REBCNT s[], const REBCNT a[], const REBCNT b[]) {
- REBU64 c = (REBU64) 0;
- REBINT i;
- for (i = 0; i < n; i++) {
- c += (REBU64) a[i] + (REBU64) b[i];
- s[i] = MASK32(c);
- c >>= 32;
- }
- s[n] = (REBCNT)c;
+void m_add (REBINT n, REBCNT s[], const REBCNT a[], const REBCNT b[]) {
+ REBU64 c = (REBU64) 0;
+ REBINT i;
+ for (i = 0; i < n; i++) {
+ c += (REBU64) a[i] + (REBU64) b[i];
+ s[i] = MASK32(c);
+ c >>= 32;
+ }
+ s[n] = (REBCNT)c;
}
/*
- Subtracts significand b from significand a yielding difference d;
- returns carry flag to signal whether the result is negative;
- using 64-bit arithmetic;
+ Subtracts significand b from significand a yielding difference d;
+ returns carry flag to signal whether the result is negative;
+ using 64-bit arithmetic;
*/
-INLINE REBINT m_subtract (REBINT n, REBCNT d[], const REBCNT a[], const REBCNT b[]) {
- REBU64 c = (REBU64) 1;
- REBINT i;
- for (i = 0; i < n; i++) {
- c += (REBU64) 0xffffffffu + (REBU64) a[i] - (REBU64) b[i];
- d[i] = MASK32(c);
- c >>= 32;
- }
- return (REBINT) c - 1;
+REBINT m_subtract (REBINT n, REBCNT d[], const REBCNT a[], const REBCNT b[]) {
+ REBU64 c = (REBU64) 1;
+ REBINT i;
+ for (i = 0; i < n; i++) {
+ c += (REBU64) 0xffffffffu + (REBU64) a[i] - (REBU64) b[i];
+ d[i] = MASK32(c);
+ c >>= 32;
+ }
+ return (REBINT) c - 1;
}
/*
- Negates significand a;
- using 64-bit arithmetic;
+ Negates significand a;
+ using 64-bit arithmetic;
*/
-INLINE void m_negate (REBINT n, REBCNT a[]) {
- REBU64 c = (REBU64) 1;
- REBINT i;
- for (i = 0; i < n; i++) {
- c += (REBU64) 0xffffffffu - (REBU64) a[i];
- a[i] = MASK32(c);
- c >>= 32;
- }
+void m_negate (REBINT n, REBCNT a[]) {
+ REBU64 c = (REBU64) 1;
+ REBINT i;
+ for (i = 0; i < n; i++) {
+ c += (REBU64) 0xffffffffu - (REBU64) a[i];
+ a[i] = MASK32(c);
+ c >>= 32;
+ }
}
-/*
- Multiplies significand a by b storing the product to p;
- p and a may be the same;
- using 64-bit arithmetic;
+/*
+ Multiplies significand a by b storing the product to p;
+ p and a may be the same;
+ using 64-bit arithmetic;
*/
-INLINE void m_multiply_1 (REBINT n, REBCNT p[], const REBCNT a[], REBCNT b) {
- REBINT j;
- REBU64 f = b, g = (REBU64) 0;
- for (j = 0; j < n; j++) {
- g += f * (REBU64) a[j];
- p[j] = MASK32(g);
- g >>= 32;
- }
- p[n] = (REBCNT) g;
+void m_multiply_1 (REBINT n, REBCNT p[], const REBCNT a[], REBCNT b) {
+ REBINT j;
+ REBU64 f = b, g = (REBU64) 0;
+ for (j = 0; j < n; j++) {
+ g += f * (REBU64) a[j];
+ p[j] = MASK32(g);
+ g >>= 32;
+ }
+ p[n] = (REBCNT) g;
}
/*
- Decimally shifts significand a to the "left";
- a must be longer than the complete result;
- n is the initial length of a;
+ Decimally shifts significand a to the "left";
+ a must be longer than the complete result;
+ n is the initial length of a;
*/
-INLINE void dsl (REBINT n, REBCNT a[], REBINT shift) {
- REBINT shift1;
- for (; shift > 0; shift -= shift1) {
- shift1 = 9 <= shift ? 9 : shift;
- m_multiply_1 (n, a, a, P[shift1][0]);
- if (a[n] != 0) n++;
- }
+void dsl (REBINT n, REBCNT a[], REBINT shift) {
+ REBINT shift1;
+ for (; shift > 0; shift -= shift1) {
+ shift1 = 9 <= shift ? 9 : shift;
+ m_multiply_1 (n, a, a, P[shift1][0]);
+ if (a[n] != 0) n++;
+ }
}
/*
- Multiplies significand a by significand b yielding the product p;
- using 64-bit arithmetic;
+ Multiplies significand a by significand b yielding the product p;
+ using 64-bit arithmetic;
*/
-INLINE void m_multiply (REBCNT p[/* n + m */], REBINT n, const REBCNT a[], REBINT m, const REBCNT b[]) {
- REBINT i, j;
- REBU64 f, g;
- memset (p, 0, (n + m) * sizeof (REBCNT));
- for (i = 0; i < m; i++) {
- f = (REBU64) b[i];
- g = (REBU64) 0;
- for (j = 0; j < n; j++) {
- g += f * (REBU64) a[j] + p[i + j];
- p[i + j] = MASK32(g);
- g >>= 32;
- }
- m_add_1 (p + i + j, (REBCNT) g);
- }
+void m_multiply (REBCNT p[/* n + m */], REBINT n, const REBCNT a[], REBINT m, const REBCNT b[]) {
+ REBINT i, j;
+ REBU64 f, g;
+ memset (p, 0, (n + m) * sizeof (REBCNT));
+ for (i = 0; i < m; i++) {
+ f = (REBU64) b[i];
+ g = (REBU64) 0;
+ for (j = 0; j < n; j++) {
+ g += f * (REBU64) a[j] + p[i + j];
+ p[i + j] = MASK32(g);
+ g >>= 32;
+ }
+ m_add_1 (p + i + j, (REBCNT) g);
+ }
}
-/*
- Divides significand a by b yielding quotient q;
- returns the remainder;
- b must be nonzero!
- using 64-bit arithmetic;
+/*
+ Divides significand a by b yielding quotient q;
+ returns the remainder;
+ b must be nonzero!
+ using 64-bit arithmetic;
*/
-INLINE REBCNT m_divide_1 (REBINT n, REBCNT q[], const REBCNT a[], REBCNT b) {
- REBINT i;
- REBU64 f = 0, g = b;
- for (i = n - 1; i >= 0; i--) {
- f = (f << 32) + (REBU64) a[i];
- q[i] = (REBCNT)(f / g);
- f %= g;
- }
- return (REBCNT) f;
+REBCNT m_divide_1 (REBINT n, REBCNT q[], const REBCNT a[], REBCNT b) {
+ REBINT i;
+ REBU64 f = 0, g = b;
+ for (i = n - 1; i >= 0; i--) {
+ f = (f << 32) + (REBU64) a[i];
+ q[i] = (REBCNT)(f / g);
+ f %= g;
+ }
+ return (REBCNT) f;
}
/*
- Decimally shifts significand a to the "right";
- truncate flag t_flag is an I/O value with the following meaning:
- 0 - result is exact
- 1 - less than half of the least significant unit truncated
- 2 - exactly half of the least significant unit truncated
- 3 - more than half of the least significant unit truncated
+ Decimally shifts significand a to the "right";
+ truncate flag t_flag is an I/O value with the following meaning:
+ 0 - result is exact
+ 1 - less than half of the least significant unit truncated
+ 2 - exactly half of the least significant unit truncated
+ 3 - more than half of the least significant unit truncated
*/
-INLINE void dsr (REBINT n, REBCNT a[], REBINT shift, REBINT *t_flag) {
- REBCNT remainder, divisor;
- REBINT shift1;
- for (; shift > 0; shift -= shift1) {
- shift1 = 9 <= shift ? 9 : shift;
- remainder = m_divide_1 (n, a, a, divisor = P[shift1][0]);
- if (remainder < divisor / 2) {
- if (remainder || *t_flag) *t_flag = 1;
- } else if ((remainder > divisor / 2) || *t_flag) *t_flag = 3;
- else *t_flag = 2;
- }
-}
+void dsr (REBINT n, REBCNT a[], REBINT shift, REBINT *t_flag) {
+ REBCNT remainder, divisor;
+ REBINT shift1;
+ for (; shift > 0; shift -= shift1) {
+ shift1 = 9 <= shift ? 9 : shift;
+ remainder = m_divide_1 (n, a, a, divisor = P[shift1][0]);
+ if (remainder < divisor / 2) {
+ if (remainder || *t_flag) *t_flag = 1;
+ } else if ((remainder > divisor / 2) || *t_flag) *t_flag = 3;
+ else *t_flag = 2;
+ }
+}
/*
- Decimally shifts significands a and b to make them comparable;
- ea and eb are exponents;
- ta and tb are truncate flags like above;
+ Decimally shifts significands a and b to make them comparable;
+ ea and eb are exponents;
+ ta and tb are truncate flags like above;
*/
-INLINE void make_comparable (REBCNT a[4], REBINT *ea, REBINT *ta, REBCNT b[4], REBINT *eb, REBINT *tb) {
- REBCNT *c;
- REBINT *p;
- REBINT shift, shift1;
-
- /* set truncate flags to zero */
- *ta = 0;
- *tb = 0;
-
- if (*ea == *eb) return; /* no work needed */
-
- if (*ea < *eb) {
- /* swap a and b to fulfill the condition below */
- c = a;
- a = b;
- b = c;
-
- p = ea;
- ea = eb;
- eb = p;
-
- p = ta;
- ta = tb;
- tb = p;
- }
- /* (*ea > *eb) */
-
- /* decimally shift a to the left */
- if (m_is_zero (3, a)) {
- *ea = *eb;
- return;
- }
- shift1 = max_shift_left (a) + 1;
- shift = *ea - *eb;
+void make_comparable (REBCNT a[4], REBINT *ea, REBINT *ta, REBCNT b[4], REBINT *eb, REBINT *tb) {
+ REBCNT *c;
+ REBINT *p;
+ REBINT shift, shift1;
+
+ /* set truncate flags to zero */
+ *ta = 0;
+ *tb = 0;
+
+ if (*ea == *eb) return; /* no work needed */
+
+ if (*ea < *eb) {
+ /* swap a and b to fulfill the condition below */
+ c = a;
+ a = b;
+ b = c;
+
+ p = ea;
+ ea = eb;
+ eb = p;
+
+ p = ta;
+ ta = tb;
+ tb = p;
+ }
+ /* (*ea > *eb) */
+
+ /* decimally shift a to the left */
+ if (m_is_zero (3, a)) {
+ *ea = *eb;
+ return;
+ }
+ shift1 = max_shift_left (a) + 1;
+ shift = *ea - *eb;
dsl (3, a, shift1 = shift1 < shift ? shift1 : shift);
*ea -= shift1;
-
- /* decimally shift b to the right if necessary */
- shift = *ea - *eb;
- if (!shift) return;
- if (shift > 26) {
- /* significand underflow */
- if (!m_is_zero (3, b)) *tb = 1;
- memset (b, 0, 3 * sizeof (REBCNT));
- *eb = *ea;
- return;
- }
- dsr (3, b, shift, tb);
- *eb = *ea;
+
+ /* decimally shift b to the right if necessary */
+ shift = *ea - *eb;
+ if (!shift) return;
+ if (shift > 26) {
+ /* significand underflow */
+ if (!m_is_zero (3, b)) *tb = 1;
+ memset (b, 0, 3 * sizeof (REBCNT));
+ *eb = *ea;
+ return;
+ }
+ dsr (3, b, shift, tb);
+ *eb = *ea;
}
-REBFLG deci_is_equal (deci a, deci b) {
- REBINT ea = a.e, eb = b.e, ta, tb;
- REBCNT sa[] = {a.m0, a.m1, a.m2, 0}, sb[] = {b.m0, b.m1, b.m2, 0};
-
- make_comparable (sa, &ea, &ta, sb, &eb, &tb);
-
- /* round */
- if ((ta == 3) || ((ta == 2) && (sa[0] % 2 == 1))) m_add_1 (sa, 1);
- else if ((tb == 3) || ((tb == 2) && (sb[0] % 2 == 1))) m_add_1 (sb, 1);
-
- return (m_cmp (3, sa, sb) == 0) && ((a.s == b.s) || m_is_zero (3, sa));
+REBOOL deci_is_equal (deci a, deci b) {
+ REBINT ea = a.e, eb = b.e, ta, tb;
+
+ // Must be compile-time const for '= {...}' style init (-Wc99-extensions)
+ REBCNT sa[4];
+ REBCNT sb[4];
+
+ sa[0] = a.m0;
+ sa[1] = a.m1;
+ sa[2] = a.m2;
+ sa[3] = 0;
+
+ sb[0] = b.m0;
+ sb[1] = b.m1;
+ sb[2] = b.m2;
+ sb[3] = 0;
+
+ make_comparable (sa, &ea, &ta, sb, &eb, &tb);
+
+ /* round */
+ if ((ta == 3) || ((ta == 2) && (sa[0] % 2 == 1))) m_add_1 (sa, 1);
+ else if ((tb == 3) || ((tb == 2) && (sb[0] % 2 == 1))) m_add_1 (sb, 1);
+
+ return LOGICAL(
+ (m_cmp (3, sa, sb) == 0) && ((a.s == b.s) || m_is_zero (3, sa))
+ );
}
-REBFLG deci_is_lesser_or_equal (deci a, deci b) {
- REBINT ea = a.e, eb = b.e, ta, tb;
- REBCNT sa[] = {a.m0, a.m1, a.m2, 0}, sb[] = {b.m0, b.m1, b.m2, 0};
+REBOOL deci_is_lesser_or_equal (deci a, deci b) {
+ REBINT ea = a.e, eb = b.e, ta, tb;
+
+ // Must be compile-time const for '= {...}' style init (-Wc99-extensions)
+ REBCNT sa[4];
+ REBCNT sb[4];
+
+ sa[0] = a.m0;
+ sa[1] = a.m1;
+ sa[2] = a.m2;
+ sa[3] = 0;
- if (a.s && !b.s) return 1;
- if (!a.s && b.s) return m_is_zero (3, sa) && m_is_zero (3, sb);
- make_comparable (sa, &ea, &ta, sb, &eb, &tb);
+ sb[0] = b.m0;
+ sb[1] = b.m1;
+ sb[2] = b.m2;
+ sb[3] = 0;
- /* round */
- if ((ta == 3) || ((ta == 2) && (sa[0] % 2 == 1))) m_add_1 (sa, 1);
- else if ((tb == 3) || ((tb == 2) && (sb[0] % 2 == 1))) m_add_1 (sb, 1);
+ if (a.s && !b.s) return TRUE;
+ if (!a.s && b.s) return LOGICAL(m_is_zero (3, sa) && m_is_zero (3, sb));
+ make_comparable (sa, &ea, &ta, sb, &eb, &tb);
- return a.s ? (m_cmp (3, sa, sb) >= 0) : (m_cmp (3, sa, sb) <= 0);
+ /* round */
+ if ((ta == 3) || ((ta == 2) && (sa[0] % 2 == 1))) m_add_1 (sa, 1);
+ else if ((tb == 3) || ((tb == 2) && (sb[0] % 2 == 1))) m_add_1 (sb, 1);
+
+ return LOGICAL(
+ a.s ? (m_cmp (3, sa, sb) >= 0) : (m_cmp (3, sa, sb) <= 0)
+ );
}
deci deci_add (deci a, deci b) {
- deci c;
- REBCNT sc[4];
- REBINT ea = a.e, eb = b.e, ta, tb, tc, test;
- REBCNT sa[] = {a.m0, a.m1, a.m2, 0}, sb[] = {b.m0, b.m1, b.m2, 0};
-
- make_comparable (sa, &ea, &ta, sb, &eb, &tb);
-
- c.s = a.s;
- if (a.s == b.s) {
- /* addition */
- m_add (3, sc, sa, sb);
- tc = ta + tb;
-
- /* significand normalization */
- test = m_cmp (3, sc, P26_1);
- if ((test > 0) || ((test == 0) && ((tc == 3) || ((tc == 2) && (sc[0] % 2 == 1))))) {
- if (ea == 127) OVERFLOW_ERROR;
- ea++;
- dsr (3, sc, 1, &tc);
- /* the shift may be needed once again */
- test = m_cmp (3, sc, P26_1);
- if ((test > 0) || ((test == 0) && ((tc == 3) || ((tc == 2) && (sc[0] % 2 == 1))))) {
- if (ea == 127) OVERFLOW_ERROR;
- ea++;
- dsr (3, sc, 1, &tc);
- }
- }
-
- /* round */
- if ((tc == 3) || ((tc == 2) && (sc[0] % 2 == 1))) m_add_1 (sc, 1);
-
- } else {
- /* subtraction */
- tc = ta - tb;
- if (m_subtract (3, sc, sa, sb)) {
- m_negate (3, sc);
- c.s = b.s;
- tc = -tc;
- }
- /* round */
- if ((tc == 3) || ((tc == 2) && (sc[0] % 2 == 1))) m_add_1 (sc, 1);
- else if ((tc == -3) || ((tc == -2) && (sc[0] % 2 == 1))) m_subtract_1 (sc, 1);
- }
- c.m0 = sc[0];
- c.m1 = sc[1];
- c.m2 = sc[2];
- c.e = ea;
- return c;
+ deci c;
+ REBCNT sc[4];
+ REBINT ea = a.e, eb = b.e, ta, tb, tc, test;
+
+ // Must be compile-time const for '= {...}' style init (-Wc99-extensions)
+ REBCNT sa[4];
+ REBCNT sb[4];
+
+ sa[0] = a.m0;
+ sa[1] = a.m1;
+ sa[2] = a.m2;
+ sa[3] = 0;
+
+ sb[0] = b.m0;
+ sb[1] = b.m1;
+ sb[2] = b.m2;
+ sb[3] = 0;
+
+ make_comparable (sa, &ea, &ta, sb, &eb, &tb);
+
+ c.s = a.s;
+ if (a.s == b.s) {
+ /* addition */
+ m_add (3, sc, sa, sb);
+ tc = ta + tb;
+
+ /* significand normalization */
+ test = m_cmp (3, sc, P26_1);
+ if ((test > 0) || ((test == 0) && ((tc == 3) || ((tc == 2) && (sc[0] % 2 == 1))))) {
+ if (ea == 127) fail (Error_Overflow_Raw());
+ ea++;
+ dsr (3, sc, 1, &tc);
+ /* the shift may be needed once again */
+ test = m_cmp (3, sc, P26_1);
+ if ((test > 0) || ((test == 0) && ((tc == 3) || ((tc == 2) && (sc[0] % 2 == 1))))) {
+ if (ea == 127) fail (Error_Overflow_Raw());
+ ea++;
+ dsr (3, sc, 1, &tc);
+ }
+ }
+
+ /* round */
+ if ((tc == 3) || ((tc == 2) && (sc[0] % 2 == 1))) m_add_1 (sc, 1);
+
+ } else {
+ /* subtraction */
+ tc = ta - tb;
+ if (m_subtract (3, sc, sa, sb)) {
+ m_negate (3, sc);
+ c.s = b.s;
+ tc = -tc;
+ }
+ /* round */
+ if ((tc == 3) || ((tc == 2) && (sc[0] % 2 == 1))) m_add_1 (sc, 1);
+ else if ((tc == -3) || ((tc == -2) && (sc[0] % 2 == 1))) m_subtract_1 (sc, 1);
+ }
+ c.m0 = sc[0];
+ c.m1 = sc[1];
+ c.m2 = sc[2];
+ c.e = ea;
+ return c;
}
deci deci_subtract (deci a, deci b) {return deci_add (a, deci_negate (b));}
/* using 64-bit arithmetic */
deci int_to_deci (REBI64 a) {
- deci c;
- c.e = 0;
- if (0 <= a) c.s = 0; else {c.s = 1; a = -a;}
- c.m0 = (REBCNT)a;
- c.m1 = (REBCNT)(a >> 32);
- c.m2 = 0;
- return c;
+ deci c;
+ c.e = 0;
+ if (0 <= a) c.s = 0; else {c.s = 1; a = -a;}
+ c.m0 = (REBCNT)a;
+ c.m1 = (REBCNT)(a >> 32);
+ c.m2 = 0;
+ return c;
}
/* using 64-bit arithmetic */
REBI64 deci_to_int (const deci a) {
- REBCNT sa[] = {a.m0, a.m1, a.m2, 0};
- REBINT ta;
- REBI64 result;
-
- /* handle zero and small numbers */
- if (m_is_zero (3, sa) || (a.e < -26)) return (REBI64) 0;
-
- /* handle exponent */
- if (a.e >= 20) OVERFLOW_ERROR;
- if (a.e > 0)
- if (m_cmp (3, P[20 - a.e], sa) <= 0) OVERFLOW_ERROR;
- else dsl (3, sa, a.e);
- else if (a.e < 0) dsr (3, sa, -a.e, &ta);
-
- /* convert significand to integer */
- if (m_cmp (3, sa, min_int64_t_as_deci) > 0) OVERFLOW_ERROR;
- result = ((REBI64) sa[1] << 32) | (REBI64) sa[0];
-
- /* handle sign */
- if (a.s) result = -result;
- if (!a.s && (result < 0)) OVERFLOW_ERROR;
-
- return result;
+ REBINT ta;
+ REBI64 result;
+
+ // Must be compile-time const for '= {...}' style init (-Wc99-extensions)
+ REBCNT sa[4];
+
+ sa[0] = a.m0;
+ sa[1] = a.m1;
+ sa[2] = a.m2;
+ sa[3] = 0;
+
+ /* handle zero and small numbers */
+ if (m_is_zero (3, sa) || (a.e < -26)) return (REBI64) 0;
+
+ /* handle exponent */
+ if (a.e >= 20) fail (Error_Overflow_Raw());
+ if (a.e > 0)
+ if (m_cmp (3, P[20 - a.e], sa) <= 0) fail (Error_Overflow_Raw());
+ else dsl (3, sa, a.e);
+ else if (a.e < 0) dsr (3, sa, -a.e, &ta);
+
+ /* convert significand to integer */
+ if (m_cmp (3, sa, min_int64_t_as_deci) > 0) fail (Error_Overflow_Raw());
+ result = cast(REBI64, (cast(REBU64, sa[1]) << 32) | cast(REBU64, sa[0]));
+
+ /* handle sign */
+ if (a.s && result > MIN_I64) result = -result;
+ if (!a.s && (result < 0)) fail (Error_Overflow_Raw());
+
+ return result;
}
REBDEC deci_to_decimal (const deci a) {
- /* use STRTOD */
- char *se;
+ /* use STRTOD */
+ const char *se;
REBYTE b [34];
- deci_to_string(b, a, 0, '.');
- return STRTOD((char *)b, &se);
+ deci_to_string(b, a, 0, '.');
+ return STRTOD(s_cast(b), &se);
}
#define DOUBLE_DIGITS 17
/* using the dtoa function */
deci decimal_to_deci (REBDEC a) {
- deci result;
- REBI64 d; /* decimal significand */
- int e; /* decimal exponent */
- int s; /* sign */
- REBYTE *c;
- REBYTE *rve;
+ deci result;
+ REBI64 d; /* decimal significand */
+ int e; /* decimal exponent */
+ int s; /* sign */
+ REBYTE *c;
+ REBYTE *rve;
/* convert a to string */
- c = (REBYTE *) dtoa (a, 0, DOUBLE_DIGITS, &e, &s, (char **) &rve);
+ c = (REBYTE *) dtoa (a, 0, DOUBLE_DIGITS, &e, &s, (char **) &rve);
- e -= (rve - c);
+ e -= (rve - c);
- d = CHR_TO_INT(c);
+ d = CHR_TO_INT(c);
- result.s = s;
- result.m2 = 0;
- result.m1 = (REBCNT)(d >> 32);
- result.m0 = (REBCNT)d;
- result.e = 0;
+ result.s = s;
+ result.m2 = 0;
+ result.m1 = (REBCNT)(d >> 32);
+ result.m0 = (REBCNT)d;
+ result.e = 0;
- return deci_ldexp(result, e);
+ return deci_ldexp(result, e);
}
/*
- Calculates a * (10 ** (*f + e));
+ Calculates a * (10 ** (*f + e));
returns zero when underflow occurs;
- ta is a truncate flag as described above;
- *f is supposed to be in range [-128; 127];
+ ta is a truncate flag as described above;
+ *f is supposed to be in range [-128; 127];
*/
-INLINE void m_ldexp (REBCNT a[4], REBINT *f, REBINT e, REBINT ta) {
- /* take care of zero significand */
- if (m_is_zero (3, a)) {
- *f = 0;
- return;
- }
-
- /* take care of exponent overflow */
- if (e >= 281) OVERFLOW_ERROR;
- if (e < -281) e = -282;
-
- *f += e;
-
- /* decimally shift the significand to the right if needed */
- if (*f < -128) {
- if (*f < -154) {
- /* underflow */
- memset (a, 0, 3 * sizeof (REBCNT));
- *f = 0;
- return;
- }
- /* shift and round */
- dsr (3, a, -128 - *f, &ta);
- *f = -128;
- if ((ta == 3) || ((ta == 2) && (a[0] % 2 == 1))) m_add_1 (a, 1);
- return;
- }
-
- /* decimally shift the significand to the left if needed */
- if (*f > 127) {
- if ((*f >= 153) || (m_cmp (3, P[153 - *f], a) <= 0)) OVERFLOW_ERROR;
- dsl (3, a, *f - 127);
- *f = 127;
- }
+void m_ldexp (REBCNT a[4], REBINT *f, REBINT e, REBINT ta) {
+ /* take care of zero significand */
+ if (m_is_zero (3, a)) {
+ *f = 0;
+ return;
+ }
+
+ /* take care of exponent overflow */
+ if (e >= 281) fail (Error_Overflow_Raw());
+ if (e < -281) e = -282;
+
+ *f += e;
+
+ /* decimally shift the significand to the right if needed */
+ if (*f < -128) {
+ if (*f < -154) {
+ /* underflow */
+ memset (a, 0, 3 * sizeof (REBCNT));
+ *f = 0;
+ return;
+ }
+ /* shift and round */
+ dsr (3, a, -128 - *f, &ta);
+ *f = -128;
+ if ((ta == 3) || ((ta == 2) && (a[0] % 2 == 1))) m_add_1 (a, 1);
+ return;
+ }
+
+ /* decimally shift the significand to the left if needed */
+ if (*f > 127) {
+ if ((*f >= 153) || (m_cmp (3, P[153 - *f], a) <= 0))
+ fail (Error_Overflow_Raw());
+ dsl (3, a, *f - 127);
+ *f = 127;
+ }
}
/* Calculates a * (10 ** e); returns zero when underflow occurs */
deci deci_ldexp (deci a, REBINT e) {
- REBCNT sa[] = {a.m0, a.m1, a.m2, 0};
- REBINT f = a.e;
-
- m_ldexp (sa, &f, e, 0);
- a.m0 = sa[0];
- a.m1 = sa[1];
- a.m2 = sa[2];
- a.e = f;
- return a;
+ REBINT f = a.e;
+
+ // Must be compile-time const for '= {...}' style init (-Wc99-extensions)
+ REBCNT sa[4];
+
+ sa[0] = a.m0;
+ sa[1] = a.m1;
+ sa[2] = a.m2;
+ sa[3] = 0;
+
+ m_ldexp (sa, &f, e, 0);
+ a.m0 = sa[0];
+ a.m1 = sa[1];
+ a.m2 = sa[2];
+ a.e = f;
+ return a;
}
#define denormalize \
- if (a.e >= b.e) return a; \
- sa[0] = a.m0; \
- sa[1] = a.m1; \
- sa[2] = a.m2; \
- dsr (3, sa, b.e - a.e, &ta); \
- a.m0 = sa[0]; \
- a.m1 = sa[1]; \
- a.m2 = sa[2]; \
- a.e = b.e; \
- return a;
+ if (a.e >= b.e) return a; \
+ sa[0] = a.m0; \
+ sa[1] = a.m1; \
+ sa[2] = a.m2; \
+ dsr (3, sa, b.e - a.e, &ta); \
+ a.m0 = sa[0]; \
+ a.m1 = sa[1]; \
+ a.m2 = sa[2]; \
+ a.e = b.e; \
+ return a;
/* truncate a to obtain a multiple of b */
deci deci_truncate (deci a, deci b) {
- deci c;
- REBCNT sa[3];
- REBINT ta = 0;
-
- c = deci_mod (a, b);
- /* negate c */
- c.s = !c.s;
- a = deci_add (a, c);
- /* a is now a multiple of b */
-
- denormalize
+ deci c;
+ REBCNT sa[3];
+ REBINT ta = 0;
+
+ c = deci_mod (a, b);
+ /* negate c */
+ c.s = !c.s;
+ a = deci_add (a, c);
+ /* a is now a multiple of b */
+
+ denormalize
}
/* round a away from zero to obtain a multiple of b */
deci deci_away (deci a, deci b) {
- deci c;
- REBCNT sa[3];
- REBINT ta = 0;
-
- c = deci_mod (a, b);
- if (!deci_is_zero (c)) {
- /* negate c and add b with the sign of c */
- b.s = c.s;
- c.s = !c.s;
- c = deci_add (c, b);
- }
- a = deci_add (a, c);
- /* a is now a multiple of b */
-
- denormalize
+ deci c;
+ REBCNT sa[3];
+ REBINT ta = 0;
+
+ c = deci_mod (a, b);
+ if (!deci_is_zero (c)) {
+ /* negate c and add b with the sign of c */
+ b.s = c.s;
+ c.s = !c.s;
+ c = deci_add (c, b);
+ }
+ a = deci_add (a, c);
+ /* a is now a multiple of b */
+
+ denormalize
}
/* round a down to obtain a multiple of b */
deci deci_floor (deci a, deci b) {
- deci c;
- REBCNT sa[3];
- REBINT ta = 0;
-
- c = deci_mod (a, b);
- /* negate c */
- c.s = !c.s;
- if (!c.s && !deci_is_zero (c)) {
- /* c is positive, add negative b to obtain a negative value */
- b.s = 1;
- c = deci_add (b, c);
- }
- a = deci_add (a, c);
- /* a is now a multiple of b */
-
- denormalize
+ deci c;
+ REBCNT sa[3];
+ REBINT ta = 0;
+
+ c = deci_mod (a, b);
+ /* negate c */
+ c.s = !c.s;
+ if (!c.s && !deci_is_zero (c)) {
+ /* c is positive, add negative b to obtain a negative value */
+ b.s = 1;
+ c = deci_add (b, c);
+ }
+ a = deci_add (a, c);
+ /* a is now a multiple of b */
+
+ denormalize
}
/* round a up to obtain a multiple of b */
deci deci_ceil (deci a, deci b) {
- deci c;
- REBCNT sa[3];
- REBINT ta = 0;
-
- c = deci_mod (a, b);
- /* negate c */
- c.s = !c.s;
- if (c.s && !deci_is_zero (c)) {
- /* c is negative, add positive b to obtain a positive value */
- b.s = 0;
- c = deci_add (c, b);
- }
- a = deci_add (a, c);
- /* a is now a multiple of b */
-
- denormalize
+ deci c;
+ REBCNT sa[3];
+ REBINT ta = 0;
+
+ c = deci_mod (a, b);
+ /* negate c */
+ c.s = !c.s;
+ if (c.s && !deci_is_zero (c)) {
+ /* c is negative, add positive b to obtain a positive value */
+ b.s = 0;
+ c = deci_add (c, b);
+ }
+ a = deci_add (a, c);
+ /* a is now a multiple of b */
+
+ denormalize
}
/* round a half even to obtain a multiple of b */
deci deci_half_even (deci a, deci b) {
- deci c, d, e, f;
- REBCNT sa[3];
- REBINT ta = 0;
- REBFLG g;
-
- c = deci_mod (a, b);
-
- /* compare c with b/2 not causing overflow */
- b.s = 0;
- c.s = 1;
- d = deci_add (b, c);
- c.s = 0;
- if (deci_is_equal (c, d)) {
- /* rounding half */
- e = deci_add(b, b); /* this may cause overflow for large b */
- f = deci_mod(a, e);
- f.s = 0;
- g = deci_is_lesser_or_equal(f, b);
- } else g = deci_is_lesser_or_equal(c, d);
- if (g) {
- /* rounding towards zero */
- c.s = !a.s;
- } else {
- /* rounding away from zero */
- c = d;
- c.s = a.s;
- }
- a = deci_add (a, c);
- /* a is now a multiple of b */
-
- denormalize
+ deci c, d, e, f;
+ REBCNT sa[3];
+ REBINT ta = 0;
+ REBOOL g;
+
+ c = deci_mod (a, b);
+
+ /* compare c with b/2 not causing overflow */
+ b.s = 0;
+ c.s = 1;
+ d = deci_add (b, c);
+ c.s = 0;
+ if (deci_is_equal (c, d)) {
+ /* rounding half */
+ e = deci_add(b, b); /* this may cause overflow for large b */
+ f = deci_mod(a, e);
+ f.s = 0;
+ g = deci_is_lesser_or_equal(f, b);
+ } else g = deci_is_lesser_or_equal(c, d);
+ if (g) {
+ /* rounding towards zero */
+ c.s = !a.s;
+ } else {
+ /* rounding away from zero */
+ c = d;
+ c.s = a.s;
+ }
+ a = deci_add (a, c);
+ /* a is now a multiple of b */
+
+ denormalize
}
/* round a half away from zero to obtain a multiple of b */
deci deci_half_away (deci a, deci b) {
- deci c, d;
- REBCNT sa[3];
- REBINT ta = 0;
-
- c = deci_mod (a, b);
-
- /* compare c with b/2 not causing overflow */
- b.s = 0;
- c.s = 1;
- d = deci_add (b, c);
- c.s = 0;
- if (deci_is_lesser_or_equal (d, c)) {
- /* rounding away */
- c = d;
- c.s = a.s;
- } else {
- /* truncating */
- c.s = !a.s;
- }
- a = deci_add (a, c);
- /* a is now a multiple of b */
-
- denormalize
+ deci c, d;
+ REBCNT sa[3];
+ REBINT ta = 0;
+
+ c = deci_mod (a, b);
+
+ /* compare c with b/2 not causing overflow */
+ b.s = 0;
+ c.s = 1;
+ d = deci_add (b, c);
+ c.s = 0;
+ if (deci_is_lesser_or_equal (d, c)) {
+ /* rounding away */
+ c = d;
+ c.s = a.s;
+ } else {
+ /* truncating */
+ c.s = !a.s;
+ }
+ a = deci_add (a, c);
+ /* a is now a multiple of b */
+
+ denormalize
}
/* round a half truncate to obtain a multiple of b */
deci deci_half_truncate (deci a, deci b) {
- deci c, d;
- REBCNT sa[3];
- REBINT ta = 0;
-
- c = deci_mod (a, b);
-
- /* compare c with b/2 not causing overflow */
- b.s = 0;
- c.s = 1;
- d = deci_add (b, c);
- c.s = 0;
- if (deci_is_lesser_or_equal (c, d)) {
- /* truncating */
- c.s = !a.s;
- } else {
- /* rounding away */
- c = d;
- c.s = a.s;
- }
- a = deci_add (a, c);
- /* a is now a multiple of b */
-
- denormalize
+ deci c, d;
+ REBCNT sa[3];
+ REBINT ta = 0;
+
+ c = deci_mod (a, b);
+
+ /* compare c with b/2 not causing overflow */
+ b.s = 0;
+ c.s = 1;
+ d = deci_add (b, c);
+ c.s = 0;
+ if (deci_is_lesser_or_equal (c, d)) {
+ /* truncating */
+ c.s = !a.s;
+ } else {
+ /* rounding away */
+ c = d;
+ c.s = a.s;
+ }
+ a = deci_add (a, c);
+ /* a is now a multiple of b */
+
+ denormalize
}
/* round a half up to obtain a multiple of b */
deci deci_half_ceil (deci a, deci b) {
- deci c, d;
- REBCNT sa[3];
- REBINT ta = 0;
-
- c = deci_mod (a, b);
-
- /* compare c with b/2 not causing overflow */
- b.s = 0;
- c.s = 1;
- d = deci_add (b, c);
- c.s = 0;
-
- if (a.s ? deci_is_lesser_or_equal(c, d) : !deci_is_lesser_or_equal(d, c)) {
- /* truncating */
- c.s = !a.s;
- } else {
- /* rounding away */
- c = d;
- c.s = a.s;
- }
+ deci c, d;
+ REBCNT sa[3];
+ REBINT ta = 0;
+
+ c = deci_mod (a, b);
+
+ /* compare c with b/2 not causing overflow */
+ b.s = 0;
+ c.s = 1;
+ d = deci_add (b, c);
+ c.s = 0;
+
+ if (
+ a.s
+ ? deci_is_lesser_or_equal(c, d)
+ : NOT(deci_is_lesser_or_equal(d, c))
+ ) {
+ /* truncating */
+ c.s = !a.s;
+ } else {
+ /* rounding away */
+ c = d;
+ c.s = a.s;
+ }
#ifdef RM_FIX_B1471
- if (deci_is_lesser_or_equal (d, c)) {
- /* rounding up */
- c.s = !a.s;
- if (c.s && !deci_is_zero (c)) {
- /* c is negative, use d */
- c = d;
- c.s = a.s;
- }
- } else {
- /* rounding down */
- c.s = !a.s;
- if (!c.s && !deci_is_zero (c)) {
- /* c is positive, use d */
- c = d;
- c.s = a.s;
- }
- }
+ if (deci_is_lesser_or_equal (d, c)) {
+ /* rounding up */
+ c.s = !a.s;
+ if (c.s && !deci_is_zero (c)) {
+ /* c is negative, use d */
+ c = d;
+ c.s = a.s;
+ }
+ } else {
+ /* rounding down */
+ c.s = !a.s;
+ if (!c.s && !deci_is_zero (c)) {
+ /* c is positive, use d */
+ c = d;
+ c.s = a.s;
+ }
+ }
#endif
- a = deci_add(a, c);
- /* a is now a multiple of b */
-
- denormalize
+ a = deci_add(a, c);
+ /* a is now a multiple of b */
+
+ denormalize
}
/* round a half down to obtain a multiple of b */
deci deci_half_floor (deci a, deci b) {
- deci c, d;
- REBCNT sa[3];
- REBINT ta = 0;
-
- c = deci_mod (a, b);
-
- /* compare c with b/2 not causing overflow */
- b.s = 0;
- c.s = 1;
- d = deci_add (b, c);
- c.s = 0;
-
- if (a.s ? !deci_is_lesser_or_equal(d, c) : deci_is_lesser_or_equal(c, d)) {
- /* truncating */
- c.s = !a.s;
- } else {
- /* rounding away */
- c = d;
- c.s = a.s;
- }
+ deci c, d;
+ REBCNT sa[3];
+ REBINT ta = 0;
+
+ c = deci_mod (a, b);
+
+ /* compare c with b/2 not causing overflow */
+ b.s = 0;
+ c.s = 1;
+ d = deci_add (b, c);
+ c.s = 0;
+
+ if (
+ a.s
+ ? NOT(deci_is_lesser_or_equal(d, c))
+ : deci_is_lesser_or_equal(c, d)
+ ) {
+ /* truncating */
+ c.s = !a.s;
+ } else {
+ /* rounding away */
+ c = d;
+ c.s = a.s;
+ }
#ifdef RM_FIX_B1471
- if (deci_is_lesser_or_equal (c, d)) {
- /* rounding down */
- c.s = !a.s;
- if (!c.s && !deci_is_zero (c)) {
- /* c is positive, use d */
- c = d;
- c.s = a.s;
- }
- } else {
- /* rounding up */
- c.s = !a.s;
- if (c.s && !deci_is_zero (c)) {
- /* c is negative, use d */
- c = d;
- c.s = a.s;
- }
- }
+ if (deci_is_lesser_or_equal (c, d)) {
+ /* rounding down */
+ c.s = !a.s;
+ if (!c.s && !deci_is_zero (c)) {
+ /* c is positive, use d */
+ c = d;
+ c.s = a.s;
+ }
+ } else {
+ /* rounding up */
+ c.s = !a.s;
+ if (c.s && !deci_is_zero (c)) {
+ /* c is negative, use d */
+ c = d;
+ c.s = a.s;
+ }
+ }
#endif
- a = deci_add(a, c);
- /* a is now a multiple of b */
-
- denormalize
+ a = deci_add(a, c);
+ /* a is now a multiple of b */
+
+ denormalize
}
deci deci_multiply (const deci a, const deci b) {
- deci c;
- REBCNT sa[] = {a.m0, a.m1, a.m2}, sb[] = {b.m0, b.m1, b.m2}, sc[7];
- REBINT shift, tc = 0, e, f = 0;
-
- /* compute the sign */
- c.s = (!a.s && b.s) || (a.s && !b.s);
-
- /* multiply sa by sb yielding "double significand" sc */
- m_multiply (sc, 3, sa, 3, sb);
-
- /* normalize "double significand" sc and round if needed */
- shift = min_shift_right (sc);
- e = a.e + b.e + shift;
- if (shift > 0) {
- dsr (6, sc, shift, &tc);
- if (((tc == 3) || ((tc == 2) && (sc[0] % 2 == 1))) && (e >= -128)) m_add_1 (sc, 1);
- }
-
- m_ldexp (sc, &f, e, tc);
- c.m0 = sc[0];
- c.m1 = sc[1];
- c.m2 = sc[2];
- c.e = f;
- return c;
+ deci c;
+ REBCNT sc[7];
+ REBINT shift, tc = 0, e, f = 0;
+
+ // Must be compile-time const for '= {...}' style init (-Wc99-extensions)
+ REBCNT sa[3];
+ REBCNT sb[3];
+
+ sa[0] = a.m0;
+ sa[1] = a.m1;
+ sa[2] = a.m2;
+
+ sb[0] = b.m0;
+ sb[1] = b.m1;
+ sb[2] = b.m2;
+
+ /* compute the sign */
+ c.s = (!a.s && b.s) || (a.s && !b.s);
+
+ /* multiply sa by sb yielding "double significand" sc */
+ m_multiply (sc, 3, sa, 3, sb);
+
+ /* normalize "double significand" sc and round if needed */
+ shift = min_shift_right (sc);
+ e = a.e + b.e + shift;
+ if (shift > 0) {
+ dsr (6, sc, shift, &tc);
+ if (((tc == 3) || ((tc == 2) && (sc[0] % 2 == 1))) && (e >= -128)) m_add_1 (sc, 1);
+ }
+
+ m_ldexp (sc, &f, e, tc);
+ c.m0 = sc[0];
+ c.m1 = sc[1];
+ c.m2 = sc[2];
+ c.e = f;
+ return c;
}
/*
- b[m - 1] is supposed to be nonzero;
- m <= n required;
- a, b are copied on entry;
- uses 64-bit arithmetic;
+ b[m - 1] is supposed to be nonzero;
+ m <= n required;
+ a, b are copied on entry;
+ uses 64-bit arithmetic;
*/
#define MAX_N 7
#define MAX_M 3
-INLINE void m_divide (
- REBCNT q[/* n - m + 1 */],
- REBCNT r[/* m */],
- const REBINT n,
- const REBCNT a[/* n */],
- const REBINT m,
- const REBCNT b[/* m */]
+void m_divide (
+ REBCNT q[/* n - m + 1 */],
+ REBCNT r[/* m */],
+ const REBINT n,
+ const REBCNT a[/* n */],
+ const REBINT m,
+ const REBCNT b[/* m */]
) {
- REBCNT c[MAX_N + 1], d[MAX_M + 1], e[MAX_M + 1];
- REBCNT bm = b[m - 1];
- REBU64 cm, dm;
- REBINT i, j, k;
-
- if (m == 1) {
- r[0] = m_divide_1 (n, q, a, bm);
- return;
- }
+ REBCNT c[MAX_N + 1], d[MAX_M + 1], e[MAX_M + 1];
+ REBCNT bm = b[m - 1];
+ REBU64 cm, dm;
+ REBINT i, j, k;
+
+ if (m <= 1) {
+ // Note: the test here used to be `if (m == 1)` but gcc 4.9.2 would
+ // warn in -O2 mode that array subscripting with [m - 1] could be
+ // below array bounds, due to not knowing the caller wouldn't pass in
+ // zero. Changed test to `if (m <= 1)`, added assert m is not zero.
+ //
+ assert(m != 0);
+ r[0] = m_divide_1 (n, q, a, bm);
+ return;
+ }
/*
we shift both the divisor and the dividend to the left
to obtain quotients that are off by one at most
*/
- /* the most significant bit of b[m - 1] */
- i = 0;
- j = 31;
- while (i < j) {
- k = (i + j + 1) / 2;
- if ((REBCNT)(1 << k) <= bm) i = k; else j = k - 1;
- }
-
- /* shift the dividend to the left */
- for (j = 0; j < n; j++) c[j] = a[j] << (31 - i);
- c[n] = 0;
- for (j = 0; j < n; j++) c[j + 1] |= a[j] >> (i + 1);
-
- /* shift the divisor to the left */
- for (j = 0; j < m; j++) d[j] = b[j] << (31 - i);
- d[m] = 0;
- for (j = 0; j < m; j++) d[j + 1] |= b[j] >> (i + 1);
-
- dm = (REBU64) d[m - 1];
-
- for (j = n - m; j >= 0; j--) {
- cm = ((REBU64) c[j + m] << 32) + (REBU64) c[j + m - 1];
- cm /= dm;
- if (cm > 0xffffffffu) cm = 0xffffffffu;
- m_multiply_1 (m, e, d, (REBCNT) cm);
- if (m_subtract (m + 1, c + j, c + j, e)) {
- /* the quotient is off by one */
- cm--;
- m_add (m, c + j, c + j, d);
- }
- q[j] = (REBCNT) cm;
- }
+ /* the most significant bit of b[m - 1] */
+ i = 0;
+ j = 31;
+ while (i < j) {
+ k = (i + j + 1) / 2;
+ if ((REBCNT)(1 << k) <= bm) i = k; else j = k - 1;
+ }
+
+ /* shift the dividend to the left */
+ for (j = 0; j < n; j++) c[j] = a[j] << (31 - i);
+ c[n] = 0;
+ for (j = 0; j < n; j++) c[j + 1] |= a[j] >> (i + 1);
+
+ /* shift the divisor to the left */
+ for (j = 0; j < m; j++) d[j] = b[j] << (31 - i);
+ d[m] = 0;
+ for (j = 0; j < m; j++) d[j + 1] |= b[j] >> (i + 1);
+
+ dm = (REBU64) d[m - 1];
+
+ for (j = n - m; j >= 0; j--) {
+ cm = ((REBU64) c[j + m] << 32) + (REBU64) c[j + m - 1];
+ cm /= dm;
+ if (cm > 0xffffffffu) cm = 0xffffffffu;
+ m_multiply_1 (m, e, d, (REBCNT) cm);
+ if (m_subtract (m + 1, c + j, c + j, e)) {
+ /* the quotient is off by one */
+ cm--;
+ m_add (m, c + j, c + j, d);
+ }
+ q[j] = (REBCNT) cm;
+ }
/* shift the remainder back to the right */
c[m] = 0;
@@ -983,334 +1070,373 @@ INLINE void m_divide (
/* uses double arithmetic */
deci deci_divide (deci a, deci b) {
- REBINT e = a.e - b.e, f = 0;
- deci c;
- REBCNT q[] = {0, 0, 0, 0, 0, 0}, r[4];
- REBCNT sa[] = {a.m0, a.m1, a.m2, 0, 0, 0}, sb[] = {b.m0, b.m1, b.m2, 0};
- double a_dbl, b_dbl, l10;
- REBINT shift, na, nb, tc;
-
- if (deci_is_zero (b)) DIVIDE_BY_ZERO_ERROR;
-
- /* compute sign */
- c.s = (!a.s && b.s) || (a.s && !b.s);
-
- if (deci_is_zero (a)) {
- c.m0 = 0;
- c.m1 = 0;
- c.m2 = 0;
- c.e = 0;
- return c;
- }
-
- /* compute decimal shift needed to obtain the highest accuracy */
- a_dbl = (a.m2 * two_to_32 + a.m1) * two_to_32 + a.m0;
- b_dbl = (b.m2 * two_to_32 + b.m1) * two_to_32 + b.m0;
- l10 = log10 (a_dbl);
- shift = (REBINT)ceil (25.5 + log10(b_dbl) - l10);
- dsl (3, sa, shift);
- e -= shift;
-
- /* count radix 2 ** 32 digits of the shifted significand sa */
- na = (REBINT)ceil ((l10 + shift) * 0.10381025296523 + 0.5);
- if (sa[na - 1] == 0) na--;
-
- nb = b.m2 ? 3 : (b.m1 ? 2 : 1);
- m_divide (q, r, na, sa, nb, sb);
-
- /* compute the truncate flag */
- m_multiply_1 (nb, r, r, 2);
- tc = m_cmp (nb + 1, r, sb);
- if (tc >= 0) tc = tc == 0 ? 2 : 3;
- else tc = m_is_zero (nb + 1, r) ? 0 : 1;
-
- /* normalize the significand q */
- shift = min_shift_right (q);
- if (shift > 0) {
- dsr (3, q, shift, &tc);
- e += shift;
- }
-
- /* round q if needed */
- if (((tc == 3) || ((tc == 2) && (q[0] % 2 == 1))) && (e >= -128)) m_add_1 (q, 1);
-
- m_ldexp (q, &f, e, tc);
- c.m0 = q[0];
- c.m1 = q[1];
- c.m2 = q[2];
- c.e = f;
- return c;
+ REBINT e = a.e - b.e, f = 0;
+ deci c;
+ double a_dbl, b_dbl, l10;
+ REBINT shift, na, nb, tc;
+ REBCNT q[] = {0, 0, 0, 0, 0, 0}, r[4];
+
+ // Must be compile-time const for '= {...}' style init (-Wc99-extensions)
+ REBCNT sa[6];
+ REBCNT sb[4];
+
+ sa[0] = a.m0;
+ sa[1] = a.m1;
+ sa[2] = a.m2;
+ sa[3] = 0;
+ sa[4] = 0;
+ sa[5] = 0;
+
+ sb[0] = b.m0;
+ sb[1] = b.m1;
+ sb[2] = b.m2;
+ sb[3] = 0;
+
+ if (deci_is_zero (b)) fail (Error_Zero_Divide_Raw());
+
+ /* compute sign */
+ c.s = (!a.s && b.s) || (a.s && !b.s);
+
+ if (deci_is_zero (a)) {
+ c.m0 = 0;
+ c.m1 = 0;
+ c.m2 = 0;
+ c.e = 0;
+ return c;
+ }
+
+ /* compute decimal shift needed to obtain the highest accuracy */
+ a_dbl = (a.m2 * two_to_32 + a.m1) * two_to_32 + a.m0;
+ b_dbl = (b.m2 * two_to_32 + b.m1) * two_to_32 + b.m0;
+ l10 = log10 (a_dbl);
+ shift = (REBINT)ceil (25.5 + log10(b_dbl) - l10);
+ dsl (3, sa, shift);
+ e -= shift;
+
+ /* count radix 2 ** 32 digits of the shifted significand sa */
+ na = (REBINT)ceil ((l10 + shift) * 0.10381025296523 + 0.5);
+ if (sa[na - 1] == 0) na--;
+
+ nb = b.m2 ? 3 : (b.m1 ? 2 : 1);
+ m_divide (q, r, na, sa, nb, sb);
+
+ /* compute the truncate flag */
+ m_multiply_1 (nb, r, r, 2);
+ tc = m_cmp (nb + 1, r, sb);
+ if (tc >= 0) tc = tc == 0 ? 2 : 3;
+ else tc = m_is_zero (nb + 1, r) ? 0 : 1;
+
+ /* normalize the significand q */
+ shift = min_shift_right (q);
+ if (shift > 0) {
+ dsr (3, q, shift, &tc);
+ e += shift;
+ }
+
+ /* round q if needed */
+ if (((tc == 3) || ((tc == 2) && (q[0] % 2 == 1))) && (e >= -128)) m_add_1 (q, 1);
+
+ m_ldexp (q, &f, e, tc);
+ c.m0 = q[0];
+ c.m1 = q[1];
+ c.m2 = q[2];
+ c.e = f;
+ return c;
}
#define MAX_NB 7
-INLINE REBINT m_to_string (REBYTE *s, REBINT n, const REBCNT a[]) {
+REBINT m_to_string (REBYTE *s, REBINT n, const REBCNT a[]) {
REBCNT r, b[MAX_NB];
- REBYTE v[10 * MAX_NB + 1], *vmax, *k;
-
+ REBYTE v[10 * MAX_NB + 1], *vmax, *k;
+
/* finds the first nonzero radix 2 ** 32 "digit" */
for (; (n > 0) && (a[n - 1] == 0); n--);
-
+
if (n == 0) {
- s[0] = '0';
- s[1] = '\0';
- return 1;
- }
-
+ s[0] = '0';
+ s[1] = '\0';
+ return 1;
+ }
+
/* copy a to preserve it */
- memcpy (b, a, n * sizeof (REBCNT));
-
- k = vmax = v + 10 * MAX_NB;
- *k = '\0';
+ memcpy (b, a, n * sizeof (REBCNT));
+
+ k = vmax = v + 10 * MAX_NB;
+ *k = '\0';
while (n > 0) {
- r = m_divide_1 (n, b, b, 10u);
- if (b[n - 1] == 0) n--;
- *--k = '0' + r;
- }
+ r = m_divide_1 (n, b, b, 10u);
+ if (b[n - 1] == 0) n--;
+ *--k = '0' + r;
+ }
- strcpy(s, k);
+ strcpy(s_cast(s), s_cast(k));
return vmax - k;
}
REBINT deci_to_string(REBYTE *string, const deci a, const REBYTE symbol, const REBYTE point) {
- REBYTE *s = string;
- REBCNT sa[] = {a.m0, a.m1, a.m2};
- REBINT j, e;
-
- /* sign */
- if (a.s) *s++ = '-';
-
- if (symbol) *s++ = symbol;
-
- if (deci_is_zero (a)) {
- *s++ = '0';
- *s = '\0';
- return s-string;
- }
-
- j = m_to_string(s, 3, sa);
- e = j + a.e;
-
- if (e < j) {
- if (e <= 0) {
- if (e < -6) {
- s++;
- if (j > 1) {
- memmove(s + 1, s, j);
- *s = point;
- s += j;
- }
- *s++ = 'e';
- INT_TO_STR(e - 1, s);
- s = strchr(s, '\0');
- } else { /* -6 <= e <= 0 */
- memmove(s + 2 - e, s, j + 1);
- *s++ = '0';
- *s++ = point;
- memset(s, '0', -e);
- s += j - e;
- }
- } else { /* 0 < e < j */
- s += e;
- memmove(s + 1, s, j - e + 1);
- *s++ = point;
- s += j - e;
- }
- } else if (e == j) {
- s += j;
- } else { /* j < e */
- s += j;
- *s++ = 'e';
- INT_TO_STR(e - j, s);
- s = strchr(s, '\0');
- }
-
- return s - string;
+ REBYTE *s = string;
+ REBINT j, e;
+
+ // Must be compile-time const for '= {...}' style init (-Wc99-extensions)
+ REBCNT sa[3];
+
+ sa[0] = a.m0;
+ sa[1] = a.m1;
+ sa[2] = a.m2;
+
+ /* sign */
+ if (a.s) *s++ = '-';
+
+ if (symbol) *s++ = symbol;
+
+ if (deci_is_zero (a)) {
+ *s++ = '0';
+ *s = '\0';
+ return s-string;
+ }
+
+ j = m_to_string(s, 3, sa);
+ e = j + a.e;
+
+ if (e < j) {
+ if (e <= 0) {
+ if (e < -6) {
+ s++;
+ if (j > 1) {
+ memmove(s + 1, s, j);
+ *s = point;
+ s += j;
+ }
+ *s++ = 'e';
+ INT_TO_STR(e - 1, s);
+ s = b_cast(strchr(s_cast(s), '\0'));
+ } else { /* -6 <= e <= 0 */
+ memmove(s + 2 - e, s, j + 1);
+ *s++ = '0';
+ *s++ = point;
+ memset(s, '0', -e);
+ s += j - e;
+ }
+ } else { /* 0 < e < j */
+ s += e;
+ memmove(s + 1, s, j - e + 1);
+ *s++ = point;
+ s += j - e;
+ }
+ } else if (e == j) {
+ s += j;
+ } else { /* j < e */
+ s += j;
+ *s++ = 'e';
+ INT_TO_STR(e - j, s);
+ s = b_cast(strchr(s_cast(s), '\0'));
+ }
+
+ return s - string;
}
deci deci_mod (deci a, deci b) {
- REBCNT sa[] = {a.m0, a.m1, a.m2};
- REBCNT sb[] = {b.m0, b.m1, b.m2,0}; /* the additional place is for dsl */
- REBCNT sc[] = {10u, 0, 0};
- REBCNT p[6]; /* for multiplication results */
- REBINT e, nb;
-
- if (deci_is_zero (b)) DIVIDE_BY_ZERO_ERROR;
- if (deci_is_zero (a)) return deci_zero;
-
- e = a.e - b.e;
- if (e < 0) {
- if (max_shift_left (sb) < -e) return a; /* a < b */
- dsl (3, sb, -e);
- b.e = a.e;
- e = 0;
- }
- /* e >= 0 */
-
- /* count radix 2 ** 32 digits of sb */
- nb = sb[2] ? 3 : (sb[1] ? 2 : 1);
-
- /* sa = remainder(sa, sb) */
- m_divide (p, sa, 3, sa, nb, sb);
+ REBCNT sc[] = {10u, 0, 0};
+ REBCNT p[6]; /* for multiplication results */
+ REBINT e, nb;
+
+ // Must be compile-time const for '= {...}' style init (-Wc99-extensions)
+ REBCNT sa[3];
+ REBCNT sb[4];
+
+ sa[0] = a.m0;
+ sa[1] = a.m1;
+ sa[2] = a.m2;
+
+ sb[0] = b.m0;
+ sb[1] = b.m1;
+ sb[2] = b.m2;
+ sb[3] = 0; /* the additional place is for dsl */
+
+ if (deci_is_zero (b)) fail (Error_Zero_Divide_Raw());
+ if (deci_is_zero (a)) return deci_zero;
+
+ e = a.e - b.e;
+ if (e < 0) {
+ if (max_shift_left (sb) < -e) return a; /* a < b */
+ dsl (3, sb, -e);
+ b.e = a.e;
+ e = 0;
+ }
+ /* e >= 0 */
+
+ /* count radix 2 ** 32 digits of sb */
+ nb = sb[2] ? 3 : (sb[1] ? 2 : 1);
+
+ /* sa = remainder(sa, sb) */
+ m_divide (p, sa, 3, sa, nb, sb);
while (e > 0) {
/* invariants:
computing remainder (sa * pow (sc, e), sb)
sa has nb radix pow (2, 32) digits
*/
- if (e % 2) {
- /* sa = remainder (sa * sc, sb) */
- m_multiply (p, nb, sa, nb, sc);
- m_divide (p, sa, nb + nb, p, nb, sb);
- e--;
- } else {
- /* sc = remainder (sc * sc, sb) */
- m_multiply (p, nb, sc, nb, sc);
- m_divide (p, sc, nb + nb, p, nb, sb);
- e /= 2;
- }
- }
- /* e = 0 */
-
- a.m0 = sa[0];
- a.m1 = nb >= 2 ? sa[1] : 0;
- a.m2 = nb == 3 ? sa[2] : 0;
- a.e = b.e;
- return a;
+ if (e % 2) {
+ /* sa = remainder (sa * sc, sb) */
+ m_multiply (p, nb, sa, nb, sc);
+ m_divide (p, sa, nb + nb, p, nb, sb);
+ e--;
+ } else {
+ /* sc = remainder (sc * sc, sb) */
+ m_multiply (p, nb, sc, nb, sc);
+ m_divide (p, sc, nb + nb, p, nb, sb);
+ e /= 2;
+ }
+ }
+ /* e = 0 */
+
+ a.m0 = sa[0];
+ a.m1 = nb >= 2 ? sa[1] : 0;
+ a.m2 = nb == 3 ? sa[2] : 0;
+ a.e = b.e;
+ return a;
}
/* in case of error the function returns deci_zero and *endptr = s */
-deci string_to_deci (REBYTE *s, REBYTE **endptr) {
- REBYTE *a = s;
- deci b = {0, 0, 0, 0, 0};
- REBCNT sb[] = {0, 0, 0, 0}; /* significand */
- REBINT f = 0, e = 0; /* exponents */
- REBINT fp = 0; /* full precision flag */
- REBINT dp = 0; /* decimal point encountered */
- REBINT tb = 0; /* truncate flag */
- REBINT d; /* digit */
- REBINT es = 1; /* exponent sign */
-
- /* sign */
- if ('+' == *a) a++; else if ('-' == *a) {
- b.s = 1;
- a++;
- }
-
- // optional $
- if ('$' == *a) a++;
-
- /* significand */
- for (; ; a++)
- if (IS_DIGIT(*a)) {
- d = *a - '0';
- if (m_cmp (3, sb, P[25]) < 0) {
- m_multiply_1 (3, sb, sb, 10u);
- m_add_1 (sb, d);
- if (dp) f--;
- } else {
- if (fp) {
- if ((tb == 0) && (d != 0)) tb = 1;
- else if ((tb == 2) && (d != 0)) tb = 3;
- } else {
- fp = 1;
- if (d > 0) tb = d < 5 ? 1 : (d == 5 ? 2 : 3);
- }
- if (!dp) f++;
- }
- } else if (('.' == *a) || (',' == *a)) {
- /* decimal point */
- if (dp) {
- *endptr = s;
- return deci_zero;
- }
- else dp = 1;
- } else if ('\'' != *a) break;
-
- /* exponent */
- if (('e' == *a) || ('E' == *a)) {
- a++;
- /* exponent sign */
- if ('+' == *a) a++; else if ('-' == *a) {
- a++;
- es = -1;
- }
- for (; ; a++) {
- if (IS_DIGIT(*a)) {
- d = *a - '0';
- e = e * 10 + d;
- if (e > 200000000) {
- if (es == 1) OVERFLOW_ERROR;
- else e = 200000000;
- }
- } else break;
- }
- e *= es;
- }
- /* that is supposed to be all */
- *endptr = a;
- e += f;
- f = 0;
-
- /* round */
- if (((tb == 3) || ((tb == 2) && (sb[0] % 2 == 1))) && (e >= -128)) {
- if (m_cmp (3, sb, P26_1) < 0) m_add_1 (sb, 1);
- else {
- dsr (3, sb, 1, &tb);
- e++;
- if ((tb == 3) || ((tb == 2) && (sb[0] % 2 == 1))) m_add_1 (sb, 1);
- }
- }
-
- m_ldexp (sb, &f, e, tb);
-
- b.m0 = sb[0];
- b.m1 = sb[1];
- b.m2 = sb[2];
- b.e = f;
- return b;
+deci string_to_deci (const REBYTE *s, const REBYTE **endptr) {
+ const REBYTE *a = s;
+ deci b = {0, 0, 0, 0, 0};
+ REBCNT sb[] = {0, 0, 0, 0}; /* significand */
+ REBINT f = 0, e = 0; /* exponents */
+ REBINT fp = 0; /* full precision flag */
+ REBINT dp = 0; /* decimal point encountered */
+ REBINT tb = 0; /* truncate flag */
+ REBINT d; /* digit */
+ REBINT es = 1; /* exponent sign */
+
+ /* sign */
+ if ('+' == *a) a++; else if ('-' == *a) {
+ b.s = 1;
+ a++;
+ }
+
+ // optional $
+ if ('$' == *a) a++;
+
+ /* significand */
+ for (; ; a++)
+ if (IS_DIGIT(*a)) {
+ d = *a - '0';
+ if (m_cmp (3, sb, P[25]) < 0) {
+ m_multiply_1 (3, sb, sb, 10u);
+ m_add_1 (sb, d);
+ if (dp) f--;
+ } else {
+ if (fp) {
+ if ((tb == 0) && (d != 0)) tb = 1;
+ else if ((tb == 2) && (d != 0)) tb = 3;
+ } else {
+ fp = 1;
+ if (d > 0) tb = d < 5 ? 1 : (d == 5 ? 2 : 3);
+ }
+ if (!dp) f++;
+ }
+ } else if (('.' == *a) || (',' == *a)) {
+ /* decimal point */
+ if (dp) {
+ *endptr = s;
+ return deci_zero;
+ }
+ else dp = 1;
+ } else if ('\'' != *a) break;
+
+ /* exponent */
+ if (('e' == *a) || ('E' == *a)) {
+ a++;
+ /* exponent sign */
+ if ('+' == *a) a++; else if ('-' == *a) {
+ a++;
+ es = -1;
+ }
+ for (; ; a++) {
+ if (IS_DIGIT(*a)) {
+ d = *a - '0';
+ e = e * 10 + d;
+ if (e > 200000000) {
+ if (es == 1) fail (Error_Overflow_Raw());
+ else e = 200000000;
+ }
+ } else break;
+ }
+ e *= es;
+ }
+ /* that is supposed to be all */
+ *endptr = a;
+ e += f;
+ f = 0;
+
+ /* round */
+ if (((tb == 3) || ((tb == 2) && (sb[0] % 2 == 1))) && (e >= -128)) {
+ if (m_cmp (3, sb, P26_1) < 0) m_add_1 (sb, 1);
+ else {
+ dsr (3, sb, 1, &tb);
+ e++;
+ if ((tb == 3) || ((tb == 2) && (sb[0] % 2 == 1))) m_add_1 (sb, 1);
+ }
+ }
+
+ m_ldexp (sb, &f, e, tb);
+
+ b.m0 = sb[0];
+ b.m1 = sb[1];
+ b.m2 = sb[2];
+ b.e = f;
+ return b;
}
deci deci_sign (deci a) {
- if (deci_is_zero (a)) return a;
- if (a.s) return deci_minus_one; else return deci_one;
+ if (deci_is_zero (a)) return a;
+ if (a.s) return deci_minus_one; else return deci_one;
}
-REBFLG deci_is_same (deci a, deci b) {
- if (deci_is_zero (a)) return deci_is_zero (b);
- return (a.m0 == b.m0) && (a.m1 == b.m1) && (a.m2 == b.m2) && (a.s == b.s) && (a.e == b.e);
+REBOOL deci_is_same (deci a, deci b) {
+ if (deci_is_zero (a)) return deci_is_zero (b);
+ return LOGICAL(
+ (a.m0 == b.m0)
+ && (a.m1 == b.m1)
+ && (a.m2 == b.m2)
+ && (a.s == b.s)
+ && (a.e == b.e)
+ );
}
-deci binary_to_deci(REBYTE s[12]) {
- deci d;
- /* this looks like the only way, since the order of bits in bitsets is compiler-dependent */
- d.s = s[0] >> 7;
- d.e = s[0] << 1 | s[1] >> 7;
- d.m2 = (REBCNT)(s[1] << 1) << 15 | (REBCNT)s[2] << 8 | s[3];
- d.m1 = (REBCNT)s[4] << 24 | (REBCNT)s[5] << 16 | (REBCNT)s[6] << 8 | s[7];
- d.m0 = (REBCNT)s[8] << 24 | (REBCNT)s[9] << 16 | (REBCNT)s[10] << 8 | s[11];
- /* validity checks */
- if (d.m2 >= 5421010u) {
- if (d.m1 >= 3704098002u) {
- if (d.m0 > 3825205247u || d.m1 > 3704098002u) OVERFLOW_ERROR;
- } else if (d.m2 > 5421010u) OVERFLOW_ERROR;
- }
- return d;
+deci binary_to_deci(const REBYTE s[12]) {
+ deci d;
+ /* this looks like the only way, since the order of bits in bitsets is compiler-dependent */
+ d.s = s[0] >> 7;
+ d.e = s[0] << 1 | s[1] >> 7;
+ d.m2 = (REBCNT)(s[1] << 1) << 15 | (REBCNT)s[2] << 8 | s[3];
+ d.m1 = (REBCNT)s[4] << 24 | (REBCNT)s[5] << 16 | (REBCNT)s[6] << 8 | s[7];
+ d.m0 = (REBCNT)s[8] << 24 | (REBCNT)s[9] << 16 | (REBCNT)s[10] << 8 | s[11];
+ /* validity checks */
+ if (d.m2 >= 5421010u) {
+ if (d.m1 >= 3704098002u) {
+ if (d.m0 > 3825205247u || d.m1 > 3704098002u)
+ fail (Error_Overflow_Raw());
+ } else if (d.m2 > 5421010u) fail (Error_Overflow_Raw());
+ }
+ return d;
}
REBYTE *deci_to_binary(REBYTE s[12], const deci d) {
- /* this looks like the only way, since the order of bits in bitsets is compiler-dependent */
- s[0] = d.s << 7 | (REBYTE)d.e >> 1;
- s[1] = (REBYTE)d.e << 7 | d.m2 >> 16;
- s[2] = d.m2 >> 8;
- s[3] = d.m2;
- s[4] = d.m1 >> 24;
- s[5] = d.m1 >> 16;
- s[6] = d.m1 >> 8;
- s[7] = d.m1;
- s[8] = d.m0 >> 24;
- s[9] = d.m0 >> 16;
- s[10] = d.m0 >> 8;
- s[11] = d.m0;
- return s;
+ /* this looks like the only way, since the order of bits in bitsets is compiler-dependent */
+ s[0] = d.s << 7 | (REBYTE)d.e >> 1;
+ s[1] = (REBYTE)d.e << 7 | d.m2 >> 16;
+ s[2] = d.m2 >> 8;
+ s[3] = d.m2;
+ s[4] = d.m1 >> 24;
+ s[5] = d.m1 >> 16;
+ s[6] = d.m1 >> 8;
+ s[7] = d.m1;
+ s[8] = d.m0 >> 24;
+ s[9] = d.m0 >> 16;
+ s[10] = d.m0 >> 8;
+ s[11] = d.m0;
+ return s;
}
diff --git a/src/core/f-dtoa.c b/src/core/f-dtoa.c
index e96e78c221..9e0ac082e5 100644
--- a/src/core/f-dtoa.c
+++ b/src/core/f-dtoa.c
@@ -23,13 +23,13 @@
***************************************************************/
/* Please send bug reports to David M. Gay (dmg at acm dot org,
- * with " at " changed at "@" and " dot " changed to "."). */
+ * with " at " changed at "@" and " dot " changed to "."). */
/* On a machine with IEEE extended-precision registers, it is
* necessary to specify double-precision (53-bit) rounding precision
* before invoking strtod or dtoa. If the machine uses (the equivalent
* of) Intel 80x87 arithmetic, the call
- * _control87(PC_53, MCW_PC);
+ * _control87(PC_53, MCW_PC);
* does this with many compilers. Whether this or another call is
* appropriate depends on the compiler; for this to work, it may be
* necessary to #include "float.h" or another system-dependent header
@@ -49,146 +49,146 @@
*
* Modifications:
*
- * 1. We only require IEEE, IBM, or VAX double-precision
- * arithmetic (not IEEE double-extended).
- * 2. We get by with floating-point arithmetic in a case that
- * Clinger missed -- when we're computing d * 10^n
- * for a small integer d and the integer n is not too
- * much larger than 22 (the maximum integer k for which
- * we can represent 10^k exactly), we may be able to
- * compute (d*10^k) * 10^(e-k) with just one roundoff.
- * 3. Rather than a bit-at-a-time adjustment of the binary
- * result in the hard case, we use floating-point
- * arithmetic to determine the adjustment to within
- * one bit; only in really hard cases do we need to
- * compute a second residual.
- * 4. Because of 3., we don't need a large table of powers of 10
- * for ten-to-e (just some small tables, e.g. of 10^k
- * for 0 <= k <= 22).
+ * 1. We only require IEEE, IBM, or VAX double-precision
+ * arithmetic (not IEEE double-extended).
+ * 2. We get by with floating-point arithmetic in a case that
+ * Clinger missed -- when we're computing d * 10^n
+ * for a small integer d and the integer n is not too
+ * much larger than 22 (the maximum integer k for which
+ * we can represent 10^k exactly), we may be able to
+ * compute (d*10^k) * 10^(e-k) with just one roundoff.
+ * 3. Rather than a bit-at-a-time adjustment of the binary
+ * result in the hard case, we use floating-point
+ * arithmetic to determine the adjustment to within
+ * one bit; only in really hard cases do we need to
+ * compute a second residual.
+ * 4. Because of 3., we don't need a large table of powers of 10
+ * for ten-to-e (just some small tables, e.g. of 10^k
+ * for 0 <= k <= 22).
*/
/*
* #define IEEE_8087 for IEEE-arithmetic machines where the least
- * significant byte has the lowest address.
+ * significant byte has the lowest address.
* #define IEEE_MC68k for IEEE-arithmetic machines where the most
- * significant byte has the lowest address.
+ * significant byte has the lowest address.
* #define Long int on machines with 32-bit ints and 64-bit longs.
* #define IBM for IBM mainframe-style floating-point arithmetic.
* #define VAX for VAX-style floating-point arithmetic (D_floating).
* #define No_leftright to omit left-right logic in fast floating-point
- * computation of dtoa. This will cause dtoa modes 4 and 5 to be
- * treated the same as modes 2 and 3 for some inputs.
+ * computation of dtoa. This will cause dtoa modes 4 and 5 to be
+ * treated the same as modes 2 and 3 for some inputs.
* #define Honor_FLT_ROUNDS if FLT_ROUNDS can assume the values 2 or 3
- * and strtod and dtoa should round accordingly. Unless Trust_FLT_ROUNDS
- * is also #defined, fegetround() will be queried for the rounding mode.
- * Note that both FLT_ROUNDS and fegetround() are specified by the C99
- * standard (and are specified to be consistent, with fesetround()
- * affecting the value of FLT_ROUNDS), but that some (Linux) systems
- * do not work correctly in this regard, so using fegetround() is more
- * portable than using FLT_ROUNDS directly.
+ * and strtod and dtoa should round accordingly. Unless Trust_FLT_ROUNDS
+ * is also #defined, fegetround() will be queried for the rounding mode.
+ * Note that both FLT_ROUNDS and fegetround() are specified by the C99
+ * standard (and are specified to be consistent, with fesetround()
+ * affecting the value of FLT_ROUNDS), but that some (Linux) systems
+ * do not work correctly in this regard, so using fegetround() is more
+ * portable than using FLT_ROUNDS directly.
* #define Check_FLT_ROUNDS if FLT_ROUNDS can assume the values 2 or 3
- * and Honor_FLT_ROUNDS is not #defined.
+ * and Honor_FLT_ROUNDS is not #defined.
* #define RND_PRODQUOT to use rnd_prod and rnd_quot (assembly routines
- * that use extended-precision instructions to compute rounded
- * products and quotients) with IBM.
+ * that use extended-precision instructions to compute rounded
+ * products and quotients) with IBM.
* #define ROUND_BIASED for IEEE-format with biased rounding and arithmetic
- * that rounds toward +Infinity.
+ * that rounds toward +Infinity.
* #define ROUND_BIASED_without_Round_Up for IEEE-format with biased
- * rounding when the underlying floating-point arithmetic uses
- * unbiased rounding. This prevent using ordinary floating-point
- * arithmetic when the result could be computed with one rounding error.
+ * rounding when the underlying floating-point arithmetic uses
+ * unbiased rounding. This prevent using ordinary floating-point
+ * arithmetic when the result could be computed with one rounding error.
* #define Inaccurate_Divide for IEEE-format with correctly rounded
- * products but inaccurate quotients, e.g., for Intel i860.
+ * products but inaccurate quotients, e.g., for Intel i860.
* #define NO_LONG_LONG on machines that do not have a "long long"
- * integer type (of >= 64 bits). On such machines, you can
- * #define Just_16 to store 16 bits per 32-bit Long when doing
- * high-precision integer arithmetic. Whether this speeds things
- * up or slows things down depends on the machine and the number
- * being converted. If long long is available and the name is
- * something other than "long long", #define Llong to be the name,
- * and if "unsigned Llong" does not work as an unsigned version of
- * Llong, #define #ULLong to be the corresponding unsigned type.
+ * integer type (of >= 64 bits). On such machines, you can
+ * #define Just_16 to store 16 bits per 32-bit Long when doing
+ * high-precision integer arithmetic. Whether this speeds things
+ * up or slows things down depends on the machine and the number
+ * being converted. If long long is available and the name is
+ * something other than "long long", #define Llong to be the name,
+ * and if "unsigned Llong" does not work as an unsigned version of
+ * Llong, #define #ULLong to be the corresponding unsigned type.
* #define KR_headers for old-style C function headers.
* #define Bad_float_h if your system lacks a float.h or if it does not
- * define some or all of DBL_DIG, DBL_MAX_10_EXP, DBL_MAX_EXP,
- * FLT_RADIX, FLT_ROUNDS, and DBL_MAX.
+ * define some or all of DBL_DIG, DBL_MAX_10_EXP, DBL_MAX_EXP,
+ * FLT_RADIX, FLT_ROUNDS, and DBL_MAX.
* #define MALLOC your_malloc, where your_malloc(n) acts like malloc(n)
- * if memory is available and otherwise does something you deem
- * appropriate. If MALLOC is undefined, malloc will be invoked
- * directly -- and assumed always to succeed. Similarly, if you
- * want something other than the system's free() to be called to
- * recycle memory acquired from MALLOC, #define FREE to be the
- * name of the alternate routine. (FREE or free is only called in
- * pathological cases, e.g., in a dtoa call after a dtoa return in
- * mode 3 with thousands of digits requested.)
+ * if memory is available and otherwise does something you deem
+ * appropriate. If MALLOC is undefined, malloc will be invoked
+ * directly -- and assumed always to succeed. Similarly, if you
+ * want something other than the system's free() to be called to
+ * recycle memory acquired from MALLOC, #define FREE to be the
+ * name of the alternate routine. (FREE or free is only called in
+ * pathological cases, e.g., in a dtoa call after a dtoa return in
+ * mode 3 with thousands of digits requested.)
* #define Omit_Private_Memory to omit logic (added Jan. 1998) for making
- * memory allocations from a private pool of memory when possible.
- * When used, the private pool is PRIVATE_MEM bytes long: 2304 bytes,
- * unless #defined to be a different length. This default length
- * suffices to get rid of MALLOC calls except for unusual cases,
- * such as decimal-to-binary conversion of a very long string of
- * digits. The longest string dtoa can return is about 751 bytes
- * long. For conversions by strtod of strings of 800 digits and
- * all dtoa conversions in single-threaded executions with 8-byte
- * pointers, PRIVATE_MEM >= 7400 appears to suffice; with 4-byte
- * pointers, PRIVATE_MEM >= 7112 appears adequate.
+ * memory allocations from a private pool of memory when possible.
+ * When used, the private pool is PRIVATE_MEM bytes long: 2304 bytes,
+ * unless #defined to be a different length. This default length
+ * suffices to get rid of MALLOC calls except for unusual cases,
+ * such as decimal-to-binary conversion of a very long string of
+ * digits. The longest string dtoa can return is about 751 bytes
+ * long. For conversions by strtod of strings of 800 digits and
+ * all dtoa conversions in single-threaded executions with 8-byte
+ * pointers, PRIVATE_MEM >= 7400 appears to suffice; with 4-byte
+ * pointers, PRIVATE_MEM >= 7112 appears adequate.
* #define NO_INFNAN_CHECK if you do not wish to have INFNAN_CHECK
- * #defined automatically on IEEE systems. On such systems,
- * when INFNAN_CHECK is #defined, strtod checks
- * for Infinity and NaN (case insensitively). On some systems
- * (e.g., some HP systems), it may be necessary to #define NAN_WORD0
- * appropriately -- to the most significant word of a quiet NaN.
- * (On HP Series 700/800 machines, -DNAN_WORD0=0x7ff40000 works.)
- * When INFNAN_CHECK is #defined and No_Hex_NaN is not #defined,
- * strtod also accepts (case insensitively) strings of the form
- * NaN(x), where x is a string of hexadecimal digits and spaces;
- * if there is only one string of hexadecimal digits, it is taken
- * for the 52 fraction bits of the resulting NaN; if there are two
- * or more strings of hex digits, the first is for the high 20 bits,
- * the second and subsequent for the low 32 bits, with intervening
- * white space ignored; but if this results in none of the 52
- * fraction bits being on (an IEEE Infinity symbol), then NAN_WORD0
- * and NAN_WORD1 are used instead.
+ * #defined automatically on IEEE systems. On such systems,
+ * when INFNAN_CHECK is #defined, strtod checks
+ * for Infinity and NaN (case insensitively). On some systems
+ * (e.g., some HP systems), it may be necessary to #define NAN_WORD0
+ * appropriately -- to the most significant word of a quiet NaN.
+ * (On HP Series 700/800 machines, -DNAN_WORD0=0x7ff40000 works.)
+ * When INFNAN_CHECK is #defined and No_Hex_NaN is not #defined,
+ * strtod also accepts (case insensitively) strings of the form
+ * NaN(x), where x is a string of hexadecimal digits and spaces;
+ * if there is only one string of hexadecimal digits, it is taken
+ * for the 52 fraction bits of the resulting NaN; if there are two
+ * or more strings of hex digits, the first is for the high 20 bits,
+ * the second and subsequent for the low 32 bits, with intervening
+ * white space ignored; but if this results in none of the 52
+ * fraction bits being on (an IEEE Infinity symbol), then NAN_WORD0
+ * and NAN_WORD1 are used instead.
* #define MULTIPLE_THREADS if the system offers preemptively scheduled
- * multiple threads. In this case, you must provide (or suitably
- * #define) two locks, acquired by ACQUIRE_DTOA_LOCK(n) and freed
- * by FREE_DTOA_LOCK(n) for n = 0 or 1. (The second lock, accessed
- * in pow5mult, ensures lazy evaluation of only one copy of high
- * powers of 5; omitting this lock would introduce a small
- * probability of wasting memory, but would otherwise be harmless.)
- * You must also invoke freedtoa(s) to free the value s returned by
- * dtoa. You may do so whether or not MULTIPLE_THREADS is #defined.
+ * multiple threads. In this case, you must provide (or suitably
+ * #define) two locks, acquired by ACQUIRE_DTOA_LOCK(n) and freed
+ * by FREE_DTOA_LOCK(n) for n = 0 or 1. (The second lock, accessed
+ * in pow5mult, ensures lazy evaluation of only one copy of high
+ * powers of 5; omitting this lock would introduce a small
+ * probability of wasting memory, but would otherwise be harmless.)
+ * You must also invoke freedtoa(s) to free the value s returned by
+ * dtoa. You may do so whether or not MULTIPLE_THREADS is #defined.
* #define NO_IEEE_Scale to disable new (Feb. 1997) logic in strtod that
- * avoids underflows on inputs whose result does not underflow.
- * If you #define NO_IEEE_Scale on a machine that uses IEEE-format
- * floating-point numbers and flushes underflows to zero rather
- * than implementing gradual underflow, then you must also #define
- * Sudden_Underflow.
+ * avoids underflows on inputs whose result does not underflow.
+ * If you #define NO_IEEE_Scale on a machine that uses IEEE-format
+ * floating-point numbers and flushes underflows to zero rather
+ * than implementing gradual underflow, then you must also #define
+ * Sudden_Underflow.
* #define USE_LOCALE to use the current locale's decimal_point value.
* #define SET_INEXACT if IEEE arithmetic is being used and extra
- * computation should be done to set the inexact flag when the
- * result is inexact and avoid setting inexact when the result
- * is exact. In this case, dtoa.c must be compiled in
- * an environment, perhaps provided by #include "dtoa.c" in a
- * suitable wrapper, that defines two functions,
- * int get_inexact(void);
- * void clear_inexact(void);
- * such that get_inexact() returns a nonzero value if the
- * inexact bit is already set, and clear_inexact() sets the
- * inexact bit to 0. When SET_INEXACT is #defined, strtod
- * also does extra computations to set the underflow and overflow
- * flags when appropriate (i.e., when the result is tiny and
- * inexact or when it is a numeric value rounded to +-infinity).
+ * computation should be done to set the inexact flag when the
+ * result is inexact and avoid setting inexact when the result
+ * is exact. In this case, dtoa.c must be compiled in
+ * an environment, perhaps provided by #include "dtoa.c" in a
+ * suitable wrapper, that defines two functions,
+ * int get_inexact(void);
+ * void clear_inexact(void);
+ * such that get_inexact() returns a nonzero value if the
+ * inexact bit is already set, and clear_inexact() sets the
+ * inexact bit to 0. When SET_INEXACT is #defined, strtod
+ * also does extra computations to set the underflow and overflow
+ * flags when appropriate (i.e., when the result is tiny and
+ * inexact or when it is a numeric value rounded to +-infinity).
* #define NO_ERRNO if strtod should not assign errno = ERANGE when
- * the result overflows to +-Infinity or underflows to 0.
+ * the result overflows to +-Infinity or underflows to 0.
* #define NO_HEX_FP to omit recognition of hexadecimal floating-point
- * values by strtod.
+ * values by strtod.
* #define NO_STRTOD_BIGCOMP (on IEEE-arithmetic systems only for now)
- * to disable logic for "fast" testing of very long input strings
- * to strtod. This testing proceeds by initially truncating the
- * input string, then if necessary comparing the whole string with
- * a decimal expansion to decide close cases. This logic is only
- * used for input more than STRTOD_DIGLIM digits long (default 40).
+ * to disable logic for "fast" testing of very long input strings
+ * to strtod. This testing proceeds by initially truncating the
+ * input string, then if necessary comparing the whole string with
+ * a decimal expansion to decide close cases. This logic is only
+ * used for input more than STRTOD_DIGLIM digits long (default 40).
*/
#ifndef Long
@@ -199,7 +199,7 @@ typedef unsigned Long ULong;
#endif
#ifdef DEBUG
-#include "stdio.h"
+// #include "stdio.h" // !!! No in Ren-C release builds
#define Bug(x) {fprintf(stderr, "%s\n", x); exit(1);}
#endif
@@ -376,7 +376,7 @@ extern int strtod_diglim;
#define Int_max 14
#ifndef NO_IEEE_Scale
#define Avoid_Underflow
-#ifdef Flush_Denorm /* debugging option */
+#ifdef Flush_Denorm /* debugging option */
#undef Sudden_Underflow
#endif
#endif
@@ -417,7 +417,7 @@ extern int strtod_diglim;
#define Emin (-260)
#define Exp_1 0x41000000
#define Exp_11 0x41000000
-#define Ebits 8 /* exponent has 7 bits, but 8 is the right value in b2d */
+#define Ebits 8 /* exponent has 7 bits, but 8 is the right value in b2d */
#define Frac_mask 0xffffff
#define Frac_mask1 0xffffff
#define Bletch 4
@@ -512,7 +512,7 @@ BCinfo { int dp0, dp1, dplen, dsign, e0, inexact, nd, nd0, rounding, scale, uflc
* slower. Hence the default is now to store 32 bits per Long.
*/
#endif
-#else /* long long available */
+#else /* long long available */
#ifndef Llong
#define Llong long long
#endif
@@ -522,24 +522,30 @@ BCinfo { int dp0, dp1, dplen, dsign, e0, inexact, nd, nd0, rounding, scale, uflc
#endif /* NO_LONG_LONG */
#ifndef MULTIPLE_THREADS
-#define ACQUIRE_DTOA_LOCK(n) /*nothing*/
-#define FREE_DTOA_LOCK(n) /*nothing*/
+#define ACQUIRE_DTOA_LOCK(n) /*nothing*/
+#define FREE_DTOA_LOCK(n) /*nothing*/
#endif
#define Kmax 7
#ifdef __cplusplus
-extern "C" double strtod(const char *s00, char **se);
-extern "C" char *dtoa(double d, int mode, int ndigits,
- int *decpt, int *sign, char **rve);
+extern "C" {
+#endif
+
+double strtod(const char *s00, const char **se);
+char *dtoa(double d, int mode, int ndigits,
+ int *decpt, int *sign, char **rve);
+
+#ifdef __cplusplus
+}
#endif
struct
Bigint {
- struct Bigint *next;
- int k, maxwds, sign, wds;
- ULong x[1];
- };
+ struct Bigint *next;
+ int k, maxwds, sign, wds;
+ ULong x[1];
+ };
typedef struct Bigint Bigint;
@@ -548,67 +554,68 @@ Bigint {
static Bigint *
Balloc
#ifdef KR_headers
- (k) int k;
+ (k) int k;
#else
- (int k)
+ (int k)
#endif
{
- int x;
- Bigint *rv;
+ int x;
+ Bigint *rv;
#ifndef Omit_Private_Memory
- unsigned int len;
+ size_t len; // !!! Ren/C: (unsigned int => size_t) for -Wsign-compare
+ // !!! REVIEW: isn't size_t unsigned? Why did that fix it?
#endif
- ACQUIRE_DTOA_LOCK(0);
- /* The k > Kmax case does not need ACQUIRE_DTOA_LOCK(0), */
- /* but this case seems very unlikely. */
- if (k <= Kmax && (rv = freelist[k]))
- freelist[k] = rv->next;
- else {
- x = 1 << k;
+ ACQUIRE_DTOA_LOCK(0);
+ /* The k > Kmax case does not need ACQUIRE_DTOA_LOCK(0), */
+ /* but this case seems very unlikely. */
+ if (k <= Kmax && (rv = freelist[k]))
+ freelist[k] = rv->next;
+ else {
+ x = 1 << k;
#ifdef Omit_Private_Memory
- rv = (Bigint *)MALLOC(sizeof(Bigint) + (x-1)*sizeof(ULong));
+ rv = (Bigint *)MALLOC(sizeof(Bigint) + (x-1)*sizeof(ULong));
#else
- len = (sizeof(Bigint) + (x-1)*sizeof(ULong) + sizeof(double) - 1)
- /sizeof(double);
- if (k <= Kmax && pmem_next - private_mem + len <= PRIVATE_mem) {
- rv = (Bigint*)pmem_next;
- pmem_next += len;
- }
- else
- rv = (Bigint*)MALLOC(len*sizeof(double));
-#endif
- rv->k = k;
- rv->maxwds = x;
- }
- FREE_DTOA_LOCK(0);
- rv->sign = rv->wds = 0;
- return rv;
- }
+ len = (sizeof(Bigint) + (x-1)*sizeof(ULong) + sizeof(double) - 1)
+ /sizeof(double);
+ if (k <= Kmax && pmem_next - private_mem + len <= PRIVATE_mem) {
+ rv = (Bigint*)pmem_next;
+ pmem_next += len;
+ }
+ else
+ rv = (Bigint*)MALLOC(len*sizeof(double));
+#endif
+ rv->k = k;
+ rv->maxwds = x;
+ }
+ FREE_DTOA_LOCK(0);
+ rv->sign = rv->wds = 0;
+ return rv;
+ }
static void
Bfree
#ifdef KR_headers
- (v) Bigint *v;
+ (v) Bigint *v;
#else
- (Bigint *v)
+ (Bigint *v)
#endif
{
- if (v) {
- if (v->k > Kmax)
+ if (v) {
+ if (v->k > Kmax)
#ifdef FREE
- FREE((void*)v);
+ FREE((void*)v);
#else
- free((void*)v);
+ free((void*)v);
#endif
- else {
- ACQUIRE_DTOA_LOCK(0);
- v->next = freelist[v->k];
- freelist[v->k] = v;
- FREE_DTOA_LOCK(0);
- }
- }
- }
+ else {
+ ACQUIRE_DTOA_LOCK(0);
+ v->next = freelist[v->k];
+ freelist[v->k] = v;
+ FREE_DTOA_LOCK(0);
+ }
+ }
+ }
#define Bcopy(x,y) memcpy((char *)&x->sign, (char *)&y->sign, \
y->wds*sizeof(Long) + 2*sizeof(int))
@@ -616,861 +623,861 @@ y->wds*sizeof(Long) + 2*sizeof(int))
static Bigint *
multadd
#ifdef KR_headers
- (b, m, a) Bigint *b; int m, a;
+ (b, m, a) Bigint *b; int m, a;
#else
- (Bigint *b, int m, int a) /* multiply by m and add a */
+ (Bigint *b, int m, int a) /* multiply by m and add a */
#endif
{
- int i, wds;
+ int i, wds;
#ifdef ULLong
- ULong *x;
- ULLong carry, y;
+ ULong *x;
+ ULLong carry, y;
#else
- ULong carry, *x, y;
+ ULong carry, *x, y;
#ifdef Pack_32
- ULong xi, z;
+ ULong xi, z;
#endif
#endif
- Bigint *b1;
+ Bigint *b1;
- wds = b->wds;
- x = b->x;
- i = 0;
- carry = a;
- do {
+ wds = b->wds;
+ x = b->x;
+ i = 0;
+ carry = a;
+ do {
#ifdef ULLong
- y = *x * (ULLong)m + carry;
- carry = y >> 32;
- *x++ = y & FFFFFFFF;
+ y = *x * (ULLong)m + carry;
+ carry = y >> 32;
+ *x++ = y & FFFFFFFF;
#else
#ifdef Pack_32
- xi = *x;
- y = (xi & 0xffff) * m + carry;
- z = (xi >> 16) * m + (y >> 16);
- carry = z >> 16;
- *x++ = (z << 16) + (y & 0xffff);
+ xi = *x;
+ y = (xi & 0xffff) * m + carry;
+ z = (xi >> 16) * m + (y >> 16);
+ carry = z >> 16;
+ *x++ = (z << 16) + (y & 0xffff);
#else
- y = *x * m + carry;
- carry = y >> 16;
- *x++ = y & 0xffff;
-#endif
-#endif
- }
- while(++i < wds);
- if (carry) {
- if (wds >= b->maxwds) {
- b1 = Balloc(b->k+1);
- Bcopy(b1, b);
- Bfree(b);
- b = b1;
- }
- b->x[wds++] = carry;
- b->wds = wds;
- }
- return b;
- }
+ y = *x * m + carry;
+ carry = y >> 16;
+ *x++ = y & 0xffff;
+#endif
+#endif
+ }
+ while(++i < wds);
+ if (carry) {
+ if (wds >= b->maxwds) {
+ b1 = Balloc(b->k+1);
+ Bcopy(b1, b);
+ Bfree(b);
+ b = b1;
+ }
+ b->x[wds++] = carry;
+ b->wds = wds;
+ }
+ return b;
+ }
static Bigint *
s2b
#ifdef KR_headers
- (s, nd0, nd, y9, dplen) CONST char *s; int nd0, nd, dplen; ULong y9;
+ (s, nd0, nd, y9, dplen) CONST char *s; int nd0, nd, dplen; ULong y9;
#else
- (const char *s, int nd0, int nd, ULong y9, int dplen)
+ (const char *s, int nd0, int nd, ULong y9, int dplen)
#endif
{
- Bigint *b;
- int i, k;
- Long x, y;
+ Bigint *b;
+ int i, k;
+ Long x, y;
- x = (nd + 8) / 9;
- for(k = 0, y = 1; x > y; y <<= 1, k++) ;
+ x = (nd + 8) / 9;
+ for(k = 0, y = 1; x > y; y <<= 1, k++) ;
#ifdef Pack_32
- b = Balloc(k);
- b->x[0] = y9;
- b->wds = 1;
+ b = Balloc(k);
+ b->x[0] = y9;
+ b->wds = 1;
#else
- b = Balloc(k+1);
- b->x[0] = y9 & 0xffff;
- b->wds = (b->x[1] = y9 >> 16) ? 2 : 1;
-#endif
-
- i = 9;
- if (9 < nd0) {
- s += 9;
- do b = multadd(b, 10, *s++ - '0');
- while(++i < nd0);
- s += dplen;
- }
- else
- s += dplen + 9;
- for(; i < nd; i++)
- b = multadd(b, 10, *s++ - '0');
- return b;
- }
+ b = Balloc(k+1);
+ b->x[0] = y9 & 0xffff;
+ b->wds = (b->x[1] = y9 >> 16) ? 2 : 1;
+#endif
+
+ i = 9;
+ if (9 < nd0) {
+ s += 9;
+ do b = multadd(b, 10, *s++ - '0');
+ while(++i < nd0);
+ s += dplen;
+ }
+ else
+ s += dplen + 9;
+ for(; i < nd; i++)
+ b = multadd(b, 10, *s++ - '0');
+ return b;
+ }
static int
hi0bits
#ifdef KR_headers
- (x) ULong x;
+ (x) ULong x;
#else
- (ULong x)
+ (ULong x)
#endif
{
- int k = 0;
-
- if (!(x & 0xffff0000)) {
- k = 16;
- x <<= 16;
- }
- if (!(x & 0xff000000)) {
- k += 8;
- x <<= 8;
- }
- if (!(x & 0xf0000000)) {
- k += 4;
- x <<= 4;
- }
- if (!(x & 0xc0000000)) {
- k += 2;
- x <<= 2;
- }
- if (!(x & 0x80000000)) {
- k++;
- if (!(x & 0x40000000))
- return 32;
- }
- return k;
- }
+ int k = 0;
+
+ if (!(x & 0xffff0000)) {
+ k = 16;
+ x <<= 16;
+ }
+ if (!(x & 0xff000000)) {
+ k += 8;
+ x <<= 8;
+ }
+ if (!(x & 0xf0000000)) {
+ k += 4;
+ x <<= 4;
+ }
+ if (!(x & 0xc0000000)) {
+ k += 2;
+ x <<= 2;
+ }
+ if (!(x & 0x80000000)) {
+ k++;
+ if (!(x & 0x40000000))
+ return 32;
+ }
+ return k;
+ }
static int
lo0bits
#ifdef KR_headers
- (y) ULong *y;
+ (y) ULong *y;
#else
- (ULong *y)
+ (ULong *y)
#endif
{
- int k;
- ULong x = *y;
-
- if (x & 7) {
- if (x & 1)
- return 0;
- if (x & 2) {
- *y = x >> 1;
- return 1;
- }
- *y = x >> 2;
- return 2;
- }
- k = 0;
- if (!(x & 0xffff)) {
- k = 16;
- x >>= 16;
- }
- if (!(x & 0xff)) {
- k += 8;
- x >>= 8;
- }
- if (!(x & 0xf)) {
- k += 4;
- x >>= 4;
- }
- if (!(x & 0x3)) {
- k += 2;
- x >>= 2;
- }
- if (!(x & 1)) {
- k++;
- x >>= 1;
- if (!x)
- return 32;
- }
- *y = x;
- return k;
- }
+ int k;
+ ULong x = *y;
+
+ if (x & 7) {
+ if (x & 1)
+ return 0;
+ if (x & 2) {
+ *y = x >> 1;
+ return 1;
+ }
+ *y = x >> 2;
+ return 2;
+ }
+ k = 0;
+ if (!(x & 0xffff)) {
+ k = 16;
+ x >>= 16;
+ }
+ if (!(x & 0xff)) {
+ k += 8;
+ x >>= 8;
+ }
+ if (!(x & 0xf)) {
+ k += 4;
+ x >>= 4;
+ }
+ if (!(x & 0x3)) {
+ k += 2;
+ x >>= 2;
+ }
+ if (!(x & 1)) {
+ k++;
+ x >>= 1;
+ if (!x)
+ return 32;
+ }
+ *y = x;
+ return k;
+ }
static Bigint *
i2b
#ifdef KR_headers
- (i) int i;
+ (i) int i;
#else
- (int i)
+ (int i)
#endif
{
- Bigint *b;
+ Bigint *b;
- b = Balloc(1);
- b->x[0] = i;
- b->wds = 1;
- return b;
- }
+ b = Balloc(1);
+ b->x[0] = i;
+ b->wds = 1;
+ return b;
+ }
static Bigint *
mult
#ifdef KR_headers
- (a, b) Bigint *a, *b;
+ (a, b) Bigint *a, *b;
#else
- (Bigint *a, Bigint *b)
+ (Bigint *a, Bigint *b)
#endif
{
- Bigint *c;
- int k, wa, wb, wc;
- ULong *x, *xa, *xae, *xb, *xbe, *xc, *xc0;
- ULong y;
+ Bigint *c;
+ int k, wa, wb, wc;
+ ULong *x, *xa, *xae, *xb, *xbe, *xc, *xc0;
+ ULong y;
#ifdef ULLong
- ULLong carry, z;
+ ULLong carry, z;
#else
- ULong carry, z;
+ ULong carry, z;
#ifdef Pack_32
- ULong z2;
-#endif
-#endif
-
- if (a->wds < b->wds) {
- c = a;
- a = b;
- b = c;
- }
- k = a->k;
- wa = a->wds;
- wb = b->wds;
- wc = wa + wb;
- if (wc > a->maxwds)
- k++;
- c = Balloc(k);
- for(x = c->x, xa = x + wc; x < xa; x++)
- *x = 0;
- xa = a->x;
- xae = xa + wa;
- xb = b->x;
- xbe = xb + wb;
- xc0 = c->x;
+ ULong z2;
+#endif
+#endif
+
+ if (a->wds < b->wds) {
+ c = a;
+ a = b;
+ b = c;
+ }
+ k = a->k;
+ wa = a->wds;
+ wb = b->wds;
+ wc = wa + wb;
+ if (wc > a->maxwds)
+ k++;
+ c = Balloc(k);
+ for(x = c->x, xa = x + wc; x < xa; x++)
+ *x = 0;
+ xa = a->x;
+ xae = xa + wa;
+ xb = b->x;
+ xbe = xb + wb;
+ xc0 = c->x;
#ifdef ULLong
- for(; xb < xbe; xc0++) {
- if ((y = *xb++)) {
- x = xa;
- xc = xc0;
- carry = 0;
- do {
- z = *x++ * (ULLong)y + *xc + carry;
- carry = z >> 32;
- *xc++ = z & FFFFFFFF;
- }
- while(x < xae);
- *xc = carry;
- }
- }
+ for(; xb < xbe; xc0++) {
+ if ((y = *xb++)) {
+ x = xa;
+ xc = xc0;
+ carry = 0;
+ do {
+ z = *x++ * (ULLong)y + *xc + carry;
+ carry = z >> 32;
+ *xc++ = z & FFFFFFFF;
+ }
+ while(x < xae);
+ *xc = carry;
+ }
+ }
#else
#ifdef Pack_32
- for(; xb < xbe; xb++, xc0++) {
- if (y = *xb & 0xffff) {
- x = xa;
- xc = xc0;
- carry = 0;
- do {
- z = (*x & 0xffff) * y + (*xc & 0xffff) + carry;
- carry = z >> 16;
- z2 = (*x++ >> 16) * y + (*xc >> 16) + carry;
- carry = z2 >> 16;
- Storeinc(xc, z2, z);
- }
- while(x < xae);
- *xc = carry;
- }
- if (y = *xb >> 16) {
- x = xa;
- xc = xc0;
- carry = 0;
- z2 = *xc;
- do {
- z = (*x & 0xffff) * y + (*xc >> 16) + carry;
- carry = z >> 16;
- Storeinc(xc, z, z2);
- z2 = (*x++ >> 16) * y + (*xc & 0xffff) + carry;
- carry = z2 >> 16;
- }
- while(x < xae);
- *xc = z2;
- }
- }
+ for(; xb < xbe; xb++, xc0++) {
+ if (y = *xb & 0xffff) {
+ x = xa;
+ xc = xc0;
+ carry = 0;
+ do {
+ z = (*x & 0xffff) * y + (*xc & 0xffff) + carry;
+ carry = z >> 16;
+ z2 = (*x++ >> 16) * y + (*xc >> 16) + carry;
+ carry = z2 >> 16;
+ Storeinc(xc, z2, z);
+ }
+ while(x < xae);
+ *xc = carry;
+ }
+ if (y = *xb >> 16) {
+ x = xa;
+ xc = xc0;
+ carry = 0;
+ z2 = *xc;
+ do {
+ z = (*x & 0xffff) * y + (*xc >> 16) + carry;
+ carry = z >> 16;
+ Storeinc(xc, z, z2);
+ z2 = (*x++ >> 16) * y + (*xc & 0xffff) + carry;
+ carry = z2 >> 16;
+ }
+ while(x < xae);
+ *xc = z2;
+ }
+ }
#else
- for(; xb < xbe; xc0++) {
- if (y = *xb++) {
- x = xa;
- xc = xc0;
- carry = 0;
- do {
- z = *x++ * y + *xc + carry;
- carry = z >> 16;
- *xc++ = z & 0xffff;
- }
- while(x < xae);
- *xc = carry;
- }
- }
-#endif
-#endif
- for(xc0 = c->x, xc = xc0 + wc; wc > 0 && !*--xc; --wc) ;
- c->wds = wc;
- return c;
- }
+ for(; xb < xbe; xc0++) {
+ if (y = *xb++) {
+ x = xa;
+ xc = xc0;
+ carry = 0;
+ do {
+ z = *x++ * y + *xc + carry;
+ carry = z >> 16;
+ *xc++ = z & 0xffff;
+ }
+ while(x < xae);
+ *xc = carry;
+ }
+ }
+#endif
+#endif
+ for(xc0 = c->x, xc = xc0 + wc; wc > 0 && !*--xc; --wc) ;
+ c->wds = wc;
+ return c;
+ }
static Bigint *p5s;
static Bigint *
pow5mult
#ifdef KR_headers
- (b, k) Bigint *b; int k;
+ (b, k) Bigint *b; int k;
#else
- (Bigint *b, int k)
+ (Bigint *b, int k)
#endif
{
- Bigint *b1, *p5, *p51;
- int i;
- static int p05[3] = { 5, 25, 125 };
+ Bigint *b1, *p5, *p51;
+ int i;
+ static int p05[3] = { 5, 25, 125 };
- if ((i = k & 3))
- b = multadd(b, p05[i-1], 0);
+ if ((i = k & 3))
+ b = multadd(b, p05[i-1], 0);
- if (!(k >>= 2))
- return b;
- if (!(p5 = p5s)) {
- /* first time */
+ if (!(k >>= 2))
+ return b;
+ if (!(p5 = p5s)) {
+ /* first time */
#ifdef MULTIPLE_THREADS
- ACQUIRE_DTOA_LOCK(1);
- if (!(p5 = p5s)) {
- p5 = p5s = i2b(625);
- p5->next = 0;
- }
- FREE_DTOA_LOCK(1);
+ ACQUIRE_DTOA_LOCK(1);
+ if (!(p5 = p5s)) {
+ p5 = p5s = i2b(625);
+ p5->next = 0;
+ }
+ FREE_DTOA_LOCK(1);
#else
- p5 = p5s = i2b(625);
- p5->next = 0;
-#endif
- }
- for(;;) {
- if (k & 1) {
- b1 = mult(b, p5);
- Bfree(b);
- b = b1;
- }
- if (!(k >>= 1))
- break;
- if (!(p51 = p5->next)) {
+ p5 = p5s = i2b(625);
+ p5->next = 0;
+#endif
+ }
+ for(;;) {
+ if (k & 1) {
+ b1 = mult(b, p5);
+ Bfree(b);
+ b = b1;
+ }
+ if (!(k >>= 1))
+ break;
+ if (!(p51 = p5->next)) {
#ifdef MULTIPLE_THREADS
- ACQUIRE_DTOA_LOCK(1);
- if (!(p51 = p5->next)) {
- p51 = p5->next = mult(p5,p5);
- p51->next = 0;
- }
- FREE_DTOA_LOCK(1);
+ ACQUIRE_DTOA_LOCK(1);
+ if (!(p51 = p5->next)) {
+ p51 = p5->next = mult(p5,p5);
+ p51->next = 0;
+ }
+ FREE_DTOA_LOCK(1);
#else
- p51 = p5->next = mult(p5,p5);
- p51->next = 0;
+ p51 = p5->next = mult(p5,p5);
+ p51->next = 0;
#endif
- }
- p5 = p51;
- }
- return b;
- }
+ }
+ p5 = p51;
+ }
+ return b;
+ }
static Bigint *
lshift
#ifdef KR_headers
- (b, k) Bigint *b; int k;
+ (b, k) Bigint *b; int k;
#else
- (Bigint *b, int k)
+ (Bigint *b, int k)
#endif
{
- int i, k1, n, n1;
- Bigint *b1;
- ULong *x, *x1, *xe, z;
+ int i, k1, n, n1;
+ Bigint *b1;
+ ULong *x, *x1, *xe, z;
#ifdef Pack_32
- n = k >> 5;
+ n = k >> 5;
#else
- n = k >> 4;
-#endif
- k1 = b->k;
- n1 = n + b->wds + 1;
- for(i = b->maxwds; n1 > i; i <<= 1)
- k1++;
- b1 = Balloc(k1);
- x1 = b1->x;
- for(i = 0; i < n; i++)
- *x1++ = 0;
- x = b->x;
- xe = x + b->wds;
+ n = k >> 4;
+#endif
+ k1 = b->k;
+ n1 = n + b->wds + 1;
+ for(i = b->maxwds; n1 > i; i <<= 1)
+ k1++;
+ b1 = Balloc(k1);
+ x1 = b1->x;
+ for(i = 0; i < n; i++)
+ *x1++ = 0;
+ x = b->x;
+ xe = x + b->wds;
#ifdef Pack_32
- if (k &= 0x1f) {
- k1 = 32 - k;
- z = 0;
- do {
- *x1++ = *x << k | z;
- z = *x++ >> k1;
- }
- while(x < xe);
- if ((*x1 = z))
- ++n1;
- }
+ if (k &= 0x1f) {
+ k1 = 32 - k;
+ z = 0;
+ do {
+ *x1++ = *x << k | z;
+ z = *x++ >> k1;
+ }
+ while(x < xe);
+ if ((*x1 = z))
+ ++n1;
+ }
#else
- if (k &= 0xf) {
- k1 = 16 - k;
- z = 0;
- do {
- *x1++ = *x << k & 0xffff | z;
- z = *x++ >> k1;
- }
- while(x < xe);
- if (*x1 = z)
- ++n1;
- }
-#endif
- else do
- *x1++ = *x++;
- while(x < xe);
- b1->wds = n1 - 1;
- Bfree(b);
- return b1;
- }
+ if (k &= 0xf) {
+ k1 = 16 - k;
+ z = 0;
+ do {
+ *x1++ = *x << k & 0xffff | z;
+ z = *x++ >> k1;
+ }
+ while(x < xe);
+ if (*x1 = z)
+ ++n1;
+ }
+#endif
+ else do
+ *x1++ = *x++;
+ while(x < xe);
+ b1->wds = n1 - 1;
+ Bfree(b);
+ return b1;
+ }
static int
cmp
#ifdef KR_headers
- (a, b) Bigint *a, *b;
+ (a, b) Bigint *a, *b;
#else
- (Bigint *a, Bigint *b)
+ (Bigint *a, Bigint *b)
#endif
{
- ULong *xa, *xa0, *xb, *xb0;
- int i, j;
+ ULong *xa, *xa0, *xb, *xb0;
+ int i, j;
- i = a->wds;
- j = b->wds;
+ i = a->wds;
+ j = b->wds;
#ifdef DEBUG
- if (i > 1 && !a->x[i-1])
- Bug("cmp called with a->x[a->wds-1] == 0");
- if (j > 1 && !b->x[j-1])
- Bug("cmp called with b->x[b->wds-1] == 0");
-#endif
- if (i -= j)
- return i;
- xa0 = a->x;
- xa = xa0 + j;
- xb0 = b->x;
- xb = xb0 + j;
- for(;;) {
- if (*--xa != *--xb)
- return *xa < *xb ? -1 : 1;
- if (xa <= xa0)
- break;
- }
- return 0;
- }
+ if (i > 1 && !a->x[i-1])
+ Bug("cmp called with a->x[a->wds-1] == 0");
+ if (j > 1 && !b->x[j-1])
+ Bug("cmp called with b->x[b->wds-1] == 0");
+#endif
+ if (i -= j)
+ return i;
+ xa0 = a->x;
+ xa = xa0 + j;
+ xb0 = b->x;
+ xb = xb0 + j;
+ for(;;) {
+ if (*--xa != *--xb)
+ return *xa < *xb ? -1 : 1;
+ if (xa <= xa0)
+ break;
+ }
+ return 0;
+ }
static Bigint *
diff
#ifdef KR_headers
- (a, b) Bigint *a, *b;
+ (a, b) Bigint *a, *b;
#else
- (Bigint *a, Bigint *b)
+ (Bigint *a, Bigint *b)
#endif
{
- Bigint *c;
- int i, wa, wb;
- ULong *xa, *xae, *xb, *xbe, *xc;
+ Bigint *c;
+ int i, wa, wb;
+ ULong *xa, *xae, *xb, *xbe, *xc;
#ifdef ULLong
- ULLong borrow, y;
+ ULLong borrow, y;
#else
- ULong borrow, y;
+ ULong borrow, y;
#ifdef Pack_32
- ULong z;
-#endif
-#endif
-
- i = cmp(a,b);
- if (!i) {
- c = Balloc(0);
- c->wds = 1;
- c->x[0] = 0;
- return c;
- }
- if (i < 0) {
- c = a;
- a = b;
- b = c;
- i = 1;
- }
- else
- i = 0;
- c = Balloc(a->k);
- c->sign = i;
- wa = a->wds;
- xa = a->x;
- xae = xa + wa;
- wb = b->wds;
- xb = b->x;
- xbe = xb + wb;
- xc = c->x;
- borrow = 0;
+ ULong z;
+#endif
+#endif
+
+ i = cmp(a,b);
+ if (!i) {
+ c = Balloc(0);
+ c->wds = 1;
+ c->x[0] = 0;
+ return c;
+ }
+ if (i < 0) {
+ c = a;
+ a = b;
+ b = c;
+ i = 1;
+ }
+ else
+ i = 0;
+ c = Balloc(a->k);
+ c->sign = i;
+ wa = a->wds;
+ xa = a->x;
+ xae = xa + wa;
+ wb = b->wds;
+ xb = b->x;
+ xbe = xb + wb;
+ xc = c->x;
+ borrow = 0;
#ifdef ULLong
- do {
- y = (ULLong)*xa++ - *xb++ - borrow;
- borrow = y >> 32 & (ULong)1;
- *xc++ = y & FFFFFFFF;
- }
- while(xb < xbe);
- while(xa < xae) {
- y = *xa++ - borrow;
- borrow = y >> 32 & (ULong)1;
- *xc++ = y & FFFFFFFF;
- }
+ do {
+ y = (ULLong)*xa++ - *xb++ - borrow;
+ borrow = y >> 32 & (ULong)1;
+ *xc++ = y & FFFFFFFF;
+ }
+ while(xb < xbe);
+ while(xa < xae) {
+ y = *xa++ - borrow;
+ borrow = y >> 32 & (ULong)1;
+ *xc++ = y & FFFFFFFF;
+ }
#else
#ifdef Pack_32
- do {
- y = (*xa & 0xffff) - (*xb & 0xffff) - borrow;
- borrow = (y & 0x10000) >> 16;
- z = (*xa++ >> 16) - (*xb++ >> 16) - borrow;
- borrow = (z & 0x10000) >> 16;
- Storeinc(xc, z, y);
- }
- while(xb < xbe);
- while(xa < xae) {
- y = (*xa & 0xffff) - borrow;
- borrow = (y & 0x10000) >> 16;
- z = (*xa++ >> 16) - borrow;
- borrow = (z & 0x10000) >> 16;
- Storeinc(xc, z, y);
- }
+ do {
+ y = (*xa & 0xffff) - (*xb & 0xffff) - borrow;
+ borrow = (y & 0x10000) >> 16;
+ z = (*xa++ >> 16) - (*xb++ >> 16) - borrow;
+ borrow = (z & 0x10000) >> 16;
+ Storeinc(xc, z, y);
+ }
+ while(xb < xbe);
+ while(xa < xae) {
+ y = (*xa & 0xffff) - borrow;
+ borrow = (y & 0x10000) >> 16;
+ z = (*xa++ >> 16) - borrow;
+ borrow = (z & 0x10000) >> 16;
+ Storeinc(xc, z, y);
+ }
#else
- do {
- y = *xa++ - *xb++ - borrow;
- borrow = (y & 0x10000) >> 16;
- *xc++ = y & 0xffff;
- }
- while(xb < xbe);
- while(xa < xae) {
- y = *xa++ - borrow;
- borrow = (y & 0x10000) >> 16;
- *xc++ = y & 0xffff;
- }
-#endif
-#endif
- while(!*--xc)
- wa--;
- c->wds = wa;
- return c;
- }
+ do {
+ y = *xa++ - *xb++ - borrow;
+ borrow = (y & 0x10000) >> 16;
+ *xc++ = y & 0xffff;
+ }
+ while(xb < xbe);
+ while(xa < xae) {
+ y = *xa++ - borrow;
+ borrow = (y & 0x10000) >> 16;
+ *xc++ = y & 0xffff;
+ }
+#endif
+#endif
+ while(!*--xc)
+ wa--;
+ c->wds = wa;
+ return c;
+ }
static double
ulp
#ifdef KR_headers
- (x) U *x;
+ (x) U *x;
#else
- (U *x)
+ (U *x)
#endif
{
- Long L;
- U u;
+ Long L;
+ U u;
- L = (word0(x) & Exp_mask) - (P-1)*Exp_msk1;
+ L = (word0(x) & Exp_mask) - (P-1)*Exp_msk1;
#ifndef Avoid_Underflow
#ifndef Sudden_Underflow
- if (L > 0) {
+ if (L > 0) {
#endif
#endif
#ifdef IBM
- L |= Exp_msk1 >> 4;
+ L |= Exp_msk1 >> 4;
#endif
- word0(&u) = L;
- word1(&u) = 0;
+ word0(&u) = L;
+ word1(&u) = 0;
#ifndef Avoid_Underflow
#ifndef Sudden_Underflow
- }
- else {
- L = -L >> Exp_shift;
- if (L < Exp_shift) {
- word0(&u) = 0x80000 >> L;
- word1(&u) = 0;
- }
- else {
- word0(&u) = 0;
- L -= Exp_shift;
- word1(&u) = L >= 31 ? 1 : 1 << 31 - L;
- }
- }
-#endif
-#endif
- return dval(&u);
- }
+ }
+ else {
+ L = -L >> Exp_shift;
+ if (L < Exp_shift) {
+ word0(&u) = 0x80000 >> L;
+ word1(&u) = 0;
+ }
+ else {
+ word0(&u) = 0;
+ L -= Exp_shift;
+ word1(&u) = L >= 31 ? 1 : 1 << 31 - L;
+ }
+ }
+#endif
+#endif
+ return dval(&u);
+ }
static double
b2d
#ifdef KR_headers
- (a, e) Bigint *a; int *e;
+ (a, e) Bigint *a; int *e;
#else
- (Bigint *a, int *e)
+ (Bigint *a, int *e)
#endif
{
- ULong *xa, *xa0, w, y, z;
- int k;
- U d;
+ ULong *xa, *xa0, w, y, z;
+ int k;
+ U d;
#ifdef VAX
- ULong d0, d1;
+ ULong d0, d1;
#else
#define d0 word0(&d)
#define d1 word1(&d)
#endif
- xa0 = a->x;
- xa = xa0 + a->wds;
- y = *--xa;
+ xa0 = a->x;
+ xa = xa0 + a->wds;
+ y = *--xa;
#ifdef DEBUG
- if (!y) Bug("zero y in b2d");
+ if (!y) Bug("zero y in b2d");
#endif
- k = hi0bits(y);
- *e = 32 - k;
+ k = hi0bits(y);
+ *e = 32 - k;
#ifdef Pack_32
- if (k < Ebits) {
- d0 = Exp_1 | y >> (Ebits - k);
- w = xa > xa0 ? *--xa : 0;
- d1 = y << ((32-Ebits) + k) | w >> (Ebits - k);
- goto ret_d;
- }
- z = xa > xa0 ? *--xa : 0;
- if (k -= Ebits) {
- d0 = Exp_1 | y << k | z >> (32 - k);
- y = xa > xa0 ? *--xa : 0;
- d1 = z << k | y >> (32 - k);
- }
- else {
- d0 = Exp_1 | y;
- d1 = z;
- }
+ if (k < Ebits) {
+ d0 = Exp_1 | y >> (Ebits - k);
+ w = xa > xa0 ? *--xa : 0;
+ d1 = y << ((32-Ebits) + k) | w >> (Ebits - k);
+ goto ret_d;
+ }
+ z = xa > xa0 ? *--xa : 0;
+ if (k -= Ebits) {
+ d0 = Exp_1 | y << k | z >> (32 - k);
+ y = xa > xa0 ? *--xa : 0;
+ d1 = z << k | y >> (32 - k);
+ }
+ else {
+ d0 = Exp_1 | y;
+ d1 = z;
+ }
#else
- if (k < Ebits + 16) {
- z = xa > xa0 ? *--xa : 0;
- d0 = Exp_1 | y << k - Ebits | z >> Ebits + 16 - k;
- w = xa > xa0 ? *--xa : 0;
- y = xa > xa0 ? *--xa : 0;
- d1 = z << k + 16 - Ebits | w << k - Ebits | y >> 16 + Ebits - k;
- goto ret_d;
- }
- z = xa > xa0 ? *--xa : 0;
- w = xa > xa0 ? *--xa : 0;
- k -= Ebits + 16;
- d0 = Exp_1 | y << k + 16 | z << k | w >> 16 - k;
- y = xa > xa0 ? *--xa : 0;
- d1 = w << k + 16 | y << k;
+ if (k < Ebits + 16) {
+ z = xa > xa0 ? *--xa : 0;
+ d0 = Exp_1 | y << k - Ebits | z >> Ebits + 16 - k;
+ w = xa > xa0 ? *--xa : 0;
+ y = xa > xa0 ? *--xa : 0;
+ d1 = z << k + 16 - Ebits | w << k - Ebits | y >> 16 + Ebits - k;
+ goto ret_d;
+ }
+ z = xa > xa0 ? *--xa : 0;
+ w = xa > xa0 ? *--xa : 0;
+ k -= Ebits + 16;
+ d0 = Exp_1 | y << k + 16 | z << k | w >> 16 - k;
+ y = xa > xa0 ? *--xa : 0;
+ d1 = w << k + 16 | y << k;
#endif
ret_d:
#ifdef VAX
- word0(&d) = d0 >> 16 | d0 << 16;
- word1(&d) = d1 >> 16 | d1 << 16;
+ word0(&d) = d0 >> 16 | d0 << 16;
+ word1(&d) = d1 >> 16 | d1 << 16;
#else
#undef d0
#undef d1
#endif
- return dval(&d);
- }
+ return dval(&d);
+ }
static Bigint *
d2b
#ifdef KR_headers
- (d, e, bits) U *d; int *e, *bits;
+ (d, e, bits) U *d; int *e, *bits;
#else
- (U *d, int *e, int *bits)
+ (U *d, int *e, int *bits)
#endif
{
- Bigint *b;
- int de, k;
- ULong *x, y, z;
+ Bigint *b;
+ int de, k;
+ ULong *x, y, z;
#ifndef Sudden_Underflow
- int i;
+ int i;
#endif
#ifdef VAX
- ULong d0, d1;
- d0 = word0(d) >> 16 | word0(d) << 16;
- d1 = word1(d) >> 16 | word1(d) << 16;
+ ULong d0, d1;
+ d0 = word0(d) >> 16 | word0(d) << 16;
+ d1 = word1(d) >> 16 | word1(d) << 16;
#else
#define d0 word0(d)
#define d1 word1(d)
#endif
#ifdef Pack_32
- b = Balloc(1);
+ b = Balloc(1);
#else
- b = Balloc(2);
+ b = Balloc(2);
#endif
- x = b->x;
+ x = b->x;
- z = d0 & Frac_mask;
- d0 &= 0x7fffffff; /* clear sign bit, which we ignore */
+ z = d0 & Frac_mask;
+ d0 &= 0x7fffffff; /* clear sign bit, which we ignore */
#ifdef Sudden_Underflow
- de = (int)(d0 >> Exp_shift);
+ de = (int)(d0 >> Exp_shift);
#ifndef IBM
- z |= Exp_msk11;
+ z |= Exp_msk11;
#endif
#else
- if ((de = (int)(d0 >> Exp_shift)))
- z |= Exp_msk1;
+ if ((de = (int)(d0 >> Exp_shift)))
+ z |= Exp_msk1;
#endif
#ifdef Pack_32
- if ((y = d1)) {
- if ((k = lo0bits(&y))) {
- x[0] = y | z << (32 - k);
- z >>= k;
- }
- else
- x[0] = y;
+ if ((y = d1)) {
+ if ((k = lo0bits(&y))) {
+ x[0] = y | z << (32 - k);
+ z >>= k;
+ }
+ else
+ x[0] = y;
#ifndef Sudden_Underflow
- i =
+ i =
#endif
- b->wds = (x[1] = z) ? 2 : 1;
- }
- else {
- k = lo0bits(&z);
- x[0] = z;
+ b->wds = (x[1] = z) ? 2 : 1;
+ }
+ else {
+ k = lo0bits(&z);
+ x[0] = z;
#ifndef Sudden_Underflow
- i =
+ i =
#endif
- b->wds = 1;
- k += 32;
- }
+ b->wds = 1;
+ k += 32;
+ }
#else
- if (y = d1) {
- if (k = lo0bits(&y))
- if (k >= 16) {
- x[0] = y | z << 32 - k & 0xffff;
- x[1] = z >> k - 16 & 0xffff;
- x[2] = z >> k;
- i = 2;
- }
- else {
- x[0] = y & 0xffff;
- x[1] = y >> 16 | z << 16 - k & 0xffff;
- x[2] = z >> k & 0xffff;
- x[3] = z >> k+16;
- i = 3;
- }
- else {
- x[0] = y & 0xffff;
- x[1] = y >> 16;
- x[2] = z & 0xffff;
- x[3] = z >> 16;
- i = 3;
- }
- }
- else {
+ if (y = d1) {
+ if (k = lo0bits(&y))
+ if (k >= 16) {
+ x[0] = y | z << 32 - k & 0xffff;
+ x[1] = z >> k - 16 & 0xffff;
+ x[2] = z >> k;
+ i = 2;
+ }
+ else {
+ x[0] = y & 0xffff;
+ x[1] = y >> 16 | z << 16 - k & 0xffff;
+ x[2] = z >> k & 0xffff;
+ x[3] = z >> k+16;
+ i = 3;
+ }
+ else {
+ x[0] = y & 0xffff;
+ x[1] = y >> 16;
+ x[2] = z & 0xffff;
+ x[3] = z >> 16;
+ i = 3;
+ }
+ }
+ else {
#ifdef DEBUG
- if (!z)
- Bug("Zero passed to d2b");
-#endif
- k = lo0bits(&z);
- if (k >= 16) {
- x[0] = z;
- i = 0;
- }
- else {
- x[0] = z & 0xffff;
- x[1] = z >> 16;
- i = 1;
- }
- k += 32;
- }
- while(!x[i])
- --i;
- b->wds = i + 1;
+ if (!z)
+ Bug("Zero passed to d2b");
+#endif
+ k = lo0bits(&z);
+ if (k >= 16) {
+ x[0] = z;
+ i = 0;
+ }
+ else {
+ x[0] = z & 0xffff;
+ x[1] = z >> 16;
+ i = 1;
+ }
+ k += 32;
+ }
+ while(!x[i])
+ --i;
+ b->wds = i + 1;
#endif
#ifndef Sudden_Underflow
- if (de) {
+ if (de) {
#endif
#ifdef IBM
- *e = (de - Bias - (P-1) << 2) + k;
- *bits = 4*P + 8 - k - hi0bits(word0(d) & Frac_mask);
+ *e = (de - Bias - (P-1) << 2) + k;
+ *bits = 4*P + 8 - k - hi0bits(word0(d) & Frac_mask);
#else
- *e = de - Bias - (P-1) + k;
- *bits = P - k;
+ *e = de - Bias - (P-1) + k;
+ *bits = P - k;
#endif
#ifndef Sudden_Underflow
- }
- else {
- *e = de - Bias - (P-1) + 1 + k;
+ }
+ else {
+ *e = de - Bias - (P-1) + 1 + k;
#ifdef Pack_32
- *bits = 32*i - hi0bits(x[i-1]);
+ *bits = 32*i - hi0bits(x[i-1]);
#else
- *bits = (i+2)*16 - hi0bits(x[i]);
+ *bits = (i+2)*16 - hi0bits(x[i]);
#endif
- }
+ }
#endif
- return b;
- }
+ return b;
+ }
#undef d0
#undef d1
static double
ratio
#ifdef KR_headers
- (a, b) Bigint *a, *b;
+ (a, b) Bigint *a, *b;
#else
- (Bigint *a, Bigint *b)
+ (Bigint *a, Bigint *b)
#endif
{
- U da, db;
- int k, ka, kb;
+ U da, db;
+ int k, ka, kb;
- dval(&da) = b2d(a, &ka);
- dval(&db) = b2d(b, &kb);
+ dval(&da) = b2d(a, &ka);
+ dval(&db) = b2d(b, &kb);
#ifdef Pack_32
- k = ka - kb + 32*(a->wds - b->wds);
+ k = ka - kb + 32*(a->wds - b->wds);
#else
- k = ka - kb + 16*(a->wds - b->wds);
+ k = ka - kb + 16*(a->wds - b->wds);
#endif
#ifdef IBM
- if (k > 0) {
- word0(&da) += (k >> 2)*Exp_msk1;
- if (k &= 3)
- dval(&da) *= 1 << k;
- }
- else {
- k = -k;
- word0(&db) += (k >> 2)*Exp_msk1;
- if (k &= 3)
- dval(&db) *= 1 << k;
- }
+ if (k > 0) {
+ word0(&da) += (k >> 2)*Exp_msk1;
+ if (k &= 3)
+ dval(&da) *= 1 << k;
+ }
+ else {
+ k = -k;
+ word0(&db) += (k >> 2)*Exp_msk1;
+ if (k &= 3)
+ dval(&db) *= 1 << k;
+ }
#else
- if (k > 0)
- word0(&da) += k*Exp_msk1;
- else {
- k = -k;
- word0(&db) += k*Exp_msk1;
- }
+ if (k > 0)
+ word0(&da) += k*Exp_msk1;
+ else {
+ k = -k;
+ word0(&db) += k*Exp_msk1;
+ }
#endif
- return dval(&da) / dval(&db);
- }
+ return dval(&da) / dval(&db);
+ }
static CONST double
tens[] = {
- 1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9,
- 1e10, 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19,
- 1e20, 1e21, 1e22
+ 1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9,
+ 1e10, 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19,
+ 1e20, 1e21, 1e22
#ifdef VAX
- , 1e23, 1e24
+ , 1e23, 1e24
#endif
- };
+ };
static CONST double
#ifdef IEEE_Arith
bigtens[] = { 1e16, 1e32, 1e64, 1e128, 1e256 };
static CONST double tinytens[] = { 1e-16, 1e-32, 1e-64, 1e-128,
#ifdef Avoid_Underflow
- 9007199254740992.*9007199254740992.e-256
- /* = 2^106 * 1e-256 */
+ 9007199254740992.*9007199254740992.e-256
+ /* = 2^106 * 1e-256 */
#else
- 1e-256
+ 1e-256
#endif
- };
+ };
/* The factor of 2^53 in tinytens[4] helps us avoid setting the underflow */
/* flag unnecessarily. It leads to a song and dance at the end of strtod. */
#define Scale_Bit 0x10
@@ -1507,39 +1514,39 @@ static unsigned char hexdig[256];
static void
htinit(unsigned char *h, unsigned char *s, int inc)
{
- int i, j;
- for(i = 0; (j = s[i]) !=0; i++)
- h[j] = i + inc;
- }
+ int i, j;
+ for(i = 0; (j = s[i]) !=0; i++)
+ h[j] = i + inc;
+ }
static void
-hexdig_init(void) /* Use of hexdig_init omitted 20121220 to avoid a */
- /* race condition when multiple threads are used. */
+hexdig_init(void) /* Use of hexdig_init omitted 20121220 to avoid a */
+ /* race condition when multiple threads are used. */
{
#define USC (unsigned char *)
- htinit(hexdig, USC "0123456789", 0x10);
- htinit(hexdig, USC "abcdef", 0x10 + 10);
- htinit(hexdig, USC "ABCDEF", 0x10 + 10);
- }
+ htinit(hexdig, USC "0123456789", 0x10);
+ htinit(hexdig, USC "abcdef", 0x10 + 10);
+ htinit(hexdig, USC "ABCDEF", 0x10 + 10);
+ }
#else
static unsigned char hexdig[256] = {
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 16,17,18,19,20,21,22,23,24,25,0,0,0,0,0,0,
- 0,26,27,28,29,30,31,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,26,27,28,29,30,31,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
- };
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 16,17,18,19,20,21,22,23,24,25,0,0,0,0,0,0,
+ 0,26,27,28,29,30,31,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,26,27,28,29,30,31,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
+ };
#endif
#endif /* } Need_Hexdig */
@@ -1556,90 +1563,90 @@ static unsigned char hexdig[256] = {
static int
match
#ifdef KR_headers
- (sp, t) char **sp, *t;
+ (sp, t) char **sp, *t;
#else
- (const char **sp, const char *t)
+ (const char **sp, const char *t)
#endif
{
- int c, d;
- CONST char *s = *sp;
-
- while((d = *t++)) {
- if ((c = *++s) >= 'A' && c <= 'Z')
- c += 'a' - 'A';
- if (c != d)
- return 0;
- }
- *sp = s + 1;
- return 1;
- }
+ int c, d;
+ CONST char *s = *sp;
+
+ while((d = *t++)) {
+ if ((c = *++s) >= 'A' && c <= 'Z')
+ c += 'a' - 'A';
+ if (c != d)
+ return 0;
+ }
+ *sp = s + 1;
+ return 1;
+ }
#ifndef No_Hex_NaN
static void
hexnan
#ifdef KR_headers
- (rvp, sp) U *rvp; CONST char **sp;
+ (rvp, sp) U *rvp; CONST char **sp;
#else
- (U *rvp, const char **sp)
+ (U *rvp, const char **sp)
#endif
{
- ULong c, x[2];
- CONST char *s;
- int c1, havedig, udx0, xshift;
-
- /**** if (!hexdig['0']) hexdig_init(); ****/
- x[0] = x[1] = 0;
- havedig = xshift = 0;
- udx0 = 1;
- s = *sp;
- /* allow optional initial 0x or 0X */
- while((c = *(CONST unsigned char*)(s+1)) && c <= ' ')
- ++s;
- if (s[1] == '0' && (s[2] == 'x' || s[2] == 'X'))
- s += 2;
- while((c = *(CONST unsigned char*)++s)) {
- if ((c1 = hexdig[c]))
- c = c1 & 0xf;
- else if (c <= ' ') {
- if (udx0 && havedig) {
- udx0 = 0;
- xshift = 1;
- }
- continue;
- }
+ ULong c, x[2];
+ CONST char *s;
+ int c1, havedig, udx0, xshift;
+
+ /**** if (!hexdig['0']) hexdig_init(); ****/
+ x[0] = x[1] = 0;
+ havedig = xshift = 0;
+ udx0 = 1;
+ s = *sp;
+ /* allow optional initial 0x or 0X */
+ while((c = *(CONST unsigned char*)(s+1)) && c <= ' ')
+ ++s;
+ if (s[1] == '0' && (s[2] == 'x' || s[2] == 'X'))
+ s += 2;
+ while((c = *(CONST unsigned char*)++s)) {
+ if ((c1 = hexdig[c]))
+ c = c1 & 0xf;
+ else if (c <= ' ') {
+ if (udx0 && havedig) {
+ udx0 = 0;
+ xshift = 1;
+ }
+ continue;
+ }
#ifdef GDTOA_NON_PEDANTIC_NANCHECK
- else if (/*(*/ c == ')' && havedig) {
- *sp = s + 1;
- break;
- }
- else
- return; /* invalid form: don't change *sp */
+ else if (/*(*/ c == ')' && havedig) {
+ *sp = s + 1;
+ break;
+ }
+ else
+ return; /* invalid form: don't change *sp */
#else
- else {
- do {
- if (/*(*/ c == ')') {
- *sp = s + 1;
- break;
- }
- } while((c = *++s));
- break;
- }
-#endif
- havedig = 1;
- if (xshift) {
- xshift = 0;
- x[0] = x[1];
- x[1] = 0;
- }
- if (udx0)
- x[0] = (x[0] << 4) | (x[1] >> 28);
- x[1] = (x[1] << 4) | c;
- }
- if ((x[0] &= 0xfffff) || x[1]) {
- word0(rvp) = Exp_mask | x[0];
- word1(rvp) = x[1];
- }
- }
+ else {
+ do {
+ if (/*(*/ c == ')') {
+ *sp = s + 1;
+ break;
+ }
+ } while((c = *++s));
+ break;
+ }
+#endif
+ havedig = 1;
+ if (xshift) {
+ xshift = 0;
+ x[0] = x[1];
+ x[1] = 0;
+ }
+ if (udx0)
+ x[0] = (x[0] << 4) | (x[1] >> 28);
+ x[1] = (x[1] << 4) | c;
+ }
+ if ((x[0] &= 0xfffff) || x[1]) {
+ word0(rvp) = Exp_mask | x[0];
+ word1(rvp) = x[1];
+ }
+ }
#endif /*No_Hex_NaN*/
#endif /* INFNAN_CHECK */
@@ -1661,29 +1668,29 @@ increment(b) Bigint *b;
increment(Bigint *b)
#endif
{
- ULong *x, *xe;
- Bigint *b1;
-
- x = b->x;
- xe = x + b->wds;
- do {
- if (*x < (ULong)0xffffffffL) {
- ++*x;
- return b;
- }
- *x++ = 0;
- } while(x < xe);
- {
- if (b->wds >= b->maxwds) {
- b1 = Balloc(b->k+1);
- Bcopy(b1,b);
- Bfree(b);
- b = b1;
- }
- b->x[b->wds++] = 1;
- }
- return b;
- }
+ ULong *x, *xe;
+ Bigint *b1;
+
+ x = b->x;
+ xe = x + b->wds;
+ do {
+ if (*x < (ULong)0xffffffffL) {
+ ++*x;
+ return b;
+ }
+ *x++ = 0;
+ } while(x < xe);
+ {
+ if (b->wds >= b->maxwds) {
+ b1 = Balloc(b->k+1);
+ Bcopy(b1,b);
+ Bfree(b);
+ b = b1;
+ }
+ b->x[b->wds++] = 1;
+ }
+ return b;
+ }
#endif /*}*/
@@ -1696,31 +1703,31 @@ rshift(b, k) Bigint *b; int k;
rshift(Bigint *b, int k)
#endif
{
- ULong *x, *x1, *xe, y;
- int n;
-
- x = x1 = b->x;
- n = k >> kshift;
- if (n < b->wds) {
- xe = x + b->wds;
- x += n;
- if (k &= kmask) {
- n = 32 - k;
- y = *x++ >> k;
- while(x < xe) {
- *x1++ = (y | (*x << n)) & 0xffffffff;
- y = *x++ >> k;
- }
- if ((*x1 = y) !=0)
- x1++;
- }
- else
- while(x < xe)
- *x1++ = *x++;
- }
- if ((b->wds = x1 - b->x) == 0)
- b->x[0] = 0;
- }
+ ULong *x, *x1, *xe, y;
+ int n;
+
+ x = x1 = b->x;
+ n = k >> kshift;
+ if (n < b->wds) {
+ xe = x + b->wds;
+ x += n;
+ if (k &= kmask) {
+ n = 32 - k;
+ y = *x++ >> k;
+ while(x < xe) {
+ *x1++ = (y | (*x << n)) & 0xffffffff;
+ y = *x++ >> k;
+ }
+ if ((*x1 = y) !=0)
+ x1++;
+ }
+ else
+ while(x < xe)
+ *x1++ = *x++;
+ }
+ if ((b->wds = x1 - b->x) == 0)
+ b->x[0] = 0;
+ }
static ULong
#ifdef KR_headers
@@ -1729,394 +1736,394 @@ any_on(b, k) Bigint *b; int k;
any_on(Bigint *b, int k)
#endif
{
- int n, nwds;
- ULong *x, *x0, x1, x2;
-
- x = b->x;
- nwds = b->wds;
- n = k >> kshift;
- if (n > nwds)
- n = nwds;
- else if (n < nwds && (k &= kmask)) {
- x1 = x2 = x[n];
- x1 >>= k;
- x1 <<= k;
- if (x1 != x2)
- return 1;
- }
- x0 = x;
- x += n;
- while(x > x0)
- if (*--x)
- return 1;
- return 0;
- }
-
-enum { /* rounding values: same as FLT_ROUNDS */
- Round_zero = 0,
- Round_near = 1,
- Round_up = 2,
- Round_down = 3
- };
+ int n, nwds;
+ ULong *x, *x0, x1, x2;
+
+ x = b->x;
+ nwds = b->wds;
+ n = k >> kshift;
+ if (n > nwds)
+ n = nwds;
+ else if (n < nwds && (k &= kmask)) {
+ x1 = x2 = x[n];
+ x1 >>= k;
+ x1 <<= k;
+ if (x1 != x2)
+ return 1;
+ }
+ x0 = x;
+ x += n;
+ while(x > x0)
+ if (*--x)
+ return 1;
+ return 0;
+ }
+
+enum { /* rounding values: same as FLT_ROUNDS */
+ Round_zero = 0,
+ Round_near = 1,
+ Round_up = 2,
+ Round_down = 3
+ };
void
#ifdef KR_headers
gethex(sp, rvp, rounding, sign)
- CONST char **sp; U *rvp; int rounding, sign;
+ CONST char **sp; U *rvp; int rounding, sign;
#else
gethex( CONST char **sp, U *rvp, int rounding, int sign)
#endif
{
- Bigint *b;
- CONST unsigned char *decpt, *s0, *s, *s1;
- Long e, e1;
- ULong L, lostbits, *x;
- int big, denorm, esign, havedig, k, n, nbits, up, zret;
+ Bigint *b;
+ CONST unsigned char *decpt, *s0, *s, *s1;
+ Long e, e1;
+ ULong L, lostbits, *x;
+ int big, denorm, esign, havedig, k, n, nbits, up, zret;
#ifdef IBM
- int j;
+ int j;
#endif
- enum {
+ enum {
#ifdef IEEE_Arith /*{{*/
- emax = 0x7fe - Bias - P + 1,
- emin = Emin - P + 1
+ emax = 0x7fe - Bias - P + 1,
+ emin = Emin - P + 1
#else /*}{*/
- emin = Emin - P,
+ emin = Emin - P,
#ifdef VAX
- emax = 0x7ff - Bias - P + 1
+ emax = 0x7ff - Bias - P + 1
#endif
#ifdef IBM
- emax = 0x7f - Bias - P
+ emax = 0x7f - Bias - P
#endif
#endif /*}}*/
- };
+ };
#ifdef USE_LOCALE
- int i;
+ int i;
#ifdef NO_LOCALE_CACHE
- const unsigned char *decimalpoint = (unsigned char*)
- localeconv()->decimal_point;
+ const unsigned char *decimalpoint = (unsigned char*)
+ localeconv()->decimal_point;
#else
- const unsigned char *decimalpoint;
- static unsigned char *decimalpoint_cache;
- if (!(s0 = decimalpoint_cache)) {
- s0 = (unsigned char*)localeconv()->decimal_point;
- if ((decimalpoint_cache = (unsigned char*)
- MALLOC(strlen((CONST char*)s0) + 1))) {
- strcpy((char*)decimalpoint_cache, (CONST char*)s0);
- s0 = decimalpoint_cache;
- }
- }
- decimalpoint = s0;
-#endif
-#endif
-
- /**** if (!hexdig['0']) hexdig_init(); ****/
- havedig = 0;
- s0 = *(CONST unsigned char **)sp + 2;
- while(s0[havedig] == '0')
- havedig++;
- s0 += havedig;
- s = s0;
- decpt = 0;
- zret = 0;
- e = 0;
- if (hexdig[*s])
- havedig++;
- else {
- zret = 1;
+ const unsigned char *decimalpoint;
+ static unsigned char *decimalpoint_cache;
+ if (!(s0 = decimalpoint_cache)) {
+ s0 = (unsigned char*)localeconv()->decimal_point;
+ if ((decimalpoint_cache = (unsigned char*)
+ MALLOC(strlen((CONST char*)s0) + 1))) {
+ strcpy((char*)decimalpoint_cache, (CONST char*)s0);
+ s0 = decimalpoint_cache;
+ }
+ }
+ decimalpoint = s0;
+#endif
+#endif
+
+ /**** if (!hexdig['0']) hexdig_init(); ****/
+ havedig = 0;
+ s0 = *(CONST unsigned char **)sp + 2;
+ while(s0[havedig] == '0')
+ havedig++;
+ s0 += havedig;
+ s = s0;
+ decpt = 0;
+ zret = 0;
+ e = 0;
+ if (hexdig[*s])
+ havedig++;
+ else {
+ zret = 1;
#ifdef USE_LOCALE
- for(i = 0; decimalpoint[i]; ++i) {
- if (s[i] != decimalpoint[i])
- goto pcheck;
- }
- decpt = s += i;
+ for(i = 0; decimalpoint[i]; ++i) {
+ if (s[i] != decimalpoint[i])
+ goto pcheck;
+ }
+ decpt = s += i;
#else
- if (*s != '.')
- goto pcheck;
- decpt = ++s;
-#endif
- if (!hexdig[*s])
- goto pcheck;
- while(*s == '0')
- s++;
- if (hexdig[*s])
- zret = 0;
- havedig = 1;
- s0 = s;
- }
- while(hexdig[*s])
- s++;
+ if (*s != '.')
+ goto pcheck;
+ decpt = ++s;
+#endif
+ if (!hexdig[*s])
+ goto pcheck;
+ while(*s == '0')
+ s++;
+ if (hexdig[*s])
+ zret = 0;
+ havedig = 1;
+ s0 = s;
+ }
+ while(hexdig[*s])
+ s++;
#ifdef USE_LOCALE
- if (*s == *decimalpoint && !decpt) {
- for(i = 1; decimalpoint[i]; ++i) {
- if (s[i] != decimalpoint[i])
- goto pcheck;
- }
- decpt = s += i;
+ if (*s == *decimalpoint && !decpt) {
+ for(i = 1; decimalpoint[i]; ++i) {
+ if (s[i] != decimalpoint[i])
+ goto pcheck;
+ }
+ decpt = s += i;
#else
- if (*s == '.' && !decpt) {
- decpt = ++s;
-#endif
- while(hexdig[*s])
- s++;
- }/*}*/
- if (decpt)
- e = -(((Long)(s-decpt)) << 2);
+ if (*s == '.' && !decpt) {
+ decpt = ++s;
+#endif
+ while(hexdig[*s])
+ s++;
+ }/*}*/
+ if (decpt)
+ e = -(((Long)(s-decpt)) << 2);
pcheck:
- s1 = s;
- big = esign = 0;
- switch(*s) {
- case 'p':
- case 'P':
- switch(*++s) {
- case '-':
- esign = 1;
- /* no break */
- case '+':
- s++;
- }
- if ((n = hexdig[*s]) == 0 || n > 0x19) {
- s = s1;
- break;
- }
- e1 = n - 0x10;
- while((n = hexdig[*++s]) !=0 && n <= 0x19) {
- if (e1 & 0xf8000000)
- big = 1;
- e1 = 10*e1 + n - 0x10;
- }
- if (esign)
- e1 = -e1;
- e += e1;
- }
- *sp = (char*)s;
- if (!havedig)
- *sp = (char*)s0 - 1;
- if (zret)
- goto retz1;
- if (big) {
- if (esign) {
+ s1 = s;
+ big = esign = 0;
+ switch(*s) {
+ case 'p':
+ case 'P':
+ switch(*++s) {
+ case '-':
+ esign = 1;
+ /* no break */
+ case '+':
+ s++;
+ }
+ if ((n = hexdig[*s]) == 0 || n > 0x19) {
+ s = s1;
+ break;
+ }
+ e1 = n - 0x10;
+ while((n = hexdig[*++s]) !=0 && n <= 0x19) {
+ if (e1 & 0xf8000000)
+ big = 1;
+ e1 = 10*e1 + n - 0x10;
+ }
+ if (esign)
+ e1 = -e1;
+ e += e1;
+ }
+ *sp = (const char*)s; // Ren/C: fix cast away of const
+ if (!havedig)
+ *sp = (const char*)s0 - 1; // Ren/C: fix cast away of const
+ if (zret)
+ goto retz1;
+ if (big) {
+ if (esign) {
#ifdef IEEE_Arith
- switch(rounding) {
- case Round_up:
- if (sign)
- break;
- goto ret_tiny;
- case Round_down:
- if (!sign)
- break;
- goto ret_tiny;
- }
-#endif
- goto retz;
+ switch(rounding) {
+ case Round_up:
+ if (sign)
+ break;
+ goto ret_tiny;
+ case Round_down:
+ if (!sign)
+ break;
+ goto ret_tiny;
+ }
+#endif
+ goto retz;
#ifdef IEEE_Arith
ret_tiny:
#ifndef NO_ERRNO
- errno = ERANGE;
+ errno = ERANGE;
#endif
- word0(rvp) = 0;
- word1(rvp) = 1;
- return;
+ word0(rvp) = 0;
+ word1(rvp) = 1;
+ return;
#endif /* IEEE_Arith */
- }
- switch(rounding) {
- case Round_near:
- goto ovfl1;
- case Round_up:
- if (!sign)
- goto ovfl1;
- goto ret_big;
- case Round_down:
- if (sign)
- goto ovfl1;
- goto ret_big;
- }
+ }
+ switch(rounding) {
+ case Round_near:
+ goto ovfl1;
+ case Round_up:
+ if (!sign)
+ goto ovfl1;
+ goto ret_big;
+ case Round_down:
+ if (sign)
+ goto ovfl1;
+ goto ret_big;
+ }
ret_big:
- word0(rvp) = Big0;
- word1(rvp) = Big1;
- return;
- }
- n = s1 - s0 - 1;
- for(k = 0; n > (1 << (kshift-2)) - 1; n >>= 1)
- k++;
- b = Balloc(k);
- x = b->x;
- n = 0;
- L = 0;
+ word0(rvp) = Big0;
+ word1(rvp) = Big1;
+ return;
+ }
+ n = s1 - s0 - 1;
+ for(k = 0; n > (1 << (kshift-2)) - 1; n >>= 1)
+ k++;
+ b = Balloc(k);
+ x = b->x;
+ n = 0;
+ L = 0;
#ifdef USE_LOCALE
- for(i = 0; decimalpoint[i+1]; ++i);
+ for(i = 0; decimalpoint[i+1]; ++i);
#endif
- while(s1 > s0) {
+ while(s1 > s0) {
#ifdef USE_LOCALE
- if (*--s1 == decimalpoint[i]) {
- s1 -= i;
- continue;
- }
+ if (*--s1 == decimalpoint[i]) {
+ s1 -= i;
+ continue;
+ }
#else
- if (*--s1 == '.')
- continue;
-#endif
- if (n == ULbits) {
- *x++ = L;
- L = 0;
- n = 0;
- }
- L |= (hexdig[*s1] & 0x0f) << n;
- n += 4;
- }
- *x++ = L;
- b->wds = n = x - b->x;
- n = ULbits*n - hi0bits(L);
- nbits = Nbits;
- lostbits = 0;
- x = b->x;
- if (n > nbits) {
- n -= nbits;
- if (any_on(b,n)) {
- lostbits = 1;
- k = n - 1;
- if (x[k>>kshift] & 1 << (k & kmask)) {
- lostbits = 2;
- if (k > 0 && any_on(b,k))
- lostbits = 3;
- }
- }
- rshift(b, n);
- e += n;
- }
- else if (n < nbits) {
- n = nbits - n;
- b = lshift(b, n);
- e -= n;
- x = b->x;
- }
- if (e > Emax) {
+ if (*--s1 == '.')
+ continue;
+#endif
+ if (n == ULbits) {
+ *x++ = L;
+ L = 0;
+ n = 0;
+ }
+ L |= (hexdig[*s1] & 0x0f) << n;
+ n += 4;
+ }
+ *x++ = L;
+ b->wds = n = x - b->x;
+ n = ULbits*n - hi0bits(L);
+ nbits = Nbits;
+ lostbits = 0;
+ x = b->x;
+ if (n > nbits) {
+ n -= nbits;
+ if (any_on(b,n)) {
+ lostbits = 1;
+ k = n - 1;
+ if (x[k>>kshift] & 1 << (k & kmask)) {
+ lostbits = 2;
+ if (k > 0 && any_on(b,k))
+ lostbits = 3;
+ }
+ }
+ rshift(b, n);
+ e += n;
+ }
+ else if (n < nbits) {
+ n = nbits - n;
+ b = lshift(b, n);
+ e -= n;
+ x = b->x;
+ }
+ if (e > Emax) {
ovfl:
- Bfree(b);
+ Bfree(b);
ovfl1:
#ifndef NO_ERRNO
- errno = ERANGE;
-#endif
- word0(rvp) = Exp_mask;
- word1(rvp) = 0;
- return;
- }
- denorm = 0;
- if (e < emin) {
- denorm = 1;
- n = emin - e;
- if (n >= nbits) {
+ errno = ERANGE;
+#endif
+ word0(rvp) = Exp_mask;
+ word1(rvp) = 0;
+ return;
+ }
+ denorm = 0;
+ if (e < emin) {
+ denorm = 1;
+ n = emin - e;
+ if (n >= nbits) {
#ifdef IEEE_Arith /*{*/
- switch (rounding) {
- case Round_near:
- if (n == nbits && (n < 2 || any_on(b,n-1)))
- goto ret_tiny;
- break;
- case Round_up:
- if (!sign)
- goto ret_tiny;
- break;
- case Round_down:
- if (sign)
- goto ret_tiny;
- }
+ switch (rounding) {
+ case Round_near:
+ if (n == nbits && (n < 2 || any_on(b,n-1)))
+ goto ret_tiny;
+ break;
+ case Round_up:
+ if (!sign)
+ goto ret_tiny;
+ break;
+ case Round_down:
+ if (sign)
+ goto ret_tiny;
+ }
#endif /* } IEEE_Arith */
- Bfree(b);
+ Bfree(b);
retz:
#ifndef NO_ERRNO
- errno = ERANGE;
+ errno = ERANGE;
#endif
retz1:
- rvp->d = 0.;
- return;
- }
- k = n - 1;
- if (lostbits)
- lostbits = 1;
- else if (k > 0)
- lostbits = any_on(b,k);
- if (x[k>>kshift] & 1 << (k & kmask))
- lostbits |= 2;
- nbits -= n;
- rshift(b,n);
- e = emin;
- }
- if (lostbits) {
- up = 0;
- switch(rounding) {
- case Round_zero:
- break;
- case Round_near:
- if (lostbits & 2
- && (lostbits & 1) | (x[0] & 1))
- up = 1;
- break;
- case Round_up:
- up = 1 - sign;
- break;
- case Round_down:
- up = sign;
- }
- if (up) {
- k = b->wds;
- b = increment(b);
- x = b->x;
- if (denorm) {
+ rvp->d = 0.;
+ return;
+ }
+ k = n - 1;
+ if (lostbits)
+ lostbits = 1;
+ else if (k > 0)
+ lostbits = any_on(b,k);
+ if (x[k>>kshift] & 1 << (k & kmask))
+ lostbits |= 2;
+ nbits -= n;
+ rshift(b,n);
+ e = emin;
+ }
+ if (lostbits) {
+ up = 0;
+ switch(rounding) {
+ case Round_zero:
+ break;
+ case Round_near:
+ if (lostbits & 2
+ && (lostbits & 1) | (x[0] & 1))
+ up = 1;
+ break;
+ case Round_up:
+ up = 1 - sign;
+ break;
+ case Round_down:
+ up = sign;
+ }
+ if (up) {
+ k = b->wds;
+ b = increment(b);
+ x = b->x;
+ if (denorm) {
#if 0
- if (nbits == Nbits - 1
- && x[nbits >> kshift] & 1 << (nbits & kmask))
- denorm = 0; /* not currently used */
-#endif
- }
- else if (b->wds > k
- || ((n = nbits & kmask) !=0
- && hi0bits(x[k-1]) < 32-n)) {
- rshift(b,1);
- if (++e > Emax)
- goto ovfl;
- }
- }
- }
+ if (nbits == Nbits - 1
+ && x[nbits >> kshift] & 1 << (nbits & kmask))
+ denorm = 0; /* not currently used */
+#endif
+ }
+ else if (b->wds > k
+ || ((n = nbits & kmask) !=0
+ && hi0bits(x[k-1]) < 32-n)) {
+ rshift(b,1);
+ if (++e > Emax)
+ goto ovfl;
+ }
+ }
+ }
#ifdef IEEE_Arith
- if (denorm)
- word0(rvp) = b->wds > 1 ? b->x[1] & ~0x100000 : 0;
- else
- word0(rvp) = (b->x[1] & ~0x100000) | ((e + 0x3ff + 52) << 20);
- word1(rvp) = b->x[0];
+ if (denorm)
+ word0(rvp) = b->wds > 1 ? b->x[1] & ~0x100000 : 0;
+ else
+ word0(rvp) = (b->x[1] & ~0x100000) | ((e + 0x3ff + 52) << 20);
+ word1(rvp) = b->x[0];
#endif
#ifdef IBM
- if ((j = e & 3)) {
- k = b->x[0] & ((1 << j) - 1);
- rshift(b,j);
- if (k) {
- switch(rounding) {
- case Round_up:
- if (!sign)
- increment(b);
- break;
- case Round_down:
- if (sign)
- increment(b);
- break;
- case Round_near:
- j = 1 << (j-1);
- if (k & j && ((k & (j-1)) | lostbits))
- increment(b);
- }
- }
- }
- e >>= 2;
- word0(rvp) = b->x[1] | ((e + 65 + 13) << 24);
- word1(rvp) = b->x[0];
+ if ((j = e & 3)) {
+ k = b->x[0] & ((1 << j) - 1);
+ rshift(b,j);
+ if (k) {
+ switch(rounding) {
+ case Round_up:
+ if (!sign)
+ increment(b);
+ break;
+ case Round_down:
+ if (sign)
+ increment(b);
+ break;
+ case Round_near:
+ j = 1 << (j-1);
+ if (k & j && ((k & (j-1)) | lostbits))
+ increment(b);
+ }
+ }
+ }
+ e >>= 2;
+ word0(rvp) = b->x[1] | ((e + 65 + 13) << 24);
+ word1(rvp) = b->x[0];
#endif
#ifdef VAX
- /* The next two lines ignore swap of low- and high-order 2 bytes. */
- /* word0(rvp) = (b->x[1] & ~0x800000) | ((e + 129 + 55) << 23); */
- /* word1(rvp) = b->x[0]; */
- word0(rvp) = ((b->x[1] & ~0x800000) >> 16) | ((e + 129 + 55) << 7) | (b->x[1] << 16);
- word1(rvp) = (b->x[0] >> 16) | (b->x[0] << 16);
-#endif
- Bfree(b);
- }
+ /* The next two lines ignore swap of low- and high-order 2 bytes. */
+ /* word0(rvp) = (b->x[1] & ~0x800000) | ((e + 129 + 55) << 23); */
+ /* word1(rvp) = b->x[0]; */
+ word0(rvp) = ((b->x[1] & ~0x800000) >> 16) | ((e + 129 + 55) << 7) | (b->x[1] << 16);
+ word1(rvp) = (b->x[0] >> 16) | (b->x[0] << 16);
+#endif
+ Bfree(b);
+ }
#endif /*!NO_HEX_FP}*/
static int
@@ -2126,1440 +2133,1440 @@ dshift(b, p2) Bigint *b; int p2;
dshift(Bigint *b, int p2)
#endif
{
- int rv = hi0bits(b->x[b->wds-1]) - 4;
- if (p2 > 0)
- rv -= p2;
- return rv & kmask;
- }
+ int rv = hi0bits(b->x[b->wds-1]) - 4;
+ if (p2 > 0)
+ rv -= p2;
+ return rv & kmask;
+ }
static int
quorem
#ifdef KR_headers
- (b, S) Bigint *b, *S;
+ (b, S) Bigint *b, *S;
#else
- (Bigint *b, Bigint *S)
+ (Bigint *b, Bigint *S)
#endif
{
- int n;
- ULong *bx, *bxe, q, *sx, *sxe;
+ int n;
+ ULong *bx, *bxe, q, *sx, *sxe;
#ifdef ULLong
- ULLong borrow, carry, y, ys;
+ ULLong borrow, carry, y, ys;
#else
- ULong borrow, carry, y, ys;
+ ULong borrow, carry, y, ys;
#ifdef Pack_32
- ULong si, z, zs;
+ ULong si, z, zs;
#endif
#endif
- n = S->wds;
+ n = S->wds;
#ifdef DEBUG
- /*debug*/ if (b->wds > n)
- /*debug*/ Bug("oversize b in quorem");
-#endif
- if (b->wds < n)
- return 0;
- sx = S->x;
- sxe = sx + --n;
- bx = b->x;
- bxe = bx + n;
- q = *bxe / (*sxe + 1); /* ensure q <= true quotient */
+ /*debug*/ if (b->wds > n)
+ /*debug*/ Bug("oversize b in quorem");
+#endif
+ if (b->wds < n)
+ return 0;
+ sx = S->x;
+ sxe = sx + --n;
+ bx = b->x;
+ bxe = bx + n;
+ q = *bxe / (*sxe + 1); /* ensure q <= true quotient */
#ifdef DEBUG
#ifdef NO_STRTOD_BIGCOMP
- /*debug*/ if (q > 9)
+ /*debug*/ if (q > 9)
#else
- /* An oversized q is possible when quorem is called from bigcomp and */
- /* the input is near, e.g., twice the smallest denormalized number. */
- /*debug*/ if (q > 15)
+ /* An oversized q is possible when quorem is called from bigcomp and */
+ /* the input is near, e.g., twice the smallest denormalized number. */
+ /*debug*/ if (q > 15)
#endif
- /*debug*/ Bug("oversized quotient in quorem");
+ /*debug*/ Bug("oversized quotient in quorem");
#endif
- if (q) {
- borrow = 0;
- carry = 0;
- do {
+ if (q) {
+ borrow = 0;
+ carry = 0;
+ do {
#ifdef ULLong
- ys = *sx++ * (ULLong)q + carry;
- carry = ys >> 32;
- y = *bx - (ys & FFFFFFFF) - borrow;
- borrow = y >> 32 & (ULong)1;
- *bx++ = y & FFFFFFFF;
+ ys = *sx++ * (ULLong)q + carry;
+ carry = ys >> 32;
+ y = *bx - (ys & FFFFFFFF) - borrow;
+ borrow = y >> 32 & (ULong)1;
+ *bx++ = y & FFFFFFFF;
#else
#ifdef Pack_32
- si = *sx++;
- ys = (si & 0xffff) * q + carry;
- zs = (si >> 16) * q + (ys >> 16);
- carry = zs >> 16;
- y = (*bx & 0xffff) - (ys & 0xffff) - borrow;
- borrow = (y & 0x10000) >> 16;
- z = (*bx >> 16) - (zs & 0xffff) - borrow;
- borrow = (z & 0x10000) >> 16;
- Storeinc(bx, z, y);
+ si = *sx++;
+ ys = (si & 0xffff) * q + carry;
+ zs = (si >> 16) * q + (ys >> 16);
+ carry = zs >> 16;
+ y = (*bx & 0xffff) - (ys & 0xffff) - borrow;
+ borrow = (y & 0x10000) >> 16;
+ z = (*bx >> 16) - (zs & 0xffff) - borrow;
+ borrow = (z & 0x10000) >> 16;
+ Storeinc(bx, z, y);
#else
- ys = *sx++ * q + carry;
- carry = ys >> 16;
- y = *bx - (ys & 0xffff) - borrow;
- borrow = (y & 0x10000) >> 16;
- *bx++ = y & 0xffff;
-#endif
-#endif
- }
- while(sx <= sxe);
- if (!*bxe) {
- bx = b->x;
- while(--bxe > bx && !*bxe)
- --n;
- b->wds = n;
- }
- }
- if (cmp(b, S) >= 0) {
- q++;
- borrow = 0;
- carry = 0;
- bx = b->x;
- sx = S->x;
- do {
+ ys = *sx++ * q + carry;
+ carry = ys >> 16;
+ y = *bx - (ys & 0xffff) - borrow;
+ borrow = (y & 0x10000) >> 16;
+ *bx++ = y & 0xffff;
+#endif
+#endif
+ }
+ while(sx <= sxe);
+ if (!*bxe) {
+ bx = b->x;
+ while(--bxe > bx && !*bxe)
+ --n;
+ b->wds = n;
+ }
+ }
+ if (cmp(b, S) >= 0) {
+ q++;
+ borrow = 0;
+ carry = 0;
+ bx = b->x;
+ sx = S->x;
+ do {
#ifdef ULLong
- ys = *sx++ + carry;
- carry = ys >> 32;
- y = *bx - (ys & FFFFFFFF) - borrow;
- borrow = y >> 32 & (ULong)1;
- *bx++ = y & FFFFFFFF;
+ ys = *sx++ + carry;
+ carry = ys >> 32;
+ y = *bx - (ys & FFFFFFFF) - borrow;
+ borrow = y >> 32 & (ULong)1;
+ *bx++ = y & FFFFFFFF;
#else
#ifdef Pack_32
- si = *sx++;
- ys = (si & 0xffff) + carry;
- zs = (si >> 16) + (ys >> 16);
- carry = zs >> 16;
- y = (*bx & 0xffff) - (ys & 0xffff) - borrow;
- borrow = (y & 0x10000) >> 16;
- z = (*bx >> 16) - (zs & 0xffff) - borrow;
- borrow = (z & 0x10000) >> 16;
- Storeinc(bx, z, y);
+ si = *sx++;
+ ys = (si & 0xffff) + carry;
+ zs = (si >> 16) + (ys >> 16);
+ carry = zs >> 16;
+ y = (*bx & 0xffff) - (ys & 0xffff) - borrow;
+ borrow = (y & 0x10000) >> 16;
+ z = (*bx >> 16) - (zs & 0xffff) - borrow;
+ borrow = (z & 0x10000) >> 16;
+ Storeinc(bx, z, y);
#else
- ys = *sx++ + carry;
- carry = ys >> 16;
- y = *bx - (ys & 0xffff) - borrow;
- borrow = (y & 0x10000) >> 16;
- *bx++ = y & 0xffff;
-#endif
-#endif
- }
- while(sx <= sxe);
- bx = b->x;
- bxe = bx + n;
- if (!*bxe) {
- while(--bxe > bx && !*bxe)
- --n;
- b->wds = n;
- }
- }
- return q;
- }
+ ys = *sx++ + carry;
+ carry = ys >> 16;
+ y = *bx - (ys & 0xffff) - borrow;
+ borrow = (y & 0x10000) >> 16;
+ *bx++ = y & 0xffff;
+#endif
+#endif
+ }
+ while(sx <= sxe);
+ bx = b->x;
+ bxe = bx + n;
+ if (!*bxe) {
+ while(--bxe > bx && !*bxe)
+ --n;
+ b->wds = n;
+ }
+ }
+ return q;
+ }
#if defined(Avoid_Underflow) || !defined(NO_STRTOD_BIGCOMP) /*{*/
static double
sulp
#ifdef KR_headers
- (x, bc) U *x; BCinfo *bc;
+ (x, bc) U *x; BCinfo *bc;
#else
- (U *x, BCinfo *bc)
+ (U *x, BCinfo *bc)
#endif
{
- U u;
- double rv;
- int i;
-
- rv = ulp(x);
- if (!bc->scale || (i = 2*P + 1 - ((word0(x) & Exp_mask) >> Exp_shift)) <= 0)
- return rv; /* Is there an example where i <= 0 ? */
- word0(&u) = Exp_1 + (i << Exp_shift);
- word1(&u) = 0;
- return rv * u.d;
- }
+ U u;
+ double rv;
+ int i;
+
+ rv = ulp(x);
+ if (!bc->scale || (i = 2*P + 1 - ((word0(x) & Exp_mask) >> Exp_shift)) <= 0)
+ return rv; /* Is there an example where i <= 0 ? */
+ word0(&u) = Exp_1 + (i << Exp_shift);
+ word1(&u) = 0;
+ return rv * u.d;
+ }
#endif /*}*/
#ifndef NO_STRTOD_BIGCOMP
static void
bigcomp
#ifdef KR_headers
- (rv, s0, bc)
- U *rv; CONST char *s0; BCinfo *bc;
+ (rv, s0, bc)
+ U *rv; CONST char *s0; BCinfo *bc;
#else
- (U *rv, const char *s0, BCinfo *bc)
+ (U *rv, const char *s0, BCinfo *bc)
#endif
{
- Bigint *b, *d;
- int b2, bbits, d2, dd, dig, dsign, i, j, nd, nd0, p2, p5, speccase;
-
- dsign = bc->dsign;
- nd = bc->nd;
- nd0 = bc->nd0;
- p5 = nd + bc->e0 - 1;
- speccase = 0;
+ Bigint *b, *d;
+ int b2, bbits, d2, dd, dig, dsign, i, j, nd, nd0, p2, p5, speccase;
+
+ dsign = bc->dsign;
+ nd = bc->nd;
+ nd0 = bc->nd0;
+ p5 = nd + bc->e0 - 1;
+ speccase = 0;
#ifndef Sudden_Underflow
- if (rv->d == 0.) { /* special case: value near underflow-to-zero */
- /* threshold was rounded to zero */
- b = i2b(1);
- p2 = Emin - P + 1;
- bbits = 1;
+ if (rv->d == 0.) { /* special case: value near underflow-to-zero */
+ /* threshold was rounded to zero */
+ b = i2b(1);
+ p2 = Emin - P + 1;
+ bbits = 1;
#ifdef Avoid_Underflow
- word0(rv) = (P+2) << Exp_shift;
+ word0(rv) = (P+2) << Exp_shift;
#else
- word1(rv) = 1;
+ word1(rv) = 1;
#endif
- i = 0;
+ i = 0;
#ifdef Honor_FLT_ROUNDS
- if (bc->rounding == 1)
-#endif
- {
- speccase = 1;
- --p2;
- dsign = 0;
- goto have_i;
- }
- }
- else
-#endif
- b = d2b(rv, &p2, &bbits);
+ if (bc->rounding == 1)
+#endif
+ {
+ speccase = 1;
+ --p2;
+ dsign = 0;
+ goto have_i;
+ }
+ }
+ else
+#endif
+ b = d2b(rv, &p2, &bbits);
#ifdef Avoid_Underflow
- p2 -= bc->scale;
+ p2 -= bc->scale;
#endif
- /* floor(log2(rv)) == bbits - 1 + p2 */
- /* Check for denormal case. */
- i = P - bbits;
- if (i > (j = P - Emin - 1 + p2)) {
+ /* floor(log2(rv)) == bbits - 1 + p2 */
+ /* Check for denormal case. */
+ i = P - bbits;
+ if (i > (j = P - Emin - 1 + p2)) {
#ifdef Sudden_Underflow
- Bfree(b);
- b = i2b(1);
- p2 = Emin;
- i = P - 1;
+ Bfree(b);
+ b = i2b(1);
+ p2 = Emin;
+ i = P - 1;
#ifdef Avoid_Underflow
- word0(rv) = (1 + bc->scale) << Exp_shift;
+ word0(rv) = (1 + bc->scale) << Exp_shift;
#else
- word0(rv) = Exp_msk1;
+ word0(rv) = Exp_msk1;
#endif
- word1(rv) = 0;
+ word1(rv) = 0;
#else
- i = j;
+ i = j;
#endif
- }
+ }
#ifdef Honor_FLT_ROUNDS
- if (bc->rounding != 1) {
- if (i > 0)
- b = lshift(b, i);
- if (dsign)
- b = increment(b);
- }
- else
-#endif
- {
- b = lshift(b, ++i);
- b->x[0] |= 1;
- }
+ if (bc->rounding != 1) {
+ if (i > 0)
+ b = lshift(b, i);
+ if (dsign)
+ b = increment(b);
+ }
+ else
+#endif
+ {
+ b = lshift(b, ++i);
+ b->x[0] |= 1;
+ }
#ifndef Sudden_Underflow
have_i:
#endif
- p2 -= p5 + i;
- d = i2b(1);
- /* Arrange for convenient computation of quotients:
- * shift left if necessary so divisor has 4 leading 0 bits.
- */
- if (p5 > 0)
- d = pow5mult(d, p5);
- else if (p5 < 0)
- b = pow5mult(b, -p5);
- if (p2 > 0) {
- b2 = p2;
- d2 = 0;
- }
- else {
- b2 = 0;
- d2 = -p2;
- }
- i = dshift(d, d2);
- if ((b2 += i) > 0)
- b = lshift(b, b2);
- if ((d2 += i) > 0)
- d = lshift(d, d2);
-
- /* Now b/d = exactly half-way between the two floating-point values */
- /* on either side of the input string. Compute first digit of b/d. */
-
- if (!(dig = quorem(b,d))) {
- b = multadd(b, 10, 0); /* very unlikely */
- dig = quorem(b,d);
- }
-
- /* Compare b/d with s0 */
-
- for(i = 0; i < nd0; ) {
- if ((dd = s0[i++] - '0' - dig))
- goto ret;
- if (!b->x[0] && b->wds == 1) {
- if (i < nd)
- dd = 1;
- goto ret;
- }
- b = multadd(b, 10, 0);
- dig = quorem(b,d);
- }
- for(j = bc->dp1; i++ < nd;) {
- if ((dd = s0[j++] - '0' - dig))
- goto ret;
- if (!b->x[0] && b->wds == 1) {
- if (i < nd)
- dd = 1;
- goto ret;
- }
- b = multadd(b, 10, 0);
- dig = quorem(b,d);
- }
- if (dig > 0 || b->x[0] || b->wds > 1)
- dd = -1;
+ p2 -= p5 + i;
+ d = i2b(1);
+ /* Arrange for convenient computation of quotients:
+ * shift left if necessary so divisor has 4 leading 0 bits.
+ */
+ if (p5 > 0)
+ d = pow5mult(d, p5);
+ else if (p5 < 0)
+ b = pow5mult(b, -p5);
+ if (p2 > 0) {
+ b2 = p2;
+ d2 = 0;
+ }
+ else {
+ b2 = 0;
+ d2 = -p2;
+ }
+ i = dshift(d, d2);
+ if ((b2 += i) > 0)
+ b = lshift(b, b2);
+ if ((d2 += i) > 0)
+ d = lshift(d, d2);
+
+ /* Now b/d = exactly half-way between the two floating-point values */
+ /* on either side of the input string. Compute first digit of b/d. */
+
+ if (!(dig = quorem(b,d))) {
+ b = multadd(b, 10, 0); /* very unlikely */
+ dig = quorem(b,d);
+ }
+
+ /* Compare b/d with s0 */
+
+ for(i = 0; i < nd0; ) {
+ if ((dd = s0[i++] - '0' - dig))
+ goto ret;
+ if (!b->x[0] && b->wds == 1) {
+ if (i < nd)
+ dd = 1;
+ goto ret;
+ }
+ b = multadd(b, 10, 0);
+ dig = quorem(b,d);
+ }
+ for(j = bc->dp1; i++ < nd;) {
+ if ((dd = s0[j++] - '0' - dig))
+ goto ret;
+ if (!b->x[0] && b->wds == 1) {
+ if (i < nd)
+ dd = 1;
+ goto ret;
+ }
+ b = multadd(b, 10, 0);
+ dig = quorem(b,d);
+ }
+ if (dig > 0 || b->x[0] || b->wds > 1)
+ dd = -1;
ret:
- Bfree(b);
- Bfree(d);
+ Bfree(b);
+ Bfree(d);
#ifdef Honor_FLT_ROUNDS
- if (bc->rounding != 1) {
- if (dd < 0) {
- if (bc->rounding == 0) {
- if (!dsign)
- goto retlow1;
- }
- else if (dsign)
- goto rethi1;
- }
- else if (dd > 0) {
- if (bc->rounding == 0) {
- if (dsign)
- goto rethi1;
- goto ret1;
- }
- if (!dsign)
- goto rethi1;
- dval(rv) += 2.*sulp(rv,bc);
- }
- else {
- bc->inexact = 0;
- if (dsign)
- goto rethi1;
- }
- }
- else
-#endif
- if (speccase) {
- if (dd <= 0)
- rv->d = 0.;
- }
- else if (dd < 0) {
- if (!dsign) /* does not happen for round-near */
+ if (bc->rounding != 1) {
+ if (dd < 0) {
+ if (bc->rounding == 0) {
+ if (!dsign)
+ goto retlow1;
+ }
+ else if (dsign)
+ goto rethi1;
+ }
+ else if (dd > 0) {
+ if (bc->rounding == 0) {
+ if (dsign)
+ goto rethi1;
+ goto ret1;
+ }
+ if (!dsign)
+ goto rethi1;
+ dval(rv) += 2.*sulp(rv,bc);
+ }
+ else {
+ bc->inexact = 0;
+ if (dsign)
+ goto rethi1;
+ }
+ }
+ else
+#endif
+ if (speccase) {
+ if (dd <= 0)
+ rv->d = 0.;
+ }
+ else if (dd < 0) {
+ if (!dsign) /* does not happen for round-near */
retlow1:
- dval(rv) -= sulp(rv,bc);
- }
- else if (dd > 0) {
- if (dsign) {
+ dval(rv) -= sulp(rv,bc);
+ }
+ else if (dd > 0) {
+ if (dsign) {
rethi1:
- dval(rv) += sulp(rv,bc);
- }
- }
- else {
- /* Exact half-way case: apply round-even rule. */
- if ((j = ((word0(rv) & Exp_mask) >> Exp_shift) - bc->scale) <= 0) {
- i = 1 - j;
- if (i <= 31) {
- if (word1(rv) & (0x1 << i))
- goto odd;
- }
- else if (word0(rv) & (0x1 << (i-32)))
- goto odd;
- }
- else if (word1(rv) & 1) {
+ dval(rv) += sulp(rv,bc);
+ }
+ }
+ else {
+ /* Exact half-way case: apply round-even rule. */
+ if ((j = ((word0(rv) & Exp_mask) >> Exp_shift) - bc->scale) <= 0) {
+ i = 1 - j;
+ if (i <= 31) {
+ if (word1(rv) & (0x1 << i))
+ goto odd;
+ }
+ else if (word0(rv) & (0x1 << (i-32)))
+ goto odd;
+ }
+ else if (word1(rv) & 1) {
odd:
- if (dsign)
- goto rethi1;
- goto retlow1;
- }
- }
+ if (dsign)
+ goto rethi1;
+ goto retlow1;
+ }
+ }
#ifdef Honor_FLT_ROUNDS
ret1:
#endif
- return;
- }
+ return;
+ }
#endif /* NO_STRTOD_BIGCOMP */
double
strtod
#ifdef KR_headers
- (s00, se) CONST char *s00; char **se;
+ (s00, se) CONST char *s00; const char **se; // Ren/C: fix cast away of const
#else
- (const char *s00, char **se)
+ (const char *s00, const char **se) // Ren/C: fix cast away of const
#endif
{
- int bb2, bb5, bbe, bd2, bd5, bbbits, bs2, c, e, e1;
- int esign, i, j, k, nd, nd0, nf, nz, nz0, nz1, sign;
- CONST char *s, *s0, *s1;
- double aadj, aadj1;
- Long L;
- U aadj2, adj, rv, rv0;
- ULong y, z;
- BCinfo bc;
- Bigint *bb, *bb1, *bd, *bd0, *bs, *delta;
+ int bb2, bb5, bbe, bd2, bd5, bbbits, bs2, c, e, e1;
+ int esign, i, j, k, nd, nd0, nf, nz, nz0, nz1, sign;
+ CONST char *s, *s0, *s1;
+ double aadj, aadj1;
+ Long L;
+ U aadj2, adj, rv, rv0;
+ ULong y, z;
+ BCinfo bc;
+ Bigint *bb, *bb1, *bd, *bd0, *bs, *delta;
#ifdef Avoid_Underflow
- ULong Lsb, Lsb1;
+ ULong Lsb, Lsb1;
#endif
#ifdef SET_INEXACT
- int oldinexact;
+ int oldinexact;
#endif
#ifndef NO_STRTOD_BIGCOMP
- int req_bigcomp = 0;
+ int req_bigcomp = 0;
#endif
#ifdef Honor_FLT_ROUNDS /*{*/
#ifdef Trust_FLT_ROUNDS /*{{ only define this if FLT_ROUNDS really works! */
- bc.rounding = Flt_Rounds;
+ bc.rounding = Flt_Rounds;
#else /*}{*/
- bc.rounding = 1;
- switch(fegetround()) {
- case FE_TOWARDZERO: bc.rounding = 0; break;
- case FE_UPWARD: bc.rounding = 2; break;
- case FE_DOWNWARD: bc.rounding = 3;
- }
+ bc.rounding = 1;
+ switch(fegetround()) {
+ case FE_TOWARDZERO: bc.rounding = 0; break;
+ case FE_UPWARD: bc.rounding = 2; break;
+ case FE_DOWNWARD: bc.rounding = 3;
+ }
#endif /*}}*/
#endif /*}*/
#ifdef USE_LOCALE
- CONST char *s2;
-#endif
-
- sign = nz0 = nz1 = nz = bc.dplen = bc.uflchk = 0;
- dval(&rv) = 0.;
- for(s = s00;;s++) switch(*s) {
- case '-':
- sign = 1;
- /* no break */
- case '+':
- if (*++s)
- goto break2;
- /* no break */
- case 0:
- goto ret0;
- case '\t':
- case '\n':
- case '\v':
- case '\f':
- case '\r':
- case ' ':
- continue;
- default:
- goto break2;
- }
+ CONST char *s2;
+#endif
+
+ sign = nz0 = nz1 = nz = bc.dplen = bc.uflchk = 0;
+ dval(&rv) = 0.;
+ for(s = s00;;s++) switch(*s) {
+ case '-':
+ sign = 1;
+ /* no break */
+ case '+':
+ if (*++s)
+ goto break2;
+ /* no break */
+ case 0:
+ goto ret0;
+ case '\t':
+ case '\n':
+ case '\v':
+ case '\f':
+ case '\r':
+ case ' ':
+ continue;
+ default:
+ goto break2;
+ }
break2:
- if (*s == '0') {
+ if (*s == '0') {
#ifndef NO_HEX_FP /*{*/
- switch(s[1]) {
- case 'x':
- case 'X':
+ switch(s[1]) {
+ case 'x':
+ case 'X':
#ifdef Honor_FLT_ROUNDS
- gethex(&s, &rv, bc.rounding, sign);
+ gethex(&s, &rv, bc.rounding, sign);
#else
- gethex(&s, &rv, 1, sign);
+ gethex(&s, &rv, 1, sign);
#endif
- goto ret;
- }
+ goto ret;
+ }
#endif /*}*/
- nz0 = 1;
- while(*++s == '0') ;
- if (!*s)
- goto ret;
- }
- s0 = s;
- y = z = 0;
- for(nd = nf = 0; (c = *s) >= '0' && c <= '9'; nd++, s++)
- if (nd < 9)
- y = 10*y + c - '0';
- else if (nd < 16)
- z = 10*z + c - '0';
- nd0 = nd;
- bc.dp0 = bc.dp1 = s - s0;
- for(s1 = s; s1 > s0 && *--s1 == '0'; )
- ++nz1;
+ nz0 = 1;
+ while(*++s == '0') ;
+ if (!*s)
+ goto ret;
+ }
+ s0 = s;
+ y = z = 0;
+ for(nd = nf = 0; (c = *s) >= '0' && c <= '9'; nd++, s++)
+ if (nd < 9)
+ y = 10*y + c - '0';
+ else if (nd < 16)
+ z = 10*z + c - '0';
+ nd0 = nd;
+ bc.dp0 = bc.dp1 = s - s0;
+ for(s1 = s; s1 > s0 && *--s1 == '0'; )
+ ++nz1;
#ifdef USE_LOCALE
- s1 = localeconv()->decimal_point;
- if (c == *s1) {
- c = '.';
- if (*++s1) {
- s2 = s;
- for(;;) {
- if (*++s2 != *s1) {
- c = 0;
- break;
- }
- if (!*++s1) {
- s = s2;
- break;
- }
- }
- }
- }
-#endif
- if (c == '.') {
- c = *++s;
- bc.dp1 = s - s0;
- bc.dplen = bc.dp1 - bc.dp0;
- if (!nd) {
- for(; c == '0'; c = *++s)
- nz++;
- if (c > '0' && c <= '9') {
- bc.dp0 = s0 - s;
- bc.dp1 = bc.dp0 + bc.dplen;
- s0 = s;
- nf += nz;
- nz = 0;
- goto have_dig;
- }
- goto dig_done;
- }
- for(; c >= '0' && c <= '9'; c = *++s) {
+ s1 = localeconv()->decimal_point;
+ if (c == *s1) {
+ c = '.';
+ if (*++s1) {
+ s2 = s;
+ for(;;) {
+ if (*++s2 != *s1) {
+ c = 0;
+ break;
+ }
+ if (!*++s1) {
+ s = s2;
+ break;
+ }
+ }
+ }
+ }
+#endif
+ if (c == '.') {
+ c = *++s;
+ bc.dp1 = s - s0;
+ bc.dplen = bc.dp1 - bc.dp0;
+ if (!nd) {
+ for(; c == '0'; c = *++s)
+ nz++;
+ if (c > '0' && c <= '9') {
+ bc.dp0 = s0 - s;
+ bc.dp1 = bc.dp0 + bc.dplen;
+ s0 = s;
+ nf += nz;
+ nz = 0;
+ goto have_dig;
+ }
+ goto dig_done;
+ }
+ for(; c >= '0' && c <= '9'; c = *++s) {
have_dig:
- nz++;
- if (c -= '0') {
- nf += nz;
- for(i = 1; i < nz; i++)
- if (nd++ < 9)
- y *= 10;
- else if (nd <= DBL_DIG + 1)
- z *= 10;
- if (nd++ < 9)
- y = 10*y + c;
- else if (nd <= DBL_DIG + 1)
- z = 10*z + c;
- nz = nz1 = 0;
- }
- }
- }
+ nz++;
+ if (c -= '0') {
+ nf += nz;
+ for(i = 1; i < nz; i++)
+ if (nd++ < 9)
+ y *= 10;
+ else if (nd <= DBL_DIG + 1)
+ z *= 10;
+ if (nd++ < 9)
+ y = 10*y + c;
+ else if (nd <= DBL_DIG + 1)
+ z = 10*z + c;
+ nz = nz1 = 0;
+ }
+ }
+ }
dig_done:
- e = 0;
- if (c == 'e' || c == 'E') {
- if (!nd && !nz && !nz0) {
- goto ret0;
- }
- s00 = s;
- esign = 0;
- switch(c = *++s) {
- case '-':
- esign = 1;
- case '+':
- c = *++s;
- }
- if (c >= '0' && c <= '9') {
- while(c == '0')
- c = *++s;
- if (c > '0' && c <= '9') {
- L = c - '0';
- s1 = s;
- while((c = *++s) >= '0' && c <= '9')
- L = 10*L + c - '0';
- if (s - s1 > 8 || L > 19999)
- /* Avoid confusion from exponents
- * so large that e might overflow.
- */
- e = 19999; /* safe for 16 bit ints */
- else
- e = (int)L;
- if (esign)
- e = -e;
- }
- else
- e = 0;
- }
- else
- s = s00;
- }
- if (!nd) {
- if (!nz && !nz0) {
+ e = 0;
+ if (c == 'e' || c == 'E') {
+ if (!nd && !nz && !nz0) {
+ goto ret0;
+ }
+ s00 = s;
+ esign = 0;
+ switch(c = *++s) {
+ case '-':
+ esign = 1;
+ case '+':
+ c = *++s;
+ }
+ if (c >= '0' && c <= '9') {
+ while(c == '0')
+ c = *++s;
+ if (c > '0' && c <= '9') {
+ L = c - '0';
+ s1 = s;
+ while((c = *++s) >= '0' && c <= '9')
+ L = 10*L + c - '0';
+ if (s - s1 > 8 || L > 19999)
+ /* Avoid confusion from exponents
+ * so large that e might overflow.
+ */
+ e = 19999; /* safe for 16 bit ints */
+ else
+ e = (int)L;
+ if (esign)
+ e = -e;
+ }
+ else
+ e = 0;
+ }
+ else
+ s = s00;
+ }
+ if (!nd) {
+ if (!nz && !nz0) {
#ifdef INFNAN_CHECK
- /* Check for Nan and Infinity */
- if (!bc.dplen)
- switch(c) {
- case 'i':
- case 'I':
- if (match(&s,"nf")) {
- --s;
- if (!match(&s,"inity"))
- ++s;
- word0(&rv) = 0x7ff00000;
- word1(&rv) = 0;
- goto ret;
- }
- break;
- case 'n':
- case 'N':
- if (match(&s, "an")) {
- word0(&rv) = NAN_WORD0;
- word1(&rv) = NAN_WORD1;
+ /* Check for Nan and Infinity */
+ if (!bc.dplen)
+ switch(c) {
+ case 'i':
+ case 'I':
+ if (match(&s,"nf")) {
+ --s;
+ if (!match(&s,"inity"))
+ ++s;
+ word0(&rv) = 0x7ff00000;
+ word1(&rv) = 0;
+ goto ret;
+ }
+ break;
+ case 'n':
+ case 'N':
+ if (match(&s, "an")) {
+ word0(&rv) = NAN_WORD0;
+ word1(&rv) = NAN_WORD1;
#ifndef No_Hex_NaN
- if (*s == '(') /*)*/
- hexnan(&rv, &s);
+ if (*s == '(') /*)*/
+ hexnan(&rv, &s);
#endif
- goto ret;
- }
- }
+ goto ret;
+ }
+ }
#endif /* INFNAN_CHECK */
ret0:
- s = s00;
- sign = 0;
- }
- goto ret;
- }
- bc.e0 = e1 = e -= nf;
-
- /* Now we have nd0 digits, starting at s0, followed by a
- * decimal point, followed by nd-nd0 digits. The number we're
- * after is the integer represented by those digits times
- * 10**e */
-
- if (!nd0)
- nd0 = nd;
- k = nd < DBL_DIG + 1 ? nd : DBL_DIG + 1;
- dval(&rv) = y;
- if (k > 9) {
+ s = s00;
+ sign = 0;
+ }
+ goto ret;
+ }
+ bc.e0 = e1 = e -= nf;
+
+ /* Now we have nd0 digits, starting at s0, followed by a
+ * decimal point, followed by nd-nd0 digits. The number we're
+ * after is the integer represented by those digits times
+ * 10**e */
+
+ if (!nd0)
+ nd0 = nd;
+ k = nd < DBL_DIG + 1 ? nd : DBL_DIG + 1;
+ dval(&rv) = y;
+ if (k > 9) {
#ifdef SET_INEXACT
- if (k > DBL_DIG)
- oldinexact = get_inexact();
+ if (k > DBL_DIG)
+ oldinexact = get_inexact();
#endif
- dval(&rv) = tens[k - 9] * dval(&rv) + z;
- }
- bd0 = 0;
- if (nd <= DBL_DIG
+ dval(&rv) = tens[k - 9] * dval(&rv) + z;
+ }
+ bd0 = 0;
+ if (nd <= DBL_DIG
#ifndef RND_PRODQUOT
#ifndef Honor_FLT_ROUNDS
- && Flt_Rounds == 1
+ && Flt_Rounds == 1
#endif
#endif
- ) {
- if (!e)
- goto ret;
+ ) {
+ if (!e)
+ goto ret;
#ifndef ROUND_BIASED_without_Round_Up
- if (e > 0) {
- if (e <= Ten_pmax) {
+ if (e > 0) {
+ if (e <= Ten_pmax) {
#ifdef VAX
- goto vax_ovfl_check;
+ goto vax_ovfl_check;
#else
#ifdef Honor_FLT_ROUNDS
- /* round correctly FLT_ROUNDS = 2 or 3 */
- if (sign) {
- rv.d = -rv.d;
- sign = 0;
- }
-#endif
- /* rv = */ rounded_product(dval(&rv), tens[e]);
- goto ret;
-#endif
- }
- i = DBL_DIG - nd;
- if (e <= Ten_pmax + i) {
- /* A fancier test would sometimes let us do
- * this for larger i values.
- */
+ /* round correctly FLT_ROUNDS = 2 or 3 */
+ if (sign) {
+ rv.d = -rv.d;
+ sign = 0;
+ }
+#endif
+ /* rv = */ rounded_product(dval(&rv), tens[e]);
+ goto ret;
+#endif
+ }
+ i = DBL_DIG - nd;
+ if (e <= Ten_pmax + i) {
+ /* A fancier test would sometimes let us do
+ * this for larger i values.
+ */
#ifdef Honor_FLT_ROUNDS
- /* round correctly FLT_ROUNDS = 2 or 3 */
- if (sign) {
- rv.d = -rv.d;
- sign = 0;
- }
-#endif
- e -= i;
- dval(&rv) *= tens[i];
+ /* round correctly FLT_ROUNDS = 2 or 3 */
+ if (sign) {
+ rv.d = -rv.d;
+ sign = 0;
+ }
+#endif
+ e -= i;
+ dval(&rv) *= tens[i];
#ifdef VAX
- /* VAX exponent range is so narrow we must
- * worry about overflow here...
- */
+ /* VAX exponent range is so narrow we must
+ * worry about overflow here...
+ */
vax_ovfl_check:
- word0(&rv) -= P*Exp_msk1;
- /* rv = */ rounded_product(dval(&rv), tens[e]);
- if ((word0(&rv) & Exp_mask)
- > Exp_msk1*(DBL_MAX_EXP+Bias-1-P))
- goto ovfl;
- word0(&rv) += P*Exp_msk1;
+ word0(&rv) -= P*Exp_msk1;
+ /* rv = */ rounded_product(dval(&rv), tens[e]);
+ if ((word0(&rv) & Exp_mask)
+ > Exp_msk1*(DBL_MAX_EXP+Bias-1-P))
+ goto ovfl;
+ word0(&rv) += P*Exp_msk1;
#else
- /* rv = */ rounded_product(dval(&rv), tens[e]);
+ /* rv = */ rounded_product(dval(&rv), tens[e]);
#endif
- goto ret;
- }
- }
+ goto ret;
+ }
+ }
#ifndef Inaccurate_Divide
- else if (e >= -Ten_pmax) {
+ else if (e >= -Ten_pmax) {
#ifdef Honor_FLT_ROUNDS
- /* round correctly FLT_ROUNDS = 2 or 3 */
- if (sign) {
- rv.d = -rv.d;
- sign = 0;
- }
+ /* round correctly FLT_ROUNDS = 2 or 3 */
+ if (sign) {
+ rv.d = -rv.d;
+ sign = 0;
+ }
#endif
- /* rv = */ rounded_quotient(dval(&rv), tens[-e]);
- goto ret;
- }
+ /* rv = */ rounded_quotient(dval(&rv), tens[-e]);
+ goto ret;
+ }
#endif
#endif /* ROUND_BIASED_without_Round_Up */
- }
- e1 += nd - k;
+ }
+ e1 += nd - k;
#ifdef IEEE_Arith
#ifdef SET_INEXACT
- bc.inexact = 1;
- if (k <= DBL_DIG)
- oldinexact = get_inexact();
+ bc.inexact = 1;
+ if (k <= DBL_DIG)
+ oldinexact = get_inexact();
#endif
#ifdef Avoid_Underflow
- bc.scale = 0;
+ bc.scale = 0;
#endif
#ifdef Honor_FLT_ROUNDS
- if (bc.rounding >= 2) {
- if (sign)
- bc.rounding = bc.rounding == 2 ? 0 : 2;
- else
- if (bc.rounding != 2)
- bc.rounding = 0;
- }
+ if (bc.rounding >= 2) {
+ if (sign)
+ bc.rounding = bc.rounding == 2 ? 0 : 2;
+ else
+ if (bc.rounding != 2)
+ bc.rounding = 0;
+ }
#endif
#endif /*IEEE_Arith*/
- /* Get starting approximation = rv * 10**e1 */
+ /* Get starting approximation = rv * 10**e1 */
- if (e1 > 0) {
- if ((i = e1 & 15))
- dval(&rv) *= tens[i];
- if (e1 &= ~15) {
- if (e1 > DBL_MAX_10_EXP) {
+ if (e1 > 0) {
+ if ((i = e1 & 15))
+ dval(&rv) *= tens[i];
+ if (e1 &= ~15) {
+ if (e1 > DBL_MAX_10_EXP) {
ovfl:
- /* Can't trust HUGE_VAL */
+ /* Can't trust HUGE_VAL */
#ifdef IEEE_Arith
#ifdef Honor_FLT_ROUNDS
- switch(bc.rounding) {
- case 0: /* toward 0 */
- case 3: /* toward -infinity */
- word0(&rv) = Big0;
- word1(&rv) = Big1;
- break;
- default:
- word0(&rv) = Exp_mask;
- word1(&rv) = 0;
- }
+ switch(bc.rounding) {
+ case 0: /* toward 0 */
+ case 3: /* toward -infinity */
+ word0(&rv) = Big0;
+ word1(&rv) = Big1;
+ break;
+ default:
+ word0(&rv) = Exp_mask;
+ word1(&rv) = 0;
+ }
#else /*Honor_FLT_ROUNDS*/
- word0(&rv) = Exp_mask;
- word1(&rv) = 0;
+ word0(&rv) = Exp_mask;
+ word1(&rv) = 0;
#endif /*Honor_FLT_ROUNDS*/
#ifdef SET_INEXACT
- /* set overflow bit */
- dval(&rv0) = 1e300;
- dval(&rv0) *= dval(&rv0);
+ /* set overflow bit */
+ dval(&rv0) = 1e300;
+ dval(&rv0) *= dval(&rv0);
#endif
#else /*IEEE_Arith*/
- word0(&rv) = Big0;
- word1(&rv) = Big1;
+ word0(&rv) = Big0;
+ word1(&rv) = Big1;
#endif /*IEEE_Arith*/
range_err:
- if (bd0) {
- Bfree(bb);
- Bfree(bd);
- Bfree(bs);
- Bfree(bd0);
- Bfree(delta);
- }
+ if (bd0) {
+ Bfree(bb);
+ Bfree(bd);
+ Bfree(bs);
+ Bfree(bd0);
+ Bfree(delta);
+ }
#ifndef NO_ERRNO
- errno = ERANGE;
-#endif
- goto ret;
- }
- e1 >>= 4;
- for(j = 0; e1 > 1; j++, e1 >>= 1)
- if (e1 & 1)
- dval(&rv) *= bigtens[j];
- /* The last multiplication could overflow. */
- word0(&rv) -= P*Exp_msk1;
- dval(&rv) *= bigtens[j];
- if ((z = word0(&rv) & Exp_mask)
- > Exp_msk1*(DBL_MAX_EXP+Bias-P))
- goto ovfl;
- if (z > Exp_msk1*(DBL_MAX_EXP+Bias-1-P)) {
- /* set to largest number */
- /* (Can't trust DBL_MAX) */
- word0(&rv) = Big0;
- word1(&rv) = Big1;
- }
- else
- word0(&rv) += P*Exp_msk1;
- }
- }
- else if (e1 < 0) {
- e1 = -e1;
- if ((i = e1 & 15))
- dval(&rv) /= tens[i];
- if (e1 >>= 4) {
- if (e1 >= 1 << n_bigtens)
- goto undfl;
+ errno = ERANGE;
+#endif
+ goto ret;
+ }
+ e1 >>= 4;
+ for(j = 0; e1 > 1; j++, e1 >>= 1)
+ if (e1 & 1)
+ dval(&rv) *= bigtens[j];
+ /* The last multiplication could overflow. */
+ word0(&rv) -= P*Exp_msk1;
+ dval(&rv) *= bigtens[j];
+ if ((z = word0(&rv) & Exp_mask)
+ > Exp_msk1*(DBL_MAX_EXP+Bias-P))
+ goto ovfl;
+ if (z > Exp_msk1*(DBL_MAX_EXP+Bias-1-P)) {
+ /* set to largest number */
+ /* (Can't trust DBL_MAX) */
+ word0(&rv) = Big0;
+ word1(&rv) = Big1;
+ }
+ else
+ word0(&rv) += P*Exp_msk1;
+ }
+ }
+ else if (e1 < 0) {
+ e1 = -e1;
+ if ((i = e1 & 15))
+ dval(&rv) /= tens[i];
+ if (e1 >>= 4) {
+ if (e1 >= 1 << n_bigtens)
+ goto undfl;
#ifdef Avoid_Underflow
- if (e1 & Scale_Bit)
- bc.scale = 2*P;
- for(j = 0; e1 > 0; j++, e1 >>= 1)
- if (e1 & 1)
- dval(&rv) *= tinytens[j];
- if (bc.scale && (j = 2*P + 1 - ((word0(&rv) & Exp_mask)
- >> Exp_shift)) > 0) {
- /* scaled rv is denormal; clear j low bits */
- if (j >= 32) {
- if (j > 54)
- goto undfl;
- word1(&rv) = 0;
- if (j >= 53)
- word0(&rv) = (P+2)*Exp_msk1;
- else
- word0(&rv) &= 0xffffffff << (j-32);
- }
- else
- word1(&rv) &= 0xffffffff << j;
- }
+ if (e1 & Scale_Bit)
+ bc.scale = 2*P;
+ for(j = 0; e1 > 0; j++, e1 >>= 1)
+ if (e1 & 1)
+ dval(&rv) *= tinytens[j];
+ if (bc.scale && (j = 2*P + 1 - ((word0(&rv) & Exp_mask)
+ >> Exp_shift)) > 0) {
+ /* scaled rv is denormal; clear j low bits */
+ if (j >= 32) {
+ if (j > 54)
+ goto undfl;
+ word1(&rv) = 0;
+ if (j >= 53)
+ word0(&rv) = (P+2)*Exp_msk1;
+ else
+ word0(&rv) &= 0xffffffff << (j-32);
+ }
+ else
+ word1(&rv) &= 0xffffffff << j;
+ }
#else
- for(j = 0; e1 > 1; j++, e1 >>= 1)
- if (e1 & 1)
- dval(&rv) *= tinytens[j];
- /* The last multiplication could underflow. */
- dval(&rv0) = dval(&rv);
- dval(&rv) *= tinytens[j];
- if (!dval(&rv)) {
- dval(&rv) = 2.*dval(&rv0);
- dval(&rv) *= tinytens[j];
-#endif
- if (!dval(&rv)) {
+ for(j = 0; e1 > 1; j++, e1 >>= 1)
+ if (e1 & 1)
+ dval(&rv) *= tinytens[j];
+ /* The last multiplication could underflow. */
+ dval(&rv0) = dval(&rv);
+ dval(&rv) *= tinytens[j];
+ if (!dval(&rv)) {
+ dval(&rv) = 2.*dval(&rv0);
+ dval(&rv) *= tinytens[j];
+#endif
+ if (!dval(&rv)) {
undfl:
- dval(&rv) = 0.;
- goto range_err;
- }
+ dval(&rv) = 0.;
+ goto range_err;
+ }
#ifndef Avoid_Underflow
- word0(&rv) = Tiny0;
- word1(&rv) = Tiny1;
- /* The refinement below will clean
- * this approximation up.
- */
- }
+ word0(&rv) = Tiny0;
+ word1(&rv) = Tiny1;
+ /* The refinement below will clean
+ * this approximation up.
+ */
+ }
#endif
- }
- }
+ }
+ }
- /* Now the hard part -- adjusting rv to the correct value.*/
+ /* Now the hard part -- adjusting rv to the correct value.*/
- /* Put digits into bd: true value = bd * 10^e */
+ /* Put digits into bd: true value = bd * 10^e */
- bc.nd = nd - nz1;
+ bc.nd = nd - nz1;
#ifndef NO_STRTOD_BIGCOMP
- bc.nd0 = nd0; /* Only needed if nd > strtod_diglim, but done here */
- /* to silence an erroneous warning about bc.nd0 */
- /* possibly not being initialized. */
- if (nd > strtod_diglim) {
- /* ASSERT(strtod_diglim >= 18); 18 == one more than the */
- /* minimum number of decimal digits to distinguish double values */
- /* in IEEE arithmetic. */
- i = j = 18;
- if (i > nd0)
- j += bc.dplen;
- for(;;) {
- if (--j < bc.dp1 && j >= bc.dp0)
- j = bc.dp0 - 1;
- if (s0[j] != '0')
- break;
- --i;
- }
- e += nd - i;
- nd = i;
- if (nd0 > nd)
- nd0 = nd;
- if (nd < 9) { /* must recompute y */
- y = 0;
- for(i = 0; i < nd0; ++i)
- y = 10*y + s0[i] - '0';
- for(j = bc.dp1; i < nd; ++i)
- y = 10*y + s0[j++] - '0';
- }
- }
-#endif
- bd0 = s2b(s0, nd0, nd, y, bc.dplen);
-
- for(;;) {
- bd = Balloc(bd0->k);
- Bcopy(bd, bd0);
- bb = d2b(&rv, &bbe, &bbbits); /* rv = bb * 2^bbe */
- bs = i2b(1);
-
- if (e >= 0) {
- bb2 = bb5 = 0;
- bd2 = bd5 = e;
- }
- else {
- bb2 = bb5 = -e;
- bd2 = bd5 = 0;
- }
- if (bbe >= 0)
- bb2 += bbe;
- else
- bd2 -= bbe;
- bs2 = bb2;
+ bc.nd0 = nd0; /* Only needed if nd > strtod_diglim, but done here */
+ /* to silence an erroneous warning about bc.nd0 */
+ /* possibly not being initialized. */
+ if (nd > strtod_diglim) {
+ /* assert(strtod_diglim >= 18); 18 == one more than the */
+ /* minimum number of decimal digits to distinguish double values */
+ /* in IEEE arithmetic. */
+ i = j = 18;
+ if (i > nd0)
+ j += bc.dplen;
+ for(;;) {
+ if (--j < bc.dp1 && j >= bc.dp0)
+ j = bc.dp0 - 1;
+ if (s0[j] != '0')
+ break;
+ --i;
+ }
+ e += nd - i;
+ nd = i;
+ if (nd0 > nd)
+ nd0 = nd;
+ if (nd < 9) { /* must recompute y */
+ y = 0;
+ for(i = 0; i < nd0; ++i)
+ y = 10*y + s0[i] - '0';
+ for(j = bc.dp1; i < nd; ++i)
+ y = 10*y + s0[j++] - '0';
+ }
+ }
+#endif
+ bd0 = s2b(s0, nd0, nd, y, bc.dplen);
+
+ for(;;) {
+ bd = Balloc(bd0->k);
+ Bcopy(bd, bd0);
+ bb = d2b(&rv, &bbe, &bbbits); /* rv = bb * 2^bbe */
+ bs = i2b(1);
+
+ if (e >= 0) {
+ bb2 = bb5 = 0;
+ bd2 = bd5 = e;
+ }
+ else {
+ bb2 = bb5 = -e;
+ bd2 = bd5 = 0;
+ }
+ if (bbe >= 0)
+ bb2 += bbe;
+ else
+ bd2 -= bbe;
+ bs2 = bb2;
#ifdef Honor_FLT_ROUNDS
- if (bc.rounding != 1)
- bs2++;
+ if (bc.rounding != 1)
+ bs2++;
#endif
#ifdef Avoid_Underflow
- Lsb = LSB;
- Lsb1 = 0;
- j = bbe - bc.scale;
- i = j + bbbits - 1; /* logb(rv) */
- j = P + 1 - bbbits;
- if (i < Emin) { /* denormal */
- i = Emin - i;
- j -= i;
- if (i < 32)
- Lsb <<= i;
- else if (i < 52)
- Lsb1 = Lsb << (i-32);
- else
- Lsb1 = Exp_mask;
- }
+ Lsb = LSB;
+ Lsb1 = 0;
+ j = bbe - bc.scale;
+ i = j + bbbits - 1; /* logb(rv) */
+ j = P + 1 - bbbits;
+ if (i < Emin) { /* denormal */
+ i = Emin - i;
+ j -= i;
+ if (i < 32)
+ Lsb <<= i;
+ else if (i < 52)
+ Lsb1 = Lsb << (i-32);
+ else
+ Lsb1 = Exp_mask;
+ }
#else /*Avoid_Underflow*/
#ifdef Sudden_Underflow
#ifdef IBM
- j = 1 + 4*P - 3 - bbbits + ((bbe + bbbits - 1) & 3);
+ j = 1 + 4*P - 3 - bbbits + ((bbe + bbbits - 1) & 3);
#else
- j = P + 1 - bbbits;
+ j = P + 1 - bbbits;
#endif
#else /*Sudden_Underflow*/
- j = bbe;
- i = j + bbbits - 1; /* logb(rv) */
- if (i < Emin) /* denormal */
- j += P - Emin;
- else
- j = P + 1 - bbbits;
+ j = bbe;
+ i = j + bbbits - 1; /* logb(rv) */
+ if (i < Emin) /* denormal */
+ j += P - Emin;
+ else
+ j = P + 1 - bbbits;
#endif /*Sudden_Underflow*/
#endif /*Avoid_Underflow*/
- bb2 += j;
- bd2 += j;
+ bb2 += j;
+ bd2 += j;
#ifdef Avoid_Underflow
- bd2 += bc.scale;
-#endif
- i = bb2 < bd2 ? bb2 : bd2;
- if (i > bs2)
- i = bs2;
- if (i > 0) {
- bb2 -= i;
- bd2 -= i;
- bs2 -= i;
- }
- if (bb5 > 0) {
- bs = pow5mult(bs, bb5);
- bb1 = mult(bs, bb);
- Bfree(bb);
- bb = bb1;
- }
- if (bb2 > 0)
- bb = lshift(bb, bb2);
- if (bd5 > 0)
- bd = pow5mult(bd, bd5);
- if (bd2 > 0)
- bd = lshift(bd, bd2);
- if (bs2 > 0)
- bs = lshift(bs, bs2);
- delta = diff(bb, bd);
- bc.dsign = delta->sign;
- delta->sign = 0;
- i = cmp(delta, bs);
+ bd2 += bc.scale;
+#endif
+ i = bb2 < bd2 ? bb2 : bd2;
+ if (i > bs2)
+ i = bs2;
+ if (i > 0) {
+ bb2 -= i;
+ bd2 -= i;
+ bs2 -= i;
+ }
+ if (bb5 > 0) {
+ bs = pow5mult(bs, bb5);
+ bb1 = mult(bs, bb);
+ Bfree(bb);
+ bb = bb1;
+ }
+ if (bb2 > 0)
+ bb = lshift(bb, bb2);
+ if (bd5 > 0)
+ bd = pow5mult(bd, bd5);
+ if (bd2 > 0)
+ bd = lshift(bd, bd2);
+ if (bs2 > 0)
+ bs = lshift(bs, bs2);
+ delta = diff(bb, bd);
+ bc.dsign = delta->sign;
+ delta->sign = 0;
+ i = cmp(delta, bs);
#ifndef NO_STRTOD_BIGCOMP /*{*/
- if (bc.nd > nd && i <= 0) {
- if (bc.dsign) {
- /* Must use bigcomp(). */
- req_bigcomp = 1;
- break;
- }
+ if (bc.nd > nd && i <= 0) {
+ if (bc.dsign) {
+ /* Must use bigcomp(). */
+ req_bigcomp = 1;
+ break;
+ }
#ifdef Honor_FLT_ROUNDS
- if (bc.rounding != 1) {
- if (i < 0) {
- req_bigcomp = 1;
- break;
- }
- }
- else
-#endif
- i = -1; /* Discarded digits make delta smaller. */
- }
+ if (bc.rounding != 1) {
+ if (i < 0) {
+ req_bigcomp = 1;
+ break;
+ }
+ }
+ else
+#endif
+ i = -1; /* Discarded digits make delta smaller. */
+ }
#endif /*}*/
#ifdef Honor_FLT_ROUNDS /*{*/
- if (bc.rounding != 1) {
- if (i < 0) {
- /* Error is less than an ulp */
- if (!delta->x[0] && delta->wds <= 1) {
- /* exact */
+ if (bc.rounding != 1) {
+ if (i < 0) {
+ /* Error is less than an ulp */
+ if (!delta->x[0] && delta->wds <= 1) {
+ /* exact */
#ifdef SET_INEXACT
- bc.inexact = 0;
-#endif
- break;
- }
- if (bc.rounding) {
- if (bc.dsign) {
- adj.d = 1.;
- goto apply_adj;
- }
- }
- else if (!bc.dsign) {
- adj.d = -1.;
- if (!word1(&rv)
- && !(word0(&rv) & Frac_mask)) {
- y = word0(&rv) & Exp_mask;
+ bc.inexact = 0;
+#endif
+ break;
+ }
+ if (bc.rounding) {
+ if (bc.dsign) {
+ adj.d = 1.;
+ goto apply_adj;
+ }
+ }
+ else if (!bc.dsign) {
+ adj.d = -1.;
+ if (!word1(&rv)
+ && !(word0(&rv) & Frac_mask)) {
+ y = word0(&rv) & Exp_mask;
#ifdef Avoid_Underflow
- if (!bc.scale || y > 2*P*Exp_msk1)
+ if (!bc.scale || y > 2*P*Exp_msk1)
#else
- if (y)
-#endif
- {
- delta = lshift(delta,Log2P);
- if (cmp(delta, bs) <= 0)
- adj.d = -0.5;
- }
- }
+ if (y)
+#endif
+ {
+ delta = lshift(delta,Log2P);
+ if (cmp(delta, bs) <= 0)
+ adj.d = -0.5;
+ }
+ }
apply_adj:
#ifdef Avoid_Underflow /*{*/
- if (bc.scale && (y = word0(&rv) & Exp_mask)
- <= 2*P*Exp_msk1)
- word0(&adj) += (2*P+1)*Exp_msk1 - y;
+ if (bc.scale && (y = word0(&rv) & Exp_mask)
+ <= 2*P*Exp_msk1)
+ word0(&adj) += (2*P+1)*Exp_msk1 - y;
#else
#ifdef Sudden_Underflow
- if ((word0(&rv) & Exp_mask) <=
- P*Exp_msk1) {
- word0(&rv) += P*Exp_msk1;
- dval(&rv) += adj.d*ulp(dval(&rv));
- word0(&rv) -= P*Exp_msk1;
- }
- else
+ if ((word0(&rv) & Exp_mask) <=
+ P*Exp_msk1) {
+ word0(&rv) += P*Exp_msk1;
+ dval(&rv) += adj.d*ulp(dval(&rv));
+ word0(&rv) -= P*Exp_msk1;
+ }
+ else
#endif /*Sudden_Underflow*/
#endif /*Avoid_Underflow}*/
- dval(&rv) += adj.d*ulp(&rv);
- }
- break;
- }
- adj.d = ratio(delta, bs);
- if (adj.d < 1.)
- adj.d = 1.;
- if (adj.d <= 0x7ffffffe) {
- /* adj = rounding ? ceil(adj) : floor(adj); */
- y = adj.d;
- if (y != adj.d) {
- if (!((bc.rounding>>1) ^ bc.dsign))
- y++;
- adj.d = y;
- }
- }
+ dval(&rv) += adj.d*ulp(&rv);
+ }
+ break;
+ }
+ adj.d = ratio(delta, bs);
+ if (adj.d < 1.)
+ adj.d = 1.;
+ if (adj.d <= 0x7ffffffe) {
+ /* adj = rounding ? ceil(adj) : floor(adj); */
+ y = adj.d;
+ if (y != adj.d) {
+ if (!((bc.rounding>>1) ^ bc.dsign))
+ y++;
+ adj.d = y;
+ }
+ }
#ifdef Avoid_Underflow /*{*/
- if (bc.scale && (y = word0(&rv) & Exp_mask) <= 2*P*Exp_msk1)
- word0(&adj) += (2*P+1)*Exp_msk1 - y;
+ if (bc.scale && (y = word0(&rv) & Exp_mask) <= 2*P*Exp_msk1)
+ word0(&adj) += (2*P+1)*Exp_msk1 - y;
#else
#ifdef Sudden_Underflow
- if ((word0(&rv) & Exp_mask) <= P*Exp_msk1) {
- word0(&rv) += P*Exp_msk1;
- adj.d *= ulp(dval(&rv));
- if (bc.dsign)
- dval(&rv) += adj.d;
- else
- dval(&rv) -= adj.d;
- word0(&rv) -= P*Exp_msk1;
- goto cont;
- }
+ if ((word0(&rv) & Exp_mask) <= P*Exp_msk1) {
+ word0(&rv) += P*Exp_msk1;
+ adj.d *= ulp(dval(&rv));
+ if (bc.dsign)
+ dval(&rv) += adj.d;
+ else
+ dval(&rv) -= adj.d;
+ word0(&rv) -= P*Exp_msk1;
+ goto cont;
+ }
#endif /*Sudden_Underflow*/
#endif /*Avoid_Underflow}*/
- adj.d *= ulp(&rv);
- if (bc.dsign) {
- if (word0(&rv) == Big0 && word1(&rv) == Big1)
- goto ovfl;
- dval(&rv) += adj.d;
- }
- else
- dval(&rv) -= adj.d;
- goto cont;
- }
+ adj.d *= ulp(&rv);
+ if (bc.dsign) {
+ if (word0(&rv) == Big0 && word1(&rv) == Big1)
+ goto ovfl;
+ dval(&rv) += adj.d;
+ }
+ else
+ dval(&rv) -= adj.d;
+ goto cont;
+ }
#endif /*}Honor_FLT_ROUNDS*/
- if (i < 0) {
- /* Error is less than half an ulp -- check for
- * special case of mantissa a power of two.
- */
- if (bc.dsign || word1(&rv) || word0(&rv) & Bndry_mask
+ if (i < 0) {
+ /* Error is less than half an ulp -- check for
+ * special case of mantissa a power of two.
+ */
+ if (bc.dsign || word1(&rv) || word0(&rv) & Bndry_mask
#ifdef IEEE_Arith /*{*/
#ifdef Avoid_Underflow
- || (word0(&rv) & Exp_mask) <= (2*P+1)*Exp_msk1
+ || (word0(&rv) & Exp_mask) <= (2*P+1)*Exp_msk1
#else
- || (word0(&rv) & Exp_mask) <= Exp_msk1
+ || (word0(&rv) & Exp_mask) <= Exp_msk1
#endif
#endif /*}*/
- ) {
+ ) {
#ifdef SET_INEXACT
- if (!delta->x[0] && delta->wds <= 1)
- bc.inexact = 0;
+ if (!delta->x[0] && delta->wds <= 1)
+ bc.inexact = 0;
#endif
- break;
- }
- if (!delta->x[0] && delta->wds <= 1) {
- /* exact result */
+ break;
+ }
+ if (!delta->x[0] && delta->wds <= 1) {
+ /* exact result */
#ifdef SET_INEXACT
- bc.inexact = 0;
-#endif
- break;
- }
- delta = lshift(delta,Log2P);
- if (cmp(delta, bs) > 0)
- goto drop_down;
- break;
- }
- if (i == 0) {
- /* exactly half-way between */
- if (bc.dsign) {
- if ((word0(&rv) & Bndry_mask1) == Bndry_mask1
- && word1(&rv) == (
+ bc.inexact = 0;
+#endif
+ break;
+ }
+ delta = lshift(delta,Log2P);
+ if (cmp(delta, bs) > 0)
+ goto drop_down;
+ break;
+ }
+ if (i == 0) {
+ /* exactly half-way between */
+ if (bc.dsign) {
+ if ((word0(&rv) & Bndry_mask1) == Bndry_mask1
+ && word1(&rv) == (
#ifdef Avoid_Underflow
- (bc.scale && (y = word0(&rv) & Exp_mask) <= 2*P*Exp_msk1)
- ? (0xffffffff & (0xffffffff << (2*P+1-(y>>Exp_shift)))) :
-#endif
- 0xffffffff)) {
- /*boundary case -- increment exponent*/
- if (word0(&rv) == Big0 && word1(&rv) == Big1)
- goto ovfl;
- word0(&rv) = (word0(&rv) & Exp_mask)
- + Exp_msk1
+ (bc.scale && (y = word0(&rv) & Exp_mask) <= 2*P*Exp_msk1)
+ ? (0xffffffff & (0xffffffff << (2*P+1-(y>>Exp_shift)))) :
+#endif
+ 0xffffffff)) {
+ /*boundary case -- increment exponent*/
+ if (word0(&rv) == Big0 && word1(&rv) == Big1)
+ goto ovfl;
+ word0(&rv) = (word0(&rv) & Exp_mask)
+ + Exp_msk1
#ifdef IBM
- | Exp_msk1 >> 4
+ | Exp_msk1 >> 4
#endif
- ;
- word1(&rv) = 0;
+ ;
+ word1(&rv) = 0;
#ifdef Avoid_Underflow
- bc.dsign = 0;
+ bc.dsign = 0;
#endif
- break;
- }
- }
- else if (!(word0(&rv) & Bndry_mask) && !word1(&rv)) {
+ break;
+ }
+ }
+ else if (!(word0(&rv) & Bndry_mask) && !word1(&rv)) {
drop_down:
- /* boundary case -- decrement exponent */
+ /* boundary case -- decrement exponent */
#ifdef Sudden_Underflow /*{{*/
- L = word0(&rv) & Exp_mask;
+ L = word0(&rv) & Exp_mask;
#ifdef IBM
- if (L < Exp_msk1)
+ if (L < Exp_msk1)
#else
#ifdef Avoid_Underflow
- if (L <= (bc.scale ? (2*P+1)*Exp_msk1 : Exp_msk1))
+ if (L <= (bc.scale ? (2*P+1)*Exp_msk1 : Exp_msk1))
#else
- if (L <= Exp_msk1)
+ if (L <= Exp_msk1)
#endif /*Avoid_Underflow*/
#endif /*IBM*/
- {
- if (bc.nd >nd) {
- bc.uflchk = 1;
- break;
- }
- goto undfl;
- }
- L -= Exp_msk1;
+ {
+ if (bc.nd >nd) {
+ bc.uflchk = 1;
+ break;
+ }
+ goto undfl;
+ }
+ L -= Exp_msk1;
#else /*Sudden_Underflow}{*/
#ifdef Avoid_Underflow
- if (bc.scale) {
- L = word0(&rv) & Exp_mask;
- if (L <= (2*P+1)*Exp_msk1) {
- if (L > (P+2)*Exp_msk1)
- /* round even ==> */
- /* accept rv */
- break;
- /* rv = smallest denormal */
- if (bc.nd >nd) {
- bc.uflchk = 1;
- break;
- }
- goto undfl;
- }
- }
+ if (bc.scale) {
+ L = word0(&rv) & Exp_mask;
+ if (L <= (2*P+1)*Exp_msk1) {
+ if (L > (P+2)*Exp_msk1)
+ /* round even ==> */
+ /* accept rv */
+ break;
+ /* rv = smallest denormal */
+ if (bc.nd >nd) {
+ bc.uflchk = 1;
+ break;
+ }
+ goto undfl;
+ }
+ }
#endif /*Avoid_Underflow*/
- L = (word0(&rv) & Exp_mask) - Exp_msk1;
+ L = (word0(&rv) & Exp_mask) - Exp_msk1;
#endif /*Sudden_Underflow}}*/
- word0(&rv) = L | Bndry_mask1;
- word1(&rv) = 0xffffffff;
+ word0(&rv) = L | Bndry_mask1;
+ word1(&rv) = 0xffffffff;
#ifdef IBM
- goto cont;
+ goto cont;
#else
#ifndef NO_STRTOD_BIGCOMP
- if (bc.nd > nd)
- goto cont;
+ if (bc.nd > nd)
+ goto cont;
#endif
- break;
+ break;
#endif
- }
+ }
#ifndef ROUND_BIASED
#ifdef Avoid_Underflow
- if (Lsb1) {
- if (!(word0(&rv) & Lsb1))
- break;
- }
- else if (!(word1(&rv) & Lsb))
- break;
+ if (Lsb1) {
+ if (!(word0(&rv) & Lsb1))
+ break;
+ }
+ else if (!(word1(&rv) & Lsb))
+ break;
#else
- if (!(word1(&rv) & LSB))
- break;
+ if (!(word1(&rv) & LSB))
+ break;
#endif
#endif
- if (bc.dsign)
+ if (bc.dsign)
#ifdef Avoid_Underflow
- dval(&rv) += sulp(&rv, &bc);
+ dval(&rv) += sulp(&rv, &bc);
#else
- dval(&rv) += ulp(&rv);
+ dval(&rv) += ulp(&rv);
#endif
#ifndef ROUND_BIASED
- else {
+ else {
#ifdef Avoid_Underflow
- dval(&rv) -= sulp(&rv, &bc);
+ dval(&rv) -= sulp(&rv, &bc);
#else
- dval(&rv) -= ulp(&rv);
+ dval(&rv) -= ulp(&rv);
#endif
#ifndef Sudden_Underflow
- if (!dval(&rv)) {
- if (bc.nd >nd) {
- bc.uflchk = 1;
- break;
- }
- goto undfl;
- }
-#endif
- }
+ if (!dval(&rv)) {
+ if (bc.nd >nd) {
+ bc.uflchk = 1;
+ break;
+ }
+ goto undfl;
+ }
+#endif
+ }
#ifdef Avoid_Underflow
- bc.dsign = 1 - bc.dsign;
+ bc.dsign = 1 - bc.dsign;
#endif
#endif
- break;
- }
- if ((aadj = ratio(delta, bs)) <= 2.) {
- if (bc.dsign)
- aadj = aadj1 = 1.;
- else if (word1(&rv) || word0(&rv) & Bndry_mask) {
+ break;
+ }
+ if ((aadj = ratio(delta, bs)) <= 2.) {
+ if (bc.dsign)
+ aadj = aadj1 = 1.;
+ else if (word1(&rv) || word0(&rv) & Bndry_mask) {
#ifndef Sudden_Underflow
- if (word1(&rv) == Tiny1 && !word0(&rv)) {
- if (bc.nd >nd) {
- bc.uflchk = 1;
- break;
- }
- goto undfl;
- }
-#endif
- aadj = 1.;
- aadj1 = -1.;
- }
- else {
- /* special case -- power of FLT_RADIX to be */
- /* rounded down... */
-
- if (aadj < 2./FLT_RADIX)
- aadj = 1./FLT_RADIX;
- else
- aadj *= 0.5;
- aadj1 = -aadj;
- }
- }
- else {
- aadj *= 0.5;
- aadj1 = bc.dsign ? aadj : -aadj;
+ if (word1(&rv) == Tiny1 && !word0(&rv)) {
+ if (bc.nd >nd) {
+ bc.uflchk = 1;
+ break;
+ }
+ goto undfl;
+ }
+#endif
+ aadj = 1.;
+ aadj1 = -1.;
+ }
+ else {
+ /* special case -- power of FLT_RADIX to be */
+ /* rounded down... */
+
+ if (aadj < 2./FLT_RADIX)
+ aadj = 1./FLT_RADIX;
+ else
+ aadj *= 0.5;
+ aadj1 = -aadj;
+ }
+ }
+ else {
+ aadj *= 0.5;
+ aadj1 = bc.dsign ? aadj : -aadj;
#ifdef Check_FLT_ROUNDS
- switch(bc.rounding) {
- case 2: /* towards +infinity */
- aadj1 -= 0.5;
- break;
- case 0: /* towards 0 */
- case 3: /* towards -infinity */
- aadj1 += 0.5;
- }
+ switch(bc.rounding) {
+ case 2: /* towards +infinity */
+ aadj1 -= 0.5;
+ break;
+ case 0: /* towards 0 */
+ case 3: /* towards -infinity */
+ aadj1 += 0.5;
+ }
#else
- if (Flt_Rounds == 0)
- aadj1 += 0.5;
+ if (Flt_Rounds == 0)
+ aadj1 += 0.5;
#endif /*Check_FLT_ROUNDS*/
- }
- y = word0(&rv) & Exp_mask;
-
- /* Check for overflow */
-
- if (y == Exp_msk1*(DBL_MAX_EXP+Bias-1)) {
- dval(&rv0) = dval(&rv);
- word0(&rv) -= P*Exp_msk1;
- adj.d = aadj1 * ulp(&rv);
- dval(&rv) += adj.d;
- if ((word0(&rv) & Exp_mask) >=
- Exp_msk1*(DBL_MAX_EXP+Bias-P)) {
- if (word0(&rv0) == Big0 && word1(&rv0) == Big1)
- goto ovfl;
- word0(&rv) = Big0;
- word1(&rv) = Big1;
- goto cont;
- }
- else
- word0(&rv) += P*Exp_msk1;
- }
- else {
+ }
+ y = word0(&rv) & Exp_mask;
+
+ /* Check for overflow */
+
+ if (y == Exp_msk1*(DBL_MAX_EXP+Bias-1)) {
+ dval(&rv0) = dval(&rv);
+ word0(&rv) -= P*Exp_msk1;
+ adj.d = aadj1 * ulp(&rv);
+ dval(&rv) += adj.d;
+ if ((word0(&rv) & Exp_mask) >=
+ Exp_msk1*(DBL_MAX_EXP+Bias-P)) {
+ if (word0(&rv0) == Big0 && word1(&rv0) == Big1)
+ goto ovfl;
+ word0(&rv) = Big0;
+ word1(&rv) = Big1;
+ goto cont;
+ }
+ else
+ word0(&rv) += P*Exp_msk1;
+ }
+ else {
#ifdef Avoid_Underflow
- if (bc.scale && y <= 2*P*Exp_msk1) {
- if (aadj <= 0x7fffffff) {
- if ((z = aadj) <= 0)
- z = 1;
- aadj = z;
- aadj1 = bc.dsign ? aadj : -aadj;
- }
- dval(&aadj2) = aadj1;
- word0(&aadj2) += (2*P+1)*Exp_msk1 - y;
- aadj1 = dval(&aadj2);
- adj.d = aadj1 * ulp(&rv);
- dval(&rv) += adj.d;
- if (rv.d == 0.)
+ if (bc.scale && y <= 2*P*Exp_msk1) {
+ if (aadj <= 0x7fffffff) {
+ if ((z = aadj) <= 0)
+ z = 1;
+ aadj = z;
+ aadj1 = bc.dsign ? aadj : -aadj;
+ }
+ dval(&aadj2) = aadj1;
+ word0(&aadj2) += (2*P+1)*Exp_msk1 - y;
+ aadj1 = dval(&aadj2);
+ adj.d = aadj1 * ulp(&rv);
+ dval(&rv) += adj.d;
+ if (rv.d == 0.)
#ifdef NO_STRTOD_BIGCOMP
- goto undfl;
+ goto undfl;
#else
- {
- if (bc.nd > nd)
- bc.dsign = 1;
- break;
- }
-#endif
- }
- else {
- adj.d = aadj1 * ulp(&rv);
- dval(&rv) += adj.d;
- }
+ {
+ if (bc.nd > nd)
+ bc.dsign = 1;
+ break;
+ }
+#endif
+ }
+ else {
+ adj.d = aadj1 * ulp(&rv);
+ dval(&rv) += adj.d;
+ }
#else
#ifdef Sudden_Underflow
- if ((word0(&rv) & Exp_mask) <= P*Exp_msk1) {
- dval(&rv0) = dval(&rv);
- word0(&rv) += P*Exp_msk1;
- adj.d = aadj1 * ulp(&rv);
- dval(&rv) += adj.d;
+ if ((word0(&rv) & Exp_mask) <= P*Exp_msk1) {
+ dval(&rv0) = dval(&rv);
+ word0(&rv) += P*Exp_msk1;
+ adj.d = aadj1 * ulp(&rv);
+ dval(&rv) += adj.d;
#ifdef IBM
- if ((word0(&rv) & Exp_mask) < P*Exp_msk1)
+ if ((word0(&rv) & Exp_mask) < P*Exp_msk1)
#else
- if ((word0(&rv) & Exp_mask) <= P*Exp_msk1)
-#endif
- {
- if (word0(&rv0) == Tiny0
- && word1(&rv0) == Tiny1) {
- if (bc.nd >nd) {
- bc.uflchk = 1;
- break;
- }
- goto undfl;
- }
- word0(&rv) = Tiny0;
- word1(&rv) = Tiny1;
- goto cont;
- }
- else
- word0(&rv) -= P*Exp_msk1;
- }
- else {
- adj.d = aadj1 * ulp(&rv);
- dval(&rv) += adj.d;
- }
+ if ((word0(&rv) & Exp_mask) <= P*Exp_msk1)
+#endif
+ {
+ if (word0(&rv0) == Tiny0
+ && word1(&rv0) == Tiny1) {
+ if (bc.nd >nd) {
+ bc.uflchk = 1;
+ break;
+ }
+ goto undfl;
+ }
+ word0(&rv) = Tiny0;
+ word1(&rv) = Tiny1;
+ goto cont;
+ }
+ else
+ word0(&rv) -= P*Exp_msk1;
+ }
+ else {
+ adj.d = aadj1 * ulp(&rv);
+ dval(&rv) += adj.d;
+ }
#else /*Sudden_Underflow*/
- /* Compute adj so that the IEEE rounding rules will
- * correctly round rv + adj in some half-way cases.
- * If rv * ulp(rv) is denormalized (i.e.,
- * y <= (P-1)*Exp_msk1), we must adjust aadj to avoid
- * trouble from bits lost to denormalization;
- * example: 1.2e-307 .
- */
- if (y <= (P-1)*Exp_msk1 && aadj > 1.) {
- aadj1 = (double)(int)(aadj + 0.5);
- if (!bc.dsign)
- aadj1 = -aadj1;
- }
- adj.d = aadj1 * ulp(&rv);
- dval(&rv) += adj.d;
+ /* Compute adj so that the IEEE rounding rules will
+ * correctly round rv + adj in some half-way cases.
+ * If rv * ulp(rv) is denormalized (i.e.,
+ * y <= (P-1)*Exp_msk1), we must adjust aadj to avoid
+ * trouble from bits lost to denormalization;
+ * example: 1.2e-307 .
+ */
+ if (y <= (P-1)*Exp_msk1 && aadj > 1.) {
+ aadj1 = (double)(int)(aadj + 0.5);
+ if (!bc.dsign)
+ aadj1 = -aadj1;
+ }
+ adj.d = aadj1 * ulp(&rv);
+ dval(&rv) += adj.d;
#endif /*Sudden_Underflow*/
#endif /*Avoid_Underflow*/
- }
- z = word0(&rv) & Exp_mask;
+ }
+ z = word0(&rv) & Exp_mask;
#ifndef SET_INEXACT
- if (bc.nd == nd) {
+ if (bc.nd == nd) {
#ifdef Avoid_Underflow
- if (!bc.scale)
-#endif
- if (y == z) {
- /* Can we stop now? */
- L = (Long)aadj;
- aadj -= L;
- /* The tolerances below are conservative. */
- if (bc.dsign || word1(&rv) || word0(&rv) & Bndry_mask) {
- if (aadj < .4999999 || aadj > .5000001)
- break;
- }
- else if (aadj < .4999999/FLT_RADIX)
- break;
- }
- }
+ if (!bc.scale)
+#endif
+ if (y == z) {
+ /* Can we stop now? */
+ L = (Long)aadj;
+ aadj -= L;
+ /* The tolerances below are conservative. */
+ if (bc.dsign || word1(&rv) || word0(&rv) & Bndry_mask) {
+ if (aadj < .4999999 || aadj > .5000001)
+ break;
+ }
+ else if (aadj < .4999999/FLT_RADIX)
+ break;
+ }
+ }
#endif
cont:
- Bfree(bb);
- Bfree(bd);
- Bfree(bs);
- Bfree(delta);
- }
- Bfree(bb);
- Bfree(bd);
- Bfree(bs);
- Bfree(bd0);
- Bfree(delta);
+ Bfree(bb);
+ Bfree(bd);
+ Bfree(bs);
+ Bfree(delta);
+ }
+ Bfree(bb);
+ Bfree(bd);
+ Bfree(bs);
+ Bfree(bd0);
+ Bfree(delta);
#ifndef NO_STRTOD_BIGCOMP
- if (req_bigcomp) {
- bd0 = 0;
- bc.e0 += nz1;
- bigcomp(&rv, s0, &bc);
- y = word0(&rv) & Exp_mask;
- if (y == Exp_mask)
- goto ovfl;
- if (y == 0 && rv.d == 0.)
- goto undfl;
- }
+ if (req_bigcomp) {
+ bd0 = 0;
+ bc.e0 += nz1;
+ bigcomp(&rv, s0, &bc);
+ y = word0(&rv) & Exp_mask;
+ if (y == Exp_mask)
+ goto ovfl;
+ if (y == 0 && rv.d == 0.)
+ goto undfl;
+ }
#endif
#ifdef SET_INEXACT
- if (bc.inexact) {
- if (!oldinexact) {
- word0(&rv0) = Exp_1 + (70 << Exp_shift);
- word1(&rv0) = 0;
- dval(&rv0) += 1.;
- }
- }
- else if (!oldinexact)
- clear_inexact();
+ if (bc.inexact) {
+ if (!oldinexact) {
+ word0(&rv0) = Exp_1 + (70 << Exp_shift);
+ word1(&rv0) = 0;
+ dval(&rv0) += 1.;
+ }
+ }
+ else if (!oldinexact)
+ clear_inexact();
#endif
#ifdef Avoid_Underflow
- if (bc.scale) {
- word0(&rv0) = Exp_1 - 2*P*Exp_msk1;
- word1(&rv0) = 0;
- dval(&rv) *= dval(&rv0);
+ if (bc.scale) {
+ word0(&rv0) = Exp_1 - 2*P*Exp_msk1;
+ word1(&rv0) = 0;
+ dval(&rv) *= dval(&rv0);
#ifndef NO_ERRNO
- /* try to avoid the bug of testing an 8087 register value */
+ /* try to avoid the bug of testing an 8087 register value */
#ifdef IEEE_Arith
- if (!(word0(&rv) & Exp_mask))
+ if (!(word0(&rv) & Exp_mask))
#else
- if (word0(&rv) == 0 && word1(&rv) == 0)
+ if (word0(&rv) == 0 && word1(&rv) == 0)
#endif
- errno = ERANGE;
+ errno = ERANGE;
#endif
- }
+ }
#endif /* Avoid_Underflow */
#ifdef SET_INEXACT
- if (bc.inexact && !(word0(&rv) & Exp_mask)) {
- /* set underflow bit */
- dval(&rv0) = 1e-300;
- dval(&rv0) *= dval(&rv0);
- }
+ if (bc.inexact && !(word0(&rv) & Exp_mask)) {
+ /* set underflow bit */
+ dval(&rv0) = 1e-300;
+ dval(&rv0) *= dval(&rv0);
+ }
#endif
ret:
- if (se)
- *se = (char *)s;
- return sign ? -dval(&rv) : dval(&rv);
- }
+ if (se)
+ *se = (const char *)s; // Ren/C: fix cast away of const
+ return sign ? -dval(&rv) : dval(&rv);
+ }
#ifndef MULTIPLE_THREADS
static char *dtoa_result;
@@ -3567,26 +3574,26 @@ strtod
static char *
#ifdef KR_headers
-rv_alloc(i) int i;
+rv_alloc(i) size_t i; // !!! Ren/C: (int => size_t) for -Wsign-compare
#else
-rv_alloc(int i)
+rv_alloc(size_t i) // !!! Ren/C: (int => size_t) for -Wsign-compare
#endif
{
- int j, k, *r;
-
- j = sizeof(ULong);
- for(k = 0;
- sizeof(Bigint) - sizeof(ULong) - sizeof(int) + j <= i;
- j <<= 1)
- k++;
- r = (int*)Balloc(k);
- *r = k;
- return
+ int j, k, *r;
+
+ j = sizeof(ULong);
+ for(k = 0;
+ sizeof(Bigint) - sizeof(ULong) - sizeof(int) + j <= i;
+ j <<= 1)
+ k++;
+ r = (int*)Balloc(k);
+ *r = k;
+ return
#ifndef MULTIPLE_THREADS
- dtoa_result =
+ dtoa_result =
#endif
- (char *)(r+1);
- }
+ (char *)(r+1);
+ }
static char *
#ifdef KR_headers
@@ -3595,14 +3602,14 @@ nrv_alloc(s, rve, n) char *s, **rve; int n;
nrv_alloc(const char *s, char **rve, int n)
#endif
{
- char *rv, *t;
+ char *rv, *t;
- t = rv = rv_alloc(n);
- while((*t = *s++)) t++;
- if (rve)
- *rve = t;
- return rv;
- }
+ t = rv = rv_alloc(n);
+ while((*t = *s++)) t++;
+ if (rve)
+ *rve = t;
+ return rv;
+ }
/* freedtoa(s) must be used to free values s returned by dtoa
* when MULTIPLE_THREADS is #defined. It should be used in all cases,
@@ -3617,14 +3624,14 @@ freedtoa(s) char *s;
freedtoa(char *s)
#endif
{
- Bigint *b = (Bigint *)((int *)s - 1);
- b->maxwds = 1 << (b->k = *(int*)b);
- Bfree(b);
+ Bigint *b = (Bigint *)((int *)s - 1);
+ b->maxwds = 1 << (b->k = *(int*)b);
+ Bfree(b);
#ifndef MULTIPLE_THREADS
- if (s == dtoa_result)
- dtoa_result = 0;
+ if (s == dtoa_result)
+ dtoa_result = 0;
#endif
- }
+ }
/* dtoa for IEEE arithmetic (dmg): convert double to ASCII string.
*
@@ -3632,743 +3639,743 @@ freedtoa(char *s)
* Guy L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, pp. 112-126].
*
* Modifications:
- * 1. Rather than iterating, we use a simple numeric overestimate
- * to determine k = floor(log10(d)). We scale relevant
- * quantities using O(log2(k)) rather than O(k) multiplications.
- * 2. For some modes > 2 (corresponding to ecvt and fcvt), we don't
- * try to generate digits strictly left to right. Instead, we
- * compute with fewer bits and propagate the carry if necessary
- * when rounding the final digit up. This is often faster.
- * 3. Under the assumption that input will be rounded nearest,
- * mode 0 renders 1e23 as 1e23 rather than 9.999999999999999e22.
- * That is, we allow equality in stopping tests when the
- * round-nearest rule will give the same floating-point value
- * as would satisfaction of the stopping test with strict
- * inequality.
- * 4. We remove common factors of powers of 2 from relevant
- * quantities.
- * 5. When converting floating-point integers less than 1e16,
- * we use floating-point arithmetic rather than resorting
- * to multiple-precision integers.
- * 6. When asked to produce fewer than 15 digits, we first try
- * to get by with floating-point arithmetic; we resort to
- * multiple-precision integer arithmetic only if we cannot
- * guarantee that the floating-point calculation has given
- * the correctly rounded result. For k requested digits and
- * "uniformly" distributed input, the probability is
- * something like 10^(k-15) that we must resort to the Long
- * calculation.
+ * 1. Rather than iterating, we use a simple numeric overestimate
+ * to determine k = floor(log10(d)). We scale relevant
+ * quantities using O(log2(k)) rather than O(k) multiplications.
+ * 2. For some modes > 2 (corresponding to ecvt and fcvt), we don't
+ * try to generate digits strictly left to right. Instead, we
+ * compute with fewer bits and propagate the carry if necessary
+ * when rounding the final digit up. This is often faster.
+ * 3. Under the assumption that input will be rounded nearest,
+ * mode 0 renders 1e23 as 1e23 rather than 9.999999999999999e22.
+ * That is, we allow equality in stopping tests when the
+ * round-nearest rule will give the same floating-point value
+ * as would satisfaction of the stopping test with strict
+ * inequality.
+ * 4. We remove common factors of powers of 2 from relevant
+ * quantities.
+ * 5. When converting floating-point integers less than 1e16,
+ * we use floating-point arithmetic rather than resorting
+ * to multiple-precision integers.
+ * 6. When asked to produce fewer than 15 digits, we first try
+ * to get by with floating-point arithmetic; we resort to
+ * multiple-precision integer arithmetic only if we cannot
+ * guarantee that the floating-point calculation has given
+ * the correctly rounded result. For k requested digits and
+ * "uniformly" distributed input, the probability is
+ * something like 10^(k-15) that we must resort to the Long
+ * calculation.
*/
char *
dtoa
#ifdef KR_headers
- (dd, mode, ndigits, decpt, sign, rve)
- double dd; int mode, ndigits, *decpt, *sign; char **rve;
+ (dd, mode, ndigits, decpt, sign, rve)
+ double dd; int mode, ndigits, *decpt, *sign; char **rve;
#else
- (double dd, int mode, int ndigits, int *decpt, int *sign, char **rve)
+ (double dd, int mode, int ndigits, int *decpt, int *sign, char **rve)
#endif
{
- /* Arguments ndigits, decpt, sign are similar to those
- of ecvt and fcvt; trailing zeros are suppressed from
- the returned string. If not null, *rve is set to point
- to the end of the return value. If d is +-Infinity or NaN,
- then *decpt is set to 9999.
-
- mode:
- 0 ==> shortest string that yields d when read in
- and rounded to nearest.
- 1 ==> like 0, but with Steele & White stopping rule;
- e.g. with IEEE P754 arithmetic , mode 0 gives
- 1e23 whereas mode 1 gives 9.999999999999999e22.
- 2 ==> max(1,ndigits) significant digits. This gives a
- return value similar to that of ecvt, except
- that trailing zeros are suppressed.
- 3 ==> through ndigits past the decimal point. This
- gives a return value similar to that from fcvt,
- except that trailing zeros are suppressed, and
- ndigits can be negative.
- 4,5 ==> similar to 2 and 3, respectively, but (in
- round-nearest mode) with the tests of mode 0 to
- possibly return a shorter string that rounds to d.
- With IEEE arithmetic and compilation with
- -DHonor_FLT_ROUNDS, modes 4 and 5 behave the same
- as modes 2 and 3 when FLT_ROUNDS != 1.
- 6-9 ==> Debugging modes similar to mode - 4: don't try
- fast floating-point estimate (if applicable).
-
- Values of mode other than 0-9 are treated as mode 0.
-
- Sufficient space is allocated to the return value
- to hold the suppressed trailing zeros.
- */
-
- int bbits, b2, b5, be, dig, i, ieps, ilim, ilim0, ilim1,
- j, j1, k, k0, k_check, leftright, m2, m5, s2, s5,
- spec_case, try_quick;
- Long L;
+ /* Arguments ndigits, decpt, sign are similar to those
+ of ecvt and fcvt; trailing zeros are suppressed from
+ the returned string. If not null, *rve is set to point
+ to the end of the return value. If d is +-Infinity or NaN,
+ then *decpt is set to 9999.
+
+ mode:
+ 0 ==> shortest string that yields d when read in
+ and rounded to nearest.
+ 1 ==> like 0, but with Steele & White stopping rule;
+ e.g. with IEEE P754 arithmetic , mode 0 gives
+ 1e23 whereas mode 1 gives 9.999999999999999e22.
+ 2 ==> max(1,ndigits) significant digits. This gives a
+ return value similar to that of ecvt, except
+ that trailing zeros are suppressed.
+ 3 ==> through ndigits past the decimal point. This
+ gives a return value similar to that from fcvt,
+ except that trailing zeros are suppressed, and
+ ndigits can be negative.
+ 4,5 ==> similar to 2 and 3, respectively, but (in
+ round-nearest mode) with the tests of mode 0 to
+ possibly return a shorter string that rounds to d.
+ With IEEE arithmetic and compilation with
+ -DHonor_FLT_ROUNDS, modes 4 and 5 behave the same
+ as modes 2 and 3 when FLT_ROUNDS != 1.
+ 6-9 ==> Debugging modes similar to mode - 4: don't try
+ fast floating-point estimate (if applicable).
+
+ Values of mode other than 0-9 are treated as mode 0.
+
+ Sufficient space is allocated to the return value
+ to hold the suppressed trailing zeros.
+ */
+
+ int bbits, b2, b5, be, dig, i, ieps, ilim, ilim0, ilim1,
+ j, j1, k, k0, k_check, leftright, m2, m5, s2, s5,
+ spec_case, try_quick;
+ Long L;
#ifndef Sudden_Underflow
- int denorm;
- ULong x;
+ int denorm;
+ ULong x;
#endif
- Bigint *b, *b1, *delta, *mlo, *mhi, *S;
- U d2, eps, u;
- double ds;
- char *s, *s0;
+ Bigint *b, *b1, *delta, *mlo, *mhi, *S;
+ U d2, eps, u;
+ double ds;
+ char *s, *s0;
#ifndef No_leftright
#ifdef IEEE_Arith
- U eps1;
+ U eps1;
#endif
#endif
#ifdef SET_INEXACT
- int inexact, oldinexact;
+ int inexact, oldinexact;
#endif
#ifdef Honor_FLT_ROUNDS /*{*/
- int Rounding;
+ int Rounding;
#ifdef Trust_FLT_ROUNDS /*{{ only define this if FLT_ROUNDS really works! */
- Rounding = Flt_Rounds;
+ Rounding = Flt_Rounds;
#else /*}{*/
- Rounding = 1;
- switch(fegetround()) {
- case FE_TOWARDZERO: Rounding = 0; break;
- case FE_UPWARD: Rounding = 2; break;
- case FE_DOWNWARD: Rounding = 3;
- }
+ Rounding = 1;
+ switch(fegetround()) {
+ case FE_TOWARDZERO: Rounding = 0; break;
+ case FE_UPWARD: Rounding = 2; break;
+ case FE_DOWNWARD: Rounding = 3;
+ }
#endif /*}}*/
#endif /*}*/
#ifndef MULTIPLE_THREADS
- if (dtoa_result) {
- freedtoa(dtoa_result);
- dtoa_result = 0;
- }
+ if (dtoa_result) {
+ freedtoa(dtoa_result);
+ dtoa_result = 0;
+ }
#endif
- u.d = dd;
- if (word0(&u) & Sign_bit) {
- /* set sign for everything, including 0's and NaNs */
- *sign = 1;
- word0(&u) &= ~Sign_bit; /* clear sign bit */
- }
- else
- *sign = 0;
+ u.d = dd;
+ if (word0(&u) & Sign_bit) {
+ /* set sign for everything, including 0's and NaNs */
+ *sign = 1;
+ word0(&u) &= ~Sign_bit; /* clear sign bit */
+ }
+ else
+ *sign = 0;
#if defined(IEEE_Arith) + defined(VAX)
#ifdef IEEE_Arith
- if ((word0(&u) & Exp_mask) == Exp_mask)
+ if ((word0(&u) & Exp_mask) == Exp_mask)
#else
- if (word0(&u) == 0x8000)
+ if (word0(&u) == 0x8000)
#endif
- {
- /* Infinity or NaN */
- *decpt = 9999;
+ {
+ /* Infinity or NaN */
+ *decpt = 9999;
#ifdef IEEE_Arith
- if (!word1(&u) && !(word0(&u) & 0xfffff))
- return nrv_alloc("Infinity", rve, 8);
+ if (!word1(&u) && !(word0(&u) & 0xfffff))
+ return nrv_alloc("Infinity", rve, 8);
#endif
- return nrv_alloc("NaN", rve, 3);
- }
+ return nrv_alloc("NaN", rve, 3);
+ }
#endif
#ifdef IBM
- dval(&u) += 0; /* normalize */
+ dval(&u) += 0; /* normalize */
#endif
- if (!dval(&u)) {
- *decpt = 1;
- return nrv_alloc("0", rve, 1);
- }
+ if (!dval(&u)) {
+ *decpt = 1;
+ return nrv_alloc("0", rve, 1);
+ }
#ifdef SET_INEXACT
- try_quick = oldinexact = get_inexact();
- inexact = 1;
+ try_quick = oldinexact = get_inexact();
+ inexact = 1;
#endif
#ifdef Honor_FLT_ROUNDS
- if (Rounding >= 2) {
- if (*sign)
- Rounding = Rounding == 2 ? 0 : 2;
- else
- if (Rounding != 2)
- Rounding = 0;
- }
+ if (Rounding >= 2) {
+ if (*sign)
+ Rounding = Rounding == 2 ? 0 : 2;
+ else
+ if (Rounding != 2)
+ Rounding = 0;
+ }
#endif
- b = d2b(&u, &be, &bbits);
+ b = d2b(&u, &be, &bbits);
#ifdef Sudden_Underflow
- i = (int)(word0(&u) >> Exp_shift1 & (Exp_mask>>Exp_shift1));
+ i = (int)(word0(&u) >> Exp_shift1 & (Exp_mask>>Exp_shift1));
#else
- if ((i = (int)(word0(&u) >> Exp_shift1 & (Exp_mask>>Exp_shift1)))) {
+ if ((i = (int)(word0(&u) >> Exp_shift1 & (Exp_mask>>Exp_shift1)))) {
#endif
- dval(&d2) = dval(&u);
- word0(&d2) &= Frac_mask1;
- word0(&d2) |= Exp_11;
+ dval(&d2) = dval(&u);
+ word0(&d2) &= Frac_mask1;
+ word0(&d2) |= Exp_11;
#ifdef IBM
- if (j = 11 - hi0bits(word0(&d2) & Frac_mask))
- dval(&d2) /= 1 << j;
-#endif
-
- /* log(x) ~=~ log(1.5) + (x-1.5)/1.5
- * log10(x) = log(x) / log(10)
- * ~=~ log(1.5)/log(10) + (x-1.5)/(1.5*log(10))
- * log10(d) = (i-Bias)*log(2)/log(10) + log10(d2)
- *
- * This suggests computing an approximation k to log10(d) by
- *
- * k = (i - Bias)*0.301029995663981
- * + ( (d2-1.5)*0.289529654602168 + 0.176091259055681 );
- *
- * We want k to be too large rather than too small.
- * The error in the first-order Taylor series approximation
- * is in our favor, so we just round up the constant enough
- * to compensate for any error in the multiplication of
- * (i - Bias) by 0.301029995663981; since |i - Bias| <= 1077,
- * and 1077 * 0.30103 * 2^-52 ~=~ 7.2e-14,
- * adding 1e-13 to the constant term more than suffices.
- * Hence we adjust the constant term to 0.1760912590558.
- * (We could get a more accurate k by invoking log10,
- * but this is probably not worthwhile.)
- */
-
- i -= Bias;
+ if (j = 11 - hi0bits(word0(&d2) & Frac_mask))
+ dval(&d2) /= 1 << j;
+#endif
+
+ /* log(x) ~=~ log(1.5) + (x-1.5)/1.5
+ * log10(x) = log(x) / log(10)
+ * ~=~ log(1.5)/log(10) + (x-1.5)/(1.5*log(10))
+ * log10(d) = (i-Bias)*log(2)/log(10) + log10(d2)
+ *
+ * This suggests computing an approximation k to log10(d) by
+ *
+ * k = (i - Bias)*0.301029995663981
+ * + ( (d2-1.5)*0.289529654602168 + 0.176091259055681 );
+ *
+ * We want k to be too large rather than too small.
+ * The error in the first-order Taylor series approximation
+ * is in our favor, so we just round up the constant enough
+ * to compensate for any error in the multiplication of
+ * (i - Bias) by 0.301029995663981; since |i - Bias| <= 1077,
+ * and 1077 * 0.30103 * 2^-52 ~=~ 7.2e-14,
+ * adding 1e-13 to the constant term more than suffices.
+ * Hence we adjust the constant term to 0.1760912590558.
+ * (We could get a more accurate k by invoking log10,
+ * but this is probably not worthwhile.)
+ */
+
+ i -= Bias;
#ifdef IBM
- i <<= 2;
- i += j;
+ i <<= 2;
+ i += j;
#endif
#ifndef Sudden_Underflow
- denorm = 0;
- }
- else {
- /* d is denormalized */
-
- i = bbits + be + (Bias + (P-1) - 1);
- x = i > 32 ? word0(&u) << (64 - i) | word1(&u) >> (i - 32)
- : word1(&u) << (32 - i);
- dval(&d2) = x;
- word0(&d2) -= 31*Exp_msk1; /* adjust exponent */
- i -= (Bias + (P-1) - 1) + 1;
- denorm = 1;
- }
-#endif
- ds = (dval(&d2)-1.5)*0.289529654602168 + 0.1760912590558 + i*0.301029995663981;
- k = (int)ds;
- if (ds < 0. && ds != k)
- k--; /* want k = floor(ds) */
- k_check = 1;
- if (k >= 0 && k <= Ten_pmax) {
- if (dval(&u) < tens[k])
- k--;
- k_check = 0;
- }
- j = bbits - i - 1;
- if (j >= 0) {
- b2 = 0;
- s2 = j;
- }
- else {
- b2 = -j;
- s2 = 0;
- }
- if (k >= 0) {
- b5 = 0;
- s5 = k;
- s2 += k;
- }
- else {
- b2 -= k;
- b5 = -k;
- s5 = 0;
- }
- if (mode < 0 || mode > 9)
- mode = 0;
+ denorm = 0;
+ }
+ else {
+ /* d is denormalized */
+
+ i = bbits + be + (Bias + (P-1) - 1);
+ x = i > 32 ? word0(&u) << (64 - i) | word1(&u) >> (i - 32)
+ : word1(&u) << (32 - i);
+ dval(&d2) = x;
+ word0(&d2) -= 31*Exp_msk1; /* adjust exponent */
+ i -= (Bias + (P-1) - 1) + 1;
+ denorm = 1;
+ }
+#endif
+ ds = (dval(&d2)-1.5)*0.289529654602168 + 0.1760912590558 + i*0.301029995663981;
+ k = (int)ds;
+ if (ds < 0. && ds != k)
+ k--; /* want k = floor(ds) */
+ k_check = 1;
+ if (k >= 0 && k <= Ten_pmax) {
+ if (dval(&u) < tens[k])
+ k--;
+ k_check = 0;
+ }
+ j = bbits - i - 1;
+ if (j >= 0) {
+ b2 = 0;
+ s2 = j;
+ }
+ else {
+ b2 = -j;
+ s2 = 0;
+ }
+ if (k >= 0) {
+ b5 = 0;
+ s5 = k;
+ s2 += k;
+ }
+ else {
+ b2 -= k;
+ b5 = -k;
+ s5 = 0;
+ }
+ if (mode < 0 || mode > 9)
+ mode = 0;
#ifndef SET_INEXACT
#ifdef Check_FLT_ROUNDS
- try_quick = Rounding == 1;
+ try_quick = Rounding == 1;
#else
- try_quick = 1;
+ try_quick = 1;
#endif
#endif /*SET_INEXACT*/
- if (mode > 5) {
- mode -= 4;
- try_quick = 0;
- }
- leftright = 1;
- ilim = ilim1 = -1; /* Values for cases 0 and 1; done here to */
- /* silence erroneous "gcc -Wall" warning. */
- switch(mode) {
- case 0:
- case 1:
- i = 18;
- ndigits = 0;
- break;
- case 2:
- leftright = 0;
- /* no break */
- case 4:
- if (ndigits <= 0)
- ndigits = 1;
- ilim = ilim1 = i = ndigits;
- break;
- case 3:
- leftright = 0;
- /* no break */
- case 5:
- i = ndigits + k + 1;
- ilim = i;
- ilim1 = i - 1;
- if (i <= 0)
- i = 1;
- }
- s = s0 = rv_alloc(i);
+ if (mode > 5) {
+ mode -= 4;
+ try_quick = 0;
+ }
+ leftright = 1;
+ ilim = ilim1 = -1; /* Values for cases 0 and 1; done here to */
+ /* silence erroneous "gcc -Wall" warning. */
+ switch(mode) {
+ case 0:
+ case 1:
+ i = 18;
+ ndigits = 0;
+ break;
+ case 2:
+ leftright = 0;
+ /* no break */
+ case 4:
+ if (ndigits <= 0)
+ ndigits = 1;
+ ilim = ilim1 = i = ndigits;
+ break;
+ case 3:
+ leftright = 0;
+ /* no break */
+ case 5:
+ i = ndigits + k + 1;
+ ilim = i;
+ ilim1 = i - 1;
+ if (i <= 0)
+ i = 1;
+ }
+ s = s0 = rv_alloc(i);
#ifdef Honor_FLT_ROUNDS
- if (mode > 1 && Rounding != 1)
- leftright = 0;
-#endif
-
- if (ilim >= 0 && ilim <= Quick_max && try_quick) {
-
- /* Try to get by with floating-point arithmetic. */
-
- i = 0;
- dval(&d2) = dval(&u);
- k0 = k;
- ilim0 = ilim;
- ieps = 2; /* conservative */
- if (k > 0) {
- ds = tens[k&0xf];
- j = k >> 4;
- if (j & Bletch) {
- /* prevent overflows */
- j &= Bletch - 1;
- dval(&u) /= bigtens[n_bigtens-1];
- ieps++;
- }
- for(; j; j >>= 1, i++)
- if (j & 1) {
- ieps++;
- ds *= bigtens[i];
- }
- dval(&u) /= ds;
- }
- else if ((j1 = -k)) {
- dval(&u) *= tens[j1 & 0xf];
- for(j = j1 >> 4; j; j >>= 1, i++)
- if (j & 1) {
- ieps++;
- dval(&u) *= bigtens[i];
- }
- }
- if (k_check && dval(&u) < 1. && ilim > 0) {
- if (ilim1 <= 0)
- goto fast_failed;
- ilim = ilim1;
- k--;
- dval(&u) *= 10.;
- ieps++;
- }
- dval(&eps) = ieps*dval(&u) + 7.;
- word0(&eps) -= (P-1)*Exp_msk1;
- if (ilim == 0) {
- S = mhi = 0;
- dval(&u) -= 5.;
- if (dval(&u) > dval(&eps))
- goto one_digit;
- if (dval(&u) < -dval(&eps))
- goto no_digits;
- goto fast_failed;
- }
+ if (mode > 1 && Rounding != 1)
+ leftright = 0;
+#endif
+
+ if (ilim >= 0 && ilim <= Quick_max && try_quick) {
+
+ /* Try to get by with floating-point arithmetic. */
+
+ i = 0;
+ dval(&d2) = dval(&u);
+ k0 = k;
+ ilim0 = ilim;
+ ieps = 2; /* conservative */
+ if (k > 0) {
+ ds = tens[k&0xf];
+ j = k >> 4;
+ if (j & Bletch) {
+ /* prevent overflows */
+ j &= Bletch - 1;
+ dval(&u) /= bigtens[n_bigtens-1];
+ ieps++;
+ }
+ for(; j; j >>= 1, i++)
+ if (j & 1) {
+ ieps++;
+ ds *= bigtens[i];
+ }
+ dval(&u) /= ds;
+ }
+ else if ((j1 = -k)) {
+ dval(&u) *= tens[j1 & 0xf];
+ for(j = j1 >> 4; j; j >>= 1, i++)
+ if (j & 1) {
+ ieps++;
+ dval(&u) *= bigtens[i];
+ }
+ }
+ if (k_check && dval(&u) < 1. && ilim > 0) {
+ if (ilim1 <= 0)
+ goto fast_failed;
+ ilim = ilim1;
+ k--;
+ dval(&u) *= 10.;
+ ieps++;
+ }
+ dval(&eps) = ieps*dval(&u) + 7.;
+ word0(&eps) -= (P-1)*Exp_msk1;
+ if (ilim == 0) {
+ S = mhi = 0;
+ dval(&u) -= 5.;
+ if (dval(&u) > dval(&eps))
+ goto one_digit;
+ if (dval(&u) < -dval(&eps))
+ goto no_digits;
+ goto fast_failed;
+ }
#ifndef No_leftright
- if (leftright) {
- /* Use Steele & White method of only
- * generating digits needed.
- */
- dval(&eps) = 0.5/tens[ilim-1] - dval(&eps);
+ if (leftright) {
+ /* Use Steele & White method of only
+ * generating digits needed.
+ */
+ dval(&eps) = 0.5/tens[ilim-1] - dval(&eps);
#ifdef IEEE_Arith
- if (k0 < 0 && j1 >= 307) {
- eps1.d = 1.01e256; /* 1.01 allows roundoff in the next few lines */
- word0(&eps1) -= Exp_msk1 * (Bias+P-1);
- dval(&eps1) *= tens[j1 & 0xf];
- for(i = 0, j = (j1-256) >> 4; j; j >>= 1, i++)
- if (j & 1)
- dval(&eps1) *= bigtens[i];
- if (eps.d < eps1.d)
- eps.d = eps1.d;
- }
-#endif
- for(i = 0;;) {
- L = dval(&u);
- dval(&u) -= L;
- *s++ = '0' + (int)L;
- if (1. - dval(&u) < dval(&eps))
- goto bump_up;
- if (dval(&u) < dval(&eps))
- goto ret1;
- if (++i >= ilim)
- break;
- dval(&eps) *= 10.;
- dval(&u) *= 10.;
- }
- }
- else {
-#endif
- /* Generate ilim digits, then fix them up. */
- dval(&eps) *= tens[ilim-1];
- for(i = 1;; i++, dval(&u) *= 10.) {
- L = (Long)(dval(&u));
- if (!(dval(&u) -= L))
- ilim = i;
- *s++ = '0' + (int)L;
- if (i == ilim) {
- if (dval(&u) > 0.5 + dval(&eps))
- goto bump_up;
- else if (dval(&u) < 0.5 - dval(&eps)) {
- while(*--s == '0');
- s++;
- goto ret1;
- }
- break;
- }
- }
+ if (k0 < 0 && j1 >= 307) {
+ eps1.d = 1.01e256; /* 1.01 allows roundoff in the next few lines */
+ word0(&eps1) -= Exp_msk1 * (Bias+P-1);
+ dval(&eps1) *= tens[j1 & 0xf];
+ for(i = 0, j = (j1-256) >> 4; j; j >>= 1, i++)
+ if (j & 1)
+ dval(&eps1) *= bigtens[i];
+ if (eps.d < eps1.d)
+ eps.d = eps1.d;
+ }
+#endif
+ for(i = 0;;) {
+ L = dval(&u);
+ dval(&u) -= L;
+ *s++ = '0' + (int)L;
+ if (1. - dval(&u) < dval(&eps))
+ goto bump_up;
+ if (dval(&u) < dval(&eps))
+ goto ret1;
+ if (++i >= ilim)
+ break;
+ dval(&eps) *= 10.;
+ dval(&u) *= 10.;
+ }
+ }
+ else {
+#endif
+ /* Generate ilim digits, then fix them up. */
+ dval(&eps) *= tens[ilim-1];
+ for(i = 1;; i++, dval(&u) *= 10.) {
+ L = (Long)(dval(&u));
+ if (!(dval(&u) -= L))
+ ilim = i;
+ *s++ = '0' + (int)L;
+ if (i == ilim) {
+ if (dval(&u) > 0.5 + dval(&eps))
+ goto bump_up;
+ else if (dval(&u) < 0.5 - dval(&eps)) {
+ while(*--s == '0');
+ s++;
+ goto ret1;
+ }
+ break;
+ }
+ }
#ifndef No_leftright
- }
+ }
#endif
fast_failed:
- s = s0;
- dval(&u) = dval(&d2);
- k = k0;
- ilim = ilim0;
- }
-
- /* Do we have a "small" integer? */
-
- if (be >= 0 && k <= Int_max) {
- /* Yes. */
- ds = tens[k];
- if (ndigits < 0 && ilim <= 0) {
- S = mhi = 0;
- if (ilim < 0 || dval(&u) <= 5*ds)
- goto no_digits;
- goto one_digit;
- }
- for(i = 1;; i++, dval(&u) *= 10.) {
- L = (Long)(dval(&u) / ds);
- dval(&u) -= L*ds;
+ s = s0;
+ dval(&u) = dval(&d2);
+ k = k0;
+ ilim = ilim0;
+ }
+
+ /* Do we have a "small" integer? */
+
+ if (be >= 0 && k <= Int_max) {
+ /* Yes. */
+ ds = tens[k];
+ if (ndigits < 0 && ilim <= 0) {
+ S = mhi = 0;
+ if (ilim < 0 || dval(&u) <= 5*ds)
+ goto no_digits;
+ goto one_digit;
+ }
+ for(i = 1;; i++, dval(&u) *= 10.) {
+ L = (Long)(dval(&u) / ds);
+ dval(&u) -= L*ds;
#ifdef Check_FLT_ROUNDS
- /* If FLT_ROUNDS == 2, L will usually be high by 1 */
- if (dval(&u) < 0) {
- L--;
- dval(&u) += ds;
- }
-#endif
- *s++ = '0' + (int)L;
- if (!dval(&u)) {
+ /* If FLT_ROUNDS == 2, L will usually be high by 1 */
+ if (dval(&u) < 0) {
+ L--;
+ dval(&u) += ds;
+ }
+#endif
+ *s++ = '0' + (int)L;
+ if (!dval(&u)) {
#ifdef SET_INEXACT
- inexact = 0;
+ inexact = 0;
#endif
- break;
- }
- if (i == ilim) {
+ break;
+ }
+ if (i == ilim) {
#ifdef Honor_FLT_ROUNDS
- if (mode > 1)
- switch(Rounding) {
- case 0: goto ret1;
- case 2: goto bump_up;
- }
+ if (mode > 1)
+ switch(Rounding) {
+ case 0: goto ret1;
+ case 2: goto bump_up;
+ }
#endif
- dval(&u) += dval(&u);
+ dval(&u) += dval(&u);
#ifdef ROUND_BIASED
- if (dval(&u) >= ds)
+ if (dval(&u) >= ds)
#else
- if (dval(&u) > ds || (dval(&u) == ds && L & 1))
+ if (dval(&u) > ds || (dval(&u) == ds && L & 1))
#endif
- {
+ {
bump_up:
- while(*--s == '9')
- if (s == s0) {
- k++;
- *s = '0';
- break;
- }
- ++*s++;
- }
- break;
- }
- }
- goto ret1;
- }
-
- m2 = b2;
- m5 = b5;
- mhi = mlo = 0;
- if (leftright) {
- i =
+ while(*--s == '9')
+ if (s == s0) {
+ k++;
+ *s = '0';
+ break;
+ }
+ ++*s++;
+ }
+ break;
+ }
+ }
+ goto ret1;
+ }
+
+ m2 = b2;
+ m5 = b5;
+ mhi = mlo = 0;
+ if (leftright) {
+ i =
#ifndef Sudden_Underflow
- denorm ? be + (Bias + (P-1) - 1 + 1) :
+ denorm ? be + (Bias + (P-1) - 1 + 1) :
#endif
#ifdef IBM
- 1 + 4*P - 3 - bbits + ((bbits + be - 1) & 3);
+ 1 + 4*P - 3 - bbits + ((bbits + be - 1) & 3);
#else
- 1 + P - bbits;
-#endif
- b2 += i;
- s2 += i;
- mhi = i2b(1);
- }
- if (m2 > 0 && s2 > 0) {
- i = m2 < s2 ? m2 : s2;
- b2 -= i;
- m2 -= i;
- s2 -= i;
- }
- if (b5 > 0) {
- if (leftright) {
- if (m5 > 0) {
- mhi = pow5mult(mhi, m5);
- b1 = mult(mhi, b);
- Bfree(b);
- b = b1;
- }
- if ((j = b5 - m5))
- b = pow5mult(b, j);
- }
- else
- b = pow5mult(b, b5);
- }
- S = i2b(1);
- if (s5 > 0)
- S = pow5mult(S, s5);
-
- /* Check for special case that d is a normalized power of 2. */
-
- spec_case = 0;
- if ((mode < 2 || leftright)
+ 1 + P - bbits;
+#endif
+ b2 += i;
+ s2 += i;
+ mhi = i2b(1);
+ }
+ if (m2 > 0 && s2 > 0) {
+ i = m2 < s2 ? m2 : s2;
+ b2 -= i;
+ m2 -= i;
+ s2 -= i;
+ }
+ if (b5 > 0) {
+ if (leftright) {
+ if (m5 > 0) {
+ mhi = pow5mult(mhi, m5);
+ b1 = mult(mhi, b);
+ Bfree(b);
+ b = b1;
+ }
+ if ((j = b5 - m5))
+ b = pow5mult(b, j);
+ }
+ else
+ b = pow5mult(b, b5);
+ }
+ S = i2b(1);
+ if (s5 > 0)
+ S = pow5mult(S, s5);
+
+ /* Check for special case that d is a normalized power of 2. */
+
+ spec_case = 0;
+ if ((mode < 2 || leftright)
#ifdef Honor_FLT_ROUNDS
- && Rounding == 1
+ && Rounding == 1
#endif
- ) {
- if (!word1(&u) && !(word0(&u) & Bndry_mask)
+ ) {
+ if (!word1(&u) && !(word0(&u) & Bndry_mask)
#ifndef Sudden_Underflow
- && word0(&u) & (Exp_mask & ~Exp_msk1)
-#endif
- ) {
- /* The special case */
- b2 += Log2P;
- s2 += Log2P;
- spec_case = 1;
- }
- }
-
- /* Arrange for convenient computation of quotients:
- * shift left if necessary so divisor has 4 leading 0 bits.
- *
- * Perhaps we should just compute leading 28 bits of S once
- * and for all and pass them and a shift to quorem, so it
- * can do shifts and ors to compute the numerator for q.
- */
- i = dshift(S, s2);
- b2 += i;
- m2 += i;
- s2 += i;
- if (b2 > 0)
- b = lshift(b, b2);
- if (s2 > 0)
- S = lshift(S, s2);
- if (k_check) {
- if (cmp(b,S) < 0) {
- k--;
- b = multadd(b, 10, 0); /* we botched the k estimate */
- if (leftright)
- mhi = multadd(mhi, 10, 0);
- ilim = ilim1;
- }
- }
- if (ilim <= 0 && (mode == 3 || mode == 5)) {
- if (ilim < 0 || cmp(b,S = multadd(S,5,0)) <= 0) {
- /* no digits, fcvt style */
+ && word0(&u) & (Exp_mask & ~Exp_msk1)
+#endif
+ ) {
+ /* The special case */
+ b2 += Log2P;
+ s2 += Log2P;
+ spec_case = 1;
+ }
+ }
+
+ /* Arrange for convenient computation of quotients:
+ * shift left if necessary so divisor has 4 leading 0 bits.
+ *
+ * Perhaps we should just compute leading 28 bits of S once
+ * and for all and pass them and a shift to quorem, so it
+ * can do shifts and ors to compute the numerator for q.
+ */
+ i = dshift(S, s2);
+ b2 += i;
+ m2 += i;
+ s2 += i;
+ if (b2 > 0)
+ b = lshift(b, b2);
+ if (s2 > 0)
+ S = lshift(S, s2);
+ if (k_check) {
+ if (cmp(b,S) < 0) {
+ k--;
+ b = multadd(b, 10, 0); /* we botched the k estimate */
+ if (leftright)
+ mhi = multadd(mhi, 10, 0);
+ ilim = ilim1;
+ }
+ }
+ if (ilim <= 0 && (mode == 3 || mode == 5)) {
+ if (ilim < 0 || cmp(b,S = multadd(S,5,0)) <= 0) {
+ /* no digits, fcvt style */
no_digits:
- k = -1 - ndigits;
- goto ret;
- }
+ k = -1 - ndigits;
+ goto ret;
+ }
one_digit:
- *s++ = '1';
- k++;
- goto ret;
- }
- if (leftright) {
- if (m2 > 0)
- mhi = lshift(mhi, m2);
-
- /* Compute mlo -- check for special case
- * that d is a normalized power of 2.
- */
-
- mlo = mhi;
- if (spec_case) {
- mhi = Balloc(mhi->k);
- Bcopy(mhi, mlo);
- mhi = lshift(mhi, Log2P);
- }
-
- for(i = 1;;i++) {
- dig = quorem(b,S) + '0';
- /* Do we yet have the shortest decimal string
- * that will round to d?
- */
- j = cmp(b, mlo);
- delta = diff(S, mhi);
- j1 = delta->sign ? 1 : cmp(b, delta);
- Bfree(delta);
+ *s++ = '1';
+ k++;
+ goto ret;
+ }
+ if (leftright) {
+ if (m2 > 0)
+ mhi = lshift(mhi, m2);
+
+ /* Compute mlo -- check for special case
+ * that d is a normalized power of 2.
+ */
+
+ mlo = mhi;
+ if (spec_case) {
+ mhi = Balloc(mhi->k);
+ Bcopy(mhi, mlo);
+ mhi = lshift(mhi, Log2P);
+ }
+
+ for(i = 1;;i++) {
+ dig = quorem(b,S) + '0';
+ /* Do we yet have the shortest decimal string
+ * that will round to d?
+ */
+ j = cmp(b, mlo);
+ delta = diff(S, mhi);
+ j1 = delta->sign ? 1 : cmp(b, delta);
+ Bfree(delta);
#ifndef ROUND_BIASED
- if (j1 == 0 && mode != 1 && !(word1(&u) & 1)
+ if (j1 == 0 && mode != 1 && !(word1(&u) & 1)
#ifdef Honor_FLT_ROUNDS
- && Rounding >= 1
+ && Rounding >= 1
#endif
- ) {
- if (dig == '9')
- goto round_9_up;
- if (j > 0)
- dig++;
+ ) {
+ if (dig == '9')
+ goto round_9_up;
+ if (j > 0)
+ dig++;
#ifdef SET_INEXACT
- else if (!b->x[0] && b->wds <= 1)
- inexact = 0;
+ else if (!b->x[0] && b->wds <= 1)
+ inexact = 0;
#endif
- *s++ = dig;
- goto ret;
- }
+ *s++ = dig;
+ goto ret;
+ }
#endif
- if (j < 0 || (j == 0 && mode != 1
+ if (j < 0 || (j == 0 && mode != 1
#ifndef ROUND_BIASED
- && !(word1(&u) & 1)
+ && !(word1(&u) & 1)
#endif
- )) {
- if (!b->x[0] && b->wds <= 1) {
+ )) {
+ if (!b->x[0] && b->wds <= 1) {
#ifdef SET_INEXACT
- inexact = 0;
+ inexact = 0;
#endif
- goto accept_dig;
- }
+ goto accept_dig;
+ }
#ifdef Honor_FLT_ROUNDS
- if (mode > 1)
- switch(Rounding) {
- case 0: goto accept_dig;
- case 2: goto keep_dig;
- }
+ if (mode > 1)
+ switch(Rounding) {
+ case 0: goto accept_dig;
+ case 2: goto keep_dig;
+ }
#endif /*Honor_FLT_ROUNDS*/
- if (j1 > 0) {
- b = lshift(b, 1);
- j1 = cmp(b, S);
+ if (j1 > 0) {
+ b = lshift(b, 1);
+ j1 = cmp(b, S);
#ifdef ROUND_BIASED
- if (j1 >= 0 /*)*/
+ if (j1 >= 0 /*)*/
#else
- if ((j1 > 0 || (j1 == 0 && dig & 1))
+ if ((j1 > 0 || (j1 == 0 && dig & 1))
#endif
- && dig++ == '9')
- goto round_9_up;
- }
+ && dig++ == '9')
+ goto round_9_up;
+ }
accept_dig:
- *s++ = dig;
- goto ret;
- }
- if (j1 > 0) {
+ *s++ = dig;
+ goto ret;
+ }
+ if (j1 > 0) {
#ifdef Honor_FLT_ROUNDS
- if (!Rounding)
- goto accept_dig;
+ if (!Rounding)
+ goto accept_dig;
#endif
- if (dig == '9') { /* possible if i == 1 */
+ if (dig == '9') { /* possible if i == 1 */
round_9_up:
- *s++ = '9';
- goto roundoff;
- }
- *s++ = dig + 1;
- goto ret;
- }
+ *s++ = '9';
+ goto roundoff;
+ }
+ *s++ = dig + 1;
+ goto ret;
+ }
#ifdef Honor_FLT_ROUNDS
keep_dig:
#endif
- *s++ = dig;
- if (i == ilim)
- break;
- b = multadd(b, 10, 0);
- if (mlo == mhi)
- mlo = mhi = multadd(mhi, 10, 0);
- else {
- mlo = multadd(mlo, 10, 0);
- mhi = multadd(mhi, 10, 0);
- }
- }
- }
- else
- for(i = 1;; i++) {
- *s++ = dig = quorem(b,S) + '0';
- if (!b->x[0] && b->wds <= 1) {
+ *s++ = dig;
+ if (i == ilim)
+ break;
+ b = multadd(b, 10, 0);
+ if (mlo == mhi)
+ mlo = mhi = multadd(mhi, 10, 0);
+ else {
+ mlo = multadd(mlo, 10, 0);
+ mhi = multadd(mhi, 10, 0);
+ }
+ }
+ }
+ else
+ for(i = 1;; i++) {
+ *s++ = dig = quorem(b,S) + '0';
+ if (!b->x[0] && b->wds <= 1) {
#ifdef SET_INEXACT
- inexact = 0;
+ inexact = 0;
#endif
- goto ret;
- }
- if (i >= ilim)
- break;
- b = multadd(b, 10, 0);
- }
+ goto ret;
+ }
+ if (i >= ilim)
+ break;
+ b = multadd(b, 10, 0);
+ }
- /* Round off last digit */
+ /* Round off last digit */
#ifdef Honor_FLT_ROUNDS
- switch(Rounding) {
- case 0: goto trimzeros;
- case 2: goto roundoff;
- }
+ switch(Rounding) {
+ case 0: goto trimzeros;
+ case 2: goto roundoff;
+ }
#endif
- b = lshift(b, 1);
- j = cmp(b, S);
+ b = lshift(b, 1);
+ j = cmp(b, S);
#ifdef ROUND_BIASED
- if (j >= 0)
+ if (j >= 0)
#else
- if (j > 0 || (j == 0 && dig & 1))
+ if (j > 0 || (j == 0 && dig & 1))
#endif
- {
+ {
roundoff:
- while(*--s == '9')
- if (s == s0) {
- k++;
- *s++ = '1';
- goto ret;
- }
- ++*s++;
- }
- else {
+ while(*--s == '9')
+ if (s == s0) {
+ k++;
+ *s++ = '1';
+ goto ret;
+ }
+ ++*s++;
+ }
+ else {
#ifdef Honor_FLT_ROUNDS
trimzeros:
#endif
- while(*--s == '0');
- s++;
- }
+ while(*--s == '0');
+ s++;
+ }
ret:
- Bfree(S);
- if (mhi) {
- if (mlo && mlo != mhi)
- Bfree(mlo);
- Bfree(mhi);
- }
+ Bfree(S);
+ if (mhi) {
+ if (mlo && mlo != mhi)
+ Bfree(mlo);
+ Bfree(mhi);
+ }
ret1:
#ifdef SET_INEXACT
- if (inexact) {
- if (!oldinexact) {
- word0(&u) = Exp_1 + (70 << Exp_shift);
- word1(&u) = 0;
- dval(&u) += 1.;
- }
- }
- else if (!oldinexact)
- clear_inexact();
-#endif
- Bfree(b);
- *s = 0;
- *decpt = k + 1;
- if (rve)
- *rve = s;
- return s0;
- }
+ if (inexact) {
+ if (!oldinexact) {
+ word0(&u) = Exp_1 + (70 << Exp_shift);
+ word1(&u) = 0;
+ dval(&u) += 1.;
+ }
+ }
+ else if (!oldinexact)
+ clear_inexact();
+#endif
+ Bfree(b);
+ *s = 0;
+ *decpt = k + 1;
+ if (rve)
+ *rve = s;
+ return s0;
+ }
#ifdef __cplusplus
}
#endif
diff --git a/src/core/f-enbase.c b/src/core/f-enbase.c
index 10181c64a0..717c311a7b 100644
--- a/src/core/f-enbase.c
+++ b/src/core/f-enbase.c
@@ -1,503 +1,531 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: f-enbase.c
-** Summary: base representation conversions
-** Section: functional
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %f-enbase.c
+// Summary: "base representation conversions"
+// Section: functional
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#include "sys-scan.h"
-/***********************************************************************
-**
-*/ static const REBYTE Debase64[128] =
-/*
-** Base-64 binary decoder table.
-**
-***********************************************************************/
+//
+// Base-64 binary decoder table.
+//
+static const REBYTE Debase64[128] =
{
- #define BIN_ERROR (REBYTE)0x80
- #define BIN_SPACE (REBYTE)0x40
- #define BIN_VALUE (REBYTE)0x3f
- #define IS_BIN_SPACE(c) (Debase64[c] & BIN_SPACE)
-
- /* Control Chars */
- BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR, /* 80 */
- BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR,
- BIN_SPACE,BIN_SPACE,BIN_SPACE,BIN_ERROR,
- BIN_SPACE,BIN_SPACE,BIN_ERROR,BIN_ERROR,
- BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR,
- BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR,
- BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR,
- BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR,
-
- /* 20 */ BIN_SPACE,
- /* 21 ! */ BIN_ERROR,
- /* 22 " */ BIN_ERROR,
- /* 23 # */ BIN_ERROR,
- /* 24 $ */ BIN_ERROR,
- /* 25 % */ BIN_ERROR,
- /* 26 & */ BIN_ERROR,
- /* 27 ' */ BIN_SPACE,
- /* 28 ( */ BIN_ERROR,
- /* 29 ) */ BIN_ERROR,
- /* 2A * */ BIN_ERROR,
- /* 2B + */ 62,
- /* 2C , */ BIN_ERROR,
- /* 2D - */ BIN_ERROR,
- /* 2E . */ BIN_ERROR,
- /* 2F / */ 63,
-
- /* 30 0 */ 52,
- /* 31 1 */ 53,
- /* 32 2 */ 54,
- /* 33 3 */ 55,
- /* 34 4 */ 56,
- /* 35 5 */ 57,
- /* 36 6 */ 58,
- /* 37 7 */ 59,
- /* 38 8 */ 60,
- /* 39 9 */ 61,
- /* 3A : */ BIN_ERROR,
- /* 3B ; */ BIN_ERROR,
- /* 3C < */ BIN_ERROR,
- /* 3D = */ 0, // pad char
- /* 3E > */ BIN_ERROR,
- /* 3F ? */ BIN_ERROR,
-
- /* 40 @ */ BIN_ERROR,
- /* 41 A */ 0,
- /* 42 B */ 1,
- /* 43 C */ 2,
- /* 44 D */ 3,
- /* 45 E */ 4,
- /* 46 F */ 5,
- /* 47 G */ 6,
- /* 48 H */ 7,
- /* 49 I */ 8,
- /* 4A J */ 9,
- /* 4B K */ 10,
- /* 4C L */ 11,
- /* 4D M */ 12,
- /* 4E N */ 13,
- /* 4F O */ 14,
-
- /* 50 P */ 15,
- /* 51 Q */ 16,
- /* 52 R */ 17,
- /* 53 S */ 18,
- /* 54 T */ 19,
- /* 55 U */ 20,
- /* 56 V */ 21,
- /* 57 W */ 22,
- /* 58 X */ 23,
- /* 59 Y */ 24,
- /* 5A Z */ 25,
- /* 5B [ */ BIN_ERROR,
- /* 5C \ */ BIN_ERROR,
- /* 5D ] */ BIN_ERROR,
- /* 5E ^ */ BIN_ERROR,
- /* 5F _ */ BIN_ERROR,
-
- /* 60 ` */ BIN_ERROR,
- /* 61 a */ 26,
- /* 62 b */ 27,
- /* 63 c */ 28,
- /* 64 d */ 29,
- /* 65 e */ 30,
- /* 66 f */ 31,
- /* 67 g */ 32,
- /* 68 h */ 33,
- /* 69 i */ 34,
- /* 6A j */ 35,
- /* 6B k */ 36,
- /* 6C l */ 37,
- /* 6D m */ 38,
- /* 6E n */ 39,
- /* 6F o */ 40,
-
- /* 70 p */ 41,
- /* 71 q */ 42,
- /* 72 r */ 43,
- /* 73 s */ 44,
- /* 74 t */ 45,
- /* 75 u */ 46,
- /* 76 v */ 47,
- /* 77 w */ 48,
- /* 78 x */ 49,
- /* 79 y */ 50,
- /* 7A z */ 51,
- /* 7B { */ BIN_ERROR,
- /* 7C | */ BIN_ERROR,
- /* 7D } */ BIN_ERROR,
- /* 7E ~ */ BIN_ERROR,
- /* 7F DEL */ BIN_ERROR,
+ #define BIN_ERROR (REBYTE)0x80
+ #define BIN_SPACE (REBYTE)0x40
+ #define BIN_VALUE (REBYTE)0x3f
+ #define IS_BIN_SPACE(c) LOGICAL(Debase64[c] & BIN_SPACE)
+
+ /* Control Chars */
+ BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR, /* 80 */
+ BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR,
+ BIN_SPACE,BIN_SPACE,BIN_SPACE,BIN_ERROR,
+ BIN_SPACE,BIN_SPACE,BIN_ERROR,BIN_ERROR,
+ BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR,
+ BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR,
+ BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR,
+ BIN_ERROR,BIN_ERROR,BIN_ERROR,BIN_ERROR,
+
+ /* 20 */ BIN_SPACE,
+ /* 21 ! */ BIN_ERROR,
+ /* 22 " */ BIN_ERROR,
+ /* 23 # */ BIN_ERROR,
+ /* 24 $ */ BIN_ERROR,
+ /* 25 % */ BIN_ERROR,
+ /* 26 & */ BIN_ERROR,
+ /* 27 ' */ BIN_SPACE,
+ /* 28 ( */ BIN_ERROR,
+ /* 29 ) */ BIN_ERROR,
+ /* 2A * */ BIN_ERROR,
+ /* 2B + */ 62,
+ /* 2C , */ BIN_ERROR,
+ /* 2D - */ BIN_ERROR,
+ /* 2E . */ BIN_ERROR,
+ /* 2F / */ 63,
+
+ /* 30 0 */ 52,
+ /* 31 1 */ 53,
+ /* 32 2 */ 54,
+ /* 33 3 */ 55,
+ /* 34 4 */ 56,
+ /* 35 5 */ 57,
+ /* 36 6 */ 58,
+ /* 37 7 */ 59,
+ /* 38 8 */ 60,
+ /* 39 9 */ 61,
+ /* 3A : */ BIN_ERROR,
+ /* 3B ; */ BIN_ERROR,
+ /* 3C < */ BIN_ERROR,
+ /* 3D = */ 0, // pad char
+ /* 3E > */ BIN_ERROR,
+ /* 3F ? */ BIN_ERROR,
+
+ /* 40 @ */ BIN_ERROR,
+ /* 41 A */ 0,
+ /* 42 B */ 1,
+ /* 43 C */ 2,
+ /* 44 D */ 3,
+ /* 45 E */ 4,
+ /* 46 F */ 5,
+ /* 47 G */ 6,
+ /* 48 H */ 7,
+ /* 49 I */ 8,
+ /* 4A J */ 9,
+ /* 4B K */ 10,
+ /* 4C L */ 11,
+ /* 4D M */ 12,
+ /* 4E N */ 13,
+ /* 4F O */ 14,
+
+ /* 50 P */ 15,
+ /* 51 Q */ 16,
+ /* 52 R */ 17,
+ /* 53 S */ 18,
+ /* 54 T */ 19,
+ /* 55 U */ 20,
+ /* 56 V */ 21,
+ /* 57 W */ 22,
+ /* 58 X */ 23,
+ /* 59 Y */ 24,
+ /* 5A Z */ 25,
+ /* 5B [ */ BIN_ERROR,
+ /* 5C \ */ BIN_ERROR,
+ /* 5D ] */ BIN_ERROR,
+ /* 5E ^ */ BIN_ERROR,
+ /* 5F _ */ BIN_ERROR,
+
+ /* 60 ` */ BIN_ERROR,
+ /* 61 a */ 26,
+ /* 62 b */ 27,
+ /* 63 c */ 28,
+ /* 64 d */ 29,
+ /* 65 e */ 30,
+ /* 66 f */ 31,
+ /* 67 g */ 32,
+ /* 68 h */ 33,
+ /* 69 i */ 34,
+ /* 6A j */ 35,
+ /* 6B k */ 36,
+ /* 6C l */ 37,
+ /* 6D m */ 38,
+ /* 6E n */ 39,
+ /* 6F o */ 40,
+
+ /* 70 p */ 41,
+ /* 71 q */ 42,
+ /* 72 r */ 43,
+ /* 73 s */ 44,
+ /* 74 t */ 45,
+ /* 75 u */ 46,
+ /* 76 v */ 47,
+ /* 77 w */ 48,
+ /* 78 x */ 49,
+ /* 79 y */ 50,
+ /* 7A z */ 51,
+ /* 7B { */ BIN_ERROR,
+ /* 7C | */ BIN_ERROR,
+ /* 7D } */ BIN_ERROR,
+ /* 7E ~ */ BIN_ERROR,
+ /* 7F DEL */ BIN_ERROR,
};
-/***********************************************************************
-**
-*/ static const REBYTE Enbase64[64] =
-/*
-** Base-64 binary encoder table.
-**
-***********************************************************************/
+// Base-64 binary encoder table.
+//
+// NOTE: Entered one-character-at-a-time in array initialization
+// format to avoid the length of 65 which would be needed if
+// a string literal were used. This helps memory tools trap
+// errant accesses to Enbase64[64] if there's an algorithm bug.
+//
+static const REBYTE Enbase64[64] =
{
- "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
- "abcdefghijklmnopqrstuvwxyz"
- "0123456789+/"
+ 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M',
+ 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z',
+ 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
+ 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z',
+ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', '+', '/'
};
-/***********************************************************************
-**
-*/ static REBSER *Decode_Base2(REBYTE **src, REBCNT len, REBYTE delim)
-/*
-***********************************************************************/
+//
+// Decode_Base2: C
+//
+static REBSER *Decode_Base2(const REBYTE **src, REBCNT len, REBYTE delim)
{
- REBYTE *bp;
- REBYTE *cp;
- REBCNT count = 0;
- REBINT accum = 0;
- REBYTE lex;
- REBSER *ser;
+ REBYTE *bp;
+ const REBYTE *cp;
+ REBCNT count = 0;
+ REBCNT accum = 0;
+ REBYTE lex;
+ REBSER *ser;
- ser = Make_Binary(len >> 3);
- bp = BIN_HEAD(ser);
- cp = *src;
+ ser = Make_Binary(len >> 3);
+ bp = BIN_HEAD(ser);
+ cp = *src;
- for (; len > 0; cp++, len--) {
+ for (; len > 0; cp++, len--) {
- if (delim && *cp == delim) break;
+ if (delim && *cp == delim) break;
- lex = Lex_Map[*cp];
+ lex = Lex_Map[*cp];
- if (lex >= LEX_NUMBER) {
+ if (lex >= LEX_NUMBER) {
- if (*cp == '0') accum *= 2;
- else if (*cp == '1') accum = (accum * 2) + 1;
- else goto err;
+ if (*cp == '0') accum *= 2;
+ else if (*cp == '1') accum = (accum * 2) + 1;
+ else goto err;
- if (count++ >= 7) {
- *bp++ = (REBYTE)accum;
- count = 0;
- accum = 0;
- }
- }
- else if (!*cp || lex > LEX_DELIMIT_RETURN) goto err;
- }
- if (count) goto err; // improper modulus
+ if (count++ >= 7) {
+ *bp++ = cast(REBYTE, accum);
+ count = 0;
+ accum = 0;
+ }
+ }
+ else if (!*cp || lex > LEX_DELIMIT_RETURN) goto err;
+ }
+ if (count) goto err; // improper modulus
- *bp = 0;
- ser->tail = bp - STR_HEAD(ser);
- return ser;
+ *bp = 0;
+ SET_SERIES_LEN(ser, bp - BIN_HEAD(ser));
+ ASSERT_SERIES_TERM(ser);
+ return ser;
err:
- Free_Series(ser);
- *src = cp;
- return 0;
+ Free_Series(ser);
+ *src = cp;
+ return 0;
}
-/***********************************************************************
-**
-*/ static REBSER *Decode_Base16(REBYTE **src, REBCNT len, REBYTE delim)
-/*
-***********************************************************************/
+//
+// Decode_Base16: C
+//
+static REBSER *Decode_Base16(const REBYTE **src, REBCNT len, REBYTE delim)
{
- REBYTE *bp;
- REBYTE *cp;
- REBCNT count = 0;
- REBINT accum = 0;
- REBYTE lex;
- REBINT val;
- REBSER *ser;
-
- ser = Make_Binary(len / 2);
- bp = STR_HEAD(ser);
- cp = *src;
-
- for (; len > 0; cp++, len--) {
-
- if (delim && *cp == delim) break;
-
- lex = Lex_Map[*cp];
-
- if (lex > LEX_WORD) {
- val = lex & LEX_VALUE; // char num encoded into lex
- if (!val && lex < LEX_NUMBER) goto err; // invalid char (word but no val)
- accum = (accum << 4) + val;
- if (count++ & 1) *bp++ = (REBYTE)accum;
- }
- else if (!*cp || lex > LEX_DELIMIT_RETURN) goto err;
- }
- if (count & 1) goto err; // improper modulus
-
- *bp = 0;
- ser->tail = bp - STR_HEAD(ser);
- return ser;
+ REBYTE *bp;
+ const REBYTE *cp;
+ REBCNT count = 0;
+ REBCNT accum = 0;
+ REBYTE lex;
+ REBINT val;
+ REBSER *ser;
+
+ ser = Make_Binary(len / 2);
+ bp = BIN_HEAD(ser);
+ cp = *src;
+
+ for (; len > 0; cp++, len--) {
+
+ if (delim && *cp == delim) break;
+
+ lex = Lex_Map[*cp];
+
+ if (lex > LEX_WORD) {
+ val = lex & LEX_VALUE; // char num encoded into lex
+ if (!val && lex < LEX_NUMBER) goto err; // invalid char (word but no val)
+ accum = (accum << 4) + val;
+ if (count++ & 1) *bp++ = cast(REBYTE, accum);
+ }
+ else if (!*cp || lex > LEX_DELIMIT_RETURN) goto err;
+ }
+ if (count & 1) goto err; // improper modulus
+
+ *bp = 0;
+ SET_SERIES_LEN(ser, bp - BIN_HEAD(ser));
+ ASSERT_SERIES_TERM(ser);
+ return ser;
err:
- Free_Series(ser);
- *src = cp;
- return 0;
+ Free_Series(ser);
+ *src = cp;
+ return 0;
}
-
-/***********************************************************************
-**
-*/ static REBSER *Decode_Base64(REBYTE **src, REBCNT len, REBYTE delim)
-/*
-***********************************************************************/
+
+//
+// Decode_Base64: C
+//
+static REBSER *Decode_Base64(const REBYTE **src, REBCNT len, REBYTE delim)
{
- REBYTE *bp;
- REBYTE *cp;
- REBCNT flip = 0;
- REBINT accum = 0;
- REBYTE lex;
- REBSER *ser;
-
- // Allocate buffer large enough to hold result:
- // Accounts for e bytes decoding into 3 bytes.
- ser = Make_Binary(((len + 3) * 3) / 4);
- bp = STR_HEAD(ser);
- cp = *src;
-
- for (; len > 0; cp++, len--) {
-
- // Check for terminating delimiter (optional):
- if (delim && *cp == delim) break;
-
- // Check for char out of range:
- if (*cp > 127) {
- if (*cp == 0xA0) continue; // hard space
- goto err;
- }
-
- lex = Debase64[*cp];
-
- if (lex < BIN_SPACE) {
-
- if (*cp != '=') {
- accum = (accum << 6) + lex;
- if (flip++ == 3) {
- *bp++ = (REBYTE)(accum >> 16);
- *bp++ = (REBYTE)(accum >> 8);
- *bp++ = (REBYTE)(accum);
- accum = 0;
- flip = 0;
- }
- } else {
- // Special padding: "="
- cp++;
- len--;
- if (flip == 3) {
- *bp++ = (REBYTE)(accum >> 10);
- *bp++ = (REBYTE)(accum >> 2);
- flip = 0;
- }
- else if (flip == 2) {
- if (!Skip_To_Char(cp, cp + len, '=')) goto err;
- cp++;
- *bp++ = (REBYTE)(accum >> 4);
- flip = 0;
- }
- else goto err;
- break;
- }
- }
- else if (lex == BIN_ERROR) goto err;
- }
-
- if (flip) goto err;
-
- *bp = 0;
- ser->tail = bp - STR_HEAD(ser);
- return ser;
+ REBYTE *bp;
+ const REBYTE *cp;
+ REBCNT flip = 0;
+ REBCNT accum = 0;
+ REBYTE lex;
+ REBSER *ser;
+
+ // Allocate buffer large enough to hold result:
+ // Accounts for e bytes decoding into 3 bytes.
+ ser = Make_Binary(((len + 3) * 3) / 4);
+ bp = BIN_HEAD(ser);
+ cp = *src;
+
+ for (; len > 0; cp++, len--) {
+
+ // Check for terminating delimiter (optional):
+ if (delim && *cp == delim) break;
+
+ // Check for char out of range:
+ if (*cp > 127) {
+ if (*cp == 0xA0) continue; // hard space
+ goto err;
+ }
+
+ lex = Debase64[*cp];
+
+ if (lex < BIN_SPACE) {
+
+ if (*cp != '=') {
+ accum = (accum << 6) + lex;
+ if (flip++ == 3) {
+ *bp++ = cast(REBYTE, accum >> 16);
+ *bp++ = cast(REBYTE, accum >> 8);
+ *bp++ = cast(REBYTE, accum);
+ accum = 0;
+ flip = 0;
+ }
+ } else {
+ // Special padding: "="
+ cp++;
+ len--;
+ if (flip == 3) {
+ *bp++ = cast(REBYTE, accum >> 10);
+ *bp++ = cast(REBYTE, accum >> 2);
+ flip = 0;
+ }
+ else if (flip == 2) {
+ if (!Skip_To_Byte(cp, cp + len, '=')) goto err;
+ cp++;
+ *bp++ = cast(REBYTE, accum >> 4);
+ flip = 0;
+ }
+ else goto err;
+ break;
+ }
+ }
+ else if (lex == BIN_ERROR) goto err;
+ }
+
+ if (flip) goto err;
+
+ *bp = 0;
+ SET_SERIES_LEN(ser, bp - BIN_HEAD(ser));
+ ASSERT_SERIES_TERM(ser);
+ return ser;
err:
- Free_Series(ser);
- *src = cp;
- return 0;
+ Free_Series(ser);
+ *src = cp;
+ return 0;
}
-/***********************************************************************
-**
-*/ REBYTE *Decode_Binary(REBVAL *value, REBYTE *src, REBCNT len, REBINT base, REBYTE delim)
-/*
-** Scan and convert a binary string.
-**
-***********************************************************************/
-{
- REBSER *ser = 0;
-
- switch (base) {
- case 64:
- ser = Decode_Base64(&src, len, delim);
- break;
- case 16:
- ser = Decode_Base16(&src, len, delim);
- break;
- case 2:
- ser = Decode_Base2 (&src, len, delim);
- break;
- }
+//
+// Decode_Binary: C
+//
+// Scan and convert a binary string.
+//
+const REBYTE *Decode_Binary(
+ REBVAL *value,
+ const REBYTE *src,
+ REBCNT len,
+ REBINT base,
+ REBYTE delim
+) {
+ REBSER *ser = 0;
+
+ switch (base) {
+ case 64:
+ ser = Decode_Base64(&src, len, delim);
+ break;
+ case 16:
+ ser = Decode_Base16(&src, len, delim);
+ break;
+ case 2:
+ ser = Decode_Base2 (&src, len, delim);
+ break;
+ }
+
+ if (!ser) return 0;
+
+ Init_Binary(value, ser);
+
+ return src;
+}
- if (!ser) return 0;
- Set_Binary(value, ser);
+//
+// Encode_Base2: C
+//
+// Base2 encode a given series. Must be BYTES, not UNICODE.
+//
+REBSER *Encode_Base2(const REBVAL *value, REBSER *series, REBOOL brk)
+{
+ REBYTE *p; // ?? should it be REBYTE? Same with below functions?
+ REBYTE *src;
+ REBINT len;
+ REBINT i;
+ REBINT n;
+ REBYTE b;
- return src;
-}
+ len = VAL_LEN_AT(value);
+ src = VAL_BIN_AT(value);
+ // Add slop-factor
+ series = Prep_String(series, &p, 8 * len + 2 * (len / 8) + 4);
-/***********************************************************************
-**
-*/ REBSER *Encode_Base2(REBVAL *value, REBSER *series, REBFLG brk)
-/*
-** Base2 encode a given series. Must be BYTES, not UNICODE.
-**
-***********************************************************************/
-{
- REBYTE *p; // ?? should it be REBYTE? Same with below functions?
- REBYTE *src;
- REBINT len;
- REBINT i;
- REBINT n;
- REBYTE b;
+ // If the input series was zero length, return empty series
+ if (len == 0) {
+ TERM_SEQUENCE_LEN(series, 0);
+ return series;
+ }
- len = VAL_LEN(value);
- src = VAL_BIN_DATA(value);
+ if (len > 8 && brk) *p++ = LF;
- // Add slop-factor
- series = Prep_String (series, &p, 8 * len + 2 * (len / 8) + 4);
- if (len > 8 && brk) *p++ = LF;
+ for (i = 0; i < len; i++) {
- for (i = 0; i < len; i++) {
+ b = src[i];
- b = src[i];
+ for (n = 0x80; n > 0; n = n>>1) {
+ *p++ = (b & n) ? '1' : '0';
+ }
- for (n = 0x80; n > 0; n = n>>1) {
- *p++ = (b & n) ? '1' : '0';
- }
-
- if ((i+1) % 8 == 0 && brk)
- *p++ = LF;
- }
- *p = 0;
+ if ((i+1) % 8 == 0 && brk)
+ *p++ = LF;
+ }
+ *p = 0;
- if (*(p-1) != LF && len > 9 && brk) *p++ = LF;
+ if (*(p-1) != LF && len > 9 && brk) *p++ = LF;
- SERIES_TAIL(series) = DIFF_PTRS(p, series->data);
- return series;
+ SET_SERIES_LEN(series, cast(REBCNT, p - BIN_HEAD(series)));
+ ASSERT_SERIES_TERM(series);
+ return series;
}
-/***********************************************************************
-**
-*/ REBSER *Encode_Base16(REBVAL *value, REBSER *series, REBFLG brk)
-/*
-** Base16 encode a given series. Must be BYTES, not UNICODE.
-**
-***********************************************************************/
+//
+// Encode_Base16: C
+//
+// Base16 encode a given series. Must be BYTES, not UNICODE.
+//
+REBSER *Encode_Base16(const REBVAL *value, REBSER *series, REBOOL brk)
{
- REBCNT count;
- REBCNT len;
- REBYTE *bp;
- REBYTE *src;
-
- len = VAL_LEN(value);
- src = VAL_BIN_DATA(value);
-
- // Account for hex, lines, and extra syntax:
- series = Prep_String(series, &bp, len*2 + len/32 + 32);
- // (Note: tail not properly set yet)
-
- if (len >= 32 && brk) *bp++ = LF;
- for (count = 1; count <= len; count++) {
- bp = Form_Hex2(bp, *src++);
- if (brk && ((count % 32) == 0)) *bp++ = LF;
- }
-
- if (*(bp-1) != LF && (len >= 32) && brk) *bp++ = LF;
- *bp = 0;
-
- SERIES_TAIL(series) = DIFF_PTRS(bp, series->data);
-
- return series;
+ REBCNT count;
+ REBCNT len;
+ REBYTE *bp;
+ REBYTE *src;
+
+ len = VAL_LEN_AT(value);
+ src = VAL_BIN_AT(value);
+
+ // Account for hex, lines, and extra syntax:
+ series = Prep_String(series, &bp, len*2 + len/32 + 32);
+ // (Note: tail not properly set yet)
+
+ // If the input series was zero length, return empty series
+ if (len == 0) {
+ TERM_SEQUENCE_LEN(series, 0);
+ return series;
+ }
+
+ if (len >= 32 && brk) *bp++ = LF;
+ for (count = 1; count <= len; count++) {
+ bp = Form_Hex2(bp, *src++);
+ if (brk && ((count % 32) == 0)) *bp++ = LF;
+ }
+
+ if (*(bp-1) != LF && (len >= 32) && brk) *bp++ = LF;
+ *bp = 0;
+
+ SET_SERIES_LEN(series, cast(REBCNT, bp - BIN_HEAD(series)));
+ ASSERT_SERIES_TERM(series);
+ return series;
}
-/***********************************************************************
-**
-*/ REBSER *Encode_Base64(REBVAL *value, REBSER *series, REBFLG brk)
-/*
-** Base64 encode a given series. Must be BYTES, not UNICODE.
-**
-***********************************************************************/
+//
+// Encode_Base64: C
+//
+// Base64 encode a given series. Must be BYTES, not UNICODE.
+//
+REBSER *Encode_Base64(const REBVAL *value, REBSER *series, REBOOL brk)
{
- REBYTE *p;
- REBYTE *src;
- REBCNT len;
- REBINT x, loop;
-
- len = VAL_LEN(value);
- src = VAL_BIN(value);
-
- // slop-factor
- series = Prep_String (series, &p, 4 * len / 3 + 2 * (len / 32) + 5);
- loop = (int) (len / 3) - 1;
- if (4 * loop > 64 && brk) *p++ = LF;
-
- for (x = 0; x <= 3 * loop; x += 3) {
- *p++ = Enbase64[src[x] >> 2];
- *p++ = Enbase64[((src[x] & 0x3) << 4) + (src[x + 1] >> 4)];
- *p++ = Enbase64[((src[x + 1] & 0xF) << 2) + (src[x + 2] >> 6)];
- *p++ = Enbase64[(src[x + 2] % 0x40)];
- if ((x+3) % 48 == 0 && brk)
- *p++ = LF;
- }
-
- if ((len % 3) != 0) {
- p[2] = p[3] = '=';
- *p++ = Enbase64[src[x] >> 2];
- if ((len - x) >= 1)
- *p++ = Enbase64[((src[x] & 0x3) << 4) + ((len - x) == 1 ? 0 : src[x + 1] >> 4)];
- else p++;
- if ((len - x) == 2)
- *p++ = Enbase64[(src[x + 1] & 0xF) << 2];
- else p++;
- p++;
- }
-
- if (*(p-1) != LF && x > 49 && brk) *p++ = LF;
- *p = 0;
-
- SERIES_TAIL(series) = DIFF_PTRS(p, series->data); /* 4 * (int) (len % 3 ? (len / 3) + 1 : len / 3); */
-
- return series;
+ REBYTE *p;
+ REBYTE *src;
+ REBCNT len;
+ REBINT x, loop;
+
+ len = VAL_LEN_AT(value);
+ src = VAL_BIN(value);
+
+ // slop-factor
+ series = Prep_String (series, &p, 4 * len / 3 + 2 * (len / 32) + 5);
+
+ // If the input series was zero length, return empty series
+ if (len == 0) {
+ TERM_SEQUENCE_LEN(series, 0);
+ return series;
+ }
+
+ loop = (int) (len / 3) - 1;
+ if (4 * loop > 64 && brk) *p++ = LF;
+
+ for (x = 0; x <= 3 * loop; x += 3) {
+ *p++ = Enbase64[src[x] >> 2];
+ *p++ = Enbase64[((src[x] & 0x3) << 4) + (src[x + 1] >> 4)];
+ *p++ = Enbase64[((src[x + 1] & 0xF) << 2) + (src[x + 2] >> 6)];
+ *p++ = Enbase64[(src[x + 2] % 0x40)];
+ if ((x+3) % 48 == 0 && brk)
+ *p++ = LF;
+ }
+
+ if ((len % 3) != 0) {
+ p[2] = p[3] = '=';
+ *p++ = Enbase64[src[x] >> 2];
+ if ((len - x) >= 1)
+ *p++ = Enbase64[
+ ((src[x] & 0x3) << 4)
+ + ((len - x) == 1 ? 0 : src[x + 1] >> 4)
+ ];
+ else p++;
+ if ((len - x) == 2)
+ *p++ = Enbase64[(src[x + 1] & 0xF) << 2];
+ else p++;
+ p++;
+ }
+
+ if (*(p-1) != LF && x > 49 && brk) *p++ = LF;
+ *p = 0;
+
+ //
+ // !!! "4 * (int) (len % 3 ? (len / 3) + 1 : len / 3);" ...?
+ //
+ SET_SERIES_LEN(series, cast(REBCNT, p - BIN_HEAD(series)));
+ ASSERT_SERIES_TERM(series);
+ return series;
}
diff --git a/src/core/f-extension.c b/src/core/f-extension.c
index b504f5634e..d06d670ef4 100644
--- a/src/core/f-extension.c
+++ b/src/core/f-extension.c
@@ -1,64 +1,63 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: f-extension.c
-** Summary: support for extensions
-** Section: functional
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %f-extension.c
+// Summary: "support for extensions"
+// Section: functional
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// NOTE: The R3-Alpha extension mechanism and API are deprecated in Ren-C.
+//
+// See %reb-ext.h for a general overview of R3-Alpha extensions. Also:
+//
+// http://www.rebol.com/r3/docs/concepts/extensions-embedded.html
+//
#include "sys-core.h"
-#include "reb-ext.h" // includes copy of ext-types.h
+#include "reb-ext.h"
#include "reb-evtypes.h"
#include "reb-lib.h"
-
-// Extension evaluation categories:
-enum {
- RXE_NULL, // unset
- RXE_PTR, // any pointer
- RXE_32, // logic
- RXE_64, // integer, decimal, etc.
- RXE_SYM, // word
- RXE_SER, // string
- RXE_IMAGE, // image
- RXE_DATE, // from upper section
- RXE_MAX
-};
+#include "sys-ext.h"
//(*call)(int cmd, RXIFRM *args);
-typedef struct reb_ext {
- RXICAL call; // Call(function) entry point
- void *dll; // DLL library "handle"
- int index; // Index in extension table
- int object; // extension object reference
-} REBEXT;
+typedef struct rxi_cmd_context {
+ void *envr; // for holding a reference to your environment
+ REBARR *block; // block being evaluated
+ REBCNT index; // 0-based index of current command in block
+} REBCEC;
-#include "tmp-exttypes.h"
+typedef int (*RXICAL)(int cmd, const REBVAL *frame, REBCEC *ctx);
-extern const REBDOF Func_Dispatch[];
+typedef struct reb_ext {
+ RXICAL call; // Call(function) entry point
+ void *dll; // DLL library "handle"
+ int index; // Index in extension table
+ int object; // extension object reference
+} REBEXT;
// !!!! The list below should not be hardcoded, but until someone
// needs a lot of extensions, it will do fine.
@@ -66,583 +65,390 @@ REBEXT Ext_List[64];
REBCNT Ext_Next = 0;
-/***********************************************************************
-**
-** Local functions
-**
-***********************************************************************/
+typedef REBYTE *(INFO_FUNC)(REBINT opts, void *lib);
-/***********************************************************************
-**
-x*/ RXIARG Value_To_RXI(REBVAL *val)
-/*
-***********************************************************************/
+//
+// Just an ID for the handler
+//
+static void cleanup_extension_init_handler(const REBVAL *val)
{
- RXIARG arg;
-
- switch (RXT_Eval_Class[Reb_To_RXT[VAL_TYPE(val)]]) {
- case RXE_64:
- arg.int64 = VAL_INT64(val);
- break;
- case RXE_SER:
- arg.series = VAL_SERIES(val);
- arg.index = VAL_INDEX(val);
- break;
- case RXE_PTR:
- arg.addr = VAL_HANDLE(val);
- break;
- case RXE_32:
- arg.int32a = VAL_I32(val);
- arg.int32b = 0;
- break;
- case RXE_DATE:
- arg.int32a = VAL_ALL_BITS(val)[2];
- arg.int32b = 0;
- break;
- case RXE_SYM:
- arg.int32a = VAL_WORD_CANON(val);
- arg.int32b = 0;
- break;
- case RXE_IMAGE:
- arg.series = VAL_SERIES(val);
- arg.width = VAL_IMAGE_WIDE(val);
- arg.height = VAL_IMAGE_HIGH(val);
- break;
- case RXE_NULL:
- default:
- arg.int64 = 0;
- break;
- }
- return arg;
+ UNUSED(val);
}
-/***********************************************************************
-**
-x*/ void RXI_To_Value(REBVAL *val, RXIARG arg, REBCNT type)
-/*
-***********************************************************************/
+static void cleanup_extension_quit_handler(const REBVAL *val)
{
- VAL_SET(val, RXT_To_Reb[type]);
- switch (RXT_Eval_Class[type]) {
- case RXE_64:
- VAL_INT64(val) = arg.int64;
- break;
- case RXE_SER:
- VAL_SERIES(val) = arg.series;
- VAL_INDEX(val) = arg.index;
- break;
- case RXE_PTR:
- VAL_HANDLE(val) = arg.addr;
- break;
- case RXE_32:
- VAL_I32(val) = arg.int32a;
- break;
- case RXE_DATE:
- VAL_TIME(val) = NO_TIME;
- VAL_ALL_BITS(val)[2] = arg.int32a;
- break;
- case RXE_SYM:
- VAL_WORD_SYM(val) = arg.int32a;
- VAL_WORD_FRAME(val) = 0;
- VAL_WORD_INDEX(val) = 0;
- break;
- case RXE_IMAGE:
- VAL_SERIES(val) = arg.series;
- VAL_IMAGE_WIDE(val) = arg.width;
- VAL_IMAGE_HIGH(val) = arg.height;
- break;
- case RXE_NULL:
- VAL_INT64(val) = 0;
- break;
- default:
- SET_NONE(val);
- }
+ UNUSED(val);
}
-/***********************************************************************
-**
-x*/ void RXI_To_Block(RXIFRM *frm, REBVAL *out) {
-/*
-***********************************************************************/
- REBCNT n;
- REBSER *blk;
- REBVAL *val;
- REBCNT len;
-
- blk = Make_Block(len = RXA_COUNT(frm));
- for (n = 1; n <= len; n++) {
- val = Append_Value(blk);
- RXI_To_Value(val, frm->args[n], RXA_TYPE(frm, n));
- }
- Set_Block(out, blk);
+//
+// load-extension-helper: native [
+//
+// "Low level extension module loader (for DLLs)."
+//
+// path-or-handle [file! handle!] "Path to the extension file or handle to a builtin extension"
+// ]
+//
+REBNATIVE(load_extension_helper)
+//
+// Low level extension loader:
+//
+// 1. Opens the DLL for the extension
+// 2. Calls RX_Init() to initialize and get its definition header (REBOL)
+// 3. Creates a extension object and returns it
+// 4. REBOL code then uses that object to define the extension module
+// including natives, data, exports, etc.
+//
+// Each extension is defined as DLL with:
+//
+// RX_Init() - init anything needed
+// optinoal RX_Quit() - cleanup anything needed
+{
+ INCLUDE_PARAMS_OF_LOAD_EXTENSION_HELPER;
+
+ REBCTX *std_ext_ctx = VAL_CONTEXT(Get_System(SYS_STANDARD, STD_EXTENSION));
+ REBCTX *context;
+
+ if (IS_FILE(ARG(path_or_handle))) {
+ REBVAL *path = ARG(path_or_handle);
+
+ //Check_Security(SYM_EXTENSION, POL_EXEC, val);
+
+ DECLARE_LOCAL (lib);
+ MAKE_Library(lib, REB_LIBRARY, path);
+
+ // check if it's reloading an existing extension
+ REBVAL *loaded_exts = CTX_VAR(VAL_CONTEXT(ROOT_SYSTEM), SYS_EXTENSIONS);
+ if (IS_BLOCK(loaded_exts)) {
+ RELVAL *item = VAL_ARRAY_HEAD(loaded_exts);
+ for (; NOT_END(item); ++item) {
+ // do some sanity checking, just to avoid crashing if system/extensions was messed up
+ if (!IS_OBJECT(item))
+ fail(Error_Bad_Extension_Raw(item));
+
+ REBCTX *item_ctx = VAL_CONTEXT(item);
+ if ((CTX_LEN(item_ctx) <= STD_EXTENSION_LIB_BASE)
+ || CTX_KEY_SPELLING(item_ctx, STD_EXTENSION_LIB_BASE)
+ != CTX_KEY_SPELLING(std_ext_ctx, STD_EXTENSION_LIB_BASE)
+ ) {
+ fail(Error_Bad_Extension_Raw(item));
+ }
+ else {
+ if (IS_BLANK(CTX_VAR(item_ctx, STD_EXTENSION_LIB_BASE))) {//builtin extension
+ continue;
+ }
+ }
+
+ assert(IS_LIBRARY(CTX_VAR(item_ctx, STD_EXTENSION_LIB_BASE)));
+
+ if (VAL_LIBRARY_FD(lib)
+ == VAL_LIBRARY_FD(CTX_VAR(item_ctx, STD_EXTENSION_LIB_BASE))) {
+ // found the existing extension
+ OS_CLOSE_LIBRARY(VAL_LIBRARY_FD(lib)); //decrease the reference added by MAKE_library
+ Move_Value(D_OUT, KNOWN(item));
+ return R_OUT;
+ }
+ }
+ }
+ context = Copy_Context_Shallow(std_ext_ctx);
+ Move_Value(CTX_VAR(context, STD_EXTENSION_LIB_BASE), lib);
+ Move_Value(CTX_VAR(context, STD_EXTENSION_LIB_FILE), path);
+
+ CFUNC *RX_Init = OS_FIND_FUNCTION(VAL_LIBRARY_FD(lib), "RX_Init");
+ if (RX_Init == NULL) {
+ OS_CLOSE_LIBRARY(VAL_LIBRARY_FD(lib));
+ fail(Error_Bad_Extension_Raw(path));
+ }
+
+ // Call its RX_Init function for header and code body:
+ if (cast(INIT_FUNC, RX_Init)(CTX_VAR(context, STD_EXTENSION_SCRIPT),
+ CTX_VAR(context, STD_EXTENSION_MODULES)) < 0) {
+ OS_CLOSE_LIBRARY(VAL_LIBRARY_FD(lib));
+ fail(Error_Extension_Init_Raw(path));
+ }
+ }
+ else {
+ assert(IS_HANDLE(ARG(path_or_handle)));
+ REBVAL *handle = ARG(path_or_handle);
+ if (VAL_HANDLE_CLEANER(handle) != cleanup_extension_init_handler)
+ fail(Error_Bad_Extension_Raw(handle));
+
+ INIT_FUNC RX_Init = cast(INIT_FUNC, VAL_HANDLE_CFUNC(handle));
+ context = Copy_Context_Shallow(std_ext_ctx);
+ if (
+ RX_Init(
+ CTX_VAR(context, STD_EXTENSION_SCRIPT),
+ CTX_VAR(context, STD_EXTENSION_MODULES)
+ ) < 0
+ ){
+ fail(Error_Extension_Init_Raw(handle));
+ }
+ }
+
+ Init_Object(D_OUT, context);
+ return R_OUT;
}
-/***********************************************************************
-**
-x*/ int Do_Callback(REBSER *obj, u32 name, RXIARG *args, RXIARG *result)
-/*
-** Given an object and a word id, call a REBOL function.
-** The arguments are converted from extension format directly
-** to the data stack. The result is passed back in ext format,
-** with the datatype returned or zero if there was a problem.
-**
-***********************************************************************/
+//
+// unload-extension-helper: native [
+//
+// "Unload an extension"
+//
+// return: []
+// ext [object!]
+// "The extension to be unloaded"
+// /cleanup
+// cleaner [handle!]
+// "The RX_Quit pointer for the builtin extension"
+// ]
+//
+REBNATIVE(unload_extension_helper)
{
- REBVAL *val;
- REBCNT dsf;
- REBCNT len;
- REBCNT n;
- REBCNT dsp = DSP; // to restore stack on errors
-
- // Find word in object, verify it is a function.
- if (!(val = Find_Word_Value(obj, name))) {
- SET_EXT_ERROR(result, RXE_NO_WORD);
- return 0;
- }
- if (!ANY_FUNC(val)) {
- SET_EXT_ERROR(result, RXE_NOT_FUNC);
- return 0;
- }
-
- // Get block and index from prior function stack frame:
- dsf = PRIOR_DSF(DSF);
-
- // Create stack frame (use prior stack frame for location info):
- dsf = Push_Func(0, VAL_SERIES(DSF_BACK(dsf)), VAL_INDEX(DSF_BACK(dsf)), name, val);
- val = DSF_FUNC(dsf); // for safety from GC
- obj = VAL_FUNC_WORDS(val); // func words
- len = SERIES_TAIL(obj)-1; // number of args (may include locals)
-
- // Push args. Too short or too long arg frames are handled W/O error.
- // Note that refinements args can be set to anything.
- for (n = 1; n <= len && n <= RXI_COUNT(args); n++) {
- DS_SKIP;
- RXI_To_Value(DS_TOP, args[n], RXI_TYPE(args, n));
- // Check type for word at the given offset:
- if (!TYPE_CHECK(BLK_SKIP(obj, n), VAL_TYPE(DS_TOP))) {
- result->int32b = n;
- SET_EXT_ERROR(result, RXE_BAD_ARGS);
- DSP = dsp;
- return 0;
- }
- }
- // Fill with NONE if necessary:
- for (; n <= len; n++) {
- DS_SKIP;
- SET_NONE(DS_TOP);
- if (!TYPE_CHECK(BLK_SKIP(obj, n), VAL_TYPE(DS_TOP))) {
- result->int32b = n;
- SET_EXT_ERROR(result, RXE_BAD_ARGS);
- DSP = dsp;
- return 0;
- }
- }
-
- // Evaluate the function:
- DSF = dsf;
- Func_Dispatch[VAL_TYPE(val) - REB_NATIVE](val);
- DSF = PRIOR_DSF(dsf);
- DSP = dsf-1;
-
- // Return resulting value from TOS1 (volatile location):
- *result = Value_To_RXI(DS_VALUE(dsf));
- return Reb_To_RXT[VAL_TYPE(DS_VALUE(dsf))];
+ INCLUDE_PARAMS_OF_UNLOAD_EXTENSION_HELPER;
+
+ REBCTX *std = VAL_CONTEXT(Get_System(SYS_STANDARD, STD_EXTENSION));
+ REBCTX *context = VAL_CONTEXT(ARG(ext));
+
+ if (
+ (CTX_LEN(context) <= STD_EXTENSION_LIB_BASE)
+ || (
+ CTX_KEY_CANON(context, STD_EXTENSION_LIB_BASE)
+ != CTX_KEY_CANON(std, STD_EXTENSION_LIB_BASE)
+ )
+ ){
+ fail (ARG(ext));
+ }
+
+ int ret;
+ if (!REF(cleanup)) {
+ REBVAL *lib = CTX_VAR(context, STD_EXTENSION_LIB_BASE);
+ if (!IS_LIBRARY(lib))
+ fail (ARG(ext));
+
+ if (IS_LIB_CLOSED(VAL_LIBRARY(lib)))
+ fail (Error_Bad_Library_Raw());
+
+ QUIT_FUNC quitter = cast(
+ QUIT_FUNC, OS_FIND_FUNCTION(VAL_LIBRARY_FD(lib), "RX_Quit")
+ );
+
+ if (quitter == NULL)
+ ret = 0;
+ else
+ ret = quitter();
+
+ OS_CLOSE_LIBRARY(VAL_LIBRARY_FD(lib));
+ }
+ else {
+ if (VAL_HANDLE_CLEANER(ARG(cleaner)) != cleanup_extension_quit_handler)
+ fail (ARG(cleaner));
+
+ QUIT_FUNC quitter = cast(QUIT_FUNC, VAL_HANDLE_CFUNC(ARG(cleaner)));
+ assert(quitter != NULL);
+
+ ret = quitter();
+ }
+
+ if (ret < 0) {
+ DECLARE_LOCAL (i);
+ Init_Integer(i, ret);
+ fail (Error_Fail_To_Quit_Extension_Raw(i));
+ }
+
+ return R_VOID;
}
-/***********************************************************************
-**
-*/ REBNATIVE(do_callback)
-/*
-** object word arg1 arg2
-**
-***********************************************************************/
+//
+// Just an ID for the handler
+//
+static void cleanup_module_handler(const REBVAL *val)
{
- RXICBI *cbi;
- REBVAL *event = D_ARG(1);
- REBCNT n;
-
- // Sanity check:
- if (VAL_EVENT_TYPE(event) != EVT_CALLBACK || !(cbi = VAL_EVENT_SER(event)))
- return R_NONE;
-
- n = Do_Callback(cbi->obj, cbi->word, cbi->args, &(cbi->result));
-
- SET_FLAG(cbi->flags, RXC_DONE);
+ UNUSED(val);
+}
- if (!n) Trap_Num(RE_INVALID_ARG, GET_EXT_ERROR(&cbi->result));
- RXI_To_Value(ds, cbi->result, n);
- return R_RET;
+//
+// Make_Extension_Module_Array: C
+//
+// Make an extension module array for being loaded later
+//
+REBARR *Make_Extension_Module_Array(
+ const REBYTE spec[],
+ REBCNT len,
+ REBNAT impl[],
+ REBCNT n,
+ REBCNT error_base
+) {
+ // the array will be like [spec C_func error_base/none]
+ REBARR *arr = Make_Array(3);
+
+ Init_Binary(ARR_AT(arr, 0), Copy_Bytes(spec, len));
+
+ Init_Handle_Managed(
+ ARR_AT(arr, 1),
+ impl, // It's a *pointer to function pointer*, not a function pointer
+ n,
+ &cleanup_module_handler
+ );
+
+ if (error_base == 0)
+ Init_Blank(ARR_AT(arr, 2));
+ else
+ Init_Integer(ARR_AT(arr, 2), error_base);
+
+ TERM_ARRAY_LEN(arr, 3);
+ return arr;
}
-/***********************************************************************
-**
-*/ REBNATIVE(load_extension)
-/*
-** arg 1: filename | body binary string (UTF-8)
-** arg 2: dispatch
-** arg 3: function handle
-**
-** Low level extension loader:
-**
-** 1. Opens the DLL for the extension
-** 2. Calls its Info() command to get its definition header (REBOL)
-** 3. Inits an extension structure (dll, Call() function)
-** 4. Creates a extension object and returns it
-** 5. REBOL code then uses that object to define the extension module
-** including commands, functions, data, exports, etc.
-**
-** Each extension is defined as DLL with:
-**
-** init() - init anything needed
-** quit() - cleanup anything needed
-** call() - dispatch a native
-**
-***********************************************************************/
+//
+// Prepare_Boot_Extensions: C
+//
+// Convert an extension [Init Quit] array to [handle! handle!] array
+//
+void Prepare_Boot_Extensions(REBVAL *exts, CFUNC **funcs, REBCNT n)
{
- REBCHR *name;
- void *dll;
- REBCNT error;
- REBYTE *code;
- REBYTE *(*info)(REBINT opts, void *lib);
- REBSER *obj;
- REBVAL *val = D_ARG(1);
- REBEXT *ext;
- RXICAL call;
- REBSER *src;
- int Remove_after_first_run;
- //Check_Security(SYM_EXTENSION, POL_EXEC, val);
-
- if (!D_REF(2)) { // No /dispatch, use the DLL file:
-
- if (!IS_FILE(val)) Trap_Arg(val);
-
- name = Val_Str_To_OS(val);
-
- // Try to load the DLL file:
- if (!(dll = OS_OPEN_LIBRARY(name, &error))) {
- Trap1(RE_NO_EXTENSION, val);
- }
-
- // Call its info() function for header and code body:
- if (!(info = OS_FIND_FUNCTION(dll, BOOT_STR(RS_EXTENSION, 0)))){
- OS_CLOSE_LIBRARY(dll);
- Trap1(RE_BAD_EXTENSION, val);
- }
-
- // Obtain info string as UTF8:
- if (!(code = info(0, Extension_Lib()))) {
- OS_CLOSE_LIBRARY(dll);
- Trap1(RE_EXTENSION_INIT, val);
- }
-
- // Import the string into REBOL-land:
- src = Copy_Bytes(code, -1); // Nursery protected
- call = OS_FIND_FUNCTION(dll, BOOT_STR(RS_EXTENSION, 2)); // zero is allowed
- }
- else {
- // Hosted extension:
- src = VAL_SERIES(val);
- call = (RXICAL)VAL_HANDLE(D_ARG(3));
- dll = 0;
- }
-
- ext = &Ext_List[Ext_Next];
- CLEARS(ext);
- ext->call = call;
- ext->dll = dll;
- ext->index = Ext_Next++;
-
- // Extension return: dll, info, filename
- obj = VAL_OBJ_FRAME(Get_System(SYS_STANDARD, STD_EXTENSION));
- obj = CLONE_OBJECT(obj);
- Set_Object(D_RET, obj);
-
- // Set extension fields needed:
- val = FRM_VALUE(obj, STD_EXTENSION_LIB_BASE);
- VAL_SET(val, REB_HANDLE);
- VAL_I32(val) = ext->index;
- if (!D_REF(2)) *FRM_VALUE(obj, STD_EXTENSION_LIB_FILE) = *D_ARG(1);
- Set_Binary(FRM_VALUE(obj, STD_EXTENSION_LIB_BOOT), src);
-
- return R_RET;
+ REBARR *arr = Make_Array(n);
+ REBCNT i;
+ for (i = 0; i < n; i += 2) {
+ Init_Handle_Managed_Cfunc(
+ Alloc_Tail_Array(arr),
+ funcs[i],
+ 0, // length, currently unused
+ &cleanup_extension_init_handler
+ );
+
+ Init_Handle_Managed_Cfunc(
+ Alloc_Tail_Array(arr),
+ funcs[i + 1],
+ 0, // length, currently unused
+ &cleanup_extension_quit_handler
+ );
+ }
+ Init_Block(exts, arr);
}
-
-/***********************************************************************
-**
-*/ void Make_Command(REBVAL *value, REBVAL *def)
-/*
-** Assumes prior function has already stored the spec and args
-** series. This function validates the body.
-**
-***********************************************************************/
+//
+// Shutdown_Boot_Extensions: C
+//
+// Call QUIT functions of boot extensions in the reversed order
+//
+// Note that this function does not call unload-extension, that is why it is
+// called SHUTDOWN instead of UNLOAD, because it's only supposed to be called
+// when the interpreter is shutting down, at which point, unloading an extension
+// is not necessary. Plus, there is not an elegant way to call unload-extension
+// on each of boot extensions: boot extensions are passed to host-start as a
+// block, and there is no host-shutdown function which would be an ideal place
+// to such things.
+//
+void Shutdown_Boot_Extensions(CFUNC **funcs, REBCNT n)
{
- REBVAL *args = BLK_HEAD(VAL_FUNC_ARGS(value));
- REBCNT n;
- REBVAL *val = VAL_BLK_SKIP(def, 1);
- REBEXT *ext;
-
- if (
- VAL_LEN(def) != 3
- || !(IS_MODULE(val) || IS_OBJECT(val))
- || !IS_HANDLE(VAL_OBJ_VALUE(val, 1))
- || !IS_INTEGER(val+1)
- || VAL_INT64(val+1) > 0xffff
- ) Trap1(RE_BAD_FUNC_DEF, def);
-
- val = VAL_OBJ_VALUE(val, 1);
- if (
- !(ext = &Ext_List[VAL_I32(val)])
- || !(ext->call)
- ) Trap1(RE_BAD_EXTENSION, def);
-
- // make command! [[arg-spec] handle cmd-index]
- VAL_FUNC_BODY(value) = Copy_Block_Len(VAL_SERIES(def), 1, 2);
-
- // Check for valid command arg datatypes:
- args++; // skip self
- n = 1;
- for (; NOT_END(args); args++, n++) {
- // If the typeset contains args that are not valid:
- // (3 is the default when no args given, for not END and UNSET)
- if (3 != ~VAL_TYPESET(args) && (VAL_TYPESET(args) & ~RXT_ALLOWED_TYPES))
- Trap1(RE_BAD_FUNC_ARG, args);
- }
-
- VAL_SET(value, REB_COMMAND);
+ for (; n > 1; n -= 2) {
+ cast(QUIT_FUNC, funcs[n - 1])();
+ }
}
-/***********************************************************************
-**
-*/ void Do_Command(REBVAL *value)
-/*
-** Evaluates the arguments for a command function and creates
-** a resulting stack frame (struct or object) for command processing.
-**
-** A command value consists of:
-** args - same as other funcs
-** spec - same as other funcs
-** body - [ext-obj func-index]
-**
-***********************************************************************/
+//
+// load-native: native [
+//
+// "Load a native from a built-in extension"
+//
+// return: [function!]
+// "function value, will be created from the native implementation"
+// spec [block!]
+// "spec of the native"
+// impl [handle!]
+// "a handle returned from RX_Init_ of the extension"
+// index [integer!]
+// "Index of the native"
+// /body
+// code [block!]
+// "User-equivalent body"
+// /unloadable
+// "The native can be unloaded later (when extension is unloaded)"
+// ]
+//
+REBNATIVE(load_native)
{
- REBVAL *val = BLK_HEAD(VAL_FUNC_BODY(value));
- REBEXT *ext;
- REBCNT cmd;
- REBCNT argc;
- REBCNT n;
- RXIFRM frm; // args stored here
-
- // All of these were checked above on definition:
- val = BLK_HEAD(VAL_FUNC_BODY(value));
- cmd = (int)VAL_INT64(val+1);
- ext = &Ext_List[VAL_I32(VAL_OBJ_VALUE(val, 1))]; // Handler
-
- // Copy args to command frame (array of args):
- RXA_COUNT(&frm) = argc = SERIES_TAIL(VAL_FUNC_ARGS(value))-1; // not self
- if (argc > 7) Trap0(RE_BAD_COMMAND);
- val = DS_ARG(1);
- for (n = 1; n <= argc; n++, val++) {
- RXA_TYPE(&frm, n) = Reb_To_RXT[VAL_TYPE(val)];
- frm.args[n] = Value_To_RXI(val);
- }
-
- // Call the command:
- n = ext->call(cmd, &frm, 0);
- val = DS_RETURN;
- switch (n) {
- case RXR_VALUE:
- RXI_To_Value(val, frm.args[1], RXA_TYPE(&frm, 1));
- break;
- case RXR_BLOCK:
- RXI_To_Block(&frm, val);
- break;
- case RXR_UNSET:
- SET_UNSET(val);
- break;
- case RXR_NONE:
- SET_NONE(val);
- break;
- case RXR_TRUE:
- SET_TRUE(val);
- break;
- case RXR_FALSE:
- SET_FALSE(val);
- break;
- case RXR_ERROR:
- default:
- SET_UNSET(val);
- }
+ INCLUDE_PARAMS_OF_LOAD_NATIVE;
+
+ if (VAL_HANDLE_CLEANER(ARG(impl)) != cleanup_module_handler)
+ fail ("HANDLE! passed to LOAD-NATIVE did not come from RX_Init");
+
+ REBI64 index = VAL_INT64(ARG(index));
+ if (index < 0 || cast(REBUPT, index) >= VAL_HANDLE_LEN(ARG(impl)))
+ fail ("Index of native is outside range specified by RX_Init");
+
+ REBNAT dispatcher = VAL_HANDLE_POINTER(REBNAT, ARG(impl))[index];
+ REBFUN *fun = Make_Function(
+ Make_Paramlist_Managed_May_Fail(
+ ARG(spec),
+ MKF_KEYWORDS | MKF_FAKE_RETURN
+ ),
+ dispatcher, // unique
+ NULL, // no underlying function, this is fundamental
+ NULL // not providing a specialization
+ );
+
+ if (REF(unloadable))
+ SET_VAL_FLAG(FUNC_VALUE(fun), FUNC_FLAG_UNLOADABLE_NATIVE);
+
+ if (REF(body)) {
+ *FUNC_BODY(fun) = *ARG(code);
+ }
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ void Do_Commands(REBSER *cmds, void *context)
-/*
-** Evaluate a block of commands as efficiently as possible.
-** The arguments to each command must already be reduced or
-** use only variable lookup.
-**
-** Returns the last evaluated value, if provided.
-**
-***********************************************************************/
+//
+// Unloaded_Dispatcher: C
+//
+// This will be the dispatcher for the natives in an extension after the
+// extension is unloaded.
+//
+static REB_R Unloaded_Dispatcher(REBFRM *f)
{
- REBVAL *blk;
- REBCNT index = 0;
- REBVAL *set_word = 0;
- REBVAL *cmd_word;
- REBSER *words;
- REBVAL *args;
- REBVAL *val;
- REBVAL *func;
- RXIFRM frm; // args stored here
- REBCNT n;
- REBEXT *ext;
- REBCEC *ctx;
-
- if ((ctx = context)) ctx->block = cmds;
- blk = BLK_HEAD(cmds);
-
- while (NOT_END(blk)) {
-
- // var: command result
- if IS_SET_WORD(blk) {
- set_word = blk++;
- index++;
- };
-
- // get command function
- if (IS_WORD(cmd_word = blk)) {
- // Optimized var fetch:
- n = VAL_WORD_INDEX(blk);
- if (n > 0) func = FRM_VALUES(VAL_WORD_FRAME(blk)) + n;
- else func = Get_Var(blk); // fallback
- } else func = blk;
-
- if (!IS_COMMAND(func)) Trap2(RE_EXPECT_VAL, Get_Type_Word(REB_COMMAND), blk);
-
- // Advance to next value
- blk++;
- if (ctx) ctx->index = index; // position of function
- index++;
-
- // get command arguments and body
- words = VAL_FUNC_WORDS(func);
- RXA_COUNT(&frm) = SERIES_TAIL(VAL_FUNC_ARGS(func))-1; // not self
-
- // collect each argument (arg list already validated on MAKE)
- n = 0;
- for (args = BLK_SKIP(words, 1); NOT_END(args); args++) {
-
- //Debug_Type(args);
- val = blk++;
- index++;
- if (IS_END(val)) Trap2(RE_NO_ARG, cmd_word, args);
- //Debug_Type(val);
-
- // actual arg is a word, lookup?
- if (VAL_TYPE(val) >= REB_WORD) {
- if (IS_WORD(val)) {
- if (IS_WORD(args)) val = Get_Var(val);
- }
- else if (IS_PATH(val)) {
- if (IS_WORD(args)) val = Get_Any_Var(val); // volatile value!
- }
- else if (IS_PAREN(val)) {
- val = Do_Blk(VAL_SERIES(val), 0); // volatile value!
- }
- // all others fall through
- }
-
- // check datatype
- if (!TYPE_CHECK(args, VAL_TYPE(val)))
- Trap3(RE_EXPECT_ARG, cmd_word, args, Of_Type(val));
-
- // put arg into command frame
- n++;
- RXA_TYPE(&frm, n) = Reb_To_RXT[VAL_TYPE(val)];
- frm.args[n] = Value_To_RXI(val);
- }
-
- // Call the command (also supports different extension modules):
- func = BLK_HEAD(VAL_FUNC_BODY(func));
- n = (REBCNT)VAL_INT64(func + 1);
- ext = &Ext_List[VAL_I32(VAL_OBJ_VALUE(func, 1))]; // Handler
- n = ext->call(n, &frm, context);
- val = DS_RETURN;
- switch (n) {
- case RXR_VALUE:
- RXI_To_Value(val, frm.args[1], RXA_TYPE(&frm, 1));
- break;
- case RXR_BLOCK:
- RXI_To_Block(&frm, val);
- break;
- case RXR_UNSET:
- SET_UNSET(val);
- break;
- case RXR_NONE:
- SET_NONE(val);
- break;
- case RXR_TRUE:
- SET_TRUE(val);
- break;
- case RXR_FALSE:
- SET_FALSE(val);
- break;
- case RXR_ERROR:
- default:
- SET_UNSET(val);
- }
-
- if (set_word) {
- Set_Var(set_word, val);
- set_word = 0;
- }
- }
+ UNUSED(f);
+
+ fail (Error_Native_Unloaded_Raw(FUNC_VALUE(f->phase)));
}
-/***********************************************************************
-**
-*/ REBNATIVE(do_commands)
-/*
-***********************************************************************/
+//
+// unload-native: native [
+//
+// "Unload a native when the containing extension is unloaded"
+//
+// return: []
+// nat [function!] "The native function to be unloaded"
+// ]
+//
+REBNATIVE(unload_native)
{
- REBCEC ctx;
+ INCLUDE_PARAMS_OF_UNLOAD_NATIVE;
- ctx.envr = 0;
- ctx.block = VAL_SERIES(D_ARG(1));
- ctx.index = 0;
- Do_Commands(ctx.block, &ctx);
+ REBFUN *fun = VAL_FUNC(ARG(nat));
+ if (NOT_VAL_FLAG(FUNC_VALUE(fun), FUNC_FLAG_UNLOADABLE_NATIVE))
+ fail (Error_Non_Unloadable_Native_Raw(ARG(nat)));
- return R_RET;
-}
+ FUNC_DISPATCHER(VAL_FUNC(ARG(nat))) = Unloaded_Dispatcher;
+ return R_VOID;
+}
-#ifdef notused
-/***********************************************************************
-**
-xx*/ REBVAL *Prior_Func_Frame(void)
-/*
-***********************************************************************/
+//
+// Init_Extension_Words: C
+//
+// Intern strings and save their canonical forms
+//
+void Init_Extension_Words(const REBYTE* strings[], REBSTR *canons[], REBCNT n)
{
- REBCNT dsf = DSF;
- REBVAL *val;
-
- for (dsf = DSF; dsf > 0; dsf = PRIOR_DSF(dsf)) {
- val = DSF_BACK(dsf);
- if (IS_BLOCK(val) && VAL_SERIES(val))
- return val;
- }
-
- return 0;
+ REBCNT i;
+ for (i = 0; i < n; ++i) {
+ canons[i] = STR_CANON(Intern_UTF8_Managed(strings[i], LEN_BYTES(strings[i])));
+ }
}
-#endif
-
diff --git a/src/core/f-int.c b/src/core/f-int.c
new file mode 100644
index 0000000000..62d803dc64
--- /dev/null
+++ b/src/core/f-int.c
@@ -0,0 +1,181 @@
+//
+// File: %f-int.c
+// Summary: "integer arithmetic functions"
+// Section: functional
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2014 Atronix Engineering, Inc
+// Copyright 2014-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Based on original code in t-integer.c
+//
+
+#include "reb-c.h"
+#include "sys-int-funcs.h"
+
+REBOOL reb_i32_add_overflow(i32 x, i32 y, i32 *sum)
+{
+ i64 sum64 = (i64)x + (i64)y;
+ if (sum64 > MAX_I32 || sum64 < MIN_I32) return TRUE;
+ *sum = (i32)sum64;
+ return FALSE;
+}
+
+REBOOL reb_u32_add_overflow(u32 x, u32 y, u32 *sum)
+{
+ u64 s = (u64)x + (u64)y;
+ if (s > MAX_I32) return TRUE;
+ *sum = (u32)s;
+ return FALSE;
+}
+
+REBOOL reb_i64_add_overflow(i64 x, i64 y, i64 *sum)
+{
+ *sum = (REBU64)x + (REBU64)y; /* never overflow with unsigned integers*/
+ if (((x < 0) == (y < 0))
+ && ((x < 0) != (*sum < 0))) return TRUE;
+ return FALSE;
+}
+
+REBOOL reb_u64_add_overflow(u64 x, u64 y, u64 *sum)
+{
+ *sum = x + y;
+ if (*sum < x || *sum < y) return TRUE;
+ return FALSE;
+}
+
+REBOOL reb_i32_sub_overflow(i32 x, i32 y, i32 *diff)
+{
+ *diff = (i64)x - (i64)y;
+ if (((x < 0) != (y < 0)) && ((x < 0) != (*diff < 0))) return TRUE;
+
+ return FALSE;
+}
+
+REBOOL reb_i64_sub_overflow(i64 x, i64 y, i64 *diff)
+{
+ *diff = (REBU64)x - (REBU64)y;
+ if (((x < 0) != (y < 0)) && ((x < 0) != (*diff < 0))) return TRUE;
+
+ return FALSE;
+}
+
+REBOOL reb_i32_mul_overflow(i32 x, i32 y, i32 *prod)
+{
+ i64 p = (i64)x * (i64)y;
+ if (p > MAX_I32 || p < MIN_I32) return TRUE;
+ *prod = (i32)p;
+ return FALSE;
+}
+
+REBOOL reb_u32_mul_overflow(u32 x, u32 y, u32 *prod)
+{
+ u64 p = (u64)x * (u64)y;
+ if (p > MAX_U32) return TRUE;
+ *prod = (u32)p;
+ return FALSE;
+}
+
+REBOOL reb_i64_mul_overflow(i64 x, i64 y, i64 *prod)
+{
+ REBOOL sgn;
+ u64 p = 0;
+
+ if (!x || !y) {
+ *prod = 0;
+ return FALSE;
+ }
+
+ sgn = LOGICAL(x < 0);
+ if (sgn) {
+ if (x == MIN_I64) {
+ switch (y) {
+ case 0:
+ *prod = 0;
+ return FALSE;
+ case 1:
+ *prod = x;
+ return FALSE;
+ default:
+ return TRUE;
+ }
+ }
+ x = -x; /* undefined when x == MIN_I64 */
+ }
+ if (y < 0) {
+ sgn = NOT(sgn);
+ if (y == MIN_I64) {
+ switch (x) {
+ case 0:
+ *prod = 0;
+ return FALSE;
+ case 1:
+ if (!sgn) {
+ return TRUE;
+ } else {
+ *prod = y;
+ return FALSE;
+ }
+ default:
+ return TRUE;
+ }
+ }
+ y = -y; /* undefined when y == MIN_I64 */
+ }
+
+ if (REB_U64_MUL_OF(x, y, (u64 *)&p)
+ || (!sgn && p > MAX_I64)
+ || (sgn && p - 1 > MAX_I64)) return TRUE; /* assumes 2's complements */
+
+ if (sgn && p == (u64)MIN_I64) {
+ *prod = MIN_I64;
+ return FALSE;
+ }
+
+ if (sgn)
+ *prod = -cast(i64, p);
+ else
+ *prod = p;
+
+ return FALSE;
+}
+
+REBOOL reb_u64_mul_overflow(u64 x, u64 y, u64 *prod)
+{
+ u64 x0, y0, x1, y1;
+ u64 b = U64_C(1) << 32;
+ u64 tmp = 0;
+ x1 = x >> 32;
+ x0 = (u32)x;
+ y1 = y >> 32;
+ y0 = (u32)y;
+
+ /* p = (x1 * y1) * b^2 + (x0 * y1 + x1 * y0) * b + x0 * y0 */
+
+ if (x1 && y1) return TRUE; /* (x1 * y1) * b^2 overflows */
+
+ tmp = (x0 * y1 + x1 * y0); /* never overflow, because x1 * y1 == 0 */
+ if (tmp >= b) return TRUE; /*(x0 * y1 + x1 * y0) * b overflows */
+
+ return LOGICAL(REB_U64_ADD_OF(tmp << 32, x0 * y0, prod));
+}
diff --git a/src/core/f-math.c b/src/core/f-math.c
index 5cbdbf2d1d..2abb9df8d4 100644
--- a/src/core/f-math.c
+++ b/src/core/f-math.c
@@ -1,473 +1,339 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: f-math.c
-** Summary: basic math conversions
-** Section: functional
-** Author: Carl Sassenrath
-** Notes:
-** Do not underestimate what it takes to make some parts of this
-** portable over all systems. Modifications to this code should be
-** tested on multiple operating system runtime libraries, including
-** older/obsolete systems.
-**
-***********************************************************************/
+//
+// File: %f-math.c
+// Summary: "basic math conversions"
+// Section: functional
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Do not underestimate what it takes to make some parts of this
+// portable over all systems. Modifications to this code should be
+// tested on multiple operating system runtime libraries, including
+// older/obsolete systems.
+//
#include "sys-core.h"
#include "sys-dec-to-char.h"
-/***********************************************************************
-**
-*/ REBYTE *Grab_Int(REBYTE *cp, REBINT *val)
-/*
-** Grab an integer value from the string.
-**
-** Return the character position just after the integer and return
-** the integer via a pointer to it.
-**
-** Notes:
-** 1. Stops at the first non-digit.
-** 2. If no integer found, pointer doesn't change position.
-** 3. Integers may contain REBOL tick (') marks.
-**
-***********************************************************************/
+//
+// Grab_Int: C
+//
+// Grab an integer value from the string.
+//
+// Return the character position just after the integer and return
+// the integer via a pointer to it.
+//
+// Notes:
+// 1. Stops at the first non-digit.
+// 2. If no integer found, pointer doesn't change position.
+// 3. Integers may contain REBOL tick (') marks.
+//
+const REBYTE *Grab_Int(const REBYTE *cp, REBINT *val)
{
- REBINT value = 0;
- REBINT neg = FALSE;
+ REBINT value = 0;
+ REBOOL neg = FALSE;
- if (*cp == '-') cp++, neg = TRUE;
- else if (*cp == '+') cp++;
+ if (*cp == '-') cp++, neg = TRUE;
+ else if (*cp == '+') cp++;
- while (*cp >= '0' && *cp <= '9') {
- value = (value * 10) + (*cp - '0');
- cp++;
- }
+ while (*cp >= '0' && *cp <= '9') {
+ value = (value * 10) + (*cp - '0');
+ cp++;
+ }
- *val = neg ? -value : value;
+ *val = neg ? -value : value;
- return cp;
+ return cp;
}
-/***********************************************************************
-**
-*/ REBYTE *Grab_Int_Scale(REBYTE *cp, REBINT *val, REBCNT scale)
-/*
-** Return integer scaled to the number of digits specified.
-** Used for the decimal part of numbers (e.g. times).
-**
-***********************************************************************/
+//
+// Grab_Int_Scale: C
+//
+// Return integer scaled to the number of digits specified.
+// Used for the decimal part of numbers (e.g. times).
+//
+const REBYTE *Grab_Int_Scale(const REBYTE *cp, REBINT *val, REBCNT scale)
{
- REBI64 value = 0;
+ REBI64 value = 0;
- for (;scale > 0 && *cp >= '0' && *cp <= '9'; scale--) {
- value = (value * 10) + (*cp - '0');
- cp++;
- }
+ for (;scale > 0 && *cp >= '0' && *cp <= '9'; scale--) {
+ value = (value * 10) + (*cp - '0');
+ cp++;
+ }
- // Round up if necessary:
- if (*cp >= '5' && *cp <= '9') value++;
+ // Round up if necessary:
+ if (*cp >= '5' && *cp <= '9') value++;
- // Ignore excess digits:
- while (*cp >= '0' && *cp <= '9') cp++;
+ // Ignore excess digits:
+ while (*cp >= '0' && *cp <= '9') cp++;
- // Make sure its full scale:
- for (;scale > 0; scale--) value *= 10;
+ // Make sure its full scale:
+ for (;scale > 0; scale--) value *= 10;
- *val = (REBINT)value;
- return cp;
+ *val = (REBINT)value;
+ return cp;
}
-/***********************************************************************
-**
-*/ REBINT Form_Int_Len(REBYTE *buf, REBI64 val, REBINT maxl)
-/*
-** Form an integer string into the given buffer. Result will
-** not exceed maxl length, including terminator.
-**
-** Returns the length of the string.
-**
-** Notes:
-** 1. If result is longer than maxl, returns 0 length.
-** 2. Make sure you have room in your buffer!
-**
-***********************************************************************/
+//
+// Form_Int_Len: C
+//
+// Form an integer string into the given buffer. Result will
+// not exceed maxl length, including terminator.
+//
+// Returns the length of the string.
+//
+// Notes:
+// 1. If result is longer than maxl, returns 0 length.
+// 2. Make sure you have room in your buffer!
+//
+REBINT Form_Int_Len(REBYTE *buf, REBI64 val, REBINT maxl)
{
- REBYTE tmp[MAX_NUM_LEN];
- REBYTE *tp = tmp;
- REBI64 n;
- REBI64 r;
- REBINT len = 0;
-
- // defaults for problem cases
- buf[0] = '?';
- buf[1] = 0;
-
- if (maxl == 0) return 0;
-
- if (val == 0) {
- *buf++ = '0';
- *buf = 0;
- return 1;
- }
-
- if (val < 0) {
- val = -val;
- *buf++ = '-';
- maxl--;
- len = 1;
- }
-
- // Generate string in reverse:
- *tp++ = 0;
- while (val != 0) {
- n = val / 10; // not using ldiv for easier compatibility
- r = val % 10;
- if (r < 0) { // check for overflow case when val = 0x80000000...
- r = -r;
- n = -n;
- }
- *tp++ = (REBYTE)('0' + (REBYTE)(r));
- val = n;
- }
- tp--;
-
- if (tp - tmp > maxl) return 0;
-
- while (NZ(*buf++ = *tp--)) len++;
- return len;
+ REBYTE tmp[MAX_NUM_LEN];
+ REBYTE *tp = tmp;
+ REBI64 n;
+ REBI64 r;
+ REBINT len = 0;
+
+ // defaults for problem cases
+ buf[0] = '?';
+ buf[1] = 0;
+
+ if (maxl == 0) return 0;
+
+ if (val == 0) {
+ *buf++ = '0';
+ *buf = 0;
+ return 1;
+ }
+
+#define MIN_I64_STR "-9223372036854775808"
+ if (val == MIN_I64) {
+ len = strlen(MIN_I64_STR);
+ if (maxl < len + 1) return 0;
+ memcpy(buf, MIN_I64_STR, len + 1);
+ return len;
+ }
+
+ if (val < 0) {
+ val = -val;
+ *buf++ = '-';
+ maxl--;
+ len = 1;
+ }
+
+ // Generate string in reverse:
+ *tp++ = 0;
+ while (val != 0 && maxl > 0 && tp < tmp + MAX_NUM_LEN) {
+ n = val / 10; // not using ldiv for easier compatibility
+ r = val % 10;
+ *tp++ = (REBYTE)('0' + (REBYTE)(r));
+ val = n;
+ maxl --;
+ }
+ tp--;
+
+ if (maxl == 0) {
+ return 0;
+ }
+
+ while ((*buf++ = *tp--)) len++;
+ return len;
}
-/***********************************************************************
-**
-*/ REBYTE *Form_Int_Pad(REBYTE *buf, REBI64 val, REBINT max, REBINT len, REBYTE pad)
-/*
-** Form an integer string in the given buffer with a min
-** width padded out with the given character. Len > 0 left
-** aligned. Len < 0 is right aligned.
-**
-** If len = 0 and val = 0, a null string is formed.
-** Make sure you have room in your buffer before calling this!
-**
-***********************************************************************/
+//
+// Form_Int_Pad: C
+//
+// Form an integer string in the given buffer with a min
+// width padded out with the given character. Len > 0 left
+// aligned. Len < 0 is right aligned.
+//
+// If len = 0 and val = 0, a null string is formed.
+// Make sure you have room in your buffer before calling this!
+//
+REBYTE *Form_Int_Pad(REBYTE *buf, REBI64 val, REBINT max, REBINT len, REBYTE pad)
{
- REBYTE tmp[MAX_NUM_LEN];
- REBINT n;
-
- n = Form_Int_Len(tmp, val, max);
- if (n == 0) {
- strcpy(buf, "??");
- return buf; // too long
- }
-
- if (len >= 0) {
- strcpy(buf, tmp);
- buf += n;
- for (; n < len; n++) *buf++ = pad;
- }
- else { // len < 0
- for (; n < -len; len++) *buf++ = pad;
- strcpy(buf, tmp);
- buf += n;
- }
-
- *buf = 0;
- return buf;
+ REBYTE tmp[MAX_NUM_LEN];
+ REBINT n;
+
+ n = Form_Int_Len(tmp, val, max + 1);
+ if (n == 0) {
+ strcpy(s_cast(buf), "??");
+ return buf; // too long
+ }
+
+ if (len >= 0) {
+ strcpy(s_cast(buf), s_cast(tmp));
+ buf += n;
+ for (; n < len; n++) *buf++ = pad;
+ }
+ else { // len < 0
+ for (; n < -len; len++) *buf++ = pad;
+ strcpy(s_cast(buf), s_cast(tmp));
+ buf += n;
+ }
+
+ *buf = 0;
+ return buf;
}
-/***********************************************************************
-**
-*/ REBYTE *Form_Int(REBYTE *buf, REBINT val)
-/*
-** Form 32 bit integer string in the given buffer.
-** Make sure you have room in your buffer before calling this!
-**
-***********************************************************************/
+//
+// Form_Int: C
+//
+// Form 32 bit integer string in the given buffer.
+// Make sure you have room in your buffer before calling this!
+//
+REBYTE *Form_Int(REBYTE *buf, REBINT val)
{
- REBINT len = Form_Int_Len(buf, val, MAX_NUM_LEN);
- return buf + len;
+ REBINT len = Form_Int_Len(buf, val, MAX_NUM_LEN);
+ return buf + len;
}
-/***********************************************************************
-**
-*/ REBYTE *Form_Integer(REBYTE *buf, REBI64 val)
-/*
-** Form standard REBOL integer value (32 or 64).
-** Make sure you have room in your buffer before calling this!
-**
-***********************************************************************/
+//
+// Form_Integer: C
+//
+// Form standard REBOL integer value (32 or 64).
+// Make sure you have room in your buffer before calling this!
+//
+REBYTE *Form_Integer(REBYTE *buf, REBI64 val)
{
- INT_TO_STR(val, buf);
- return buf+LEN_BYTES(buf);
+ INT_TO_STR(val, buf);
+ return buf+LEN_BYTES(buf);
}
-/***********************************************************************
-**
-*/ REBINT Emit_Integer(REBYTE *buf, REBI64 val)
-/*
-***********************************************************************/
+//
+// Emit_Integer: C
+//
+REBINT Emit_Integer(REBYTE *buf, REBI64 val)
{
- INT_TO_STR(val, buf);
- return LEN_BYTES(buf);
+ INT_TO_STR(val, buf);
+ return LEN_BYTES(buf);
}
-#ifdef OLDER
-/***********************************************************************
-**
-xx*/ REBCNT Set_Random(REBCNT seed)
-/*
-***********************************************************************/
-{
- REBCNT save = next;
- next = seed;
- return save;
-}
-
-
-/***********************************************************************
-**
-xx*/ REBCNT Random_Int(REBFLG secure)
-/*
-** Return random integer. Secure uses SHA1 for better quality.
-** Be careful of endian-ness.
-**
-***********************************************************************/
-{
- REBCNT tmp;
-
- next = next * 1103515245L + 12345L;
- tmp = next & 0xffff0000;
- next = next * 1103515245L + 12345L;
- tmp |= (next >> 16);
-
- if (secure) {
- REBYTE srcbuf[20], dstbuf[20];
- REBCNT i;
-
- Long_To_Bytes(srcbuf, tmp);
- for(i = sizeof(tmp); i < 20; i += sizeof(tmp))
- memcpy(srcbuf + i, srcbuf, sizeof(tmp));
- SHA1(srcbuf, i, dstbuf);
- tmp = Bytes_To_Long(dstbuf);
- }
-
- return tmp;
-}
-#endif
-
-#ifdef OLD_DEC_TO_STR
-static int Convert_Decimal(REBDEC d, REBI64 *sig, REBINT *point)
-{
- REBDEC e;
- REBDEC n;
-
- // Check if num needs exp format:
- e = floor(log10(d));
- if (e > 15 || e < -6) return 0; // use gcvt
-
- modf(d * pow(10, (15-e)), &n);
- *sig = (REBI64)n;
- *point = 1 + (REBINT)e;
- return 1;
-}
-
-/***********************************************************************
-**
-*/ REBINT Emit_Decimal(REBYTE *cp, REBDEC d, REBFLG percent, REBYTE point, REBINT digits)
-/*
-***********************************************************************/
-{
- REBYTE out[MAX_NUMCHR];
- REBINT len;
- REBINT n;
- REBINT i;
- REBI64 sig;
- REBINT pt;
- REBFLG neg;
- REBYTE *start = cp;
-
- *cp = out[0] = 0;
-
- // Deal with 0 as special case:
- if (d == 0.0 || d == -0.0) {
- *cp++ = '0';
- if (!percent) {
- *cp++ = '.';
- *cp++ = '0';
- }
- }
- else {
-
- if (percent) d *= 100.0;
-
- if (NZ(neg = (d < 0))) d = -d;
-
- if (Convert_Decimal(d, &sig, &pt)) {
- // Not exp format.
- len = Form_Integer(out, sig) - out;
- if (neg) *cp++ = '-';
-
- // Trim un-needed trailing zeros:
- for (len--; len > 0 && len >= pt; len--) {
- if (out[len] == '0') out[len] = 0;
- else break;
- }
-
- // Leading zero, as in 0.1
- if (pt <= 0) *cp++ = '0';
-
- // Other leading digits:
- for (n = 0; out[n] && n < pt; n++) *cp++ = out[n];
-
- if (!percent || n <= len) {
- // Decimal point:
- *cp++ = point;
-
- // Zeros before first significant digit:
- for (i = 0; i > pt; i--) *cp++ = '0';
-
- // All remaining digits:
- for (; n <= len; n++) *cp++ = out[n];
-
- // Force extra zero in 1.0 cases:
- if (cp[-1] == point) *cp++ = '0';
- }
- }
- else {
- REBYTE *pp;
-
- // Requires exp format:
- if (percent) Trap0(RE_OVERFLOW);
- len = Get_System_Int(SYS_OPTIONS, OPTIONS_DECIMAL_DIGITS, MAX_DIGITS);
- if (len > MAX_DIGITS) len = MAX_DIGITS;
- gcvt(d, len, cp); // returns 1.2e123 (also 1e123)
- pp = strchr(cp, '.');
- if (pp && (pp[1] == 'e' || pp[1] == 'E')) {
- memcpy(pp, pp+1, strlen(pp));
- }
- if (point != '.' && pp) {
- cp = strchr(cp, '.');
- if (cp) *cp = point;
- }
- cp = start + LEN_BYTES(start);
- }
- }
-
- if (percent) *cp++ = '%';
- *cp = 0;
-
- return cp - start;
-}
-
-#else // NEW_DEC_TO_STR
#define MIN_DIGITS 1
/* this is appropriate for 64-bit IEEE754 binary floating point format */
#define MAX_DIGITS 17
-REBINT Emit_Decimal(REBYTE *cp, REBDEC d, REBFLG trim, REBYTE point, REBINT decimal_digits) {
- REBYTE *start = cp, *sig, *rve;
- int e, sgn;
- REBINT digits_obtained;
-
- /* sanity checks */
- if (decimal_digits < MIN_DIGITS) decimal_digits = MIN_DIGITS;
- else if (decimal_digits > MAX_DIGITS) decimal_digits = MAX_DIGITS;
-
- sig = (REBYTE *) dtoa (d, 0, decimal_digits, &e, &sgn, (char **) &rve);
-
- digits_obtained = rve - sig;
-
- /* handle sign */
- if (sgn) *cp++ = '-';
-
- if (trim == DEC_MOLD_PERCENT) e += 2;
-
- if ((e > decimal_digits) || (e <= -6)) {
- /* e-format */
- *cp++ = *sig++;
-
- /* insert the radix point */
- *cp++ = point;
-
- /* insert the rest */
- memcpy(cp, sig, digits_obtained - 1);
- cp += digits_obtained - 1;
- } else if (e > 0) {
- if (e <= digits_obtained) {
- /* insert digits preceding point */
- memcpy (cp, sig, e);
- cp += e;
- sig += e;
-
- *cp++ = point;
-
- /* insert digits following point */
- memcpy(cp, sig, digits_obtained - e);
- cp += digits_obtained - e;
- } else {
- /* insert all digits obtained */
- memcpy (cp, sig, digits_obtained);
- cp += digits_obtained;
-
- /* insert zeros preceding point */
- memset (cp, '0', e - digits_obtained);
- cp += e - digits_obtained;
-
- *cp++ = point;
- }
- e = 0;
- } else {
- *cp++ = '0';
-
- *cp++ = point;
-
- memset(cp, '0', -e);
- cp -= e;
-
- memcpy(cp, sig, digits_obtained);
- cp += digits_obtained;
-
- e = 0;
- }
-
- // Add at least one zero after point (unless percent or pair):
- if (*(cp - 1) == point) {if (trim) cp--; else *cp++ = '0';}
-
- // Add E part if needed:
- if (e) {
- *cp++ = 'e';
- INT_TO_STR(e - 1, cp);
- cp = strchr(cp, 0);
- }
-
- if (trim == DEC_MOLD_PERCENT) *cp++ = '%';
- *cp = 0;
- return cp - start;
+//
+// Emit_Decimal: C
+//
+REBINT Emit_Decimal(
+ REBYTE *cp,
+ REBDEC d,
+ REBFLGS flags, // DEC_MOLD_PERCENT, DEC_MOLD_MINIMAL
+ REBYTE point,
+ REBINT decimal_digits
+) {
+ REBYTE *start = cp, *sig, *rve;
+ int e, sgn;
+ REBINT digits_obtained;
+
+ /* sanity checks */
+ if (decimal_digits < MIN_DIGITS) decimal_digits = MIN_DIGITS;
+ else if (decimal_digits > MAX_DIGITS) decimal_digits = MAX_DIGITS;
+
+ sig = (REBYTE *) dtoa (d, 0, decimal_digits, &e, &sgn, (char **) &rve);
+
+ digits_obtained = rve - sig;
+
+ /* handle sign */
+ if (sgn) *cp++ = '-';
+
+ if (flags & DEC_MOLD_PERCENT) e += 2;
+
+ if ((e > decimal_digits) || (e <= -6)) {
+ /* e-format */
+ *cp++ = *sig++;
+
+ /* insert the radix point */
+ *cp++ = point;
+
+ /* insert the rest */
+ memcpy(cp, sig, digits_obtained - 1);
+ cp += digits_obtained - 1;
+ } else if (e > 0) {
+ if (e <= digits_obtained) {
+ /* insert digits preceding point */
+ memcpy (cp, sig, e);
+ cp += e;
+ sig += e;
+
+ *cp++ = point;
+
+ /* insert digits following point */
+ memcpy(cp, sig, digits_obtained - e);
+ cp += digits_obtained - e;
+ } else {
+ /* insert all digits obtained */
+ memcpy (cp, sig, digits_obtained);
+ cp += digits_obtained;
+
+ /* insert zeros preceding point */
+ memset (cp, '0', e - digits_obtained);
+ cp += e - digits_obtained;
+
+ *cp++ = point;
+ }
+ e = 0;
+ } else {
+ *cp++ = '0';
+
+ *cp++ = point;
+
+ memset(cp, '0', -e);
+ cp -= e;
+
+ memcpy(cp, sig, digits_obtained);
+ cp += digits_obtained;
+
+ e = 0;
+ }
+
+ // Add at least one zero after point (unless percent or pair):
+ if (*(cp - 1) == point) {
+ if ((flags & DEC_MOLD_PERCENT) || (flags & DEC_MOLD_MINIMAL))
+ cp--;
+ else
+ *cp++ = '0';
+ }
+
+ // Add E part if needed:
+ if (e) {
+ *cp++ = 'e';
+ INT_TO_STR(e - 1, cp);
+ cp = b_cast(strchr(s_cast(cp), 0));
+ }
+
+ if (flags & DEC_MOLD_PERCENT) *cp++ = '%';
+ *cp = 0;
+ return cp - start;
}
-#endif // NEW_DEC_TO_STR
diff --git a/src/core/f-modify.c b/src/core/f-modify.c
index 2e6f3c5943..293d8295c0 100644
--- a/src/core/f-modify.c
+++ b/src/core/f-modify.c
@@ -1,198 +1,275 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: f-modify.c
-** Summary: block series modification (insert, append, change)
-** Section: functional
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %f-modify.c
+// Summary: "block series modification (insert, append, change)"
+// Section: functional
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ REBCNT Modify_Block(REBCNT action, REBSER *dst_ser, REBCNT dst_idx, REBVAL *src_val, REBCNT flags, REBINT dst_len, REBINT dups)
-/*
-** action: INSERT, APPEND, CHANGE
-**
-** dst_ser: target
-** dst_idx: position
-** src_val: source
-** flags: AN_ONLY, AN_PART
-** dst_len: length to remove
-** dups: dup count
-**
-** return: new dst_idx
-**
-***********************************************************************/
-{
- REBCNT tail = SERIES_TAIL(dst_ser);
- REBINT ilen = 1; // length to be inserted
- REBINT size; // total to insert
- REBFLG is_blk = FALSE; // src_val is a block not a value
-
- if (dups < 0) return (action == A_APPEND) ? 0 : dst_idx;
- if (action == A_APPEND || dst_idx > tail) dst_idx = tail;
-
- // Check /PART, compute LEN:
- if (!GET_FLAG(flags, AN_ONLY) && ANY_BLOCK(src_val)) {
- is_blk = TRUE; // src_val is a block
- // Are we modifying ourselves? If so, copy src_val block first:
- if (dst_ser == VAL_SERIES(src_val)) {
- VAL_SERIES(src_val) = Copy_Block(VAL_SERIES(src_val), VAL_INDEX(src_val));
- VAL_INDEX(src_val) = 0;
- }
- // Length of insertion:
- ilen = (action != A_CHANGE && GET_FLAG(flags, AN_PART)) ? dst_len : VAL_LEN(src_val);
- }
-
- // Total to insert:
- size = dups * ilen;
-
- if (action != A_CHANGE) {
- // Always expand dst_ser for INSERT and APPEND actions:
- Expand_Series(dst_ser, dst_idx, size);
- } else {
- if (size > dst_len)
- Expand_Series(dst_ser, dst_idx, size-dst_len);
- else if (size < dst_len && GET_FLAG(flags, AN_PART))
- Remove_Series(dst_ser, dst_idx, dst_len-size);
- else if (size + dst_idx > tail) {
- EXPAND_SERIES_TAIL(dst_ser, size - (tail - dst_idx));
- }
- }
-
- tail = (action == A_APPEND) ? 0 : size + dst_idx;
-
- if (is_blk) src_val = VAL_BLK_DATA(src_val);
-
- dst_idx *= SERIES_WIDE(dst_ser); // loop invariant
- ilen *= SERIES_WIDE(dst_ser); // loop invariant
- for (; dups > 0; dups--) {
- memcpy(dst_ser->data + dst_idx, (REBYTE *)src_val, ilen);
- dst_idx += ilen;
- }
- BLK_TERM(dst_ser);
-
- return tail;
+//
+// Modify_Array: C
+//
+// Returns new dst_idx
+//
+REBCNT Modify_Array(
+ REBCNT action, // INSERT, APPEND, CHANGE
+ REBARR *dst_arr, // target
+ REBCNT dst_idx, // position
+ const REBVAL *src_val, // source
+ REBCNT flags, // AM_ONLY, AM_PART
+ REBINT dst_len, // length to remove
+ REBINT dups // dup count
+) {
+ REBCNT tail = ARR_LEN(dst_arr);
+
+ REBINT ilen = 1; // length to be inserted
+
+ const RELVAL *src_rel;
+ REBSPC *specifier;
+
+ if (IS_VOID(src_val) || dups < 0) {
+ // If they are effectively asking for "no action" then all we have
+ // to do is return the natural index result for the operation.
+ // (APPEND will return 0, insert the tail of the insertion...so index)
+
+ return (action == SYM_APPEND) ? 0 : dst_idx;
+ }
+
+ if (action == SYM_APPEND || dst_idx > tail) dst_idx = tail;
+
+ // Check /PART, compute LEN:
+ if (NOT(flags & AM_ONLY) && ANY_ARRAY(src_val)) {
+ // Adjust length of insertion if changing /PART:
+ if (action != SYM_CHANGE && (flags & AM_PART))
+ ilen = dst_len;
+ else
+ ilen = VAL_LEN_AT(src_val);
+
+ // Are we modifying ourselves? If so, copy src_val block first:
+ if (dst_arr == VAL_ARRAY(src_val)) {
+ REBARR *copy = Copy_Array_At_Shallow(
+ VAL_ARRAY(src_val), VAL_INDEX(src_val), VAL_SPECIFIER(src_val)
+ );
+ MANAGE_ARRAY(copy); // !!! Review: worth it to not manage and free?
+ src_rel = ARR_HEAD(copy);
+ specifier = SPECIFIED; // copy already specified it
+ }
+ else {
+ src_rel = VAL_ARRAY_AT(src_val); // skips by VAL_INDEX values
+ specifier = VAL_SPECIFIER(src_val);
+ }
+ }
+ else {
+ // use passed in RELVAL and specifier
+ src_rel = src_val;
+ specifier = SPECIFIED; // it's a REBVAL, not a RELVAL, so specified
+ }
+
+ REBINT size = dups * ilen; // total to insert
+
+ if (action != SYM_CHANGE) {
+ // Always expand dst_arr for INSERT and APPEND actions:
+ Expand_Series(SER(dst_arr), dst_idx, size);
+ }
+ else {
+ if (size > dst_len)
+ Expand_Series(SER(dst_arr), dst_idx, size-dst_len);
+ else if (size < dst_len && (flags & AM_PART))
+ Remove_Series(SER(dst_arr), dst_idx, dst_len-size);
+ else if (size + dst_idx > tail) {
+ EXPAND_SERIES_TAIL(SER(dst_arr), size - (tail - dst_idx));
+ }
+ }
+
+ tail = (action == SYM_APPEND) ? 0 : size + dst_idx;
+
+#if !defined(NDEBUG)
+ if (IS_ARRAY_MANAGED(dst_arr)) {
+ REBINT i;
+ for (i = 0; i < ilen; ++i)
+ ASSERT_VALUE_MANAGED(&src_rel[i]);
+ }
+#endif
+
+ for (; dups > 0; dups--) {
+ REBINT index = 0;
+ for (; index < ilen; ++index, ++dst_idx) {
+ Derelativize(
+ ARR_HEAD(dst_arr) + dst_idx,
+ src_rel + index,
+ specifier
+ );
+ }
+ }
+ TERM_ARRAY_LEN(dst_arr, ARR_LEN(dst_arr));
+
+ ASSERT_ARRAY(dst_arr);
+
+ return tail;
}
-/***********************************************************************
-**
-*/ REBCNT Modify_String(REBCNT action, REBSER *dst_ser, REBCNT dst_idx, REBVAL *src_val, REBCNT flags, REBINT dst_len, REBINT dups)
-/*
-** action: INSERT, APPEND, CHANGE
-**
-** dst_ser: target
-** dst_idx: position
-** src_val: source
-** flags: AN_PART
-** dst_len: length to remove
-** dups: dup count
-**
-** return: new dst_idx
-**
-***********************************************************************/
-{
- REBSER *src_ser = 0;
- REBCNT src_idx = 0;
- REBCNT src_len;
- REBCNT tail = SERIES_TAIL(dst_ser);
- REBINT size; // total to insert
-
- if (dups < 0) return (action == A_APPEND) ? 0 : dst_idx;
- if (action == A_APPEND || dst_idx > tail) dst_idx = tail;
-
- // If the src_val is not a string, then we need to create a string:
- if (GET_FLAG(flags, AN_SERIES)) { // used to indicate a BINARY series
- if (IS_INTEGER(src_val)) {
- src_ser = Append_Byte(0, Int8u(src_val)); // creates a binary
- }
- else if (IS_BLOCK(src_val)) {
- src_ser = Join_Binary(src_val); // NOTE: it's the shared FORM buffer!
- }
- else if (IS_CHAR(src_val)) {
- src_ser = Make_Binary(6); // (I hate unicode)
- src_ser->tail = Encode_UTF8_Char(BIN_HEAD(src_ser), VAL_CHAR(src_val));
- }
- else if (!ANY_BINSTR(src_val)) Trap_Arg(src_val);
- }
- else if (IS_CHAR(src_val)) {
- src_ser = Append_Byte(0, VAL_CHAR(src_val)); // unicode ok too
- }
- else if (IS_BLOCK(src_val)) {
- src_ser = Form_Tight_Block(src_val);
- }
- else if (!ANY_STR(src_val) || IS_TAG(src_val)) {
- src_ser = Copy_Form_Value(src_val, 0);
- }
-
- // Use either new src or the one that was passed:
- if (src_ser) {
- src_len = SERIES_TAIL(src_ser);
- }
- else {
- src_ser = VAL_SERIES(src_val);
- src_idx = VAL_INDEX(src_val);
- src_len = VAL_LEN(src_val);
- }
-
- // For INSERT or APPEND with /PART use the dst_len not src_len:
- if (action != A_CHANGE && GET_FLAG(flags, AN_PART)) src_len = dst_len;
-
- // If Source == Destination we need to prevent possible conflicts.
- // Clone the argument just to be safe.
- // (Note: It may be possible to optimize special cases like append !!)
- if (dst_ser == src_ser) {
- src_ser = Copy_Series_Part(src_ser, src_idx, src_len);
- src_idx = 0;
- }
-
- // Total to insert:
- size = dups * src_len;
-
- if (action != A_CHANGE) {
- // Always expand dst_ser for INSERT and APPEND actions:
- Expand_Series(dst_ser, dst_idx, size);
- } else {
- if (size > dst_len)
- Expand_Series(dst_ser, dst_idx, size - dst_len);
- else if (size < dst_len && GET_FLAG(flags, AN_PART))
- Remove_Series(dst_ser, dst_idx, dst_len - size);
- else if (size + dst_idx > tail) {
- EXPAND_SERIES_TAIL(dst_ser, size - (tail - dst_idx));
- }
- }
-
- // For dup count:
- for (; dups > 0; dups--) {
- Insert_String(dst_ser, dst_idx, src_ser, src_idx, src_len, TRUE);
- dst_idx += src_len;
- }
-
- TERM_SERIES(dst_ser);
-
- return (action == A_APPEND) ? 0 : dst_idx;
+//
+// Modify_String: C
+//
+// Returns new dst_idx.
+//
+REBCNT Modify_String(
+ REBCNT action, // INSERT, APPEND, CHANGE
+ REBSER *dst_ser, // target
+ REBCNT dst_idx, // position
+ const REBVAL *src_val, // source
+ REBFLGS flags, // AM_PART, AM_BINARY_SERIES
+ REBINT dst_len, // length to remove
+ REBINT dups // dup count
+) {
+ REBSER *src_ser = 0;
+ REBCNT src_idx = 0;
+ REBCNT src_len;
+ REBCNT tail = SER_LEN(dst_ser);
+ REBINT size; // total to insert
+ REBOOL needs_free;
+ REBINT limit;
+
+ // For INSERT/PART and APPEND/PART
+ if (action != SYM_CHANGE && (flags & AM_PART))
+ limit = dst_len; // should be non-negative
+ else
+ limit = -1;
+
+ if (IS_VOID(src_val) || limit == 0 || dups < 0)
+ return (action == SYM_APPEND) ? 0 : dst_idx;
+
+ if (action == SYM_APPEND || dst_idx > tail) dst_idx = tail;
+
+ // If the src_val is not a string, then we need to create a string:
+ if (flags & AM_BINARY_SERIES) {
+ if (IS_INTEGER(src_val)) {
+ src_ser = Make_Series_Codepoint(Int8u(src_val));
+ needs_free = TRUE;
+ limit = -1;
+ }
+ else if (IS_BLOCK(src_val)) {
+ src_ser = Join_Binary(src_val, limit); // NOTE: it's the shared FORM buffer!
+ needs_free = FALSE;
+ limit = -1;
+ }
+ else if (IS_CHAR(src_val)) {
+ //
+ // "UTF-8 was originally specified to allow codepoints with up to
+ // 31 bits (or 6 bytes). But with RFC3629, this was reduced to 4
+ // bytes max. to be more compatible to UTF-16." So depending on
+ // which RFC you consider "the UTF-8", max size is either 4 or 6.
+ //
+ src_ser = Make_Binary(6);
+ SET_SERIES_LEN(
+ src_ser,
+ Encode_UTF8_Char(BIN_HEAD(src_ser), VAL_CHAR(src_val))
+ );
+ needs_free = TRUE;
+ limit = -1;
+ }
+ else if (ANY_STRING(src_val)) {
+ src_len = VAL_LEN_AT(src_val);
+ if (limit >= 0 && src_len > cast(REBCNT, limit))
+ src_len = limit;
+ src_ser = Make_UTF8_From_Any_String(src_val, src_len, 0);
+ needs_free = TRUE;
+ limit = -1;
+ }
+ else if (!IS_BINARY(src_val))
+ fail (src_val);
+ }
+ else if (IS_CHAR(src_val)) {
+ src_ser = Make_Series_Codepoint(VAL_CHAR(src_val));
+ needs_free = TRUE;
+ }
+ else if (IS_BLOCK(src_val)) {
+ src_ser = Form_Tight_Block(src_val);
+ needs_free = TRUE;
+ }
+ else if (!ANY_STRING(src_val) || IS_TAG(src_val)) {
+ src_ser = Copy_Form_Value(src_val, 0);
+ needs_free = TRUE;
+ }
+
+ // Use either new src or the one that was passed:
+ if (src_ser) {
+ src_len = SER_LEN(src_ser);
+ }
+ else {
+ src_ser = VAL_SERIES(src_val);
+ src_idx = VAL_INDEX(src_val);
+ src_len = VAL_LEN_AT(src_val);
+ needs_free = FALSE;
+ }
+
+ if (limit >= 0) src_len = limit;
+
+ // If Source == Destination we need to prevent possible conflicts.
+ // Clone the argument just to be safe.
+ // (Note: It may be possible to optimize special cases like append !!)
+ if (dst_ser == src_ser) {
+ assert(!needs_free);
+ src_ser = Copy_Sequence_At_Len(src_ser, src_idx, src_len);
+ needs_free = TRUE;
+ src_idx = 0;
+ }
+
+ // Total to insert:
+ size = dups * src_len;
+
+ if (action != SYM_CHANGE) {
+ // Always expand dst_ser for INSERT and APPEND actions:
+ Expand_Series(dst_ser, dst_idx, size);
+ } else {
+ if (size > dst_len)
+ Expand_Series(dst_ser, dst_idx, size - dst_len);
+ else if (size < dst_len && (flags & AM_PART))
+ Remove_Series(dst_ser, dst_idx, dst_len - size);
+ else if (size + dst_idx > tail) {
+ EXPAND_SERIES_TAIL(dst_ser, size - (tail - dst_idx));
+ }
+ }
+
+ // For dup count:
+ for (; dups > 0; dups--) {
+ Insert_String(dst_ser, dst_idx, src_ser, src_idx, src_len, TRUE);
+ dst_idx += src_len;
+ }
+
+ TERM_SEQUENCE(dst_ser);
+
+ if (needs_free) {
+ // If we did not use the series that was passed in, but rather
+ // created an internal temporary one, we need to free it.
+ Free_Series(src_ser);
+ }
+
+ return (action == SYM_APPEND) ? 0 : dst_idx;
}
diff --git a/src/core/f-qsort.c b/src/core/f-qsort.c
index 0040472a75..dd42fdaf29 100644
--- a/src/core/f-qsort.c
+++ b/src/core/f-qsort.c
@@ -2,9 +2,24 @@
* https://raw.github.com/android/platform_bionic/master/libc/upstream-freebsd/lib/libc/stdlib/qsort.c
*/
+
+// "The qsort_r() function is identical to qsort() except that the comparison
+// function takes a third argument. A pointer is passed to the comparison
+// function via [thunk]. In this way, the comparison function does not
+// need to use global variables to pass through arbitrary arguments, and
+// is therefore reentrant and safe to use in threads."
+//
+// This file can declare either qsort or qsort_r, and we'd like the latter.
+// Note that `qsort_r` is part of no portability standard, and this version
+// (used by Android) puts the "thunk" as the next to last parameter instead
+// of the last one. :-/
+//
+#define I_AM_QSORT_R
+
+
/*-
* Copyright (c) 1992, 1993
- * The Regents of the University of California. All rights reserved.
+ * The Regents of the University of California. All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
@@ -32,7 +47,7 @@
*/
#if defined(LIBC_SCCS) && !defined(lint)
-static char sccsid[] = "@(#)qsort.c 8.1 (Berkeley) 6/4/93";
+static char sccsid[] = "@(#)qsort.c 8.1 (Berkeley) 6/4/93";
#endif /* LIBC_SCCS and not lint */
/* commented out by L.M.
@@ -42,73 +57,85 @@ __FBSDID("$FreeBSD$");
#include
+// When qsort_r is defined, it will actually wind up being named reb_qsort_r.
+// Define this after including to avoid the prototype being
+// declared as extern "C"
+//
+#define qsort_r reb_qsort_r
+
#ifdef I_AM_QSORT_R
-typedef int cmp_t(void *, const void *, const void *);
+typedef int cmp_t(void *, const void *, const void *);
#else
-typedef int cmp_t(const void *, const void *);
+typedef int cmp_t(const void *, const void *);
#endif
-static inline char *med3(char *, char *, char *, cmp_t *, void *);
-static inline void swapfunc(char *, char *, int, int);
+#ifdef _MSC_VER
+#define __inline__
+#else
+#define __inline__ inline
+#endif
+
+static __inline__ char *med3(char *, char *, char *, cmp_t *, void *);
+static __inline__ void swapfunc(char *, char *, int, int);
-#define min(a, b) (a) < (b) ? a : b
+#if !defined(min)
+ #define min(a, b) (a) < (b) ? a : b
+#endif
/*
* Qsort routine from Bentley & McIlroy's "Engineering a Sort Function".
*/
-#define swapcode(TYPE, parmi, parmj, n) { \
- long i = (n) / sizeof (TYPE); \
- TYPE *pi = (TYPE *) (parmi); \
- TYPE *pj = (TYPE *) (parmj); \
- do { \
- TYPE t = *pi; \
- *pi++ = *pj; \
- *pj++ = t; \
- } while (--i > 0); \
+#define swapcode(TYPE, parmi, parmj, n) { \
+ long i = (n) / sizeof (TYPE); \
+ TYPE *pi = (TYPE *) (parmi); \
+ TYPE *pj = (TYPE *) (parmj); \
+ do { \
+ TYPE t = *pi; \
+ *pi++ = *pj; \
+ *pj++ = t; \
+ } while (--i > 0); \
}
#define SWAPINIT(a, es) swaptype = ((char *)a - (char *)0) % sizeof(long) || \
- es % sizeof(long) ? 2 : es == sizeof(long)? 0 : 1;
+ es % sizeof(long) ? 2 : es == sizeof(long)? 0 : 1;
-static inline void
-swapfunc(a, b, n, swaptype)
- char *a, *b;
- int n, swaptype;
+static __inline__ void
+swapfunc(char *a, char *b, int n, int swaptype)
{
- if(swaptype <= 1)
- swapcode(long, a, b, n)
- else
- swapcode(char, a, b, n)
+ if(swaptype <= 1)
+ swapcode(long, a, b, n)
+ else
+ swapcode(char, a, b, n)
}
-#define swap(a, b) \
- if (swaptype == 0) { \
- long t = *(long *)(a); \
- *(long *)(a) = *(long *)(b); \
- *(long *)(b) = t; \
- } else \
- swapfunc(a, b, es, swaptype)
+#define swap(a, b) \
+ if (swaptype == 0) { \
+ long t = *(long *)(a); \
+ *(long *)(a) = *(long *)(b); \
+ *(long *)(b) = t; \
+ } else \
+ swapfunc((char*)a, (char*)b, es, swaptype)
-#define vecswap(a, b, n) if ((n) > 0) swapfunc(a, b, n, swaptype)
+#define vecswap(a, b, n) if ((n) > 0) swapfunc(a, b, n, swaptype)
#ifdef I_AM_QSORT_R
-#define CMP(t, x, y) (cmp((t), (x), (y)))
+#define CMP(t, x, y) (cmp((t), (x), (y)))
#else
-#define CMP(t, x, y) (cmp((x), (y)))
+#define CMP(t, x, y) (cmp((x), (y)))
#endif
-static inline char *
+static __inline__ char *
med3(char *a, char *b, char *c, cmp_t *cmp, void *thunk
#ifndef I_AM_QSORT_R
-/* commented out by L.M.
+/* commented out by L.M.
__unused
*/
#endif
)
{
- return CMP(thunk, a, b) < 0 ?
- (CMP(thunk, b, c) < 0 ? b : (CMP(thunk, a, c) < 0 ? c : a ))
+ return CMP(thunk, a, b) < 0 ?
+ (CMP(thunk, b, c) < 0 ? b : (CMP(thunk, a, c) < 0 ? c : a ))
:(CMP(thunk, b, c) > 0 ? b : (CMP(thunk, a, c) < 0 ? a : c ));
}
@@ -121,86 +148,87 @@ void
qsort(void *a, size_t n, size_t es, cmp_t *cmp)
#endif
{
- char *pa, *pb, *pc, *pd, *pl, *pm, *pn;
- size_t d, r;
- int cmp_result;
- int swaptype, swap_cnt;
-
-loop: SWAPINIT(a, es);
- swap_cnt = 0;
- if (n < 7) {
- for (pm = (char *)a + es; pm < (char *)a + n * es; pm += es)
- for (pl = pm;
- pl > (char *)a && CMP(thunk, pl - es, pl) > 0;
- pl -= es)
- swap(pl, pl - es);
- return;
- }
- pm = (char *)a + (n / 2) * es;
- if (n > 7) {
- pl = a;
- pn = (char *)a + (n - 1) * es;
- if (n > 40) {
- d = (n / 8) * es;
- pl = med3(pl, pl + d, pl + 2 * d, cmp, thunk);
- pm = med3(pm - d, pm, pm + d, cmp, thunk);
- pn = med3(pn - 2 * d, pn - d, pn, cmp, thunk);
- }
- pm = med3(pl, pm, pn, cmp, thunk);
- }
- swap(a, pm);
- pa = pb = (char *)a + es;
-
- pc = pd = (char *)a + (n - 1) * es;
- for (;;) {
- while (pb <= pc && (cmp_result = CMP(thunk, pb, a)) <= 0) {
- if (cmp_result == 0) {
- swap_cnt = 1;
- swap(pa, pb);
- pa += es;
- }
- pb += es;
- }
- while (pb <= pc && (cmp_result = CMP(thunk, pc, a)) >= 0) {
- if (cmp_result == 0) {
- swap_cnt = 1;
- swap(pc, pd);
- pd -= es;
- }
- pc -= es;
- }
- if (pb > pc)
- break;
- swap(pb, pc);
- swap_cnt = 1;
- pb += es;
- pc -= es;
- }
- if (swap_cnt == 0) { /* Switch to insertion sort */
- for (pm = (char *)a + es; pm < (char *)a + n * es; pm += es)
- for (pl = pm;
- pl > (char *)a && CMP(thunk, pl - es, pl) > 0;
- pl -= es)
- swap(pl, pl - es);
- return;
- }
-
- pn = (char *)a + n * es;
- r = min(pa - (char *)a, pb - pa);
- vecswap(a, pb - r, r);
- r = min(pd - pc, pn - pd - es);
- vecswap(pb, pn - r, r);
- if ((r = pb - pa) > es)
+ char *pa, *pb, *pc, *pd, *pl, *pm, *pn;
+ size_t d, r;
+ int cmp_result;
+ int swaptype, swap_cnt;
+
+loop: SWAPINIT(a, es);
+ swap_cnt = 0;
+ if (n < 7) {
+ for (pm = (char *)a + es; pm < (char *)a + n * es; pm += es)
+ for (pl = pm;
+ pl > (char *)a && CMP(thunk, pl - es, pl) > 0;
+ pl -= es)
+ swap(pl, pl - es);
+ return;
+ }
+ pm = (char *)a + (n / 2) * es;
+ if (n > 7) {
+ pl = (char *)a;
+ pn = (char *)a + (n - 1) * es;
+ if (n > 40) {
+ d = (n / 8) * es;
+ pl = med3(pl, pl + d, pl + 2 * d, cmp, thunk);
+ pm = med3(pm - d, pm, pm + d, cmp, thunk);
+ pn = med3(pn - 2 * d, pn - d, pn, cmp, thunk);
+ }
+ pm = med3(pl, pm, pn, cmp, thunk);
+ }
+ swap(a, pm);
+ pa = pb = (char *)a + es;
+
+ pc = pd = (char *)a + (n - 1) * es;
+ for (;;) {
+ while (pb <= pc && (cmp_result = CMP(thunk, pb, a)) <= 0) {
+ if (cmp_result == 0) {
+ swap_cnt = 1;
+ swap(pa, pb);
+ pa += es;
+ }
+ pb += es;
+ }
+ while (pb <= pc && (cmp_result = CMP(thunk, pc, a)) >= 0) {
+ if (cmp_result == 0) {
+ swap_cnt = 1;
+ swap(pc, pd);
+ pd -= es;
+ }
+ pc -= es;
+ }
+ if (pb > pc)
+ break;
+ swap(pb, pc);
+ swap_cnt = 1;
+ pb += es;
+ pc -= es;
+ }
+ if (swap_cnt == 0) { /* Switch to insertion sort */
+ for (pm = (char *)a + es; pm < (char *)a + n * es; pm += es)
+ for (pl = pm;
+ pl > (char *)a && CMP(thunk, pl - es, pl) > 0;
+ pl -= es)
+ swap(pl, pl - es);
+ return;
+ }
+
+ pn = (char *)a + n * es;
+ r = min(pa - (char *)a, pb - pa);
+ vecswap((char*)a, (char *)(pb - r), r);
+ // !!! Ren/C: pn - pd - es => (long)(pn - pd - ps) for -Wsign-compare
+ r = min(pd - pc, (long)(pn - pd - es));
+ vecswap(pb, pn - r, r);
+ if ((r = pb - pa) > es)
#ifdef I_AM_QSORT_R
- qsort_r(a, r / es, es, thunk, cmp);
+ qsort_r(a, r / es, es, thunk, cmp);
#else
- qsort(a, r / es, es, cmp);
+ qsort(a, r / es, es, cmp);
#endif
- if ((r = pd - pc) > es) {
- /* Iterate rather than recurse to save stack space */
- a = pn - r;
- n = r / es;
- goto loop;
- }
-/* qsort(pn - r, r / es, es, cmp);*/
+ if ((r = pd - pc) > es) {
+ /* Iterate rather than recurse to save stack space */
+ a = pn - r;
+ n = r / es;
+ goto loop;
+ }
+/* qsort(pn - r, r / es, es, cmp);*/
}
diff --git a/src/core/f-random.c b/src/core/f-random.c
index 99cacc3f8b..c51582a264 100644
--- a/src/core/f-random.c
+++ b/src/core/f-random.c
@@ -1,74 +1,76 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: f-random.c
-** Summary: random number generation
-** Section: functional
-** Notes:
-**
-***********************************************************************/
+//
+// File: %f-random.c
+// Summary: "random number generation"
+// Section: functional
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/* This program by D E Knuth is in the public domain and freely copyable.
- * It is explained in Seminumerical Algorithms, 3rd edition, Section 3.6
- * (or in the errata to the 2nd edition --- see
- * http://www-cs-faculty.stanford.edu/~knuth/taocp.html
- * in the changes to Volume 2 on pages 171 and following). */
+/* This program by D E Knuth is in the public domain and freely copyable.
+ * It is explained in Seminumerical Algorithms, 3rd edition, Section 3.6
+ * (or in the errata to the 2nd edition --- see
+ * http://www-cs-faculty.stanford.edu/~knuth/taocp.html
+ * in the changes to Volume 2 on pages 171 and following). */
-/* N.B. The MODIFICATIONS introduced in the 9th printing (2002) are
- included here; there's no backwards compatibility with the original. */
+/* N.B. The MODIFICATIONS introduced in the 9th printing (2002) are
+ included here; there's no backwards compatibility with the original. */
-/* This version also adopts Brendan McKay's suggestion to
- accommodate naive users who forget to call Set_Random (seed). */
+/* This version also adopts Brendan McKay's suggestion to
+ accommodate naive users who forget to call Set_Random (seed). */
-/* If you find any bugs, please report them immediately to
- * taocp@cs.stanford.edu
- * (and you will be rewarded if the bug is genuine). Thanks! */
+/* If you find any bugs, please report them immediately to
+ * taocp@cs.stanford.edu
+ * (and you will be rewarded if the bug is genuine). Thanks! */
/************ see the book for explanations and caveats! *******************/
/************ in particular, you need two's complement arithmetic **********/
/* Modified by Ladislav Mecir for REBOL to generate 62-bit numbers */
-#define KK 100 /* the long lag */
-#define LL 37 /* the short lag */
-#define MM ((REBI64)1<<62) /* the modulus, 2^62 */
-#define mod_diff(x,y) (((x)-(y))&(MM-1)) /* subtraction mod MM */
+#define KK 100 /* the long lag */
+#define LL 37 /* the short lag */
+#define MM ((REBI64)1<<62) /* the modulus, 2^62 */
+#define mod_diff(x,y) (((x)-(y))&(MM-1)) /* subtraction mod MM */
-static REBI64 ran_x[KK]; /* the generator state */
+static REBI64 ran_x[KK]; /* the generator state */
-#ifdef __STDC__
+#if defined __STDC__ || defined __cplusplus
void ran_array(REBI64 aa[], int n)
#else
-void ran_array(aa,n) /* put n new random numbers in aa */
- REBI64 *aa; /* destination */
- int n; /* array length (must be at least KK) */
+void ran_array(aa,n) /* put n new random numbers in aa */
+ REBI64 *aa; /* destination */
+ int n; /* array length (must be at least KK) */
#endif
{
- register int i,j;
- for (j=0;j=MM) ss-=MM-2; /* cyclic shift 61 bits */
- }
- x[1]++; /* make x[1] (and only x[1]) odd */
- for (ss=seed&(MM-1),t=TT-1; t;) {
- for (j=KK-1;j>0;j--) x[j+j]=x[j], x[j+j-1]=0; /* "square" */
- for (j=KK+KK-2;j>=KK;j--)
- x[j-(KK-LL)]=mod_diff(x[j-(KK-LL)],x[j]),
- x[j-KK]=mod_diff(x[j-KK],x[j]);
- if (is_odd(ss)) { /* "multiply by z" */
- for (j=KK;j>0;j--) x[j]=x[j-1];
- x[0]=x[KK]; /* shift the buffer cyclically */
- x[LL]=mod_diff(x[LL],x[KK]);
- }
- if (ss) ss>>=1; else t--;
- }
- for (j=0;j=MM) ss-=MM-2; /* cyclic shift 61 bits */
+ }
+ x[1]++; /* make x[1] (and only x[1]) odd */
+ for (ss=seed&(MM-1),t=TT-1; t;) {
+ for (j=KK-1;j>0;j--) x[j+j]=x[j], x[j+j-1]=0; /* "square" */
+ for (j=KK+KK-2;j>=KK;j--)
+ x[j-(KK-LL)]=mod_diff(x[j-(KK-LL)],x[j]),
+ x[j-KK]=mod_diff(x[j-KK],x[j]);
+ if (is_odd(ss)) { /* "multiply by z" */
+ for (j=KK;j>0;j--) x[j]=x[j-1];
+ x[0]=x[KK]; /* shift the buffer cyclically */
+ x[LL]=mod_diff(x[LL],x[KK]);
+ }
+ if (ss) ss>>=1; else t--;
+ }
+ for (j=0;j=0? *ran_arr_ptr++: ran_arr_cycle())
static REBI64 ran_arr_cycle()
{
- if (ran_arr_ptr==&ran_arr_dummy)
- Set_Random(314159L); /* the user forgot to initialize */
- ran_array(ran_arr_buf,QUALITY);
- ran_arr_buf[KK]=-1;
- ran_arr_ptr=ran_arr_buf+1;
- return ran_arr_buf[0];
+ if (ran_arr_ptr==&ran_arr_dummy)
+ Set_Random(314159L); /* the user forgot to initialize */
+ ran_array(ran_arr_buf,QUALITY);
+ ran_arr_buf[KK]=-1;
+ ran_arr_ptr=ran_arr_buf+1;
+ return ran_arr_buf[0];
}
-/***********************************************************************
-**
-*/ REBI64 Random_Int(REBFLG secure)
-/*
-** Return random integer. Secure uses SHA1 for better safety.
-**
-***********************************************************************/
+//
+// Random_Int: C
+//
+// Return random integer. Secure uses SHA1 for better safety.
+//
+REBI64 Random_Int(REBOOL secure)
{
- REBI64 tmp;
- tmp = ran_arr_next();
+ REBI64 tmp;
+ tmp = ran_arr_next();
- if (secure) {
- REBYTE srcbuf[20], dstbuf[20];
+ if (secure) {
+ REBYTE srcbuf[20], dstbuf[20];
- memcpy(srcbuf, (REBYTE*)&tmp, sizeof(tmp));
- memset(srcbuf + sizeof(tmp), *(REBYTE*)&tmp, 20 - sizeof(tmp));
+ memcpy(srcbuf, &tmp, sizeof(tmp));
+ memset(srcbuf + sizeof(tmp), *(REBYTE*)&tmp, 20 - sizeof(tmp));
- SHA1(srcbuf, 20, dstbuf);
- memcpy((REBYTE*)&tmp, dstbuf, sizeof(tmp));
- }
+ SHA1(srcbuf, 20, dstbuf);
+ memcpy(&tmp, dstbuf, sizeof(tmp));
+ }
- return tmp;
+ return tmp;
}
-#define MAX_U64 ((REBU64)(REBI64)-1)
-/***********************************************************************
-**
-*/ REBI64 Random_Range(REBI64 r, REBFLG secure)
-/*
-***********************************************************************/
+//
+// Random_Range: C
+//
+REBI64 Random_Range(REBI64 r, REBOOL secure)
{
- REBU64 s, m, u;
- if (r == 0) return 0;
- s = (r < 0) ? -r : r;
- if (!secure && s > MM) Trap0(RE_OVERFLOW);
- m = secure ? MAX_U64 - (MAX_U64 - s + 1) % s : MM - MM % s - 1; /* rejection limit */
- do u = Random_Int(secure); while (u > m); /* get a random below the limit */
- u = u % s + 1;
- return (r > 0) ? u : - (REBI64)u;
+ REBU64 s, m, u;
+ if (r == 0) return 0;
+ s = (r < 0) ? -r : r;
+ if (!secure && s > MM) fail (Error_Overflow_Raw());
+ m = secure ? MAX_U64 - (MAX_U64 - s + 1) % s : MM - MM % s - 1; /* rejection limit */
+ do u = Random_Int(secure); while (u > m); /* get a random below the limit */
+ u = u % s + 1;
+ return (r > 0) ? cast(REBI64, u) : -cast(REBI64, u);
}
-/***********************************************************************
-**
-*/ REBDEC Random_Dec(REBDEC r, REBFLG secure)
-/*
-***********************************************************************/
+//
+// Random_Dec: C
+//
+REBDEC Random_Dec(REBDEC r, REBOOL secure)
{
- REBDEC t, s;
- t = secure ? 5.4210108624275222e-20 /* 2^-64 */ : 2.1684043449710089e-19 /* 2^-62 */;
- /* care is taken to never overflow and yield a correct sign */
- s = (REBDEC)Random_Int(secure);
- if (s < 0.0) s += 1.8446744073709552e19;
- return (s * t) * r;
+ REBDEC t, s;
+ t = secure ? 5.4210108624275222e-20 /* 2^-64 */ : 2.1684043449710089e-19 /* 2^-62 */;
+ /* care is taken to never overflow and yield a correct sign */
+ s = (REBDEC)Random_Int(secure);
+ if (s < 0.0) s += 1.8446744073709552e19;
+ return (s * t) * r;
}
diff --git a/src/core/f-round.c b/src/core/f-round.c
index d62b7cccbc..c88379423b 100644
--- a/src/core/f-round.c
+++ b/src/core/f-round.c
@@ -1,227 +1,204 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: f-round.c
-** Summary: special rounding math functions
-** Section: functional
-** Notes:
-**
-***********************************************************************/
+//
+// File: %f-round.c
+// Summary: "special rounding math functions"
+// Section: functional
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
#include "sys-deci-funcs.h"
-// Rounding flags (passed as refinements to ROUND function):
-enum {
- RF_TO,
- RF_EVEN,
- RF_DOWN,
- RF_HALF_DOWN,
- RF_FLOOR,
- RF_CEILING,
- RF_HALF_CEILING
-};
-
-#define RB_DFC (1 << RF_DOWN | 1 << RF_FLOOR | 1 << RF_CEILING)
-
-/***********************************************************************
-**
-*/ REBCNT Get_Round_Flags(REBVAL *ds)
-/*
-** 1 n [number! money! time!] "The value to round"
-** 2 /to "Return the nearest multiple of the scale parameter"
-** 3 scale [number! money! time!] "Must be a non-zero value"
-** 4 /even "Halves round toward even results"
-** 5 /down "Round toward zero, ignoring discarded digits. (truncate)"
-** 6 /half-down "Halves round toward zero"
-** 7 /floor "Round in negative direction"
-** 8 /ceiling "Round in positive direction"
-** 9 /half-ceiling "Halves round in positive direction"
-**
-***********************************************************************/
+#define Dec_Trunc(x) (((x) < 0.0) ? -1.0 : 1.0) * floor(fabs(x))
+#define Dec_Away(x) (((x) < 0.0) ? -1.0 : 1.0) * ceil(fabs(x))
+
+//
+// Round_Dec: C
+//
+// Identical to ROUND mezzanine function.
+// Note: scale arg only valid if RF_TO is set
+//
+REBDEC Round_Dec(REBDEC dec, REBCNT flags, REBDEC scale)
{
- REBCNT flags = 0;
+ REBDEC r;
+ int e;
+ REBOOL v;
+ union {REBDEC d; REBI64 i;} m;
+ REBI64 j;
+
+ if (flags & RF_TO) {
+ if (scale == 0.0) fail (Error_Zero_Divide_Raw());
+ scale = fabs(scale);
+ } else scale = 1.0;
+
+ /* is scale negligible? */
+ if (scale < ldexp(fabs(dec), -53)) return dec;
+
+ if ((v = LOGICAL(scale >= 1.0))) dec = dec / scale;
+ else {
+ r = frexp(scale, &e);
+ if (e <= -1022) {
+ scale = r;
+ dec = ldexp(dec, e);
+ } else e = 0;
+ scale = 1.0 / scale;
+ dec = dec * scale;
+ }
+ if (flags & (RF_DOWN | RF_FLOOR | RF_CEILING)) {
+ if (flags & RF_FLOOR) dec = floor(dec);
+ else if (flags & RF_DOWN) dec = Dec_Trunc(dec);
+ else dec = ceil(dec);
+ } else {
+ /* integer-compare fabs(dec) and floor(fabs(dec)) + 0.5,
+ which is equivalent to "tolerant comparison" of the
+ fractional part with 0.5 */
+ m.d = fabs(dec);
+ j = m.i;
+ m.d = floor(m.d) + 0.5;
+ if (j - m.i < -10) dec = Dec_Trunc(dec);
+ else if (j - m.i > 10) dec = Dec_Away(dec);
+ else if (flags & RF_EVEN) {
+ if (fmod(fabs(dec), 2.0) < 1.0) dec = Dec_Trunc(dec);
+ else dec = Dec_Away(dec);
+ }
+ else if (flags & RF_HALF_DOWN) dec = Dec_Trunc(dec);
+ else if (flags & RF_HALF_CEILING) dec = ceil(dec);
+ else dec = Dec_Away(dec);
+ }
+
+ if (v) {
+ if (fabs(dec = dec * scale) != HUGE_VAL)
+ return dec;
+ else
+ fail (Error_Overflow_Raw());
+ }
+ return ldexp(dec / scale, e);
+}
- if (D_REF(2)) SET_FLAG(flags, RF_TO);
- if (D_REF(4)) SET_FLAG(flags, RF_EVEN);
- if (D_REF(5)) SET_FLAG(flags, RF_DOWN);
- if (D_REF(6)) SET_FLAG(flags, RF_HALF_DOWN);
- if (D_REF(7)) SET_FLAG(flags, RF_FLOOR);
- if (D_REF(8)) SET_FLAG(flags, RF_CEILING);
- if (D_REF(9)) SET_FLAG(flags, RF_HALF_CEILING);
+#define Int_Abs(x) ((x) < 0) ? -(x) : (x)
- return flags;
+#define Int_Trunc { \
+ num = (num > 0) ? cast(REBI64, n - r) : -cast(REBI64, n - r); \
}
+#define Int_Floor { \
+ if (num > 0) \
+ num = n - r; \
+ else if ((m = n + s) <= cast(REBU64, 1) << 63) \
+ num = -cast(REBI64, m); \
+ else \
+ fail (Error_Overflow_Raw()); \
+}
-#define Dec_Trunc(x) (((x) < 0.0) ? -1.0 : 1.0) * floor(fabs(x))
-#define Dec_Away(x) (((x) < 0.0) ? -1.0 : 1.0) * ceil(fabs(x))
+#define Int_Ceil { \
+ if (num < 0) \
+ num = -cast(REBI64, n - r); \
+ else if ((m = n + s) < cast(REBU64, 1) << 63) \
+ num = m; \
+ else \
+ fail (Error_Overflow_Raw()); \
+}
-/***********************************************************************
-**
-*/ REBDEC Round_Dec(REBDEC dec, REBCNT flags, REBDEC scale)
-/*
-** Identical to ROUND mezzanine function.
-** Note: scale arg only valid if RF_TO is set
-**
-***********************************************************************/
-{
- REBDEC r;
- int e;
- REBFLG v;
- union {REBDEC d; REBI64 i;} m;
- REBI64 j;
-
- if (GET_FLAG(flags, RF_TO)) {
- if (scale == 0.0) Trap0(RE_ZERO_DIVIDE);
- scale = fabs(scale);
- } else scale = 1.0;
-
- /* is scale negligible? */
- if (scale < ldexp(fabs(dec), -53)) return dec;
-
- if (v = scale >= 1.0) dec = dec / scale;
- else {
- r = frexp(scale, &e);
- if (e <= -1022) {
- scale = r;
- dec = ldexp(dec, e);
- } else e = 0;
- scale = 1.0 / scale;
- dec = dec * scale;
- }
- if (flags & RB_DFC) {
- if (GET_FLAG(flags, RF_FLOOR)) dec = floor(dec);
- else if (GET_FLAG(flags, RF_DOWN)) dec = Dec_Trunc(dec);
- else dec = ceil(dec);
- } else {
- /* integer-compare fabs(dec) and floor(fabs(dec)) + 0.5,
- which is equivalent to "tolerant comparison" of the
- fractional part with 0.5 */
- m.d = fabs(dec);
- j = m.i;
- m.d = floor(m.d) + 0.5;
- if (j - m.i < -10) dec = Dec_Trunc(dec);
- else if (j - m.i > 10) dec = Dec_Away(dec);
- else if (GET_FLAG(flags, RF_EVEN)) {
- if (fmod(fabs(dec), 2.0) < 1.0) dec = Dec_Trunc(dec);
- else dec = Dec_Away(dec);
- }
- else if (GET_FLAG(flags, RF_HALF_DOWN)) dec = Dec_Trunc(dec);
- else if (GET_FLAG(flags, RF_HALF_CEILING)) dec = ceil(dec);
- else dec = Dec_Away(dec);
- }
-
- if (v) {
- if (fabs(dec = dec * scale) != HUGE_VAL) return dec;
- else Trap0(RE_OVERFLOW);
- }
- return ldexp(dec / scale, e);
+#define Int_Away { \
+ if ((m = n + s) >= cast(REBU64, 1) << 63) \
+ if (num < 0 && m == cast(REBU64, 1) << 63) \
+ num = m; \
+ else \
+ fail (Error_Overflow_Raw()); \
+ else \
+ num = (num > 0) ? cast(REBI64, m) : -cast(REBI64, m); \
}
-#define Int_Abs(x) ((x) < 0) ? -(x) : (x)
-#define Int_Trunc num = (num > 0) ? n - r : -(REBI64)(n - r)
-#define Int_Floor {\
- if (num > 0) num = n - r;\
- else if ((m = n + s) <= (REBU64)1 << 63) num = -(REBI64)m;\
- else Trap0(RE_OVERFLOW);\
- }
-#define Int_Ceil {\
- if (num < 0) num = -(REBI64)(n - r);\
- else if ((m = n + s) < (REBU64)1 << 63) num = m;\
- else Trap0(RE_OVERFLOW);\
- }
-#define Int_Away if ((m = n + s) >= (REBU64)1 << 63)\
- if (num < 0 && m == (REBU64) 1 << 63) num = m;\
- else Trap0(RE_OVERFLOW);\
- else num = (num > 0) ? m : -(REBI64)m
-
-/***********************************************************************
-**
-*/ REBI64 Round_Int(REBI64 num, REBCNT flags, REBI64 scale)
-/*
-** Identical to ROUND mezzanine function.
-** Note: scale arg only valid if RF_TO is set
-**
-***********************************************************************/
+
+//
+// Round_Int: C
+//
+// Identical to ROUND mezzanine function.
+// Note: scale arg only valid if RF_TO is set
+//
+REBI64 Round_Int(REBI64 num, REBCNT flags, REBI64 scale)
{
- /* using safe unsigned arithmetic */
- REBU64 sc, n, r, m, s;
-
- if (GET_FLAG(flags, RF_TO)) {
- if (scale == 0) Trap0(RE_ZERO_DIVIDE);
- sc = Int_Abs(scale);
- }
- else sc = 1;
-
- n = Int_Abs(num);
- r = n % sc;
- s = sc - r;
- if (r == 0) return num;
-
- if (flags & RB_DFC) {
- if (GET_FLAG(flags, RF_DOWN)) {Int_Trunc; return num;}
- if (GET_FLAG(flags, RF_FLOOR)) {Int_Floor; return num;}
- Int_Ceil; return num;
- }
-
- /* "genuine" rounding */
- if (r < s) {Int_Trunc; return num;}
- else if (r > s) {Int_Away; return num;}
-
- /* half */
- if (GET_FLAG(flags, RF_EVEN)) {
- if ((n / sc) & 1) {Int_Away; return num;}
- else {Int_Trunc; return num;}
- }
- if (GET_FLAG(flags, RF_HALF_DOWN)) {Int_Trunc; return num;}
- if (GET_FLAG(flags, RF_HALF_CEILING)) {Int_Ceil; return num;}
-
- Int_Away; return num; /* this is round_half_away */
+ /* using safe unsigned arithmetic */
+ REBU64 sc, n, r, m, s;
+
+ if (flags & RF_TO) {
+ if (scale == 0) fail (Error_Zero_Divide_Raw());
+ sc = Int_Abs(scale);
+ }
+ else sc = 1;
+
+ n = Int_Abs(num);
+ r = n % sc;
+ s = sc - r;
+ if (r == 0) return num;
+
+ if (flags & (RF_DOWN | RF_FLOOR | RF_CEILING)) {
+ if (flags & RF_DOWN) {Int_Trunc; return num;}
+ if (flags & RF_FLOOR) {Int_Floor; return num;}
+ Int_Ceil;
+ return num;
+ }
+
+ /* "genuine" rounding */
+ if (r < s) {Int_Trunc; return num;}
+ else if (r > s) {Int_Away; return num;}
+
+ /* half */
+ if (flags & RF_EVEN) {
+ if ((n / sc) & 1) {Int_Away; return num;}
+ else {Int_Trunc; return num;}
+ }
+ if (flags & RF_HALF_DOWN) {Int_Trunc; return num;}
+ if (flags & RF_HALF_CEILING) {Int_Ceil; return num;}
+
+ Int_Away; return num; /* this is round_half_away */
}
-/***********************************************************************
-**
-*/ REBDCI Round_Deci(REBDCI num, REBCNT flags, REBDCI scale)
-/*
-** Identical to ROUND mezzanine function.
-** Note: scale arg only valid if RF_TO is set
-**
-***********************************************************************/
+//
+// Round_Deci: C
+//
+// Identical to ROUND mezzanine function.
+// Note: scale arg only valid if RF_TO is set
+//
+deci Round_Deci(deci num, REBCNT flags, deci scale)
{
- REBDCI deci_one = {1u, 0u, 0u, 0u, 0};
-
- if (GET_FLAG(flags, RF_TO)) {
- if (deci_is_zero(scale)) Trap0(RE_ZERO_DIVIDE);
- scale = deci_abs(scale);
- }
- else scale = deci_one;
-
- if (GET_FLAG(flags, RF_EVEN)) return deci_half_even(num, scale);
- if (GET_FLAG(flags, RF_DOWN)) return deci_truncate(num, scale);
- if (GET_FLAG(flags, RF_HALF_DOWN)) return deci_half_truncate(num, scale);
- if (GET_FLAG(flags, RF_FLOOR)) return deci_floor(num, scale);
- if (GET_FLAG(flags, RF_CEILING)) return deci_ceil(num, scale);
- if (GET_FLAG(flags, RF_HALF_CEILING)) return deci_half_ceil(num, scale);
-
- return deci_half_away(num, scale);
+ deci deci_one = {1u, 0u, 0u, 0u, 0};
+
+ if (flags & RF_TO) {
+ if (deci_is_zero(scale)) fail (Error_Zero_Divide_Raw());
+ scale = deci_abs(scale);
+ }
+ else scale = deci_one;
+
+ if (flags & RF_EVEN) return deci_half_even(num, scale);
+ if (flags & RF_DOWN) return deci_truncate(num, scale);
+ if (flags & RF_HALF_DOWN) return deci_half_truncate(num, scale);
+ if (flags & RF_FLOOR) return deci_floor(num, scale);
+ if (flags & RF_CEILING) return deci_ceil(num, scale);
+ if (flags & RF_HALF_CEILING) return deci_half_ceil(num, scale);
+
+ return deci_half_away(num, scale);
}
diff --git a/src/core/f-series.c b/src/core/f-series.c
index 172f4a40b8..45bd42b22e 100644
--- a/src/core/f-series.c
+++ b/src/core/f-series.c
@@ -1,321 +1,321 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: f-series.c
-** Summary: common series handling functions
-** Section: functional
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %f-series.c
+// Summary: "common series handling functions"
+// Section: functional
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
+#include "sys-deci-funcs.h"
#define THE_SIGN(v) ((v < 0) ? -1 : (v > 0) ? 1 : 0)
-/***********************************************************************
-**
-*/ REBINT Do_Series_Action(REBCNT action, REBVAL *value, REBVAL *arg)
-/*
-** Common series functions.
-**
-***********************************************************************/
-{
- REBINT index;
- REBINT tail;
- REBINT len = 0;
-
- // Common setup code for all actions:
- if (action != A_MAKE && action != A_TO) {
- index = (REBINT)VAL_INDEX(value);
- tail = (REBINT)VAL_TAIL(value);
- } else return -1;
-
- switch (action) {
-
- //-- Navigation:
-
- case A_HEAD:
- VAL_INDEX(value) = 0;
- break;
-
- case A_TAIL:
- VAL_INDEX(value) = (REBCNT)tail;
- break;
-
- case A_HEADQ:
- DECIDE(index == 0);
-
- case A_TAILQ:
- DECIDE(index >= tail);
-
- case A_PASTQ:
- DECIDE(index > tail);
-
- case A_NEXT:
- if (index < tail) VAL_INDEX(value)++;
- break;
-
- case A_BACK:
- if (index > 0) VAL_INDEX(value)--;
- break;
-
- case A_SKIP:
- case A_AT:
- len = Get_Num_Arg(arg);
- {
- REBI64 i = (REBI64)index + (REBI64)len;
- if (action == A_SKIP) {
- if (IS_LOGIC(arg)) i--;
- } else { // A_AT
- if (len > 0) i--;
- }
- if (i > (REBI64)tail) i = (REBI64)tail;
- else if (i < 0) i = 0;
- VAL_INDEX(value) = (REBCNT)i;
- }
- break;
-/*
- case A_ATZ:
- len = Get_Num_Arg(arg);
- {
- REBI64 idx = Add_Max(0, index, len, MAX_I32);
- if (idx < 0) idx = 0;
- VAL_INDEX(value) = (REBCNT)idx;
- }
- break;
-*/
- case A_INDEXQ:
- SET_INTEGER(DS_RETURN, ((REBI64)index) + 1);
- return R_RET;
-
- case A_LENGTHQ:
- SET_INTEGER(DS_RETURN, tail > index ? tail - index : 0);
- return R_RET;
-
- case A_REMOVE:
- // /PART length
- TRAP_PROTECT(VAL_SERIES(value));
- len = DS_REF(2) ? Partial(value, 0, DS_ARG(3), 0) : 1;
- index = (REBINT)VAL_INDEX(value);
- if (index < tail && len != 0)
- Remove_Series(VAL_SERIES(value), VAL_INDEX(value), len);
- break;
-
- case A_ADD: // Join_Strings(value, arg);
- case A_SUBTRACT: // "test this" - 10
- case A_MULTIPLY: // "t" * 4 = "tttt"
- case A_DIVIDE:
- case A_REMAINDER:
- case A_POWER:
- case A_ODDQ:
- case A_EVENQ:
- case A_ABSOLUTE:
- Trap_Action(VAL_TYPE(value), action);
-
- default:
- return -1;
- }
-
- DS_RET_VALUE(value);
- return R_RET;
-
-is_false:
- return R_FALSE;
-
-is_true:
- return R_TRUE;
+//
+// Series_Common_Action_Maybe_Unhandled: C
+//
+// This routine is called to handle actions on ANY-SERIES! that can be taken
+// care of without knowing what specific kind of series it is. So generally
+// index manipulation, and things like LENGTH/etc.
+//
+REB_R Series_Common_Action_Maybe_Unhandled(
+ REBFRM *frame_,
+ REBSYM action
+) {
+ REBVAL *value = D_ARG(1);
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+
+ REBINT index = cast(REBINT, VAL_INDEX(value));
+ REBINT tail = cast(REBINT, VAL_LEN_HEAD(value));
+ REBINT len = 0;
+
+ switch (action) {
+
+ //-- Navigation:
+
+ case SYM_HEAD_OF:
+ VAL_INDEX(value) = 0;
+ break;
+
+ case SYM_TAIL_OF:
+ VAL_INDEX(value) = cast(REBCNT, tail);
+ break;
+
+ case SYM_HEAD_Q:
+ return R_FROM_BOOL(LOGICAL(index == 0));
+
+ case SYM_TAIL_Q:
+ return R_FROM_BOOL(LOGICAL(index >= tail));
+
+ case SYM_PAST_Q:
+ return R_FROM_BOOL(LOGICAL(index > tail));
+
+ case SYM_SKIP:
+ case SYM_AT:
+ len = Get_Num_From_Arg(arg);
+ {
+ REBI64 i = (REBI64)index + (REBI64)len;
+ if (action == SYM_SKIP) {
+ if (IS_LOGIC(arg)) i--;
+ } else { // A_AT
+ if (len > 0) i--;
+ }
+ if (i > (REBI64)tail) i = (REBI64)tail;
+ else if (i < 0) i = 0;
+ VAL_INDEX(value) = (REBCNT)i;
+ }
+ break;
+
+ case SYM_INDEX_OF:
+ Init_Integer(D_OUT, cast(REBI64, index) + 1);
+ return R_OUT; // handled
+
+ case SYM_LENGTH_OF:
+ Init_Integer(D_OUT, tail > index ? tail - index : 0);
+ return R_OUT; // handled
+
+ case SYM_REMOVE: {
+ INCLUDE_PARAMS_OF_REMOVE;
+
+ UNUSED(PAR(series)); // already accounted for
+
+ if (REF(map)) {
+ UNUSED(ARG(key));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(value));
+ len = REF(part) ? Partial(value, 0, ARG(limit)) : 1;
+ index = cast(REBINT, VAL_INDEX(value));
+ if (index < tail && len != 0)
+ Remove_Series(VAL_SERIES(value), VAL_INDEX(value), len);
+ break; }
+
+ default:
+ return R_UNHANDLED; // not a common operation, not handled
+ }
+
+ Move_Value(D_OUT, value);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBINT Cmp_Block(REBVAL *sval, REBVAL *tval, REBFLG is_case)
-/*
-** Compare two blocks and return the difference of the first
-** non-matching value.
-**
-***********************************************************************/
+//
+// Cmp_Array: C
+//
+// Compare two arrays and return the difference of the first
+// non-matching value.
+//
+REBINT Cmp_Array(const RELVAL *sval, const RELVAL *tval, REBOOL is_case)
{
- REBVAL *s = VAL_BLK_DATA(sval);
- REBVAL *t = VAL_BLK_DATA(tval);
- REBINT diff;
-
- CHECK_STACK(&s);
-
- if ((VAL_SERIES(sval)==VAL_SERIES(tval))&&
- (VAL_INDEX(sval)==VAL_INDEX(tval)))
- return 0;
-
- while (!IS_END(s) && (VAL_TYPE(s) == VAL_TYPE(t) ||
- (IS_NUMBER(s) && IS_NUMBER(t)))) {
- if ((diff = Cmp_Value(s, t, is_case)) != 0)
- return diff;
- s++, t++;
- }
- return VAL_TYPE(s) - VAL_TYPE(t);
+ RELVAL *s = VAL_ARRAY_AT(sval);
+ RELVAL *t = VAL_ARRAY_AT(tval);
+ REBINT diff;
+
+ if (C_STACK_OVERFLOWING(&s)) Trap_Stack_Overflow();
+
+ if ((VAL_SERIES(sval)==VAL_SERIES(tval))&&
+ (VAL_INDEX(sval)==VAL_INDEX(tval)))
+ return 0;
+
+ if (IS_END(s) || IS_END(t)) goto diff_of_ends;
+
+ while (
+ (VAL_TYPE(s) == VAL_TYPE(t) ||
+ (ANY_NUMBER(s) && ANY_NUMBER(t)))
+ ) {
+ if ((diff = Cmp_Value(s, t, is_case)) != 0)
+ return diff;
+
+ s++;
+ t++;
+
+ if (IS_END(s) || IS_END(t)) goto diff_of_ends;
+ }
+
+ return VAL_TYPE(s) - VAL_TYPE(t);
+
+diff_of_ends:
+ // Treat end as if it were a REB_xxx type of 0, so all other types would
+ // compare larger than it.
+ //
+ if (IS_END(s)) {
+ if (IS_END(t)) return 0;
+ return -1;
+ }
+ return 1;
}
-/***********************************************************************
-**
-*/ REBINT Cmp_Value(REBVAL *s, REBVAL *t, REBFLG is_case)
-/*
-** Compare two values and return the difference.
-**
-** is_case TRUE for case sensitive compare
-**
-***********************************************************************/
+//
+// Cmp_Value: C
+//
+// Compare two values and return the difference.
+//
+// is_case TRUE for case sensitive compare
+//
+REBINT Cmp_Value(const RELVAL *s, const RELVAL *t, REBOOL is_case)
{
- REBDEC d1, d2;
-
- if (VAL_TYPE(t) != VAL_TYPE(s) && !(IS_NUMBER(s) && IS_NUMBER(t)))
- return VAL_TYPE(s) - VAL_TYPE(t);
-
- switch(VAL_TYPE(s)) {
-
- case REB_INTEGER:
- if (IS_DECIMAL(t)) {
- d1 = (REBDEC)VAL_INT64(s);
- d2 = VAL_DECIMAL(t);
- goto chkDecimal;
- }
- return THE_SIGN(VAL_INT64(s) - VAL_INT64(t));
-
- case REB_LOGIC:
- return VAL_LOGIC(s) - VAL_LOGIC(t);
-
- case REB_CHAR:
- if (is_case) return THE_SIGN(VAL_CHAR(s) - VAL_CHAR(t));
- return THE_SIGN((REBINT)(UP_CASE(VAL_CHAR(s)) - UP_CASE(VAL_CHAR(t))));
-
- case REB_DECIMAL:
- case REB_MONEY:
- d1 = VAL_DECIMAL(s);
- if (IS_INTEGER(t))
- d2 = (REBDEC)VAL_INT64(t);
- else
- d2 = VAL_DECIMAL(t);
+ REBDEC d1, d2;
+
+ if (VAL_TYPE(t) != VAL_TYPE(s) && !(ANY_NUMBER(s) && ANY_NUMBER(t)))
+ return VAL_TYPE(s) - VAL_TYPE(t);
+
+ assert(NOT_END(s) && NOT_END(t));
+
+ switch(VAL_TYPE(s)) {
+
+ case REB_INTEGER:
+ if (IS_DECIMAL(t)) {
+ d1 = (REBDEC)VAL_INT64(s);
+ d2 = VAL_DECIMAL(t);
+ goto chkDecimal;
+ }
+ return THE_SIGN(VAL_INT64(s) - VAL_INT64(t));
+
+ case REB_LOGIC:
+ return VAL_LOGIC(s) - VAL_LOGIC(t);
+
+ case REB_CHAR:
+ if (is_case) return THE_SIGN(VAL_CHAR(s) - VAL_CHAR(t));
+ return THE_SIGN((REBINT)(UP_CASE(VAL_CHAR(s)) - UP_CASE(VAL_CHAR(t))));
+
+ case REB_PERCENT:
+ case REB_DECIMAL:
+ case REB_MONEY:
+ if (IS_MONEY(s))
+ d1 = deci_to_decimal(VAL_MONEY_AMOUNT(s));
+ else
+ d1 = VAL_DECIMAL(s);
+ if (IS_INTEGER(t))
+ d2 = cast(REBDEC, VAL_INT64(t));
+ else if (IS_MONEY(t))
+ d2 = deci_to_decimal(VAL_MONEY_AMOUNT(t));
+ else
+ d2 = VAL_DECIMAL(t);
chkDecimal:
- if (Eq_Decimal(d1, d2))
- return 0;
- if (d1 < d2)
- return -1;
- return 1;
-
- case REB_PAIR:
- return Cmp_Pair(s, t);
-
- case REB_EVENT:
- return Cmp_Event(s, t);
-
- case REB_GOB:
- return Cmp_Gob(s, t);
-
- case REB_TUPLE:
- return Cmp_Tuple(s, t);
-
- case REB_TIME:
- return Cmp_Time(s, t);
-
- case REB_DATE:
- return Cmp_Date(s, t);
-
- case REB_BLOCK:
- case REB_PAREN:
- case REB_MAP:
- case REB_PATH:
- case REB_SET_PATH:
- case REB_GET_PATH:
- case REB_LIT_PATH:
- return Cmp_Block(s, t, is_case);
-
- case REB_STRING:
- case REB_FILE:
- case REB_EMAIL:
- case REB_URL:
- case REB_TAG:
- return Compare_String_Vals(s, t, (REBOOL)!is_case);
-
- case REB_BITSET:
- case REB_BINARY:
- case REB_IMAGE:
- return Compare_Binary_Vals(s, t);
-
- case REB_VECTOR:
- return Compare_Vector(s, t);
-
- case REB_DATATYPE:
- return VAL_DATATYPE(s) - VAL_DATATYPE(t);
-
- case REB_WORD:
- case REB_SET_WORD:
- case REB_GET_WORD:
- case REB_LIT_WORD:
- case REB_REFINEMENT:
- case REB_ISSUE:
- return Compare_Word(s,t,is_case);
-
- case REB_ERROR:
- return VAL_ERR_NUM(s) - VAL_ERR_NUM(s);
-
- case REB_OBJECT:
- case REB_MODULE:
- case REB_PORT:
- return VAL_OBJ_FRAME(s) - VAL_OBJ_FRAME(t);
-
- case REB_NATIVE:
- return &VAL_FUNC_CODE(s) - &VAL_FUNC_CODE(t);
-
- case REB_ACTION:
- case REB_COMMAND:
- case REB_OP:
- case REB_FUNCTION:
- return VAL_FUNC_BODY(s) - VAL_FUNC_BODY(t);
-
- case REB_NONE:
- case REB_UNSET:
- case REB_END:
- default:
- break;
-
- }
- return 0;
+ if (Eq_Decimal(d1, d2))
+ return 0;
+ if (d1 < d2)
+ return -1;
+ return 1;
+
+ case REB_PAIR:
+ return Cmp_Pair(s, t);
+
+ case REB_EVENT:
+ return Cmp_Event(s, t);
+
+ case REB_GOB:
+ return Cmp_Gob(s, t);
+
+ case REB_TUPLE:
+ return Cmp_Tuple(s, t);
+
+ case REB_TIME:
+ return Cmp_Time(s, t);
+
+ case REB_DATE:
+ return Cmp_Date(s, t);
+
+ case REB_BLOCK:
+ case REB_GROUP:
+ case REB_MAP:
+ case REB_PATH:
+ case REB_SET_PATH:
+ case REB_GET_PATH:
+ case REB_LIT_PATH:
+ return Cmp_Array(s, t, is_case);
+
+ case REB_STRING:
+ case REB_FILE:
+ case REB_EMAIL:
+ case REB_URL:
+ case REB_TAG:
+ return Compare_String_Vals(s, t, NOT(is_case));
+
+ case REB_BITSET:
+ case REB_BINARY:
+ case REB_IMAGE:
+ return Compare_Binary_Vals(s, t);
+
+ case REB_VECTOR:
+ return Compare_Vector(s, t);
+
+ case REB_DATATYPE:
+ return VAL_TYPE_KIND(s) - VAL_TYPE_KIND(t);
+
+ case REB_WORD:
+ case REB_SET_WORD:
+ case REB_GET_WORD:
+ case REB_LIT_WORD:
+ case REB_REFINEMENT:
+ case REB_ISSUE:
+ return Compare_Word(s,t,is_case);
+
+ case REB_ERROR:
+ return VAL_ERR_NUM(s) - VAL_ERR_NUM(t);
+
+ case REB_OBJECT:
+ case REB_MODULE:
+ case REB_PORT:
+ return VAL_CONTEXT(s) - VAL_CONTEXT(t);
+
+ case REB_FUNCTION:
+ return VAL_FUNC_PARAMLIST(s) - VAL_FUNC_PARAMLIST(t);
+
+ case REB_LIBRARY:
+ return VAL_LIBRARY(s) - VAL_LIBRARY(t);
+
+ case REB_STRUCT:
+ return Cmp_Struct(s, t);
+
+ case REB_BLANK:
+ case REB_MAX_VOID:
+ default:
+ break;
+
+ }
+ return 0;
}
-/***********************************************************************
-**
-*/ REBCNT Find_Block_Simple(REBSER *series, REBCNT index, REBVAL *target)
-/*
-** Simple search for a value in a block. Return the index of
-** the value or the TAIL index if not found.
-**
-***********************************************************************/
+//
+// Find_In_Array_Simple: C
+//
+// Simple search for a value in an array. Return the index of
+// the value or the TAIL index if not found.
+//
+REBCNT Find_In_Array_Simple(REBARR *array, REBCNT index, const RELVAL *target)
{
- REBVAL *value = BLK_HEAD(series);
+ RELVAL *value = ARR_HEAD(array);
- for (; index < SERIES_TAIL(series); index++) {
- if (0 == Cmp_Value(value+index, target, FALSE)) return index;
- }
+ for (; index < ARR_LEN(array); index++) {
+ if (0 == Cmp_Value(value + index, target, FALSE))
+ return index;
+ }
- return SERIES_TAIL(series);
+ return ARR_LEN(array);
}
diff --git a/src/core/f-stubs.c b/src/core/f-stubs.c
index 86903768e7..d66e8e8d23 100644
--- a/src/core/f-stubs.c
+++ b/src/core/f-stubs.c
@@ -1,948 +1,644 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: f-stubs.c
-** Summary: miscellaneous little functions
-** Section: functional
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %f-stubs.c
+// Summary: "miscellaneous little functions"
+// Section: functional
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
#include "sys-deci-funcs.h"
-/***********************************************************************
-**
-*/ void Long_To_Bytes(REBYTE *out, REBCNT in)
-/*
-***********************************************************************/
-{
- out[0] = (REBYTE) in;
- out[1] = (REBYTE)(in >> 8);
- out[2] = (REBYTE)(in >> 16);
- out[3] = (REBYTE)(in >> 24);
-}
-
-/***********************************************************************
-**
-*/ REBCNT Bytes_To_Long(REBYTE const *in)
-/*
-***********************************************************************/
+//
+// Get_Num_From_Arg: C
+//
+// Get the amount to skip or pick.
+// Allow multiple types. Throw error if not valid.
+// Note that the result is one-based.
+//
+REBINT Get_Num_From_Arg(const REBVAL *val)
{
- return (REBCNT) in[0] // & 0xFF
- | (REBCNT) (in[1] << 8) // & 0xFF00;
- | (REBCNT) (in[2] << 16) // & 0xFF0000;
- | (REBCNT) (in[3] << 24); // & 0xFF000000;
-}
+ REBINT n;
+ if (IS_INTEGER(val)) {
+ if (VAL_INT64(val) > (i64)MAX_I32 || VAL_INT64(val) < (i64)MIN_I32)
+ fail (Error_Out_Of_Range(val));
+ n = VAL_INT32(val);
+ }
+ else if (IS_DECIMAL(val) || IS_PERCENT(val)) {
+ if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
+ fail (Error_Out_Of_Range(val));
+ n = (REBINT)VAL_DECIMAL(val);
+ }
+ else if (IS_LOGIC(val))
+ n = (VAL_LOGIC(val) ? 1 : 2);
+ else
+ fail (val);
-/***********************************************************************
-**
-*/ REBCNT Find_Int(REBINT *array, REBINT num)
-/*
-***********************************************************************/
-{
- REBCNT n;
-
- for (n = 0; array[n] && array[n] != num; n++);
- if (array[n]) return n;
- return NOT_FOUND;
+ return n;
}
-/***********************************************************************
-**
-*/ REBINT Get_Num_Arg(REBVAL *val)
-/*
-** Get the amount to skip or pick.
-** Allow multiple types. Throw error if not valid.
-** Note that the result is one-based.
-**
-***********************************************************************/
+//
+// Float_Int16: C
+//
+REBINT Float_Int16(REBD32 f)
{
- REBINT n;
-
- if (IS_INTEGER(val)) {
- if (VAL_INT64(val) > (i64)MAX_I32 || VAL_INT64(val) < (i64)MIN_I32)
- Trap_Range(val);
- n = VAL_INT32(val);
- }
- else if (IS_DECIMAL(val) || IS_PERCENT(val)) {
- if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
- Trap_Range(val);
- n = (REBINT)VAL_DECIMAL(val);
- }
- else if (IS_LOGIC(val)) n = (VAL_LOGIC(val) ? 1 : 2);
- else Trap_Arg(val);
-
- return n;
-}
-
+ if (fabs(f) > cast(REBD32, 0x7FFF)) {
+ DECLARE_LOCAL (temp);
+ Init_Decimal(temp, f);
-/***********************************************************************
-**
-*/ REBINT Float_Int16(REBD32 f)
-/*
-***********************************************************************/
-{
- if (fabs(f) > (REBD32)(0x7FFF)) {
- DS_PUSH_DECIMAL(f);
- Trap_Range(DS_TOP);
- }
- return (REBINT)f;
+ fail (Error_Out_Of_Range(temp));
+ }
+ return cast(REBINT, f);
}
-/***********************************************************************
-**
-*/ REBINT Int32(REBVAL *val)
-/*
-***********************************************************************/
+//
+// Int32: C
+//
+REBINT Int32(const RELVAL *val)
{
- REBINT n = 0;
-
- if (IS_DECIMAL(val)) {
- if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
- Trap_Range(val);
- n = (REBINT)VAL_DECIMAL(val);
- } else {
- if (VAL_INT64(val) > (i64)MAX_I32 || VAL_INT64(val) < (i64)MIN_I32)
- Trap_Range(val);
- n = VAL_INT32(val);
- }
-
- return n;
-}
+ if (IS_DECIMAL(val)) {
+ if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
+ goto out_of_range;
+ return cast(REBINT, VAL_DECIMAL(val));
+ }
-/***********************************************************************
-**
-*/ REBINT Int32s(REBVAL *val, REBINT sign)
-/*
-** Get integer as positive, negative 32 bit value.
-** Sign field can be
-** 0: >= 0
-** 1: > 0
-** -1: < 0
-**
-***********************************************************************/
-{
- REBINT n = 0;
-
- if (IS_DECIMAL(val)) {
- if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
- Trap_Range(val);
-
- n = (REBINT)VAL_DECIMAL(val);
- } else {
- if (VAL_INT64(val) > (i64)MAX_I32 || VAL_INT64(val) < (i64)MIN_I32)
- Trap_Range(val);
-
- n = VAL_INT32(val);
- }
-
- // More efficient to use positive sense:
- if (
- (sign == 0 && n >= 0) ||
- (sign > 0 && n > 0) ||
- (sign < 0 && n < 0)
- )
- return n;
-
- Trap_Range(val);
- return 0;
-}
-
+ assert(IS_INTEGER(val));
-/***********************************************************************
-**
-*/ REBI64 Int64(REBVAL *val)
-/*
-***********************************************************************/
-{
- if (IS_INTEGER(val)) return VAL_INT64(val);
- if (IS_DECIMAL(val) || IS_PERCENT(val)) return (REBI64)VAL_DECIMAL(val);
- if (IS_MONEY(val)) return deci_to_int(VAL_DECI(val));
- Trap_Arg(val);
- return 0;
-}
+ if (
+ VAL_INT64(val) > cast(i64, MAX_I32)
+ || VAL_INT64(val) < cast(i64, MIN_I32)
+ ) {
+ goto out_of_range;
+ }
+ return VAL_INT32(val);
-/***********************************************************************
-**
-*/ REBDEC Dec64(REBVAL *val)
-/*
-***********************************************************************/
-{
- if (IS_DECIMAL(val) || IS_PERCENT(val)) return VAL_DECIMAL(val);
- if (IS_INTEGER(val)) return (REBDEC)VAL_INT64(val);
- if (IS_MONEY(val)) return deci_to_decimal(VAL_DECI(val));
- Trap_Arg(val);
- return 0;
+out_of_range:
+ fail (Error_Out_Of_Range(const_KNOWN(val)));
}
-/***********************************************************************
-**
-*/ REBI64 Int64s(REBVAL *val, REBINT sign)
-/*
-** Get integer as positive, negative 64 bit value.
-** Sign field can be
-** 0: >= 0
-** 1: > 0
-** -1: < 0
-**
-***********************************************************************/
+//
+// Int32s: C
+//
+// Get integer as positive, negative 32 bit value.
+// Sign field can be
+// 0: >= 0
+// 1: > 0
+// -1: < 0
+//
+REBINT Int32s(const RELVAL *val, REBINT sign)
{
- REBI64 n;
-
- if (IS_DECIMAL(val)) {
- if (VAL_DECIMAL(val) > MAX_I64 || VAL_DECIMAL(val) < MIN_I64)
- Trap_Range(val);
- n = (REBI64)VAL_DECIMAL(val);
- } else {
- n = VAL_INT64(val);
- }
-
- // More efficient to use positive sense:
- if (
- (sign == 0 && n >= 0) ||
- (sign > 0 && n > 0) ||
- (sign < 0 && n < 0)
- )
- return n;
-
- Trap_Range(val);
- DEAD_END;
-}
+ REBINT n;
+ if (IS_DECIMAL(val)) {
+ if (VAL_DECIMAL(val) > MAX_I32 || VAL_DECIMAL(val) < MIN_I32)
+ goto out_of_range;
-/***********************************************************************
-**
-*/ REBINT Int8u(REBVAL *val)
-/*
-***********************************************************************/
-{
- if (VAL_INT64(val) > (i64)255 || VAL_INT64(val) < (i64)0) Trap_Range(val);
- return VAL_INT32(val);
-}
+ n = cast(REBINT, VAL_DECIMAL(val));
+ } else {
+ assert(IS_INTEGER(val));
+ if (VAL_INT64(val) > cast(i64, MAX_I32))
+ goto out_of_range;
-/***********************************************************************
-**
-*/ REBCNT Find_Refines(REBVAL *ds, REBCNT mask)
-/*
-** Scans the stack for function refinements that have been
-** specified in the mask (each as a bit) and are being used.
-**
-***********************************************************************/
-{
- REBINT n;
- REBCNT result = 0;
- REBINT len = DS_ARGC;
-
- for (n = 0; n < len; n++) {
- if ((mask & (1 << n) && D_REF(n+1)))
- result |= 1 << n;
- }
- return result;
-}
+ n = VAL_INT32(val);
+ }
+ // More efficient to use positive sense:
+ if (
+ (sign == 0 && n >= 0) ||
+ (sign > 0 && n > 0) ||
+ (sign < 0 && n < 0)
+ )
+ return n;
-/***********************************************************************
-**
-*/ void Set_Datatype(REBVAL *value, REBINT n)
-/*
-***********************************************************************/
-{
- *value = *BLK_SKIP(Lib_Context, n+1);
+out_of_range:
+ fail (Error_Out_Of_Range(const_KNOWN(val)));
}
-/***********************************************************************
-**
-*/ REBVAL *Get_Type(REBCNT index)
-/*
-** Returns the specified datatype value from the system context.
-** The datatypes are all at the head of the context.
-**
-***********************************************************************/
+//
+// Int64: C
+//
+REBI64 Int64(const REBVAL *val)
{
- ASSERT(index < SERIES_TAIL(Lib_Context), RP_BAD_OBJ_INDEX);
- return FRM_VALUES(Lib_Context) + index + 1;
-}
-
+ if (IS_INTEGER(val))
+ return VAL_INT64(val);
+ if (IS_DECIMAL(val) || IS_PERCENT(val))
+ return cast(REBI64, VAL_DECIMAL(val));
+ if (IS_MONEY(val))
+ return deci_to_int(VAL_MONEY_AMOUNT(val));
-/***********************************************************************
-**
-*/ REBVAL *Of_Type(REBVAL *value)
-/*
-** Returns the datatype value for the given value.
-** The datatypes are all at the head of the context.
-**
-***********************************************************************/
-{
- return FRM_VALUES(Lib_Context) + VAL_TYPE(value) + 1;
+ fail (val);
}
-/***********************************************************************
-**
-*/ REBINT Get_Type_Sym(REBCNT type)
-/*
-** Returns the datatype word for the given type number.
-**
-***********************************************************************/
+//
+// Dec64: C
+//
+REBDEC Dec64(const REBVAL *val)
{
- return FRM_WORD_SYM(Lib_Context, type + 1);
-}
+ if (IS_DECIMAL(val) || IS_PERCENT(val))
+ return VAL_DECIMAL(val);
+ if (IS_INTEGER(val))
+ return cast(REBDEC, VAL_INT64(val));
+ if (IS_MONEY(val))
+ return deci_to_decimal(VAL_MONEY_AMOUNT(val));
-
-/***********************************************************************
-**
-*/ REBVAL *Get_Type_Word(REBCNT type)
-/*
-** Returns the datatype word for the given type number.
-**
-***********************************************************************/
-{
- return FRM_WORD(Lib_Context, type + 1);
+ fail (val);
}
-/***********************************************************************
-**
-*/ REBYTE *Get_Field_Name(REBSER *obj, REBCNT index)
-/*
-** Get the name of a field of an object.
-**
-***********************************************************************/
+//
+// Int64s: C
+//
+// Get integer as positive, negative 64 bit value.
+// Sign field can be
+// 0: >= 0
+// 1: > 0
+// -1: < 0
+//
+REBI64 Int64s(const REBVAL *val, REBINT sign)
{
- ASSERT1(index < SERIES_TAIL(obj), RP_BAD_OBJ_INDEX);
- return Get_Sym_Name(FRM_WORD_SYM(obj, index));
-}
-
+ REBI64 n;
-/***********************************************************************
-**
-*/ REBVAL *Get_Field(REBSER *obj, REBCNT index)
-/*
-** Get an instance variable from an object series.
-**
-***********************************************************************/
-{
- ASSERT1(index < SERIES_TAIL(obj), RP_BAD_OBJ_INDEX);
- return FRM_VALUES(obj) + index;
-}
+ if (IS_DECIMAL(val)) {
+ if (VAL_DECIMAL(val) > MAX_I64 || VAL_DECIMAL(val) < MIN_I64)
+ fail (Error_Out_Of_Range(val));
+ n = (REBI64)VAL_DECIMAL(val);
+ } else {
+ n = VAL_INT64(val);
+ }
+ // More efficient to use positive sense:
+ if (
+ (sign == 0 && n >= 0) ||
+ (sign > 0 && n > 0) ||
+ (sign < 0 && n < 0)
+ )
+ return n;
-/***********************************************************************
-**
-*/ REBVAL *Get_Object(REBVAL *objval, REBCNT index)
-/*
-** Get an instance variable from an object value.
-**
-***********************************************************************/
-{
- REBSER *obj = VAL_OBJ_FRAME(objval);
- ASSERT1(IS_FRAME(BLK_HEAD(obj)), RP_BAD_OBJ_FRAME);
- ASSERT1(index < SERIES_TAIL(obj), RP_BAD_OBJ_INDEX);
- return FRM_VALUES(obj) + index;
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *In_Object(REBSER *base, ...)
-/*
-** Get value from nested list of objects. List is null terminated.
-** Returns object value, else returns 0 if not found.
-**
-***********************************************************************/
-{
- REBVAL *obj = 0;
- REBCNT n;
- va_list args;
-
- va_start(args, base);
- while (NZ(n = va_arg(args, REBCNT))) {
- if (n >= SERIES_TAIL(base)) return 0;
- obj = OFV(base, n);
- if (!IS_OBJECT(obj)) return 0;
- base = VAL_OBJ_FRAME(obj);
- }
- va_end(args);
-
- return obj;
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Get_System(REBCNT i1, REBCNT i2)
-/*
-** Return a second level object field of the system object.
-**
-***********************************************************************/
-{
- REBVAL *obj;
-
- obj = VAL_OBJ_VALUES(ROOT_SYSTEM) + i1;
- if (!i2) return obj;
- ASSERT1(IS_OBJECT(obj), RP_BAD_OBJ_INDEX);
- return Get_Field(VAL_OBJ_FRAME(obj), i2);
+ fail (Error_Out_Of_Range(val));
}
-/***********************************************************************
-**
-*/ REBINT Get_System_Int(REBCNT i1, REBCNT i2, REBINT default_int)
-/*
-** Get an integer from system object.
-**
-***********************************************************************/
+//
+// Int8u: C
+//
+REBINT Int8u(const REBVAL *val)
{
- REBVAL *val = Get_System(i1, i2);
- if (IS_INTEGER(val)) return VAL_INT32(val);
- return default_int;
-}
-
+ if (VAL_INT64(val) > cast(i64, 255) || VAL_INT64(val) < cast(i64, 0))
+ fail (Error_Out_Of_Range(val));
-/***********************************************************************
-**
-*/ REBSER *Make_Std_Object(REBCNT index)
-/*
-***********************************************************************/
-{
- return CLONE_OBJECT(VAL_OBJ_FRAME(Get_System(SYS_STANDARD, index)));
+ return VAL_INT32(val);
}
-/***********************************************************************
-**
-*/ void Set_Object_Values(REBSER *obj, REBVAL *vals)
-/*
-***********************************************************************/
+//
+// Val_Init_Datatype: C
+//
+void Val_Init_Datatype(REBVAL *out, enum Reb_Kind kind)
{
- REBVAL *value;
-
- for (value = FRM_VALUES(obj) + 1; NOT_END(value); value++) { // skip self
- if (IS_END(vals)) SET_NONE(value);
- else *value = *vals++;
- }
+ assert(kind > REB_0 && kind < REB_MAX);
+ Move_Value(out, CTX_VAR(Lib_Context, SYM_FROM_KIND(kind)));
}
-/***********************************************************************
-**
-*/ void Set_Series(REBINT type, REBVAL *value, REBSER *series)
-/*
-** Common function.
-**
-***********************************************************************/
+//
+// Get_Type: C
+//
+// Returns the specified datatype value from the system context.
+// The datatypes are all at the head of the context.
+//
+REBVAL *Get_Type(enum Reb_Kind kind)
{
- VAL_SET(value, type);
- VAL_SERIES(value) = series;
- VAL_INDEX(value) = 0;
- VAL_SERIES_SIDE(value) = 0;
+ assert(kind > REB_0 && kind < REB_MAX);
+ return CTX_VAR(Lib_Context, SYM_FROM_KIND(kind));
}
-/***********************************************************************
-**
-*/ void Set_Block(REBVAL *value, REBSER *series)
-/*
-** Common function.
-**
-***********************************************************************/
+//
+// Type_Of: C
+//
+// Returns the datatype value for the given value.
+// The datatypes are all at the head of the context.
+//
+REBVAL *Type_Of(const RELVAL *value)
{
- VAL_SET(value, REB_BLOCK);
- VAL_SERIES(value) = series;
- VAL_INDEX(value) = 0;
- VAL_SERIES_SIDE(value) = 0;
-}
-
-
-/***********************************************************************
-**
-*/ void Set_Block_Index(REBVAL *value, REBSER *series, REBCNT index)
-/*
-** Common function.
-**
-***********************************************************************/
-{
- VAL_SET(value, REB_BLOCK);
- VAL_SERIES(value) = series;
- VAL_INDEX(value) = index;
- VAL_SERIES_SIDE(value) = 0;
-}
-
-
-/***********************************************************************
-**
-*/ void Set_String(REBVAL *value, REBSER *series)
-/*
-** Common function.
-**
-***********************************************************************/
-{
- VAL_SET(value, REB_STRING);
- VAL_SERIES(value) = series;
- VAL_INDEX(value) = 0;
- VAL_SERIES_SIDE(value) = 0;
-}
-
-
-/***********************************************************************
-**
-*/ void Set_Binary(REBVAL *value, REBSER *series)
-/*
-** Common function.
-**
-***********************************************************************/
-{
- VAL_SET(value, REB_BINARY);
- VAL_SERIES(value) = series;
- VAL_INDEX(value) = 0;
- VAL_SERIES_SIDE(value) = 0;
-}
-
-
-/***********************************************************************
-**
-*/ void Set_Tuple(REBVAL *value, REBYTE *bytes, REBCNT len)
-/*
-***********************************************************************/
-{
- REBYTE *bp;
-
- VAL_SET(value, REB_TUPLE);
- VAL_TUPLE_LEN(value) = (REBYTE)len;
- for (bp = VAL_TUPLE(value); len > 0; len--)
- *bp++ = *bytes++;
+ return CTX_VAR(Lib_Context, SYM_FROM_KIND(VAL_TYPE(value)));
}
-/***********************************************************************
-**
-*/ void Set_Object(REBVAL *value, REBSER *series)
-/*
-***********************************************************************/
-{
- VAL_SET(value, REB_OBJECT);
- VAL_OBJ_FRAME(value) = series;
-}
-
-
-/***********************************************************************
-**
-*/ REBCNT Val_Series_Len(REBVAL *value)
-/*
-** Get length of series, but avoid negative values.
-**
-***********************************************************************/
-{
- if (VAL_INDEX(value) >= VAL_TAIL(value)) return 0;
- return VAL_TAIL(value) - VAL_INDEX(value);
-}
-
-
-/***********************************************************************
-**
-*/ REBCNT Val_Byte_Len(REBVAL *value)
-/*
-** Get length of series in bytes.
-**
-***********************************************************************/
-{
- if (VAL_INDEX(value) >= VAL_TAIL(value)) return 0;
- return (VAL_TAIL(value) - VAL_INDEX(value)) * SERIES_WIDE(VAL_SERIES(value));
-}
-
-
-/***********************************************************************
-**
-*/ REBFLG Get_Logic_Arg(REBVAL *arg)
-/*
-***********************************************************************/
-{
- if (IS_NONE(arg)) return 0;
- if (IS_INTEGER(arg)) return (VAL_INT64(arg) != 0);
- if (IS_LOGIC(arg)) return (VAL_LOGIC(arg) != 0);
- if (IS_DECIMAL(arg) || IS_PERCENT(arg)) return (VAL_DECIMAL(arg) != 0.0);
- Trap_Arg(arg);
- DEAD_END;
-}
-
-
-
-#ifdef ndef
-/***********************************************************************
-**
-*/ REBCNT Get_Part_Length(REBVAL *bval, REBVAL *eval)
-/*
-** Determine the length of a /PART value.
-** If /PART value is an integer just use it.
-** If it is a series and it is the same series as the first,
-** use the difference between the two indices.
-**
-** If the length ends up negative, back up the index as much
-** as possible. If backed up over the head, adjust the length.
-**
-** Note: This one does not handle list datatypes.
-**
-***********************************************************************/
-{
- REBINT len;
- REBCNT tail;
-
- if (IS_INTEGER(eval) || IS_DECIMAL(eval)) {
- len = Int32(eval);
- if (IS_SCALAR(bval) && VAL_TYPE(bval) != REB_PORT)
- Trap1(RE_INVALID_PART, bval);
- }
- else if (
- (
- // IF normal series and self referencing:
- VAL_TYPE(eval) >= REB_STRING &&
- VAL_TYPE(eval) <= REB_BLOCK &&
- VAL_TYPE(bval) == VAL_TYPE(eval) &&
- VAL_SERIES(bval) == VAL_SERIES(eval)
- ) || (
- // OR IF it is a port:
- IS_PORT(bval) && IS_PORT(eval) &&
- VAL_OBJ_FRAME(bval) == VAL_OBJ_FRAME(eval)
- )
- )
- len = (REBINT)VAL_INDEX(eval) - (REBINT)VAL_INDEX(bval);
- else
- Trap1(RE_INVALID_PART, eval);
-/* !!!!
- if (IS_PORT(bval)) {
- PORT_STATE_OBJ *port;
-
- port = VAL_PORT(&VAL_PSP(bval)->state);
- if (PORT_FLAG(port) & PF_DIRECT)
- tail = 0x7fffffff;
- else
- tail = PORT_TAIL(VAL_PORT(&VAL_PSP(bval)->state));
- }
- else
-*/ tail = VAL_TAIL(bval);
-
- if (len < 0) {
- len = -len;
- if (len > (REBINT)VAL_INDEX(bval))
- len = (REBINT)VAL_INDEX(bval);
- VAL_INDEX(bval) -= (REBCNT)len;
- }
- else if (!IS_INTEGER(eval) && (len + VAL_INDEX(bval)) > tail)
- len = (REBINT)(tail - VAL_INDEX(bval));
-
- return (REBCNT)len;
-}
+//
+// In_Object: C
+//
+// Get value from nested list of objects. List is null terminated.
+// Returns object value, else returns 0 if not found.
+//
+REBVAL *In_Object(REBCTX *base, ...)
+{
+ REBVAL *context = NULL;
+ REBCNT n;
+ va_list va;
+
+ va_start(va, base);
+ while ((n = va_arg(va, REBCNT))) {
+ if (n > CTX_LEN(base)) {
+ va_end(va);
+ return NULL;
+ }
+ context = CTX_VAR(base, n);
+ if (!ANY_CONTEXT(context)) {
+ va_end(va);
+ return NULL;
+ }
+ base = VAL_CONTEXT(context);
+ }
+ va_end(va);
+
+ return context;
+}
+
+
+//
+// Get_System: C
+//
+// Return a second level object field of the system object.
+//
+REBVAL *Get_System(REBCNT i1, REBCNT i2)
+{
+ REBVAL *obj;
+
+ obj = CTX_VAR(VAL_CONTEXT(ROOT_SYSTEM), i1);
+ if (i2 == 0) return obj;
+ assert(IS_OBJECT(obj));
+ return CTX_VAR(VAL_CONTEXT(obj), i2);
+}
+
+
+//
+// Get_System_Int: C
+//
+// Get an integer from system object.
+//
+REBINT Get_System_Int(REBCNT i1, REBCNT i2, REBINT default_int)
+{
+ REBVAL *val = Get_System(i1, i2);
+ if (IS_INTEGER(val)) return VAL_INT32(val);
+ return default_int;
+}
+
+
+//
+// Init_Any_Series_At_Core: C
+//
+// Common function.
+//
+void Init_Any_Series_At_Core(
+ RELVAL *out, // allows RELVAL slot as input, but will be filled w/REBVAL
+ enum Reb_Kind type,
+ REBSER *series,
+ REBCNT index,
+ REBSPC *specifier
+) {
+ ENSURE_SERIES_MANAGED(series);
+
+ if (type != REB_IMAGE && type != REB_VECTOR) {
+ // Code in various places seemed to have different opinions of
+ // whether a BINARY needed to be zero terminated. It doesn't
+ // make a lot of sense to zero terminate a binary unless it
+ // simplifies the code assumptions somehow--it's in the class
+ // "ANY_BINSTR()" so that suggests perhaps it has a bit more
+ // obligation to conform. Also, the original Make_Binary comment
+ // from the open source release read:
+ //
+ // Make a binary string series. For byte, C, and UTF8 strings.
+ // Add 1 extra for terminator.
+ //
+ // Until that is consciously overturned, check the REB_BINARY too
+
+ ASSERT_SERIES_TERM(series); // doesn't apply to image/vector
+ }
+
+ VAL_RESET_HEADER(out, type);
+ out->payload.any_series.series = series;
+ VAL_INDEX(out) = index;
+ if (specifier == SPECIFIED)
+ INIT_SPECIFIC(out, SPECIFIED);
+ else
+ INIT_SPECIFIC(out, CTX(specifier));
+
+#if !defined(NDEBUG)
+ if (GET_SER_FLAG(series, SERIES_FLAG_ARRAY) && specifier == SPECIFIED) {
+ //
+ // If a SPECIFIED is used for an array, then that top level of the
+ // array cannot have any relative values in it. Catch it here vs.
+ // waiting until a later assertion.
+ //
+ ASSERT_NO_RELATIVE(ARR(series), FALSE);
+ }
+ else if (ANY_STRING(out))
+ assert(SER_WIDE(series) == 1 || SER_WIDE(series) == 2);
#endif
-
-
-/***********************************************************************
-**
-*/ REBINT Partial1(REBVAL *sval, REBVAL *lval)
-/*
-** Process the /part (or /skip) and other length modifying
-** arguments.
-**
-***********************************************************************/
-{
- REBI64 len;
- REBINT maxlen;
- REBINT is_ser = ANY_SERIES(sval);
-
- // If lval = NONE, use the current len of the target value:
- if (IS_NONE(lval)) {
- if (!is_ser) return 1;
- if (VAL_INDEX(sval) >= VAL_TAIL(sval)) return 0;
- return (VAL_TAIL(sval) - VAL_INDEX(sval));
- }
- if (IS_INTEGER(lval) || IS_DECIMAL(lval)) len = Int32(lval);
- else {
- if (is_ser && VAL_TYPE(sval) == VAL_TYPE(lval) && VAL_SERIES(sval) == VAL_SERIES(lval))
- len = (REBINT)VAL_INDEX(lval) - (REBINT)VAL_INDEX(sval);
- else
- Trap1(RE_INVALID_PART, lval);
-
- }
-
- if (is_ser) {
- // Restrict length to the size available:
- if (len >= 0) {
- maxlen = (REBINT)VAL_LEN(sval);
- if (len > maxlen) len = maxlen;
- } else {
- len = -len;
- if (len > (REBINT)VAL_INDEX(sval)) len = (REBINT)VAL_INDEX(sval);
- VAL_INDEX(sval) -= (REBCNT)len;
- }
- }
-
- return (REBINT)len;
}
-/***********************************************************************
-**
-*/ REBINT Partial(REBVAL *aval, REBVAL *bval, REBVAL *lval, REBFLG flag)
-/*
-** Args:
-** aval: target value
-** bval: argument to modify target (optional)
-** lval: length value (or none)
-**
-** Determine the length of a /PART value. It can be:
-** 1. integer or decimal
-** 2. relative to A value (bval is null)
-** 3. relative to B value
-**
-** Flag: indicates special treatment for CHANGE. As in:
-** CHANGE/part "abcde" "xy" 3 => "xyde"
-**
-** NOTE: Can modify the value's index!
-** The result can be negative. ???
-**
-***********************************************************************/
-{
- REBVAL *val;
- REBINT len;
- REBINT maxlen;
-
- // If lval = NONE, use the current len of the target value:
- if (IS_NONE(lval)) {
- val = (bval && ANY_SERIES(bval)) ? bval : aval;
- if (VAL_INDEX(val) >= VAL_TAIL(val)) return 0;
- return (VAL_TAIL(val) - VAL_INDEX(val));
- }
-
- if (IS_INTEGER(lval)) {
- len = Int32(lval);
- val = flag ? aval : bval;
- }
-
- else if (IS_DECIMAL(lval)) {
- len = Int32(lval);
- val = bval;
- }
-
- else {
- // So, lval must be relative to aval or bval series:
- if (VAL_TYPE(aval) == VAL_TYPE(lval) && VAL_SERIES(aval) == VAL_SERIES(lval))
- val = aval;
- else if (bval && VAL_TYPE(bval) == VAL_TYPE(lval) && VAL_SERIES(bval) == VAL_SERIES(lval))
- val = bval;
- else
- Trap1(RE_INVALID_PART, lval);
-
- len = (REBINT)VAL_INDEX(lval) - (REBINT)VAL_INDEX(val);
- }
-
- if (!val) val = aval;
-
- // Restrict length to the size available:
- if (len >= 0) {
- maxlen = (REBINT)VAL_LEN(val);
- if (len > maxlen) len = maxlen;
- } else {
- len = -len;
- if (len > (REBINT)VAL_INDEX(val)) len = (REBINT)VAL_INDEX(val);
- VAL_INDEX(val) -= (REBCNT)len;
-// if ((-len) > (REBINT)VAL_INDEX(val)) len = -(REBINT)VAL_INDEX(val);
- }
-
- return len;
-}
-
-
-#ifdef ndef
-/***********************************************************************
-**
-*/ void Define_File_Global(REBYTE *name, REBYTE *content)
-/*
-** Util function used in startup.
-**
-***********************************************************************/
-{
- REBCNT sym = Make_Word(name, 0);
- REBSER *str = Make_CStr(content);
- REBVAL *value;
-
- value = Append_Frame(Main_Context, 0, sym);
- SET_STR_TYPE(REB_FILE, value, str);
-}
-
+//
+// Set_Tuple: C
+//
+void Set_Tuple(REBVAL *value, REBYTE *bytes, REBCNT len)
+{
+ REBYTE *bp;
+
+ VAL_RESET_HEADER(value, REB_TUPLE);
+ VAL_TUPLE_LEN(value) = (REBYTE)len;
+ for (bp = VAL_TUPLE(value); len > 0; len--)
+ *bp++ = *bytes++;
+}
+
+
+//
+// Init_Any_Context_Core: C
+//
+// Common routine for initializing OBJECT, MODULE!, PORT!, and ERROR!
+//
+// A fully constructed context can reconstitute the ANY-CONTEXT! REBVAL that
+// is its canon form from a single pointer...the REBVAL sitting in the 0 slot
+// of the context's varlist.
+//
+void Init_Any_Context_Core(
+ RELVAL *out, // allows RELVAL slot as input, but will be filled w/REBVAL
+ enum Reb_Kind kind,
+ REBCTX *c
+) {
+#if defined(NDEBUG)
+ UNUSED(kind);
+#else
+ //
+ // In a debug build we check to make sure the type of the embedded value
+ // matches the type of what is intended (so someone who thinks they are
+ // initializing a REB_OBJECT from a CONTEXT does not accidentally get a
+ // REB_ERROR, for instance.) It's a point for several other integrity
+ // checks as well.
+ //
+ REBVAL *archetype = CTX_VALUE(c);
+ assert(VAL_CONTEXT(archetype) == c);
+
+ assert(CTX_TYPE(c) == kind);
+ if (CTX_KEYLIST(c) == NULL)
+ panic (c);
+
+ assert(GET_SER_FLAG(CTX_VARLIST(c), ARRAY_FLAG_VARLIST));
+
+ assert(NOT_SER_FLAG(CTX_VARLIST(c), SERIES_FLAG_FILE_LINE));
+ assert(NOT_SER_FLAG(CTX_KEYLIST(c), SERIES_FLAG_FILE_LINE));
+
+ if (IS_FRAME(CTX_VALUE(c)))
+ assert(IS_FUNCTION(CTX_FRAME_FUNC_VALUE(c)));
+
+ // !!! Currently only a context can serve as the "meta" information,
+ // though the interface may expand.
+ //
+ assert(CTX_META(c) == NULL || ANY_CONTEXT(CTX_VALUE(CTX_META(c))));
#endif
-/***********************************************************************
-**
-*/ int Clip_Int(int val, int mini, int maxi)
-/*
-***********************************************************************/
-{
- if (val < mini) val = mini;
- else if (val > maxi) val = maxi;
- return val;
-}
-
-/***********************************************************************
-**
-*/ void memswapl(void *m1, void *m2, size_t len)
-/*
-** For long integer memory units, not chars. It is assumed that
-** the len is an exact modulo of long.
-**
-***********************************************************************/
-{
- long t, *a, *b;
-
- a = m1;
- b = m2;
- len /= sizeof(long);
- while (len--) {
- t = *b;
- *b++ = *a;
- *a++ = t;
- }
-}
-
-
-/***********************************************************************
-**
-*/ i64 Add_Max(int type, i64 n, i64 m, i64 maxi)
-/*
-***********************************************************************/
-{
- i64 r = n + m;
- if (r < -maxi || r > maxi) {
- if (type) Trap1(RE_TYPE_LIMIT, Get_Type(type));
- r = r > 0 ? maxi : -maxi;
- }
- return r;
-}
-
-
-/***********************************************************************
-**
-*/ int Mul_Max(int type, i64 n, i64 m, i64 maxi)
-/*
-***********************************************************************/
-{
- i64 r = n * m;
- if (r < -maxi || r > maxi) Trap1(RE_TYPE_LIMIT, Get_Type(type));
- return (int)r;
-}
-
-
-/***********************************************************************
-**
-*/ REBVAL *Make_OS_Error()
-/*
-***********************************************************************/
-{
- REBCHR str[100];
-
- OS_FORM_ERROR(0, str, 100);
- Set_String(DS_RETURN, Copy_OS_Str(str, LEN_STR(str)));
- return DS_RETURN;
+ // Some contexts (stack frames in particular) start out unmanaged, and
+ // then check to see if an operation like Init_Any_Context set them to
+ // managed. If not, they will free the context. This avoids the need
+ // for the garbage collector to have to deal with the series if there's
+ // no reason too.
+ //
+ // Here is a case of where we mark the context as having an extant usage,
+ // so that at minimum this value must become unreachable from the root GC
+ // set before they are GC'd. For another case, see INIT_WORD_CONTEXT(),
+ // where an ANY-WORD! can mark a context as in use.
+ //
+ ENSURE_ARRAY_MANAGED(CTX_VARLIST(c));
+
+ // Keylists are different, because they may-or-may-not-be-reused by some
+ // operations. There needs to be a uniform policy on their management,
+ // or certain routines would return "sometimes managed, sometimes not"
+ // keylist series...a bad invariant.
+ //
+ ASSERT_ARRAY_MANAGED(CTX_KEYLIST(c));
+
+ Move_Value(out, CTX_VALUE(c));
+
+ // Currently only FRAME! uses the ->binding field. Following the pattern
+ // of function, we assume the archetype form of a frame has no binding,
+ // and it's only REBVAL instances besides the canon that become bound.
+ //
+ assert(VAL_BINDING(out) == NULL);
+
+ // Only FRAME!s are allowed to have phases.
+ //
+ assert(
+ out->payload.any_context.phase == NULL
+ || (
+ CTX_TYPE(c) == REB_FRAME
+ && NOT(IS_POINTER_TRASH_DEBUG(out->payload.any_context.phase))
+ )
+ );
+}
+
+
+//
+// Partial1: C
+//
+// Process the /part (or /skip) and other length modifying arguments.
+//
+// Adjusts the value's index if necessary, and returns the length indicated.
+// Hence if a negative limit is passed in, it will adjust value to the
+// position that negative limit would seek to...and save the length of
+// the span to get to the original index.
+//
+void Partial1(REBVAL *value, const REBVAL *limit, REBCNT *span)
+{
+ REBOOL is_series = ANY_SERIES(value);
+
+ if (IS_VOID(limit)) { // use current length of the target value
+ if (!is_series) {
+ *span = 1;
+ }
+ else if (VAL_INDEX(value) >= VAL_LEN_HEAD(value)) {
+ *span = 0;
+ }
+ else {
+ *span = (VAL_LEN_HEAD(value) - VAL_INDEX(value));
+ }
+ return;
+ }
+
+ REBI64 len;
+ if (IS_INTEGER(limit) || IS_DECIMAL(limit))
+ len = Int32(limit);
+ else {
+ if (
+ !is_series
+ || VAL_TYPE(value) != VAL_TYPE(limit)
+ || VAL_SERIES(value) != VAL_SERIES(limit)
+ ){
+ fail (Error_Invalid_Part_Raw(limit));
+ }
+
+ len = cast(REBINT, VAL_INDEX(limit)) - cast(REBINT, VAL_INDEX(value));
+
+ }
+
+ if (is_series) {
+ // Restrict length to the size available:
+ if (len >= 0) {
+ REBCNT maxlen = VAL_LEN_AT(value);
+ if (len > cast(REBINT, maxlen))
+ len = maxlen;
+ }
+ else {
+ len = -len;
+ if (len > cast(REBINT, VAL_INDEX(value)))
+ len = VAL_INDEX(value);
+ assert(len >= 0);
+ VAL_INDEX(value) -= cast(REBCNT, len);
+ }
+ }
+
+ assert(len >= 0);
+ *span = cast(REBCNT, len);
+}
+
+
+//
+// Partial: C
+//
+// Args:
+// aval: target value
+// bval: argument to modify target (optional)
+// lval: length value (or blank)
+//
+// Determine the length of a /PART value. It can be:
+// 1. integer or decimal
+// 2. relative to A value (bval is null)
+// 3. relative to B value
+//
+// NOTE: Can modify the value's index!
+// The result can be negative. ???
+//
+REBINT Partial(REBVAL *aval, REBVAL *bval, REBVAL *lval)
+{
+ REBVAL *val;
+ REBINT len;
+ REBINT maxlen;
+
+ // If lval is unset, use the current len of the target value:
+ if (IS_VOID(lval)) {
+ val = (bval && ANY_SERIES(bval)) ? bval : aval;
+ if (VAL_INDEX(val) >= VAL_LEN_HEAD(val)) return 0;
+ return (VAL_LEN_HEAD(val) - VAL_INDEX(val));
+ }
+
+ if (IS_INTEGER(lval) || IS_DECIMAL(lval)) {
+ len = Int32(lval);
+ val = bval;
+ }
+ else {
+ // So, lval must be relative to aval or bval series:
+ if (
+ VAL_TYPE(aval) == VAL_TYPE(lval)
+ && VAL_SERIES(aval) == VAL_SERIES(lval)
+ ) {
+ val = aval;
+ }
+ else if (
+ bval
+ && VAL_TYPE(bval) == VAL_TYPE(lval)
+ && VAL_SERIES(bval) == VAL_SERIES(lval)
+ ) {
+ val = bval;
+ }
+ else
+ fail (Error_Invalid_Part_Raw(lval));
+
+ len = cast(REBINT, VAL_INDEX(lval)) - cast(REBINT, VAL_INDEX(val));
+ }
+
+ if (!val) val = aval;
+
+ // Restrict length to the size available
+ //
+ if (len >= 0) {
+ maxlen = (REBINT)VAL_LEN_AT(val);
+ if (len > maxlen) len = maxlen;
+ }
+ else {
+ len = -len;
+ if (len > cast(REBINT, VAL_INDEX(val)))
+ len = cast(REBINT, VAL_INDEX(val));
+ VAL_INDEX(val) -= (REBCNT)len;
+ }
+
+ return len;
+}
+
+
+//
+// Clip_Int: C
+//
+int Clip_Int(int val, int mini, int maxi)
+{
+ if (val < mini) val = mini;
+ else if (val > maxi) val = maxi;
+ return val;
+}
+
+
+//
+// Add_Max: C
+//
+i64 Add_Max(enum Reb_Kind type, i64 n, i64 m, i64 maxi)
+{
+ i64 r = n + m;
+ if (r < -maxi || r > maxi) {
+ if (type != REB_0) fail (Error_Type_Limit_Raw(Get_Type(type)));
+ r = r > 0 ? maxi : -maxi;
+ }
+ return r;
+}
+
+
+//
+// Mul_Max: C
+//
+int Mul_Max(enum Reb_Kind type, i64 n, i64 m, i64 maxi)
+{
+ i64 r = n * m;
+ if (r < -maxi || r > maxi) fail (Error_Type_Limit_Raw(Get_Type(type)));
+ return (int)r;
}
-
-/***********************************************************************
-**
-*/ REBSER *At_Head(REBVAL *value)
-/*
-** Return the series for a value, but if it has an index
-** offset, return a copy of the series from that position.
-** Useful for functions that do not accept index offsets.
-**
-***********************************************************************/
-{
- REBCNT len;
- REBSER *ser;
- REBSER *src = VAL_SERIES(value);
- REBCNT wide;
-
- if (VAL_INDEX(value) == 0) return src;
-
- len = VAL_LEN(value);
- wide = SERIES_WIDE(src);
- ser = Make_Series(len, wide, FALSE);
-
- memcpy(ser->data, src->data + (VAL_INDEX(value) * wide), len * wide);
- ser->tail = len;
-
- return ser;
-}
-
-
-/***********************************************************************
-**
-*/ REBSER *Collect_Set_Words(REBVAL *val)
-/*
-** Scan a block, collecting all of its SET words as a block.
-**
-***********************************************************************/
-{
- REBCNT cnt = 0;
- REBVAL *val2 = val;
- REBSER *ser;
-
- for (; NOT_END(val); val++) if (IS_SET_WORD(val)) cnt++;
- val = val2;
-
- ser = Make_Block(cnt);
- val2 = BLK_HEAD(ser);
- for (; NOT_END(val); val++) {
- if (IS_SET_WORD(val)) Init_Word(val2++, VAL_WORD_SYM(val));
- }
- SET_END(val2);
- SERIES_TAIL(ser) = cnt;
-
- return ser;
-}
-
-
-/***********************************************************************
-**
-*/ REBINT What_Reflector(REBVAL *word)
-/*
-***********************************************************************/
-{
- if (IS_WORD(word)) {
- switch (VAL_WORD_SYM(word)) {
- case SYM_SPEC: return OF_SPEC;
- case SYM_BODY: return OF_BODY;
- case SYM_WORDS: return OF_WORDS;
- case SYM_VALUES: return OF_VALUES;
- case SYM_TYPES: return OF_TYPES;
- case SYM_TITLE: return OF_TITLE;
- }
- }
- return 0;
-}
diff --git a/src/core/l-scan.c b/src/core/l-scan.c
old mode 100644
new mode 100755
index 46351735a6..6a61bb3ece
--- a/src/core/l-scan.c
+++ b/src/core/l-scan.c
@@ -1,1702 +1,2449 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: l-scan.c
-** Summary: lexical analyzer for source to binary translation
-** Section: lexical
-** Author: Carl Sassenrath
-** Notes:
-** WARNING WARNING WARNING
-** This is highly tuned code that should only be modified by experts
-** who fully understand its design. It is very easy to create odd
-** side effects so please be careful and extensively test all changes!
-**
-***********************************************************************/
+//
+// File: %l-scan.c
+// Summary: "lexical analyzer for source to binary translation"
+// Section: lexical
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Rebol's lexical scanner was implemented as hand-coded C, as opposed to
+// using a more formal grammar and generator. This makes the behavior hard
+// to formalize, though some attempts have been made to do so:
+//
+// http://rgchris.github.io/Rebol-Notation/
+//
+// Because Red is implemented using Rebol, it has a more abstract definition
+// in the sense that it uses PARSE rules:
+//
+// https://github.com/red/red/blob/master/lexer.r
+//
+// It would likely be desirable to bring more formalism and generativeness
+// to Rebol's scanner; though the current method of implementation was
+// ostensibly chosen for performance.
+//
#include "sys-core.h"
-#include "sys-scan.h"
-// In UTF8 C0, C1, F5, and FF are invalid.
-#ifdef USE_UNICODE
-#define LEX_UTFE LEX_DEFAULT
-#else
-#define LEX_UTFE LEX_WORD
-#endif
-/***********************************************************************
-**
-*/ const REBYTE Lex_Map[256] =
-/*
-** Maps each character to its lexical attributes, using
-** a frequency optimized encoding.
-**
-** UTF8: The values C0, C1, F5 to FF never appear.
-**
-***********************************************************************/
+//
+// Maps each character to its lexical attributes, using
+// a frequency optimized encoding.
+//
+// UTF8: The values C0, C1, F5 to FF never appear.
+//
+const REBYTE Lex_Map[256] =
{
- /* 00 EOF */ LEX_DELIMIT|LEX_DELIMIT_END_FILE,
- /* 01 */ LEX_DEFAULT,
- /* 02 */ LEX_DEFAULT,
- /* 03 */ LEX_DEFAULT,
- /* 04 */ LEX_DEFAULT,
- /* 05 */ LEX_DEFAULT,
- /* 06 */ LEX_DEFAULT,
- /* 07 */ LEX_DEFAULT,
- /* 08 BS */ LEX_DEFAULT,
- /* 09 TAB */ LEX_DEFAULT,
- /* 0A LF */ LEX_DELIMIT|LEX_DELIMIT_LINEFEED,
- /* 0B */ LEX_DEFAULT,
- /* 0C PG */ LEX_DEFAULT,
- /* 0D CR */ LEX_DELIMIT|LEX_DELIMIT_RETURN,
- /* 0E */ LEX_DEFAULT,
- /* 0F */ LEX_DEFAULT,
-
- /* 10 */ LEX_DEFAULT,
- /* 11 */ LEX_DEFAULT,
- /* 12 */ LEX_DEFAULT,
- /* 13 */ LEX_DEFAULT,
- /* 14 */ LEX_DEFAULT,
- /* 15 */ LEX_DEFAULT,
- /* 16 */ LEX_DEFAULT,
- /* 17 */ LEX_DEFAULT,
- /* 18 */ LEX_DEFAULT,
- /* 19 */ LEX_DEFAULT,
- /* 1A */ LEX_DEFAULT,
- /* 1B */ LEX_DEFAULT,
- /* 1C */ LEX_DEFAULT,
- /* 1D */ LEX_DEFAULT,
- /* 1E */ LEX_DEFAULT,
- /* 1F */ LEX_DEFAULT,
-
- /* 20 */ LEX_DELIMIT|LEX_DELIMIT_SPACE,
- /* 21 ! */ LEX_WORD,
- /* 22 " */ LEX_DELIMIT|LEX_DELIMIT_QUOTE,
- /* 23 # */ LEX_SPECIAL|LEX_SPECIAL_POUND,
- /* 24 $ */ LEX_SPECIAL|LEX_SPECIAL_DOLLAR,
- /* 25 % */ LEX_SPECIAL|LEX_SPECIAL_PERCENT,
- /* 26 & */ LEX_WORD,
- /* 27 ' */ LEX_SPECIAL|LEX_SPECIAL_TICK,
- /* 28 ( */ LEX_DELIMIT|LEX_DELIMIT_LEFT_PAREN,
- /* 29 ) */ LEX_DELIMIT|LEX_DELIMIT_RIGHT_PAREN,
- /* 2A * */ LEX_WORD,
- /* 2B + */ LEX_SPECIAL|LEX_SPECIAL_PLUS,
- /* 2C , */ LEX_SPECIAL|LEX_SPECIAL_COMMA,
- /* 2D - */ LEX_SPECIAL|LEX_SPECIAL_MINUS,
- /* 2E . */ LEX_SPECIAL|LEX_SPECIAL_PERIOD,
- /* 2F / */ LEX_DELIMIT|LEX_DELIMIT_SLASH,
-
- /* 30 0 */ LEX_NUMBER|0,
- /* 31 1 */ LEX_NUMBER|1,
- /* 32 2 */ LEX_NUMBER|2,
- /* 33 3 */ LEX_NUMBER|3,
- /* 34 4 */ LEX_NUMBER|4,
- /* 35 5 */ LEX_NUMBER|5,
- /* 36 6 */ LEX_NUMBER|6,
- /* 37 7 */ LEX_NUMBER|7,
- /* 38 8 */ LEX_NUMBER|8,
- /* 39 9 */ LEX_NUMBER|9,
- /* 3A : */ LEX_SPECIAL|LEX_SPECIAL_COLON,
- /* 3B ; */ LEX_DELIMIT|LEX_DELIMIT_SEMICOLON,
- /* 3C < */ LEX_SPECIAL|LEX_SPECIAL_LESSER,
- /* 3D = */ LEX_WORD,
- /* 3E > */ LEX_SPECIAL|LEX_SPECIAL_GREATER,
- /* 3F ? */ LEX_WORD,
-
- /* 40 @ */ LEX_SPECIAL|LEX_SPECIAL_AT,
- /* 41 A */ LEX_WORD|10,
- /* 42 B */ LEX_WORD|11,
- /* 43 C */ LEX_WORD|12,
- /* 44 D */ LEX_WORD|13,
- /* 45 E */ LEX_WORD|14,
- /* 46 F */ LEX_WORD|15,
- /* 47 G */ LEX_WORD,
- /* 48 H */ LEX_WORD,
- /* 49 I */ LEX_WORD,
- /* 4A J */ LEX_WORD,
- /* 4B K */ LEX_WORD,
- /* 4C L */ LEX_WORD,
- /* 4D M */ LEX_WORD,
- /* 4E N */ LEX_WORD,
- /* 4F O */ LEX_WORD,
-
- /* 50 P */ LEX_WORD,
- /* 51 Q */ LEX_WORD,
- /* 52 R */ LEX_WORD,
- /* 53 S */ LEX_WORD,
- /* 54 T */ LEX_WORD,
- /* 55 U */ LEX_WORD,
- /* 56 V */ LEX_WORD,
- /* 57 W */ LEX_WORD,
- /* 58 X */ LEX_WORD,
- /* 59 Y */ LEX_WORD,
- /* 5A Z */ LEX_WORD,
- /* 5B [ */ LEX_DELIMIT|LEX_DELIMIT_LEFT_BRACKET,
- /* 5C \ */ LEX_SPECIAL|LEX_SPECIAL_BACKSLASH,
- /* 5D ] */ LEX_DELIMIT|LEX_DELIMIT_RIGHT_BRACKET,
- /* 5E ^ */ LEX_WORD,
- /* 5F _ */ LEX_WORD,
-
- /* 60 ` */ LEX_WORD,
- /* 61 a */ LEX_WORD|10,
- /* 62 b */ LEX_WORD|11,
- /* 63 c */ LEX_WORD|12,
- /* 64 d */ LEX_WORD|13,
- /* 65 e */ LEX_WORD|14,
- /* 66 f */ LEX_WORD|15,
- /* 67 g */ LEX_WORD,
- /* 68 h */ LEX_WORD,
- /* 69 i */ LEX_WORD,
- /* 6A j */ LEX_WORD,
- /* 6B k */ LEX_WORD,
- /* 6C l */ LEX_WORD,
- /* 6D m */ LEX_WORD,
- /* 6E n */ LEX_WORD,
- /* 6F o */ LEX_WORD,
-
- /* 70 p */ LEX_WORD,
- /* 71 q */ LEX_WORD,
- /* 72 r */ LEX_WORD,
- /* 73 s */ LEX_WORD,
- /* 74 t */ LEX_WORD,
- /* 75 u */ LEX_WORD,
- /* 76 v */ LEX_WORD,
- /* 77 w */ LEX_WORD,
- /* 78 x */ LEX_WORD,
- /* 79 y */ LEX_WORD,
- /* 7A z */ LEX_WORD,
- /* 7B { */ LEX_DELIMIT|LEX_DELIMIT_LEFT_BRACE,
- /* 7C | */ LEX_WORD,
- /* 7D } */ LEX_DELIMIT|LEX_DELIMIT_RIGHT_BRACE,
- /* 7E ~ */ LEX_WORD, //LEX_SPECIAL|LEX_SPECIAL_TILDE,
- /* 7F DEL */ LEX_DEFAULT,
-
- /* Odd Control Chars */
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD, /* 80 */
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
-
- /* Alternate Chars */
-#ifdef USE_UNICODE
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
-#else
- LEX_DEFAULT,LEX_WORD,LEX_WORD,LEX_WORD, /* A0 (a space) */
-#endif
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
-
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
-
- // C0, C1
- LEX_UTFE,LEX_UTFE,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
-
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
-
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
-
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_UTFE,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
- LEX_WORD,LEX_WORD,LEX_WORD,LEX_UTFE
+ /* 00 EOF */ LEX_DELIMIT|LEX_DELIMIT_END,
+ /* 01 */ LEX_DEFAULT,
+ /* 02 */ LEX_DEFAULT,
+ /* 03 */ LEX_DEFAULT,
+ /* 04 */ LEX_DEFAULT,
+ /* 05 */ LEX_DEFAULT,
+ /* 06 */ LEX_DEFAULT,
+ /* 07 */ LEX_DEFAULT,
+ /* 08 BS */ LEX_DEFAULT,
+ /* 09 TAB */ LEX_DEFAULT,
+ /* 0A LF */ LEX_DELIMIT|LEX_DELIMIT_LINEFEED,
+ /* 0B */ LEX_DEFAULT,
+ /* 0C PG */ LEX_DEFAULT,
+ /* 0D CR */ LEX_DELIMIT|LEX_DELIMIT_RETURN,
+ /* 0E */ LEX_DEFAULT,
+ /* 0F */ LEX_DEFAULT,
+
+ /* 10 */ LEX_DEFAULT,
+ /* 11 */ LEX_DEFAULT,
+ /* 12 */ LEX_DEFAULT,
+ /* 13 */ LEX_DEFAULT,
+ /* 14 */ LEX_DEFAULT,
+ /* 15 */ LEX_DEFAULT,
+ /* 16 */ LEX_DEFAULT,
+ /* 17 */ LEX_DEFAULT,
+ /* 18 */ LEX_DEFAULT,
+ /* 19 */ LEX_DEFAULT,
+ /* 1A */ LEX_DEFAULT,
+ /* 1B */ LEX_DEFAULT,
+ /* 1C */ LEX_DEFAULT,
+ /* 1D */ LEX_DEFAULT,
+ /* 1E */ LEX_DEFAULT,
+ /* 1F */ LEX_DEFAULT,
+
+ /* 20 */ LEX_DELIMIT|LEX_DELIMIT_SPACE,
+ /* 21 ! */ LEX_WORD,
+ /* 22 " */ LEX_DELIMIT|LEX_DELIMIT_DOUBLE_QUOTE,
+ /* 23 # */ LEX_SPECIAL|LEX_SPECIAL_POUND,
+ /* 24 $ */ LEX_SPECIAL|LEX_SPECIAL_DOLLAR,
+ /* 25 % */ LEX_SPECIAL|LEX_SPECIAL_PERCENT,
+ /* 26 & */ LEX_WORD,
+ /* 27 ' */ LEX_SPECIAL|LEX_SPECIAL_APOSTROPHE,
+ /* 28 ( */ LEX_DELIMIT|LEX_DELIMIT_LEFT_PAREN,
+ /* 29 ) */ LEX_DELIMIT|LEX_DELIMIT_RIGHT_PAREN,
+ /* 2A * */ LEX_WORD,
+ /* 2B + */ LEX_SPECIAL|LEX_SPECIAL_PLUS,
+ /* 2C , */ LEX_SPECIAL|LEX_SPECIAL_COMMA,
+ /* 2D - */ LEX_SPECIAL|LEX_SPECIAL_MINUS,
+ /* 2E . */ LEX_SPECIAL|LEX_SPECIAL_PERIOD,
+ /* 2F / */ LEX_DELIMIT|LEX_DELIMIT_SLASH,
+
+ /* 30 0 */ LEX_NUMBER|0,
+ /* 31 1 */ LEX_NUMBER|1,
+ /* 32 2 */ LEX_NUMBER|2,
+ /* 33 3 */ LEX_NUMBER|3,
+ /* 34 4 */ LEX_NUMBER|4,
+ /* 35 5 */ LEX_NUMBER|5,
+ /* 36 6 */ LEX_NUMBER|6,
+ /* 37 7 */ LEX_NUMBER|7,
+ /* 38 8 */ LEX_NUMBER|8,
+ /* 39 9 */ LEX_NUMBER|9,
+ /* 3A : */ LEX_SPECIAL|LEX_SPECIAL_COLON,
+ /* 3B ; */ LEX_DELIMIT|LEX_DELIMIT_SEMICOLON,
+ /* 3C < */ LEX_SPECIAL|LEX_SPECIAL_LESSER,
+ /* 3D = */ LEX_WORD,
+ /* 3E > */ LEX_SPECIAL|LEX_SPECIAL_GREATER,
+ /* 3F ? */ LEX_WORD,
+
+ /* 40 @ */ LEX_SPECIAL|LEX_SPECIAL_AT,
+ /* 41 A */ LEX_WORD|10,
+ /* 42 B */ LEX_WORD|11,
+ /* 43 C */ LEX_WORD|12,
+ /* 44 D */ LEX_WORD|13,
+ /* 45 E */ LEX_WORD|14,
+ /* 46 F */ LEX_WORD|15,
+ /* 47 G */ LEX_WORD,
+ /* 48 H */ LEX_WORD,
+ /* 49 I */ LEX_WORD,
+ /* 4A J */ LEX_WORD,
+ /* 4B K */ LEX_WORD,
+ /* 4C L */ LEX_WORD,
+ /* 4D M */ LEX_WORD,
+ /* 4E N */ LEX_WORD,
+ /* 4F O */ LEX_WORD,
+
+ /* 50 P */ LEX_WORD,
+ /* 51 Q */ LEX_WORD,
+ /* 52 R */ LEX_WORD,
+ /* 53 S */ LEX_WORD,
+ /* 54 T */ LEX_WORD,
+ /* 55 U */ LEX_WORD,
+ /* 56 V */ LEX_WORD,
+ /* 57 W */ LEX_WORD,
+ /* 58 X */ LEX_WORD,
+ /* 59 Y */ LEX_WORD,
+ /* 5A Z */ LEX_WORD,
+ /* 5B [ */ LEX_DELIMIT|LEX_DELIMIT_LEFT_BRACKET,
+ /* 5C \ */ LEX_SPECIAL|LEX_SPECIAL_BACKSLASH,
+ /* 5D ] */ LEX_DELIMIT|LEX_DELIMIT_RIGHT_BRACKET,
+ /* 5E ^ */ LEX_WORD,
+ /* 5F _ */ LEX_SPECIAL|LEX_SPECIAL_BLANK,
+
+ /* 60 ` */ LEX_WORD,
+ /* 61 a */ LEX_WORD|10,
+ /* 62 b */ LEX_WORD|11,
+ /* 63 c */ LEX_WORD|12,
+ /* 64 d */ LEX_WORD|13,
+ /* 65 e */ LEX_WORD|14,
+ /* 66 f */ LEX_WORD|15,
+ /* 67 g */ LEX_WORD,
+ /* 68 h */ LEX_WORD,
+ /* 69 i */ LEX_WORD,
+ /* 6A j */ LEX_WORD,
+ /* 6B k */ LEX_WORD,
+ /* 6C l */ LEX_WORD,
+ /* 6D m */ LEX_WORD,
+ /* 6E n */ LEX_WORD,
+ /* 6F o */ LEX_WORD,
+
+ /* 70 p */ LEX_WORD,
+ /* 71 q */ LEX_WORD,
+ /* 72 r */ LEX_WORD,
+ /* 73 s */ LEX_WORD,
+ /* 74 t */ LEX_WORD,
+ /* 75 u */ LEX_WORD,
+ /* 76 v */ LEX_WORD,
+ /* 77 w */ LEX_WORD,
+ /* 78 x */ LEX_WORD,
+ /* 79 y */ LEX_WORD,
+ /* 7A z */ LEX_WORD,
+ /* 7B { */ LEX_DELIMIT|LEX_DELIMIT_LEFT_BRACE,
+ /* 7C | */ LEX_SPECIAL|LEX_SPECIAL_BAR,
+ /* 7D } */ LEX_DELIMIT|LEX_DELIMIT_RIGHT_BRACE,
+ /* 7E ~ */ LEX_WORD, //LEX_SPECIAL|LEX_SPECIAL_TILDE,
+ /* 7F DEL */ LEX_DEFAULT,
+
+ /* Odd Control Chars */
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD, /* 80 */
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+
+ /* Alternate Chars */
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+
+ // C0, C1
+ LEX_UTFE,LEX_UTFE,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_UTFE,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_WORD,
+ LEX_WORD,LEX_WORD,LEX_WORD,LEX_UTFE
};
#ifdef LOWER_CASE_BYTE
-/***********************************************************************
-**
-*/ const REBYTE Upper_Case[256] =
-/*
-** Maps each character to its upper case value. Done this
-** way for speed. Note the odd cases in last block.
-**
-***********************************************************************/
+//
+// Maps each character to its upper case value. Done this
+// way for speed. Note the odd cases in last block.
+//
+const REBYTE Upper_Case[256] =
{
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
- 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47,
- 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63,
-
- 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79,
- 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95,
- 96, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79,
- 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90,123,124,125,126,127,
-
- 128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,
- 144,145,146,147,148,149,150,151,152,153,138,155,156,141,142,159, /* some up/low cases mod 16 (not mod 32) */
- 160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,
- 176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,
-
- 192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,
- 208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,
- 192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,
- 208,209,210,211,212,213,214,247,216,217,218,219,220,221,222,159
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63,
+
+ 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79,
+ 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95,
+ 96, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79,
+ 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90,123,124,125,126,127,
+
+ 128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,
+ // some up/low cases mod 16 (not mod 32)
+ 144,145,146,147,148,149,150,151,152,153,138,155,156,141,142,159,
+ 160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,
+ 176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,
+
+ 192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,
+ 208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,
+ 192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,
+ 208,209,210,211,212,213,214,247,216,217,218,219,220,221,222,159
};
-/***********************************************************************
-**
-*/ const REBYTE Lower_Case[256] =
-/*
-** Maps each character to its lower case value. Done this
-** way for speed. Note the odd cases in last block.
-**
-***********************************************************************/
+//
+// Maps each character to its lower case value. Done this
+// way for speed. Note the odd cases in last block.
+//
+const REBYTE Lower_Case[256] =
{
- 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
- 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
- 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47,
- 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63,
-
- 64, 97, 98, 99,100,101,102,103,104,105,106,107,108,109,110,111,
- 112,113,114,115,116,117,118,119,120,121,122, 91, 92, 93, 94, 95,
- 96, 97, 98, 99,100,101,102,103,104,105,106,107,108,109,110,111,
- 112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,
-
- 128,129,130,131,132,133,134,135,136,137,154,139,140,157,158,143,
- 144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,255, /* some up/low cases mod 16 (not mod 32) */
- 160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,
- 176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,
-
- 224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,
- 240,241,242,243,244,245,246,215,248,249,250,251,252,253,254,223,
- 224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,
- 240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255
+ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63,
+
+ 64, 97, 98, 99,100,101,102,103,104,105,106,107,108,109,110,111,
+ 112,113,114,115,116,117,118,119,120,121,122, 91, 92, 93, 94, 95,
+ 96, 97, 98, 99,100,101,102,103,104,105,106,107,108,109,110,111,
+ 112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,
+
+ 128,129,130,131,132,133,134,135,136,137,154,139,140,157,158,143,
+ // some up/low cases mod 16 (not mod 32)
+ 144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,255,
+ 160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,
+ 176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,
+
+ 224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,
+ 240,241,242,243,244,245,246,215,248,249,250,251,252,253,254,223,
+ 224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,
+ 240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255
};
#endif
-/***********************************************************************
-**
-*/ static REBINT Scan_Char(REBYTE **bp)
-/*
-** Scan a char, handling ^A, ^/, ^(null), ^(1234)
-**
-** Returns the numeric value for char, or -1 for errors.
-**
-** Advances the cp to just past the last position.
-**
-** test: to-integer load to-binary mold to-char 1234
-**
-***********************************************************************/
+//
+// Scan_UTF8_Char_Escapable: C
+//
+// Scan a char, handling ^A, ^/, ^(null), ^(1234)
+//
+// Returns the numeric value for char, or NULL for errors.
+// 0 is a legal codepoint value which may be returned.
+//
+// Advances the cp to just past the last position.
+//
+// test: to-integer load to-binary mold to-char 1234
+//
+static const REBYTE *Scan_UTF8_Char_Escapable(REBUNI *out, const REBYTE *bp)
{
- REBINT n;
- REBYTE *cp;
- REBYTE c;
- REBYTE lex;
+ const REBYTE *cp;
+ REBYTE c;
+ REBYTE lex;
- c = **bp;
+ c = *bp;
- // Handle unicoded char:
- if (c >= 0x80) {
- n = Decode_UTF8_Char(bp, 0); // zero on error
- (*bp)++; // skip char
- return n;
- }
+ // Handle unicoded char:
+ if (c >= 0x80) {
+ if (!(bp = Back_Scan_UTF8_Char(out, bp, NULL))) return NULL;
+ return bp + 1; // Back_Scan advances one less than the full encoding
+ }
- (*bp)++;
+ bp++;
- if (c != '^') return c;
+ if (c != '^') {
+ *out = c;
+ return bp;
+ }
- // Must be ^ escaped char:
- c = **bp;
- (*bp)++;
+ // Must be ^ escaped char:
+ c = *bp;
+ bp++;
switch (c) {
- case 0:
- n = 0;
- break;
+ case 0:
+ *out = 0;
+ break;
- case '/':
- n = LF;
- break;
+ case '/':
+ *out = LF;
+ break;
- case '^':
- n = c;
- break;
+ case '^':
+ *out = c;
+ break;
case '-':
- n = TAB;
- break;
-
- case '!':
- n = '\036'; // record separator
- break;
-
- case '(': // ^(tab) ^(1234)
- // Check for hex integers ^(1234):
- cp = *bp; // restart location
- n = 0;
- while ((lex = Lex_Map[*cp]) > LEX_WORD) {
- c = lex & LEX_VALUE;
- if (!c && lex < LEX_NUMBER) break;
- n = (n << 4) + c;
- cp++;
- }
- if ((cp - *bp) > 4) return -1;
- if (*cp == ')') {
- cp++;
- *bp = cp;
- return n;
- }
-
- // Check for identifiers:
- for (n = 0; n < ESC_MAX; n++) {
- if (NZ(cp = Match_Bytes(*bp, (REBYTE*)(Esc_Names[n])))) {
- if (cp && *cp == ')') {
- *bp = cp + 1;
- return Esc_Codes[n];
- }
- }
- }
- return -1;
+ *out = '\t'; // tab character
+ break;
+
+ case '!':
+ *out = '\036'; // record separator
+ break;
+
+ case '(': // ^(tab) ^(1234)
+ // Check for hex integers ^(1234):
+ cp = bp; // restart location
+ *out = 0;
+ while ((lex = Lex_Map[*cp]) > LEX_WORD) {
+ c = lex & LEX_VALUE;
+ if (!c && lex < LEX_NUMBER) break;
+ *out = (*out << 4) + c;
+ cp++;
+ }
+ if ((cp - bp) > 4) return NULL;
+ if (*cp == ')') {
+ cp++;
+ return cp;
+ }
+
+ // Check for identifiers:
+ for (c = 0; c < ESC_MAX; c++) {
+ if ((cp = Match_Bytes(bp, cb_cast(Esc_Names[c])))) {
+ if (cp && *cp == ')') {
+ bp = cp + 1;
+ *out = Esc_Codes[c];
+ return bp;
+ }
+ }
+ }
+ return NULL;
default:
- n = UP_CASE(c);
- if (n >= '@' && n <= '_') n -= '@';
- else if (n == '~') n = 0x7f; // special for DEL
- else n = c; // includes: ^{ ^} ^"
+ *out = c;
+
+ c = UP_CASE(c);
+ if (c >= '@' && c <= '_') *out = c - '@';
+ else if (c == '~') *out = 0x7f; // special for DEL
+ else {
+ // keep original `c` value before UP_CASE (includes: ^{ ^} ^")
+ }
}
- return n;
+ return bp;
}
-/***********************************************************************
-**
-*/ REBYTE *Scan_Quote(REBYTE *src, SCAN_STATE *scan_state)
-/*
-** Scan a quoted string, handling all the escape characters.
-**
-** The result will be put into the temporary MOLD_BUF unistring.
-**
-***********************************************************************/
-{
- REBINT nest = 0;
- REBUNI term;
- REBINT chr;
- REBCNT lines = 0;
- REBSER *buf = BUF_MOLD;
+//
+// Scan_Quote_Push_Mold: C
+//
+// Scan a quoted string, handling all the escape characters.
+//
+// The result will be put into the temporary unistring mold buffer.
+//
+static const REBYTE *Scan_Quote_Push_Mold(
+ REB_MOLD *mo,
+ const REBYTE *src,
+ SCAN_STATE *ss
+) {
+ assert(ss != NULL);
- RESET_TAIL(buf);
+ Push_Mold(mo);
- term = (*src++ == '{') ? '}' : '"'; // pick termination
+ REBUNI term = (*src == '{') ? '}' : '"'; // pick termination
+ ++src;
- while (*src != term || nest > 0) {
-
- chr = *src;
+ REBINT nest = 0;
+ REBCNT lines = 0;
+ while (*src != term || nest > 0) {
+ REBUNI chr = *src;
switch (chr) {
- case 0:
- return 0; // Scan_state shows error location.
-
- case '^':
- chr = Scan_Char(&src);
- if (chr == -1) return 0;
- src--;
+ case 0:
+ return NULL; // Scan_state shows error location.
+
+ case '^':
+ if ((src = Scan_UTF8_Char_Escapable(&chr, src)) == NULL)
+ return NULL;
+ --src;
break;
- case '{':
- if (term != '"') nest++;
- break;
+ case '{':
+ if (term != '"')
+ ++nest;
+ break;
- case '}':
- if (term != '"' && nest > 0) nest--;
- break;
+ case '}':
+ if (term != '"' && nest > 0)
+ --nest;
+ break;
- case CR:
- if (src[1] == LF) src++;
- // fall thru
+ case CR:
+ if (src[1] == LF) src++;
+ // fall thru
case LF:
- if (term == '"') return 0;
- lines++;
- chr = LF;
- break;
+ if (term == '"')
+ return NULL;
+ lines++;
+ chr = LF;
+ break;
+
+ default:
+ if (chr >= 0x80) {
+ if ((src = Back_Scan_UTF8_Char(&chr, src, NULL)) == NULL)
+ return NULL;
+ }
+ }
- default:
- if (chr >= 0x80) {
- chr = Decode_UTF8_Char(&src, 0); // zero on error
- if (chr == 0) return 0;
- }
- }
+ src++;
- src++;
+ if (SER_LEN(mo->series) + 1 >= SER_REST(mo->series)) // incl term
+ Extend_Series(mo->series, 1);
- *UNI_SKIP(buf, buf->tail) = chr;
+ *UNI_TAIL(mo->series) = chr;
- if (++(buf->tail) >= SERIES_REST(buf)) Extend_Series(buf, 1);
+ SET_SERIES_LEN(mo->series, SER_LEN(mo->series) + 1);
}
- src++; // Skip ending quote or brace.
+ src++; // Skip ending quote or brace.
- if (scan_state) scan_state->line_count += lines;
+ ss->line += lines;
- UNI_TERM(buf);
+ TERM_UNI(mo->series);
- return src;
+ return src;
}
-/***********************************************************************
-**
-*/ REBYTE *Scan_Item(REBYTE *src, REBYTE *end, REBUNI term, REBYTE *invalid)
-/*
-** Scan as UTF8 an item like a file or URL.
-**
-** Returns continuation point or zero for error.
-**
-** Put result into the MOLD_BUF as uni-chars.
-**
-***********************************************************************/
-{
- REBUNI c;
- REBSER *buf;
+//
+// Scan_Item_Push_Mold: C
+//
+// Scan as UTF8 an item like a file or URL.
+//
+// Returns continuation point or zero for error.
+//
+// Put result into the temporary mold buffer as uni-chars.
+//
+const REBYTE *Scan_Item_Push_Mold(
+ REB_MOLD *mo,
+ const REBYTE *src,
+ const REBYTE *end,
+ REBUNI term,
+ const REBYTE *invalid
+) {
+ REBUNI c;
- buf = BUF_MOLD;
- RESET_TAIL(buf);
+ Push_Mold(mo);
- while (src < end && *src != term) {
+ while (src < end && *src != term) {
- c = *src;
+ c = *src;
- // End of stream?
- if (c == 0) break;
+ // End of stream?
+ if (c == 0) break;
- // If no term, then any white will terminate:
- if (!term && IS_WHITE(c)) break;
+ // If no term, then any white will terminate:
+ if (!term && IS_WHITE(c)) break;
- // Ctrl chars are invalid:
- if (c < ' ') return 0; // invalid char
+ // Ctrl chars are invalid:
+ if (c < ' ') return 0; // invalid char
- if (c == '\\') c = '/';
+ if (c == '\\') c = '/';
- // Accept %xx encoded char:
- else if (c == '%') {
- if (!Scan_Hex2(src+1, &c, FALSE)) return 0;
- src += 2;
- }
+ // Accept %xx encoded char:
+ else if (c == '%') {
+ if (!Scan_Hex2(src+1, &c, FALSE)) return 0;
+ src += 2;
+ }
- // Accept ^X encoded char:
- else if (c == '^') {
- if (src+1 == end) return 0; // nothing follows ^
- c = Scan_Char(&src);
- if (!term && IS_WHITE(c)) break;
- src--;
- }
+ // Accept ^X encoded char:
+ else if (c == '^') {
+ if (src+1 == end) return 0; // nothing follows ^
+ if (!(src = Scan_UTF8_Char_Escapable(&c, src))) return NULL;
+ if (!term && IS_WHITE(c)) break;
+ src--;
+ }
+
+ // Accept UTF8 encoded char:
+ else if (c >= 0x80) {
+ if (!(src = Back_Scan_UTF8_Char(&c, src, 0))) return NULL;
+ }
- // Accept UTF8 encoded char:
- else if (c >= 0x80) {
- c = Decode_UTF8_Char(&src, 0); // zero on error
- if (c == 0) return 0;
- }
+ // Is char as literal valid? (e.g. () [] etc.)
+ else if (invalid && strchr(cs_cast(invalid), c)) return 0;
- // Is char as literal valid? (e.g. () [] etc.)
- else if (invalid && strchr(invalid, c)) return 0;
+ src++;
- src++;
+ *UNI_TAIL(mo->series) = c; // not affected by Extend_Series
- *UNI_SKIP(buf, buf->tail) = c; // not affected by Extend_Series
+ SET_SERIES_LEN(mo->series, SER_LEN(mo->series) + 1);
- if (++(buf->tail) >= SERIES_REST(buf)) Extend_Series(buf, 1);
+ if (SER_LEN(mo->series) >= SER_REST(mo->series))
+ Extend_Series(mo->series, 1);
}
- if (*src && *src == term) src++;
+ if (*src && *src == term) src++;
- UNI_TERM(buf);
+ TERM_UNI(mo->series);
- return src;
+ return src;
}
-/***********************************************************************
-**
-*/ static REBYTE *Skip_Tag(REBYTE *cp)
-/*
-** Skip the entire contents of a tag, including quoted strings.
-** The argument points to the opening '<'. Zero is returned on
-** errors.
-**
-***********************************************************************/
+//
+// Skip_Tag: C
+//
+// Skip the entire contents of a tag, including quoted strings.
+// The argument points to the opening '<'. Zero is returned on
+// errors.
+//
+static const REBYTE *Skip_Tag(const REBYTE *cp)
{
- if (*cp == '<') cp++;
- while (*cp && *cp != '>') {
- if (*cp == '"') {
- cp++;
- while (*cp && *cp != '"') cp++;
- if (!*cp) return 0;
- }
- cp++;
- }
- if (*cp) return cp+1;
+ if (*cp == '<') cp++;
+ while (*cp && *cp != '>') {
+ if (*cp == '"') {
+ cp++;
+ while (*cp && *cp != '"') cp++;
+ if (!*cp) return 0;
+ }
+ cp++;
+ }
+ if (*cp) return cp+1;
return 0;
}
-/***********************************************************************
-**
-*/ static void Scan_Error(REBCNT errnum, SCAN_STATE *ss, REBCNT tkn, REBYTE *arg, REBCNT size, REBVAL *relax)
-/*
-** Scanner error handler
-**
-***********************************************************************/
-{
- ERROR_OBJ *error;
- REBSER *errs;
- REBYTE *name;
- REBYTE *cp;
- REBYTE *bp;
- REBSER *ser;
- REBCNT len = 0;
-
- ss->errors++;
-
- if (PG_Boot_Strs)
- name = BOOT_STR(RS_SCAN,tkn);
- else
- name = (REBYTE*)"boot";
-
- cp = ss->head_line;
- while (IS_LEX_SPACE(*cp)) cp++; // skip indentation
- bp = cp;
- while (NOT_NEWLINE(*cp)) cp++, len++;
-
- //DISABLE_GC;
- errs = Make_Error(errnum, 0, 0, 0);
- error = (ERROR_OBJ *)FRM_VALUES(errs);
- ser = Make_Binary(len + 16);
- Append_Bytes(ser, "(line ");
- Append_Int(ser, ss->line_count);
- Append_Bytes(ser, ") ");
- Append_Series(ser, (REBYTE*)bp, len);
- Set_String(&error->nearest, ser);
- Set_String(&error->arg1, Copy_Bytes(name, -1));
- Set_String(&error->arg2, Copy_Bytes(arg, size));
-
- if (relax) {
- SET_ERROR(relax, errnum, errs);
- //ENABLE_GC;
- return;
- }
-
- Throw_Error(errs); // ENABLE_GC implied
+//
+// Update_Error_Near_For_Line: C
+//
+// The NEAR information in an error is typically expressed in terms of loaded
+// Rebol code. Scanner errors have historically used the NEAR not to tell you
+// where the LOAD that is failing is in Rebol, but to form a string of the
+// "best place" to report the textual error.
+//
+// While this is probably a bad overloading of NEAR, it is being made more
+// clear that this is what's happening for the moment.
+//
+static void Update_Error_Near_For_Line(
+ REBCTX *error,
+ REBCNT line,
+ const REBYTE *line_head
+){
+ // Skip indentation (don't include in the NEAR)
+ //
+ const REBYTE *cp = line_head;
+ while (IS_LEX_SPACE(*cp))
+ ++cp;
+
+ // Find end of line to capture in error message
+ //
+ REBCNT len = 0;
+ const REBYTE *bp = cp;
+ while (!ANY_CR_LF_END(*cp)) {
+ cp++;
+ len++;
+ }
+
+ // Put the line count and the line's text into a string.
+ //
+ // !!! This should likely be separated into an integer and a string, so
+ // that those processing the error don't have to parse it back out.
+ //
+ REBSER *ser = Make_Binary(len + 16);
+ Append_Unencoded(ser, "(line ");
+ Append_Int(ser, line);
+ Append_Unencoded(ser, ") ");
+ Append_Series(ser, bp, len);
+
+ ERROR_VARS *vars = ERR_VARS(error);
+ Init_String(&vars->nearest, ser);
+}
+
+
+//
+// Error_Syntax: C
+//
+// Catch-all scanner error handler. Reports the name of the token that gives
+// the complaint, and gives the substring of the token's text. Populates
+// the NEAR field of the error with the "current" line number and line text,
+// e.g. where the end point of the token is seen.
+//
+static REBCTX *Error_Syntax(SCAN_STATE *ss) {
+ DECLARE_LOCAL (token_name);
+ Init_String(token_name, Copy_Bytes(cb_cast(Token_Names[ss->token]), -1));
+
+ // !!! Note: This uses Copy_Bytes, which assumes Latin1 safe characters.
+ // But this could be UTF8.
+ //
+ DECLARE_LOCAL (token_text);
+ Init_String(
+ token_text,
+ Copy_Bytes(ss->begin, cast(REBCNT, ss->end - ss->begin))
+ );
+
+ REBCTX *error = Error(RE_SCAN_INVALID, token_name, token_text, END);
+ Update_Error_Near_For_Line(error, ss->line, ss->line_head);
+ return error;
+}
+
+
+//
+// Error_Missing: C
+//
+// For instance, `load "( abc"`.
+//
+// Note: This error is useful for things like multi-line input, because it
+// indicates a state which could be reconciled by adding more text. A
+// better form of this error would walk the scan state stack and be able to
+// report all the unclosed terms.
+//
+static REBCTX *Error_Missing(SCAN_STATE *ss, char wanted) {
+ REBYTE tmp_buf[2];
+ tmp_buf[0] = wanted;
+ tmp_buf[1] = 0;
+
+ DECLARE_LOCAL (expected);
+ Init_String(expected, Copy_Bytes(tmp_buf, 1));
+
+ REBCTX *error = Error(RE_SCAN_MISSING, expected, END);
+ Update_Error_Near_For_Line(error, ss->start_line, ss->start_line_head);
+ return error;
+}
+
+
+//
+// Error_Extra: C
+//
+// For instance, `load "abc ]"`
+//
+static REBCTX *Error_Extra(SCAN_STATE *ss, char seen) {
+ REBYTE tmp_buf[2]; // Temporary error string
+ tmp_buf[0] = seen;
+ tmp_buf[1] = 0;
+
+ DECLARE_LOCAL (unexpected);
+ Init_String(unexpected, Copy_Bytes(tmp_buf, 1));
+
+ REBCTX *error = Error(RE_SCAN_EXTRA, unexpected, END);
+ Update_Error_Near_For_Line(error, ss->line, ss->line_head);
+ return error;
+}
+
+
+//
+// Error_Mismatch: C
+//
+// For instance, `load "( abc ]"`
+//
+// Note: This answer would be more useful for syntax highlighting or other
+// applications if it would point out the locations of both points. R3-Alpha
+// only pointed out the location of the start token.
+//
+static REBCTX *Error_Mismatch(SCAN_STATE *ss, char wanted, char seen) {
+ REBYTE tmp_buf[2]; // Temporary error string
+ tmp_buf[0] = wanted;
+ tmp_buf[1] = 0;
+
+ DECLARE_LOCAL (expected);
+ Init_String(expected, Copy_Bytes(tmp_buf, 1));
+
+ tmp_buf[0] = seen;
+
+ DECLARE_LOCAL (unexpected);
+ Init_String(unexpected, Copy_Bytes(tmp_buf, 1));
+
+ REBCTX *error = Error(RE_SCAN_MISMATCH, expected, unexpected, END);
+ Update_Error_Near_For_Line(error, ss->start_line, ss->start_line_head);
+ return error;
}
-/***********************************************************************
-**
-*/ static REBCNT Prescan(SCAN_STATE *scan_state)
-/*
-** The general idea of this function is to break up a string
-** into tokens, with sensitivity to common token frequencies.
-** That is, find DELIMITERS, simple WORDS, and simple NUMBERS
-** rapidly. For everything else, find the substring and note
-** the special characters that it contains. All scans start
-** by skipping whitespace and are concluded by a delimiter.
-** A delimiter is returned only when nothing was found before
-** it (i.e. not part of other lexical tokens).
-**
-** Returns a word with bit flags indicating special chars
-** that were found during the scan (other than the first
-** char, which is not part of the flags).
-** Both the beginning and ending positions are updated.
-**
-***********************************************************************/
+//
+// Prescan_Token: C
+//
+// This function updates `ss->begin` to skip past leading
+// whitespace. If the first character it finds after that is a
+// LEX_DELIMITER (`"`, `[`, `)`, `{`, etc. or a space/newline)
+// then it will advance the end position to just past that one
+// character. For all other leading characters, it will advance
+// the end pointer up to the first delimiter class byte (but not
+// include it.)
+//
+// If the first character is not a delimiter, then this routine
+// also gathers a quick "fingerprint" of the special characters
+// that appeared after it, but before a delimiter was found.
+// This comes from unioning LEX_SPECIAL_XXX flags of the bytes
+// that are seen (plus LEX_SPECIAL_WORD if any legal word bytes
+// were found in that range.)
+//
+// So if the input were "$#foobar[@" this would come back with
+// the flags LEX_SPECIAL_POUND and LEX_SPECIAL_WORD set. Since
+// it is the first character, the `$` would not be counted to
+// add LEX_SPECIAL_DOLLAR. And LEX_SPECIAL_AT would not be set
+// even though there is an `@` character, because it occurs
+// after the `[` which is LEX_DELIMITER class.
+//
+// Note: The reason the first character's lexical class is not
+// considered is because it's important to know it exactly, so
+// the caller will use GET_LEX_CLASS(ss->begin[0]).
+// Fingerprinting just helps accelerate further categorization.
+//
+static REBCNT Prescan_Token(SCAN_STATE *ss)
{
- REBYTE *cp = scan_state->begin; /* char scan pointer */
- REBCNT flags = 0; /* lexical flags */
+ const REBYTE *cp = ss->begin;
+ REBCNT flags = 0;
- while (IS_LEX_SPACE(*cp)) cp++; /* skip white space */
- scan_state->begin = cp; /* start of lexical symbol */
+ // Skip whitespace (if any) and update the ss
+ while (IS_LEX_SPACE(*cp)) cp++;
+ ss->begin = cp;
- while (1) {
+ while (TRUE) {
switch (GET_LEX_CLASS(*cp)) {
case LEX_CLASS_DELIMIT:
- if (cp == scan_state->begin) cp++; /* returning delimiter */
- scan_state->end = cp;
+ if (cp == ss->begin) {
+ // Include the delimiter if it is the only character we
+ // are returning in the range (leave it out otherwise)
+ ss->end = cp + 1;
+
+ // Note: We'd liked to have excluded LEX_DELIMIT_END, but
+ // would require a GET_LEX_VALUE() call to know to do so.
+ // Locate_Token_May_Push_Mold() does a `switch` on that,
+ // so it can subtract this addition back out itself.
+ }
+ else
+ ss->end = cp;
return flags;
- case LEX_CLASS_SPECIAL: /* Flag all but first special char: */
- if (cp != scan_state->begin) SET_LEX_FLAG(flags, GET_LEX_VALUE(*cp));
+ case LEX_CLASS_SPECIAL:
+ if (cp != ss->begin) {
+ // As long as it isn't the first character, we union a flag
+ // in the result mask to signal this special char's presence
+ SET_LEX_FLAG(flags, GET_LEX_VALUE(*cp));
+ }
cp++;
break;
case LEX_CLASS_WORD:
- SET_LEX_FLAG(flags, LEX_SPECIAL_WORD); /* flags word char (for nums) */
- while (IS_LEX_AT_LEAST_WORD(*cp)) cp++; /* word or number */
+ // !!! Comment said "flags word char (for nums)"...meaning?
+ SET_LEX_FLAG(flags, LEX_SPECIAL_WORD);
+ while (IS_LEX_WORD_OR_NUMBER(*cp)) cp++;
break;
case LEX_CLASS_NUMBER:
- while (IS_LEX_AT_LEAST_NUMBER(*cp)) cp++;
+ while (IS_LEX_NUMBER(*cp)) cp++;
break;
}
}
}
-/***********************************************************************
-**
-*/ static REBINT Scan_Token(SCAN_STATE *scan_state)
-/*
-** Scan the next lexical object and determine its datatype.
-** Skip all leading whitespace and conclude on a delimiter.
-**
-** Returns the value type (VT) identifying the token.
-** Negative value types indicate an error in that type.
-** Both the beginning and ending positions are updated.
-**
-** Note: this function does not need to find errors in types
-** that are to be scanned and converted. It only needs to
-** recognize that the value should be of that type. For words
-** however, since no further scanning is done, they must be
-** checked for errors here. Same is true for delimiters.
-**
-***********************************************************************/
-{
- REBCNT flags;
- REBYTE *cp;
- REBINT type;
+//
+// Locate_Token_May_Push_Mold: C
+//
+// Find the beginning and end character pointers for the next
+// TOKEN_ in the scanner state. The TOKEN_ type returned will
+// correspond directly to a Rebol datatype if it isn't an
+// ANY-ARRAY! (e.g. TOKEN_INTEGER for INTEGER! or TOKEN_STRING
+// for STRING!). When a block or group delimiter was found it
+// will indicate that (e.g. TOKEN_BLOCK_BEGIN or TOKEN_GROUP_END).
+// Hence the routine will have to be called multiple times during
+// the array's content scan.
+//
+// !!! This should be modified to explain how paths work, once
+// I can understand how paths work. :-/ --HF
+//
+// The scan state will be updated so that `ss->begin` has been moved past any
+// leading whitespace that was pending in the buffer. `ss->end` will hold the
+// conclusion at a delimiter. TOKEN_END is returned if end of input is
+// reached (signaled by a null byte).
+//
+// Newlines that should be internal to a non-ANY-ARRAY! type are
+// included in the scanned range between the `begin` and `end`.
+// But newlines that are found outside of a string are returned
+// as TOKEN_NEWLINE. (These are used to set the OPTS_VALUE_LINE
+// formatting bit on the values.)
+//
+// Determining the end point of token types that need escaping
+// requires processing (for instance `{a^}b}` can't see the first
+// close brace as ending the string). To avoid double processing,
+// the routine decodes the string's content into UNI_BUF for any
+// quoted form to be used by the caller. This is overwritten in
+// successive calls, and is only done for quoted forms (e.g. %"foo"
+// will have data in UNI_BUF but %foo will not.)
+//
+// !!! This is a somewhat weird separation of responsibilities,
+// that seems to arise from a desire to make "Scan_XXX" functions
+// independent of the "Locate_Token_May_Push_Mold" function.
+// But if the work of locating the value means you have to basically
+// do what you'd do to read it into a REBVAL anyway, why split it?
+//
+// Error handling is limited for most types, as an additional
+// phase is needed to load their data into a REBOL value. Yet if
+// a "cheap" error is incidentally found during this routine
+// without extra cost to compute, it can fail here.
+//
+// Examples with ss's (B)egin (E)nd and return value:
+//
+// foo: baz bar => TOKEN_SET
+// B E
+//
+// [quick brown fox] => TOKEN_BLOCK_BEGIN
+// B
+// E
+//
+// "brown fox]" => TOKEN_WORD
+// B E
+//
+// $10AE.20 sent => fail()
+// B E
+//
+// {line1\nline2} => TOKEN_STRING (content in UNI_BUF)
+// B E
+//
+// \n{line2} => TOKEN_NEWLINE (newline is external)
+// BB
+// E
+//
+// %"a ^"b^" c" d => TOKEN_FILE (content in UNI_BUF)
+// B E
+//
+// %a-b.c d => TOKEN_FILE (content *not* in UNI_BUF)
+// B E
+//
+// \0 => TOKEN_END
+// BB
+// EE
+//
+// Note: The reason that the code is able to use byte scanning
+// over UTF-8 encoded source is because all the characters
+// that dictate the tokenization are ASCII (< 128).
+//
+static void Locate_Token_May_Push_Mold(
+ REB_MOLD *mo,
+ SCAN_STATE *ss
+) {
+#if !defined(NDEBUG)
+ ss->token = TOKEN_MAX;
+#endif
+
+ TRASH_POINTER_IF_DEBUG(ss->end); // prescan only uses ->begin
+
+ REBCNT flags = Prescan_Token(ss); // sets ->begin, ->end
- flags = Prescan(scan_state);
- cp = scan_state->begin;
+ const REBYTE *cp = ss->begin;
switch (GET_LEX_CLASS(*cp)) {
case LEX_CLASS_DELIMIT:
switch (GET_LEX_VALUE(*cp)) {
- case LEX_DELIMIT_SPACE: /* white space (pre-processed above) */
+ case LEX_DELIMIT_SPACE:
+ panic ("Prescan_Token did not skip whitespace");
+
case LEX_DELIMIT_SEMICOLON: /* ; begin comment */
- while (NOT_NEWLINE(*cp)) cp++;
- if (!*cp) cp--; /* avoid passing EOF */
- if (*cp == LF) goto line_feed;
+ while (NOT(ANY_CR_LF_END(*cp)))
+ ++cp;
+ if (*cp == '\0')
+ --cp; /* avoid passing EOF */
+ if (*cp == LF) goto line_feed;
/* fall thru */
- case LEX_DELIMIT_RETURN: /* CR */
- if (cp[1] == LF) cp++;
+ case LEX_DELIMIT_RETURN:
+ if (cp[1] == LF)
+ ++cp;
/* fall thru */
- case LEX_DELIMIT_LINEFEED: /* LF */
- line_feed:
- scan_state->line_count++;
- scan_state->end = cp+1;
- return TOKEN_LINE;
+ case LEX_DELIMIT_LINEFEED:
+ line_feed:
+ ss->line++;
+ ss->end = cp + 1;
+ ss->token = TOKEN_NEWLINE;
+ return;
+
+
+ // [BRACKETS]
+
+ case LEX_DELIMIT_LEFT_BRACKET:
+ ss->token = TOKEN_BLOCK_BEGIN;
+ return;
+
+ case LEX_DELIMIT_RIGHT_BRACKET:
+ ss->token = TOKEN_BLOCK_END;
+ return;
- case LEX_DELIMIT_LEFT_BRACKET: /* [ begin block */
- return TOKEN_BLOCK;
+ // (PARENS)
- case LEX_DELIMIT_RIGHT_BRACKET: /* ] end block */
- return TOKEN_BLOCK_END;
+ case LEX_DELIMIT_LEFT_PAREN:
+ ss->token = TOKEN_GROUP_BEGIN;
+ return;
- case LEX_DELIMIT_LEFT_PAREN: /* ( begin paren */
- return TOKEN_PAREN;
+ case LEX_DELIMIT_RIGHT_PAREN:
+ ss->token = TOKEN_GROUP_END;
+ return;
- case LEX_DELIMIT_RIGHT_PAREN: /* ) end paren */
- return TOKEN_PAREN_END;
- case LEX_DELIMIT_QUOTE: /* " quote */
- cp = Scan_Quote(cp, scan_state); // stores result string in BUF_MOLD
+ // "QUOTES" and {BRACES}
+
+ case LEX_DELIMIT_DOUBLE_QUOTE:
+ cp = Scan_Quote_Push_Mold(mo, cp, ss);
goto check_str;
- case LEX_DELIMIT_LEFT_BRACE: /* { begin quote */
- cp = Scan_Quote(cp, scan_state); // stores result string in BUF_MOLD
+ case LEX_DELIMIT_LEFT_BRACE:
+ cp = Scan_Quote_Push_Mold(mo, cp, ss);
check_str:
if (cp) {
- scan_state->end = cp;
- return TOKEN_STRING;
- } else { /* try to recover at next new line... */
- for (cp = (scan_state->begin)+1; NOT_NEWLINE(*cp); cp++);
- scan_state->end = cp;
- return -TOKEN_STRING;
- }
-
- case LEX_DELIMIT_RIGHT_BRACE: /* } end quote !!! handle better (missing) */
- return -TOKEN_STRING;
-
- case LEX_DELIMIT_SLASH: /* probably / or / * */
- while (*cp && *cp == '/') cp++;
- if (IS_LEX_AT_LEAST_WORD(*cp) || *cp=='+' || *cp=='-' || *cp=='.') {
- // ///refine not allowed
- if (scan_state->begin + 1 != cp) {
- scan_state->end = cp;
- return -TOKEN_REFINE;
- }
- scan_state->begin = cp;
- flags = Prescan(scan_state);
- scan_state->begin--;
- type = TOKEN_REFINE;
- // Fast easy case:
- if (ONLY_LEX_FLAG(flags, LEX_SPECIAL_WORD)) return type;
- goto scanword;
- }
- if (cp[0] == '<' || cp[0] == '>') {
- scan_state->end = cp+1;
- return -TOKEN_REFINE;
- }
- scan_state->end = cp;
- return TOKEN_WORD;
-
- case LEX_DELIMIT_END_FILE: /* end of file */
- scan_state->end--;
- return TOKEN_EOF;
+ ss->end = cp;
+ ss->token = TOKEN_STRING;
+ return;
+ }
+ // try to recover at next new line...
+ cp = ss->begin + 1;
+ while (NOT(ANY_CR_LF_END(*cp)))
+ ++cp;
+ ss->end = cp;
+ ss->token = TOKEN_STRING;
+ if (ss->begin[0] == '"')
+ fail (Error_Missing(ss, '"'));
+ if (ss->begin[0] == '{')
+ fail (Error_Missing(ss, '}'));
+ panic ("Invalid string start delimiter");
+
+ case LEX_DELIMIT_RIGHT_BRACE:
+ ss->token = TOKEN_STRING;
+ fail (Error_Extra(ss, '}'));
+
+
+ // /SLASH
+
+ case LEX_DELIMIT_SLASH:
+ while (*cp && *cp == '/')
+ ++cp;
+ if (
+ IS_LEX_WORD_OR_NUMBER(*cp)
+ || *cp == '+'
+ || *cp == '-'
+ || *cp == '.'
+ || *cp == '|'
+ || *cp == '_'
+ ){
+ // ///refine not allowed
+ if (ss->begin + 1 != cp) {
+ ss->end = cp;
+ ss->token = TOKEN_REFINE;
+ fail (Error_Syntax(ss));
+ }
+ ss->begin = cp;
+ flags = Prescan_Token(ss);
+ ss->begin--;
+ ss->token = TOKEN_REFINE;
+ // Fast easy case:
+ if (ONLY_LEX_FLAG(flags, LEX_SPECIAL_WORD))
+ return;
+ goto scanword;
+ }
+ if (cp[0] == '<' || cp[0] == '>') {
+ ss->end = cp + 1;
+ ss->token = TOKEN_REFINE;
+ fail (Error_Syntax(ss));
+ }
+ ss->end = cp;
+ ss->token = TOKEN_WORD;
+ return;
+
+ case LEX_DELIMIT_END:
+ // Prescan_Token() spans the terminator as if it were a byte
+ // to process, so we collapse end to begin to signal no data
+ ss->end--;
+ assert(ss->end == ss->begin);
+ ss->token = TOKEN_END;
+ return;
case LEX_DELIMIT_UTF8_ERROR:
+ ss->token = TOKEN_WORD;
+ fail (Error_Syntax(ss));
+
default:
- return -TOKEN_WORD; /* just in case */
+ panic ("Invalid LEX_DELIMIT class");
}
case LEX_CLASS_SPECIAL:
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_AT) && *cp != '<') return TOKEN_EMAIL;
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_AT) && *cp != '<') {
+ ss->token = TOKEN_EMAIL;
+ return;
+ }
next_ls:
switch (GET_LEX_VALUE(*cp)) {
case LEX_SPECIAL_AT:
- return -TOKEN_EMAIL;
+ ss->token = TOKEN_EMAIL;
+ fail (Error_Syntax(ss));
case LEX_SPECIAL_PERCENT: /* %filename */
- cp = scan_state->end;
+ cp = ss->end;
if (*cp == '"') {
- cp = Scan_Quote(cp, scan_state); // stores result string in BUF_MOLD
- if (!cp) return -TOKEN_FILE;
- scan_state->end = cp;
- return TOKEN_FILE;
+ cp = Scan_Quote_Push_Mold(mo, cp, ss);
+ ss->token = TOKEN_FILE;
+ if (cp == NULL)
+ fail (Error_Syntax(ss));
+ ss->end = cp;
+ ss->token = TOKEN_FILE;
+ return;
}
while (*cp == '/') { /* deal with path delimiter */
cp++;
- while (IS_LEX_AT_LEAST_SPECIAL(*cp)) cp++;
+ while (IS_LEX_NOT_DELIMIT(*cp))
+ ++cp;
}
- scan_state->end = cp;
- return TOKEN_FILE;
+ ss->end = cp;
+ ss->token = TOKEN_FILE;
+ return;
case LEX_SPECIAL_COLON: /* :word :12 (time) */
- if (IS_LEX_NUMBER(cp[1])) return TOKEN_TIME;
- if (ONLY_LEX_FLAG(flags, LEX_SPECIAL_WORD)) return TOKEN_GET; /* common case */
- if (cp[1] == '\'') return -TOKEN_WORD;
- // Various special cases of < << <> >> > >= <=
- if (cp[1] == '<' || cp[1] == '>') {
- cp++;
- if (cp[1] == '<' || cp[1] == '>' || cp[1] == '=') cp++;
- if (!IS_LEX_DELIMIT(cp[1])) return -TOKEN_GET;
- scan_state->end = cp+1;
- return TOKEN_GET;
- }
- type = TOKEN_GET;
- cp++; /* skip ':' */
+ if (IS_LEX_NUMBER(cp[1])) {
+ ss->token = TOKEN_TIME;
+ return;
+ }
+ if (ONLY_LEX_FLAG(flags, LEX_SPECIAL_WORD)) {
+ ss->token = TOKEN_GET;
+ return; // common case
+ }
+ if (cp[1] == '\'') {
+ ss->token = TOKEN_WORD;
+ fail (Error_Syntax(ss));
+ }
+ // Various special cases of < << <> >> > >= <=
+ if (cp[1] == '<' || cp[1] == '>') {
+ cp++;
+ if (cp[1] == '<' || cp[1] == '>' || cp[1] == '=')
+ ++cp;
+ ss->token = TOKEN_GET;
+ if (NOT(IS_LEX_DELIMIT(cp[1])))
+ fail (Error_Syntax(ss));
+ ss->end = cp + 1;
+ return;
+ }
+ ss->token = TOKEN_GET;
+ ++cp; // skip ':'
goto scanword;
- case LEX_SPECIAL_TICK:
- if (IS_LEX_NUMBER(cp[1])) return -TOKEN_LIT; // no '2nd
- if (cp[1] == ':') return -TOKEN_LIT; // no ':X
- if (ONLY_LEX_FLAG(flags, LEX_SPECIAL_WORD)) return TOKEN_LIT; /* common case */
- if (!IS_LEX_WORD(cp[1])) {
- // Various special cases of < << <> >> > >= <=
- if ((cp[1] == '-' || cp[1] == '+') && IS_LEX_NUMBER(cp[2])) return -TOKEN_WORD;
- if (cp[1] == '<' || cp[1] == '>') {
- cp++;
- if (cp[1] == '<' || cp[1] == '>' || cp[1] == '=') cp++;
- if (!IS_LEX_DELIMIT(cp[1])) return -TOKEN_LIT;
- scan_state->end = cp+1;
- return TOKEN_LIT;
- }
- }
- if (cp[1] == '\'') return -TOKEN_WORD;
- type = TOKEN_LIT;
+ case LEX_SPECIAL_APOSTROPHE:
+ if (IS_LEX_NUMBER(cp[1])) { // no '2nd
+ ss->token = TOKEN_LIT;
+ fail (Error_Syntax(ss));
+ }
+ if (cp[1] == ':') { // no ':X
+ ss->token = TOKEN_LIT;
+ fail (Error_Syntax(ss));
+ }
+ if (
+ cp[1] == '|'
+ && (IS_LEX_DELIMIT(cp[2]) || IS_LEX_ANY_SPACE(cp[2]))
+ ){
+ ss->token = TOKEN_LIT_BAR;
+ return; // '| is a LIT-BAR!, '|foo is LIT-WORD!
+ }
+ if (ONLY_LEX_FLAG(flags, LEX_SPECIAL_WORD)) {
+ ss->token = TOKEN_LIT;
+ return; // common case
+ }
+ if (NOT(IS_LEX_WORD(cp[1]))) {
+ // Various special cases of < << <> >> > >= <=
+ if ((cp[1] == '-' || cp[1] == '+') && IS_LEX_NUMBER(cp[2])) {
+ ss->token = TOKEN_WORD;
+ fail (Error_Syntax(ss));
+ }
+ if (cp[1] == '<' || cp[1] == '>') {
+ cp++;
+ if (cp[1] == '<' || cp[1] == '>' || cp[1] == '=')
+ ++cp;
+ ss->token = TOKEN_LIT;
+ if (NOT(IS_LEX_DELIMIT(cp[1])))
+ fail (Error_Syntax(ss));
+ ss->end = cp + 1;
+ return;
+ }
+ }
+ if (cp[1] == '\'') {
+ ss->token = TOKEN_WORD;
+ fail (Error_Syntax(ss));
+ }
+ ss->token = TOKEN_LIT;
goto scanword;
case LEX_SPECIAL_COMMA: /* ,123 */
case LEX_SPECIAL_PERIOD: /* .123 .123.456.789 */
SET_LEX_FLAG(flags, (GET_LEX_VALUE(*cp)));
- if (IS_LEX_NUMBER(cp[1])) goto num;
- if (GET_LEX_VALUE(*cp) != LEX_SPECIAL_PERIOD) return -TOKEN_WORD;
- type = TOKEN_WORD;
- goto scanword;
-
- case LEX_SPECIAL_GREATER:
- if (IS_LEX_DELIMIT(cp[1])) return TOKEN_WORD; // RAMBO 3903
- if (cp[1] == '>') {
- if (IS_LEX_DELIMIT(cp[2])) return TOKEN_WORD;
- return -TOKEN_WORD;
- }
- case LEX_SPECIAL_LESSER:
- if (IS_LEX_ANY_SPACE(cp[1]) || cp[1] == ']' || cp[1] == 0) return TOKEN_WORD; // CES.9121 Was LEX_DELIMIT - changed for
- if ((cp[0] == '<' && cp[1] == '<') || cp[1] == '=' || cp[1] == '>') {
- if (IS_LEX_DELIMIT(cp[2])) return TOKEN_WORD;
- return -TOKEN_WORD;
- }
- if (GET_LEX_VALUE(*cp) == LEX_SPECIAL_GREATER) return -TOKEN_WORD;
- cp = Skip_Tag(cp);
- if (!cp) return -TOKEN_TAG;
- scan_state->end = cp;
- return TOKEN_TAG;
+ if (IS_LEX_NUMBER(cp[1]))
+ goto num;
+ ss->token = TOKEN_WORD;
+ if (GET_LEX_VALUE(*cp) != LEX_SPECIAL_PERIOD)
+ fail (Error_Syntax(ss));
+ ss->token = TOKEN_WORD;
+ goto scanword;
+
+ case LEX_SPECIAL_GREATER:
+ if (IS_LEX_DELIMIT(cp[1])) {
+ ss->token = TOKEN_WORD;
+ return;
+ }
+ if (cp[1] == '>') {
+ ss->token = TOKEN_WORD;
+ if (IS_LEX_DELIMIT(cp[2]))
+ return;
+ fail (Error_Syntax(ss));
+ }
+ // falls through
+ case LEX_SPECIAL_LESSER:
+ if (IS_LEX_ANY_SPACE(cp[1]) || cp[1] == ']' || cp[1] == 0) {
+ ss->token = TOKEN_WORD; // changed for
+ return;
+ }
+ if (
+ (cp[0] == '<' && cp[1] == '<') || cp[1] == '=' || cp[1] == '>'
+ ){
+ ss->token = TOKEN_WORD;
+ if (IS_LEX_DELIMIT(cp[2]))
+ return;
+ fail (Error_Syntax(ss));
+ }
+ if (
+ cp[0] == '<' && (cp[1] == '-' || cp[1] == '|')
+ && (IS_LEX_DELIMIT(cp[2]) || IS_LEX_ANY_SPACE(cp[2]))
+ ){
+ ss->token = TOKEN_WORD;
+ return; // "<|" and "<-"
+ }
+ if (GET_LEX_VALUE(*cp) == LEX_SPECIAL_GREATER) {
+ ss->token = TOKEN_WORD;
+ fail (Error_Syntax(ss));
+ }
+ cp = Skip_Tag(cp);
+ ss->token = TOKEN_TAG;
+ if (cp == NULL)
+ fail (Error_Syntax(ss));
+ ss->end = cp;
+ return;
case LEX_SPECIAL_PLUS: /* +123 +123.45 +$123 */
case LEX_SPECIAL_MINUS: /* -123 -123.45 -$123 */
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_AT)) return TOKEN_EMAIL;
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_DOLLAR)) return TOKEN_MONEY;
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_AT)) {
+ ss->token = TOKEN_EMAIL;
+ return;
+ }
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_DOLLAR)) {
+ ss->token = TOKEN_MONEY;
+ return;
+ }
if (HAS_LEX_FLAG(flags, LEX_SPECIAL_COLON)) {
- cp = Skip_To_Char(cp, scan_state->end, ':');
- if (cp && (cp+1) != scan_state->end) return TOKEN_TIME; /* 12:34 */
- cp = scan_state->begin;
- if (cp[1] == ':') { // +: -:
- type = TOKEN_WORD;
+ cp = Skip_To_Byte(cp, ss->end, ':');
+ if (cp != NULL && (cp + 1) != ss->end) { // 12:34
+ ss->token = TOKEN_TIME;
+ return;
+ }
+ cp = ss->begin;
+ if (cp[1] == ':') { // +: -:
+ ss->token = TOKEN_WORD;
goto scanword;
- }
- }
+ }
+ }
cp++;
- if (IS_LEX_AT_LEAST_NUMBER(*cp)) goto num;
+ if (IS_LEX_NUMBER(*cp))
+ goto num;
if (IS_LEX_SPECIAL(*cp)) {
- if ((GET_LEX_VALUE(*cp)) >= LEX_SPECIAL_PERIOD) goto next_ls;
-/* if (*cp == '#') goto hex; */
+ if ((GET_LEX_VALUE(*cp)) >= LEX_SPECIAL_PERIOD)
+ goto next_ls;
if (*cp == '+' || *cp == '-') {
- type = TOKEN_WORD;
+ ss->token = TOKEN_WORD;
goto scanword;
}
- return -TOKEN_WORD;
+ if (
+ *cp == '>'
+ && (IS_LEX_DELIMIT(cp[1]) || IS_LEX_ANY_SPACE(cp[1]))
+ ) {
+ // Special exemption for ->
+ ss->token = TOKEN_WORD;
+ return;
+ }
+ ss->token = TOKEN_WORD;
+ fail (Error_Syntax(ss));
}
- type = TOKEN_WORD;
+ ss->token = TOKEN_WORD;
+ goto scanword;
+
+ case LEX_SPECIAL_BAR:
+ //
+ // `|` standalone should become a BAR!, so if followed by a
+ // delimiter or space. However `|a|` and `a|b` are left as
+ // legal words (at least for the time being).
+ //
+ if (IS_LEX_DELIMIT(cp[1]) || IS_LEX_ANY_SPACE(cp[1])) {
+ ss->token = TOKEN_BAR;
+ return;
+ }
+ if (
+ cp[1] == '>'
+ && (IS_LEX_DELIMIT(cp[2]) || IS_LEX_ANY_SPACE(cp[2]))
+ ) {
+ ss->token = TOKEN_WORD;
+ return; // for `|>`
+ }
+ ss->token = TOKEN_WORD;
+ goto scanword;
+
+ case LEX_SPECIAL_BLANK:
+ //
+ // `_` standalone should become a BLANK!, so if followed by a
+ // delimiter or space. However `_a_` and `a_b` are left as
+ // legal words (at least for the time being).
+ //
+ if (IS_LEX_DELIMIT(cp[1]) || IS_LEX_ANY_SPACE(cp[1])) {
+ ss->token = TOKEN_BLANK;
+ return;
+ }
+ ss->token = TOKEN_WORD;
goto scanword;
case LEX_SPECIAL_POUND:
pound:
cp++;
-/* hex:
- if (HAS_LEX_FLAGS(flags, ~(LEX_FLAG(LEX_SPECIAL_POUND) | LEX_FLAG(LEX_SPECIAL_PERIOD)
- | LEX_FLAG(LEX_SPECIAL_TICK) | LEX_FLAG(LEX_SPECIAL_WORD)))) return -TOKEN_INTEGER;
-*/
-/* if (HAS_LEX_FLAG(flags, LEX_SPECIAL_PERIOD)) return TOKEN_BYTES; */
- if (*cp == '[') {
- scan_state->end = ++cp;
- return TOKEN_CONSTRUCT;
- }
- if (*cp == '"') { /* CHAR #"C" */
- cp++;
- type = Scan_Char(&cp);
- if (type >= 0 && *cp == '"') {
- scan_state->end = cp+1;
- return TOKEN_CHAR;
- } else { /* try to recover at next new line... */
- for (cp = (scan_state->begin)+1; NOT_NEWLINE(*cp); cp++);
- scan_state->end = cp;
- return -TOKEN_CHAR;
- }
- }
- if (*cp == '{') { /* BINARY #{12343132023902902302938290382} */
- scan_state->end = scan_state->begin; /* save start */
- scan_state->begin = cp;
- cp = Scan_Quote(cp, scan_state); // stores result string in BUF_MOLD !!??
- scan_state->begin = scan_state->end; /* restore start */
- if (cp) {
- scan_state->end = cp;
- return TOKEN_BINARY;
- } else { /* try to recover at next new line... */
- for (cp = (scan_state->begin)+1; NOT_NEWLINE(*cp); cp++);
- scan_state->end = cp;
- return -TOKEN_BINARY;
- }
- }
- if (cp-1 == scan_state->begin) return TOKEN_ISSUE;
- else return -TOKEN_INTEGER;
+ if (*cp == '[') {
+ ss->end = ++cp;
+ ss->token = TOKEN_CONSTRUCT;
+ return;
+ }
+ if (*cp == '"') { /* CHAR #"C" */
+ REBUNI dummy;
+ cp++;
+ cp = Scan_UTF8_Char_Escapable(&dummy, cp);
+ if (cp && *cp == '"') {
+ ss->end = cp + 1;
+ ss->token = TOKEN_CHAR;
+ return;
+ }
+ // try to recover at next new line...
+ cp = ss->begin + 1;
+ while (NOT(ANY_CR_LF_END(*cp)))
+ ++cp;
+ ss->end = cp;
+ ss->token = TOKEN_CHAR;
+ fail (Error_Syntax(ss));
+ }
+ if (*cp == '{') { /* BINARY #{12343132023902902302938290382} */
+ ss->end = ss->begin; /* save start */
+ ss->begin = cp;
+ cp = Scan_Quote_Push_Mold(mo, cp, ss);
+ ss->begin = ss->end; /* restore start */
+ if (cp) {
+ ss->end = cp;
+ ss->token = TOKEN_BINARY;
+ return;
+ }
+ // try to recover at next new line...
+ cp = ss->begin + 1;
+ while (NOT(ANY_CR_LF_END(*cp)))
+ ++cp;
+ ss->end = cp;
+ ss->token = TOKEN_BINARY;
+ fail (Error_Syntax(ss));
+ }
+ if (cp - 1 == ss->begin) {
+ ss->token = TOKEN_ISSUE;
+ return;
+ }
+
+ ss->token = TOKEN_INTEGER;
+ fail (Error_Syntax(ss));
case LEX_SPECIAL_DOLLAR:
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_AT)) return TOKEN_EMAIL;
- return TOKEN_MONEY;
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_AT)) {
+ ss->token = TOKEN_EMAIL;
+ return;
+ }
+ ss->token = TOKEN_MONEY;
+ return;
default:
- return -TOKEN_WORD;
+ ss->token = TOKEN_WORD;
+ fail (Error_Syntax(ss));
}
case LEX_CLASS_WORD:
- if (ONLY_LEX_FLAG(flags, LEX_SPECIAL_WORD)) return TOKEN_WORD;
- type = TOKEN_WORD;
+ ss->token = TOKEN_WORD;
+ if (ONLY_LEX_FLAG(flags, LEX_SPECIAL_WORD))
+ return;
goto scanword;
case LEX_CLASS_NUMBER: /* order of tests is important */
num:
- if (!flags) return TOKEN_INTEGER; /* simple integer */
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_AT)) return TOKEN_EMAIL;
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_POUND)) {
- if (cp == scan_state->begin) { // no +2 +16 +64 allowed
- if (
- (cp[0] == '6' && cp[1] == '4' && cp[2] == '#' && cp[3] == '{')
- || (cp[0] == '1' && cp[1] == '6' && cp[2] == '#' && cp[3] == '{') // rare
- ) {cp += 2; goto pound;}
- if (cp[0] == '2' && cp[1] == '#' && cp[2] == '{')
- {cp++; goto pound;} // very rare
- }
- return -TOKEN_INTEGER;
- }
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_COLON)) return TOKEN_TIME; /* 12:34 */
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_PERIOD)) { /* 1.2 1.2.3 1,200.3 1.200,3 1.E-2 */
- if (Skip_To_Char(cp, scan_state->end, 'x')) return TOKEN_PAIR;
- cp = Skip_To_Char(cp, scan_state->end, '.');
- if (!(HAS_LEX_FLAG(flags, LEX_SPECIAL_COMMA)) && /* no comma in bytes */
- Skip_To_Char(cp+1, scan_state->end, '.')) return TOKEN_TUPLE;
- return TOKEN_DECIMAL;
- }
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_COMMA)) {
- if (Skip_To_Char(cp, scan_state->end, 'x')) return TOKEN_PAIR;
- return TOKEN_DECIMAL; /* 1,23 */
- }
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_POUND)) { /* -#123 2#1010 */
- if (HAS_LEX_FLAGS(flags, ~(LEX_FLAG(LEX_SPECIAL_POUND) | LEX_FLAG(LEX_SPECIAL_PERIOD) | LEX_FLAG(LEX_SPECIAL_TICK)))) return -TOKEN_INTEGER;
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_PERIOD)) return TOKEN_TUPLE;
- return TOKEN_INTEGER;
- }
- /* Note: cannot detect dates of the form 1/2/1998 because they
- ** may appear within a path, where they are not actually dates!
- ** Special parsing is required at the next level up. */
- for (;cp != scan_state->end; cp++) { /* what do we hit first? 1-AUG-97 or 123E-4 */
- if (*cp == '-') return TOKEN_DATE; /* 1-2-97 1-jan-97 */
- if (*cp == 'x' || *cp == 'X') return TOKEN_PAIR; // 320x200
- if (*cp == 'E' || *cp == 'e') {
- if (Skip_To_Char(cp, scan_state->end, 'x')) return TOKEN_PAIR;
- return TOKEN_DECIMAL; /* 123E4 */
- }
- if (*cp == '%') return TOKEN_PERCENT;
- }
- /*cp = scan_state->begin;*/
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_TICK)) return TOKEN_INTEGER; /* 1'200 */
- return -TOKEN_INTEGER;
+ if (flags == 0) { // simple integer
+ ss->token = TOKEN_INTEGER;
+ return;
+ }
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_AT)) {
+ ss->token = TOKEN_EMAIL;
+ return;
+ }
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_POUND)) {
+ if (cp == ss->begin) { // no +2 +16 +64 allowed
+ if (
+ (
+ cp[0] == '6'
+ && cp[1] == '4'
+ && cp[2] == '#'
+ && cp[3] == '{'
+ ) || (
+ cp[0] == '1'
+ && cp[1] == '6'
+ && cp[2] == '#'
+ && cp[3] == '{'
+ ) // rare
+ ) {
+ cp += 2;
+ goto pound;
+ }
+ if (cp[0] == '2' && cp[1] == '#' && cp[2] == '{') {
+ // very rare
+ cp++;
+ goto pound;
+ }
+ }
+ ss->token = TOKEN_INTEGER;
+ fail (Error_Syntax(ss));
+ }
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_COLON)) { // 12:34
+ ss->token = TOKEN_TIME;
+ return;
+ }
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_PERIOD)) {
+ // 1.2 1.2.3 1,200.3 1.200,3 1.E-2
+ if (Skip_To_Byte(cp, ss->end, 'x')) {
+ ss->token = TOKEN_TIME;
+ return;
+ }
+ cp = Skip_To_Byte(cp, ss->end, '.');
+ // Note: no comma in bytes
+ if (
+ NOT(HAS_LEX_FLAG(flags, LEX_SPECIAL_COMMA))
+ && Skip_To_Byte(cp + 1, ss->end, '.')
+ ){
+ ss->token = TOKEN_TUPLE;
+ return;
+ }
+ ss->token = TOKEN_DECIMAL;
+ return;
+ }
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_COMMA)) {
+ if (Skip_To_Byte(cp, ss->end, 'x')) {
+ ss->token = TOKEN_PAIR;
+ return;
+ }
+ ss->token = TOKEN_DECIMAL; // 1,23
+ return;
+ }
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_POUND)) { // -#123 2#1010
+ if (
+ HAS_LEX_FLAGS(
+ flags,
+ ~(
+ LEX_FLAG(LEX_SPECIAL_POUND)
+ | LEX_FLAG(LEX_SPECIAL_PERIOD)
+ | LEX_FLAG(LEX_SPECIAL_APOSTROPHE)
+ )
+ )
+ ){
+ ss->token = TOKEN_INTEGER;
+ fail (Error_Syntax(ss));
+ }
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_PERIOD)) {
+ ss->token = TOKEN_TUPLE;
+ return;
+ }
+ ss->token = TOKEN_INTEGER;
+ return;
+ }
+ /* Note: cannot detect dates of the form 1/2/1998 because they
+ ** may appear within a path, where they are not actually dates!
+ ** Special parsing is required at the next level up. */
+ for (;cp != ss->end; cp++) {
+ // what do we hit first? 1-AUG-97 or 123E-4
+ if (*cp == '-') {
+ ss->token = TOKEN_DATE;
+ return; // 1-2-97 1-jan-97
+ }
+ if (*cp == 'x' || *cp == 'X') {
+ ss->token = TOKEN_PAIR;
+ return; // 320x200
+ }
+ if (*cp == 'E' || *cp == 'e') {
+ if (Skip_To_Byte(cp, ss->end, 'x')) {
+ ss->token = TOKEN_PAIR;
+ return;
+ }
+ ss->token = TOKEN_DECIMAL; // 123E4
+ return;
+ }
+ if (*cp == '%') {
+ ss->token = TOKEN_PERCENT;
+ return;
+ }
+ }
+ ss->token = TOKEN_INTEGER;
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_APOSTROPHE)) // 1'200
+ return;
+ fail (Error_Syntax(ss));
default:
- return -TOKEN_WORD;
+ panic ("Invalid LEX class");
}
-#if ndef // unreachable code
- /* avoid '123 :123 from scanning as a word.... */
- if (IS_LEX_WORD(cp[1]) && !HAS_LEX_FLAGS(flags, LEX_WORD_FLAGS))
- return TOKEN_LIT;
- return -TOKEN_WORD;
-#endif
+ DEAD_END;
scanword:
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_COLON)) { /* word: url:words */
- if (type != TOKEN_WORD) return type; //-TOKEN_WORD; /* only valid with WORD (not set or lit) */
- cp = Skip_To_Char(cp, scan_state->end, ':'); /* always returns a pointer (always a ':') */
- if (cp[1] != '/' && Lex_Map[(REBYTE)cp[1]] < LEX_SPECIAL) { /* a valid delimited word SET? */
- if (HAS_LEX_FLAGS(flags, ~LEX_FLAG(LEX_SPECIAL_COLON) & LEX_WORD_FLAGS)) return -TOKEN_WORD;
- return TOKEN_SET;
+#if !defined(NDEBUG)
+ assert(ss->token != TOKEN_MAX);
+#endif
+
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_COLON)) { // word: url:words
+ if (ss->token != TOKEN_WORD) {
+ // only valid with WORD (not set or lit)
+ return;
+ }
+ // This Skip_To_Byte always returns a pointer (always a ':')
+ cp = Skip_To_Byte(cp, ss->end, ':');
+ if (cp[1] != '/' && Lex_Map[cp[1]] < LEX_SPECIAL) {
+ // a valid delimited word SET?
+ if (
+ HAS_LEX_FLAGS(
+ flags, ~LEX_FLAG(LEX_SPECIAL_COLON) & LEX_WORD_FLAGS
+ )
+ ){
+ ss->token = TOKEN_WORD;
+ fail (Error_Syntax(ss));
+ }
+ ss->token = TOKEN_SET;
+ return;
}
- cp = scan_state->end; /* then, must be a URL */
+ cp = ss->end; /* then, must be a URL */
while (*cp == '/') { /* deal with path delimiter */
cp++;
- while (IS_LEX_AT_LEAST_SPECIAL(*cp) || *cp == '/') cp++;
+ while (IS_LEX_NOT_DELIMIT(*cp) || *cp == '/')
+ ++cp;
}
- scan_state->end = cp;
- return TOKEN_URL;
+ ss->end = cp;
+ ss->token = TOKEN_URL;
+ return;
+ }
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_AT)) {
+ ss->token = TOKEN_EMAIL;
+ return;
+ }
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_DOLLAR)) {
+ ss->token = TOKEN_MONEY;
+ return;
}
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_AT)) return TOKEN_EMAIL;
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_DOLLAR)) return TOKEN_MONEY;
- if (HAS_LEX_FLAGS(flags, LEX_WORD_FLAGS)) return -type; /* has chars not allowed in word (eg % \ ) */
- if (HAS_LEX_FLAG(flags, LEX_SPECIAL_LESSER)) {
- // Allow word and word but not word< word<= word<> etc.
- cp = Skip_To_Char(cp, scan_state->end, '<');
- if (cp[1] == '<' || cp[1] == '>' || cp[1] == '=' ||
- IS_LEX_SPACE(cp[1]) || (cp[1] != '/' && IS_LEX_DELIMIT(cp[1])))
- return -type;
- /*bogus: if (HAS_LEX_FLAG(flags, LEX_SPECIAL_GREATER) &&
- Skip_To_Char(scan_state->begin, cp, '>')) return -TOKEN_WORD; */
- scan_state->end = cp;
- } else if (HAS_LEX_FLAG(flags, LEX_SPECIAL_GREATER)) return -type;
- return type;
+ if (HAS_LEX_FLAGS(flags, LEX_WORD_FLAGS)) {
+ // has chars not allowed in word (eg % \ )
+ fail (Error_Syntax(ss));
+ }
+ if (HAS_LEX_FLAG(flags, LEX_SPECIAL_LESSER)) {
+ // Allow word and word but not word< word<= word<> etc.
+ cp = Skip_To_Byte(cp, ss->end, '<');
+ if (
+ cp[1] == '<' || cp[1] == '>' || cp[1] == '='
+ || IS_LEX_SPACE(cp[1])
+ || (cp[1] != '/' && IS_LEX_DELIMIT(cp[1]))
+ ){
+ fail (Error_Syntax(ss));
+ }
+ ss->end = cp;
+ }
+ else if (HAS_LEX_FLAG(flags, LEX_SPECIAL_GREATER))
+ fail (Error_Syntax(ss));
+
+ return;
}
-/***********************************************************************
-**
-*/ static void Init_Scan_State(SCAN_STATE *scan_state, REBYTE *cp, REBCNT limit)
-/*
-** Initialize a scanner state structure. Set the standard
-** scan pointers and the limit pointer.
-**
-***********************************************************************/
-{
- scan_state->head_line = scan_state->begin = scan_state->end = cp;
- scan_state->limit = cp + limit;
- scan_state->line_count = 1;
- scan_state->opts = 0;
- scan_state->errors = 0;
-// scan_state->error_id = (REBYTE *)"";
+//
+// Init_Scan_State: C
+//
+// Initialize a scanner state structure. Set the standard
+// scan pointers and the limit pointer.
+//
+static void Init_Scan_State(
+ SCAN_STATE *ss,
+ const REBYTE *utf8,
+ REBCNT limit,
+ REBSTR *filename,
+ REBUPT line
+) {
+ ss->start_line_head = ss->line_head = ss->begin = utf8;
+ TRASH_POINTER_IF_DEBUG(ss->end);
+ ss->limit = utf8 + limit;
+ ss->start_line = ss->line = line;
+ ss->filename = filename;
+ ss->opts = 0;
+
+#if !defined(NDEBUG)
+ ss->token = TOKEN_MAX;
+#endif
}
-/***********************************************************************
-**
-*/ static REBINT Scan_Head(SCAN_STATE *scan_state)
-/*
-** Search text for a REBOL header. It is distinguished as
-** the word REBOL followed by a '[' (they can be separated
-** only by lines and comments). There can be nothing on the
-** line before the header. Also, if a '[' preceedes the
-** header, then note its position (for embedded code).
-** The scan_state begin pointer is updated to point to the header block.
-** Keep track of line-count.
-**
-** Returns:
-** 0 if no header,
-** 1 if header,
-** -1 if embedded header (inside []).
-**
-** The scan_state structure is updated to point to the
-** beginning of the source text.
-**
-***********************************************************************/
+//
+// Scan_Head: C
+//
+// Search text for a REBOL header. It is distinguished as
+// the word REBOL followed by a '[' (they can be separated
+// only by lines and comments). There can be nothing on the
+// line before the header. Also, if a '[' preceedes the
+// header, then note its position (for embedded code).
+// The ss begin pointer is updated to point to the header block.
+// Keep track of line-count.
+//
+// Returns:
+// 0 if no header,
+// 1 if header,
+// -1 if embedded header (inside []).
+//
+// The ss structure is updated to point to the
+// beginning of the source text.
+//
+static REBINT Scan_Head(SCAN_STATE *ss)
{
- REBYTE *rp = 0; /* pts to the REBOL word */
- REBYTE *bp = 0; /* pts to optional [ just before REBOL */
- REBYTE *cp = scan_state->begin;
- REBCNT count = scan_state->line_count;
+ const REBYTE *rp = 0; /* pts to the REBOL word */
+ const REBYTE *bp = 0; /* pts to optional [ just before REBOL */
+ const REBYTE *cp = ss->begin;
+ REBCNT count = ss->line;
- while (TRUE) {
+ while (TRUE) {
while (IS_LEX_SPACE(*cp)) cp++; /* skip white space */
- switch (*cp) {
- case '[':
+ switch (*cp) {
+ case '[':
if (rp) {
- scan_state->begin = ++cp; //(bp ? bp : cp);
- scan_state->line_count = count;
+ ss->begin = ++cp; //(bp ? bp : cp);
+ ss->line = count;
return (bp ? -1 : 1);
}
- bp = cp++;
- break;
+ bp = cp++;
+ break;
case 'R':
- case 'r':
- if (Match_Bytes(cp, (REBYTE *)&Str_REBOL[0])) {
- rp = cp;
+ case 'r':
+ if (Match_Bytes(cp, cb_cast(Str_REBOL))) {
+ rp = cp;
cp += 5;
- break;
+ break;
}
cp++;
- bp = 0; /* prior '[' was a red herring */
- /* fall thru... */
+ bp = 0; /* prior '[' was a red herring */
+ /* fall thru... */
case ';':
goto skipline;
case 0:
- return 0;
- default: /* everything else... */
- if NOT_NEWLINE(*cp) rp = bp = 0;
- skipline:
- while NOT_NEWLINE(*cp) cp++;
- if (*cp == CR && cp[1] == LF) cp++;
- if (*cp) cp++;
- count++;
+ return 0;
+ default: /* everything else... */
+ if (!ANY_CR_LF_END(*cp)) rp = bp = 0;
+ skipline:
+ while (!ANY_CR_LF_END(*cp)) cp++;
+ if (*cp == CR && cp[1] == LF) cp++;
+ if (*cp) cp++;
+ count++;
break;
- }
- }
+ }
+ }
}
-#ifdef not_used
-//!!!
-/***********************************************************************
-**
- REBOOL Construct_Simple(REBVAL *value, REBSER *spec)
-/*
-** Handle special #[type] constructs. These are used to
-** boot REBOL, so must not require binding.
-**
-***********************************************************************/
-{
- REBVAL *blk = BLK_HEAD(spec);
- if (!IS_WORD(blk)) return FALSE;
- switch (VAL_WORD_SYM(blk)-1) {
- case SYM_NONE:
- SET_NONE(value);
- break;
- case SYM_FALSE:
- SET_LOGIC(value, FALSE);
- break;
- case SYM_TRUE:
- SET_LOGIC(value, TRUE);
- break;
- default:
- return FALSE;
- }
- return TRUE;
-}
-#endif
-extern REBSER *Scan_Full_Block(SCAN_STATE *scan_state, REBYTE mode_char);
+static REBARR *Scan_Full_Array(SCAN_STATE *ss, REBYTE mode_char);
+static REBARR *Scan_Child_Array(SCAN_STATE *ss, REBYTE mode_char);
+
+//
+// Scan_Array: C
+//
+// Scans an array of values, based on a mode_char. This character can be
+// '[', '(', or '/' to indicate the processing type. Always returns array.
+//
+// If the source bytes are "1" then it will be the array [1]
+// If the source bytes are "[1]" then it will be the array [[1]]
+//
+// Variations like GET-PATH!, SET-PATH! or LIT-PATH! are not discerned in
+// the result here. Instead, ordinary path scanning is done, followed by a
+// transformation (e.g. if the first element was a GET-WORD!, change it to
+// an ordinary WORD! and make it a GET-PATH!) The caller does this.
+//
+static REBARR *Scan_Array(
+ SCAN_STATE *ss,
+ REBYTE mode_char
+) {
+ const REBDSP dsp_orig = DSP;
+
+ // just_once for load/next see Load_Script for more info.
+ const REBOOL just_once = GET_FLAG(ss->opts, SCAN_NEXT);
+
+ struct Reb_State state;
+ REBCTX *error;
+
+ if (C_STACK_OVERFLOWING(&state))
+ Trap_Stack_Overflow();
+
+ if (GET_FLAG(ss->opts, SCAN_RELAX)) {
+ PUSH_TRAP(&error, &state);
+ if (error != NULL) {
+ ss->begin = ss->end; // skip malformed token
+
+ DS_PUSH_TRASH;
+ Init_Error(DS_TOP, error);
+
+ goto array_done_relax;
+ }
+ }
-/***********************************************************************
-**
-*/ static REBSER *Scan_Block(SCAN_STATE *scan_state, REBYTE mode_char)
-/*
-** Scan a block (or paren) and return it.
-** Sub scanners may return bad by setting value type to zero.
-**
-***********************************************************************/
-{
- REBINT token;
- REBCNT len;
- REBYTE *bp;
- REBYTE *ep;
- REBVAL *value = 0;
- REBSER *emitbuf = BUF_EMIT;
- REBSER *block;
- REBCNT begin = emitbuf->tail; // starting point in block buffer
- REBOOL line = FALSE;
-#ifdef COMP_LINES
- REBINT linenum;
-#endif
- REBCNT start = scan_state->line_count;
- REBYTE *start_line = scan_state->head_line;
- // just_once for load/next see Load_Script for more info.
- REBOOL just_once = GET_FLAG(scan_state->opts, SCAN_NEXT);
+ REBOOL line; // goto would cross init, moving up gets clobber warning
+ line = FALSE;
- CHECK_STACK(&token);
-
- if (just_once)
- CLR_FLAG(scan_state->opts, SCAN_NEXT); // no deeper
+ REB_MOLD mo;
+ CLEARS(&mo);
- //scan_state->error_id = (REBYTE *) "";
+ if (just_once)
+ CLR_FLAG(ss->opts, SCAN_NEXT); // no deeper
while (
-#ifdef COMP_LINES
- linenum=scan_state->line_count,
-#endif
- ((token = Scan_Token(scan_state)) != TOKEN_EOF)
- ) {
-
- bp = scan_state->begin;
- ep = scan_state->end;
- len = (REBCNT)(ep - bp);
-
- if (token < 0) { // Check for error tokens
- token = -token;
- ACCEPT_TOKEN(scan_state);
- goto syntax_error;
- }
-
- // Is output block buffer large enough?
- if (token >= TOKEN_WORD && SERIES_FULL(emitbuf))
- Extend_Series(emitbuf, 1024);
-
- value = BLK_TAIL(emitbuf);
- SET_END(value);
- // Line opt was set here. Moved to end in 3.0.
+ Drop_Mold_If_Pushed(&mo),
+ Locate_Token_May_Push_Mold(&mo, ss),
+ (ss->token != TOKEN_END)
+ ){
+ const REBYTE *bp = ss->begin;
+ const REBYTE *ep = ss->end;
+ REBCNT len = cast(REBCNT, ep - bp);
// If in a path, handle start of path /word or word//word cases:
if (mode_char == '/' && *bp == '/') {
- SET_NONE(value);
- emitbuf->tail++;
- scan_state->begin = bp + 1;
- continue;
+ DS_PUSH_TRASH;
+ Init_Blank(DS_TOP);
+ ss->begin = bp + 1;
+ continue;
}
// Check for new path: /word or word/word:
- if ((token == TOKEN_PATH || ((token == TOKEN_WORD || token == TOKEN_LIT ||
- token == TOKEN_GET) && *ep == '/'))
- && mode_char != '/') {
- //line = VAL_GET_LINE(value);
- block = Scan_Block(scan_state, '/'); // (could realloc emitbuf)
- value = BLK_TAIL(emitbuf);
- VAL_SERIES(value) = block;
- if (token == TOKEN_LIT) {
- token = REB_LIT_PATH;
- VAL_SET(BLK_HEAD(block), REB_WORD); // NO_FRAME
- }
- else if (IS_GET_WORD(BLK_HEAD(block))) {
- if (*scan_state->end == ':') goto syntax_error;
- token = REB_GET_PATH;
- VAL_SET(BLK_HEAD(block), REB_WORD); // NO_FRAME
- }
- else {
- if (*scan_state->end == ':') {
- token = REB_SET_PATH;
- scan_state->begin = ++(scan_state->end);
- } else token = REB_PATH;
- }
-// if (IS_SET_WORD(BLK_SKIP(block, block->tail - 1)
- VAL_SET(value, token);
- VAL_INDEX(value) = 0;
- //if (line) line = FALSE, VAL_SET_LINE(value);
- token = TOKEN_PATH;
- } else {
- ACCEPT_TOKEN(scan_state);
+ if (
+ (
+ ss->token == TOKEN_PATH
+ || (
+ (
+ ss->token == TOKEN_WORD
+ || ss->token == TOKEN_LIT
+ || ss->token == TOKEN_GET
+ )
+ && *ep == '/'
+ )
+ )
+ && mode_char != '/'
+ ) {
+ REBARR *array = Scan_Child_Array(ss, '/');
+
+ DS_PUSH_TRASH;
+
+ if (ss->token == TOKEN_LIT) {
+ VAL_RESET_HEADER(DS_TOP, REB_LIT_PATH);
+ VAL_RESET_HEADER(ARR_HEAD(array), REB_WORD);
+ assert(IS_WORD_UNBOUND(ARR_HEAD(array)));
+ }
+ else if (IS_GET_WORD(ARR_HEAD(array))) {
+ if (*ss->end == ':')
+ fail (Error_Syntax(ss));
+ VAL_RESET_HEADER(DS_TOP, REB_GET_PATH);
+ VAL_RESET_HEADER(ARR_HEAD(array), REB_WORD);
+ assert(IS_WORD_UNBOUND(ARR_HEAD(array)));
+ }
+ else {
+ if (*ss->end == ':') {
+ VAL_RESET_HEADER(DS_TOP, REB_SET_PATH);
+ ss->begin = ++ss->end;
+ }
+ else
+ VAL_RESET_HEADER(DS_TOP, REB_PATH);
+ }
+ INIT_VAL_ARRAY(DS_TOP, array); // copies args
+ VAL_INDEX(DS_TOP) = 0;
+ ss->token = TOKEN_PATH;
}
+ else
+ ss->begin = ss->end; // accept token
+
+ // Process each lexical token appropriately:
+ switch (ss->token) {
+
+ case TOKEN_NEWLINE:
+ line = TRUE;
+ ss->line_head = ep;
+ continue;
+
+ case TOKEN_BAR:
+ DS_PUSH_TRASH;
+ Init_Bar(DS_TOP);
+ ++bp;
+ break;
+
+ case TOKEN_LIT_BAR:
+ DS_PUSH_TRASH;
+ Init_Lit_Bar(DS_TOP);
+ ++bp;
+ break;
+
+ case TOKEN_BLANK:
+ DS_PUSH_TRASH;
+ Init_Blank(DS_TOP);
+ ++bp;
+ break;
+
+ case TOKEN_LIT:
+ case TOKEN_GET:
+ if (ep[-1] == ':') {
+ if (len == 1 || mode_char != '/')
+ fail (Error_Syntax(ss));
+ --len;
+ --ss->end;
+ }
+ bp++;
+ // falls through
+ case TOKEN_SET:
+ len--;
+ if (mode_char == '/' && ss->token == TOKEN_SET) {
+ ss->token = TOKEN_WORD; // will be a PATH_SET
+ ss->end--; // put ':' back on end but not beginning
+ }
+ // falls through
+ case TOKEN_WORD: {
+ if (len == 0) {
+ --bp;
+ fail (Error_Syntax(ss));
+ }
+
+ REBSTR *spelling = Intern_UTF8_Managed(bp, len);
+ DS_PUSH_TRASH;
+ Init_Any_Word(
+ DS_TOP, KIND_OF_WORD_FROM_TOKEN(ss->token), spelling
+ );
+ break; }
+
+ case TOKEN_REFINE: {
+ REBSTR *spelling = Intern_UTF8_Managed(bp + 1, len - 1);
+ DS_PUSH_TRASH;
+ Init_Refinement(DS_TOP, spelling);
+ break; }
+
+ case TOKEN_ISSUE:
+ if (len == 1) {
+ if (bp[1] == '(') {
+ ss->token = TOKEN_CONSTRUCT;
+ fail (Error_Syntax(ss));
+ }
+ DS_PUSH_TRASH;
+ Init_Blank(DS_TOP); // A single # means NONE
+ }
+ else {
+ DS_PUSH_TRASH;
+ if (ep != Scan_Issue(DS_TOP, bp + 1, len - 1))
+ fail (Error_Syntax(ss));
+ }
+ break;
+
+ case TOKEN_BLOCK_BEGIN:
+ case TOKEN_GROUP_BEGIN: {
+ REBARR *array = Scan_Child_Array(
+ ss, (ss->token == TOKEN_BLOCK_BEGIN) ? ']' : ')'
+ );
+
+ ep = ss->end;
+
+ DS_PUSH_TRASH;
+ Init_Any_Array(
+ DS_TOP,
+ (ss->token == TOKEN_BLOCK_BEGIN) ? REB_BLOCK : REB_GROUP,
+ array
+ );
+ break; }
+
+ case TOKEN_PATH:
+ break;
+
+ case TOKEN_BLOCK_END: {
+ if (mode_char == ']')
+ goto array_done;
+
+ if (mode_char != 0) // expected a `)` or otherwise before the `]`
+ fail (Error_Mismatch(ss, mode_char, ']'));
- // Process each lexical token appropriately:
- switch (token) { // (idea is that compiler selects computed branch)
-
- case TOKEN_LINE:
- #ifdef TEST_SCAN
- Wait_User("next...");
- #endif
- line = TRUE;
- scan_state->head_line = ep;
- continue;
-
- case TOKEN_LIT:
- case TOKEN_GET:
- if (ep[-1] == ':') {
- if (len == 1 || mode_char != '/') goto syntax_error;
- len--, scan_state->end--;
- }
- bp++;
- case TOKEN_SET:
- len--;
- if (mode_char == '/' && token == TOKEN_SET) {
- token = TOKEN_WORD; // will be a PATH_SET
- scan_state->end--; // put ':' back on end but not beginning
- }
- case TOKEN_WORD:
- if (len == 0) {bp--; goto syntax_error;}
- VAL_SET(value, (REBYTE)(REB_WORD + (token - TOKEN_WORD))); // NO_FRAME
- if (!(VAL_WORD_SYM(value) = Make_Word(bp, len))) goto syntax_error;
- VAL_WORD_FRAME(value) = 0;
- break;
-
- case TOKEN_REFINE:
- VAL_SET(value, REB_REFINEMENT); // NO_FRAME
- if (!(VAL_WORD_SYM(value) = Make_Word(bp+1, len-1))) goto syntax_error;
- break;
-
- case TOKEN_ISSUE:
- if (len == 1) {
- if (bp[1] == '(') {token = TOKEN_CONSTRUCT; goto syntax_error;}
- SET_NONE(value); // A single # means NONE
- }
- else {
- VAL_SET(value, REB_ISSUE); // NO_FRAME
- if (!(VAL_WORD_SYM(value) = Scan_Issue(bp+1, len-1))) goto syntax_error;
- }
- break;
-
- case TOKEN_BLOCK:
- case TOKEN_PAREN:
- //line = VAL_GET_LINE(value);
- block = Scan_Block(scan_state, (REBYTE)((token == TOKEN_BLOCK) ? ']' : ')'));
- // (above line could have realloced emitbuf)
- ep = scan_state->end;
- value = BLK_TAIL(emitbuf);
- if (scan_state->errors) {
- *value = *BLK_LAST(block); // Copy the error
- emitbuf->tail++;
- goto exit_block;
- }
- VAL_SERIES(value) = block;
- VAL_SET(value, (REBYTE)((token == TOKEN_BLOCK) ? REB_BLOCK : REB_PAREN));
- VAL_INDEX(value) = 0;
- //if (line) line = FALSE, VAL_SET_LINE(value);
- break;
-
- case TOKEN_PATH:
- break;
-
- case TOKEN_BLOCK_END:
- if (!mode_char) { mode_char = '['; goto extra_error; }
- else if (mode_char != ']') goto missing_error;
- else goto exit_block;
-
- case TOKEN_PAREN_END:
- if (!mode_char) { mode_char = '('; goto extra_error; }
- else if (mode_char != ')') goto missing_error;
- else goto exit_block;
-
- case TOKEN_INTEGER: // or start of DATE
+ // just a stray unexpected ']'
+ //
+ fail (Error_Extra(ss, ']')); }
+
+ case TOKEN_GROUP_END: {
+ if (mode_char == ')')
+ goto array_done;
+
+ if (mode_char != 0) // expected a ']' or otherwise before the ')'
+ fail (Error_Mismatch(ss, mode_char, ')'));
+
+ // just a stray unexpected ')'
+ //
+ fail (Error_Extra(ss, ')')); }
+
+ case TOKEN_INTEGER: // or start of DATE
if (*ep != '/' || mode_char == '/') {
- if (0 == Scan_Integer(bp, len, value))
- goto syntax_error;
- }
- else { // A / and not in block
- token = TOKEN_DATE;
- while (*ep == '/' || IS_LEX_AT_LEAST_SPECIAL(*ep)) ep++;
- scan_state->begin = ep;
- len = (REBCNT)(ep - bp);
- if (ep != Scan_Date(bp, len, value)) goto syntax_error;
- }
- break;
-
- case TOKEN_DECIMAL:
- case TOKEN_PERCENT:
- // Do not allow 1.2/abc:
- if (*ep == '/' || !Scan_Decimal(bp, len, value, 0)) goto syntax_error;
- if (bp[len-1] == '%') {
- VAL_SET(value, REB_PERCENT);
- VAL_DECIMAL(value) /= 100.0;
- }
- break;
-
- case TOKEN_MONEY:
- // Do not allow $1/$2:
- if (*ep == '/') {ep++; goto syntax_error;}
- if (!Scan_Money(bp, len, value)) goto syntax_error;
- break;
-
- case TOKEN_TIME:
- if (bp[len-1] == ':' && mode_char == '/') { // could be path/10: set
- if (!Scan_Integer(bp, len-1, value)) goto syntax_error;
- scan_state->end--; // put ':' back on end but not beginning
- break;
- }
- if (ep != Scan_Time(bp, len, value)) goto syntax_error;
- break;
-
- case TOKEN_DATE:
- while (*ep == '/' && mode_char != '/') { // Is it a date/time?
- ep++;
- while (IS_LEX_AT_LEAST_SPECIAL(*ep)) ep++;
- len = (REBCNT)(ep - bp);
- if (len > 50) break; // prevent inf-loop - should never be longer than this
- scan_state->begin = ep; // End point extended to cover time
- }
- if (ep != Scan_Date(bp, len, value)) goto syntax_error;
- break;
-
- case TOKEN_CHAR:
- bp += 2; // skip #"
- VAL_CHAR(value) = Scan_Char(&bp);
- bp++; // skip end "
- VAL_SET(value, REB_CHAR);
- break;
-
- case TOKEN_STRING:
- // During scan above, string was stored in BUF_MOLD (with Uni width)
- Set_String(value, Copy_String(BUF_MOLD, 0, -1));
- LABEL_SERIES(VAL_SERIES(value), "scan string");
- break;
-
- case TOKEN_BINARY:
- Scan_Binary(bp, len, value);
- LABEL_SERIES(VAL_SERIES(value), "scan binary");
- break;
-
- case TOKEN_PAIR:
- Scan_Pair(bp, len, value);
- break;
-
- case TOKEN_TUPLE:
- if (!Scan_Tuple(bp, len, value)) goto syntax_error;
- break;
-
- case TOKEN_FILE:
- Scan_File(bp, len, value);
- LABEL_SERIES(VAL_SERIES(value), "scan file");
- break;
-
- case TOKEN_EMAIL:
- Scan_Email(bp, len, value);
- LABEL_SERIES(VAL_SERIES(value), "scan email");
- break;
-
- case TOKEN_URL:
- Scan_URL(bp, len, value);
- LABEL_SERIES(VAL_SERIES(value), "scan url");
- break;
-
- case TOKEN_TAG:
- Scan_Any(bp+1, len-2, value, REB_TAG);
- LABEL_SERIES(VAL_SERIES(value), "scan tag");
- break;
-
- case TOKEN_CONSTRUCT:
- block = Scan_Full_Block(scan_state, ']');
- value = BLK_TAIL(emitbuf);
- emitbuf->tail++; // Protect the block from GC
-// if (!Construct_Simple(value, block)) {
- Bind_Block(Lib_Context, BLK_HEAD(block), BIND_ALL|BIND_DEEP);
- //Bind_Global_Block(BLK_HEAD(block));
- if (!Construct_Value(value, block)) {
- if (IS_END(value)) Set_Block(value, block);
- Trap1(RE_MALCONSTRUCT, value);
- }
- emitbuf->tail--; // Unprotect
- break;
-
- case TOKEN_EOF: continue;
-
- default: ;
- SET_NONE(value);
- }
-
- if (line) {
- line = FALSE;
- VAL_SET_LINE(value);
- }
-
- #ifdef TEST_SCAN
- Print((REBYTE*)"%s - %s", Token_Names[token], Use_Buf(bp,ep));
- if (VAL_TYPE(value) >= REB_STRING && VAL_TYPE(value) <= REB_URL)
- Print_Str(VAL_BIN(value));
- //Wait_User(0);
- #endif
-
-#ifdef COMP_LINES
- VAL_LINE(value)=linenum;
- VAL_FLAGS(value)|=FLAGS_LINE;
+ DS_PUSH_TRASH;
+ if (ep != Scan_Integer(DS_TOP, bp, len))
+ fail (Error_Syntax(ss));
+ }
+ else { // A / and not in block
+ ss->token = TOKEN_DATE;
+ while (*ep == '/' || IS_LEX_NOT_DELIMIT(*ep))
+ ++ep;
+ ss->begin = ep;
+ len = cast(REBCNT, ep - bp);
+ DS_PUSH_TRASH;
+ if (ep != Scan_Date(DS_TOP, bp, len))
+ fail (Error_Syntax(ss));
+ }
+ break;
+
+ case TOKEN_DECIMAL:
+ case TOKEN_PERCENT:
+ // Do not allow 1.2/abc:
+ if (*ep == '/')
+ fail (Error_Syntax(ss));
+
+ DS_PUSH_TRASH;
+ if (ep != Scan_Decimal(DS_TOP, bp, len, FALSE))
+ fail (Error_Syntax(ss));
+
+ if (bp[len - 1] == '%') {
+ VAL_RESET_HEADER(DS_TOP, REB_PERCENT);
+ VAL_DECIMAL(DS_TOP) /= 100.0;
+ }
+ break;
+
+ case TOKEN_MONEY:
+ // Do not allow $1/$2:
+ if (*ep == '/') {
+ ++ep;
+ fail (Error_Syntax(ss));
+ }
+
+ DS_PUSH_TRASH;
+ if (ep != Scan_Money(DS_TOP, bp, len))
+ fail (Error_Syntax(ss));
+ break;
+
+ case TOKEN_TIME:
+ if (bp[len-1] == ':' && mode_char == '/') { // could be path/10: set
+ DS_PUSH_TRASH;
+ if (ep - 1 != Scan_Integer(DS_TOP, bp, len - 1))
+ fail (Error_Syntax(ss));
+ ss->end--; // put ':' back on end but not beginning
+ break;
+ }
+ DS_PUSH_TRASH;
+ if (ep != Scan_Time(DS_TOP, bp, len))
+ fail (Error_Syntax(ss));
+ break;
+
+ case TOKEN_DATE:
+ while (*ep == '/' && mode_char != '/') { // Is it a date/time?
+ ep++;
+ while (IS_LEX_NOT_DELIMIT(*ep)) ep++;
+ len = (REBCNT)(ep - bp);
+ if (len > 50) {
+ // prevent infinite loop, should never be longer than this
+ break;
+ }
+ ss->begin = ep; // End point extended to cover time
+ }
+ DS_PUSH_TRASH;
+ if (ep != Scan_Date(DS_TOP, bp, len))
+ fail (Error_Syntax(ss));
+ break;
+
+ case TOKEN_CHAR:
+ DS_PUSH_TRASH;
+ bp += 2; // skip #", and subtract 1 from ep for "
+ if (ep - 1 != Scan_UTF8_Char_Escapable(&VAL_CHAR(DS_TOP), bp))
+ fail (Error_Syntax(ss));
+ VAL_RESET_HEADER(DS_TOP, REB_CHAR);
+ break;
+
+ case TOKEN_STRING: {
+ // During scan above, string was stored in UNI_BUF (with Uni width)
+ //
+ REBSER *s = Pop_Molded_String(&mo);
+ DS_PUSH_TRASH;
+ Init_String(DS_TOP, s);
+ break; }
+
+ case TOKEN_BINARY:
+ DS_PUSH_TRASH;
+ if (ep != Scan_Binary(DS_TOP, bp, len))
+ fail (Error_Syntax(ss));
+ break;
+
+ case TOKEN_PAIR:
+ DS_PUSH_TRASH;
+ if (ep != Scan_Pair(DS_TOP, bp, len))
+ fail (Error_Syntax(ss));
+ break;
+
+ case TOKEN_TUPLE:
+ DS_PUSH_TRASH;
+ if (ep != Scan_Tuple(DS_TOP, bp, len))
+ fail (Error_Syntax(ss));
+ break;
+
+ case TOKEN_FILE:
+ DS_PUSH_TRASH;
+ if (ep != Scan_File(DS_TOP, bp, len))
+ fail (Error_Syntax(ss));
+ break;
+
+ case TOKEN_EMAIL:
+ DS_PUSH_TRASH;
+ if (ep != Scan_Email(DS_TOP, bp, len))
+ fail (Error_Syntax(ss));
+ break;
+
+ case TOKEN_URL:
+ DS_PUSH_TRASH;
+ if (ep != Scan_URL(DS_TOP, bp, len))
+ fail (Error_Syntax(ss));
+ break;
+
+ case TOKEN_TAG:
+ DS_PUSH_TRASH;
+
+ // The Scan_Any routine (only used here for tag) doesn't
+ // know where the tag ends, so it scans the len.
+ //
+ if (ep - 1 != Scan_Any(DS_TOP, bp + 1, len - 2, REB_TAG))
+ fail (Error_Syntax(ss));
+ break;
+
+ case TOKEN_CONSTRUCT: {
+ REBARR *array = Scan_Full_Array(ss, ']');
+
+ // !!! Should the scanner be doing binding at all, and if so why
+ // just Lib_Context? Not binding would break functions entirely,
+ // but they can't round-trip anyway. See #2262.
+ //
+ Bind_Values_All_Deep(ARR_HEAD(array), Lib_Context);
+
+ if (ARR_LEN(array) == 0 || !IS_WORD(ARR_HEAD(array))) {
+ DECLARE_LOCAL (temp);
+ Init_Block(temp, array);
+ fail (Error_Malconstruct_Raw(temp));
+ }
+
+ REBSYM sym = VAL_WORD_SYM(ARR_HEAD(array));
+ if (IS_KIND_SYM(sym)) {
+ enum Reb_Kind kind = KIND_FROM_SYM(sym);
+
+ MAKE_FUNC dispatcher = Make_Dispatch[kind];
+
+ if (dispatcher == NULL || ARR_LEN(array) != 2) {
+ DECLARE_LOCAL (temp);
+ Init_Block(temp, array);
+ fail (Error_Malconstruct_Raw(temp));
+ }
+
+ // !!! As written today, MAKE may call into the evaluator, and
+ // hence a GC may be triggered. Performing evaluations during
+ // the scanner is a questionable idea, but at the very least
+ // `array` must be guarded, and a data stack cell can't be
+ // used as the destination...because a raw pointer into the
+ // data stack could go bad on any DS_PUSH or DS_DROP.
+ //
+ DECLARE_LOCAL (cell);
+ PUSH_GUARD_ARRAY(array);
+ SET_UNREADABLE_BLANK(cell);
+ PUSH_GUARD_VALUE(cell);
+
+ dispatcher(cell, kind, KNOWN(ARR_AT(array, 1))); // may fail()
+
+ DS_PUSH_TRASH;
+ Move_Value(DS_TOP, cell);
+ DROP_GUARD_VALUE(cell);
+ DROP_GUARD_ARRAY(array);
+ }
+ else {
+ if (ARR_LEN(array) != 1) {
+ DECLARE_LOCAL (temp);
+ Init_Block(temp, array);
+ fail (Error_Malconstruct_Raw(temp));
+ }
+
+ // !!! Construction syntax allows the "type" slot to be one of
+ // the literals #[false], #[true]... along with legacy #[none]
+ // while the legacy #[unset] is no longer possible (but
+ // could load some kind of erroring function value)
+ //
+ switch (sym) {
+ #if !defined(NDEBUG)
+ case SYM_NONE:
+ // Should be under a LEGACY flag...
+ DS_PUSH_TRASH;
+ Init_Blank(DS_TOP);
+ break;
+ #endif
+
+ case SYM_FALSE:
+ DS_PUSH_TRASH;
+ Init_Logic(DS_TOP, FALSE);
+ break;
+
+ case SYM_TRUE:
+ DS_PUSH_TRASH;
+ Init_Logic(DS_TOP, TRUE);
+ break;
+
+ default: {
+ DECLARE_LOCAL (temp);
+ Init_Block(temp, array);
+ fail (Error_Malconstruct_Raw(temp)); }
+ }
+ }
+ break; } // case TOKEN_CONSTRUCT
+
+ case TOKEN_END:
+ continue;
+
+ default:
+ panic ("Invalid TOKEN in Scanner.");
+ }
+
+ if (ANY_ARRAY(DS_TOP)) {
+ //
+ // Current thinking is that only arrays will preserve file and
+ // line numbers, because if ANY-STRING! merges with WORD! then
+ // they might wind up using the ->misc and ->link fields for
+ // canonizing and interning like REBSTR* does.
+ //
+ REBSER *s = VAL_SERIES(DS_TOP);
+ s->misc.line = ss->line;
+ s->link.filename = ss->filename;
+ SET_SER_FLAG(s, SERIES_FLAG_FILE_LINE);
+ }
+
+ if (line) {
+ line = FALSE;
+ SET_VAL_FLAG(DS_TOP, VALUE_FLAG_LINE);
+ }
+
+ // Check for end of path:
+ if (mode_char == '/') {
+ if (*ep == '/') {
+ ep++;
+ ss->begin = ep; // skip next /
+ if (*ep != '(' && IS_LEX_DELIMIT(*ep)) {
+ ss->token = TOKEN_PATH;
+ fail (Error_Syntax(ss));
+ }
+ }
+ else goto array_done;
+ }
+
+ // Added for load/next
+ if (GET_FLAG(ss->opts, SCAN_ONLY) || just_once)
+ goto array_done;
+ }
+
+ // At some point, a token for an end of block or group needed to jump to
+ // the array_done. If it didn't, we never got a proper closing.
+ //
+ if (mode_char == ']' || mode_char == ')')
+ fail (Error_Missing(ss, mode_char));
+
+array_done:
+ if (GET_FLAG(ss->opts, SCAN_RELAX))
+ DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
+
+array_done_relax:
+ Drop_Mold_If_Pushed(&mo);
+
+ REBARR *result = Pop_Stack_Values(dsp_orig);
+
+ // All scanned code is expected to be managed by the GC (because walking
+ // the tree after constructing it to add the "manage GC" bit would be
+ // expensive, and we don't load source and free it manually anyway)
+ //
+ MANAGE_ARRAY(result);
+
+ // In Legacy mode, it can be helpful to know if a block of code is
+ // loaded after legacy mode is turned on. This way, for instance a
+ // SWITCH can run differently based on noticing it was dispatched from
+ // a reference living in that legacy code.
+ //
+ // !!! Currently cued by the REFINEMENTS_BLANK option which also applies
+ // to functions, but should be its own independent switch.
+ //
+#if !defined(NDEBUG)
+ if (LEGACY(OPTIONS_REFINEMENTS_BLANK))
+ SET_SER_INFO(result, SERIES_INFO_LEGACY_DEBUG);
#endif
- if (VAL_TYPE(value)) emitbuf->tail++;
- else {
- syntax_error:
- value = BLK_TAIL(emitbuf);
- Scan_Error(RE_INVALID, scan_state, (REBCNT)token, bp, (REBCNT)(ep-bp), GET_FLAG(scan_state->opts, SCAN_RELAX) ? value : 0);
- emitbuf->tail++;
- goto exit_block;
- missing_error:
- scan_state->line_count = start; // where block started
- scan_state->head_line = start_line;
- extra_error: {
- REBYTE tmp_buf[4]; // Temporary error string
- tmp_buf[0] = mode_char;
- tmp_buf[1] = 0;
- value = BLK_TAIL(emitbuf);
- Scan_Error(RE_MISSING, scan_state, (REBCNT)token, tmp_buf, 1, GET_FLAG(scan_state->opts, SCAN_RELAX) ? value : 0);
- emitbuf->tail++;
- goto exit_block;
- }
- }
-
- // Check for end of path:
- if (mode_char == '/') {
- if (*ep == '/') {
- ep++;
- scan_state->begin = ep; // skip next /
- if (*ep != '(' && IS_LEX_DELIMIT(*ep)) {
- token = TOKEN_PATH;
- goto syntax_error;
- }
- }
- else goto exit_block;
- }
-
- // Added for load/next
- if (GET_FLAG(scan_state->opts, SCAN_ONLY) || just_once) goto exit_block;
- }
-
- if (mode_char == ']' || mode_char == ')') goto missing_error;
-
-exit_block:
- if (line && value) VAL_SET_LINE(value);
- #ifdef TEST_SCAN
- Print((REBYTE*)"block of %d values ", emitbuf->tail - begin); //Wait_User("...");
- #endif
-
- len = emitbuf->tail;
- block = Copy_Values(BLK_SKIP(emitbuf, begin), len - begin);
- LABEL_SERIES(block, "scan block");
- SERIES_SET_FLAG(block, SER_MON);
- emitbuf->tail = begin;
-//!!!! if (value) VAL_OPTS(BLK_TAIL(block)) = VAL_OPTS(value); // save NEWLINE marker
-
- return block;
+
+ return result;
}
-/***********************************************************************
-**
-*/ REBSER *Scan_Full_Block(SCAN_STATE *scan_state, REBYTE mode_char)
-/*
-** Simple variation of scan_block to avoid problem with
-** construct of aggregate values.
-**
-***********************************************************************/
+//
+// Scan_Child_Array: C
+//
+// This routine would create a new structure on the scanning stack. Putting
+// what would be local variables for each level into a structure helps with
+// reflection, allowing for better introspection and error messages. (This
+// is similar to the benefits of Reb_Frame.)
+//
+static REBARR *Scan_Child_Array(SCAN_STATE *ss, REBYTE mode_char)
{
- REBFLG only = GET_FLAG(scan_state->opts, SCAN_ONLY);
- REBSER *ser;
- CLR_FLAG(scan_state->opts, SCAN_ONLY);
- ser = Scan_Block(scan_state, mode_char);
- if (only) SET_FLAG(scan_state->opts, SCAN_ONLY);
- return ser;
-}
+ SCAN_STATE child = *ss;
+ // Capture current line and head of line into the starting points, because
+ // some errors wish to report the start of the array's location.
+ //
+ child.start_line = ss->line;
+ child.start_line_head = ss->line_head;
-/***********************************************************************
-**
-*/ REBSER *Scan_Code(SCAN_STATE *scan_state, REBYTE mode_char)
-/*
-** Scan source code, given a scan state. Allows scan of source
-** code a section at a time (used for LOAD/next).
-**
-** Note: Renamed this from Scan_Trap (a bad name, no trap used)
-**
-***********************************************************************/
-{
-// REBSER *ser;
+ REBARR *result = Scan_Array(&child, mode_char);
- BLK_RESET(BUF_EMIT); // Prevents growth (when errors are thrown)
- return Scan_Block(scan_state, mode_char);
-// Set_Block(Temp_Scan_Value, ser);
-// return Temp_Scan_Value;
-}
+ // The only variables that should actually be written back into the
+ // parent ss are those reflecting an update in the "feed" of
+ // data. Here's a quick hack while the shape of that is discovered.
+ REBCNT line_count = ss->line;
+ const REBYTE *line_head = ss->line_head;
+ enum Reb_Token token = ss->token;
-/***********************************************************************
-**
-*/ REBSER *Scan_Source(REBYTE *src, REBCNT len)
-/*
-** Scan source code. Scan state initialized. No header required.
-** If len = 0, then use the C string terminated length.
-**
-***********************************************************************/
-{
- SCAN_STATE scan_state;
+ *ss = child;
+
+ ss->line = line_count;
+ ss->line_head = line_head;
+ ss->token = token;
- Check_Stack();
- if (!len) len = LEN_BYTES(src);
- Init_Scan_State(&scan_state, src, len);
- return Scan_Code(&scan_state, 0);
+ return result;
}
-/***********************************************************************
-**
-*/ REBINT Scan_Header(REBYTE *src, REBCNT len)
-/*
-** Scan for header, return its offset if found or -1 if not.
-**
-***********************************************************************/
+//
+// Scan_Full_Array: C
+//
+// Simple variation of scan_block to avoid problem with
+// construct of aggregate values.
+//
+static REBARR *Scan_Full_Array(SCAN_STATE *ss, REBYTE mode_char)
{
- SCAN_STATE scan_state;
- REBYTE *cp;
- REBINT result;
-
- // Must be UTF8 byte-stream:
- Init_Scan_State(&scan_state, src, len);
- result = Scan_Head(&scan_state);
- if (!result) return -1;
-
- cp = scan_state.begin-2;
- // Backup to start of it:
- if (result > 0) { // normal header found
- while (cp != src && *cp != 'r' && *cp != 'R') cp--;
- } else {
- while (cp != src && *cp != '[') cp--;
- }
- return (REBINT)(cp - src);
+ REBOOL saved_only = GET_FLAG(ss->opts, SCAN_ONLY);
+ CLR_FLAG(ss->opts, SCAN_ONLY);
+
+ REBARR *array = Scan_Child_Array(ss, mode_char);
+
+ if (saved_only) SET_FLAG(ss->opts, SCAN_ONLY);
+ return array;
}
-/***********************************************************************
-**
-*/ void Init_Scanner(void)
-/*
-***********************************************************************/
+//
+// Scan_UTF8_Managed: C
+//
+// Scan source code. Scan state initialized. No header required.
+//
+REBARR *Scan_UTF8_Managed(const REBYTE *utf8, REBCNT len, REBSTR *filename)
{
- Set_Root_Series(TASK_BUF_EMIT, Make_Block(511), "emit block");
- Set_Root_Series(TASK_BUF_UTF8, Make_Unicode(1020), "utf8 buffer");
+ SCAN_STATE ss;
+ const REBUPT start_line = 1;
+ Init_Scan_State(&ss, utf8, len, filename, start_line);
+ return Scan_Array(&ss, 0);
}
-/***********************************************************************
-**
-*/ REBNATIVE(transcode)
-/*
-** Allows BINARY! input only!
-**
-***********************************************************************/
+//
+// Scan_Header: C
+//
+// Scan for header, return its offset if found or -1 if not.
+//
+REBINT Scan_Header(const REBYTE *utf8, REBCNT len)
{
- REBSER *blk;
- SCAN_STATE scan_state;
+ SCAN_STATE ss;
+ REBSTR * const filename = Canon(SYM___ANONYMOUS__);
+ const REBUPT start_line = 1;
+ Init_Scan_State(&ss, utf8, len, filename, start_line);
+
+ REBINT result = Scan_Head(&ss);
+ if (result == 0)
+ return -1;
+
+ const REBYTE *cp = ss.begin - 2;
+
+ // Backup to start of it:
+ if (result > 0) { // normal header found
+ while (cp != utf8 && *cp != 'r' && *cp != 'R')
+ --cp;
+ } else {
+ while (cp != utf8 && *cp != '[')
+ --cp;
+ }
+ return cast(REBINT, cp - utf8);
+}
- Init_Scan_State(&scan_state, VAL_BIN_DATA(D_ARG(1)), VAL_LEN(D_ARG(1)));
- if (D_REF(2)) SET_FLAG(scan_state.opts, SCAN_NEXT);
- if (D_REF(3)) SET_FLAG(scan_state.opts, SCAN_ONLY);
- if (D_REF(4)) SET_FLAG(scan_state.opts, SCAN_RELAX);
+//
+// Startup_Scanner: C
+//
+void Startup_Scanner(void)
+{
+ REBCNT n = 0;
+ while (Token_Names[n] != NULL)
+ ++n;
+ assert(cast(enum Reb_Token, n) == TOKEN_MAX);
- blk = Scan_Code(&scan_state, 0);
- DS_RELOAD(ds); // in case stack moved
- Set_Block(D_RET, blk);
+ Init_String(TASK_BUF_UTF8, Make_Unicode(1020));
+}
- VAL_INDEX(D_ARG(1)) = scan_state.end - VAL_BIN(D_ARG(1));
- Append_Val(blk, D_ARG(1));
- return R_RET;
+//
+// Shutdown_Scanner: C
+//
+void Shutdown_Scanner(void)
+{
+ // Note: Emit and UTF8 buffers freed by task root set
}
-/***********************************************************************
-**
-*/ REBCNT Scan_Word(REBYTE *cp, REBCNT len)
-/*
-** Scan word chars and make word symbol for it.
-** This method gets exactly the same results as scanner.
-** Returns symbol number, or zero for errors.
-**
-***********************************************************************/
+//
+// transcode: native [
+//
+// {Translates UTF-8 binary source to values. Returns [value binary].}
+//
+// source [binary!]
+// "Must be Unicode UTF-8 encoded"
+// /next
+// {Translate next complete value (blocks as single value)}
+// /only
+// "Translate only a single value (blocks dissected)"
+// /relax
+// {Do not cause errors - return error object as value in place}
+// /file
+// file-name [file! url!]
+// /line
+// line-number [integer!]
+// ]
+//
+REBNATIVE(transcode)
{
- SCAN_STATE scan_state;
-
- Init_Scan_State(&scan_state, cp, len);
+ INCLUDE_PARAMS_OF_TRANSCODE;
+
+ REBSTR *filename;
+ if (REF(file)) {
+ //
+ // The file string may be mutable, so we wouldn't want to store it
+ // persistently as-is. Consider:
+ //
+ // file: copy %test
+ // x: transcode/file data1 file
+ // append file "-2"
+ // y: transcode/file data2 file
+ //
+ // You would not want the change of `file` to affect the filename
+ // references in x's loaded source. So the series shouldn't be used
+ // directly, and as long as another reference is needed, use an
+ // interned one (the same mechanic words use). Since the source
+ // filename may be a wide string it is converted to UTF-8 first.
+ //
+ // !!! Should the base name and extension be stored, or whole path?
+ //
+ REBCNT index = VAL_INDEX(ARG(file_name));
+ REBCNT len = VAL_LEN_AT(ARG(file_name));
+ REBSER *temp = Temp_Bin_Str_Managed(ARG(file_name), &index, &len);
+ filename = Intern_UTF8_Managed(BIN_AT(temp, index), len);
+ }
+ else
+ filename = Canon(SYM___ANONYMOUS__);
+
+ REBUPT start_line = 1;
+ if (REF(line)) {
+ start_line = VAL_INT32(ARG(line_number));
+ if (start_line <= 0)
+ fail (ARG(line_number));
+ }
+ else
+ start_line = 1;
+
+ SCAN_STATE ss;
+ Init_Scan_State(
+ &ss,
+ VAL_BIN_AT(ARG(source)),
+ VAL_LEN_AT(ARG(source)),
+ filename,
+ start_line
+ );
+
+ if (REF(next))
+ SET_FLAG(ss.opts, SCAN_NEXT);
+ if (REF(only))
+ SET_FLAG(ss.opts, SCAN_ONLY);
+ if (REF(relax))
+ SET_FLAG(ss.opts, SCAN_RELAX);
+
+ // The scanner always returns an "array" series. So set the result
+ // to a BLOCK! of the results.
+ //
+ // If the source data bytes are "1" then it will be the block [1]
+ // if the source data is "[1]" then it will be the block [[1]]
+
+ Init_Block(D_OUT, Scan_Array(&ss, 0));
+
+ // Add a value to the tail of the result, representing the input
+ // with position advanced past the content consumed by the scan.
+ // (Returning a length 2 block is how TRANSCODE does a "multiple
+ // return value, but #1916 discusses a possible "revamp" of this.)
+
+ VAL_INDEX(ARG(source)) = ss.end - VAL_BIN(ARG(source));
+ Append_Value(VAL_ARRAY(D_OUT), ARG(source));
+
+ return R_OUT;
+}
- if (TOKEN_WORD == Scan_Token(&scan_state)) return Make_Word(cp, len);
- return 0;
+//
+// Scan_Any_Word: C
+//
+// Scan word chars and make word symbol for it.
+// This method gets exactly the same results as scanner.
+// Returns symbol number, or zero for errors.
+//
+const REBYTE *Scan_Any_Word(
+ REBVAL *out,
+ enum Reb_Kind kind,
+ const REBYTE *utf8,
+ REBCNT len
+) {
+ SCAN_STATE ss;
+ REBSTR * const filename = Canon(SYM___ANONYMOUS__);
+ const REBUPT start_line = 1;
+ Init_Scan_State(&ss, utf8, len, filename, start_line);
+
+ REB_MOLD mo;
+ CLEARS(&mo);
+
+ Locate_Token_May_Push_Mold(&mo, &ss);
+ if (ss.token != TOKEN_WORD)
+ return NULL;
+
+ Init_Any_Word(out, kind, Intern_UTF8_Managed(utf8, len));
+ Drop_Mold_If_Pushed(&mo);
+ return ss.begin; // !!! is this right?
}
-/***********************************************************************
-**
-*/ REBCNT Scan_Issue(REBYTE *cp, REBCNT len)
-/*
-** Scan an issue word, allowing special characters.
-**
-***********************************************************************/
+//
+// Scan_Issue: C
+//
+// Scan an issue word, allowing special characters.
+//
+const REBYTE *Scan_Issue(REBVAL *out, const REBYTE *cp, REBCNT len)
{
- REBYTE *bp;
- REBCNT l = len;
- REBCNT c;
+ if (len == 0) return NULL; // will trigger error
- if (len == 0) return 0;
while (IS_LEX_SPACE(*cp)) cp++; /* skip white space */
- bp = cp;
+ const REBYTE *bp = cp;
+ REBCNT l = len;
while (l > 0) {
switch (GET_LEX_CLASS(*bp)) {
case LEX_CLASS_DELIMIT:
- return 0;
-
- case LEX_CLASS_SPECIAL: /* Flag all but first special char: */
- c = GET_LEX_VALUE(*bp);
- if (!(LEX_SPECIAL_TICK == c
- || LEX_SPECIAL_COMMA == c
- || LEX_SPECIAL_PERIOD == c
- || LEX_SPECIAL_PLUS == c
- || LEX_SPECIAL_MINUS == c
- || LEX_SPECIAL_TILDE == c
- ))
- return 0;
-
+ return NULL; // will trigger error
+
+ case LEX_CLASS_SPECIAL: { // Flag all but first special char
+ REBCNT c = GET_LEX_VALUE(*bp);
+ if (!(LEX_SPECIAL_APOSTROPHE == c
+ || LEX_SPECIAL_COMMA == c
+ || LEX_SPECIAL_PERIOD == c
+ || LEX_SPECIAL_PLUS == c
+ || LEX_SPECIAL_MINUS == c
+ || LEX_SPECIAL_TILDE == c
+ || LEX_SPECIAL_BAR == c
+ || LEX_SPECIAL_BLANK == c
+ )) {
+ return NULL; // will trigger error
+ }}
+ // fallthrough
case LEX_CLASS_WORD:
case LEX_CLASS_NUMBER:
bp++;
- l--;
+ l--;
break;
}
}
- return Make_Word(cp, len);
+ REBSTR *str = Intern_UTF8_Managed(cp, len);
+ Init_Issue(out, str);
+ return bp;
}
diff --git a/src/core/l-types.c b/src/core/l-types.c
index 4436f13e18..2771e2d2c7 100644
--- a/src/core/l-types.c
+++ b/src/core/l-types.c
@@ -1,1098 +1,1351 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: l-types.c
-** Summary: special lexical type converters
-** Section: lexical
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %l-types.c
+// Summary: "special lexical type converters"
+// Section: lexical
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#include "sys-scan.h"
#include "sys-deci-funcs.h"
#include "sys-dec-to-char.h"
#include
-typedef REBFLG (*MAKE_FUNC)(REBVAL *, REBVAL *, REBCNT);
-#include "tmp-maketypes.h"
-
-
-/***********************************************************************
-**
-*/ REBYTE *Scan_Hex(REBYTE *cp, REBI64 *num, REBCNT minlen, REBCNT maxlen)
-/*
-** Scans hex while it is valid and does not exceed the maxlen.
-** If the hex string is longer than maxlen - it's an error.
-** If a bad char is found less than the minlen - it's an error.
-** String must not include # - ~ or other invalid chars.
-** If minlen is zero, and no string, that's a valid zero value.
-**
-** Note, this function relies on LEX_WORD lex values having a LEX_VALUE
-** field of zero, except for hex values.
-**
-***********************************************************************/
-{
- REBYTE lex;
- REBYTE v;
- REBI64 n = 0;
- REBCNT cnt = 0;
-
- if (maxlen > MAX_HEX_LEN) return 0;
- while ((lex = Lex_Map[*cp]) > LEX_WORD) {
- if (++cnt > maxlen) return 0;
- v = (REBYTE)(lex & LEX_VALUE); /* char num encoded into lex */
- if (!v && lex < LEX_NUMBER) return 0; /* invalid char (word but no val) */
- n = (n << 4) + v;
- cp++;
- }
-
- if (cnt < minlen) return 0;
- *num = n;
- return cp;
-}
+//
+// The scanning code in R3-Alpha used NULL to return failure during the scan
+// of a value, possibly leaving the value itself in an incomplete or invalid
+// state. Rather than write stray incomplete values into these spots, Ren-C
+// puts "unreadable blank"
+//
-/***********************************************************************
-**
-*/ REBOOL Scan_Hex2(REBYTE *bp, REBUNI *n, REBFLG uni)
-/*
-** Decode a %xx hex encoded byte into a char.
-**
-** The % should already be removed before calling this.
-**
-** We don't allow a %00 in files, urls, email, etc... so
-** a return of 0 is used to indicate an error.
-**
-***********************************************************************/
-{
- REBUNI c1, c2;
- REBYTE d1, d2;
- REBYTE lex;
-
- if (uni) {
- REBUNI *up = (REBUNI*)bp;
- c1 = up[0];
- c2 = up[1];
- } else {
- c1 = bp[0];
- c2 = bp[1];
- }
-
- lex = Lex_Map[c1];
- d1 = lex & LEX_VALUE;
- if (lex < LEX_WORD || (!d1 && lex < LEX_NUMBER)) return FALSE;
-
- lex = Lex_Map[c2];
- d2 = lex & LEX_VALUE;
- if (lex < LEX_WORD || (!d2 && lex < LEX_NUMBER)) return FALSE;
+#define return_NULL \
+ do { SET_UNREADABLE_BLANK(out); return NULL; } while (TRUE)
- *n = (REBUNI)((d1 << 4) + d2);
- return TRUE;
+//
+// MAKE_Fail: C
+//
+void MAKE_Fail(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ UNUSED(out);
+ UNUSED(kind);
+ UNUSED(arg);
+
+ fail ("Datatype does not have a MAKE handler registered");
}
-/***********************************************************************
-**
-*/ REBINT Scan_Hex_Bytes(REBVAL *val, REBCNT maxlen, REBYTE *out)
-/*
-** Low level conversion of hex chars into binary bytes.
-** Returns the number of bytes in binary.
-**
-***********************************************************************/
+//
+// make: native [
+//
+// {Constructs or allocates the specified datatype.}
+//
+// return: [any-value!]
+// {Constructed value.}
+// type [any-value!]
+// {The datatype -or- an examplar value of the type to construct}
+// def [any-value!]
+// {Definition or size of the new value (binding may be modified)}
+// ]
+//
+REBNATIVE(make)
{
- REBYTE b, n = 0;
- REBCNT cnt;
- REBYTE lex;
- REBCNT len;
- REBUNI c;
- REBYTE *start = out;
-
- len = VAL_LEN(val);
- if (len > maxlen) return 0;
-
- for (cnt = 0; cnt < len; cnt++) {
- c = GET_ANY_CHAR(VAL_SERIES(val), VAL_INDEX(val)+cnt);
- if (c > 127) return 0;
- lex = Lex_Map[c];
- b = (REBYTE)(lex & LEX_VALUE); /* char num encoded into lex */
- if (!b && lex < LEX_NUMBER) return 0; /* invalid char (word but no val) */
- if ((cnt + len) & 1) *out++ = (n << 4) + b; // cnt + len deals with odd # of chars
- else n = b & 15;
- }
-
- return (out - start);
+ INCLUDE_PARAMS_OF_MAKE;
+
+ REBVAL *type = ARG(type);
+ REBVAL *arg = ARG(def);
+
+#if !defined(NDEBUG)
+ if (IS_GOB(type)) {
+ //
+ // !!! It appears that GOBs had some kind of inheritance mechanism, by
+ // which you would write:
+ //
+ // gob1: make gob! [...]
+ // gob2: make gob1 [...]
+ //
+ // The new plan is that MAKE operates on a definition spec, and that
+ // this type slot is always a value or exemplar. So if the feature
+ // is needed, it should be something like:
+ //
+ // gob1: make gob! [...]
+ // gob2: make gob! [gob1 ...]
+ //
+ // Or perhaps not use make at all, but some other operation.
+ //
+ assert(FALSE);
+ }
+ else if (IS_EVENT(type)) {
+ assert(FALSE); // ^-- same for events (?)
+ }
+#endif
+
+ enum Reb_Kind kind;
+ if (IS_DATATYPE(type))
+ kind = VAL_TYPE_KIND(type);
+ else
+ kind = VAL_TYPE(type);
+
+ MAKE_FUNC dispatcher = Make_Dispatch[kind];
+ if (dispatcher == NULL)
+ fail (Error_Bad_Make(kind, arg));
+
+ if (IS_VARARGS(arg)) {
+ //
+ // Converting a VARARGS! to an ANY-ARRAY! involves spooling those
+ // varargs to the end and making an array out of that. It's not known
+ // how many elements that will be, so they're gathered to the data
+ // stack to find the size, then an array made. Note that | will stop
+ // varargs gathering.
+ //
+ // !!! MAKE should likely not be allowed to THROW in the general
+ // case--especially if it is the implementation of construction
+ // syntax (arbitrary code should not run during LOAD). Since
+ // vararg spooling may involve evaluation (e.g. to create an array)
+ // it may be a poor fit for the MAKE umbrella.
+ //
+ // Temporarily putting the code here so that the make dispatchers
+ // do not have to bubble up throws, but it is likely that this
+ // should not have been a MAKE operation in the first place.
+ //
+ // !!! This MAKE will be destructive to its input (the varargs will
+ // be fetched and exhausted). That's not necessarily obvious, but
+ // with a TO conversion it would be even less obvious...
+ //
+ if (dispatcher != &MAKE_Array)
+ fail (Error_Bad_Make(kind, arg));
+
+ // If there's any chance that the argument could produce voids, we
+ // can't guarantee an array can be made out of it.
+ //
+ if (arg->extra.binding == NULL) {
+ //
+ // A vararg created from a block AND never passed as an argument
+ // so no typeset or quoting settings available. Can't produce
+ // any voids, because the data source is a block.
+ //
+ assert(
+ NOT_SER_FLAG(
+ arg->payload.varargs.feed, ARRAY_FLAG_VARLIST
+ )
+ );
+ }
+ else {
+ REBCTX *context = CTX(arg->extra.binding);
+ REBFRM *param_frame = CTX_FRAME_IF_ON_STACK(context);
+
+ // If the VARARGS! has a call frame, then ensure that the call
+ // frame where the VARARGS! originated is still on the stack.
+ //
+ if (param_frame == NULL)
+ fail (Error_Varargs_No_Stack_Raw());
+
+ REBVAL *param = FUNC_FACADE_HEAD(param_frame->phase)
+ + arg->payload.varargs.param_offset;
+
+ if (TYPE_CHECK(param, REB_MAX_VOID))
+ fail (Error_Void_Vararg_Array_Raw());
+ }
+
+ REBDSP dsp_orig = DSP;
+
+ do {
+ REB_R r = Do_Vararg_Op_May_Throw(D_OUT, arg, VARARG_OP_TAKE);
+
+ if (r == R_OUT_IS_THROWN) {
+ DS_DROP_TO(dsp_orig);
+ return R_OUT_IS_THROWN;
+ }
+ if (r == R_VOID)
+ break;
+ assert(r == R_OUT);
+
+ DS_PUSH(D_OUT);
+ SET_END(D_OUT); // expected by Do_Vararg_Op
+ } while (TRUE);
+
+ Init_Any_Array(D_OUT, kind, Pop_Stack_Values(dsp_orig));
+ return R_OUT;
+ }
+
+ dispatcher(D_OUT, kind, arg); // may fail()
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBCNT Scan_Hex_Value(void *src, REBCNT len, REBOOL uni)
-/*
-** Given a string, scan it as hex. Chars can be 8 or 16 bit.
-** Result is 32 bits max.
-** Throw errors.
-**
-***********************************************************************/
+//
+// TO_Fail: C
+//
+void TO_Fail(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBUNI c;
- REBCNT n;
- REBYTE lex;
- REBCNT num = 0;
-
- if (len > 8) goto bad_hex;
-
- for (n = 0; n < len; n++) {
-
- c = (REBUNI)(uni ? ((REBUNI*)src)[n] : ((REBYTE*)src)[n]);
-
- if (c > 255) goto bad_hex;
-
- lex = Lex_Map[c];
- if (lex > LEX_WORD) {
- c = lex & LEX_VALUE;
- if (!c && lex < LEX_NUMBER) goto bad_hex;
- num = (num << 4) + c;
- }
- else {
-bad_hex: Trap0(RE_INVALID_CHARS);
- }
- }
- return num;
+ UNUSED(out);
+ UNUSED(kind);
+ UNUSED(arg);
+
+ fail ("Datatype does not have a TO handler registered");
}
-/***********************************************************************
-**
-*/ REBYTE *Scan_Dec_Buf(REBYTE *cp, REBCNT len, REBYTE *buf)
-/*
-** Validate a decimal number. Return on first invalid char
-** (or end). Return zero if not valid.
-**
-** len: max size of buffer (must be MAX_NUM_LEN or larger).
-**
-** Scan is valid for 1 1.2 1,2 1'234.5 1x 1.2x 1% 1.2% etc.
-**
-***********************************************************************/
+//
+// to: native [
+//
+// {Converts to a specified datatype.}
+//
+// type [any-value!]
+// {The datatype -or- an exemplar value of the target type}
+// value [any-value!]
+// {The source value to convert}
+// ]
+//
+REBNATIVE(to)
{
- REBYTE *bp = buf;
- REBYTE *be = bp + len - 1;
- REBOOL dig = FALSE; /* flag that a digit was present */
-
- if (*cp == '+' || *cp == '-') *bp++ = *cp++;
- while (IS_LEX_NUMBER(*cp) || *cp == '\'')
- if (*cp != '\'') {
- *bp++ = *cp++;
- if (bp >= be) return 0;
- dig=1;
- }
- else cp++;
- if (*cp == ',' || *cp == '.') cp++;
- *bp++ = '.';
- if (bp >= be) return 0;
- while (IS_LEX_NUMBER(*cp) || *cp == '\'')
- if (*cp != '\'') {
- *bp++ = *cp++;
- if (bp >= be) return 0;
- dig=1;
- }
- else cp++;
- if (!dig) return 0;
- if (*cp == 'E' || *cp == 'e') {
- *bp++ = *cp++;
- if (bp >= be) return 0;
- dig = 0;
- if (*cp == '-' || *cp == '+') {
- *bp++ = *cp++;
- if (bp >= be) return 0;
- }
- while (IS_LEX_NUMBER(*cp)) {
- *bp++ = *cp++;
- if (bp >= be) return 0;
- dig=1;
- }
- if (!dig) return 0;
- }
- *bp = 0;
- return cp;
+ INCLUDE_PARAMS_OF_TO;
+
+ REBVAL *type = ARG(type);
+ REBVAL *arg = ARG(value);
+
+ enum Reb_Kind kind;
+ if (IS_DATATYPE(type))
+ kind = VAL_TYPE_KIND(type);
+ else
+ kind = VAL_TYPE(type);
+
+ // !!! The only thing you can TO convert a blank into is a BLANK!. This
+ // allows one to sort of opt-out:
+ //
+ // kind: get-kind-maybe-blank x y z
+ // if blank? converted: to kind value [...]
+ //
+ // Is this a good rule, or should types be able to have a custom behavior
+ // for the TO of a blank conversion into them?
+ //
+ if (IS_BLANK(arg)) {
+ if (kind == REB_BLANK)
+ return R_BLANK;
+ fail (arg);
+ }
+
+ TO_FUNC dispatcher = To_Dispatch[kind];
+ if (dispatcher == NULL)
+ fail (arg);
+
+ dispatcher(D_OUT, kind, arg); // may fail();
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBYTE *Scan_Decimal(REBYTE *cp, REBCNT len, REBVAL *value, REBFLG dec_only)
-/*
-** Scan and convert a decimal value. Return zero if error.
-**
-***********************************************************************/
-{
- REBYTE *bp = cp;
- REBYTE buf[MAX_NUM_LEN+4];
- REBYTE *ep = buf;
- REBOOL dig = FALSE; /* flag that a digit was present */
- char *se;
-
- if (len > MAX_NUM_LEN) return 0;
-
- if (*cp == '+' || *cp == '-') *ep++ = *cp++;
- while (IS_LEX_NUMBER(*cp) || *cp == '\'')
- if (*cp != '\'') *ep++ = *cp++, dig=1;
- else cp++;
- if (*cp == ',' || *cp == '.') cp++;
- *ep++ = '.';
- while (IS_LEX_NUMBER(*cp) || *cp == '\'')
- if (*cp != '\'') *ep++ = *cp++, dig=1;
- else cp++;
- if (!dig) return 0;
- if (*cp == 'E' || *cp == 'e') {
- *ep++ = *cp++;
- dig = 0;
- if (*cp == '-' || *cp == '+') *ep++ = *cp++;
- while (IS_LEX_NUMBER(*cp)) *ep++ = *cp++, dig=1;
- if (!dig) return 0;
- }
- if (*cp == '%') {
- if (dec_only) return 0;
- cp++; // ignore it
- }
- *ep = 0;
-
- if ((REBCNT)(cp-bp) != len) return 0;
-
- VAL_SET(value, REB_DECIMAL);
- VAL_DECIMAL(value) = STRTOD((char *)buf, &se); // need check for NaN, and INF !!!
- if (fabs(VAL_DECIMAL(value)) == HUGE_VAL) Trap0(RE_OVERFLOW);
- return cp;
+//
+// Scan_Hex: C
+//
+// Scans hex while it is valid and does not exceed the maxlen.
+// If the hex string is longer than maxlen - it's an error.
+// If a bad char is found less than the minlen - it's an error.
+// String must not include # - ~ or other invalid chars.
+// If minlen is zero, and no string, that's a valid zero value.
+//
+// Note, this function relies on LEX_WORD lex values having a LEX_VALUE
+// field of zero, except for hex values.
+//
+const REBYTE *Scan_Hex(
+ REBVAL *out,
+ const REBYTE *cp,
+ REBCNT minlen,
+ REBCNT maxlen
+) {
+ TRASH_CELL_IF_DEBUG(out);
+
+ if (maxlen > MAX_HEX_LEN)
+ return_NULL;
+
+ REBI64 i = 0;
+ REBCNT cnt = 0;
+ REBYTE lex;
+ while ((lex = Lex_Map[*cp]) > LEX_WORD) {
+ REBYTE v;
+ if (++cnt > maxlen)
+ return_NULL;
+ v = cast(REBYTE, lex & LEX_VALUE); // char num encoded into lex
+ if (!v && lex < LEX_NUMBER)
+ return_NULL; // invalid char (word but no val)
+ i = (i << 4) + v;
+ cp++;
+ }
+
+ if (cnt < minlen)
+ return_NULL;
+
+ Init_Integer(out, i);
+ return cp;
}
-/***********************************************************************
-**
-*/ REBYTE *Scan_Integer(REBYTE *cp, REBCNT len, REBVAL *value)
-/*
-** Scan and convert an integer value. Return zero if error.
-** Allow preceding + - and any combination of ' marks.
-**
-***********************************************************************/
+//
+// Scan_Hex2: C
+//
+// Decode a %xx hex encoded byte into a char.
+//
+// The % should already be removed before calling this.
+//
+// We don't allow a %00 in files, urls, email, etc... so
+// a return of 0 is used to indicate an error.
+//
+REBOOL Scan_Hex2(const REBYTE *bp, REBUNI *n, REBOOL unicode)
{
- REBINT num = (REBINT)len;
- REBYTE buf[MAX_NUM_LEN+4];
- REBYTE *bp;
- REBI64 n;
- REBOOL neg = FALSE;
-
- // Super-fast conversion of zero and one (most common cases):
- if (num == 1) {
- if (*cp == '0') {SET_INTEGER(value, 0); return cp+1;}
- if (*cp == '1') {SET_INTEGER(value, 1); return cp+1;}
- }
-
- if (len > MAX_NUM_LEN) return 0; // prevent buffer overflow
- len = 0;
- bp = buf;
-
- // Strip leading signs:
- if (*cp == '-') *bp++ = *cp++, num--, neg = TRUE;
- else if (*cp == '+') cp++, num--;
-
- // Remove leading zeros:
- for (; num > 0; num--) {
- if (*cp == '0' || *cp == '\'') cp++;
- else break;
- }
-
- // Copy all digits, except ' :
- for (; num > 0; num--) {
- if (*cp >= '0' && *cp <= '9') *bp++ = *cp++;
- else if (*cp == '\'') cp++;
- else return 0;
- }
- *bp = 0;
-
- // Too many digits?
- len = bp - &buf[0];
- if (neg) len--;
- if (len > 19) return 0;
-
- // Convert, check, and return:
- n = CHR_TO_INT(buf);
- if ((n > 0 && neg) || (n < 0 && !neg)) return 0;
- SET_INTEGER(value, n);
- return cp;
-}
+ REBUNI c1, c2;
+ REBYTE d1, d2;
+ REBYTE lex;
+
+ if (unicode) {
+ const REBUNI *up = cast(const REBUNI*, bp);
+ c1 = up[0];
+ c2 = up[1];
+ } else {
+ c1 = bp[0];
+ c2 = bp[1];
+ }
+
+ lex = Lex_Map[c1];
+ d1 = lex & LEX_VALUE;
+ if (lex < LEX_WORD || (!d1 && lex < LEX_NUMBER)) return FALSE;
+
+ lex = Lex_Map[c2];
+ d2 = lex & LEX_VALUE;
+ if (lex < LEX_WORD || (!d2 && lex < LEX_NUMBER)) return FALSE;
+ *n = (REBUNI)((d1 << 4) + d2);
-/***********************************************************************
-**
-*/ REBYTE *Scan_Money(REBYTE *cp, REBCNT len, REBVAL *value)
-/*
-** Scan and convert money. Return zero if error.
-**
-***********************************************************************/
-{
- REBYTE *end;
-
- if (*cp == '$') cp++, len--;
- if (len == 0) return 0;
- VAL_DECI(value) = string_to_deci(cp, &end);
- if (end != cp + len) return 0;
- VAL_SET(value, REB_MONEY);
-
- return end;
-
-#ifdef ndef
- REBYTE *bp = cp;
- REBYTE buf[MAX_NUM_LEN+8];
- REBYTE *ep = buf;
- REBCNT n = 0;
- REBOOL dig = FALSE;
-
- if (*cp == '+') cp++;
- else if (*cp == '-') *ep++ = *cp++;
-
- if (*cp != '$') {
- for (; Upper_Case[*cp] >= 'A' && Upper_Case[*cp] <= 'Z' && n < 3; cp++, n++) {
- VAL_MONEY_DENOM(value)[n] = Upper_Case[*cp];
- }
- if (*cp != '$' || n > 3) return 0;
- VAL_MONEY_DENOM(value)[n] = 0;
- } else VAL_MONEY_DENOM(value)[0] = 0;
- cp++;
-
- while (ep < buf+MAX_NUM_LEN && (IS_LEX_NUMBER(*cp) || *cp == '\''))
- if (*cp != '\'') *ep++ = *cp++, dig=1;
- else cp++;
- if (*cp == ',' || *cp == '.') cp++;
- *ep++ = '.';
- while (ep < buf+MAX_NUM_LEN && (IS_LEX_NUMBER(*cp) || *cp == '\''))
- if (*cp != '\'') *ep++ = *cp++, dig=1;
- else cp++;
- if (!dig) return 0;
- if (ep >= buf+MAX_NUM_LEN) return 0;
- *ep = 0;
-
- if ((REBCNT)(cp-bp) != len) return 0;
- VAL_SET(value, REB_MONEY);
- VAL_MONEY_AMOUNT(value) = atof((char*)(&buf[0]));
- if (fabs(VAL_MONEY_AMOUNT(value)) == HUGE_VAL) Trap0(RE_OVERFLOW);
- return cp;
-#endif
+ return TRUE;
}
-/***********************************************************************
-**
-*/ REBYTE *Scan_Date(REBYTE *cp, REBCNT len, REBVAL *value)
-/*
-** Scan and convert a date. Also can include a time and zone.
-**
-***********************************************************************/
+//
+// Scan_Hex_Value: C
+//
+// Given a string, scan it as hex. Chars can be 8 or 16 bit.
+// Result is 32 bits max.
+// Throw errors.
+//
+REBCNT Scan_Hex_Value(const void *p, REBCNT len, REBOOL unicode)
{
- REBYTE *ep;
- REBYTE *end = cp + len;
- REBINT num;
- REBINT day = 0;
- REBINT month;
- REBINT year;
- REBINT tz = 0;
- REBYTE sep;
- REBCNT size;
-
- // Skip spaces:
- for (; *cp == ' ' && cp != end; cp++);
-
- // Skip day name, comma, and spaces:
- for (ep = cp; *ep != ',' && ep != end; ep++);
- if (ep != end) {
- cp = ep + 1;
- while (*cp == ' ' && cp != end) cp++;
- }
- if (cp == end) return 0;
-
- // Day or 4-digit year:
- ep = Grab_Int(cp, &num);
- if (num < 0) return 0;
- size = (REBCNT)(ep - cp);
- if (size >= 4) year = num;
- else if (size) day = num;
- else return 0;
- cp = ep;
-
- // Determine field separator:
- if (*cp != '/' && *cp != '-' && *cp != '.' && *cp != ' ') return 0;
- sep = *cp++;
-
- // Month as number or name:
- ep = Grab_Int(cp, &num);
- if (num < 0) return 0;
- size = (REBCNT)(ep - cp);
- if (size > 0) month = num; // got a number
- else { // must be a word
- for (ep = cp; IS_LEX_WORD(*ep); ep++); // scan word
- size = (REBCNT)(ep - cp);
- if (size < 3) return 0;
- for (num = 0; num < 12; num++) {
- if (!Compare_Bytes((REBYTE *)(Month_Names[num]), cp, size, TRUE)) break;
- }
- month = num + 1;
- }
- if (month < 1 || month > 12) return 0;
- cp = ep;
- if (*cp++ != sep) return 0;
-
- // Year or day (if year was first):
- ep = Grab_Int(cp, &num);
- if (*cp == '-' || num < 0) return 0;
- size = (REBCNT)(ep - cp);
- if (!size) return 0;
- if (!day) day = num;
- else { // it is a year
- // Allow shorthand form (e.g. /96) ranging +49,-51 years
- // (so in year 2050 a 0 -> 2000 not 2100)
- if (size >= 3) year = num;
- else {
- year = (Current_Year / 100) * 100 + num;
- if (year - Current_Year > 50) year -=100;
- else if (year - Current_Year < -50) year += 100;
- }
- }
- if (year > MAX_YEAR || day < 1 || day > (REBINT)(Month_Lengths[month-1])) return 0;
- // Check February for leap year or century:
- if (month == 2 && day == 29) {
- if (((year % 4) != 0) || // not leap year
- ((year % 100) == 0 && // century?
- (year % 400) != 0)) return 0; // not leap century
- }
-
- cp = ep;
- VAL_TIME(value) = NO_TIME;
- if (cp >= end) goto end_date;
-
- if (*cp == '/' || *cp == ' ') {
- sep = *cp++;
- if (cp >= end) goto end_date;
- cp = Scan_Time(cp, 0, value);
- if (!IS_TIME(value) || (VAL_TIME(value) < 0) || (VAL_TIME(value) >= TIME_SEC(24 * 60 * 60)))
- return 0;
- }
-
- if (*cp == sep) cp++;
-
- // Time zone can be 12:30 or 1230 (optional hour indicator)
- if (*cp == '-' || *cp == '+') {
- if (cp >= end) goto end_date;
- ep = Grab_Int(cp+1, &num);
- if (ep-cp == 0) return 0;
- if (*ep != ':') {
- int h, m;
- if (num < -1500 || num > 1500) return 0;
- h = (num / 100);
- m = (num - (h * 100));
- tz = (h * 60 + m) / ZONE_MINS;
- } else {
- if (num < -15 || num > 15) return 0;
- tz = num * (60/ZONE_MINS);
- if (*ep == ':') {
- ep = Grab_Int(ep+1, &num);
- if (num % ZONE_MINS != 0) return 0;
- tz += num / ZONE_MINS;
- }
- }
- if (ep != end) return 0;
- if (*cp == '-') tz = -tz;
- cp = ep;
- }
-end_date:
- Set_Date_UTC(value, year, month, day, VAL_TIME(value), tz);
- return cp;
+ REBUNI c;
+ REBCNT n;
+ REBYTE lex;
+ REBCNT num = 0;
+ const REBYTE *bp = unicode ? NULL : cast(const REBYTE *, p);
+ const REBUNI *up = unicode ? cast(const REBUNI *, p) : NULL;
+
+ if (len > 8) goto bad_hex;
+
+ for (n = 0; n < len; n++) {
+ c = unicode ? up[n] : cast(REBUNI, bp[n]);
+
+ if (c > 255) goto bad_hex;
+
+ lex = Lex_Map[c];
+ if (lex <= LEX_WORD) goto bad_hex;
+
+ c = lex & LEX_VALUE;
+ if (!c && lex < LEX_NUMBER) goto bad_hex;
+ num = (num << 4) + c;
+ }
+ return num;
+
+bad_hex:
+ fail (Error_Invalid_Chars_Raw());
}
-#ifdef moved
-/***********************************************************************
-**
-**/ REBCNT Scan_Word(REBYTE *cp, REBCNT len)
-/*
-** Scan word chars and make word symbol for it.
-** Returns symbol number, or zero for errors.
-**
-***********************************************************************/
-{
- REBCNT n;
-
- if (
- IS_LEX_WORD(*cp)
- || strchr("/+-<>.", *cp)
- ) {
- // Special / and // cases:
- if (*cp == '/') {
- if (len == 1 || (len == 2 && cp[1] == '/'))
- return Make_Word(cp, len);
- else
- return 0;
- }
-
- // Check other cases:
- for (n = 1; n < len; n++) {
- if (
- !IS_LEX_AT_LEAST_SPECIAL(cp[n])
- || strchr(":/", cp[n])
- ) {
- return 0;
- }
- }
- }
- else
- return 0;
-
- return Make_Word(cp, len);
+//
+// Scan_Dec_Buf: C
+//
+// Validate a decimal number. Return on first invalid char (or end).
+// Returns NULL if not valid.
+//
+// Scan is valid for 1 1.2 1,2 1'234.5 1x 1.2x 1% 1.2% etc.
+//
+// !!! Is this redundant with Scan_Decimal? Appears to be similar code.
+//
+const REBYTE *Scan_Dec_Buf(
+ REBYTE *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT len // max size of buffer
+) {
+ assert(len >= MAX_NUM_LEN);
+
+ REBYTE *bp = out;
+ REBYTE *be = bp + len - 1;
+
+ if (*cp == '+' || *cp == '-')
+ *bp++ = *cp++;
+
+ REBOOL digit_present = FALSE;
+ while (IS_LEX_NUMBER(*cp) || *cp == '\'') {
+ if (*cp != '\'') {
+ *bp++ = *cp++;
+ if (bp >= be)
+ return NULL;
+ digit_present = TRUE;
+ }
+ else
+ ++cp;
+ }
+
+ if (*cp == ',' || *cp == '.')
+ cp++;
+
+ *bp++ = '.';
+ if (bp >= be)
+ return NULL;
+
+ while (IS_LEX_NUMBER(*cp) || *cp == '\'') {
+ if (*cp != '\'') {
+ *bp++ = *cp++;
+ if (bp >= be)
+ return NULL;
+ digit_present = TRUE;
+ }
+ else
+ ++cp;
+ }
+
+ if (NOT(digit_present))
+ return NULL;
+
+ if (*cp == 'E' || *cp == 'e') {
+ *bp++ = *cp++;
+ if (bp >= be)
+ return NULL;
+
+ digit_present = FALSE;
+
+ if (*cp == '-' || *cp == '+') {
+ *bp++ = *cp++;
+ if (bp >= be)
+ return NULL;
+ }
+
+ while (IS_LEX_NUMBER(*cp)) {
+ *bp++ = *cp++;
+ if (bp >= be)
+ return NULL;
+ digit_present = TRUE;
+ }
+
+ if (NOT(digit_present))
+ return NULL;
+ }
+
+ *bp = '\0';
+ return cp;
}
-#endif
-#ifdef not_used
-/***********************************************************************
-**
-*/ REBYTE *Scan_String(REBYTE *cp, REBCNT len, REBVAL *value)
-/*
-** Scan and convert a string. Return zero if error.
-**
-***********************************************************************/
-{
- REBYTE *ep;
- Reset_Buffer(BUF_FORM, len);
+//
+// Scan_Decimal: C
+//
+// Scan and convert a decimal value. Return zero if error.
+//
+const REBYTE *Scan_Decimal(
+ REBVAL *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT len,
+ REBOOL dec_only
+) {
+ TRASH_CELL_IF_DEBUG(out);
- if (!(ep = Scan_Quote(cp, BIN_HEAD(BUF_FORM), 0))) {
- VAL_CLEAR(value);
- return 0;
- }
+ REBYTE buf[MAX_NUM_LEN + 4];
+ REBYTE *ep = buf;
+ if (len > MAX_NUM_LEN)
+ return_NULL;
- Set_String(value, Decode_UTF8_Value(BIN_HEAD(BUF_FORM), (REBCNT)(ep - BIN_HEAD(BUF_FORM))));
+ const REBYTE *bp = cp;
- return ep;
-}
-#endif
+ if (*cp == '+' || *cp == '-')
+ *ep++ = *cp++;
-/***********************************************************************
-**
-*/ REBYTE *Scan_File(REBYTE *cp, REBCNT len, REBVAL *value)
-/*
-** Scan and convert a file name.
-**
-***********************************************************************/
-{
- REBUNI term = 0;
- REBYTE *invalid = ":;()[]\"";
-
- if (*cp == '%') cp++, len--;
- if (*cp == '"') {
- cp++;
- len--;
- term = '"';
- invalid = ":;\"";
- }
- cp = Scan_Item(cp, cp+len, term, invalid);
- if (cp)
- Set_Series(REB_FILE, value, Copy_String(BUF_MOLD, 0, -1));
- return cp;
-
-#ifdef ndef
- extern REBYTE *Scan_Quote(REBYTE *src, SCAN_STATE *scan_state);
-
- if (*cp == '%') cp++, len--;
- if (len == 0) return 0;
- if (*cp == '"') {
- cp = Scan_Quote(cp, 0);
- if (cp) {
- int need_changes;
- Set_String(value, Copy_String(BUF_MOLD, 0, -1));
- VAL_SET(value, REB_FILE);
- }
- return cp;
- }
-
- VAL_SERIES(value) = Make_Binary(len);
- VAL_INDEX(value) = 0;
-
- str = VAL_BIN(value);
- for (; len > 0; len--) {
- if (*cp == '%' && len > 2 && Scan_Hex2(cp+1, &n, FALSE)) {
- *str++ = n;
- cp += 3;
- len -= 2;
- }
- else if (*cp == '\\') cp++, *str++ = '/';
- else if (strchr(":;()[]\"", *cp)) return 0; // chars not allowed in files !!!
- else *str++ = *cp++;
- }
- *str = 0;
- VAL_TAIL(value) = (REBCNT)(str - VAL_BIN(value));
- VAL_SET(value, REB_FILE);
- return cp;
-#endif
-}
+ REBOOL digit_present = FALSE;
+ while (IS_LEX_NUMBER(*cp) || *cp == '\'') {
+ if (*cp != '\'') {
+ *ep++ = *cp++;
+ digit_present = TRUE;
+ }
+ else
+ ++cp;
+ }
-/***********************************************************************
-**
-*/ REBYTE *Scan_Email(REBYTE *cp, REBCNT len, REBVAL *value)
-/*
-** Scan and convert email.
-**
-***********************************************************************/
-{
- REBYTE *str;
- REBOOL at = FALSE;
- REBUNI n;
-
- VAL_SERIES(value) = Make_Binary(len);
- VAL_INDEX(value) = 0;
-
- str = VAL_BIN(value);
- for (; len > 0; len--) {
- if (*cp == '@') {
- if (at) return 0;
- at = TRUE;
- }
- if (*cp == '%') {
- if (len <= 2 || !Scan_Hex2(cp+1, &n, FALSE)) return 0;
- *str++ = (REBYTE)n;
- cp += 3;
- len -= 2;
- }
- else *str++ = *cp++;
- }
- *str = 0;
- if (!at) return 0;
- VAL_TAIL(value) = (REBCNT)(str - VAL_BIN(value));
- VAL_SET(value, REB_EMAIL);
- return cp;
-}
+ if (*cp == ',' || *cp == '.')
+ ++cp;
+ *ep++ = '.';
-/***********************************************************************
-**
-*/ REBYTE *Scan_URL(REBYTE *cp, REBCNT len, REBVAL *value)
-/*
-** Scan and convert a URL.
-**
-***********************************************************************/
-{
- REBYTE *str;
- REBUNI n;
+ while (IS_LEX_NUMBER(*cp) || *cp == '\'') {
+ if (*cp != '\'') {
+ *ep++ = *cp++;
+ digit_present = TRUE;
+ }
+ else
+ ++cp;
+ }
-// !!! Need to check for any possible scheme followed by ':'
+ if (NOT(digit_present))
+ return_NULL;
-// for (n = 0; n < URL_MAX; n++) {
-// if (str = Match_Bytes(cp, (REBYTE *)(URL_Schemes[n]))) break;
-// }
-// if (n >= URL_MAX) return 0;
-// if (*str != ':') return 0;
-
- VAL_SERIES(value) = Make_Binary(len);
- VAL_INDEX(value) = 0;
-
- str = VAL_BIN(value);
- for (; len > 0; len--) {
- //if (*cp == '%' && len > 2 && Scan_Hex2(cp+1, &n, FALSE)) {
- if (*cp == '%') {
- if (len <= 2 || !Scan_Hex2(cp+1, &n, FALSE)) return 0;
- *str++ = (REBYTE)n;
- cp += 3;
- len -= 2;
- }
- else *str++ = *cp++;
- }
- *str = 0;
- VAL_TAIL(value) = (REBCNT)(str - VAL_BIN(value));
- VAL_SET(value, REB_URL);
- return cp;
-}
+ if (*cp == 'E' || *cp == 'e') {
+ *ep++ = *cp++;
+ digit_present = FALSE;
+ if (*cp == '-' || *cp == '+')
+ *ep++ = *cp++;
-/***********************************************************************
-**
-*/ REBYTE *Scan_Pair(REBYTE *cp, REBCNT len, REBVAL *value)
-/*
-** Scan and convert a pair
-**
-***********************************************************************/
-{
- REBYTE *ep, *xp;
- REBYTE buf[MAX_NUM_LEN+4];
-
- ep = cp;
- //ep = Grab_Int(ep, &n);
- ep = Scan_Dec_Buf(cp, MAX_NUM_LEN, &buf[0]);
- if (!ep) return 0;
- VAL_PAIR_X(value) = (float)atof((char*)(&buf[0])); //n;
- if (*ep != 'x' && *ep != 'X') return 0;
- ep++;
-
- xp = Scan_Dec_Buf(ep, MAX_NUM_LEN, &buf[0]);
- if (!xp) return 0;
- VAL_PAIR_Y(value) = (float)atof((char*)(&buf[0])); //n;
-
- if (len > (REBCNT)(xp - cp)) return 0;
- VAL_SET(value, REB_PAIR);
- return xp;
+ while (IS_LEX_NUMBER(*cp)) {
+ *ep++ = *cp++;
+ digit_present = TRUE;
+ }
+
+ if (NOT(digit_present))
+ return_NULL;
+ }
+
+ if (*cp == '%') {
+ if (dec_only)
+ return_NULL;
+
+ ++cp; // ignore it
+ }
+
+ *ep = '\0';
+
+ if (cast(REBCNT, cp - bp) != len)
+ return_NULL;
+
+ VAL_RESET_HEADER(out, REB_DECIMAL);
+
+ const char *se;
+ VAL_DECIMAL(out) = STRTOD(s_cast(buf), &se);
+
+ // !!! TBD: need check for NaN, and INF
+
+ if (fabs(VAL_DECIMAL(out)) == HUGE_VAL)
+ fail (Error_Overflow_Raw());
+
+ return cp;
}
-/***********************************************************************
-**
-*/ REBYTE *Scan_Tuple(REBYTE *cp, REBCNT len, REBVAL *value)
-/*
-** Scan and convert a tuple.
-**
-***********************************************************************/
-{
- REBYTE *ep;
- REBYTE *tp;
- REBCNT size = 1;
- REBINT n;
-
- if (len == 0) return 0;
- for (n = (REBINT)len, ep = cp; n > 0; n--, ep++) // count '.'
- if (*ep == '.') size++;
- if (size > MAX_TUPLE) return 0;
- if (size < 3) size = 3;
- VAL_TUPLE_LEN(value) = (REBYTE)size;
- tp = VAL_TUPLE(value);
- memset(tp, 0, sizeof(REBTUP)-2);
- for (ep = cp; len > (REBCNT)(ep - cp); ep++) {
- ep = Grab_Int(ep, &n);
- if (n < 0 || n > 255) return 0;
- *tp++ = (REBYTE)n;
- if (*ep != '.') break;
- }
- if (len > (REBCNT)(ep - cp)) return 0;
- VAL_SET(value, REB_TUPLE);
- return ep;
+//
+// Scan_Integer: C
+//
+// Scan and convert an integer value. Return zero if error.
+// Allow preceding + - and any combination of ' marks.
+//
+const REBYTE *Scan_Integer(
+ REBVAL *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT len
+) {
+ TRASH_CELL_IF_DEBUG(out);
+
+ // Super-fast conversion of zero and one (most common cases):
+ if (len == 1) {
+ if (*cp == '0') {
+ Init_Integer(out, 0);
+ return cp + 1;
+ }
+ if (*cp == '1') {
+ Init_Integer(out, 1);
+ return cp + 1;
+ }
+ }
+
+ REBYTE buf[MAX_NUM_LEN + 4];
+ if (len > MAX_NUM_LEN)
+ return_NULL; // prevent buffer overflow
+
+ REBYTE *bp = buf;
+
+ REBOOL neg = FALSE;
+
+ REBINT num = cast(REBINT, len);
+
+ // Strip leading signs:
+ if (*cp == '-') {
+ *bp++ = *cp++;
+ --num;
+ neg = TRUE;
+ }
+ else if (*cp == '+') {
+ ++cp;
+ --num;
+ }
+
+ // Remove leading zeros:
+ for (; num > 0; num--) {
+ if (*cp == '0' || *cp == '\'')
+ ++cp;
+ else
+ break;
+ }
+
+ if (num == 0) { // all zeros or '
+ // return early to avoid platform dependant error handling in CHR_TO_INT
+ Init_Integer(out, 0);
+ return cp;
+ }
+
+ // Copy all digits, except ' :
+ for (; num > 0; num--) {
+ if (*cp >= '0' && *cp <= '9')
+ *bp++ = *cp++;
+ else if (*cp == '\'')
+ ++cp;
+ else
+ return_NULL;
+ }
+ *bp = '\0';
+
+ // Too many digits?
+ len = bp - &buf[0];
+ if (neg)
+ --len;
+ if (len > 19) {
+ // !!! magic number :-( How does it relate to MAX_INT_LEN (also magic)
+ return_NULL;
+ }
+
+ // Convert, check, and return:
+ errno = 0;
+
+ VAL_RESET_HEADER(out, REB_INTEGER);
+
+ VAL_INT64(out) = CHR_TO_INT(buf);
+ if (errno != 0)
+ return_NULL; // overflow
+
+ if ((VAL_INT64(out) > 0 && neg) || (VAL_INT64(out) < 0 && !neg))
+ return_NULL;
+
+ return cp;
}
-/***********************************************************************
-**
-*/ REBYTE *Scan_Binary(REBYTE *cp, REBCNT len, REBVAL *value)
-/*
-** Scan and convert binary strings.
-**
-***********************************************************************/
-{
- REBYTE *ep;
- REBINT base = 16;
-
- if (*cp != '#') {
- ep = Grab_Int(cp, &base);
- if (cp == ep || *ep != '#') return 0;
- len -= (REBCNT)(ep - cp);
- cp = ep;
- }
- cp++; // skip #
- if (*cp++ != '{') return 0;
- len -= 2;
-
- cp = Decode_Binary(value, cp, len, base, '}');
- if (!cp) return 0;
-
- cp = Skip_To_Char(cp, cp + len, '}');
- if (!cp) return 0; // series will be gc'd
-
- return cp;
+//
+// Scan_Money: C
+//
+// Scan and convert money. Return zero if error.
+//
+const REBYTE *Scan_Money(
+ REBVAL *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT len
+) {
+ TRASH_CELL_IF_DEBUG(out);
+
+ const REBYTE *end;
+
+ if (*cp == '$') {
+ ++cp;
+ --len;
+ }
+ if (len == 0)
+ return_NULL;
+
+ Init_Money(out, string_to_deci(cp, &end));
+ if (end != cp + len)
+ return_NULL;
+
+ return end;
}
-/***********************************************************************
-**
-*/ REBYTE *Scan_Any(REBYTE *cp, REBCNT len, REBVAL *value, REBYTE type)
-/*
-** Scan any string that does not require special decoding.
-**
-***********************************************************************/
-{
- REBCNT n;
+//
+// Scan_Date: C
+//
+// Scan and convert a date. Also can include a time and zone.
+//
+const REBYTE *Scan_Date(
+ REBVAL *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT len
+) {
+ TRASH_CELL_IF_DEBUG(out);
+
+ const REBYTE *end = cp + len;
+
+ // Skip spaces:
+ for (; *cp == ' ' && cp != end; cp++);
+
+ // Skip day name, comma, and spaces:
+ const REBYTE *ep;
+ for (ep = cp; *ep != ',' && ep != end; ep++);
+ if (ep != end) {
+ cp = ep + 1;
+ while (*cp == ' ' && cp != end) cp++;
+ }
+ if (cp == end)
+ return_NULL;
+
+ REBINT num;
+
+ // Day or 4-digit year:
+ ep = Grab_Int(cp, &num);
+ if (num < 0)
+ return_NULL;
+
+ REBINT day;
+ REBINT month;
+ REBINT year;
+ REBINT tz = 0;
+
+ REBCNT size = cast(REBCNT, ep - cp);
+ if (size >= 4) {
+ // year is set in this branch (we know because day is 0)
+ // Ex: 2009/04/20/19:00:00+0:00
+ year = num;
+ day = 0;
+ }
+ else if (size) {
+ // year is not set in this branch (we know because day ISN'T 0)
+ // Ex: 12-Dec-2012
+ day = num;
+ if (day == 0)
+ return_NULL;
+
+ // !!! Clang static analyzer doesn't know from test of `day` below
+ // how it connects with year being set or not. Suppress warning.
+ year = MIN_I32; // !!! Garbage, should not be read.
+ }
+ else
+ return_NULL;
+
+ cp = ep;
+
+ // Determine field separator:
+ if (*cp != '/' && *cp != '-' && *cp != '.' && *cp != ' ')
+ return_NULL;
+
+ REBYTE sep = *cp++;
+
+ // Month as number or name:
+ ep = Grab_Int(cp, &num);
+ if (num < 0)
+ return_NULL;
+
+ size = cast(REBCNT, ep - cp);
+
+ if (size > 0)
+ month = num; // got a number
+ else { // must be a word
+ for (ep = cp; IS_LEX_WORD(*ep); ep++)
+ NOOP; // scan word
+
+ size = cast(REBCNT, ep - cp);
+ if (size < 3)
+ return_NULL;
+
+ for (num = 0; num < 12; num++) {
+ if (!Compare_Bytes(cb_cast(Month_Names[num]), cp, size, TRUE))
+ break;
+ }
+ month = num + 1;
+ }
+
+ if (month < 1 || month > 12)
+ return_NULL;
+
+ cp = ep;
+ if (*cp++ != sep)
+ return_NULL;
+
+ // Year or day (if year was first):
+ ep = Grab_Int(cp, &num);
+ if (*cp == '-' || num < 0)
+ return_NULL;
+
+ size = cast(REBCNT, ep - cp);
+ if (size == 0)
+ return_NULL;
+
+ if (day == 0) {
+ // year already set, but day hasn't been
+ day = num;
+ }
+ else {
+ // day has been set, but year hasn't been.
+ if (size >= 3)
+ year = num;
+ else {
+ // !!! Originally this allowed shorthands, so that 96 = 1996, etc.
+ //
+ // if (num >= 70)
+ // year = 1900 + num;
+ // else
+ // year = 2000 + num;
+ //
+ // It was trickier than that, because it actually used the current
+ // year (from the clock) to guess what the short year meant. That
+ // made it so the scanner would scan the same source code
+ // differently based on the clock, which is bad. By allowing
+ // short dates to be turned into their short year equivalents, the
+ // user code can parse such dates and fix them up after the fact
+ // according to their requirements, `if date/year < 100 [...]`
+ //
+ year = num;
+ }
+ }
+
+ if (year > MAX_YEAR || day < 1 || day > Month_Max_Days[month-1])
+ return_NULL;
+
+ // Check February for leap year or century:
+ if (month == 2 && day == 29) {
+ if (
+ ((year % 4) != 0) || // not leap year
+ ((year % 100) == 0 && // century?
+ (year % 400) != 0)
+ ){
+ return_NULL; // not leap century
+ }
+ }
+
+ cp = ep;
+
+ VAL_RESET_HEADER(out, REB_DATE);
+ VAL_NANO(out) = NO_TIME;
+
+ if (cp >= end)
+ goto end_date;
+
+ if (*cp == '/' || *cp == ' ') {
+ sep = *cp++;
+
+ if (cp >= end)
+ goto end_date;
+
+ cp = Scan_Time(out, cp, 0);
+ if (
+ cp == NULL
+ || !IS_TIME(out)
+ || (VAL_NANO(out) < 0)
+ || (VAL_NANO(out) >= SECS_TO_NANO(24 * 60 * 60))
+ ){
+ return_NULL;
+ }
+ }
+
+ if (*cp == sep) cp++;
+
+ // Time zone can be 12:30 or 1230 (optional hour indicator)
+ if (*cp == '-' || *cp == '+') {
+ if (cp >= end)
+ goto end_date;
+
+ ep = Grab_Int(cp + 1, &num);
+ if (ep - cp == 0)
+ return_NULL;
+
+ if (*ep != ':') {
+ if (num < -1500 || num > 1500)
+ return_NULL;
+
+ int h = (num / 100);
+ int m = (num - (h * 100));
+
+ tz = (h * 60 + m) / ZONE_MINS;
+ }
+ else {
+ if (num < -15 || num > 15)
+ return_NULL;
+
+ tz = num * (60 / ZONE_MINS);
+
+ if (*ep == ':') {
+ ep = Grab_Int(ep + 1, &num);
+ if (num % ZONE_MINS != 0)
+ return_NULL;
+
+ tz += num / ZONE_MINS;
+ }
+ }
+
+ if (ep != end)
+ return_NULL;
+
+ if (*cp == '-')
+ tz = -tz;
+
+ cp = ep;
+ }
- VAL_SET(value, type);
- VAL_SERIES(value) = Append_UTF8(0, cp, len);
- VAL_INDEX(value) = 0;
- VAL_TAIL(value) = len;
+end_date:
+ Set_Date_UTC(out, year, month, day, VAL_NANO(out), tz);
+ return cp;
+}
- if (VAL_BYTE_SIZE(value)) {
- n = Deline_Bytes(VAL_BIN(value), len);
- } else {
- n = Deline_Uni(VAL_UNI(value), len);
- }
- VAL_TAIL(value) = n;
- return cp + len;
+//
+// Scan_File: C
+//
+// Scan and convert a file name.
+//
+const REBYTE *Scan_File(
+ REBVAL *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT len
+) {
+ TRASH_CELL_IF_DEBUG(out);
+
+ if (*cp == '%') {
+ cp++;
+ len--;
+ }
+
+ REBUNI term = 0;
+ const REBYTE *invalid;
+ if (*cp == '"') {
+ cp++;
+ len--;
+ term = '"';
+ invalid = cb_cast(":;\"");
+ }
+ else {
+ term = 0;
+ invalid = cb_cast(":;()[]\"");
+ }
+
+ REB_MOLD mo;
+ CLEARS(&mo);
+
+ cp = Scan_Item_Push_Mold(&mo, cp, cp + len, term, invalid);
+ if (cp == NULL) {
+ Drop_Mold(&mo);
+ return_NULL;
+ }
+
+ Init_File(out, Pop_Molded_String(&mo));
+ return cp;
}
-/***********************************************************************
-**
-*/ static void Append_Markup(REBSER *series, REBCNT type, REBYTE *bp, REBINT len)
-/*
-** Add a new string or tag to a markup block, advancing the tail.
-**
-***********************************************************************/
-{
- REBVAL *val;
- if (SERIES_FULL(series)) Extend_Series(series, 8);
- val = BLK_TAIL(series);
- SET_END(val);
- series->tail++;
- SET_END(val+1);
- SET_STR_TYPE(type, val, Append_UTF8(0, bp, len));
+//
+// Scan_Email: C
+//
+// Scan and convert email.
+//
+const REBYTE *Scan_Email(
+ REBVAL *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT len
+) {
+ TRASH_CELL_IF_DEBUG(out);
+
+ REBSER *series = Make_Binary(len);
+
+ REBOOL at = FALSE;
+ REBYTE *str = BIN_HEAD(series);
+ for (; len > 0; len--) {
+ if (*cp == '@') {
+ if (at) return_NULL;
+ at = TRUE;
+ }
+
+ if (*cp == '%') {
+ REBUNI n;
+ if (len <= 2 || !Scan_Hex2(cp + 1, &n, FALSE))
+ return_NULL;
+ *str++ = cast(REBYTE, n);
+ cp += 3;
+ len -= 2;
+ }
+ else
+ *str++ = *cp++;
+ }
+ *str = 0;
+ if (NOT(at))
+ return_NULL;
+
+ SET_SERIES_LEN(series, cast(REBCNT, str - BIN_HEAD(series)));
+
+ Init_Email(out, series);
+ return cp;
}
-/***********************************************************************
-**
-*/ REBSER *Load_Markup(REBYTE *cp, REBINT len)
-/*
-** Scan a string as HTML or XML and convert it to a block
-** of strings and tags. Return the block as a series.
-**
-***********************************************************************/
-{
- REBYTE *bp = cp;
- REBSER *series;
- REBYTE quote;
-
- series = Make_Block(16);
- //DISABLE_GC;
-
- while (len > 0) {
- // Look for tag, gathering text as we go:
- for (; len > 0 && *cp != '<'; len--, cp++);
- if (len <= 0) break;
- if (!IS_LEX_WORD(cp[1]) && cp[1] != '/' && cp[1] != '?' && cp[1] != '!') {
- cp++; len--; continue;
- }
- if (cp != bp) Append_Markup(series, REB_STRING, bp, cp - bp);
- bp = ++cp; // skip <
-
- // Check for comment tag:
- if (*cp == '!' && len > 7 && cp[1] == '-' && cp[2] == '-') {
- for (len -= 3, cp += 3; len > 2 &&
- !(*cp == '-' && cp[1] == '-' && cp[2] == '>'); cp++, len--);
- if (len > 2) cp += 2, len -= 2;
- // fall into tag code below...
- }
- // Look for end of tag, watch for quotes:
- for (len--; len > 0; len--, cp++) {
- if (*cp == '>') {
- Append_Markup(series, REB_TAG, bp, cp - bp);
- bp = ++cp; len--;
- break;
- }
- if (*cp == '"' || *cp == '\'') { // quote in tag
- quote = *cp++;
- for (len--; len > 0 && *cp != quote; len--, cp++); // find end quote
- if (len <= 0) break;
- }
- }
- // Note: if final tag does not end, then it is treated as text.
- }
- if (cp != bp) Append_Markup(series, REB_STRING, bp, cp - bp);
- //ENABLE_GC;
-
- return series;
+//
+// Scan_URL: C
+//
+// Scan and convert a URL.
+//
+const REBYTE *Scan_URL(
+ REBVAL *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT len
+) {
+ TRASH_CELL_IF_DEBUG(out);
+
+// !!! Need to check for any possible scheme followed by ':'
+
+// for (n = 0; n < URL_MAX; n++) {
+// if (str = Match_Bytes(cp, (REBYTE *)(URL_Schemes[n]))) break;
+// }
+// if (n >= URL_MAX) return_NULL;
+// if (*str != ':') return_NULL;
+
+ REBSER *series = Make_Binary(len);
+
+ REBYTE *str = BIN_HEAD(series);
+ for (; len > 0; len--) {
+ //if (*cp == '%' && len > 2 && Scan_Hex2(cp+1, &n, FALSE)) {
+ if (*cp == '%') {
+ REBUNI n;
+ if (len <= 2 || !Scan_Hex2(cp + 1, &n, FALSE))
+ return_NULL;
+
+ *str++ = cast(REBYTE, n);
+ cp += 3;
+ len -= 2;
+ }
+ else
+ *str++ = *cp++;
+ }
+ *str = 0;
+ SET_SERIES_LEN(series, cast(REBCNT, str - BIN_HEAD(series)));
+
+ Init_Url(out, series);
+ return cp;
}
-/***********************************************************************
-**
-*/ REBFLG Construct_Value(REBVAL *value, REBSER *spec)
-/*
-** Lexical datatype constructor. Return TRUE on success.
-**
-** This function makes datatypes that are not normally expressible
-** in unevaluated source code format. The format of the datatype
-** constructor is:
-**
-** #[datatype! | keyword spec]
-**
-** The first item is a datatype word or NONE, FALSE or TRUE. The
-** second part is a specification for the datatype, as a basic
-** type (such as a string) or a block.
-**
-** Keep in mind that this function is being called as part of the
-** scanner, so optimal performance is critical.
-**
-***********************************************************************/
-{
- REBVAL *val;
- REBCNT type;
- MAKE_FUNC func;
+//
+// Scan_Pair: C
+//
+// Scan and convert a pair
+//
+const REBYTE *Scan_Pair(
+ REBVAL *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT len
+) {
+ TRASH_CELL_IF_DEBUG(out);
+
+ REBYTE buf[MAX_NUM_LEN + 4];
+
+ const REBYTE *ep = Scan_Dec_Buf(&buf[0], cp, MAX_NUM_LEN);
+ if (ep == NULL)
+ return_NULL;
+ if (*ep != 'x' && *ep != 'X')
+ return_NULL;
+
+ VAL_RESET_HEADER(out, REB_PAIR);
+ out->payload.pair = Alloc_Pairing(NULL);
+ VAL_RESET_HEADER(out->payload.pair, REB_DECIMAL);
+ VAL_RESET_HEADER(PAIRING_KEY(out->payload.pair), REB_DECIMAL);
+
+ VAL_PAIR_X(out) = cast(float, atof(cast(char*, &buf[0]))); //n;
+ ep++;
+
+ const REBYTE *xp = Scan_Dec_Buf(&buf[0], ep, MAX_NUM_LEN);
+ if (!xp) {
+ Free_Pairing(out->payload.pair);
+ return_NULL;
+ }
+
+ VAL_PAIR_Y(out) = cast(float, atof(cast(char*, &buf[0]))); //n;
+
+ if (len > cast(REBCNT, xp - cp)) {
+ Free_Pairing(out->payload.pair);
+ return_NULL;
+ }
+
+ Manage_Pairing(out->payload.pair);
+ return xp;
+}
- val = BLK_HEAD(spec);
- if (!IS_WORD(val)) return FALSE;
+//
+// Scan_Tuple: C
+//
+// Scan and convert a tuple.
+//
+const REBYTE *Scan_Tuple(
+ REBVAL *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT len
+) {
+ TRASH_CELL_IF_DEBUG(out);
- Set_Block(value, spec); //GC
+ if (len == 0)
+ return_NULL;
- // Handle the datatype or keyword:
- type = VAL_WORD_CANON(val);
- if (type > REB_MAX) { // >, not >=, because they are one-based
+ const REBYTE *ep;
+ REBCNT size = 1;
+ REBINT n;
+ for (n = cast(REBINT, len), ep = cp; n > 0; n--, ep++) { // count '.'
+ if (*ep == '.')
+ ++size;
+ }
- switch (type) {
+ if (size > MAX_TUPLE)
+ return_NULL;
- case SYM_NONE:
- SET_NONE(value);
- return TRUE;
+ if (size < 3)
+ size = 3;
- case SYM_FALSE:
- SET_FALSE(value);
- return TRUE;
+ VAL_RESET_HEADER(out, REB_TUPLE);
+ VAL_TUPLE_LEN(out) = cast(REBYTE, size);
- case SYM_TRUE:
- SET_TRUE(value);
- return TRUE;
+ REBYTE *tp = VAL_TUPLE(out);
+ memset(tp, 0, sizeof(REBTUP) - 2);
- default:
- return FALSE;
- }
- }
- type--; // The global word for datatype x is at word x+1.
+ for (ep = cp; len > cast(REBCNT, ep - cp); ++ep) {
+ ep = Grab_Int(ep, &n);
+ if (n < 0 || n > 255)
+ return_NULL;
+
+ *tp++ = cast(REBYTE, n);
+ if (*ep != '.')
+ break;
+ }
+
+ if (len > cast(REBCNT, ep - cp))
+ return_NULL;
+
+ return ep;
+}
- // Check for trivial types:
- if (type == REB_UNSET) {
- SET_UNSET(value);
- return TRUE;
- }
- if (type == REB_NONE) {
- SET_NONE(value);
- return TRUE;
- }
- val++;
- if (IS_END(val)) return FALSE;
+//
+// Scan_Binary: C
+//
+// Scan and convert binary strings.
+//
+const REBYTE *Scan_Binary(
+ REBVAL *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT len
+) {
+ TRASH_CELL_IF_DEBUG(out);
+
+ REBINT base = 16;
+
+ if (*cp != '#') {
+ const REBYTE *ep = Grab_Int(cp, &base);
+ if (cp == ep || *ep != '#')
+ return_NULL;
+ len -= cast(REBCNT, ep - cp);
+ cp = ep;
+ }
+
+ cp++; // skip #
+ if (*cp++ != '{')
+ return_NULL;
+
+ len -= 2;
+
+ cp = Decode_Binary(out, cp, len, base, '}');
+ if (cp == NULL)
+ return_NULL;
+
+ cp = Skip_To_Byte(cp, cp + len, '}');
+ if (cp == NULL)
+ return_NULL; // series will be gc'd
+
+ return cp + 1; // include the "}" in the scan total
+}
- // Dispatch maker:
- if (NZ(func = Make_Dispatch[type])) {
- if (func(value, val, type)) return TRUE;
- }
- return FALSE;
+//
+// Scan_Any: C
+//
+// Scan any string that does not require special decoding.
+//
+const REBYTE *Scan_Any(
+ REBVAL *out, // may live in data stack (do not call DS_PUSH, GC, eval)
+ const REBYTE *cp,
+ REBCNT num_bytes,
+ enum Reb_Kind type
+) {
+ TRASH_CELL_IF_DEBUG(out);
+
+ REBSER *s = Append_UTF8_May_Fail(NULL, cp, num_bytes); // NULL means alloc
+
+ REBCNT delined_len;
+ if (BYTE_SIZE(s)) {
+ delined_len = Deline_Bytes(BIN_HEAD(s), SER_LEN(s));
+ } else {
+ delined_len = Deline_Uni(UNI_HEAD(s), SER_LEN(s));
+ }
+
+ // We hand it over to management by the GC, but don't run the GC before
+ // the source has been scanned and put somewhere safe!
+ //
+ SET_SERIES_LEN(s, delined_len);
+ Init_Any_Series(out, type, s);
+
+ return cp + num_bytes;
}
-/***********************************************************************
-**
-*/ REBSER *Scan_Net_Header(REBSER *blk, REBYTE *str)
-/*
-** Scan an Internet-style header (HTTP, SMTP).
-** Fields with duplicate words will be merged into a block.
-**
-***********************************************************************/
+//
+// scan-net-header: native [
+// {Scan an Internet-style header (HTTP, SMTP).}
+//
+// header [string! binary!]
+// {Fields with duplicate words will be merged into a block.}
+// ]
+//
+REBNATIVE(scan_net_header)
+//
+// !!! This routine used to be a feature of CONSTRUCT in R3-Alpha, and was
+// used by %prot-http.r. The idea was that instead of providing a parent
+// object, a STRING! or BINARY! could be provided which would be turned
+// into a block by this routine.
+//
+// The only reason it seemed to support BINARY! was to optimize the case
+// where the binary only contained ASCII codepoints to dodge a string
+// conversion.
+//
+// It doesn't make much sense to have this coded in C rather than using PARSE
+// It's only being converted into a native to avoid introducing bugs by
+// rewriting it as Rebol in the middle of other changes.
{
- REBYTE *cp = str;
- REBYTE *start;
- REBVAL *val;
- REBINT len;
- REBSER *ser;
-
- while (IS_LEX_ANY_SPACE(*cp)) cp++; // skip white space
-
- while (1) {
- // Scan valid word:
- if (GET_LEX_CLASS(*cp) == LEX_CLASS_WORD) {
- start = cp;
- while (
- IS_LEX_AT_LEAST_WORD(*cp) || *cp == '.' || *cp == '-' || *cp == '_'
- ) cp++; // word char or number
- }
- else break;
-
- if (*cp == ':') {
- REBCNT sym = Make_Word(start, cp-start);
- cp++;
- // Search if word already present:
- for (val = BLK_HEAD(blk); NOT_END(val); val += 2) {
- if (VAL_WORD_SYM(val) == sym) {
- // Does it already use a block?
- if (IS_BLOCK(val+1)) {
- // Block of values already exists:
- val = Append_Value(VAL_SERIES(val+1));
- }
- else {
- // Create new block for values:
- REBVAL *val2;
- ser = Make_Block(2);
- val2 = Append_Value(ser); // prior value
- *val2 = val[1];
- Set_Block(val+1, ser);
- val = Append_Value(ser); // for new value
- }
- break;
- }
- }
- if (IS_END(val)) {
- val = Append_Value(blk); // add new word
- Init_Word(val, sym);
- VAL_SET(val, REB_SET_WORD);
- val = Append_Value(blk); // for new value
- }
- }
- else break;
-
- // Get value:
- while (IS_LEX_SPACE(*cp)) cp++;
- start = cp;
- len = 0;
- while (NOT_NEWLINE(*cp)) len++, cp++;
- // Is it continued on next line?
- while (*cp) {
- if (*cp == CR) cp++;
- if (*cp == LF) cp++;
- if (IS_LEX_SPACE(*cp)) {
- while (IS_LEX_SPACE(*cp)) cp++;
- while (NOT_NEWLINE(*cp)) len++, cp++;
- }
- else break;
- }
-
- // Create string value (ignoring lines and indents):
- ser = Make_Binary(len);
- ser->tail = len;
- str = STR_HEAD(ser);
- cp = start;
- // Code below *MUST* mirror that above:
- while (NOT_NEWLINE(*cp)) *str++ = *cp++;
- while (*cp) {
- if (*cp == CR) cp++;
- if (*cp == LF) cp++;
- if (IS_LEX_SPACE(*cp)) {
- while (IS_LEX_SPACE(*cp)) cp++;
- while (NOT_NEWLINE(*cp)) *str++ = *cp++;
- }
- else break;
- }
- *str = 0;
- Set_String(val, ser);
- }
-
- return blk;
+ INCLUDE_PARAMS_OF_SCAN_NET_HEADER;
+
+ REBARR *result = Make_Array(10); // Just a guess at size (use STD_BUF?)
+
+ // Convert string if necessary. Store back for GC safety.
+ //
+ REBVAL *header = ARG(header);
+ REBCNT index;
+ REBSER *utf8 = Temp_Bin_Str_Managed(header, &index, NULL);
+ INIT_VAL_SERIES(header, utf8); // GC protect, unnecessary?
+
+ REBYTE *cp = BIN_HEAD(utf8) + index;
+
+ while (IS_LEX_ANY_SPACE(*cp)) cp++; // skip white space
+
+ REBYTE *start;
+ REBINT len;
+
+ while (TRUE) {
+ // Scan valid word:
+ if (IS_LEX_WORD(*cp)) {
+ start = cp;
+ while (
+ IS_LEX_WORD_OR_NUMBER(*cp)
+ || *cp == '.'
+ || *cp == '-'
+ || *cp == '_'
+ ) {
+ cp++;
+ }
+ }
+ else break;
+
+ if (*cp != ':')
+ break;
+
+ REBVAL *val = NULL; // rigorous checks worry it could be uninitialized
+
+ REBSTR *name = Intern_UTF8_Managed(start, cp - start);
+ RELVAL *item;
+
+ cp++;
+ // Search if word already present:
+ for (item = ARR_HEAD(result); NOT_END(item); item += 2) {
+ assert(IS_STRING(item + 1) || IS_BLOCK(item + 1));
+ if (SAME_STR(VAL_WORD_SPELLING(item), name)) {
+ // Does it already use a block?
+ if (IS_BLOCK(item + 1)) {
+ // Block of values already exists:
+ val = Alloc_Tail_Array(VAL_ARRAY(item + 1));
+ }
+ else {
+ // Create new block for values:
+ REBARR *array = Make_Array(2);
+ Derelativize(
+ Alloc_Tail_Array(array),
+ item + 1, // prior value
+ SPECIFIED // no relative values added
+ );
+ val = Alloc_Tail_Array(array);
+ SET_UNREADABLE_BLANK(val); // for Init_Block
+ Init_Block(item + 1, array);
+ }
+ break;
+ }
+ }
+
+ if (IS_END(item)) { // didn't break, add space for new word/value
+ Init_Set_Word(Alloc_Tail_Array(result), name);
+ val = Alloc_Tail_Array(result);
+ }
+
+ while (IS_LEX_SPACE(*cp)) cp++;
+ start = cp;
+ len = 0;
+ while (!ANY_CR_LF_END(*cp)) {
+ len++;
+ cp++;
+ }
+ // Is it continued on next line?
+ while (*cp) {
+ if (*cp == CR) cp++;
+ if (*cp == LF) cp++;
+ if (IS_LEX_SPACE(*cp)) {
+ while (IS_LEX_SPACE(*cp)) cp++;
+ while (!ANY_CR_LF_END(*cp)) {
+ len++;
+ cp++;
+ }
+ }
+ else break;
+ }
+
+ // Create string value (ignoring lines and indents):
+ REBSER *string = Make_Binary(len);
+ SET_SERIES_LEN(string, len);
+ REBYTE *str = BIN_HEAD(string);
+ cp = start;
+ // Code below *MUST* mirror that above:
+ while (!ANY_CR_LF_END(*cp)) *str++ = *cp++;
+ while (*cp) {
+ if (*cp == CR) cp++;
+ if (*cp == LF) cp++;
+ if (IS_LEX_SPACE(*cp)) {
+ while (IS_LEX_SPACE(*cp)) cp++;
+ while (!ANY_CR_LF_END(*cp))
+ *str++ = *cp++;
+ }
+ else break;
+ }
+ *str = '\0';
+ Init_String(val, string);
+ }
+
+ Init_Block(D_OUT, result);
+ return R_OUT;
}
diff --git a/src/core/m-gc.c b/src/core/m-gc.c
old mode 100644
new mode 100755
index 8c86ed2e3f..fdd2cdef7b
--- a/src/core/m-gc.c
+++ b/src/core/m-gc.c
@@ -1,679 +1,1860 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: m-gc.c
-** Summary: main memory garbage collection
-** Section: memory
-** Author: Carl Sassenrath, Ladislav Mecir, HostileFork
-** Notes:
-** WARNING WARNING WARNING
-** This is highly tuned code that should only be modified by experts
-** who fully understand its design. It is very easy to create odd
-** side effects so please be careful and extensively test all changes!
-**
-** The process consists of two stages:
-**
-** MARK - Mark all series and gobs ("collectible values")
-* that can be found in:
-**
-** Root Block: special structures and buffers
-** Task Block: special structures and buffers per task
-** Data Stack: current state of evaluation
-** Safe Series: saves the last N allocations
-**
-** Mark is recursive until we reach the terminals, or
-** until we hit values already marked.
-**
-** SWEEP - Free all collectible values that were not marked.
-**
-** GC protection methods:
-**
-** KEEP flag - protects an individual series from GC, but
-** does not protect its contents (if it holds values).
-** Reserved for non-block system series.
-**
-** Root_Context - protects all series listed. This list is
-** used by Sweep as the root of the in-use memory tree.
-** Reserved for important system series only.
-**
-** Task_Context - protects all series listed. This list is
-** the same as Root, but per the current task context.
-**
-** Save_Series - protects temporary series. Used with the
-** SAVE_SERIES and UNSAVE_SERIES macros. Throws and errors
-** must roll back this series to avoid "stuck" memory.
-**
-** Safe_Series - protects last MAX_SAFE_SERIES series from GC.
-** Can only be used if no deeply allocating functions are
-** called within the scope of its protection. Not affected
-** by throws and errors.
-**
-** Data_Stack - all values in the data stack that are below
-** the TOP (DSP) are automatically protected. This is a
-** common protection method used by native functions.
-**
-** DISABLE_GC - macro that turns off GC. A quick way to avoid
-** GC, but must only be used for well-behaved sections
-** or could cause substantial memory growth.
-**
-** DONE flag - do not scan the series; it has no links.
-**
-***********************************************************************/
+//
+// File: %m-gc.c
+// Summary: "main memory garbage collection"
+// Section: memory
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Today's garbage collector is based on a conventional "mark and sweep",
+// of REBSER "nodes", which is how it was done in R3-Alpha:
+//
+// https://en.wikipedia.org/wiki/Tracing_garbage_collection
+//
+// A REBVAL's "payload" and "extra" field may or may not contain pointers to
+// REBSERs that the GC needs to be aware of. Some small values like LOGIC!
+// or INTEGER! don't, because they can fit the entirety of their data into the
+// REBVAL's 4*sizeof(void) cell...though this would change if INTEGER! added
+// support for arbitrary-sized-numbers.
+//
+// Some REBVALs embed REBSER pointers even when the payload would technically
+// fit inside their cell. They do this in order to create a level of
+// indirection so that their data can be shared among copies of that REBVAL.
+// For instance, HANDLE! does this.
+//
+// "Deep" marking in R3-Alpha was originally done with recursion, and the
+// recursion would stop whenever a mark was hit. But this meant deeply nested
+// structures could quickly wind up overflowing the C stack. Consider:
+//
+// a: copy []
+// loop 200'000 [a: append/only copy [] a]
+// recycle
+//
+// The simple solution is that when an unmarked array is hit that it is
+// marked and put into a queue for processing (instead of recursed on the
+// spot). This queue is then handled as soon as the marking call is exited,
+// and the process repeated until no more items are queued.
+//
+// !!! There is actually not a specific list of roots of the garbage collect,
+// so a first pass of all the REBSER nodes must be done to find them. This is
+// because with the redesigned "RL_API" in Ren-C, ordinary REBSER nodes do
+// double duty as lifetime-managed containers for REBVALs handed out by the
+// API--without requiring a separate series data allocation. These could be
+// in their own "pool", but that would prevent mingling and reuse among REBSER
+// nodes used for other purposes. Review in light of any new garbage collect
+// approaches used.
+//
#include "sys-core.h"
+
+#include "mem-pools.h" // low-level memory pool access
+#include "mem-series.h" // low-level series memory access
+
+#include "sys-int-funcs.h"
+
+
+//
+// !!! In R3-Alpha, the core included specialized structures which required
+// their own GC participation. This is because rather than store their
+// properties in conventional Rebol types (like an OBJECT!) they wanted to
+// compress their data into a tighter bit pattern than that would allow.
+//
+// Ren-C has attempted to be increasingly miserly about bytes, and also
+// added the ability for C extensions to hook the GC for a cleanup callback
+// relating to HANDLE! for any non-Rebol types. Hopefully this will reduce
+// the desire to hook the core garbage collector more deeply. If a tighter
+// structure is desired, that can be done with a HANDLE! or BINARY!, so long
+// as any Rebol series/arrays/contexts/functions are done with full values.
+//
+// Events, Devices, and Gobs are slated to be migrated to structures that
+// lean less heavily on C structs and raw C pointers, and leverage higher
+// level Rebol services. So ultimately their implementations would not
+// require including specialized code in the garbage collector. For the
+// moment, they still need the hook.
+//
+
#include "reb-evtypes.h"
+static void Queue_Mark_Event_Deep(const RELVAL *value);
+
+#define IS_GOB_MARK(g) \
+ GET_GOB_FLAG((g), GOBF_MARK)
+#define MARK_GOB(g) \
+ SET_GOB_FLAG((g), GOBF_MARK)
+#define UNMARK_GOB(g) \
+ CLR_GOB_FLAG((g), GOBF_MARK)
+static void Queue_Mark_Gob_Deep(REBGOB *gob);
+static REBCNT Sweep_Gobs(void);
+
+static void Mark_Devices_Deep(void);
-#ifdef REB_API
-extern REBOL_HOST_LIB *Host_Lib;
+
+#ifndef NDEBUG
+ static REBOOL in_mark = FALSE; // needs to be per-GC thread
#endif
-//-- For Serious Debugging:
-#ifdef WATCH_GC_VALUE
-REBSER *Watcher = 0;
-REBVAL *WatchVar = 0;
-REBVAL *GC_Break_Point(REBVAL *val) {return val;}
-REBVAL *N_watch(REBFRM *frame, REBVAL **inter_block)
+#define ASSERT_NO_GC_MARKS_PENDING() \
+ assert(SER_LEN(GC_Mark_Stack) == 0)
+
+
+// Private routines for dealing with the GC mark bit. Note that not all
+// REBSERs are actually series at the present time, because some are
+// "pairings". Plus the name Mark_Rebser_Only helps drive home that it's
+// not actually marking an "any_series" type (like array) deeply.
+//
+static inline void Mark_Rebser_Only(REBSER *s)
{
- WatchVar = Get_Word(FRM_ARG1(frame));
- Watcher = VAL_SERIES(WatchVar);
- SET_INTEGER(FRM_ARG1(frame), 0);
- return Nothing;
+#if !defined(NDEBUG)
+ if (NOT(IS_SERIES_MANAGED(s))) {
+ printf("Link to non-MANAGED item reached by GC\n");
+ panic (s);
+ }
+#endif
+ assert(NOT_SER_FLAG(s, SERIES_FLAG_ARRAY));
+
+ if (s->header.bits & SERIES_FLAG_FILE_LINE)
+ s->link.filename->header.bits |= NODE_FLAG_MARKED;
+ s->header.bits |= NODE_FLAG_MARKED;
+}
+
+static inline REBOOL Is_Rebser_Marked_Or_Pending(REBSER *rebser) {
+ return LOGICAL(rebser->header.bits & NODE_FLAG_MARKED);
+}
+
+static inline REBOOL Is_Rebser_Marked(REBSER *rebser) {
+ // ASSERT_NO_GC_MARKS_PENDING(); // overkill check, but must be true
+ return LOGICAL(rebser->header.bits & NODE_FLAG_MARKED);
+}
+
+static inline void Unmark_Rebser(REBSER *rebser) {
+ rebser->header.bits &= ~cast(REBUPT, NODE_FLAG_MARKED);
+}
+
+
+//
+// Queue_Mark_Array_Subclass_Deep: C
+//
+// Submits the array into the deferred stack to be processed later with
+// Propagate_All_GC_Marks(). If it were not queued and just used recursion
+// (as R3-Alpha did) then deeply nested arrays could overflow the C stack.
+//
+// Although there are subclasses of REBARR which have ->link and ->misc
+// and other properties that must be marked, the subclass processing is done
+// during the propagation. This is to prevent recursion from within the
+// subclass queueing routine itself. Hence this routine is the workhorse for
+// the subclasses, but there are type-checked specializations for clarity
+// if you have a REBFUN*, REBCTX*, etc.
+//
+// (Note: The data structure used for this processing is a "stack" and not
+// a "queue". But when you use 'queue' as a verb, it has more leeway than as
+// the CS noun, and can just mean "put into a list for later processing".)
+//
+static void Queue_Mark_Array_Subclass_Deep(REBARR *a)
+{
+#if !defined(NDEBUG)
+ if (IS_FREE_NODE(a))
+ panic (a);
+
+ if (NOT_SER_FLAG(a, SERIES_FLAG_ARRAY))
+ panic (a);
+
+ if (!IS_ARRAY_MANAGED(a))
+ panic (a);
+#endif
+
+ // A marked array doesn't necessarily mean all references reached from it
+ // have been marked yet--it could still be waiting in the queue. But we
+ // don't want to wastefully submit it to the queue multiple times.
+ //
+ if (Is_Rebser_Marked_Or_Pending(SER(a)))
+ return;
+
+ SER(a)->header.bits |= NODE_FLAG_MARKED; // the up-front marking
+
+ // Add series to the end of the mark stack series. The length must be
+ // maintained accurately to know when the stack needs to grow.
+ //
+ // !!! Should this use a "bumping a NULL at the end" technique to grow,
+ // like the data stack?
+ //
+ if (SER_FULL(GC_Mark_Stack))
+ Extend_Series(GC_Mark_Stack, 8);
+ *SER_AT(REBARR*, GC_Mark_Stack, SER_LEN(GC_Mark_Stack)) = a;
+ SET_SERIES_LEN(GC_Mark_Stack, SER_LEN(GC_Mark_Stack) + 1); // unterminated
+}
+
+inline static void Queue_Mark_Array_Deep(REBARR *a) {
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_VARLIST));
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_PARAMLIST));
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_PAIRLIST));
+
+ if (GET_SER_FLAG(a, SERIES_FLAG_FILE_LINE))
+ SER(a)->link.filename->header.bits |= NODE_FLAG_MARKED;
+
+ Queue_Mark_Array_Subclass_Deep(a);
+}
+
+inline static void Queue_Mark_Context_Deep(REBCTX *c) {
+ REBARR *a = CTX_VARLIST(c);
+ assert(GET_SER_FLAG(a, ARRAY_FLAG_VARLIST));
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_PARAMLIST));
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_PAIRLIST));
+ assert(NOT_SER_FLAG(a, SERIES_FLAG_FILE_LINE));
+
+ Queue_Mark_Array_Subclass_Deep(a);
+
+ // Further handling is in Propagate_All_GC_Marks() for ARRAY_FLAG_VARLIST
+ // where it can safely call Queue_Mark_Context_Deep() again without it
+ // being a recursion. (e.g. marking the context for this context's meta)
}
+
+inline static void Queue_Mark_Function_Deep(REBFUN *f) {
+ REBARR *a = FUNC_PARAMLIST(f);
+ assert(GET_SER_FLAG(a, ARRAY_FLAG_PARAMLIST));
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_VARLIST));
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_PAIRLIST));
+ assert(NOT_SER_FLAG(a, SERIES_FLAG_FILE_LINE));
+
+ Queue_Mark_Array_Subclass_Deep(a);
+
+ // Further handling is in Propagate_All_GC_Marks() for ARRAY_FLAG_PARAMLIST
+ // where it can safely call Queue_Mark_Function_Deep() again without it
+ // being a recursion. (e.g. marking underlying function for this function)
+}
+
+inline static void Queue_Mark_Map_Deep(REBMAP *m) {
+ REBARR *a = MAP_PAIRLIST(m);
+ assert(GET_SER_FLAG(a, ARRAY_FLAG_PAIRLIST));
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_PARAMLIST));
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_VARLIST));
+ assert(NOT_SER_FLAG(a, SERIES_FLAG_FILE_LINE));
+
+
+ Queue_Mark_Array_Subclass_Deep(a);
+
+ // Further handling is in Propagate_All_GC_Marks() for ARRAY_FLAG_PAIRLIST
+ // where it can safely call Queue_Mark_Map_Deep() again without it
+ // being a recursion. (e.g. marking underlying function for this function)
+}
+
+
+static void Queue_Mark_Opt_Value_Deep(const RELVAL *v);
+
+// A singular array, if you know it to be singular, can be marked a little
+// faster by avoiding a queue step for the array node or walk.
+//
+inline static void Queue_Mark_Singular_Array(REBARR *a) {
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_PAIRLIST));
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_PARAMLIST));
+ assert(NOT_SER_FLAG(a, ARRAY_FLAG_VARLIST));
+ assert(NOT_SER_FLAG(a, SERIES_FLAG_FILE_LINE));
+
+ assert(NOT_SER_INFO(a, SERIES_INFO_HAS_DYNAMIC));
+
+ SER(a)->header.bits |= NODE_FLAG_MARKED;
+ Queue_Mark_Opt_Value_Deep(ARR_HEAD(a));
+}
+
+
+//
+// Queue_Mark_Opt_Value_Deep: C
+//
+// This queues *optional* values, which may include void cells. If a slot is
+// not supposed to allow a void, use Queue_Mark_Value_Deep()
+//
+static void Queue_Mark_Opt_Value_Deep(const RELVAL *v)
+{
+ assert(NOT(in_mark));
+
+ // If this happens, it means somehow Recycle() got called between
+ // when an `if (Do_XXX_Throws())` branch was taken and when the throw
+ // should have been caught up the stack (before any more calls made).
+ //
+ assert(NOT(v->header.bits & VALUE_FLAG_THROWN));
+
+#if !defined(NDEBUG)
+ if (IS_UNREADABLE_IF_DEBUG(v))
+ return;
#endif
-// This can be put below
-#ifdef WATCH_GC_VALUE
- if (Watcher && ser == Watcher)
- GC_Break_Point(val);
+#if !defined(NDEBUG)
+ in_mark = TRUE;
+#endif
- // for (n = 0; n < depth * 2; n++) Prin_Str(" ");
- // Mark_Count++;
- // Print("Mark: %s %x", TYPE_NAME(val), val);
+ // This switch is done via contiguous REB_XXX values, in order to
+ // facilitate use of a "jump table optimization":
+ //
+ // http://stackoverflow.com/questions/17061967/c-switch-and-jump-tables
+ //
+ enum Reb_Kind kind = VAL_TYPE(v);
+ switch (kind) {
+ case REB_0:
+ //
+ // Should not be possible, REB_0 instances should not exist or
+ // be filtered out by caller.
+ //
+ panic (v);
+
+ case REB_FUNCTION: {
+ REBFUN *func = VAL_FUNC(v);
+ Queue_Mark_Function_Deep(func);
+
+ if (VAL_BINDING(v) != NULL)
+ Queue_Mark_Array_Subclass_Deep(VAL_BINDING(v));
+
+ #if !defined(NDEBUG)
+ //
+ // Make sure the [0] slot of the paramlist holds an archetype that is
+ // consistent with the paramlist itself.
+ //
+ REBVAL *archetype = FUNC_VALUE(func);
+ assert(FUNC_PARAMLIST(func) == VAL_FUNC_PARAMLIST(archetype));
+ assert(FUNC_BODY(func) == VAL_FUNC_BODY(archetype));
+
+ // It would be prohibitive to do validity checks on the facade of
+ // a function on each call to FUNC_FACADE, so it is checked here.
+ //
+ // Though a facade *may* be a paramlist, it could just be an array
+ // that *looks* like a paramlist, holding the underlying function the
+ // facade is "fronting for" in the head slot. The facade must always
+ // hold the same number of parameters as the underlying function.
+ //
+ REBARR *facade = SER(FUNC_PARAMLIST(func))->misc.facade;
+ assert(IS_FUNCTION(ARR_HEAD(facade)));
+ REBARR *underlying = ARR_HEAD(facade)->payload.function.paramlist;
+ if (underlying != facade) {
+ assert(NOT_SER_FLAG(facade, ARRAY_FLAG_PARAMLIST));
+ assert(GET_SER_FLAG(underlying, ARRAY_FLAG_PARAMLIST));
+ assert(ARR_LEN(facade) == ARR_LEN(underlying));
+ }
+ #endif
+ break; }
+
+ case REB_BAR:
+ case REB_LIT_BAR:
+ break;
+
+ case REB_WORD:
+ case REB_SET_WORD:
+ case REB_GET_WORD:
+ case REB_LIT_WORD:
+ case REB_REFINEMENT:
+ case REB_ISSUE: {
+ REBSTR *spelling = v->payload.any_word.spelling;
+
+ // A word marks the specific spelling it uses, but not the canon
+ // value. That's because if the canon value gets GC'd, then
+ // another value might become the new canon during that sweep.
+ //
+ Mark_Rebser_Only(spelling);
+
+ // A GC cannot run during a binding process--which is the only
+ // time a canon word's "index" field is allowed to be nonzero.
+ //
+ assert(
+ NOT_SER_INFO(spelling, STRING_INFO_CANON)
+ || (
+ spelling->misc.bind_index.high == 0
+ && spelling->misc.bind_index.low == 0
+ )
+ );
+
+ if (GET_VAL_FLAG(v, WORD_FLAG_BOUND)) {
+ assert(v->payload.any_word.index != 0);
+
+ if (GET_VAL_FLAG(v, VALUE_FLAG_RELATIVE)) {
+ // Bound relative to a function, keep that function alive.
+ //
+ // (To turn a relative binding into a specific one, a
+ // frame is needed from the BLOCK!/GROUP!/PATH! etc. that
+ // holds a word instance. So those frames are kept alive
+ // by the REB_BLOCK/REB_GROUP/REB_PATH lines in this switch
+ // where they mark their "binding" field.)
+ //
+ REBFUN* func = VAL_WORD_FUNC(v);
+ Queue_Mark_Function_Deep(func);
+ }
+ else {
+ // Bound to a specific context, keep that context alive.
+ //
+ REBCTX* context = VAL_WORD_CONTEXT(const_KNOWN(v));
+ Queue_Mark_Context_Deep(context);
+ }
+ }
+ else {
+ // The word is unbound...make sure index is 0 in debug build.
+ // (it can be left uninitialized in release builds, for now)
+ //
+ assert(!GET_VAL_FLAG(v, VALUE_FLAG_RELATIVE));
+ #if !defined(NDEBUG)
+ assert(v->payload.any_word.index == 0);
+ #endif
+ }
+ break; }
+
+ case REB_PATH:
+ case REB_SET_PATH:
+ case REB_GET_PATH:
+ case REB_LIT_PATH:
+ case REB_BLOCK:
+ case REB_GROUP: {
+ if (IS_SPECIFIC(v)) {
+ REBSPC *specifier = VAL_SPECIFIER(const_KNOWN(v));
+ if (specifier != SPECIFIED)
+ Queue_Mark_Context_Deep(CTX(specifier));
+ }
+ else {
+ // We trust that if a relative array's context needs to make
+ // it into the transitive closure, that will be taken care
+ // of by a higher-up array reference that holds it.
+ //
+ REBFUN* func = VAL_RELATIVE(v);
+ Queue_Mark_Function_Deep(func);
+ }
+
+ Queue_Mark_Array_Deep(VAL_ARRAY(v));
+ break; }
+
+ case REB_BINARY:
+ case REB_STRING:
+ case REB_FILE:
+ case REB_EMAIL:
+ case REB_URL:
+ case REB_TAG:
+ case REB_BITSET: {
+ REBSER *series = VAL_SERIES(v);
+ assert(SER_WIDE(series) <= sizeof(REBUNI));
+ Mark_Rebser_Only(series);
+ break; }
+
+ case REB_HANDLE: { // See %sys-handle.h
+ REBARR *singular = v->extra.singular;
+ if (singular == NULL) {
+ //
+ // This HANDLE! was created with Init_Handle_Simple. There is
+ // no GC interaction.
+ }
+ else {
+ // Handle was created with Init_Handle_Managed. It holds a
+ // REBSER node that contains exactly one handle, and the actual
+ // data for the handle lives in that shared location. There is
+ // nothing the GC needs to see inside a handle.
+ //
+ SER(singular)->header.bits |= NODE_FLAG_MARKED;
+
+ #if !defined(NDEBUG)
+ assert(ARR_LEN(singular) == 1);
+ RELVAL *single = ARR_HEAD(singular);
+ assert(IS_HANDLE(single));
+ assert(single->extra.singular == v->extra.singular);
+ if (v != single) {
+ //
+ // In order to make it clearer that individual handles do not
+ // hold the shared data (there'd be no way to update all the
+ // references at once), the data pointers in all but the
+ // shared singular value are NULL.
+ //
+ if (GET_VAL_FLAG(v, HANDLE_FLAG_CFUNC))
+ assert(
+ IS_CFUNC_TRASH_DEBUG(v->payload.handle.data.cfunc)
+ );
+ else
+ assert(
+ IS_POINTER_TRASH_DEBUG(v->payload.handle.data.pointer)
+ );
+ }
+ #endif
+ }
+ break; }
+
+ case REB_IMAGE:
+ Mark_Rebser_Only(VAL_SERIES(v));
+ break;
+
+ case REB_VECTOR:
+ Mark_Rebser_Only(VAL_SERIES(v));
+ break;
+
+ case REB_BLANK:
+ case REB_LOGIC:
+ case REB_INTEGER:
+ case REB_DECIMAL:
+ case REB_PERCENT:
+ case REB_MONEY:
+ case REB_CHAR:
+ break;
+
+ case REB_PAIR: {
+ //
+ // Ren-C's PAIR! uses a special kind of REBSER that does no additional
+ // memory allocation, but embeds two REBVALs in the REBSER itself.
+ // A REBVAL has a REBUPT-sized header at the beginning of its struct,
+ // just like a REBSER, and the NODE_FLAG_MARKED bit is a 0
+ // if unmarked...so it can stealthily participate in the marking
+ // process, as long as the bit is cleared at the end.
+ //
+ REBSER *pairing = cast(REBSER*, PAIRING_KEY(v->payload.pair));
+ pairing->header.bits |= NODE_FLAG_MARKED; // read via REBSER
+ break; }
+
+ case REB_TUPLE:
+ case REB_TIME:
+ case REB_DATE:
+ break;
+
+ case REB_MAP: {
+ REBMAP* map = VAL_MAP(v);
+ Queue_Mark_Map_Deep(map);
+ break;
+ }
+
+ case REB_DATATYPE:
+ // Type spec is allowed to be NULL. See %typespec.r file
+ if (VAL_TYPE_SPEC(v))
+ Queue_Mark_Array_Deep(VAL_TYPE_SPEC(v));
+ break;
+
+ case REB_TYPESET:
+ //
+ // Not all typesets have symbols--only those that serve as the
+ // keys of objects (or parameters of functions)
+ //
+ if (v->extra.key_spelling != NULL)
+ Mark_Rebser_Only(v->extra.key_spelling);
+ break;
+
+ case REB_VARARGS: {
+ //
+ // Binding may be NULL if the varargs was a MAKE VARARGS! and hasn't
+ // been passed through any parameter. Otherwise it is the frame
+ // context where the param and arg live (possibly expired).
+ //
+ REBARR *binding = v->extra.binding;
+ if (binding != NULL) {
+ if (IS_ARRAY_MANAGED(binding))
+ Queue_Mark_Context_Deep(CTX(v->extra.binding));
+ else {
+ // !!! Should assert that the binding is to a frame that is
+ // in mid-fulfillment on the stack
+ }
+ }
+
+ // The data feed is either a frame context or a singular block which
+ // holds the shared index among all same varargs into that array.
+ //
+ REBARR *feed = v->payload.varargs.feed;
+ assert(GET_SER_FLAG(feed, ARRAY_FLAG_VARLIST) || ARR_LEN(feed) == 1);
+ if (IS_ARRAY_MANAGED(feed))
+ Queue_Mark_Array_Subclass_Deep(feed);
+ else {
+ // !!! Should also assert that this is a frame in mid-fulfillment
+ // on the stack.
+ //
+ assert(GET_SER_FLAG(feed, ARRAY_FLAG_VARLIST));
+ }
+ break; }
+
+ case REB_OBJECT:
+ case REB_FRAME:
+ case REB_MODULE:
+ case REB_ERROR:
+ case REB_PORT: {
+ REBCTX *context = VAL_CONTEXT(v);
+ Queue_Mark_Context_Deep(context);
+
+ // Currently the "binding" in a context is only used by FRAME! to
+ // preserve the binding of the FUNCTION! value that spawned that
+ // frame. Currently that binding is typically NULL inside of a
+ // function's REBVAL unless it is a definitional RETURN or LEAVE.
+ //
+ // !!! Expanded usages may be found in other situations that mix an
+ // archetype with an instance (e.g. an archetypal function body that
+ // could apply to any OBJECT!, but the binding cheaply makes it
+ // a method for that object.)
+ //
+ REBARR *binding = VAL_BINDING(v);
+ if (binding != NULL) {
+ assert(CTX_TYPE(context) == REB_FRAME);
+
+ #if !defined(NDEBUG)
+ if (CTX_VARS_UNAVAILABLE(context)) {
+ //
+ // !!! It seems a bit wasteful to keep alive the binding of a
+ // stack frame you can no longer get values out of. But
+ // However, FUNCTION-OF still works on a FRAME! value after
+ // the function is finished, if the FRAME! value was kept.
+ // And that needs to give back a correct binding.
+ //
+ }
+ else {
+ struct Reb_Frame *f = CTX_FRAME_IF_ON_STACK(context);
+ if (f != NULL) // comes from execution, not MAKE FRAME!
+ assert(binding == f->binding);
+ }
+ #endif
+
+ Queue_Mark_Array_Subclass_Deep(binding);
+ }
+
+ REBFUN *phase = v->payload.any_context.phase;
+ if (phase != NULL) {
+ if (CTX_TYPE(context) != REB_FRAME)
+ panic (context);
+ Queue_Mark_Function_Deep(phase);
+ }
+
+ #if !defined(NDEBUG)
+ REBVAL *archetype = CTX_VALUE(context);
+ assert(CTX_TYPE(context) == VAL_TYPE(v));
+ assert(VAL_CONTEXT(archetype) == context);
+ assert(VAL_CONTEXT_META(archetype) == CTX_META(context));
+ #endif
+
+ // Note: for VAL_CONTEXT_FRAME, the FRM_CALL is either on the stack
+ // (in which case it's already taken care of for marking) or it
+ // has gone bad, in which case it should be ignored.
+
+ break; }
+
+ case REB_GOB:
+ Queue_Mark_Gob_Deep(VAL_GOB(v));
+ break;
+
+ case REB_EVENT:
+ Queue_Mark_Event_Deep(v);
+ break;
+
+ case REB_STRUCT: {
+ //
+ // The struct gets its GC'able identity and is passable by one
+ // pointer from the fact that it is a single-element array that
+ // contains the REBVAL of the struct itself. (Because it is
+ // "singular" it is only a REBSER node--no data allocation.)
+ //
+ Queue_Mark_Array_Deep(VAL_STRUCT(v));
+
+ // The schema is the hierarchical description of the struct.
+ //
+ REBFLD *schema = SER(VAL_STRUCT(v))->link.schema;
+ assert(FLD_IS_STRUCT(schema));
+ Queue_Mark_Array_Deep(schema);
+
+ // The symbol needs to be GC protected, but only fields have them
+ //
+ assert(FLD_NAME(schema) == NULL);
+
+ // The data series needs to be marked. It needs to be marked
+ // even for structs that aren't at the 0 offset--because their
+ // lifetime can be longer than the struct which they represent
+ // a "slice" out of.
+ //
+ // Note this may be a singular array handle, or it could be a BINARY!
+ //
+ Mark_Rebser_Only(v->payload.structure.data);
+ break; }
+
+ case REB_LIBRARY: {
+ Queue_Mark_Array_Deep(VAL_LIBRARY(v));
+ REBCTX *meta = VAL_LIBRARY_META(v);
+ if (meta != NULL)
+ Queue_Mark_Context_Deep(meta);
+ break; }
+
+ case REB_MAX_VOID:
+ //
+ // Not an actual ANY-VALUE! "value", just a void cell. Instead of
+ // this "Opt"ional routine, use Queue_Mark_Value_Deep() on slots
+ // that should not be void.
+ //
+ break;
+
+ default:
+ panic (v);
+ }
+
+#if !defined(NDEBUG)
+ in_mark = FALSE;
#endif
+}
+
+inline static void Queue_Mark_Value_Deep(const RELVAL *v)
+{
+#if !defined(NDEBUG)
+ if (IS_VOID(v))
+ panic (v);
+#endif
+ Queue_Mark_Opt_Value_Deep(v);
+}
+
+
+//
+// Propagate_All_GC_Marks: C
+//
+// The Mark Stack is a series containing series pointers. They have already
+// had their SERIES_FLAG_MARK set to prevent being added to the stack multiple
+// times, but the items they can reach are not necessarily marked yet.
+//
+// Processing continues until all reachable items from the mark stack are
+// known to be marked.
+//
+static void Propagate_All_GC_Marks(void)
+{
+ assert(!in_mark);
+
+ while (SER_LEN(GC_Mark_Stack) != 0) {
+ SET_SERIES_LEN(GC_Mark_Stack, SER_LEN(GC_Mark_Stack) - 1); // still ok
+
+ // Data pointer may change in response to an expansion during
+ // Mark_Array_Deep_Core(), so must be refreshed on each loop.
+ //
+ REBARR *a = *SER_AT(REBARR*, GC_Mark_Stack, SER_LEN(GC_Mark_Stack));
+
+ // Termination is not required in the release build (the length is
+ // enough to know where it ends). But overwrite with trash in debug.
+ //
+ TRASH_POINTER_IF_DEBUG(
+ *SER_AT(REBARR*, GC_Mark_Stack, SER_LEN(GC_Mark_Stack))
+ );
+
+ // We should have marked this series at queueing time to keep it from
+ // being doubly added before the queue had a chance to be processed
+ //
+ assert(Is_Rebser_Marked(SER(a)));
+
+ #ifdef HEAVY_CHECKS
+ //
+ // The GC is a good general hook point that all series which have been
+ // managed will go through, so it's a good time to assert properties
+ // about the array.
+ //
+ ASSERT_ARRAY(a);
+ #else
+ //
+ // For a lighter check, make sure it's marked as a value-bearing array
+ // and that it hasn't been freed.
+ //
+ assert(GET_SER_FLAG(a, SERIES_FLAG_ARRAY));
+ assert(!IS_FREE_NODE(SER(a)));
+ #endif
+
+ RELVAL *v = ARR_HEAD(a);
+
+ if (GET_SER_FLAG(a, ARRAY_FLAG_PARAMLIST)) {
+ //
+ // These queueings cannot be done in Queue_Mark_Function_Deep
+ // because of the potential for overflowing the C stack with calls
+ // to Queue_Mark_Function_Deep.
+
+ REBARR *body_holder = v->payload.function.body_holder;
+ Queue_Mark_Singular_Array(body_holder);
+
+ REBCTX *exemplar = SER(body_holder)->link.exemplar;
+ if (exemplar != NULL)
+ Queue_Mark_Context_Deep(exemplar);
+
+ REBCTX *meta = SER(a)->link.meta;
+ if (meta != NULL)
+ Queue_Mark_Context_Deep(meta);
+
+ REBARR *facade = SER(a)->misc.facade;
+ Queue_Mark_Array_Subclass_Deep(facade);
+
+ assert(IS_FUNCTION(v));
+ assert(v->extra.binding == NULL); // archetypes have no binding
+ ++v; // function archetype completely marked by this process
+ }
+ else if (GET_SER_FLAG(a, ARRAY_FLAG_VARLIST)) {
+ //
+ // These queueings cannot be done in Queue_Mark_Context_Deep
+ // because of the potential for overflowing the C stack with calls
+ // to Queue_Mark_Context_Deep.
+
+ REBARR *keylist = SER(a)->link.keylist;
+ assert(keylist == CTX_KEYLIST(CTX(a)));
+ Queue_Mark_Array_Subclass_Deep(keylist); // might be paramlist
+
+ REBCTX *meta = SER(keylist)->link.meta;
+ if (meta != NULL)
+ Queue_Mark_Context_Deep(meta);
+
+ assert(ANY_CONTEXT(v));
+ assert(v->extra.binding == NULL); // archetypes have no binding
+ ++v; // context archtype completely marked by this process
+ }
+ else if (GET_SER_FLAG(a, ARRAY_FLAG_PAIRLIST)) {
+ //
+ // There was once a "small map" optimization that wouldn't
+ // produce a hashlist for small maps and just did linear search.
+ // @giuliolunati deleted that for the time being because it
+ // seemed to be a source of bugs, but it may be added again...in
+ // which case the hashlist may be NULL.
+ //
+ REBSER *hashlist = SER(a)->link.hashlist;
+ assert(hashlist != NULL);
+
+ Mark_Rebser_Only(hashlist);
+ }
+
+ if (GET_SER_INFO(a, SERIES_INFO_INACCESSIBLE)) {
+ //
+ // At present the only inaccessible arrays are expired frames of
+ // functions with stack-bound arg and local lifetimes. They are
+ // just singular REBARRs with the FRAME! archetype value.
+ //
+ assert(GET_SER_FLAG(a, ARRAY_FLAG_VARLIST));
+ assert(IS_FRAME(ARR_HEAD(a)));
+ assert(GET_SER_INFO(a, CONTEXT_INFO_STACK));
+ continue;
+ }
+
+ for (; NOT_END(v); ++v) {
+ Queue_Mark_Opt_Value_Deep(v);
+ //
+ #if !defined(NDEBUG)
+ //
+ // Voids are illegal in most arrays, but the varlist of a context
+ // uses void values to denote that the variable is not set. Also
+ // reified C va_lists as Do_Core() sources can have them.
+ //
+ if (NOT(IS_BLANK_RAW(v)) && IS_VOID(v)) {
+ if(
+ !GET_SER_FLAG(a, ARRAY_FLAG_VARLIST)
+ && !GET_SER_FLAG(a, ARRAY_FLAG_VOIDS_LEGAL)
+ )
+ panic(a);
+ }
+ #endif
+ }
+ }
+}
+
-static void Mark_Series(REBSER *series, REBCNT depth);
+//
+// Reify_Any_C_Valist_Frames: C
+//
+// Some of the call stack frames may have been invoked with a C function call
+// that took a comma-separated list of REBVAL (the way printf works, a
+// variadic "va_list").
+//
+// http://en.cppreference.com/w/c/variadic
+//
+// Although it's a list of REBVAL*, these call frames have no REBARR series
+// behind. Yet they still need to be enumerated to protect the values coming
+// up in the later DO/NEXTs. But enumerating a C va_list can't be undone.
+// The REBVAL* is lost if it isn't saved, and these frames may be in
+// mid-evaluation.
+//
+// Hence, the garbage collector has to "reify" the remaining portion of the
+// va_list into a REBARR before starting the GC. Then the rest of the
+// evaluation happens on that array.
+//
+static void Reify_Any_C_Valist_Frames(void)
+{
+ // IMPORTANT: This must be done *before* any of the mark/sweep logic
+ // begins, because it creates new arrays. In the future it may be
+ // possible to introduce new series in mid-garbage collection (which would
+ // be necessary for an incremental garbage collector), but for now the
+ // feature is not supported.
+ //
+ ASSERT_NO_GC_MARKS_PENDING();
+
+ REBFRM *f = FS_TOP;
+ for (; f != NULL; f = f->prior) {
+ if (f->flags.bits & DO_FLAG_VA_LIST) {
+ const REBOOL truncated = TRUE;
+ Reify_Va_To_Array_In_Frame(f, truncated);
+ }
+ }
+}
+
+
+//
+// Mark_Root_Series: C
+//
+// In Ren-C, there is a concept of there being an open number of GC roots.
+// Through the API, each cell held by a "paired" which is under GC management
+// is considered to be a root.
+//
+// There is also a special ability of a paired, such that if the "key" is
+// a frame with a certain bit set, then it will tie its lifetime to the
+// lifetime of that frame on the stack. (Not to the lifetime of the FRAME!
+// value itself, which could be indefinite.)
+//
+static void Mark_Root_Series(void)
+{
+ REBSEG *seg;
+ for (seg = Mem_Pools[SER_POOL].segs; seg; seg = seg->next) {
+ REBSER *s = cast(REBSER *, seg + 1);
+ REBCNT n;
+ for (n = Mem_Pools[SER_POOL].units; n > 0; --n, ++s) {
+ if (IS_FREE_NODE(s))
+ continue;
+
+ assert(NOT(Is_Rebser_Marked(s))); // can't be marked yet
+
+ if (NOT(s->header.bits & NODE_FLAG_ROOT))
+ continue;
+
+ // If something is marked as a root, then it has its contents
+ // GC managed...even if it is not itself a candidate for GC.
+
+ if (s->header.bits & NODE_FLAG_CELL) {
+ //
+ // There is a special feature of root paired series, which
+ // is that if the "key" is a frame marked in a certain way,
+ // it will tie its lifetime to that of the execution of that
+ // frame. When the frame is done executing, it will no
+ // longer preserve the paired.
+ //
+ // (Note: This does not have anything to do with the lifetime
+ // of the FRAME! value itself, which could be indefinite.)
+ //
+ // !!! Does it need to check for pending? Could it be set
+ // up such that you can't make an owning frame that's in
+ // a pending state?
+ //
+ REBVAL *key = cast(REBVAL*, s);
+ REBVAL *paired = key + 1;
+ if (
+ IS_FRAME(key)
+ && GET_VAL_FLAG(key, ANY_CONTEXT_FLAG_OWNS_PAIRED)
+ && !Is_Context_Running_Or_Pending(VAL_CONTEXT(key))
+ ){
+ Free_Pairing(paired); // don't consider a root
+ continue;
+ }
+
+ // It's alive and a root. Pick up its dependencies deeply.
+ // Note that ENDs are allowed because for instance, a DO
+ // might be executed with the pairing as the OUT slot (since
+ // it is memory guaranteed not to relocate)
+ //
+ Mark_Rebser_Only(s);
+ Queue_Mark_Value_Deep(key);
+ if (NOT_END(paired))
+ Queue_Mark_Value_Deep(paired);
+ }
+ else {
+ // We have to do the queueing based on whatever type of series
+ // this is. So if it's a context, we have to get the
+ // keylist...etc.
+ //
+ if (GET_SER_FLAG(s, SERIES_FLAG_ARRAY))
+ Queue_Mark_Array_Subclass_Deep(ARR(s));
+ else
+ Mark_Rebser_Only(s);
+ }
+ }
+ }
+
+ Propagate_All_GC_Marks();
+}
-/***********************************************************************
-**
-*/ static void Mark_Gob(REBGOB *gob, REBCNT depth)
-/*
-***********************************************************************/
+//
+// Mark_Data_Stack: C
+//
+// The data stack logic is that it is contiguous values with no END markers
+// except at the array end. Bumping up against that END signal is how the
+// stack knows when it needs to grow.
+//
+// But every drop of the stack doesn't overwrite the dropped value. Since the
+// values are not END markers, they are considered fine as far as a NOT_END()
+// test is concerned to indicate unused capacity. So the values are good
+// for the testing purpose, yet the GC doesn't want to consider those to be
+// "live" references. So rather than to a full Queue_Mark_Array_Deep() on
+// the capacity of the data stack's underlying array, it begins at DS_TOP.
+//
+static void Mark_Data_Stack(void)
{
- REBGOB **pane;
- REBCNT i;
+ assert(IS_UNREADABLE_IF_DEBUG(&DS_Movable_Base[0]));
+
+ REBVAL *stackval = DS_TOP;
+ for (; stackval != &DS_Movable_Base[0]; --stackval) {
+ //
+ // During path evaluation, function refinements are pushed to the
+ // data stack as WORD!. If the order of definition of refinements
+ // in the function spec doesn't match the order of usage, then the
+ // refinement will need to be revisited. The WORD! is converted
+ // into a "pickup" which stores the parameter and argument position.
+ // These are only legal on the data stack, and are skipped by the GC.
+ //
+ if (VAL_TYPE(stackval) == REB_0_PICKUP)
+ continue;
+
+ Queue_Mark_Value_Deep(stackval);
+ }
+
+ Propagate_All_GC_Marks();
+}
- if (IS_GOB_MARK(gob)) return;
- MARK_GOB(gob);
+//
+// Mark_Symbol_Series: C
+//
+// Mark symbol series. These canon words for SYM_XXX are the only ones that
+// are never candidates for GC (until shutdown). All other symbol series may
+// go away if no words, parameters, object keys, etc. refer to them.
+//
+static void Mark_Symbol_Series(void)
+{
+ REBSTR **canon = SER_HEAD(REBSTR*, PG_Symbol_Canons);
+ assert(IS_POINTER_TRASH_DEBUG(*canon)); // SYM_0 is for all non-builtin words
+ ++canon;
+ for (; *canon != NULL; ++canon)
+ Mark_Rebser_Only(*canon);
- if (GOB_PANE(gob)) {
- MARK_SERIES(GOB_PANE(gob));
- pane = GOB_HEAD(gob);
- for (i = 0; i < GOB_TAIL(gob); i++, pane++) {
- Mark_Gob(*pane, depth);
- }
- }
+ ASSERT_NO_GC_MARKS_PENDING(); // doesn't ues any queueing
+}
- if (GOB_PARENT(gob)) Mark_Gob(GOB_PARENT(gob), depth);
- if (GOB_CONTENT(gob)) {
- if (GOB_TYPE(gob) >= GOBT_IMAGE && GOB_TYPE(gob) <= GOBT_STRING) {
- MARK_SERIES(GOB_CONTENT(gob));
- } else if (GOB_TYPE(gob) >= GOBT_DRAW && GOB_TYPE(gob) <= GOBT_EFFECT) {
- CHECK_MARK(GOB_CONTENT(gob), depth);
- }
- }
+//
+// Mark_Natives: C
+//
+// For each native C implemenation, a REBVAL is created during init to
+// represent it as a FUNCTION!. These are kept in a global array and are
+// protected from GC. It might not technically be necessary to do so for
+// all natives, but at least some have their paramlists referenced by the
+// core code (such as RETURN).
+//
+static void Mark_Natives(void)
+{
+ REBCNT n;
+ for (n = 0; n < NUM_NATIVES; ++n)
+ Queue_Mark_Value_Deep(&Natives[n]);
- if (GOB_DATA(gob) && GOB_DTYPE(gob) && GOB_DTYPE(gob) != GOBD_INTEGER) {
- CHECK_MARK(GOB_DATA(gob), depth);
- }
+ Propagate_All_GC_Marks();
}
-/***********************************************************************
-**
-*/ static void Mark_Event(REBVAL *value, REBCNT depth)
-/*
-***********************************************************************/
+//
+// Mark_Guarded_Nodes: C
+//
+// Mark series and values that have been temporarily protected from garbage
+// collection with PUSH_GUARD_SERIES and PUSH_GUARD_VALUE.
+//
+// Note: If the REBSER is actually a REBCTX, REBFUN, or REBARR then the
+// reachable values for the series will be guarded appropriate to its type.
+// (e.g. guarding a REBSER of an array will mark the values in that array,
+// not just shallow mark the REBSER node)
+//
+static void Mark_Guarded_Nodes(void)
{
- REBREQ *req;
-
- if (
- IS_EVENT_MODEL(value, EVM_PORT)
- || IS_EVENT_MODEL(value, EVM_OBJECT)
- || (VAL_EVENT_TYPE(value) == EVT_DROP_FILE && GET_FLAG(VAL_EVENT_FLAGS(value), EVF_COPIED))
- ) {
- // The ->ser field of the REBEVT is void*, so we must cast
- // Comment says it is a "port or object"
- CHECK_MARK((REBSER*)VAL_EVENT_SER(value), depth);
- }
-
- if (IS_EVENT_MODEL(value, EVM_DEVICE)) {
- // In the case of being an EVM_DEVICE event type, the port! will
- // not be in VAL_EVENT_SER of the REBEVT structure. It is held
- // indirectly by the REBREQ ->req field of the event, which
- // in turn possibly holds a singly linked list of other requests.
- req = VAL_EVENT_REQ(value);
-
- while(req) {
- // The ->port field of the REBREQ is void*, so we must cast
- // Comment says it is "link back to REBOL port object"
- if (req->port) CHECK_MARK((REBSER*)req->port, depth);
- req = req->next;
- }
- }
-}
-
-/***********************************************************************
-**
-*/ static void Mark_Devices(REBCNT depth)
-/*
-** Mark all devices. Search for pending requests.
-**
-***********************************************************************/
+ REBNOD **np = SER_HEAD(REBNOD*, GC_Guarded);
+ REBCNT n = SER_LEN(GC_Guarded);
+ for (; n > 0; --n, ++np) {
+ REBNOD *node = *np;
+ if (node->header.bits & NODE_FLAG_CELL) { // a value cell
+ if (NOT(node->header.bits & NODE_FLAG_END))
+ Queue_Mark_Opt_Value_Deep(cast(REBVAL*, node));
+ }
+ else { // a series
+ REBSER *s = cast(REBSER*, node);
+ if (GET_SER_FLAG(s, SERIES_FLAG_ARRAY))
+ Queue_Mark_Array_Subclass_Deep(ARR(s));
+ else
+ Mark_Rebser_Only(s);
+ }
+ Propagate_All_GC_Marks();
+ }
+}
+
+
+//
+// Mark_Frame_Stack_Deep: C
+//
+// Mark values being kept live by all call frames. If a function is running,
+// then this will keep the function itself live, as well as the arguments.
+// There is also an "out" slot--which may point to an arbitrary REBVAL cell
+// on the C stack. The out slot is initialized to an END marker at the
+// start of every function call, so that it won't be uninitialized bits
+// which would crash the GC...but it must be turned into a value (or a void)
+// by the time the function is finished running.
+//
+// Since function argument slots are not pre-initialized, how far the function
+// has gotten in its fulfillment must be taken into account. Only those
+// argument slots through points of fulfillment may be GC protected.
+//
+// This should be called at the top level, and not from inside a
+// Propagate_All_GC_Marks(). All marks will be propagated.
+//
+static void Mark_Frame_Stack_Deep(void)
{
- int d;
- REBDEV *dev;
- REBREQ *req;
- REBDEV **devices = Host_Lib->devices;
-
- for (d = 0; d < RDI_MAX; d++) {
- dev = devices[d];
- if (dev)
- for (req = dev->pending; req; req = req->next)
- if (req->port) CHECK_MARK((REBSER*)req->port, depth);
- }
-}
-
-/***********************************************************************
-**
-*/ static void Mark_Series(REBSER *series, REBCNT depth)
-/*
-** Mark all series reachable from the block.
-**
-***********************************************************************/
+ REBFRM *f = TG_Frame_Stack;
+
+ for (; f != NULL; f = f->prior) {
+ assert(f->eval_type <= REB_MAX_VOID);
+
+ // Should have taken care of reifying all the VALIST on the stack
+ // earlier in the recycle process (don't want to create new arrays
+ // once the recycling has started...)
+ //
+ assert(f->pending != VA_LIST_PENDING);
+
+ ASSERT_ARRAY_MANAGED(f->source.array);
+ Queue_Mark_Array_Deep(f->source.array);
+
+ // END is possible, because the frame could be sitting at the end of
+ // a block when a function runs, e.g. `do [zero-arity]`. That frame
+ // will stay on the stack while the zero-arity function is running.
+ // The array still might be used in an error, so can't GC it.
+ //
+ if (f->value && NOT_END(f->value) && Is_Value_Managed(f->value))
+ Queue_Mark_Value_Deep(f->value);
+
+ if (f->specifier != SPECIFIED)
+ Queue_Mark_Context_Deep(CTX(f->specifier));
+
+ if (NOT_END(f->out)) // never NULL, always initialized bit pattern
+ Queue_Mark_Opt_Value_Deep(f->out);
+
+ if (NOT(Is_Any_Function_Frame(f))) {
+ //
+ // Consider something like `eval copy quote (recycle)`, because
+ // while evaluating the group it has no anchor anywhere in the
+ // root set and could be GC'd. The Reb_Frame's array ref is it.
+ //
+ continue;
+ }
+
+ if (NOT_END(&f->cell))
+ Queue_Mark_Opt_Value_Deep(&f->cell);
+
+ Queue_Mark_Function_Deep(f->phase); // never NULL
+ Mark_Rebser_Only(f->label); // also never NULL
+
+ if (!Is_Function_Frame_Fulfilling(f)) {
+ assert(IS_END(f->param)); // indicates function is running
+
+ // refine and special can be used to GC protect an arbitrary
+ // value while a function is running, currently. (A more
+ // important purpose may come up...)
+
+ if (NOT_END(f->refine) && Is_Value_Managed(f->refine))
+ Queue_Mark_Opt_Value_Deep(f->refine);
+
+ if (NOT_END(f->special) && Is_Value_Managed(f->special))
+ Queue_Mark_Opt_Value_Deep(f->special);
+ }
+
+ // Need to keep the label symbol alive for error messages/stacktraces
+ //
+ Mark_Rebser_Only(f->label);
+
+ // We need to GC protect the values in the args no matter what,
+ // but it might not be managed yet (e.g. could still contain garbage
+ // during argument fulfillment). But if it is managed, then it needs
+ // to be handed to normal GC.
+ //
+ if (f->varlist != NULL && IS_ARRAY_MANAGED(f->varlist))
+ Queue_Mark_Context_Deep(CTX(f->varlist));
+
+ // (Although the above will mark the varlist, it may not mark the
+ // values...because it may be a single element array that merely
+ // points at the stackvars. Queue_Mark_Context expects stackvars
+ // to be marked separately.)
+
+ // The slots may be stack based or dynamic. Mark in use but only
+ // as far as parameter filling has gotten (may be garbage bits
+ // past that). Could also be an END value of an in-progress arg
+ // fulfillment, but in that case it is protected by the evaluating
+ // frame's f->out.
+ //
+ // Refinements need special treatment, and also consideration
+ // of if this is the "doing pickups" or not. If doing pickups
+ // then skip the cells for pending refinement arguments.
+ //
+ REBVAL *param = FUNC_FACADE_HEAD(f->phase);
+ REBVAL *arg = f->args_head; // may be stack or dynamic
+ for (; NOT_END(param); ++param, ++arg) {
+ if (param == f->param && !f->doing_pickups)
+ break; // protect arg for current param, but no further
+
+ assert(!IS_UNREADABLE_IF_DEBUG(arg) || f->doing_pickups);
+
+ Queue_Mark_Opt_Value_Deep(arg);
+ }
+ assert(IS_END(param) ? IS_END(arg) : TRUE); // may not enforce
+
+ Propagate_All_GC_Marks();
+ }
+}
+
+
+//
+// Sweep_Series: C
+//
+// Scans all series nodes (REBSER structs) in all segments that are part of
+// the SER_POOL. If a series had its lifetime management delegated to the
+// garbage collector with MANAGE_SERIES(), then if it didn't get "marked" as
+// live during the marking phase then free it.
+//
+static REBCNT Sweep_Series(void)
{
- REBCNT len;
- REBSER *ser;
- REBVAL *val;
-
- ASSERT(series != 0, RP_NULL_MARK_SERIES);
-
- if (SERIES_FREED(series)) return; // series data freed already
-
- MARK_SERIES(series);
-
- // If not a block, go no further
- if (SERIES_WIDE(series) != sizeof(REBVAL)) return;
-
- ASSERT2(RP_SERIES_OVERFLOW, SERIES_TAIL(series) < SERIES_REST(series));
-
- //Moved to end: ASSERT1(IS_END(BLK_TAIL(series)), RP_MISSING_END);
-
- //if (depth == 1 && series->label) Print("Marking %s", series->label);
-
- depth++;
-
- for (len = 0; len < series->tail; len++) {
- val = BLK_SKIP(series, len);
-
- switch (VAL_TYPE(val)) {
-
- case REB_END:
- // We should never reach the end before len above.
- // Exception is the stack itself.
- if (series != DS_Series) Crash(RP_UNEXPECTED_END);
- break;
-
- case REB_UNSET:
- case REB_TYPESET:
- case REB_HANDLE:
- break;
-
- case REB_DATATYPE:
- if (VAL_TYPE_SPEC(val)) { // allow it to be zero
- CHECK_MARK(VAL_TYPE_SPEC(val), depth); // check typespec.r file
- }
- break;
-
- case REB_ERROR:
- // If it has an actual error object, then mark it. Otherwise,
- // it is a THROW, and GC of a THROW value is invalid because
- // it contains temporary values on the stack that could be
- // above the current DSP (where the THROW was done).
- if (VAL_ERR_NUM(val) > RE_THROW_MAX) {
- if (VAL_ERR_OBJECT(val)) CHECK_MARK(VAL_ERR_OBJECT(val), depth);
- }
- // else Crash(RP_THROW_IN_GC); // !!!! in question - is it true?
- break;
-
- case REB_TASK: // not yet implemented
- break;
-
- case REB_FRAME:
- // Mark special word list. Contains no pointers because
- // these are special word bindings (to typesets if used).
- if (VAL_FRM_WORDS(val)) MARK_SERIES(VAL_FRM_WORDS(val));
- if (VAL_FRM_SPEC(val)) {CHECK_MARK(VAL_FRM_SPEC(val), depth);}
- break;
-
- case REB_PORT:
- // Debug_Fmt("\n\nmark port: %x %d", val, VAL_TAIL(val));
- // Debug_Values(VAL_OBJ_VALUE(val,1), VAL_TAIL(val)-1, 100);
- goto mark_obj;
-
- case REB_MODULE:
- if (VAL_MOD_BODY(val)) CHECK_MARK(VAL_MOD_BODY(val), depth);
- case REB_OBJECT:
- // Object is just a block with special first value (context):
-mark_obj:
- if (!IS_MARK_SERIES(VAL_OBJ_FRAME(val))) {
- Mark_Series(VAL_OBJ_FRAME(val), depth);
- if (SERIES_TAIL(VAL_OBJ_FRAME(val)) >= 1)
- ; //Dump_Frame(VAL_OBJ_FRAME(val), 4);
- }
- break;
-
- case REB_FUNCTION:
- case REB_COMMAND:
- case REB_CLOSURE:
- case REB_REBCODE:
- CHECK_MARK(VAL_FUNC_BODY(val), depth);
- case REB_NATIVE:
- case REB_ACTION:
- case REB_OP:
- CHECK_MARK(VAL_FUNC_SPEC(val), depth);
- MARK_SERIES(VAL_FUNC_ARGS(val));
- // There is a problem for user define function operators !!!
- // Their bodies are not GC'd!
- break;
-
- case REB_WORD: // (and also used for function STACK backtrace frame)
- case REB_SET_WORD:
- case REB_GET_WORD:
- case REB_LIT_WORD:
- case REB_REFINEMENT:
- case REB_ISSUE:
- // Special word used in word frame, stack, or errors:
- if (VAL_GET_OPT(val, OPTS_UNWORD)) break;
- // Mark its context, if it has one:
- if (VAL_WORD_INDEX(val) > 0 && NZ(ser = VAL_WORD_FRAME(val))) {
- //if (SERIES_TAIL(ser) > 100) Dump_Word_Value(val);
- CHECK_MARK(ser, depth);
- }
- // Possible bug above!!! We cannot mark relative words (negative
- // index) because the frame pointer does not point to a context,
- // it may point to a function body, native code, or action number.
- // But, what if a function is GC'd during it's own evaluation, what
- // keeps the function's code block from being GC'd?
- break;
-
- case REB_NONE:
- case REB_LOGIC:
- case REB_INTEGER:
- case REB_DECIMAL:
- case REB_PERCENT:
- case REB_MONEY:
- case REB_TIME:
- case REB_DATE:
- case REB_CHAR:
- case REB_PAIR:
- case REB_TUPLE:
- break;
-
- case REB_STRING:
- case REB_BINARY:
- case REB_FILE:
- case REB_EMAIL:
- case REB_URL:
- case REB_TAG:
- case REB_BITSET:
- ser = VAL_SERIES(val);
- if (SERIES_WIDE(ser) > sizeof(REBUNI))
- Crash(RP_BAD_WIDTH, sizeof(REBUNI), SERIES_WIDE(ser), VAL_TYPE(val));
- MARK_SERIES(ser);
- break;
-
- case REB_IMAGE:
- //MARK_SERIES(VAL_SERIES_SIDE(val)); //????
- MARK_SERIES(VAL_SERIES(val));
- break;
-
- case REB_VECTOR:
- MARK_SERIES(VAL_SERIES(val));
- break;
-
- case REB_BLOCK:
- case REB_PAREN:
- case REB_PATH:
- case REB_SET_PATH:
- case REB_GET_PATH:
- case REB_LIT_PATH:
- ser = VAL_SERIES(val);
- ASSERT(ser != 0, RP_NULL_SERIES);
- if (IS_BARE_SERIES(ser)) {
- MARK_SERIES(ser);
- break;
- }
-#if (ALEVEL>0)
- if (!IS_END(BLK_SKIP(ser, SERIES_TAIL(ser))) && ser != DS_Series)
- Crash(RP_MISSING_END);
+ REBCNT count = 0;
+
+ // Optimization here depends on SWITCH of a bank of 4 bits.
+ //
+ static_assert_c(
+ NODE_FLAG_MARKED == FLAGIT_LEFT(3) // 0x1 after right shift
+ && (NODE_FLAG_MANAGED == FLAGIT_LEFT(2)) // 0x2 after right shift
+ && (NODE_FLAG_FREE == FLAGIT_LEFT(1)) // 0x4 after right shift
+ && (NODE_FLAG_NODE == FLAGIT_LEFT(0)) // 0x8 after right shift
+ );
+
+ REBSEG *seg;
+ for (seg = Mem_Pools[SER_POOL].segs; seg != NULL; seg = seg->next) {
+ REBSER *s = cast(REBSER*, seg + 1);
+ REBCNT n;
+ for (n = Mem_Pools[SER_POOL].units; n > 0; --n, ++s) {
+ switch (LEFT_N_BITS(s->header.bits, 4)) {
+ case 0:
+ case 1: // 0x1
+ case 2: // 0x2
+ case 3: // 0x2 + 0x1
+ case 4: // 0x4
+ case 5: // 0x4 + 0x1
+ case 6: // 0x4 + 0x2
+ case 7: // 0x4 + 0x2 + 0x1
+ //
+ // NODE_FLAG_NODE (0x8) is clear. This signature is
+ // reserved for UTF-8 strings (corresponding to valid ASCII
+ // values in the first byte).
+ //
+ panic (s);
+
+ // v-- Everything below here has NODE_FLAG_NODE set (0x8)
+
+ case 8:
+ // 0x8: unmanaged and unmarked, e.g. a series that was made
+ // with Make_Series() and hasn't been managed. It doesn't
+ // participate in the GC. Leave it as is.
+ //
+ break;
+
+ case 9:
+ // 0x8 + 0x1: marked but not managed, this can't happen,
+ // because the marking itself asserts nodes are managed.
+ //
+ panic (s);
+
+ case 10:
+ // 0x8 + 0x2: managed but didn't get marked, should be GC'd
+ //
+ // !!! It would be nice if we could have NODE_FLAG_CELL here
+ // as part of the switch, but see its definition for why it
+ // is at position 8 from left and not an earlier bit.
+ //
+ if (s->header.bits & NODE_FLAG_CELL)
+ Free_Node(SER_POOL, s); // Free_Pairing is for manuals
+ else
+ GC_Kill_Series(s);
+ ++count;
+ break;
+
+ case 11:
+ // 0x8 + 0x2 + 0x1: managed and marked, so it's still live.
+ // Don't GC it, just clear the mark.
+ //
+ s->header.bits &= ~NODE_FLAG_MARKED;
+ break;
+
+ // v-- Everything below this line has the two leftmost bits set
+ // in the header. In the *general* case this could be a valid
+ // first byte of a multi-byte sequence in UTF-8...so only the
+ // special bit pattern of the free case uses this.
+
+ case 12:
+ // 0x8 + 0x4: free node, uses special illegal UTF-8 byte
+ //
+ assert(LEFT_8_BITS(s->header.bits) == FREED_SERIES_BYTE);
+ break;
+
+ case 13:
+ // 0x8 + 0x4 + 0x1: "free unmanaged marked node" (?!)
+ //
+ panic (s);
+
+ case 14:
+ // 0x8 + 0x4 + 0x2: "free managed unmarked node" (?!)
+ //
+ panic (s);
+
+ case 15:
+ // 0x8 + 0x4 + 0x2 + 0x1: "free managed marked node" (?!)
+ //
+ panic (s);
+ }
+ }
+ }
+
+ return count;
+}
+
+
+#if !defined(NDEBUG)
+
+//
+// Fill_Sweeplist: C
+//
+REBCNT Fill_Sweeplist(REBSER *sweeplist)
+{
+ assert(SER_WIDE(sweeplist) == sizeof(REBNOD*));
+ assert(SER_LEN(sweeplist) == 0);
+
+ REBCNT count = 0;
+
+ REBSEG *seg;
+ for (seg = Mem_Pools[SER_POOL].segs; seg != NULL; seg = seg->next) {
+ REBSER *s = cast(REBSER*, seg + 1);
+ REBCNT n;
+ for (n = Mem_Pools[SER_POOL].units; n > 0; --n, ++s) {
+ switch (LEFT_N_BITS(s->header.bits, 4)) {
+ case 9: // 0x8 + 0x1
+ assert(IS_SERIES_MANAGED(s));
+ if (Is_Rebser_Marked(s))
+ Unmark_Rebser(s);
+ else {
+ EXPAND_SERIES_TAIL(sweeplist, 1);
+ *SER_AT(REBNOD*, sweeplist, count) = NOD(s);
+ ++count;
+ }
+ break;
+
+ case 11: // 0x8 + 0x2 + 0x1
+ //
+ // It's a cell which is managed where the key is not an END.
+ // This is a managed pairing, so mark bit should be heeded.
+ //
+ // !!! It is a REBNOD, but *not* a "series".
+ //
+ assert(IS_SERIES_MANAGED(s));
+ if (Is_Rebser_Marked(s))
+ Unmark_Rebser(s);
+ else {
+ EXPAND_SERIES_TAIL(sweeplist, 1);
+ *SER_AT(REBNOD*, sweeplist, count) = NOD(s);
+ ++count;
+ }
+ break;
+ }
+ }
+ }
+
+ return count;
+}
+
+#endif
+
+
+//
+// Recycle_Core: C
+//
+// Recycle memory no longer needed. If sweeplist is not NULL, then it needs
+// to be a series whose width is sizeof(REBSER*), and it will be filled with
+// the list of series that *would* be recycled.
+//
+REBCNT Recycle_Core(REBOOL shutdown, REBSER *sweeplist)
+{
+ // Ordinarily, it should not be possible to spawn a recycle during a
+ // recycle. But when debug code is added into the recycling code, it
+ // could cause a recursion. Be tolerant of such recursions to make that
+ // debugging easier...but make a note that it's not ordinarily legal.
+ //
+#if !defined(NDEBUG)
+ if (GC_Recycling) {
+ printf("Recycle re-entry; should only happen in debug scenarios.\n");
+ SET_SIGNAL(SIG_RECYCLE);
+ return 0;
+ }
+#endif
+
+ // If disabled by RECYCLE/OFF, exit now but set the pending flag. (If
+ // shutdown, ignore so recycling runs and can be checked for balance.)
+ //
+ if (!shutdown && GC_Disabled) {
+ SET_SIGNAL(SIG_RECYCLE);
+ return 0;
+ }
+
+#if !defined(NDEBUG)
+ GC_Recycling = TRUE;
+#endif
+
+ ASSERT_NO_GC_MARKS_PENDING();
+
+ Reify_Any_C_Valist_Frames();
+
+
+#if !defined(NDEBUG)
+ PG_Reb_Stats->Recycle_Counter++;
+ PG_Reb_Stats->Recycle_Series = Mem_Pools[SER_POOL].free;
+
+ PG_Reb_Stats->Mark_Count = 0;
#endif
- if (SERIES_WIDE(ser) != sizeof(REBVAL) && SERIES_WIDE(ser) != 4 && SERIES_WIDE(ser) != 0)
- Crash(RP_BAD_WIDTH, 16, SERIES_WIDE(ser), VAL_TYPE(val));
- CHECK_MARK(ser, depth);
- break;
-
- case REB_MAP:
- ser = VAL_SERIES(val);
- CHECK_MARK(ser, depth);
- if (ser->series) {
- MARK_SERIES(ser->series);
- }
- break;
-
-#ifdef ndef
- case REB_ROUTINE:
- // Deal with the co-joined struct value...
- CHECK_MARK(VAL_STRUCT_SPEC(VAL_ROUTINE_SPEC(val)), depth);
- CHECK_MARK(VAL_STRUCT_VALS(VAL_ROUTINE_SPEC(val)), depth);
- MARK_SERIES(VAL_STRUCT_DATA(VAL_ROUTINE_SPEC(val)));
- MARK_SERIES(VAL_ROUTINE_SPEC_SER(val));
-//!!! if (Current_Closing_Library && VAL_ROUTINE_ID(val) == Current_Closing_Library)
- VAL_ROUTINE_ID(val) = 0; // Invalidate the routine
- break;
+
+ // WARNING: This terminates an existing open block. This could be a
+ // problem if code is building a new value at the tail, but has not yet
+ // updated the TAIL marker.
+ //
+ TERM_ARRAY_LEN(BUF_COLLECT, ARR_LEN(BUF_COLLECT));
+
+ // MARKING PHASE: the "root set" from which we determine the liveness
+ // (or deadness) of a series. If we are shutting down, we do not mark
+ // several categories of series...but we do need to run the root marking.
+ // (In particular because that is when pairing series whose lifetimes
+ // are bound to frames will be freed, if the frame is expired.)
+ //
+ Mark_Root_Series();
+
+ if (!shutdown) {
+ Mark_Natives();
+ Mark_Symbol_Series();
+
+ Mark_Data_Stack();
+
+ Mark_Guarded_Nodes();
+
+ Mark_Frame_Stack_Deep();
+
+ // Mark potential error object from callback!
+ if (!IS_BLANK_RAW(&Callback_Error)) {
+ assert(NOT_VAL_FLAG(&Callback_Error, VALUE_FLAG_RELATIVE));
+ Queue_Mark_Value_Deep(&Callback_Error);
+ }
+ Propagate_All_GC_Marks();
+
+ Mark_Devices_Deep();
+
+ }
+
+ // SWEEPING PHASE
+
+ ASSERT_NO_GC_MARKS_PENDING();
+
+ REBCNT count = 0;
+
+ if (sweeplist != NULL) {
+ #if defined(NDEBUG)
+ panic (sweeplist);
+ #else
+ count += Fill_Sweeplist(sweeplist);
+ #endif
+ }
+ else
+ count += Sweep_Series();
+
+ // !!! The intent is for GOB! to be unified in the REBNOD pattern, the
+ // way that the FFI structures were. So they are not included in the
+ // count, in order to help make the numbers returned consistent between
+ // when the sweeplist is used and not.
+ //
+ Sweep_Gobs();
+
+#if !defined(NDEBUG)
+ // Compute new stats:
+ PG_Reb_Stats->Recycle_Series
+ = Mem_Pools[SER_POOL].free - PG_Reb_Stats->Recycle_Series;
+ PG_Reb_Stats->Recycle_Series_Total += PG_Reb_Stats->Recycle_Series;
+ PG_Reb_Stats->Recycle_Prior_Eval = Eval_Cycles;
#endif
- case REB_LIBRARY:
- MARK_SERIES(VAL_LIBRARY_NAME(val));
-//!!! if (Current_Closing_Library && VAL_LIBRARY_ID(val) == Current_Closing_Library)
- VAL_LIBRARY_ID(val) = 0; // Invalidate the library
- break;
-
- case REB_STRUCT:
- CHECK_MARK(VAL_STRUCT_SPEC(val), depth); // is a block
- CHECK_MARK(VAL_STRUCT_VALS(val), depth); // " "
- MARK_SERIES(VAL_STRUCT_DATA(val));
- break;
-
- case REB_GOB:
- Mark_Gob(VAL_GOB(val), depth);
- break;
-
- case REB_EVENT:
- Mark_Event(val, depth);
- break;
-
- default:
- Crash(RP_DATATYPE+1, VAL_TYPE(val));
- }
- }
-
-#if (ALEVEL>0)
- if (!IS_END(BLK_SKIP(series, len)) && series != DS_Series)
- Crash(RP_MISSING_END);
+ // Do not adjust task variables or boot strings in shutdown when they
+ // are being freed.
+ //
+ if (!shutdown) {
+ //
+ // !!! This code was added by Atronix to deal with frequent garbage
+ // collection, but the logic is not correct. The issue has been
+ // raised and is commented out pending a correct solution.
+ //
+ // https://github.com/zsx/r3/issues/32
+ //
+ /*if (GC_Ballast <= VAL_INT32(TASK_BALLAST) / 2
+ && VAL_INT64(TASK_BALLAST) < MAX_I32) {
+ //increasing ballast by half
+ VAL_INT64(TASK_BALLAST) /= 2;
+ VAL_INT64(TASK_BALLAST) *= 3;
+ } else if (GC_Ballast >= VAL_INT64(TASK_BALLAST) * 2) {
+ //reduce ballast by half
+ VAL_INT64(TASK_BALLAST) /= 2;
+ }
+
+ // avoid overflow
+ if (
+ VAL_INT64(TASK_BALLAST) < 0
+ || VAL_INT64(TASK_BALLAST) >= MAX_I32
+ ) {
+ VAL_INT64(TASK_BALLAST) = MAX_I32;
+ }*/
+
+ GC_Ballast = VAL_INT32(TASK_BALLAST);
+
+ if (Reb_Opts->watch_recycle)
+ Debug_Fmt(RM_WATCH_RECYCLE, count);
+ }
+
+ ASSERT_NO_GC_MARKS_PENDING();
+
+#if !defined(NDEBUG)
+ GC_Recycling = FALSE;
#endif
+
+ return count;
}
-/***********************************************************************
-**
-*/ static REBCNT Sweep_Series(void)
-/*
-** Free all unmarked series.
-**
-** Scans all series in all segments that are part of the
-** SERIES_POOL. Free series that have not been marked.
-**
-***********************************************************************/
-{
- REBSEG *seg;
- REBSER *series;
- REBCNT n;
- REBCNT count = 0;
-
- for (seg = Mem_Pools[SERIES_POOL].segs; seg; seg = seg->next) {
- series = (REBSER *) (seg + 1);
- for (n = Mem_Pools[SERIES_POOL].units; n > 0; n--) {
- SKIP_WALL(series);
- MUNG_CHECK(SERIES_POOL, series, sizeof(*series));
- if (!SERIES_FREED(series)) {
- if (IS_FREEABLE(series)) {
- Free_Series(series);
- count++;
- } else
- UNMARK_SERIES(series);
- }
- series++;
- SKIP_WALL(series);
- }
- }
-
- return count;
-}
-
-
-/***********************************************************************
-**
-*/ static REBCNT Sweep_Gobs(void)
-/*
-** Free all unmarked gobs.
-**
-** Scans all gobs in all segments that are part of the
-** GOB_POOL. Free gobs that have not been marked.
-**
-***********************************************************************/
+//
+// Recycle: C
+//
+// Recycle memory no longer needed.
+//
+REBCNT Recycle(void)
{
- REBSEG *seg;
- REBGOB *gob;
- REBCNT n;
- REBCNT count = 0;
-
- for (seg = Mem_Pools[GOB_POOL].segs; seg; seg = seg->next) {
- gob = (REBGOB *) (seg + 1);
- for (n = Mem_Pools[GOB_POOL].units; n > 0; n--) {
-#ifdef MUNGWALL
- gob = (gob *) (((REBYTE *)s)+MUNG_SIZE);
- MUNG_CHECK(GOB_POOL, gob, sizeof(*gob));
+ // Default to not passing the `shutdown` flag.
+ //
+ REBCNT n = Recycle_Core(FALSE, NULL);
+
+#ifdef DOUBLE_RECYCLE_TEST
+ //
+ // If there are two recycles in a row, then the second should not free
+ // any additional series that were not freed by the first. (It also
+ // shouldn't crash.) This is an expensive check, but helpful to try if
+ // it seems a GC left things in a bad state that crashed a later GC.
+ //
+ REBCNT n2 = Recycle_Core(FALSE, NULL);
+ assert(n2 == 0);
#endif
- if (IS_GOB_USED(gob)) {
- if (IS_GOB_MARK(gob))
- UNMARK_GOB(gob);
- else {
- Free_Gob(gob);
- count++;
- }
- }
- gob++;
-#ifdef MUNGWALL
- gob = (gob *) (((REBYTE *)s)+MUNG_SIZE);
+
+ return n;
+}
+
+
+//
+// Guard_Node_Core: C
+//
+void Guard_Node_Core(const REBNOD *node)
+{
+#if !defined(NDEBUG)
+ if (node->header.bits & NODE_FLAG_CELL) {
+ //
+ // It is a value. Cheap check: require that it already contain valid
+ // data when the guard call is made (even if GC isn't necessarily
+ // going to happen immediately, and value could theoretically become
+ // valid before then.)
+ //
+ const REBVAL* value = cast(const REBVAL*, node);
+ assert(
+ IS_END(value)
+ || IS_BLANK_RAW(value)
+ || VAL_TYPE(value) <= REB_MAX_VOID
+ );
+
+ #ifdef STRESS_CHECK_GUARD_VALUE_POINTER
+ //
+ // Technically we should never call this routine to guard a value
+ // that lives inside of a series. Not only would we have to guard the
+ // containing series, we would also have to lock the series from
+ // being able to resize and reallocate the data pointer. But this is
+ // a somewhat expensive check, so only feasible to run occasionally.
+ //
+ REBSER *containing = Try_Find_Containing_Series_Debug(value);
+ if (containing != NULL)
+ panic (containing);
+ #endif
+ }
+ else {
+ // It's a series. Does not ensure the series being guarded is
+ // managed, since it can be interesting to guard the managed
+ // *contents* of an unmanaged array. The calling wrappers ensure
+ // managedness or not.
+ }
#endif
- }
- }
- return count;
+ if (SER_FULL(GC_Guarded))
+ Extend_Series(GC_Guarded, 8);
+
+ *SER_AT(
+ const REBNOD*,
+ GC_Guarded,
+ SER_LEN(GC_Guarded)
+ ) = node;
+
+ SET_SERIES_LEN(GC_Guarded, SER_LEN(GC_Guarded) + 1);
}
-/***********************************************************************
-**
-*/ REBCNT Recycle(void)
-/*
-** Recycle memory no longer needed.
-**
-***********************************************************************/
+//
+// Snapshot_All_Functions: C
+//
+// This routine can be used to get a list of all the functions in the system
+// at a given moment in time. Be sure to protect this array from GC when
+// enumerating if there is any chance the GC might run (e.g. if user code
+// is called to process the function list)
+//
+REBARR *Snapshot_All_Functions(void)
{
- REBINT n;
- REBSER **sp;
- REBCNT count;
-
- //Debug_Num("GC", GC_Disabled);
-
- // If disabled, exit now but set the pending flag.
- if (GC_Disabled || !GC_Active) {
- SET_SIGNAL(SIG_RECYCLE);
- //Print("pending");
- return 0;
- }
-
- if (Reb_Opts->watch_recycle) Debug_Str(BOOT_STR(RS_WATCH, 0));
-
- GC_Disabled = 1;
-
- PG_Reb_Stats->Recycle_Counter++;
- PG_Reb_Stats->Recycle_Series = Mem_Pools[SERIES_POOL].free;
-
- PG_Reb_Stats->Mark_Count = 0;
-
- // WARNING: These terminate existing open blocks. This could
- // be a problem if code is building a new value at the tail,
- // but has not yet updated the TAIL marker.
- DS_TERMINATE; // Update data stack tail
-// SET_END(DS_NEXT);
- VAL_BLK_TERM(TASK_BUF_EMIT);
- VAL_BLK_TERM(TASK_BUF_WORDS);
-//!!! SET_END(BLK_TAIL(Save_Value_List));
-
- // Mark series stack (temp-saved series):
- sp = (REBSER **)GC_Protect->data;
- for (n = SERIES_TAIL(GC_Protect); n > 0; n--) {
- Mark_Series(*sp++, 0);
- }
-
- // Mark all special series:
- sp = (REBSER **)GC_Series->data;
- for (n = SERIES_TAIL(GC_Series); n > 0; n--) {
- Mark_Series(*sp++, 0);
- }
-
- // Mark the last MAX_SAFE "infant" series that were created.
- // We must assume that infant blocks are valid - that they contain
- // no partially valid datatypes (that are under construction).
- for (n = 0; n < MAX_SAFE_SERIES; n++) {
- REBSER *ser;
- if (NZ(ser = GC_Infants[n])) {
- //Dump_Series(ser, "Safe Series");
- Mark_Series(ser, 0);
- } else break;
- }
-
- // Mark all root series:
- Mark_Series(VAL_SERIES(ROOT_ROOT), 0);
- Mark_Series(Task_Series, 0);
-
- // Mark all devices:
- Mark_Devices(0);
-
- count = Sweep_Series();
- count += Sweep_Gobs();
-
- CHECK_MEMORY(4);
-
- // Compute new stats:
- PG_Reb_Stats->Recycle_Series = Mem_Pools[SERIES_POOL].free - PG_Reb_Stats->Recycle_Series;
- PG_Reb_Stats->Recycle_Series_Total += PG_Reb_Stats->Recycle_Series;
- PG_Reb_Stats->Recycle_Prior_Eval = Eval_Cycles;
-
- // Reset stack to prevent invalid MOLD access:
- RESET_TAIL(DS_Series);
-
- GC_Ballast = VAL_INT32(TASK_BALLAST);
- GC_Disabled = 0;
-
- if (Reb_Opts->watch_recycle) Debug_Fmt(BOOT_STR(RS_WATCH, 1), count);
- return count;
-}
-
-
-/***********************************************************************
-**
-*/ void Save_Series(REBSER *series)
-/*
-***********************************************************************/
+ REBDSP dsp_orig = DSP;
+
+ REBSEG *seg;
+ for (seg = Mem_Pools[SER_POOL].segs; seg != NULL; seg = seg->next) {
+ REBSER *s = cast(REBSER*, seg + 1);
+ REBCNT n;
+ for (n = Mem_Pools[SER_POOL].units; n > 0; --n, ++s) {
+ switch (s->header.bits & 0x7) {
+ case 5:
+ // A managed REBSER which has no cell mask and is marked as
+ // *not* an END. This is the typical signature of what one
+ // would call an "ordinary managed REBSER". (For the meanings
+ // of other bits, see Sweep_Series.)
+ //
+ assert(IS_SERIES_MANAGED(s));
+ if (GET_SER_FLAG(s, ARRAY_FLAG_PARAMLIST)) {
+ REBVAL *v = KNOWN(ARR_HEAD(ARR(s)));
+ assert(IS_FUNCTION(v));
+ DS_PUSH(v);
+ }
+ break;
+ }
+ }
+ }
+
+ return Pop_Stack_Values(dsp_orig);
+}
+
+
+//
+// Startup_GC: C
+//
+// Initialize garbage collector.
+//
+void Startup_GC(void)
{
- if (SERIES_FULL(GC_Protect)) Extend_Series(GC_Protect, 8);
- ((REBSER **)GC_Protect->data)[GC_Protect->tail++] = series;
+ assert(NOT(GC_Disabled));
+ assert(NOT(GC_Recycling));
+
+ GC_Ballast = MEM_BALLAST;
+
+ // Temporary series and values protected from GC. Holds node pointers.
+ //
+ GC_Guarded = Make_Series(15, sizeof(REBNOD*));
+
+ // The marking queue used in lieu of recursion to ensure that deeply
+ // nested structures don't cause the C stack to overflow.
+ //
+ GC_Mark_Stack = Make_Series(100, sizeof(REBARR*));
+ TERM_SEQUENCE(GC_Mark_Stack);
}
-/***********************************************************************
-**
-*/ void Guard_Series(REBSER *series)
-/*
-** A list of protected series, managed by specific removal.
-**
-***********************************************************************/
+//
+// Shutdown_GC: C
+//
+void Shutdown_GC(void)
{
- LABEL_SERIES(series, "guarded");
- if (SERIES_FULL(GC_Series)) Extend_Series(GC_Series, 8);
- ((REBSER **)GC_Series->data)[GC_Series->tail++] = series;
+ Free_Series(GC_Guarded);
+ Free_Series(GC_Mark_Stack);
}
-/***********************************************************************
-**
-*/ void Loose_Series(REBSER *series)
-/*
-** Remove a series from the protected list.
-**
-***********************************************************************/
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// DEPRECATED HOOKS INTO THE CORE GARBAGE COLLECTOR
+//
+//=////////////////////////////////////////////////////////////////////////=//
+
+//
+// Queue_Mark_Gob_Deep: C
+//
+// 'Queue' refers to the fact that after calling this routine,
+// one will have to call Propagate_All_GC_Marks() to have the
+// deep transitive closure be guaranteed fully marked.
+//
+// Note: only referenced blocks are queued, the GOB structure
+// itself is processed via recursion. Deeply nested GOBs could
+// in theory overflow the C stack.
+//
+static void Queue_Mark_Gob_Deep(REBGOB *gob)
{
- REBSER **sp;
- REBCNT n;
-
- LABEL_SERIES(series, "unguarded");
- sp = (REBSER **)GC_Series->data;
- for (n = 0; n < SERIES_TAIL(GC_Series); n++) {
- if (sp[n] == series) {
- Remove_Series(GC_Series, n, sizeof(REBSER *));
- break;
- }
- }
-}
-
-
-/***********************************************************************
-**
-*/ void Init_Memory(REBINT scale)
-/*
-** Initialize memory system.
-**
-***********************************************************************/
+ REBGOB **pane;
+ REBCNT i;
+
+ if (IS_GOB_MARK(gob)) return;
+
+ MARK_GOB(gob);
+
+ if (GOB_PANE(gob)) {
+ Mark_Rebser_Only(GOB_PANE(gob));
+ pane = GOB_HEAD(gob);
+ for (i = 0; i < GOB_LEN(gob); i++, pane++)
+ Queue_Mark_Gob_Deep(*pane);
+ }
+
+ if (GOB_PARENT(gob)) Queue_Mark_Gob_Deep(GOB_PARENT(gob));
+
+ if (GOB_CONTENT(gob)) {
+ if (GOB_TYPE(gob) >= GOBT_IMAGE && GOB_TYPE(gob) <= GOBT_STRING)
+ Mark_Rebser_Only(GOB_CONTENT(gob));
+ else if (GOB_TYPE(gob) >= GOBT_DRAW && GOB_TYPE(gob) <= GOBT_EFFECT)
+ Queue_Mark_Array_Deep(ARR(GOB_CONTENT(gob)));
+ }
+
+ if (GOB_DATA(gob)) {
+ switch (GOB_DTYPE(gob)) {
+ case GOBD_INTEGER:
+ case GOBD_NONE:
+ default:
+ break;
+ case GOBD_OBJECT:
+ Queue_Mark_Context_Deep(CTX(GOB_DATA(gob)));
+ break;
+ case GOBD_STRING:
+ case GOBD_BINARY:
+ Mark_Rebser_Only(GOB_DATA(gob));
+ break;
+ case GOBD_BLOCK:
+ Queue_Mark_Array_Deep(ARR(GOB_DATA(gob)));
+ }
+ }
+}
+
+
+//
+// Sweep_Gobs: C
+//
+// Free all unmarked gobs.
+//
+// Scans all gobs in all segments that are part of the
+// GOB_POOL. Free gobs that have not been marked.
+//
+static REBCNT Sweep_Gobs(void)
{
- GC_Active = 0; // TRUE when recycle is enabled (set by RECYCLE func)
- GC_Disabled = 0; // GC disabled counter for critical sections.
- GC_Ballast = MEM_BALLAST;
- GC_Last_Infant = 0; // Keep the last N series safe from GC.
- GC_Infants = Make_Mem((MAX_SAFE_SERIES + 2) * sizeof(REBSER*)); // extra
+ REBCNT count = 0;
+
+ REBSEG *seg;
+ for (seg = Mem_Pools[GOB_POOL].segs; seg; seg = seg->next) {
+ REBGOB *gob = cast(REBGOB*, seg + 1);
+
+ REBCNT n;
+ for (n = Mem_Pools[GOB_POOL].units; n > 0; --n, ++gob) {
+ if (IS_FREE_NODE(gob)) // unused REBNOD
+ continue;
+
+ if (IS_GOB_MARK(gob))
+ UNMARK_GOB(gob);
+ else {
+ Free_Node(GOB_POOL, gob);
+
+ // GC_Ballast is of type REBINT, which might be long
+ // and REB_I32_ADD_OF takes (int*)
+ // it's illegal to convert form (long*) to (int*) in C++
+ i32 tmp;
+ GC_Ballast = REB_I32_ADD_OF(
+ GC_Ballast, Mem_Pools[GOB_POOL].wide, &tmp
+ ) ? MAX_I32 : tmp;
+
+ if (GC_Ballast > 0)
+ CLR_SIGNAL(SIG_RECYCLE);
+
+ count++;
+ }
+ }
+ }
+
+ return count;
+}
+
- Init_Pools(scale);
+//
+// Queue_Mark_Event_Deep: C
+//
+// 'Queue' refers to the fact that after calling this routine,
+// one will have to call Propagate_All_GC_Marks() to have the
+// deep transitive closure completely marked.
+//
+static void Queue_Mark_Event_Deep(const RELVAL *value)
+{
+ REBREQ *req;
+
+ if (
+ IS_EVENT_MODEL(value, EVM_PORT)
+ || IS_EVENT_MODEL(value, EVM_OBJECT)
+ ) {
+ Queue_Mark_Context_Deep(CTX(VAL_EVENT_SER(m_cast(RELVAL*, value))));
+ }
+ else if (IS_EVENT_MODEL(value, EVM_GUI)) {
+ Queue_Mark_Gob_Deep(cast(REBGOB*, VAL_EVENT_SER(m_cast(RELVAL*, value))));
+ }
+
+ // FIXME: This test is not in parallel to others.
+ if (VAL_EVENT_TYPE(value) == EVT_DROP_FILE
+ && GET_FLAG(VAL_EVENT_FLAGS(value), EVF_COPIED)
+ )
+ {
+ assert(FALSE);
+ Queue_Mark_Array_Deep(ARR(VAL_EVENT_SER(m_cast(RELVAL*, value))));
+ }
+
+ if (IS_EVENT_MODEL(value, EVM_DEVICE)) {
+ // In the case of being an EVM_DEVICE event type, the port! will
+ // not be in VAL_EVENT_SER of the REBEVT structure. It is held
+ // indirectly by the REBREQ ->req field of the event, which
+ // in turn possibly holds a singly linked list of other requests.
+ req = VAL_EVENT_REQ(value);
+
+ while (req) {
+ // Comment says void* ->port is "link back to REBOL port object"
+ if (req->port)
+ Queue_Mark_Context_Deep(CTX(req->port));
+ req = req->next;
+ }
+ }
+}
+
+
+//
+// Mark_Devices_Deep: C
+//
+// Mark all devices. Search for pending requests.
+//
+// This should be called at the top level, and as it is not
+// 'Queued' it guarantees that the marks have been propagated.
+//
+static void Mark_Devices_Deep(void)
+{
+ REBDEV **devices = Host_Lib->devices;
- Prior_Expand = Make_Mem(MAX_EXPAND_LIST * sizeof(REBSER*));
- Prior_Expand[0] = (REBSER*)1;
+ int d;
+ for (d = 0; d < RDI_MAX; d++) {
+ REBREQ *req;
+ REBDEV *dev = devices[d];
+ if (!dev)
+ continue;
- // Temporary series protected from GC. Holds series pointers.
- GC_Protect = Make_Series(15, sizeof(REBSER *), FALSE);
- KEEP_SERIES(GC_Protect, "gc protected");
+ for (req = dev->pending; req; req = req->next)
+ if (req->port)
+ Queue_Mark_Context_Deep(CTX(req->port));
+ }
- GC_Series = Make_Series(60, sizeof(REBSER *), FALSE);
- KEEP_SERIES(GC_Series, "gc guarded");
+ Propagate_All_GC_Marks();
}
diff --git a/src/core/m-pools.c b/src/core/m-pools.c
index 828e3c6e8a..00a9a935e8 100644
--- a/src/core/m-pools.c
+++ b/src/core/m-pools.c
@@ -1,851 +1,2216 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: m-pools.c
-** Summary: memory allocation pool management
-** Section: memory
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-/*
- Ideas...
+//
+// File: %m-pools.c
+// Summary: "memory allocation pool management"
+// Section: memory
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// A point of Rebol's design was to remain small and solve its domain without
+// relying on a lot of abstraction. Its memory-management was thus focused on
+// staying low-level...and being able to do efficient and lightweight
+// allocations of series.
+//
+// Unless they've been explicitly marked as fixed-size, series have a dynamic
+// component. But they also have a fixed-size component that is allocated
+// from a memory pool of other fixed-size things. This is called the "Node"
+// in both Rebol and Red terminology. It is an item whose pointer is valid
+// for the lifetime of the object, regardless of resizing. This is where
+// header information is stored, and pointers to these objects may be saved
+// in REBVAL values; such that they are kept alive by the garbage collector.
+//
+// The more complicated thing to do memory pooling of is the variable-sized
+// portion of a series (currently called the "series data")...as series sizes
+// can vary widely. But a trick Rebol has is that a series might be able to
+// take advantage of being given back an allocation larger than requested.
+// They can use it as reserved space for growth.
+//
+// (Typical models for implementation of things like C++'s std::vector do not
+// reach below new[] or delete[]...which are generally implemented with malloc
+// and free under the hood. Their buffered additional capacity is done
+// assuming the allocation they get is as big as they asked for...no more and
+// no less.)
+//
+// !!! While the space usage is very optimized in this model, there was no
+// consideration for intelligent thread safety for allocations and frees.
+// So although code like `tcmalloc` might be slower and have more overhead,
+// it does offer that advantage.
+//
+// R3-Alpha included some code to assist in debugging client code using series
+// such as by initializing the memory to garbage values. Given the existence
+// of modern tools like Valgrind and Address Sanitizer, Ren-C instead has a
+// mode in which pools are not used for data allocations, but going through
+// malloc and free. You can enable this by setting the environment variable
+// R3_ALWAYS_MALLOC to 1.
+//
- Each task needs its own series-save list that is simply a pointer
- array of un-rooted (NEW) series that should not be GCed. When
- a TRAP or THROW occurs, the list is trimmed back to its prior
- marker, allowing series that were orphaned by the TRAP to be GCed.
+#include "sys-core.h"
- When GC occurs, each series on the save list is mark-scanned to
- keep it alive. The save list can be expanded, but care should be
- used to avoid creating a huge list when recursion happens.
+#include "mem-pools.h" // low-level memory pool access
+#include "mem-series.h" // low-level series memory access
+
+#include "sys-int-funcs.h"
+
+
+//
+// Alloc_Mem: C
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// NOTE: Instead of Alloc_Mem, use the ALLOC and ALLOC_N wrapper macros to
+// ensure the memory block being freed matches the size for the type.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Alloc_Mem is an interface for a basic memory allocator. It is coupled with
+// a Free_Mem function that clients must call with the correct size of the
+// memory block to be freed. It is thus lower-level than malloc()... whose
+// where clients do not need to remember the size of the allocation to pass
+// into free().
+//
+// One motivation behind using such an allocator in Rebol is to allow it to
+// keep knowledge of how much memory the system is using. This means it can
+// decide when to trigger a garbage collection, or raise an out-of-memory error
+// before the operating system would, e.g. via 'ulimit':
+//
+// http://stackoverflow.com/questions/1229241/
+//
+// Finer-grained allocations are done with memory pooling. But the blocks of
+// memory used by the pools are still acquired using ALLOC_N and FREE_N, which
+// are interfaces to this routine.
+//
+void *Alloc_Mem(size_t size)
+{
+ // Trap memory usage limit *before* the allocation is performed
- What if interpreter kept track of save list marker when calling
- each native, and reset it on return?
-*/
+ PG_Mem_Usage += size;
+ if ((PG_Mem_Limit != 0) && (PG_Mem_Usage > PG_Mem_Limit))
+ Check_Security(Canon(SYM_MEMORY), POL_EXEC, 0);
-//-- Special Debugging Options:
-//#define CHAFF // Fill series data to crash old references
-//#define HIT_END // Crash if block tail is past block terminator.
-//#define WATCH_FREED // Show # series freed each GC
-//#define MEM_STRESS // Special torture mode enabled
-//#define INSPECT_SERIES
+ // While conceptually a simpler interface than malloc(), the
+ // current implementations on all C platforms just pass through to
+ // malloc and free.
-#include "sys-core.h"
+#ifdef NDEBUG
+ return malloc(size);
+#else
+ // In debug builds we cache the size at the head of the allocation
+ // so we can check it. This also allows us to catch cases when
+ // free() is paired with Alloc_Mem() instead of using Free_Mem()
+ //
+ // Note that we use a 64-bit quantity, as we want the allocations
+ // to remain suitable in alignment for 64-bit values!
+
+ void *ptr = malloc(size + sizeof(REBI64));
+ if (ptr == NULL)
+ return NULL;
+ *cast(REBI64 *, ptr) = size;
+ return cast(char *, ptr) + sizeof(REBI64);
+#endif
+}
-#define POOL_MAP
-#define BAD_MEM_PTR ((REBYTE *)0xBAD1BAD1)
+//
+// Free_Mem: C
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// NOTE: Instead of Free_Mem, use the FREE and FREE_N wrapper macros to ensure
+// the memory block being freed matches the appropriate size for the type.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Free_Mem is a wrapper over free(), that subtracts from a total count that
+// Rebol can see how much memory was released. This information assists in
+// deciding when it is necessary to run a garbage collection, or when to
+// impose a quota.
+//
+// Release builds have no way to check that the correct size is passed in
+// for the allocated unit. But in debug builds the size is stored with the
+// allocation and checked here. Also, the pointer is skewed such that if
+// clients try to use a normal free() and bypass Free_Mem it will trigger
+// debug alerts from the C runtime of trying to free a non-head-of-malloc.
+//
+// We also know the host allocator (OS_Alloc_Mem) uses a similar trick. But
+// since it doesn't require callers to remember the size, it puts a known
+// garbage value for this routine to check for--to give a useful message.
+//
+void Free_Mem(void *mem, size_t size)
+{
+#ifdef NDEBUG
+ free(mem);
+#else
+ assert(mem != NULL);
+ char *ptr = cast(char *, mem) - sizeof(REBI64);
+ if (*cast(REBI64 *, ptr) == cast(REBI64, -1020))
+ panic ("** FREE() used on OS_Alloc_Mem() memory instead of FREE()");
+
+ assert(*cast(REBI64*, ptr) == cast(REBI64, size));
+ free(ptr);
+#endif
+ PG_Mem_Usage -= size;
+}
+
-//#define GC_TRIGGER (GC_Active && (GC_Ballast <= 0 || (GC_Pending && !GC_Disabled)))
+#define POOL_MAP
#ifdef POOL_MAP
-#define FIND_POOL(n) ((n <= 4 * MEM_BIG_SIZE) ? (REBCNT)(PG_Pool_Map[n]) : SYSTEM_POOL)
+ #ifdef NDEBUG
+ #define FIND_POOL(n) \
+ ((n <= 4 * MEM_BIG_SIZE) \
+ ? cast(REBCNT, PG_Pool_Map[n]) \
+ : cast(REBCNT, SYSTEM_POOL))
+ #else
+ #define FIND_POOL(n) \
+ ((!PG_Always_Malloc && (n <= 4 * MEM_BIG_SIZE)) \
+ ? cast(REBCNT, PG_Pool_Map[n]) \
+ : cast(REBCNT, SYSTEM_POOL))
+ #endif
#else
-#define FIND_POOL(n) Find_Pool(n);
+ #ifdef NDEBUG
+ #define FIND_POOL(n) Find_Pool(n)
+ #else
+ #define FIND_POOL(n) (PG_Always_Malloc ? SYSTEM_POOL : Find_Pool(n))
+ #endif
#endif
-
/***********************************************************************
**
-** MEMORY POOLS
+** MEMORY POOLS
**
-** Memory management operates off an array of pools, the first
-** group of which are fixed size (so require no compaction).
+** Memory management operates off an array of pools, the first
+** group of which are fixed size (so require no compaction).
**
***********************************************************************/
const REBPOOLSPEC Mem_Pool_Spec[MAX_POOLS] =
{
- {8, 256}, // 0-8 Small string pool
-
- MOD_POOL( 1, 256), // 9-16 (when REBVAL is 16)
- MOD_POOL( 2, 512), // 17-32 - Small series (x 16)
- MOD_POOL( 3, 1024), // 33-64
- MOD_POOL( 4, 512),
- MOD_POOL( 5, 256),
- MOD_POOL( 6, 128),
- MOD_POOL( 7, 128),
- MOD_POOL( 8, 64),
- MOD_POOL( 9, 64),
- MOD_POOL(10, 64),
- MOD_POOL(11, 32),
- MOD_POOL(12, 32),
- MOD_POOL(13, 32),
- MOD_POOL(14, 32),
- MOD_POOL(15, 32),
- MOD_POOL(16, 64), // 257
- MOD_POOL(20, 32), // 321 - Mid-size series (x 64)
- MOD_POOL(24, 16), // 385
- MOD_POOL(28, 16), // 449
- MOD_POOL(32, 8), // 513
-
- DEF_POOL(MEM_BIG_SIZE, 16), // 1K - Large series (x 1024)
- DEF_POOL(MEM_BIG_SIZE*2, 8), // 2K
- DEF_POOL(MEM_BIG_SIZE*3, 4), // 3K
- DEF_POOL(MEM_BIG_SIZE*4, 4), // 4K
-
- DEF_POOL(sizeof(REBSER), 4096), // Series headers
- DEF_POOL(sizeof(REBGOB), 128), // Gobs
- DEF_POOL(1, 1), // Just used for tracking main memory
+ // R3-Alpha had a "0-8 small string pool". e.g. a pool of allocations for
+ // payloads 0 to 8 bytes in length. These are not technically possible in
+ // Ren-C's pool, because it requires 2*sizeof(void*) for each node at the
+ // minimum...because instead of just the freelist pointer, it has a
+ // standardized header (0 when free).
+ //
+ // This is not a problem, since all such small strings would also need
+ // REBSERs...and Ren-C has a better answer to embed the payload directly
+ // into the REBSER. This wouldn't apply if you were trying to do very
+ // small allocations of strings that did not have associated REBSERs..
+ // but those don't exist in the code.
+
+ MOD_POOL( 1, 256), // 9-16 (when REBVAL is 16)
+ MOD_POOL( 2, 512), // 17-32 - Small series (x 16)
+ MOD_POOL( 3, 1024), // 33-64
+ MOD_POOL( 4, 512),
+ MOD_POOL( 5, 256),
+ MOD_POOL( 6, 128),
+ MOD_POOL( 7, 128),
+ MOD_POOL( 8, 64),
+ MOD_POOL( 9, 64),
+ MOD_POOL(10, 64),
+ MOD_POOL(11, 32),
+ MOD_POOL(12, 32),
+ MOD_POOL(13, 32),
+ MOD_POOL(14, 32),
+ MOD_POOL(15, 32),
+ MOD_POOL(16, 64), // 257
+ MOD_POOL(20, 32), // 321 - Mid-size series (x 64)
+ MOD_POOL(24, 16), // 385
+ MOD_POOL(28, 16), // 449
+ MOD_POOL(32, 8), // 513
+
+ DEF_POOL(MEM_BIG_SIZE, 16), // 1K - Large series (x 1024)
+ DEF_POOL(MEM_BIG_SIZE*2, 8), // 2K
+ DEF_POOL(MEM_BIG_SIZE*3, 4), // 3K
+ DEF_POOL(MEM_BIG_SIZE*4, 4), // 4K
+
+ DEF_POOL(sizeof(REBSER), 4096), // Series headers
+ DEF_POOL(sizeof(REBGOB), 128), // Gobs
+ DEF_POOL(sizeof(REBI64), 1), // Just used for tracking main memory
};
-/***********************************************************************
-**
-*/ void *Make_Mem(size_t size)
-/*
-** Main memory allocation wrapper function.
-**
-***********************************************************************/
+//
+// Startup_Pools: C
+//
+// Initialize memory pool array.
+//
+void Startup_Pools(REBINT scale)
{
- void *ptr;
+#ifndef NDEBUG
+ const char *env_always_malloc = NULL;
+ env_always_malloc = getenv("R3_ALWAYS_MALLOC");
+ if (env_always_malloc != NULL && atoi(env_always_malloc) != 0) {
+ Debug_Str(
+ "**\n"
+ "** R3_ALWAYS_MALLOC is TRUE in environment variable!\n"
+ "** Memory allocations aren't pooled, expect slowness...\n"
+ "**\n"
+ );
+ PG_Always_Malloc = TRUE;
+ }
+#endif
- if (!(ptr = malloc(size))) return 0;
- PG_Mem_Usage += size;
- if (PG_Mem_Limit != 0 && (PG_Mem_Usage > PG_Mem_Limit)) {
- Check_Security(SYM_MEMORY, POL_EXEC, 0);
- }
- CLEAR(ptr, size);
+ REBINT unscale = 1;
+ if (scale == 0)
+ scale = 1;
+ else if (scale < 0) {
+ unscale = -scale;
+ scale = 1;
+ }
+
+ Mem_Pools = ALLOC_N(REBPOL, MAX_POOLS);
+
+ // Copy pool sizes to new pool structure:
+ //
+ REBCNT n;
+ for (n = 0; n < MAX_POOLS; n++) {
+ Mem_Pools[n].segs = NULL;
+ Mem_Pools[n].first = NULL;
+ Mem_Pools[n].last = NULL;
+
+ // The current invariant is that allocations returned from Make_Node()
+ // should always come back as being at a legal 64-bit alignment point.
+ // Although it would be possible to round the allocations, turning it
+ // into an alert helps make sure available space isn't idly wasted.
+ //
+ // A panic is used instead of an assert, since the debug sizes and
+ // release sizes may be different...and both must be checked.
+ //
+ if (Mem_Pool_Spec[n].wide % sizeof(REBI64) != 0)
+ panic ("memory pool width is not 64-bit aligned");
+
+ Mem_Pools[n].wide = Mem_Pool_Spec[n].wide;
+
+ Mem_Pools[n].units = (Mem_Pool_Spec[n].units * scale) / unscale;
+ if (Mem_Pools[n].units < 2) Mem_Pools[n].units = 2;
+ Mem_Pools[n].free = 0;
+ Mem_Pools[n].has = 0;
+ }
+
+ // For pool lookup. Maps size to pool index. (See Find_Pool below)
+ PG_Pool_Map = ALLOC_N(REBYTE, (4 * MEM_BIG_SIZE) + 1);
+
+ // sizes 0 - 8 are pool 0
+ for (n = 0; n <= 8; n++) PG_Pool_Map[n] = 0;
+ for (; n <= 16 * MEM_MIN_SIZE; n++)
+ PG_Pool_Map[n] = MEM_TINY_POOL + ((n-1) / MEM_MIN_SIZE);
+ for (; n <= 32 * MEM_MIN_SIZE; n++)
+ PG_Pool_Map[n] = MEM_SMALL_POOLS-4 + ((n-1) / (MEM_MIN_SIZE * 4));
+ for (; n <= 4 * MEM_BIG_SIZE; n++)
+ PG_Pool_Map[n] = MEM_MID_POOLS + ((n-1) / MEM_BIG_SIZE);
+
+ // !!! Revisit where series init/shutdown goes when the code is more
+ // organized to have some of the logic not in the pools file
+
+#if !defined(NDEBUG)
+ PG_Reb_Stats = ALLOC(REB_STATS);
+#endif
- return ptr;
+ // Manually allocated series that GC is not responsible for (unless a
+ // trap occurs). Holds series pointers.
+ //
+ // As a trick to keep this series from trying to track itself, say it's
+ // managed, then sneak the flag off.
+ //
+ GC_Manuals = Make_Series_Core(15, sizeof(REBSER *), NODE_FLAG_MANAGED);
+ CLEAR_SER_FLAG(GC_Manuals, NODE_FLAG_MANAGED);
+
+ Prior_Expand = ALLOC_N(REBSER*, MAX_EXPAND_LIST);
+ CLEAR(Prior_Expand, sizeof(REBSER*) * MAX_EXPAND_LIST);
+ Prior_Expand[0] = (REBSER*)1;
}
-/***********************************************************************
-**
-*/ void Free_Mem(void *mem, size_t size)
-/*
-***********************************************************************/
+//
+// Shutdown_Pools: C
+//
+// Release all segments in all pools, and the pools themselves.
+//
+void Shutdown_Pools(void)
{
- PG_Mem_Usage -= size;
- free(mem);
-}
+ // Can't use Free_Series() because GC_Manuals couldn't be put in
+ // the manuals list...
+ //
+ GC_Kill_Series(GC_Manuals);
+
+#if !defined(NDEBUG)
+ REBSEG *seg = Mem_Pools[SER_POOL].segs;
+ for(; seg != NULL; seg = seg->next) {
+ REBSER *series = cast(REBSER*, seg + 1);
+ REBCNT n;
+ for (n = Mem_Pools[SER_POOL].units; n > 0; n--, series++) {
+ if (IS_FREE_NODE(series))
+ continue;
+
+ printf("At least one leaked series at shutdown...\n");
+ panic (series);
+ }
+ }
+#endif
+ REBCNT pool_num;
+ for (pool_num = 0; pool_num < MAX_POOLS; pool_num++) {
+ REBPOL *pool = &Mem_Pools[pool_num];
+ REBCNT mem_size = pool->wide * pool->units + sizeof(REBSEG);
-/***********************************************************************
-**
-*/ void Init_Pools(REBINT scale)
-/*
-** Initialize memory pool array.
-**
-***********************************************************************/
-{
- REBINT n;
- REBINT unscale = 1;
-
- if (scale == 0) scale = 1;
- else if (scale < 0) unscale = -scale, scale = 1;
-
- // Copy pool sizes to new pool structure:
- Mem_Pools = Make_Mem(sizeof(REBPOL) * MAX_POOLS);
- for (n = 0; n < MAX_POOLS; n++) {
- Mem_Pools[n].wide = Mem_Pool_Spec[n].wide;
- Mem_Pools[n].units = (Mem_Pool_Spec[n].units * scale) / unscale;
- if (Mem_Pools[n].units < 2) Mem_Pools[n].units = 2;
- }
-
- // For pool lookup. Maps size to pool index. (See Find_Pool below)
- PG_Pool_Map = Make_Mem((4 * MEM_BIG_SIZE) + 4); // extra
- n = 9; // sizes 0 - 8 are pool 0
- for (; n <= 16 * MEM_MIN_SIZE; n++) PG_Pool_Map[n] = MEM_TINY_POOL + ((n-1) / MEM_MIN_SIZE);
- for (; n <= 32 * MEM_MIN_SIZE; n++) PG_Pool_Map[n] = MEM_SMALL_POOLS-4 + ((n-1) / (MEM_MIN_SIZE * 4));
- for (; n <= 4 * MEM_BIG_SIZE; n++) PG_Pool_Map[n] = MEM_MID_POOLS + ((n-1) / MEM_BIG_SIZE);
+ REBSEG *seg = pool->segs;
+ while (seg) {
+ REBSEG *next;
+ next = seg->next;
+ FREE_N(char, mem_size, cast(char*, seg));
+ seg = next;
+ }
+ }
+
+ FREE_N(REBPOL, MAX_POOLS, Mem_Pools);
+
+ FREE_N(REBYTE, (4 * MEM_BIG_SIZE) + 1, PG_Pool_Map);
+
+ // !!! Revisit location (just has to be after all series are freed)
+ FREE_N(REBSER*, MAX_EXPAND_LIST, Prior_Expand);
+
+#if !defined(NDEBUG)
+ FREE(REB_STATS, PG_Reb_Stats);
+#endif
+
+#if !defined(NDEBUG)
+ if (PG_Mem_Usage != 0) {
+ //
+ // If using valgrind or address sanitizer, they can present more
+ // information about leaks than just how much was leaked. So don't
+ // assert...exit normally so they go through their process of
+ // presenting the leaks at program termination.
+ //
+ printf(
+ "*** PG_Mem_Usage = %lu ***\n",
+ cast(unsigned long, PG_Mem_Usage)
+ );
+
+ printf(
+ "Memory accounting imbalance: Rebol internally tracks how much\n"
+ "memory it uses to know when to garbage collect, etc. For\n"
+ "some reason this accounting did not balance to zero on exit.\n"
+ "Run under Valgrind with --leak-check=full --track-origins=yes\n"
+ "to find out why this is happening.\n"
+ );
+ }
+#endif
}
-#ifndef POOL_MAP
-/***********************************************************************
-**
-*/ static INLINE REBCNT Find_Pool(REBCNT size)
-/*
-** Given a size, tell us what pool it belongs to.
-**
-***********************************************************************/
+//
+// Fill_Pool: C
+//
+// Allocate memory for a pool. The amount allocated will be determined from
+// the size and units specified when the pool header was created. The nodes
+// of the pool are linked to the free list.
+//
+static void Fill_Pool(REBPOL *pool)
{
- if (size <= 8) return 0; // Note: 0 - 8 (and size change for proper modulus)
- size--;
- if (size < 16 * MEM_MIN_SIZE) return MEM_TINY_POOL + (size / MEM_MIN_SIZE);
- if (size < 32 * MEM_MIN_SIZE) return MEM_SMALL_POOLS-4 + (size / (MEM_MIN_SIZE * 4));
- if (size < 4 * MEM_BIG_SIZE) return MEM_MID_POOLS + (size / MEM_BIG_SIZE);
- return SYSTEM_POOL;
+ REBCNT units = pool->units;
+ REBCNT mem_size = pool->wide * units + sizeof(REBSEG);
+
+ REBSEG *seg = cast(REBSEG *, ALLOC_N(char, mem_size));
+ if (seg == NULL) {
+ panic ("Out of memory error during Fill_Pool()");
+
+ // Rebol's safe handling of running out of memory was never really
+ // articulated. Yet it should be possible to run a fail()...at least
+ // of a certain type...without allocating more memory. (This probably
+ // suggests a need for pre-creation of the out of memory objects,
+ // as is done with the stack overflow error)
+ //
+ // fail (Error_No_Memory(mem_size));
+ }
+
+ seg->size = mem_size;
+ seg->next = pool->segs;
+ pool->segs = seg;
+ pool->has += units;
+ pool->free += units;
+
+ // Add new nodes to the end of free list:
+
+ // Can't use NOD() here because it tests for NOT(NODE_FLAG_FREE)
+ //
+ REBNOD *node = cast(REBNOD*, seg + 1);
+
+ if (pool->first == NULL) {
+ assert(pool->last == NULL);
+ pool->first = node;
+ }
+ else {
+ assert(pool->last != NULL);
+ pool->last->next_if_free = node;
+ }
+
+ while (TRUE) {
+ //
+ // See Init_Endlike_Header() for why we do this
+ //
+ struct Reb_Header *alias = &node->header;
+ alias->bits = FLAGBYTE_FIRST(FREED_SERIES_BYTE);
+
+ if (--units == 0) {
+ node->next_if_free = NULL;
+ break;
+ }
+
+ // Can't use NOD() here because it tests for NODE_FLAG_FREE
+ //
+ node->next_if_free = cast(REBNOD*, cast(REBYTE*, node) + pool->wide);
+ node = node->next_if_free;
+ }
+
+ pool->last = node;
}
-/***********************************************************************
-**
-** void Check_Pool_Map(void)
-/*
-************************************************************************
+//
+// Make_Node: C
+//
+// Allocate a node from a pool. If the pool has run out of nodes, it will
+// be refilled.
+//
+// The node will not be zero-filled. However its header bits will be
+// guaranteed to be zero--which is the same as the state of all freed nodes.
+// Callers likely want to change this to not be zero, so that zero can be
+// used to recognize freed nodes if they enumerate the pool themselves.
+//
+// All nodes are 64-bit aligned. This way, data allocated in nodes can be
+// structured to know where legal 64-bit alignment points would be. This
+// is required for correct functioning of some types. (See notes on
+// alignment in %sys-rebval.h.)
+//
+void *Make_Node(REBCNT pool_id)
{
- int n;
+ REBPOL *pool = &Mem_Pools[pool_id];
+ if (pool->first == NULL)
+ Fill_Pool(pool);
+
+ assert(pool->first != NULL);
+
+ REBNOD *node = pool->first;
- for (n = 0; n <= 4 * MEM_BIG_SIZE + 1; n++)
- if (FIND_POOL(n) != Find_Pool(n))
- Debug_Fmt("%d: %d %d", n, FIND_POOL(n), Find_Pool(n));
+ pool->first = node->next_if_free;
+ if (node == pool->last)
+ pool->last = NULL;
+
+ pool->free--;
+
+ assert(cast(REBUPT, node) % sizeof(REBI64) == 0);
+ assert(IS_FREE_NODE(node)); // client needs to change to non-zero
+
+ return cast(void *, node);
}
-*/
-#endif
-/***********************************************************************
-**
-*/ static void Fill_Pool(REBPOL *pool)
-/*
-** Allocate memory for a pool. The amount allocated will be
-** determined from the size and units specified when the
-** pool header was created. The nodes of the pool are linked
-** to the free list.
-**
-***********************************************************************/
+//
+// Free_Node: C
+//
+// Free a node, returning it to its pool. Once it is freed, its header will
+// be set to 0. This will identify the node as not in use to anyone who
+// enumerates the nodes in the pool (such as the garbage collector).
+//
+void Free_Node(REBCNT pool_id, void *p)
{
- REBSEG *seg;
- REBNOD *node;
- REBYTE *next;
- REBCNT units = pool->units;
-#ifdef MUNGWALL
- REBCNT mem_size = (pool->wide + 2 * MUNG_SIZE) * units + sizeof(REBSEG);
+ REBNOD *node = NOD(p);
+
+ // See Init_Endlike_Header() for why we do this
+ //
+ struct Reb_Header *alias = &node->header;
+ alias->bits = FLAGBYTE_FIRST(FREED_SERIES_BYTE);
+
+ REBPOL *pool = &Mem_Pools[pool_id];
+
+#ifdef NDEBUG
+ node->next_if_free = pool->first;
+ pool->first = node;
#else
- REBCNT mem_size = pool->wide * units + sizeof(REBSEG);
+ // !!! In R3-Alpha, the most recently freed node would become the first
+ // node to hand out. This is a simple and likely good strategy for
+ // cache usage, but makes the "poisoning" nearly useless.
+ //
+ // This code was added to insert an empty segment, such that this node
+ // won't be picked by the next Make_Node. That enlongates the poisonous
+ // time of this area to catch stale pointers. But doing this in the
+ // debug build only creates a source of variant behavior.
+
+ if (pool->last == NULL) // Fill pool if empty
+ Fill_Pool(pool);
+
+ assert(pool->last != NULL);
+
+ pool->last->next_if_free = node;
+ pool->last = node;
+ node->next_if_free = NULL;
+
#endif
- seg = (REBSEG *) Make_Mem(mem_size);
- if (!seg) Crash(RP_NO_MEMORY, mem_size);
-
- CLEAR(seg, mem_size); // needed to clear series nodes
- seg->size = mem_size;
- seg->next = pool->segs;
- pool->segs = seg;
- pool->free += units;
- pool->has += units;
-
- // Add new nodes to the end of free list:
- for (node = (REBNOD *)&pool->first; *node; node = *node); // goto end
-
-#ifdef MUNGWALL
- for (next = (REBYTE *)(seg + 1); units > 0; units--) {
- memcpy(next,MUNG_PATTERN1,MUNG_SIZE);
- memcpy(next+MUNG_SIZE+pool->wide,MUNG_PATTERN2,MUNG_SIZE);
- *node = (REBNOD) (next+MUNG_SIZE);
- node = *node;
- next+=pool->wide+2*MUNG_SIZE;
- }
-#else
- for (next = (REBYTE *)(seg + 1); units > 0; units--, next += pool->wide) {
- *node = (REBNOD) next;
- node = *node;
- }
+ pool->free++;
+}
+
+
+//
+// Series_Data_Alloc: C
+//
+// Allocates element array for an already allocated REBSER node structure.
+// Resets the bias and tail to zero, and sets the new width. Flags like
+// SERIES_FLAG_FIXED_SIZE are left as they were, and other fields in the
+// series structure are untouched.
+//
+// This routine can thus be used for an initial construction or an operation
+// like expansion. Currently not exported from this file.
+//
+static REBOOL Series_Data_Alloc(REBSER *s, REBCNT length) {
+ //
+ // Data should have not been allocated yet OR caller has extracted it
+ // and nulled it to indicate taking responsibility for freeing it.
+ //
+ assert(s->content.dynamic.data == NULL);
+
+ REBYTE wide = SER_WIDE(s);
+ assert(wide != 0);
+
+ REBCNT size; // size of allocation (possibly bigger than we need)
+
+ REBCNT pool_num = FIND_POOL(length * wide);
+ if (pool_num < SYSTEM_POOL) {
+ // ...there is a pool designated for allocations of this size range
+ s->content.dynamic.data = cast(REBYTE*, Make_Node(pool_num));
+ if (s->content.dynamic.data == NULL)
+ return FALSE;
+
+ // The pooled allocation might wind up being larger than we asked.
+ // Don't waste the space...mark as capacity the series could use.
+ size = Mem_Pools[pool_num].wide;
+ assert(size >= length * wide);
+
+ // We don't round to power of 2 for allocations in memory pools
+ CLEAR_SER_FLAG(s, SERIES_FLAG_POWER_OF_2);
+ }
+ else {
+ // ...the allocation is too big for a pool. But instead of just
+ // doing an unpooled allocation to give you the size you asked
+ // for, the system does some second-guessing to align to 2Kb
+ // boundaries (or choose a power of 2, if requested).
+
+ size = length * wide;
+ if (GET_SER_FLAG(s, SERIES_FLAG_POWER_OF_2)) {
+ REBCNT len = 2048;
+ while(len < size)
+ len *= 2;
+ size = len;
+
+ // Clear the power of 2 flag if it isn't necessary, due to even
+ // divisibility by the item width.
+ //
+ if (size % wide == 0)
+ CLEAR_SER_FLAG(s, SERIES_FLAG_POWER_OF_2);
+ }
+
+ s->content.dynamic.data = ALLOC_N(REBYTE, size);
+ if (s->content.dynamic.data == NULL)
+ return FALSE;
+
+ Mem_Pools[SYSTEM_POOL].has += size;
+ Mem_Pools[SYSTEM_POOL].free++;
+ }
+
+ // Note: Bias field may contain other flags at some point. Because
+ // SER_SET_BIAS() uses bit masking on an existing value, we are sure
+ // here to clear out the whole value for starters.
+ //
+ s->content.dynamic.bias = 0;
+
+ // The allocation may have returned more than we requested, so we note
+ // that in 'rest' so that the series can expand in and use the space.
+ // Note that it wastes remainder if size % wide != 0 :-(
+ //
+ s->content.dynamic.rest = size / wide;
+
+ // We set the tail of all series to zero initially, but currently do
+ // leave series termination to callers. (This is under review.)
+ //
+ s->content.dynamic.len = 0;
+
+ // Currently once a series becomes dynamic, it never goes back. There is
+ // no shrinking process that will pare it back to fit completely inside
+ // the REBSER node.
+ //
+ SET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC);
+
+ // See if allocation tripped our need to queue a garbage collection
+
+ if ((GC_Ballast -= size) <= 0)
+ SET_SIGNAL(SIG_RECYCLE);
+
+#if !defined(NDEBUG)
+ if (pool_num >= SYSTEM_POOL)
+ assert(Series_Allocation_Unpooled(s) == size);
#endif
- *node = 0;
+
+ if (GET_SER_FLAG(s, SERIES_FLAG_ARRAY)) {
+ assert(wide == sizeof(REBVAL));
+
+ REBCNT n;
+
+ #if !defined(NDEBUG)
+ PG_Reb_Stats->Blocks++;
+ #endif
+
+ // For REBVAL-valued-arrays, we mark as trash to mark the "settable"
+ // bit, heeded by both SET_END() and RESET_HEADER(). See remarks on
+ // VALUE_FLAG_CELL for why this is done.
+ //
+ // Note that the "len" field of the series (its number of valid
+ // elements as maintained by the client) will be 0. As far as this
+ // layer is concerned, we've given back `length` entries for the
+ // caller to manage...they do not know about the ->rest
+ //
+ for (n = 0; n < length; n++)
+ INIT_CELL(ARR_AT(ARR(s), n));
+
+ // !!! We should intentionally mark the overage range as not having
+ // NODE_FLAG_CELL in the debug build. Then have the series go through
+ // an expansion to overrule it.
+ //
+ // That's complicated logic that is likely best done in the context of
+ // a simplifying review of the series mechanics themselves. So
+ // for now we just use ordinary trash...which means we don't get
+ // as much potential debug warning as we might when writing into
+ // bias or tail capacity.
+ //
+ // !!! Also, should the release build do the NODE_FLAG_CELL setting
+ // up front, or only on expansions?
+ //
+ for(; n < s->content.dynamic.rest - 1; n++) {
+ INIT_CELL(ARR_AT(ARR(s), n));
+ }
+
+ // The convention is that the *last* cell in the allocated capacity
+ // is an unwritable end. This may be located arbitrarily beyond the
+ // capacity the user requested, if a pool unit was used that was
+ // bigger than they asked for...but this will be used in expansion.
+ //
+ // Having an unwritable END in that spot paves the way for more forms
+ // of implicit termination. In theory one should not need 5 cells
+ // to hold an array of length 4...the 5th header position can merely
+ // mark termination with the low bit clear.
+ //
+ // Currently only singular arrays exploit this, but since they exist
+ // they must be accounted for. Because callers cannot write past the
+ // capacity they requested, they must use TERM_ARRAY_LEN(), which
+ // avoids writing the unwritable locations by checking for END first.
+ //
+ RELVAL *ultimate = ARR_AT(ARR(s), s->content.dynamic.rest - 1);
+ Init_Endlike_Header(&ultimate->header, 0);
+ #if !defined(NDEBUG)
+ Set_Track_Payload_Debug(ultimate, __FILE__, __LINE__);
+ #endif
+ }
+
+ return TRUE;
}
-/***********************************************************************
-**
-*/ void *Make_Node(REBCNT pool_id)
-/*
-** Allocate a node from a pool. The node will NOT be cleared.
-** If the pool has run out of nodes, it will be refilled.
-**
-***********************************************************************/
+#if !defined(NDEBUG)
+
+//
+// Try_Find_Containing_Series_Debug: C
+//
+// This debug-build-only routine will look to see if it can find what series
+// a data pointer lives in. It returns NULL if it can't find one. It's very
+// slow, because it has to look at all the series. Use sparingly!
+//
+REBSER *Try_Find_Containing_Series_Debug(const void *p)
{
- REBNOD *node;
- REBPOL *pool;
-
- pool = &Mem_Pools[pool_id];
- if (!pool->first) Fill_Pool(pool);
- node = pool->first;
- pool->first = *node;
- pool->free--;
- return (void *)node;
+ REBSEG *seg;
+
+ for (seg = Mem_Pools[SER_POOL].segs; seg; seg = seg->next) {
+ REBSER *s = cast(REBSER*, seg + 1);
+ REBCNT n;
+ for (n = Mem_Pools[SER_POOL].units; n > 0; --n, ++s) {
+ if (IS_FREE_NODE(s))
+ continue;
+
+ if (s->header.bits & NODE_FLAG_CELL) { // a pairing, REBSER is REBVAL[2]
+ if ((p >= cast(void*, s)) && (p < cast(void*, s + 1))) {
+ printf("pointer found in 'pairing' series");
+ printf("not a real REBSER, no information available");
+ assert(FALSE);
+ }
+ continue;
+ }
+
+ if (NOT(GET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC))) {
+ if (
+ p >= cast(void*, &s->content)
+ && p < cast(void*, &s->content + 1)
+ ){
+ return s;
+ }
+ continue;
+ }
+
+ if (p < cast(void*,
+ s->content.dynamic.data - (SER_WIDE(s) * SER_BIAS(s))
+ )) {
+ // The memory lies before the series data allocation.
+ //
+ continue;
+ }
+
+ if (p >= cast(void*, s->content.dynamic.data
+ + (SER_WIDE(s) * SER_REST(s))
+ )) {
+ // The memory lies after the series capacity.
+ //
+ continue;
+ }
+
+ // We now have a bad condition, in that the pointer is known to
+ // be inside a series data allocation. But it could be doubly
+ // bad if the pointer is in the extra head or tail capacity,
+ // because that's effectively free data. Since we're already
+ // going to be asserting if we get here, go ahead and pay to
+ // check if either of those is the case.
+
+ if (p < cast(void*, s->content.dynamic.data)) {
+ printf("Pointer found in freed head capacity of series\n");
+ fflush(stdout);
+ return s;
+ }
+
+ if (p >= cast(void*,
+ s->content.dynamic.data
+ + (SER_WIDE(s) * SER_LEN(s))
+ )) {
+ printf("Pointer found in freed tail capacity of series\n");
+ fflush(stdout);
+ return s;
+ }
+
+ return s;
+ }
+ }
+
+ return NULL; // not found
}
+#endif
-/***********************************************************************
-**
-*/ void Free_Node(REBCNT pool_id, REBNOD *node)
-/*
-** Free a node, returning it to its pool.
-**
-***********************************************************************/
+
+//
+// Series_Allocation_Unpooled: C
+//
+// When we want the actual memory accounting for a series, the whole story may
+// not be told by the element size multiplied by the capacity. The series may
+// have been allocated from a pool where it was rounded up to the pool size,
+// and elements may not fit evenly in that space. Or it may be allocated from
+// the "system pool" via Alloc_Mem, but rounded up to a power of 2.
+//
+// (Note: It's necessary to know the size because Free_Mem requires it, as
+// Rebol's allocator doesn't remember the size of system pool allocations for
+// you. It also needs it in order to keep track of GC boundaries and memory
+// use quotas.)
+//
+// Rather than pay for the cost on every series of an "actual allocation size",
+// the optimization choice is to only pay for a "rounded up to power of 2" bit.
+//
+REBCNT Series_Allocation_Unpooled(REBSER *series)
{
- MUNG_CHECK(pool_id, node, Mem_Pools[pool_id].wide);
- *node = Mem_Pools[pool_id].first;
- Mem_Pools[pool_id].first = node;
- Mem_Pools[pool_id].free++;
+ REBCNT total = SER_TOTAL(series);
+
+ if (GET_SER_FLAG(series, SERIES_FLAG_POWER_OF_2)) {
+ REBCNT len = 2048;
+ while(len < total)
+ len *= 2;
+ return len;
+ }
+
+ return total;
}
-/***********************************************************************
-**
-*/ REBSER *Make_Series_Data(REBSER *series, REBCNT length)
-/*
-** Allocates memory for series data of the given width
-** and length (number of units).
-**
-** Can be used by Make_Series below once we measure to
-** determine performance impact. !!!
-**
-***********************************************************************/
+//
+// Make_Series_Core: C
+//
+// Make a series of a given capacity and width (unit size).
+// If the data is tiny enough, it will be fit into the series node itself.
+// Small series will be allocated from a memory pool.
+// Large series will be allocated from system memory.
+// The series will be zero length to start with.
+//
+REBSER *Make_Series_Core(REBCNT capacity, REBYTE wide, REBUPT flags)
{
- REBNOD *node;
- REBPOL *pool;
- REBCNT pool_num;
-
-// if (GC_TRIGGER) Recycle();
-
- length *= SERIES_WIDE(series);
- pool_num = FIND_POOL(length);
- if (pool_num < SYSTEM_POOL) {
- pool = &Mem_Pools[pool_num];
- if (!pool->first) Fill_Pool(pool);
- node = pool->first;
- pool->first = *node;
- pool->free--;
- length = pool->wide;
- } else {
- length = ALIGN(length, 2048);
-#ifdef DEBUGGING
- Debug_Fmt_Num("Alloc1:", length);
+ assert(wide != 0 && capacity != 0); // not allowed
+
+ if (cast(REBU64, capacity) * wide > MAX_I32)
+ fail (Error_No_Memory(cast(REBU64, capacity) * wide));
+
+#if !defined(NDEBUG)
+ PG_Reb_Stats->Series_Made++;
+ PG_Reb_Stats->Series_Memory += capacity * wide;
#endif
-#ifdef MUNGWALL
- node = (REBNOD *) Make_Mem(length+2*MUNG_SIZE);
-#else
- node = (REBNOD *) Make_Mem(length);
+
+ REBSER *s = cast(REBSER*, Make_Node(SER_POOL));
+
+ // Header bits can't be zero. NODE_FLAG_NODE is sufficient to identify
+ // this as a REBSER node that is not GC managed.
+ //
+ s->header.bits = NODE_FLAG_NODE | flags;
+
+ if ((GC_Ballast -= sizeof(REBSER)) <= 0)
+ SET_SIGNAL(SIG_RECYCLE);
+
+#if !defined(NDEBUG)
+ //
+ // For debugging purposes, it's nice to be able to crash on some
+ // kind of guard for tracking the call stack at the point of allocation
+ // if we find some undesirable condition that we want a trace from
+ //
+ s->guard = cast(int*, malloc(sizeof(*s->guard)));
+ free(s->guard);
+
+ TRASH_POINTER_IF_DEBUG(s->link.keylist);
+ TRASH_POINTER_IF_DEBUG(s->misc.canon);
+
+ // It's necessary to have another value in order to round out the size of
+ // the pool node so pointer-aligned entries are given out, so might as well
+ // make that hold a useful value--the tick count when the series was made
+ //
+ s->do_count = TG_Do_Count;
#endif
- if (!node) Trap0(RE_NO_MEMORY);
-#ifdef MUNGWALL
- memcpy((REBYTE *)node,MUNG_PATTERN1,MUNG_SIZE);
- memcpy(((REBYTE *)node)+length+MUNG_SIZE,MUNG_PATTERN2,MUNG_SIZE);
- node=(REBNOD *)(((REBYTE *)node)+MUNG_SIZE);
+
+ // The info bits must be able to implicitly terminate the `content`,
+ // so that if a REBVAL is in slot [0] then it would appear terminated
+ // if the [1] slot was read.
+ //
+ Init_Endlike_Header(&s->info, 0); // acts as unwritable END marker
+ assert(IS_END(&s->content.values[1])); // test by using Reb_Value pointer
+
+ s->content.dynamic.data = NULL;
+
+ assert(wide != 0);
+ SER_SET_WIDE(s, wide);
+
+ if ((flags & SERIES_FLAG_ARRAY) && capacity <= 2) {
+ //
+ // An array requested of capacity 2 actually means one cell of data
+ // and one cell that can serve as an END marker. The invariant that
+ // is guaranteed is that the final slot will already be written as
+ // an END, and that the caller must never write it...hence it can
+ // be less than a full cell's size.
+ //
+ assert(NOT_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC));
+ INIT_CELL(&s->content.values[0]);
+ }
+ else if (capacity * wide <= sizeof(s->content)) {
+ assert(NOT_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC));
+ }
+ else {
+ // Allocate the actual data blob that holds the series elements
+
+ if (!Series_Data_Alloc(s, capacity)) {
+ Free_Node(SER_POOL, s);
+ fail (Error_No_Memory(capacity * wide));
+ }
+
+ // <> - The capacity that will be given back as the ->rest
+ // field may be larger than the requested size. The memory pool API
+ // is able to give back the size of the actual allocated block--which
+ // includes any overage. So to keep that from going to waste it is
+ // recorded as the block's capacity, in case it ever needs to grow
+ // it might be able to save on a reallocation.
+ }
+
+ // It is possible for a series to start out unmanaged and then be
+ // transitioned to managed, or it may start off in a managed state. It
+ // is more efficient if you know a series is going to be managed to
+ // create it in the managed state (it doesn't have to be added and
+ // removed from a manuals list). But be sure no evaluations are called
+ // in that case before the places that will hold it live are set up.
+ //
+ // Note: The call to create GC_Manuals itself lies and says it is managed,
+ // just for the moment of set up, so it doesn't try to add itself to the
+ // manuals list! It removes the managed flag after the create.
+ //
+ if (NOT(flags & NODE_FLAG_MANAGED)) {
+ assert(GET_SER_INFO(GC_Manuals, SERIES_INFO_HAS_DYNAMIC));
+
+ if (SER_FULL(GC_Manuals))
+ Extend_Series(GC_Manuals, 8);
+
+ cast(REBSER**, GC_Manuals->content.dynamic.data)[
+ GC_Manuals->content.dynamic.len++
+ ] = s;
+ }
+
+ // Since we're not the scanner, the only way we can attribute a file and
+ // a line number to a series created at runtime is to examine the frame
+ // stack and propagate whatever file and line number information it might
+ // know about from the source it's running onto this series.
+ //
+ if (flags & SERIES_FLAG_FILE_LINE) {
+ //
+ // !!! Feature TBD. Until then take off the flag since leaving it on
+ // and not setting the fields would crash the GC.
+ //
+ // s->link.filename = ???
+ // s->misc.line = ???;
+ //
+ CLEAR_SER_FLAG(s, SERIES_FLAG_FILE_LINE);
+ }
+
+ assert(s->info.bits & NODE_FLAG_END);
+ assert(NOT(s->info.bits & NODE_FLAG_CELL));
+ assert(SER_LEN(s) == 0);
+ return s;
+}
+
+
+//
+// Alloc_Pairing: C
+//
+// Allocate a paired set of values. The "key" is in the cell *before* the
+// returned pointer.
+//
+// Because pairings are created in large numbers and left outstanding, they
+// are not put into any tracking lists by default. This means that if there
+// is a fail(), they will leak--unless whichever API client that is using
+// them ensures they are cleaned up. So in C++, this is done with exception
+// handling.
+//
+// However, untracked/unmanaged pairings have a special ability. It's
+// possible for them to be "owned" by a FRAME!, which sits in the first cell.
+// This provides an alternate mechanism for plain C code to do cleanup besides
+// handlers based on PUSH_TRAP().
+//
+REBVAL *Alloc_Pairing(REBCTX *opt_owning_frame) {
+ REBSER *s = cast(REBSER*, Make_Node(SER_POOL)); // 2x REBVAL size
+
+ REBVAL *key = cast(REBVAL*, s);
+ REBVAL *paired = key + 1;
+
+ INIT_CELL(key);
+ if (opt_owning_frame) {
+ Init_Any_Context(key, REB_FRAME, opt_owning_frame);
+ SET_VAL_FLAGS(
+ key, ANY_CONTEXT_FLAG_OWNS_PAIRED | NODE_FLAG_ROOT
+ );
+ }
+ else {
+ // Client will need to put *something* in the key slot (accessed with
+ // PAIRING_KEY). Whatever they end up writing should be acceptable
+ // to avoid a GC, since the header is not purely 0...and it works out
+ // that all "ordinary" values will just act as unmanaged metadata.
+ //
+ TRASH_CELL_IF_DEBUG(key);
+ }
+
+ INIT_CELL(paired);
+ TRASH_CELL_IF_DEBUG(paired);
+
+#if !defined(NDEBUG)
+ s->guard = cast(int*, malloc(sizeof(*s->guard)));
+ free(s->guard);
+
+ s->do_count = TG_Do_Count;
#endif
- Mem_Pools[SYSTEM_POOL].has += length;
- Mem_Pools[SYSTEM_POOL].free++;
- }
-#ifdef CHAFF
- memset((REBYTE *)node, 0xff, length);
+
+ return paired;
+}
+
+
+//
+// Manage_Pairing: C
+//
+// GC management is a one-way street in Ren-C, and the paired management
+// status is handled by bits directly in the first (or key's) REBVAL header.
+// Switching to managed mode means the key can no longer be changed--only
+// the value.
+//
+// !!! a const_Pairing_Key() accessor should help enforce the rule, only
+// allowing const access if managed.
+//
+void Manage_Pairing(REBVAL *paired) {
+ REBVAL *key = PAIRING_KEY(paired);
+ SET_VAL_FLAG(key, NODE_FLAG_MANAGED);
+}
+
+
+//
+// Free_Pairing: C
+//
+void Free_Pairing(REBVAL *paired) {
+ REBVAL *key = PAIRING_KEY(paired);
+ assert(NOT_VAL_FLAG(key, NODE_FLAG_MANAGED));
+ REBSER *series = cast(REBSER*, key);
+ TRASH_CELL_IF_DEBUG(paired);
+ Free_Node(SER_POOL, series);
+
+#if !defined(NDEBUG)
+ series->do_count = TG_Do_Count;
#endif
- series->tail = 0;
- SERIES_REST(series) = length / SERIES_WIDE(series);
- series->data = (REBYTE *)node;
- if ((GC_Ballast -= length) <= 0) SET_SIGNAL(SIG_RECYCLE);
- return series;
}
-/***********************************************************************
-**
-*/ REBSER *Make_Series(REBCNT length, REBCNT wide, REBOOL powerof2)
-/*
-** Make a series of a given length and width (unit size).
-** Small series will be allocated from a REBOL pool.
-** Large series will be allocated from system memory.
-** A width of zero is not allowed.
-**
-***********************************************************************/
+//
+// Swap_Underlying_Series_Data: C
+//
+void Swap_Underlying_Series_Data(REBSER *s1, REBSER *s2)
+{
+ assert(SER_WIDE(s1) == SER_WIDE(s2));
+ assert(
+ GET_SER_FLAG(s1, SERIES_FLAG_ARRAY)
+ == GET_SER_FLAG(s2, SERIES_FLAG_ARRAY)
+ );
+
+ REBSER temp = *s1;
+ *s1 = *s2;
+ *s2 = temp;
+}
+
+
+//
+// Free_Unbiased_Series_Data: C
+//
+// Routines that are part of the core series implementation
+// call this, including Expand_Series. It requires a low-level
+// awareness that the series data pointer cannot be freed
+// without subtracting out the "biasing" which skips the pointer
+// ahead to account for unused capacity at the head of the
+// allocation. They also must know the total allocation size.
+//
+static void Free_Unbiased_Series_Data(REBYTE *unbiased, REBCNT size_unpooled)
+{
+ REBCNT pool_num = FIND_POOL(size_unpooled);
+ REBPOL *pool;
+
+ if (pool_num < SYSTEM_POOL) {
+ //
+ // The series data does not honor "node protocol" when it is in use
+ // The pools are not swept the way the REBSER pool is, so only the
+ // free nodes have significance to their headers. Use a cast and not
+ // NOD() because that assumes NOT(NODE_FLAG_FREE)
+ //
+ REBNOD *node = cast(REBNOD*, unbiased);
+
+ assert(Mem_Pools[pool_num].wide >= size_unpooled);
+
+ pool = &Mem_Pools[pool_num];
+ node->next_if_free = pool->first;
+ pool->first = node;
+ pool->free++;
+
+ // See Init_Endlike_Header() for why we do this
+ //
+ struct Reb_Header *alias = &node->header;
+ alias->bits = FLAGBYTE_FIRST(FREED_SERIES_BYTE);
+ }
+ else {
+ FREE_N(REBYTE, size_unpooled, unbiased);
+ Mem_Pools[SYSTEM_POOL].has -= size_unpooled;
+ Mem_Pools[SYSTEM_POOL].free++;
+ }
+}
+
+
+//
+// Expand_Series: C
+//
+// Expand a series at a particular index point by the number
+// number of units specified by delta.
+//
+// index - where space is expanded (but not cleared)
+// delta - number of UNITS to expand (keeping terminator)
+// tail - will be updated
+//
+// |<---rest--->|
+// <-bias->|<-tail->| |
+// +--------------------+
+// | abcdefghi |
+// +--------------------+
+// | |
+// data index
+//
+// If the series has enough space within it, then it will be used,
+// otherwise the series data will be reallocated.
+//
+// When expanded at the head, if bias space is available, it will
+// be used (if it provides enough space).
+//
+// !!! It seems the original intent of this routine was
+// to be used with a group of other routines that were "Noterm"
+// and do not terminate. However, Expand_Series assumed that
+// the capacity of the original series was at least (tail + 1)
+// elements, and would include the terminator when "sliding"
+// the data in the update. This makes the other Noterm routines
+// seem a bit high cost for their benefit. If this were to be
+// changed to Expand_Series_Noterm it would put more burden
+// on the clients...for a *potential* benefit in being able to
+// write just an END marker into the terminal REBVAL vs. copying
+// the entire value cell. (Of course, with a good memcpy it
+// might be an irrelevant difference.) For the moment we reverse
+// the burden by enforcing the assumption that the incoming series
+// was already terminated. That way our "slide" of the data via
+// memcpy will keep it terminated.
+//
+// WARNING: never use direct pointers into the series data, as the
+// series data can be relocated in memory.
+//
+void Expand_Series(REBSER *s, REBCNT index, REBCNT delta)
{
- REBSER *series;
- REBNOD *node;
- REBPOL *pool;
- REBCNT pool_num;
-
- CHECK_STACK(&series);
-
- if (((REBU64)length * wide) > MAX_I32) Trap0(RE_NO_MEMORY);
-
- PG_Reb_Stats->Series_Made++;
- PG_Reb_Stats->Series_Memory += length * wide;
-
- ASSERT(wide != 0, RP_BAD_SERIES);
-
-// if (GC_TRIGGER) Recycle();
-
- series = (REBSER *)Make_Node(SERIES_POOL);
- length *= wide;
- pool_num = FIND_POOL(length);
- if (pool_num < SYSTEM_POOL) {
- pool = &Mem_Pools[pool_num];
- if (!pool->first) Fill_Pool(pool);
- node = pool->first;
- pool->first = *node;
- pool->free--;
- length = pool->wide;
- } else {
- if (powerof2) {
- // !!! WHO added this and why??? Just use a left shift and mask!
- REBCNT len=2048;
- while(len= delta) {
+
+ //=//// HEAD INSERTION OPTIMIZATION ///////////////////////////////////=//
+
+ s->content.dynamic.data -= wide * delta;
+ s->content.dynamic.len += delta;
+ s->content.dynamic.rest += delta;
+ SER_SUB_BIAS(s, delta);
+
+ #if !defined(NDEBUG)
+ if (GET_SER_FLAG(s, SERIES_FLAG_ARRAY)) {
+ //
+ // When the bias region was marked, it was made "unsettable" if
+ // this was a debug build. Now that the memory is included in
+ // the array again, we want it to be "settable", but still trash
+ // until the caller puts something there.
+ //
+ // !!! The unsettable feature is currently not implemented,
+ // but when it is this will be useful.
+ //
+ for (index = 0; index < delta; index++)
+ INIT_CELL(ARR_AT(ARR(s), index));
+ }
+ #endif
+ return;
+ }
+
+ // Width adjusted variables:
+
+ REBCNT start = index * wide;
+ REBCNT extra = delta * wide;
+ REBCNT size = SER_LEN(s) * wide;
+
+ // + wide for terminator
+ if ((size + extra + wide) <= SER_REST(s) * SER_WIDE(s)) {
+ //
+ // No expansion was needed. Slide data down if necessary. Note that
+ // the tail is not moved and instead the termination is done
+ // separately with TERM_SERIES (in case it reaches an implicit
+ // termination that is not a full-sized cell).
+
+ memmove(
+ SER_DATA_RAW(s) + start + extra,
+ SER_DATA_RAW(s) + start,
+ size - start
+ );
+
+ SET_SERIES_LEN(s, len_old + delta);
+ assert(
+ !was_dynamic ||
+ (
+ (SER_LEN(s) + SER_BIAS(s)) * wide
+ < SER_TOTAL(s)
+ )
+ );
+
+ TERM_SERIES(s);
+
+ #if !defined(NDEBUG)
+ if (GET_SER_FLAG(s, SERIES_FLAG_ARRAY)) {
+ //
+ // The opened up area needs to be set to "settable" trash in the
+ // debug build. This takes care of making "unsettable" values
+ // settable (if part of the expansion is in what was formerly the
+ // ->rest), as well as just making sure old data which was in
+ // the expanded region doesn't get left over on accident.
+ //
+ // !!! The unsettable feature is not currently implemented, but
+ // when it is this will be useful.
+ //
+ while (delta != 0) {
+ --delta;
+ INIT_CELL(ARR_AT(ARR(s), index + delta));
+ }
+ }
+ #endif
+
+ return;
+ }
+
+//=//// INSUFFICIENT CAPACITY, NEW ALLOCATION REQUIRED ////////////////////=//
+
+ if (GET_SER_FLAG(s, SERIES_FLAG_FIXED_SIZE))
+ fail (Error_Locked_Series_Raw());
+
+#ifndef NDEBUG
+ if (Reb_Opts->watch_expand) {
+ printf(
+ "Expand %p wide: %d tail: %d delta: %d\n",
+ cast(void*, s),
+ cast(int, wide),
+ cast(int, len_old),
+ cast(int, delta)
+ );
+ fflush(stdout);
+ }
#endif
-#ifdef MUNGWALL
- node = (REBNOD *) Make_Mem(length+2*MUNG_SIZE);
-#else
- node = (REBNOD *) Make_Mem(length);
+
+ // Have we recently expanded the same series?
+
+ REBCNT x = 1;
+ REBUPT n_available = 0;
+ REBUPT n_found;
+ for (n_found = 0; n_found < MAX_EXPAND_LIST; n_found++) {
+ if (Prior_Expand[n_found] == s) {
+ x = SER_LEN(s) + delta + 1; // Double the size
+ break;
+ }
+ if (!Prior_Expand[n_found])
+ n_available = n_found;
+ }
+
+#ifndef NDEBUG
+ if (Reb_Opts->watch_expand) {
+ // Print_Num("Expand:", series->tail + delta + 1);
+ }
+#endif
+
+ // !!! The protocol for doing new allocations currently mandates that the
+ // dynamic content area be cleared out. But the data lives in the content
+ // area if there's no dynamic portion. The in-REBSER content has to be
+ // copied to preserve the data. This could be generalized so that the
+ // routines that do calculations operate on the content as a whole, not
+ // the REBSER node, so the content is extracted either way.
+ //
+ union Reb_Series_Content content_old;
+ REBINT bias_old;
+ REBCNT size_old;
+ REBYTE *data_old;
+ if (was_dynamic) {
+ data_old = s->content.dynamic.data;
+ bias_old = SER_BIAS(s);
+ size_old = Series_Allocation_Unpooled(s);
+ }
+ else {
+ content_old = s->content; // may be raw bits
+ data_old = cast(REBYTE*, &content_old);
+ }
+
+ // The new series will *always* be dynamic, because it would not be
+ // expanding if a fixed size allocation was sufficient.
+
+ s->content.dynamic.data = NULL;
+ SET_SER_FLAG(s, SERIES_FLAG_POWER_OF_2);
+ if (!Series_Data_Alloc(s, len_old + delta + x))
+ fail (Error_No_Memory((len_old + delta + x) * wide));
+
+ assert(s->content.dynamic.data != NULL);
+
+ // If necessary, add series to the recently expanded list
+ //
+ if (n_found >= MAX_EXPAND_LIST)
+ Prior_Expand[n_available] = s;
+
+ // Copy the series up to the expansion point
+ //
+ memcpy(s->content.dynamic.data, data_old, start);
+
+ // Copy the series after the expansion point.
+ //
+ memcpy(
+ s->content.dynamic.data + start + extra,
+ data_old + start,
+ size - start
+ );
+ s->content.dynamic.len = len_old + delta;
+
+ TERM_SERIES(s);
+
+ if (was_dynamic) {
+ //
+ // We have to de-bias the data pointer before we can free it.
+ //
+ assert(SER_BIAS(s) == 0); // should be reset
+ Free_Unbiased_Series_Data(data_old - (wide * bias_old), size_old);
+ }
+
+#if !defined(NDEBUG)
+ PG_Reb_Stats->Series_Expanded++;
#endif
- if (!node) {
- Free_Node(SERIES_POOL, (REBNOD *)series);
- Trap0(RE_NO_MEMORY);
- }
-#ifdef MUNGWALL
- memcpy((REBYTE *)node,MUNG_PATTERN1,MUNG_SIZE);
- memcpy(((REBYTE *)node)+length+MUNG_SIZE,MUNG_PATTERN2,MUNG_SIZE);
- node=(REBNOD *)(((REBYTE *)node)+MUNG_SIZE);
+
+ assert(NOT_SER_FLAG(s, NODE_FLAG_MARKED));
+}
+
+
+//
+// Remake_Series: C
+//
+// Reallocate a series as a given maximum size. Content in the retained
+// portion of the length will be preserved if NODE_FLAG_NODE is passed in.
+//
+void Remake_Series(REBSER *s, REBCNT units, REBYTE wide, REBUPT flags)
+{
+ // !!! This routine is being scaled back in terms of what it's allowed to
+ // do for the moment; so the method of passing in flags is a bit strange.
+ //
+ assert((flags & ~(NODE_FLAG_NODE | SERIES_FLAG_POWER_OF_2)) == 0);
+
+ REBOOL preserve = LOGICAL(flags & NODE_FLAG_NODE);
+
+ REBCNT len_old = SER_LEN(s);
+ REBYTE wide_old = SER_WIDE(s);
+
+#if !defined(NDEBUG)
+ if (preserve)
+ assert(wide == wide_old); // can't change width if preserving
#endif
- Mem_Pools[SYSTEM_POOL].has += length;
- Mem_Pools[SYSTEM_POOL].free++;
- }
-#ifdef CHAFF
- memset((REBYTE *)node, 0xff, length);
+
+ assert(NOT_SER_FLAG(s, SERIES_FLAG_FIXED_SIZE));
+
+ REBOOL was_dynamic = GET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC);
+
+ REBINT bias_old;
+ REBINT size_old;
+
+ // Extract the data pointer to take responsibility for it. (The pointer
+ // may have already been extracted if the caller is doing their own
+ // updating preservation.)
+
+ REBYTE *data_old;
+ union Reb_Series_Content content_old;
+ if (was_dynamic) {
+ assert(s->content.dynamic.data != NULL);
+ data_old = s->content.dynamic.data;
+ bias_old = SER_BIAS(s);
+ size_old = Series_Allocation_Unpooled(s);
+ }
+ else {
+ content_old = s->content;
+ data_old = cast(REBYTE*, &content_old);
+ }
+
+ // We don't want to update the header bits to reflect a new state of the
+ // SERIES_FLAG_POWER_OF_2 until *after* Series_Allocation_Unpooled
+ // was able to take the old state into account.
+ //
+ SER_SET_WIDE(s, wide);
+ s->header.bits |= flags;
+
+ // !!! Currently the remake won't make a series that fits in the size of
+ // a REBSER. All series code needs a general audit, so that should be one
+ // of the things considered.
+
+ s->content.dynamic.data = NULL;
+
+ if (!Series_Data_Alloc(s, units + 1)) {
+ // Put series back how it was (there may be extant references)
+ s->content.dynamic.data = data_old;
+ fail (Error_No_Memory((units + 1) * wide));
+ }
+ assert(s->content.dynamic.data != NULL);
+
+ if (preserve) {
+ // Preserve as much data as possible (if it was requested, some
+ // operations may extract the data pointer ahead of time and do this
+ // more selectively)
+
+ s->content.dynamic.len = MIN(len_old, units);
+ memcpy(
+ s->content.dynamic.data,
+ data_old,
+ s->content.dynamic.len * wide
+ );
+ } else
+ s->content.dynamic.len = 0;
+
+ if (GET_SER_FLAG(s, SERIES_FLAG_ARRAY))
+ TERM_ARRAY_LEN(ARR(s), SER_LEN(s));
+ else
+ TERM_SEQUENCE(s);
+
+ if (was_dynamic)
+ Free_Unbiased_Series_Data(data_old - (wide_old * bias_old), size_old);
+}
+
+
+//
+// GC_Kill_Series: C
+//
+// Only the garbage collector should be calling this routine.
+// It frees a series even though it is under GC management,
+// because the GC has figured out no references exist.
+//
+void GC_Kill_Series(REBSER *s)
+{
+ assert(!IS_FREE_NODE(s));
+ assert(NOT(s->header.bits & NODE_FLAG_CELL)); // use Free_Paired
+
+ if (GET_SER_FLAG(s, SERIES_FLAG_UTF8_STRING))
+ GC_Kill_Interning(s); // needs special handling to adjust canons
+
+ // Remove series from expansion list, if found:
+ REBCNT n;
+ for (n = 1; n < MAX_EXPAND_LIST; n++) {
+ if (Prior_Expand[n] == s) Prior_Expand[n] = 0;
+ }
+
+ if (GET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC)) {
+ REBCNT size = SER_TOTAL(s);
+
+ REBYTE wide = SER_WIDE(s);
+ REBCNT bias = SER_BIAS(s);
+ s->content.dynamic.data -= wide * bias;
+ Free_Unbiased_Series_Data(
+ s->content.dynamic.data,
+ Series_Allocation_Unpooled(s)
+ );
+
+ // !!! This indicates reclaiming of the space, not for the series
+ // nodes themselves...have they never been accounted for, e.g. in
+ // R3-Alpha? If not, they should be...additional sizeof(REBSER),
+ // also tracking overhead for that. Review the question of how
+ // the GC watermarks interact with Alloc_Mem and the "higher
+ // level" allocations.
+
+ i32 tmp;
+ GC_Ballast = REB_I32_ADD_OF(GC_Ballast, size, &tmp) ? MAX_I32 : tmp;
+ }
+ else {
+ // Special GC processing for HANDLE! when the handle is implemented as
+ // a singular array, so that if the handle represents a resource, it
+ // may be freed.
+ //
+ // Note that not all singular arrays containing a HANDLE! should be
+ // interpreted that when the array is freed the handle is freed (!)
+ // Only when the handle array pointer in the freed singular
+ // handle matches the REBARR being freed. (It may have been just a
+ // singular array that happened to contain a handle, otherwise, as
+ // opposed to the specific singular made for the handle's GC awareness)
+
+ if (GET_SER_FLAG(s, SERIES_FLAG_ARRAY)) {
+ RELVAL *v = ARR_HEAD(ARR(s));
+ if (NOT_END(v) && IS_HANDLE(v)) {
+ if (v->extra.singular == ARR(s)) {
+ (s->misc.cleaner)(KNOWN(v));
+ }
+ }
+ }
+ }
+
+#if !defined(NDEBUG)
+ s->info.bits = 0; // makes it look like width is 0
#endif
- series->tail = series->size = 0;
- SERIES_REST(series) = length / wide;
- series->data = (REBYTE *)node;
- series->info = wide; // also clears flags
- LABEL_SERIES(series, "make");
- if ((GC_Ballast -= length) <= 0) SET_SIGNAL(SIG_RECYCLE);
+ TRASH_POINTER_IF_DEBUG(s->link.keylist);
+
+ Free_Node(SER_POOL, s);
- // Keep the last few series in the nursery, safe from GC:
- if (GC_Last_Infant >= MAX_SAFE_SERIES) GC_Last_Infant = 0;
- GC_Infants[GC_Last_Infant++] = series;
+ // GC may no longer be necessary:
+ if (GC_Ballast > 0) CLR_SIGNAL(SIG_RECYCLE);
- CHECK_MEMORY(2);
+#if !defined(NDEBUG)
+ PG_Reb_Stats->Series_Freed++;
- return series;
+ // Update the do count to be the count on which the series was freed
+ //
+ s->do_count = TG_Do_Count;
+#endif
}
-/***********************************************************************
-**
-*/ void Free_Series_Data(REBSER *series, REBOOL protect)
-/*
-** Free series data, but leave series header. Protect flag
-** can be used to prevent GC away from the data field.
-**
-***********************************************************************/
+inline static void Drop_Manual_Series(REBSER *s)
{
- REBNOD *node;
- REBPOL *pool;
- REBCNT pool_num;
- REBCNT size;
-
- // !!!! Dump_Series(series, "Free-Data");
-
- if (SERIES_FREED(series) || series->data == BAD_MEM_PTR) return; // No free twice.
- if (IS_EXT_SERIES(series)) goto clear_header; // Must be library related
-
- size = SERIES_TOTAL(series);
- if ((GC_Ballast += size) > VAL_INT32(TASK_BALLAST))
- GC_Ballast = VAL_INT32(TASK_BALLAST);
-
- // GC may no longer be necessary:
- if (GC_Ballast > 0) CLR_SIGNAL(SIG_RECYCLE);
-
- series->data -= SERIES_WIDE(series) * SERIES_BIAS(series);
- node = (REBNOD *)series->data;
- pool_num = FIND_POOL(size);
-
- if (GC_Stay_Dirty) {
- memset(series->data, 0xbb, size);
- return;
- }
-
- // Verify that size matches pool size:
- if (pool_num < SERIES_POOL) {
- ASSERT(Mem_Pools[pool_num].wide == size, RP_FREE_NODE_SIZE);
- }
- MUNG_CHECK(pool_num,node, size);
-
- if (pool_num < SYSTEM_POOL) {
- pool = &Mem_Pools[pool_num];
- *node = pool->first;
- pool->first = node;
- pool->free++;
- } else {
-#ifdef MUNGWALL
- Free_Mem(((REBYTE *)node)-MUNG_SIZE, size + MUNG_SIZE*2);
-#else
- Free_Mem(node, size);
+ REBSER ** const last_ptr
+ = &cast(REBSER**, GC_Manuals->content.dynamic.data)[
+ GC_Manuals->content.dynamic.len - 1
+ ];
+
+ assert(GC_Manuals->content.dynamic.len >= 1);
+ if (*last_ptr != s) {
+ //
+ // If the series is not the last manually added series, then
+ // find where it is, then move the last manually added series
+ // to that position to preserve it when we chop off the tail
+ // (instead of keeping the series we want to free).
+ //
+ REBSER **current_ptr = last_ptr - 1;
+ while (*current_ptr != s) {
+ #if !defined(NDEBUG)
+ if (
+ current_ptr
+ <= cast(REBSER**, GC_Manuals->content.dynamic.data)
+ ){
+ printf("Series not in list of last manually added series\n");
+ panic(s);
+ }
+ #endif
+ --current_ptr;
+ }
+ *current_ptr = *last_ptr;
+ }
+
+ // !!! Should GC_Manuals ever shrink or save memory?
+ //
+ GC_Manuals->content.dynamic.len--;
+}
+
+
+//
+// Free_Series: C
+//
+// Free a series, returning its memory for reuse. You can only
+// call this on series that are not managed by the GC.
+//
+void Free_Series(REBSER *s)
+{
+#if !defined(NDEBUG)
+ //
+ // If a series has already been freed, we'll find out about that
+ // below indirectly, so better in the debug build to get a clearer
+ // error that won't be conflated with a possible tracking problem
+ //
+ if (IS_FREE_NODE(s)) {
+ printf("Trying to Free_Series() on an already freed series\n");
+ panic (s);
+ }
+
+ // We can only free a series that is not under management by the
+ // garbage collector
+ //
+ if (IS_SERIES_MANAGED(s)) {
+ printf("Trying to Free_Series() on a series managed by GC.\n");
+ panic (s);
+ }
#endif
- Mem_Pools[SYSTEM_POOL].has -= size;
- Mem_Pools[SYSTEM_POOL].free--;
- }
- CHECK_MEMORY(2);
+ Drop_Manual_Series(s);
-clear_header:
- if (protect) {
- series->data = BAD_MEM_PTR; // force bad references to trap
- series->info = 0; // indicates series deallocated (wide = 0)
- }
+ // With bookkeeping done, use the same routine the GC uses to free
+ //
+ GC_Kill_Series(s);
}
-/***********************************************************************
-**
-*/ void Free_Series(REBSER *series)
-/*
-** Free a series, returning its memory for reuse.
-**
-***********************************************************************/
+//
+// Widen_String: C
+//
+// Widen string from 1 byte to 2 bytes.
+//
+// NOTE: allocates new memory. Cached pointers are invalid.
+//
+void Widen_String(REBSER *s, REBOOL preserve)
{
- REBCNT n;
+ REBCNT len_old = SER_LEN(s);
+
+ REBYTE wide_old = SER_WIDE(s);
+ assert(wide_old == 1);
+
+ REBOOL was_dynamic = GET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC);
+
+ REBCNT bias_old;
+ REBCNT size_old;
+ REBYTE *data_old;
+ union Reb_Series_Content content_old;
+ if (was_dynamic) {
+ data_old = s->content.dynamic.data;
+ bias_old = SER_BIAS(s);
+ size_old = Series_Allocation_Unpooled(s);
+ }
+ else {
+ content_old = s->content;
+ data_old = cast(REBYTE*, &content_old);
+ }
+
+#if !defined(NDEBUG)
+ // We may be resizing a partially constructed series, or otherwise
+ // not want to preserve the previous contents
+ if (preserve)
+ ASSERT_SERIES(s);
+#endif
+
+ s->content.dynamic.data = NULL;
- PG_Reb_Stats->Series_Freed++;
+ SER_SET_WIDE(s, cast(REBYTE, sizeof(REBUNI)));
+ if (!Series_Data_Alloc(s, len_old + 1)) {
+ // Put series back how it was (there may be extant references)
+ s->content.dynamic.data = data_old;
+ fail (Error_No_Memory((len_old + 1) * sizeof(REBUNI)));
+ }
- // Remove series from expansion list, if found:
- for (n = 1; n < MAX_EXPAND_LIST; n++) {
- if (Prior_Expand[n] == series) Prior_Expand[n] = 0;
- }
+ if (preserve) {
+ REBYTE *bp = data_old;
+ REBUNI *up = UNI_HEAD(s);
- Free_Series_Data(series, TRUE);
- series->info = 0; // includes width
- //series->data = BAD_MEM_PTR;
- //series->tail = 0xBAD2BAD2;
- //series->size = 0xBAD3BAD3;
+ REBCNT n;
+ for (n = 0; n <= len_old; n++) up[n] = bp[n]; // includes terminator
+ s->content.dynamic.len = len_old;
+ }
+ else {
+ s->content.dynamic.len = 0;
+ TERM_SEQUENCE(s);
+ }
- Free_Node(SERIES_POOL, (REBNOD *)series);
+ if (was_dynamic)
+ Free_Unbiased_Series_Data(data_old - (wide_old * bias_old), size_old);
-/* Old torture mode:
- if (!SERIES_FREED(series)) { // Don't try to free twice.
- MUNG_CHECK(SERIES_POOL, (REBNOD *)series, Mem_Pools[SERIES_POOL].wide);
- FREE_SERIES(series); // special GC mark as freed
- }
-*/
+ ASSERT_SERIES(s);
}
-/***********************************************************************
-**
-*/ void Free_Gob(REBGOB *gob)
-/*
-** Free a gob, returning its memory for reuse.
-**
-***********************************************************************/
+//
+// Manage_Series: C
+//
+// When a series is first created, it is in a state of being
+// manually memory managed. Thus, you can call Free_Series on
+// it if you are sure you do not need it. This will transition
+// a manually managed series to be one managed by the GC. There
+// is no way to transition it back--once a series has become
+// managed, only the GC can free it.
+//
+// All series that wind up in user-visible values *must* be
+// managed, because the user can make copies of values
+// containing that series. When these copies are made, it's
+// no longer safe to assume it's okay to free the original.
+//
+void Manage_Series(REBSER *s)
{
- FREE_GOB(gob);
+#if !defined(NDEBUG)
+ if (IS_SERIES_MANAGED(s)) {
+ printf("Attempt to manage already managed series\n");
+ panic (s);
+ }
+#endif
+
+ s->header.bits |= NODE_FLAG_MANAGED;
- Free_Node(GOB_POOL, (REBNOD *)gob);
+ Drop_Manual_Series(s);
}
-/***********************************************************************
-**
-*/ void Prop_Series(REBSER *newser, REBSER *oldser)
-/*
-** Propagate a series from another.
-**
-***********************************************************************/
+//
+// Is_Value_Managed: C
+//
+// Determines if a value would be visible to the garbage collector or not.
+// Defaults to the answer of TRUE if the value has nothing the GC cares if
+// it sees or not.
+//
+// Note: Avoid causing conditional behavior on this casually. It's really
+// for GC internal use and ASSERT_VALUE_MANAGED. Most code should work
+// with either managed or unmanaged value states for variables w/o needing
+// this test to know which it has.)
+//
+REBOOL Is_Value_Managed(const RELVAL *value)
{
- newser->info = oldser->info;
- newser->size = oldser->size;
-#ifdef SERIES_LABELS
- newser->label = oldser->label;
+ assert(!THROWN(value));
+
+ if (ANY_CONTEXT(value)) {
+ REBCTX *context = VAL_CONTEXT(value);
+ if (IS_ARRAY_MANAGED(CTX_VARLIST(context))) {
+ ASSERT_ARRAY_MANAGED(CTX_KEYLIST(context));
+ return TRUE;
+ }
+ assert(NOT(IS_ARRAY_MANAGED(CTX_KEYLIST(context)))); // !!! untrue?
+ return FALSE;
+ }
+
+ if (ANY_SERIES(value))
+ return IS_SERIES_MANAGED(VAL_SERIES(value));
+
+ return TRUE;
+}
+
+
+//
+// Detect_Rebol_Pointer: C
+//
+// See the elaborate explanation in %m-gc.c for how this works! It is a
+// trustworthy method for "sniffing" pointers and discerning whether it is a
+// REBSER*, a REBVAL*, or a UTF-8 character string.
+//
+enum Reb_Pointer_Detect Detect_Rebol_Pointer(const void *p) {
+ const REBYTE *bp = cast(const REBYTE*, p);
+ REBYTE left_4_bits = *bp >> 4;
+
+#if !defined(NDEBUG)
+ REBUPT cell_flag = NODE_FLAG_CELL;
+ assert(LEFT_8_BITS(cell_flag) == 0x1);
+ REBUPT end_flag = NODE_FLAG_END;
+ assert(LEFT_8_BITS(end_flag) == 0x8);
#endif
+
+ switch (left_4_bits) {
+ case 0:
+ case 1:
+ case 2:
+ case 3:
+ case 4:
+ case 5:
+ case 6:
+ case 7:
+ return DETECTED_AS_UTF8; // ASCII codepoints 0 - 127
+
+ // v-- bit sequences starting with `10` (continuation bytes, so not
+ // valid starting points for a UTF-8 string)
+
+ case 8: // 0xb1000
+ if (*bp & 0x8)
+ return DETECTED_AS_END; // may be end cell or "endlike" header
+ if (*bp & 0x1)
+ return DETECTED_AS_VALUE; // unmanaged
+ return DETECTED_AS_SERIES; // unmanaged
+
+ case 9: // 0xb1001
+ if (*bp & 0x8)
+ return DETECTED_AS_END; // has to be an "endlike" header
+ panic (p); // would be "marked and unmanaged", not legal
+
+ case 10: // 0b1010
+ case 11: // 0b1011
+ if (*bp & 0x8)
+ return DETECTED_AS_END;
+ if (*bp & 0x1)
+ return DETECTED_AS_VALUE; // managed, marked if `case 11`
+ return DETECTED_AS_SERIES; // managed, marked if `case 11`
+
+ // v-- bit sequences starting with `11` are usually legal multi-byte
+ // valid starting points for UTF-8, with only the exceptions made for
+ // the illegal 192 and 193 bytes which represent freed series and trash.
+
+ case 12: // 0b1100
+ if (*bp == FREED_SERIES_BYTE)
+ return DETECTED_AS_FREED_SERIES;
+
+ if (*bp == TRASH_CELL_BYTE)
+ return DETECTED_AS_TRASH_CELL;
+
+ return DETECTED_AS_UTF8;
+
+ case 13: // 0b1101
+ case 14: // 0b1110
+ case 15: // 0b1111
+ return DETECTED_AS_UTF8;
+ }
+
+ DEAD_END;
}
-/***********************************************************************
-**
-*/ REBFLG Series_In_Pool(REBSER *series)
-/*
-** Confirm that the series value is in the series pool.
-**
-***********************************************************************/
+#if !defined(NDEBUG)
+
+//
+// Assert_Pointer_Detection_Working: C
+//
+void Assert_Pointer_Detection_Working(void)
{
- REBSEG *seg;
- REBSER *start;
+ assert(Detect_Rebol_Pointer("") == DETECTED_AS_UTF8);
+ assert(Detect_Rebol_Pointer("asdf") == DETECTED_AS_UTF8);
+
+ assert(Detect_Rebol_Pointer(EMPTY_ARRAY) == DETECTED_AS_SERIES);
+ assert(Detect_Rebol_Pointer(BLANK_VALUE) == DETECTED_AS_VALUE);
+
+ DECLARE_LOCAL (trash_cell);
+ assert(Detect_Rebol_Pointer(trash_cell) == DETECTED_AS_TRASH_CELL);
+
+ DECLARE_LOCAL (end_cell);
+ SET_END(end_cell);
+ assert(Detect_Rebol_Pointer(end_cell) == DETECTED_AS_END);
+ assert(Detect_Rebol_Pointer(END) == DETECTED_AS_END);
+
+ // It's not generally known that an Init_Endlike_Header() header will
+ // not be managed. But the canon END is not managed, and end cells can
+ // be either managed or unmanaged...but by default, not.
+ //
+ assert(NOT(end_cell->header.bits & NODE_FLAG_MANAGED));
+ assert(NOT(END->header.bits & NODE_FLAG_MANAGED));
+
+ REBSER *series = Make_Series(1, sizeof(char));
+ assert(Detect_Rebol_Pointer(series) == DETECTED_AS_SERIES);
+ Free_Series(series);
+ assert(Detect_Rebol_Pointer(series) == DETECTED_AS_FREED_SERIES);
+
+ // Sanity check the flags used for the Init_Endlike_Header trick
+ //
+ assert(
+ SERIES_INFO_0_IS_TRUE == NODE_FLAG_NODE
+ && SERIES_INFO_1_IS_FALSE == NODE_FLAG_FREE
+ && SERIES_INFO_4_IS_TRUE == NODE_FLAG_END
+ && SERIES_INFO_7_IS_FALSE == NODE_FLAG_CELL
+ );
+ assert(
+ DO_FLAG_0_IS_TRUE == NODE_FLAG_NODE
+ && DO_FLAG_1_IS_FALSE == NODE_FLAG_FREE
+ && DO_FLAG_4_IS_TRUE == NODE_FLAG_END
+ && DO_FLAG_7_IS_FALSE == NODE_FLAG_CELL
+ );
+}
- // Scan all series headers to check that series->size is correct:
- for (seg = Mem_Pools[SERIES_POOL].segs; seg; seg = seg->next) {
- start = (REBSER *) (seg + 1);
- if (series >= start && series <= (REBSER*)((REBYTE*)start + seg->size - sizeof(REBSER)))
- return TRUE;
- }
- return FALSE;
+//
+// Check_Memory_Debug: C
+//
+// Traverse the free lists of all pools -- just to prove we can.
+//
+// Note: This was useful in R3-Alpha for finding corruption from bad memory
+// writes, because a write past the end of a node destroys the pointer for the
+// next free area. The Always_Malloc option for Ren-C leverages the faster
+// checking built into Valgrind or Address Sanitizer for the same problem.
+// However, a call to this is kept in the debug build on init and shutdown
+// just to keep it working as a sanity check.
+//
+REBCNT Check_Memory_Debug(void)
+{
+ REBOOL expansion_null_found = FALSE;
+
+ REBSEG *seg;
+ for (seg = Mem_Pools[SER_POOL].segs; seg; seg = seg->next) {
+ REBSER *s = cast(REBSER*, seg + 1);
+
+ REBCNT n;
+ for (n = Mem_Pools[SER_POOL].units; n > 0; --n, ++s) {
+ if (IS_FREE_NODE(s))
+ continue;
+
+ if (GET_SER_FLAG(s, NODE_FLAG_CELL))
+ continue; // a pairing
+
+ if (NOT(GET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC)))
+ continue; // data lives in the series node itself
+
+ if (SER_REST(s) == 0)
+ panic (s); // zero size allocations not legal
+
+ if (s->content.dynamic.data == NULL) {
+ //
+ // !!! legal during the moment of series expansion only; e.g.
+ // can only be true for one series at a time (current invariant
+ // which was needed as a patch so Check_Memory could be called
+ // during Make_Node()...hacky, should be rethought)
+ //
+ if (expansion_null_found)
+ panic (s);
+
+ expansion_null_found = TRUE;
+ }
+
+ REBCNT pool_num = FIND_POOL(SER_TOTAL(s));
+ if (pool_num >= SER_POOL)
+ continue; // size doesn't match a known pool
+
+ if (Mem_Pools[pool_num].wide != SER_TOTAL(s))
+ panic (s);
+ }
+ }
+
+ REBCNT total_free_nodes = 0;
+
+ REBCNT pool_num;
+ for (pool_num = 0; pool_num < SYSTEM_POOL; pool_num++) {
+ REBCNT pool_free_nodes = 0;
+
+ REBNOD *node = Mem_Pools[pool_num].first;
+ for (; node != NULL; node = node->next_if_free) {
+ ++pool_free_nodes;
+
+ REBOOL found = FALSE;
+ seg = Mem_Pools[pool_num].segs;
+ for (; seg != NULL; seg = seg->next) {
+ if (
+ cast(REBUPT, node) > cast(REBUPT, seg)
+ && (
+ cast(REBUPT, node)
+ < cast(REBUPT, seg) + cast(REBUPT, seg->size)
+ )
+ ){
+ if (found)
+ panic ("node belongs to more than one segment");
+
+ found = TRUE;
+ }
+ }
+
+ if (NOT(found))
+ panic ("node does not belong to one of the pool's segments");
+ }
+
+ if (Mem_Pools[pool_num].free != pool_free_nodes)
+ panic ("actual free node count does not agree with pool header");
+
+ total_free_nodes += pool_free_nodes;
+ }
+
+ return total_free_nodes;
}
-/***********************************************************************
-**
-*/ REBCNT Check_Memory(void)
-/*
-** FOR DEBUGGING ONLY:
-** Traverse the free lists of all pools -- just to prove we can.
-** This is useful for finding corruption from bad memory writes,
-** because a write past the end of a node will destory the pointer
-** for the next free area.
-**
-***********************************************************************/
+//
+// Dump_All_Series_Of_Size: C
+//
+void Dump_All_Series_Of_Size(REBCNT size)
{
- REBCNT pool_num;
- REBNOD *node;
- REBNOD *pnode;
- REBCNT count = 0;
- REBSEG *seg;
- REBSER *series;
-
- //Debug_Str("");
- PG_Reb_Stats->Free_List_Checked++;
-
- // Scan all series headers to check that series->size is correct:
- for (seg = Mem_Pools[SERIES_POOL].segs; seg; seg = seg->next) {
- series = (REBSER *) (seg + 1);
- for (count = Mem_Pools[SERIES_POOL].units; count > 0; count--) {
- SKIP_WALL(series);
- MUNG_CHECK(SERIES_POOL, series, sizeof(*series));
- if (!SERIES_FREED(series)) {
- if (!SERIES_REST(series) || !series->data)
- goto crash;
- // Does the size match a known pool?
- pool_num = FIND_POOL(SERIES_TOTAL(series));
- // Just to be sure the pool matches the allocation:
- if (pool_num < SERIES_POOL && Mem_Pools[pool_num].wide != SERIES_TOTAL(series))
- goto crash;
- }
- series++;
- SKIP_WALL(series);
- }
- }
-
- // Scan each memory pool:
- for (pool_num = 0; pool_num < SYSTEM_POOL; pool_num++) {
- count = 0;
- // Check each free node in the memory pool:
- for (node = Mem_Pools[pool_num].first; node; node = *node) {
- count++;
- // The node better belong to one of the pool's segments:
- for (seg = Mem_Pools[pool_num].segs; seg; seg = seg->next) {
- if ((int)node > (int)seg && (int)node < (int)seg + (int)seg->size) break;
- }
- if (!seg) goto crash;
- pnode = node; // for debugger
- }
- // The number of free nodes must agree with header:
- if (
- (Mem_Pools[pool_num].free != count) ||
- (Mem_Pools[pool_num].free == 0 && Mem_Pools[pool_num].first != 0)
- )
- goto crash;
- }
-
- return count;
-crash:
- Crash(RP_CORRUPT_MEMORY);
- return 0; // for compiler only
+ REBCNT count = 0;
+
+ REBSEG *seg;
+ for (seg = Mem_Pools[SER_POOL].segs; seg; seg = seg->next) {
+ REBSER *s = cast(REBSER*, seg + 1);
+ REBCNT n;
+ for (n = Mem_Pools[SER_POOL].units; n > 0; --n, ++s) {
+ if (IS_FREE_NODE(s))
+ continue;
+
+ if (SER_WIDE(s) == size) {
+ ++count;
+ printf(
+ "%3d %4d %4d\n",
+ cast(int, count),
+ cast(int, SER_LEN(s)),
+ cast(int, SER_REST(s))
+ );
+ }
+ fflush(stdout);
+ }
+ }
}
-/***********************************************************************
-**
-*/ void Dump_All(REBINT size)
-/*
-** Dump all series of a given size.
-**
-***********************************************************************/
+//
+// Dump_Series_In_Pool: C
+//
+// Dump all series in pool @pool_id, UNKNOWN (-1) for all pools
+//
+void Dump_Series_In_Pool(REBCNT pool_id)
{
- REBSEG *seg;
- REBSER *series;
- REBCNT count;
- REBCNT n = 0;
-
- for (seg = Mem_Pools[SERIES_POOL].segs; seg; seg = seg->next) {
- series = (REBSER *) (seg + 1);
- for (count = Mem_Pools[SERIES_POOL].units; count > 0; count--) {
- SKIP_WALL(series);
- if (!SERIES_FREED(series)) {
- if (SERIES_WIDE(series) == size && SERIES_GET_FLAG(series, SER_MON)) {
- //Debug_Fmt("%3d %4d %4d = \"%s\"", n++, series->tail, SERIES_TOTAL(series), series->data);
- Debug_Fmt("%3d %4d %4d = \"%s\"", n++, series->tail, SERIES_REST(series), (SERIES_LABEL(series) ? SERIES_LABEL(series) : "-"));
- }
- }
- series++;
- SKIP_WALL(series);
- }
- }
+ REBSEG *seg;
+ for (seg = Mem_Pools[SER_POOL].segs; seg; seg = seg->next) {
+ REBSER *s = cast(REBSER*, seg + 1);
+ REBCNT n = 0;
+ for (n = Mem_Pools[SER_POOL].units; n > 0; --n, ++s) {
+ if (IS_FREE_NODE(s))
+ continue;
+
+ if (GET_SER_FLAG(s, NODE_FLAG_CELL))
+ continue; // pairing
+
+ if (
+ pool_id == UNKNOWN
+ || (
+ GET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC)
+ && FIND_POOL(SER_TOTAL(s)) == pool_id
+ )
+ ) {
+ Dump_Series(s, "Dump_Series_In_Pool");
+ }
+
+ }
+ }
}
-/***********************************************************************
-**
-*/ static void Dump_Pools(void)
-/*
-** Print statistics about all memory pools.
-**
-***********************************************************************/
+//
+// Dump_Pools: C
+//
+// Print statistics about all memory pools.
+//
+void Dump_Pools(void)
{
- REBSEG *seg;
- REBCNT segs;
- REBCNT size;
- REBCNT used;
- REBCNT total = 0;
- REBCNT tused = 0;
- REBCNT n;
-
- FOREACH(n, SYSTEM_POOL) {
- size = segs = 0;
-
- for (seg = Mem_Pools[n].segs; seg; seg = seg->next, segs++)
- size += seg->size;
-
- used = Mem_Pools[n].has - Mem_Pools[n].free;
- Debug_Fmt("Pool[%-2d] %-4dB %-5d/%-5d:%-4d (%-2d%%) %-2d segs, %-07d total",
- n,
- Mem_Pools[n].wide,
- used,
- Mem_Pools[n].has,
- Mem_Pools[n].units,
- Mem_Pools[n].has ? ((used * 100) / Mem_Pools[n].has) : 0,
- segs,
- size
- );
-
- tused += used * Mem_Pools[n].wide;
- total += size;
- }
- Debug_Fmt("Pools used %d of %d (%2d%%)", tused, total, (tused*100) / total);
- Debug_Fmt("System pool used %d", Mem_Pools[SYSTEM_POOL].has);
- //Debug_Fmt("Raw allocator reports %d", PG_Mem_Usage);
+ REBCNT total = 0;
+ REBCNT tused = 0;
+
+ REBCNT n;
+ for (n = 0; n < SYSTEM_POOL; n++) {
+ REBCNT segs = 0;
+ REBCNT size = 0;
+
+ size = segs = 0;
+
+ REBSEG *seg;
+ for (seg = Mem_Pools[n].segs; seg; seg = seg->next, segs++)
+ size += seg->size;
+
+ REBCNT used = Mem_Pools[n].has - Mem_Pools[n].free;
+ printf(
+ "Pool[%-2d] %5dB %-5d/%-5d:%-4d (%3d%%) ",
+ cast(int, n),
+ cast(int, Mem_Pools[n].wide),
+ cast(int, used),
+ cast(int, Mem_Pools[n].has),
+ cast(int, Mem_Pools[n].units),
+ cast(int,
+ Mem_Pools[n].has != 0 ? ((used * 100) / Mem_Pools[n].has) : 0
+ )
+ );
+ printf("%-2d segs, %-7d total\n", cast(int, segs), cast(int, size));
+
+ tused += used * Mem_Pools[n].wide;
+ total += size;
+ }
+
+ printf(
+ "Pools used %d of %d (%2d%%)\n",
+ cast(int, tused),
+ cast(int, total),
+ cast(int, (tused * 100) / total)
+ );
+ printf("System pool used %d\n", cast(int, Mem_Pools[SYSTEM_POOL].has));
+ printf("Raw allocator reports %lu\n", cast(unsigned long, PG_Mem_Usage));
+
+ fflush(stdout);
}
-/***********************************************************************
-**
-*/ REBU64 Inspect_Series(REBCNT flags)
-/*
-***********************************************************************/
+//
+// Inspect_Series: C
+//
+// !!! This is an old routine which was exposed through STATS to "expert
+// users". Its purpose is to calculate the total amount of memory currently
+// in use by series, but it could also print out a breakdown of categories.
+//
+REBU64 Inspect_Series(REBOOL show)
{
- REBSEG *seg;
- REBSER *series;
- REBCNT segs, n, tot, blks, strs, unis, nons, odds, fre;
- REBCNT str_size, uni_size, blk_size, odd_size, seg_size, fre_size;
- REBFLG f = 0;
- REBINT pool_num;
-#ifdef SERIES_LABELS
- REBYTE *kind;
-#endif
- REBU64 tot_size;
-
- segs = tot = blks = strs = unis = nons = odds = fre = 0;
- seg_size = str_size = uni_size = blk_size = odd_size = fre_size = 0;
- tot_size = 0;
- DS_TERMINATE;
-
- for (seg = Mem_Pools[SERIES_POOL].segs; seg; seg = seg->next) {
-
- seg_size += seg->size;
- segs++;
-
- series = (REBSER *) (seg + 1);
-
- for (n = Mem_Pools[SERIES_POOL].units; n > 0; n--) {
- SKIP_WALL(series);
- MUNG_CHECK(SERIES_POOL, series, sizeof(*series));
-
- if (SERIES_WIDE(series)) {
- tot++;
- tot_size += SERIES_TOTAL(series);
- f = 0;
- } else {
- fre++;
- }
-
-#ifdef SERIES_LABELS
- kind = "----";
- if (SERIES_GET_FLAG(series, SER_KEEP)) kind = "KEEP";
- //if (Find_Root(series)) kind = "ROOT";
- if (!SERIES_FREED(series) && series->label) {
- Debug_Fmt_("%08x: %16s %s ", series, series->label, kind);
- f = 1;
- } else if (!SERIES_FREED(series) && (flags & 0x100)) {
- Debug_Fmt_("%08x: %s ", series, kind);
- f = 1;
- }
-#endif
- if (SERIES_WIDE(series) == sizeof(REBVAL)) {
- blks++;
- blk_size += SERIES_TOTAL(series);
- if (f) Debug_Fmt_("BLOCK ");
- }
- else if (SERIES_WIDE(series) == 1) {
- strs++;
- str_size += SERIES_TOTAL(series);
- if (f) Debug_Fmt_("STRING");
- }
- else if (SERIES_WIDE(series) == sizeof(REBUNI)) {
- unis++;
- uni_size += SERIES_TOTAL(series);
- if (f) Debug_Fmt_("UNICOD");
- }
- else if (SERIES_WIDE(series)) {
- odds++;
- odd_size += SERIES_TOTAL(series);
- if (f) Debug_Fmt_("ODD[%d]", SERIES_WIDE(series));
- }
- if (f && SERIES_WIDE(series)) {
- Debug_Fmt(" units: %-5d tail: %-5d bytes: %-7d", SERIES_REST(series), SERIES_TAIL(series), SERIES_TOTAL(series));
- }
-
- series++;
- SKIP_WALL(series);
- }
- }
-
- // Size up unused memory:
- for (pool_num = 0; pool_num < SYSTEM_POOL; pool_num++) {
- fre_size += Mem_Pools[pool_num].free * Mem_Pools[pool_num].wide;
- }
-
- if (flags & 1) {
- Debug_Fmt(
- "Series Memory Info:\n"
- " node size = %d\n"
- " series size = %d\n"
- " %-6d segs = %-7d bytes - headers\n"
- " %-6d blks = %-7d bytes - blocks\n"
- " %-6d strs = %-7d bytes - byte strings\n"
- " %-6d unis = %-7d bytes - unicode strings\n"
- " %-6d odds = %-7d bytes - odd series\n"
- " %-6d used = %-7d bytes - total used\n"
- " %-6d free / %-7d bytes - free headers / node-space\n"
- ,
- sizeof(REBVAL),
- sizeof(REBSER),
- segs, seg_size,
- blks, blk_size,
- strs, str_size,
- unis, uni_size,
- odds, odd_size,
- tot, tot_size,
- fre, fre_size // the 2 are not related
- );
- }
-
- if (flags & 2) Dump_Pools();
-
- return tot_size;
+ REBCNT segs = 0;
+ REBCNT tot = 0;
+ REBCNT blks = 0;
+ REBCNT strs = 0;
+ REBCNT unis = 0;
+ REBCNT odds = 0;
+ REBCNT fre = 0;
+
+ REBCNT seg_size = 0;
+ REBCNT str_size = 0;
+ REBCNT uni_size = 0;
+ REBCNT blk_size = 0;
+ REBCNT odd_size = 0;
+
+ REBU64 tot_size = 0;
+
+ REBSEG *seg;
+ for (seg = Mem_Pools[SER_POOL].segs; seg; seg = seg->next) {
+
+ seg_size += seg->size;
+ segs++;
+
+ REBSER *s = cast(REBSER*, seg + 1);
+
+ REBCNT n;
+ for (n = Mem_Pools[SER_POOL].units; n > 0; n--) {
+ if (IS_FREE_NODE(s)) {
+ ++fre;
+ continue;
+ }
+
+ ++tot;
+
+ if (GET_SER_FLAG(s, NODE_FLAG_CELL))
+ continue;
+
+ tot_size += SER_TOTAL_IF_DYNAMIC(s); // else 0
+
+ if (GET_SER_FLAG(s, SERIES_FLAG_ARRAY)) {
+ blks++;
+ blk_size += SER_TOTAL_IF_DYNAMIC(s);
+ }
+ else if (SER_WIDE(s) == 1) {
+ strs++;
+ str_size += SER_TOTAL_IF_DYNAMIC(s);
+ }
+ else if (SER_WIDE(s) == sizeof(REBUNI)) {
+ unis++;
+ uni_size += SER_TOTAL_IF_DYNAMIC(s);
+ }
+ else if (SER_WIDE(s)) {
+ odds++;
+ odd_size += SER_TOTAL_IF_DYNAMIC(s);
+ }
+
+ ++s;
+ }
+ }
+
+ // Size up unused memory:
+ //
+ REBU64 fre_size = 0;
+ REBINT pool_num;
+ for (pool_num = 0; pool_num < SYSTEM_POOL; pool_num++) {
+ fre_size += Mem_Pools[pool_num].free * Mem_Pools[pool_num].wide;
+ }
+
+ if (show) {
+ printf("Series Memory Info:\n");
+ printf(" REBVAL size = %lu\n", cast(unsigned long, sizeof(REBVAL)));
+ printf(" REBSER size = %lu\n", cast(unsigned long, sizeof(REBSER)));
+ printf(
+ " %-6d segs = %-7d bytes - headers\n",
+ cast(int, segs),
+ cast(int, seg_size)
+ );
+ printf(
+ " %-6d blks = %-7d bytes - blocks\n",
+ cast(int, blks),
+ cast(int, blk_size)
+ );
+ printf(
+ " %-6d strs = %-7d bytes - byte strings\n",
+ cast(int, strs),
+ cast(int, str_size)
+ );
+ printf(
+ " %-6d unis = %-7d bytes - uni strings\n",
+ cast(int, unis),
+ cast(int, uni_size)
+ );
+ printf(
+ " %-6d odds = %-7d bytes - odd series\n",
+ cast(int, odds),
+ cast(int, odd_size)
+ );
+ printf(
+ " %-6d used = %lu bytes - total used\n",
+ cast(int, tot),
+ cast(unsigned long, tot_size)
+ );
+ printf(" %lu free headers\n", cast(unsigned long, fre));
+ printf(" %lu bytes node-space\n", cast(unsigned long, fre_size));
+ printf("\n");
+ }
+
+ fflush(stdout);
+
+ return tot_size;
}
+#endif
diff --git a/src/core/m-series.c b/src/core/m-series.c
index c7ac0fa0fb..78edc1f9c6 100644
--- a/src/core/m-series.c
+++ b/src/core/m-series.c
@@ -1,534 +1,525 @@
-/***********************************************************************
-**
-** REBOL Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: m-series.c
-** Summary: implements REBOL's series concept
-** Section: memory
-** Author: Carl Sassenrath
-**
-***********************************************************************/
+//
+// File: %m-series.c
+// Summary: "implements REBOL's series concept"
+// Section: memory
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
+#include "mem-series.h" // low-level series memory access
+#include "sys-int-funcs.h"
-/***********************************************************************
-**
-*/ void Expand_Series(REBSER *series, REBCNT index, REBCNT delta)
-/*
-** Expand a series at a particular index point by the number
-** number of units specified by delta.
-**
-** index - where space is expanded (but not cleared)
-** delta - number of UNITS to expand (keeping terminator)
-** tail - will be updated
-**
-** |<---rest--->|
-** <-bias->|<-tail->| |
-** +--------------------+
-** | abcdefghi |
-** +--------------------+
-** | |
-** data index
-**
-** If the series has enough space within it, then it will be used,
-** otherwise the series data will be reallocated.
-**
-** When expanded at the head, if bias space is available, it will
-** be used (if it provides enough space).
-**
-** WARNING: never use direct pointers into the series data, as the
-** series data can be relocated in memory.
-**
-***********************************************************************/
-{
- REBCNT start;
- REBCNT size;
- REBCNT extra;
- REBCNT wide;
- REBSER *newser, swap;
- REBCNT n;
- REBCNT x;
-
- if (delta == 0) return;
-
- // Optimized case of head insertion:
- if (index == 0 && SERIES_BIAS(series) >= delta) {
- series->data -= SERIES_WIDE(series) * delta;
- SERIES_TAIL(series) += delta;
- SERIES_REST(series) += delta;
- SERIES_SUB_BIAS(series, delta);
- return;
- }
-
- // Range checks:
- if (delta & 0x80000000) Trap0(RE_PAST_END); // 2GB max
- if (index > series->tail) index = series->tail; // clip
-
- // Width adjusted variables:
- wide = SERIES_WIDE(series);
- start = index * wide;
- extra = delta * wide;
- size = (series->tail + 1) * wide;
-
- // Do we need to expand the current series allocation?
- // WARNING: Do not use ">=" below or newser size may be the same!
- if ((size + extra) > SERIES_SPACE(series)) {
- if (IS_LOCK_SERIES(series)) Crash(RP_LOCKED_SERIES);
- //DISABLE_GC; // Don't let GC occur just for an expansion.
-
- if (Reb_Opts->watch_expand) {
- Debug_Fmt("Expand %x wide: %d tail: %d delta: %d", series, wide, series->tail, delta);
- }
-
- // Create a new series that is bigger.
- // Have we recently expanded the same series?
- x = 1;
- n = (REBCNT)(Prior_Expand[0]);
- do {
- if (Prior_Expand[n] == series) {
- x = series->tail + delta + 1; // Double the size
- break;
- }
- if (++n >= MAX_EXPAND_LIST) n = 1;
- } while (n != (REBCNT)(Prior_Expand[0]));
-#ifdef DEBUGGING
- Print_Num("Expand:", series->tail + delta + 1);
-#endif
- newser = Make_Series(series->tail + delta + x, wide, TRUE);
- // If necessary, add series to the recently expanded list:
- if (Prior_Expand[n] != series) {
- n = (REBCNT)(Prior_Expand[0]) + 1;
- if (n >= MAX_EXPAND_LIST) n = 1;
- Prior_Expand[n] = series;
- }
- Prior_Expand[0] = (REBSER*)n; // start next search here
- Prop_Series(newser, series);
- //ENABLE_GC;
-
- // Copy the series up to the expansion point:
- memcpy(newser->data, series->data, start);
-
- // Copy the series after the expansion point:
- // In AT_TAIL cases, this just moves the terminator to the new tail.
- memcpy(newser->data + start + extra, series->data + start, size - start);
-
- newser->tail = series->tail + delta;
-
- // Swap new and old series, then free the old one.
- // This seems silly, but this method isolates us from
- // needing to know the internals series headers.
- swap = *series;
- *series = *newser;
- *newser = swap;
- Free_Series(newser);
- SERIES_SET_BIAS(series, 0); // be sure it is reset
-
- PG_Reb_Stats->Series_Expanded++; // Metric
- CHECK_MEMORY(3);
- return;
- }
-
- // No expansion was need. Slide data down if necessary.
- // Note that the tail is always moved here. This is probably faster
- // than doing the computation to determine if it is needs to be done.
- memmove(series->data + start + extra, series->data + start, size - start);
- series->tail += delta;
-
- if ((SERIES_TAIL(series) + SERIES_BIAS(series)) * wide >= SERIES_TOTAL(series)) {
- Dump_Series(series, "Overflow");
- ASSERT(0, RP_OVER_SERIES);
- }
-
- CHECK_MEMORY(3);
-}
-
-/***********************************************************************
-**
-*/ void Extend_Series(REBSER *series, REBCNT delta)
-/*
-** Extend a series at its end without affecting its tail index.
-**
-***********************************************************************/
+//
+// Extend_Series: C
+//
+// Extend a series at its end without affecting its tail index.
+//
+void Extend_Series(REBSER *s, REBCNT delta)
{
- REBCNT tail = series->tail; // maintain tail position
- EXPAND_SERIES_TAIL(series, delta);
- series->tail = tail;
+ REBCNT len_old = SER_LEN(s);
+ EXPAND_SERIES_TAIL(s, delta);
+ SET_SERIES_LEN(s, len_old);
}
-/***********************************************************************
-**
-*/ REBCNT Insert_Series(REBSER *series, REBCNT index, REBYTE *data, REBCNT len)
-/*
-** Insert a series of values (bytes, longs, reb-vals) into the
-** series at the given index. Expand it if necessary. Does
-** not add a terminator to tail.
-**
-***********************************************************************/
-{
- if (index > series->tail) index = series->tail;
- Expand_Series(series, index, len); // tail += len
- //Print("i: %d t: %d l: %d x: %d s: %d", index, series->tail, len, (series->tail + 1) * SERIES_WIDE(series), series->size);
- memcpy(series->data + (SERIES_WIDE(series) * index), data, SERIES_WIDE(series) * len);
- //*(int *)(series->data + (series->tail-1) * SERIES_WIDE(series)) = 5; // for debug purposes
- return index + len;
+//
+// Insert_Series: C
+//
+// Insert a series of values (bytes, longs, reb-vals) into the
+// series at the given index. Expand it if necessary. Does
+// not add a terminator to tail.
+//
+REBCNT Insert_Series(
+ REBSER *s,
+ REBCNT index,
+ const REBYTE *data,
+ REBCNT len
+) {
+ if (index > SER_LEN(s))
+ index = SER_LEN(s);
+
+ Expand_Series(s, index, len); // tail += len
+
+ memcpy(
+ SER_DATA_RAW(s) + (SER_WIDE(s) * index),
+ data,
+ SER_WIDE(s) * len
+ );
+
+ return index + len;
}
-/***********************************************************************
-**
-*/ void Append_Series(REBSER *series, REBYTE *data, REBCNT len)
-/*
-** Append value(s) onto the tail of a series. The len is
-** the number of units (bytes, REBVALS, etc.) of the data,
-** and does not include the terminator (which will be added).
-** The new tail position will be returned as the result.
-** A terminator will be added to the end of the appended data.
-**
-***********************************************************************/
+//
+// Append_Series: C
+//
+// Append value(s) onto the tail of a series. The len is
+// the number of units (bytes, REBVALS, etc.) of the data,
+// and does not include the terminator (which will be added).
+// The new tail position will be returned as the result.
+// A terminator will be added to the end of the appended data.
+//
+void Append_Series(REBSER *s, const REBYTE *data, REBCNT len)
{
- REBCNT tail = series->tail;
- REBCNT wide = SERIES_WIDE(series);
+ REBCNT len_old = SER_LEN(s);
+ REBYTE wide = SER_WIDE(s);
- EXPAND_SERIES_TAIL(series, len);
- memcpy(series->data + (wide * tail), data, wide * len);
- CLEAR(series->data + (wide * series->tail), wide); // terminator
-}
+ assert(NOT_SER_FLAG(s, SERIES_FLAG_ARRAY));
+ EXPAND_SERIES_TAIL(s, len);
+ memcpy(SER_DATA_RAW(s) + (wide * len_old), data, wide * len);
-/***********************************************************************
-**
-*/ void Append_Mem_Extra(REBSER *series, REBYTE *data, REBCNT len, REBCNT extra)
-/*
-** An optimized function for appending raw memory bytes to
-** a byte-sized series. The series will be expanded if room
-** is needed. A zero terminator will be added at the tail.
-** The extra size will be assured in the series, but is not
-** part of the appended length. (Allows adding additional bytes.)
-**
-***********************************************************************/
-{
- REBCNT tail = series->tail;
-
- if ((tail + len + extra + 1) >= SERIES_REST(series)) {
- Expand_Series(series, tail, len+extra); // series->tail changed
- series->tail -= extra;
- }
- else {
- series->tail += len;
- }
-
- memcpy(series->data + tail, data, len);
- STR_TERM(series);
+ TERM_SERIES(s);
}
-/***********************************************************************
-**
-*/ REBSER *Copy_Series(REBSER *source)
-/*
-** Copy any series, including terminator for it.
-**
-***********************************************************************/
+//
+// Append_Values_Len: C
+//
+// Append value(s) onto the tail of an array. The len is
+// the number of units and does not include the terminator
+// (which will be added).
+//
+void Append_Values_Len(REBARR *a, const REBVAL head[], REBCNT len)
{
- REBCNT len = source->tail + 1;
- REBSER *series = Make_Series(len, SERIES_WIDE(source), FALSE);
+ REBCNT old_len = ARR_LEN(a);
- memcpy(series->data, source->data, len * SERIES_WIDE(source));
- series->tail = source->tail;
- return series;
-}
+ // updates tail, which could move data storage.
+ //
+ EXPAND_SERIES_TAIL(SER(a), len);
+ memcpy(ARR_AT(a, old_len), head, sizeof(REBVAL) * len);
-/***********************************************************************
-**
-*/ REBSER *Copy_Series_Part(REBSER *source, REBCNT index, REBCNT length)
-/*
-** Copy any subseries, including terminator for it.
-**
-***********************************************************************/
-{
- REBSER *series = Make_Series(length+1, SERIES_WIDE(source), FALSE);
-
- memcpy(series->data, source->data + index * SERIES_WIDE(source), (length+1) * SERIES_WIDE(source));
- series->tail = length;
- return series;
+ TERM_ARRAY_LEN(a, ARR_LEN(a));
}
-/***********************************************************************
-**
-*/ REBSER *Copy_Series_Value(REBVAL *value)
-/*
-** Copy a series from its value structure.
-** Index does not need to be at head location.
-**
-***********************************************************************/
+//
+// Copy_Sequence: C
+//
+// Copy any series that *isn't* an "array" (such as STRING!,
+// BINARY!, BITSET!, VECTOR!...). Includes the terminator.
+//
+// Use Copy_Array routines (which specify Shallow, Deep, etc.) for
+// greater detail needed when expressing intent for Rebol Arrays.
+//
+// Note: No suitable name for "non-array-series" has been picked.
+// "Sequence" is used for now because Copy_Non_Array() doesn't
+// look good and lots of things aren't "Rebol Arrays" that aren't
+// series. The main idea was just to get rid of the generic
+// Copy_Series() routine, which doesn't call any attention
+// to the importance of stating one's intentions specifically
+// about semantics when copying an array.
+//
+REBSER *Copy_Sequence(REBSER *original)
{
- return Copy_Series_Part(VAL_SERIES(value), VAL_INDEX(value), VAL_LEN(value));
+ assert(NOT_SER_FLAG(original, SERIES_FLAG_ARRAY));
+
+ REBCNT len = SER_LEN(original);
+ REBSER *copy = Make_Series(len + 1, SER_WIDE(original));
+
+ memcpy(
+ SER_DATA_RAW(copy),
+ SER_DATA_RAW(original),
+ len * SER_WIDE(original)
+ );
+ TERM_SEQUENCE_LEN(copy, SER_LEN(original));
+ return copy;
}
-#ifdef NOT_USED
-/***********************************************************************
-**
-*/ REBINT Clone_Series(REBVAL *dst, REBVAL *src)
-/*
-** Properly deep copy all types of series.
-** Return TRUE if BLOCK type.
-**
-***********************************************************************/
+//
+// Copy_Sequence_At_Len: C
+//
+// Copy a subseries out of a series that is not an array.
+// Includes the terminator for it.
+//
+// Use Copy_Array routines (which specify Shallow, Deep, etc.) for
+// greater detail needed when expressing intent for Rebol Arrays.
+//
+REBSER *Copy_Sequence_At_Len(REBSER *original, REBCNT index, REBCNT len)
{
- Check_Stack();
- if (VAL_TYPE(src) < REB_BLOCK) {
- if (VAL_SERIES_WIDTH(src) == 4)
- VAL_SERIES(dst) = Make_Quad(VAL_BIN(src), VAL_TAIL(src));
- else
- VAL_SERIES(dst) = Copy_String(VAL_SERIES(src));
- return FALSE;
- } else {
-
- VAL_SERIES(dst) = Clone_Block(VAL_SERIES(src));
- if (IS_HASH(dst) || IS_LIST(dst))
- VAL_SERIES_SIDE(dst) = Copy_Side_Series(VAL_SERIES_SIDE(dst));
- return TRUE;
- }
+ assert(NOT_SER_FLAG(original, SERIES_FLAG_ARRAY));
+
+ REBSER *copy = Make_Series(len + 1, SER_WIDE(original));
+ memcpy(
+ SER_DATA_RAW(copy),
+ SER_DATA_RAW(original) + index * SER_WIDE(original),
+ (len + 1) * SER_WIDE(original)
+ );
+ TERM_SEQUENCE_LEN(copy, len);
+ return copy;
}
-#endif
-/***********************************************************************
-**
-*/ void Remove_Series(REBSER *series, REBCNT index, REBINT len)
-/*
-** Remove a series of values (bytes, longs, reb-vals) from the
-** series at the given index.
-**
-***********************************************************************/
+//
+// Copy_Sequence_At_Position: C
+//
+// Copy a non-array series from its value structure, using the
+// value's index as the location to start copying the data.
+//
+REBSER *Copy_Sequence_At_Position(const REBVAL *position)
{
- REBCNT start;
- REBCNT length;
- REBYTE *data;
-
- if (len <= 0) return;
-
- // Optimized case of head removal:
- if (index == 0) {
- if ((REBCNT)len > series->tail) len = series->tail;
- SERIES_TAIL(series) -= len;
- if (SERIES_TAIL(series) == 0) {
- // Reset bias to zero:
- len = SERIES_BIAS(series);
- SERIES_SET_BIAS(series, 0);
- SERIES_REST(series) += len;
- series->data -= SERIES_WIDE(series) * len;
- CLEAR(series->data, SERIES_WIDE(series)); // terminate
- } else {
- // Add bias to head:
- SERIES_ADD_BIAS(series, len);
- SERIES_REST(series) -= len;
- series->data += SERIES_WIDE(series) * len;
- if (NZ(start = SERIES_BIAS(series))) {
- // If more than half biased:
- if (start >= MAX_SERIES_BIAS || start > SERIES_REST(series))
- Reset_Bias(series);
- }
- }
- return;
- }
-
- if (index >= series->tail) return;
-
- start = index * SERIES_WIDE(series);
-
- // Clip if past end and optimize the remove operation:
- if (len + index >= series->tail) {
- series->tail = index;
- CLEAR(series->data + start, SERIES_WIDE(series));
- return;
- }
-
- length = SERIES_LEN(series) * SERIES_WIDE(series);
- series->tail -= (REBCNT)len;
- len *= SERIES_WIDE(series);
- data = series->data + start;
- memmove(data, data + len, length - (start + len));
-
- CHECK_MEMORY(5);
+ return Copy_Sequence_At_Len(
+ VAL_SERIES(position), VAL_INDEX(position), VAL_LEN_AT(position)
+ );
}
-/***********************************************************************
-**
-*/ void Remove_Last(REBSER *series)
-/*
-** Remove last value from a series.
-**
-***********************************************************************/
+//
+// Remove_Series: C
+//
+// Remove a series of values (bytes, longs, reb-vals) from the
+// series at the given index.
+//
+void Remove_Series(REBSER *s, REBCNT index, REBINT len)
{
- if (series->tail == 0) return;
- series->tail--;
- CLEAR(series->data + SERIES_WIDE(series) * series->tail, SERIES_WIDE(series));
+ if (len <= 0) return;
+
+ REBOOL is_dynamic = GET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC);
+ REBCNT len_old = SER_LEN(s);
+
+ REBCNT start = index * SER_WIDE(s);
+
+ // Optimized case of head removal. For a dynamic series this may just
+ // add "bias" to the head...rather than move any bytes.
+
+ if (is_dynamic && index == 0) {
+ if (cast(REBCNT, len) > len_old)
+ len = len_old;
+
+ s->content.dynamic.len -= len;
+ if (s->content.dynamic.len == 0) {
+ // Reset bias to zero:
+ len = SER_BIAS(s);
+ SER_SET_BIAS(s, 0);
+ s->content.dynamic.rest += len;
+ s->content.dynamic.data -= SER_WIDE(s) * len;
+ TERM_SERIES(s);
+ }
+ else {
+ // Add bias to head:
+ u32 bias = SER_BIAS(s);
+ if (REB_U32_ADD_OF(bias, len, &bias))
+ fail (Error_Overflow_Raw());
+
+ if (bias > 0xffff) { //bias is 16-bit, so a simple SER_ADD_BIAS could overflow it
+ REBYTE *data = s->content.dynamic.data;
+
+ data += SER_WIDE(s) * len;
+ s->content.dynamic.data -= SER_WIDE(s) * SER_BIAS(s);
+
+ s->content.dynamic.rest += SER_BIAS(s);
+ SER_SET_BIAS(s, 0);
+
+ memmove(
+ s->content.dynamic.data,
+ data,
+ SER_LEN(s) * SER_WIDE(s)
+ );
+ TERM_SERIES(s);
+ }
+ else {
+ SER_SET_BIAS(s, bias);
+ s->content.dynamic.rest -= len;
+ s->content.dynamic.data += SER_WIDE(s) * len;
+ if ((start = SER_BIAS(s)) != 0) {
+ // If more than half biased:
+ if (start >= MAX_SERIES_BIAS || start > SER_REST(s))
+ Unbias_Series(s, TRUE);
+ }
+ }
+ }
+ return;
+ }
+
+ if (index >= len_old) return;
+
+ // Clip if past end and optimize the remove operation:
+
+ if (len + index >= len_old) {
+ SET_SERIES_LEN(s, index);
+ TERM_SERIES(s);
+ return;
+ }
+
+ // The terminator is not included in the length, because termination may
+ // be implicit (e.g. there may not be a full SER_WIDE() worth of data
+ // at the termination location). Use TERM_SERIES() instead.
+ //
+ REBCNT length = SER_LEN(s) * SER_WIDE(s);
+ SET_SERIES_LEN(s, len_old - cast(REBCNT, len));
+ len *= SER_WIDE(s);
+
+ REBYTE *data = SER_DATA_RAW(s) + start;
+ memmove(data, data + len, length - (start + len));
+ TERM_SERIES(s);
}
-/***********************************************************************
-**
-*/ void Reset_Bias(REBSER *series)
-/*
-** Reset series bias.
-**
-***********************************************************************/
+//
+// Unbias_Series: C
+//
+// Reset series bias.
+//
+void Unbias_Series(REBSER *s, REBOOL keep)
{
- REBCNT len;
- REBYTE *data = series->data;
+ REBCNT len = SER_BIAS(s);
+ if (len == 0)
+ return;
+
+ REBYTE *data = s->content.dynamic.data;
- len = SERIES_BIAS(series);
- SERIES_SET_BIAS(series, 0);
- SERIES_REST(series) += len;
- series->data -= SERIES_WIDE(series) * len;
+ SER_SET_BIAS(s, 0);
+ s->content.dynamic.rest += len;
+ s->content.dynamic.data -= SER_WIDE(s) * len;
- memmove(series->data, data, SERIES_USED(series));
+ if (keep) {
+ memmove(s->content.dynamic.data, data, SER_LEN(s) * SER_WIDE(s));
+ TERM_SERIES(s);
+ }
}
-/***********************************************************************
-**
-*/ void Reset_Series(REBSER *series)
-/*
-** Reset series to empty. Reset bias, tail, and termination.
-** The tail is reset to zero.
-**
-***********************************************************************/
+//
+// Reset_Sequence: C
+//
+// Reset series to empty. Reset bias, tail, and termination.
+// The tail is reset to zero.
+//
+void Reset_Sequence(REBSER *s)
{
- series->tail = 0;
- if (SERIES_BIAS(series)) Reset_Bias(series);
- CLEAR(series->data, SERIES_WIDE(series)); // re-terminate
+ assert(NOT_SER_FLAG(s, SERIES_FLAG_ARRAY));
+ if (GET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC)) {
+ Unbias_Series(s, FALSE);
+ s->content.dynamic.len = 0;
+ TERM_SEQUENCE(s);
+ }
+ else
+ TERM_SEQUENCE_LEN(s, 0);
}
-/***********************************************************************
-**
-*/ void Clear_Series(REBSER *series)
-/*
-** Clear an entire series to zero. Resets bias and tail.
-** The tail is reset to zero.
-**
-***********************************************************************/
+//
+// Reset_Array: C
+//
+// Reset series to empty. Reset bias, tail, and termination.
+// The tail is reset to zero.
+//
+void Reset_Array(REBARR *a)
{
- series->tail = 0;
- if (SERIES_BIAS(series)) Reset_Bias(series);
- CLEAR(series->data, SERIES_SPACE(series));
+ if (GET_SER_INFO(a, SERIES_INFO_HAS_DYNAMIC))
+ Unbias_Series(SER(a), FALSE);
+ TERM_ARRAY_LEN(a, 0);
}
-/***********************************************************************
-**
-*/ void Resize_Series(REBSER *series, REBCNT size)
-/*
-** Reset series and expand it to required size.
-** The tail is reset to zero.
-**
-***********************************************************************/
+//
+// Clear_Series: C
+//
+// Clear an entire series to zero. Resets bias and tail.
+// The tail is reset to zero.
+//
+void Clear_Series(REBSER *s)
{
- series->tail = 0;
- if (SERIES_BIAS(series)) Reset_Bias(series);
- EXPAND_SERIES_TAIL(series, size);
- series->tail = 0;
- CLEAR(series->data, SERIES_WIDE(series)); // re-terminate
+ assert(!Is_Series_Read_Only(s));
+
+ if (GET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC)) {
+ Unbias_Series(s, FALSE);
+ CLEAR(s->content.dynamic.data, SER_REST(s) * SER_WIDE(s));
+ }
+ else
+ CLEAR(cast(REBYTE*, &s->content), sizeof(s->content));
+
+ TERM_SERIES(s);
}
-/***********************************************************************
-**
-*/ void Terminate_Series(REBSER *series)
-/*
-** Put terminator at tail of the series.
-**
-***********************************************************************/
+//
+// Resize_Series: C
+//
+// Reset series and expand it to required size.
+// The tail is reset to zero.
+//
+void Resize_Series(REBSER *s, REBCNT size)
{
- CLEAR(series->data + SERIES_WIDE(series) * series->tail, SERIES_WIDE(series));
+ if (GET_SER_INFO(s, SERIES_INFO_HAS_DYNAMIC)) {
+ s->content.dynamic.len = 0;
+ Unbias_Series(s, TRUE);
+ }
+ else
+ SET_SERIES_LEN(s, 0);
+
+ EXPAND_SERIES_TAIL(s, size);
+ SET_SERIES_LEN(s, 0);
+ TERM_SERIES(s);
}
-/***********************************************************************
-**
-*/ void Shrink_Series(REBSER *series, REBCNT units)
-/*
-** Shrink a series back to a given maximum size. All
-** content is deleted and tail is reset.
-**
-** WARNING: This should only be used for strings or other
-** series that cannot contain internally referenced values.
-**
-***********************************************************************/
+//
+// Reset_Buffer: C
+//
+// Setup to reuse a shared buffer. Expand it if needed.
+//
+// NOTE: The length will be set to the supplied value, but the series will
+// not be terminated.
+//
+REBYTE *Reset_Buffer(REBSER *buf, REBCNT len)
{
- if (SERIES_REST(series) <= units) return;
- //DISABLE_GC;
- Free_Series_Data(series, FALSE);
- Make_Series_Data(series, units);
- //ENABLE_GC;
+ if (buf == NULL)
+ panic ("buffer not yet allocated");
+
+ SET_SERIES_LEN(buf, 0);
+ Unbias_Series(buf, TRUE);
+ Expand_Series(buf, 0, len); // sets new tail
+
+ return SER_DATA_RAW(buf);
}
-/***********************************************************************
-**
-*/ REBYTE *Reset_Buffer(REBSER *buf, REBCNT len)
-/*
-** Setup to reuse a shared buffer. Expand it if needed.
-**
-** NOTE:The tail is set to the length position.
-**
-***********************************************************************/
+//
+// Copy_Buffer: C
+//
+// Copy a shared buffer, starting at index. Set tail and termination.
+//
+REBSER *Copy_Buffer(REBSER *buf, REBCNT index, void *end)
{
- if (!buf) Crash(RP_NO_BUFFER);
+ assert(NOT_SER_FLAG(buf, SERIES_FLAG_ARRAY));
+
+ REBCNT len = BYTE_SIZE(buf)
+ ? cast(REBYTE*, end) - BIN_HEAD(buf)
+ : cast(REBUNI*, end) - UNI_HEAD(buf);
+
+ if (index) len -= index;
+
+ REBSER *copy = Make_Series(len + 1, SER_WIDE(buf));
+
+ memcpy(
+ SER_DATA_RAW(copy),
+ SER_DATA_RAW(buf) + index * SER_WIDE(buf),
+ SER_WIDE(buf) * len
+ );
+ TERM_SEQUENCE_LEN(copy, len);
+
+ return copy;
+}
- RESET_TAIL(buf);
- if (SERIES_BIAS(buf)) Reset_Bias(buf);
- Expand_Series(buf, 0, len); // sets new tail
- return BIN_DATA(buf);
+#if !defined(NDEBUG)
+
+//
+// Assert_Series_Term_Core: C
+//
+void Assert_Series_Term_Core(REBSER *s)
+{
+ if (GET_SER_FLAG(s, SERIES_FLAG_ARRAY)) {
+ //
+ // END values aren't canonized to zero bytes, check IS_END explicitly
+ //
+ RELVAL *tail = ARR_TAIL(ARR(s));
+ if (NOT_END(tail))
+ panic (tail);
+ }
+ else {
+ // If they are terminated, then non-REBVAL-bearing series must have
+ // their terminal element as all 0 bytes (to use this check)
+ //
+ REBCNT len = SER_LEN(s);
+ REBCNT wide = SER_WIDE(s);
+ REBCNT n;
+ for (n = 0; n < wide; n++) {
+ if (0 != SER_DATA_RAW(s)[(len * wide) + n])
+ panic (s);
+ }
+ }
}
-/***********************************************************************
-**
-*/ REBSER *Copy_Buffer(REBSER *buf, void *end)
-/*
-** Copy a shared buffer. Set tail and termination.
-**
-***********************************************************************/
+//
+// Assert_Series_Core: C
+//
+void Assert_Series_Core(REBSER *s)
{
- REBSER *ser;
- REBCNT len;
+ if (IS_FREE_NODE(s))
+ panic (s);
- len = BYTE_SIZE(buf) ? ((REBYTE *)end) - BIN_HEAD(buf)
- : ((REBUNI *)end) - UNI_HEAD(buf);
+ assert(
+ GET_SER_INFO(s, SERIES_INFO_0_IS_TRUE) // @ NODE_FLAG_NODE
+ && NOT_SER_INFO(s, SERIES_INFO_1_IS_FALSE) // @ NOT(NODE_FLAG_FREE)
+ && GET_SER_INFO(s, SERIES_INFO_4_IS_TRUE) // @ NODE_FLAG_END
+ && NOT_SER_INFO(s, SERIES_INFO_7_IS_FALSE) // @ NODE_FLAG_CELL
+ );
- ser = Make_Series(len+1, SERIES_WIDE(buf), FALSE);
+ assert(SER_LEN(s) < SER_REST(s));
+
+ Assert_Series_Term_Core(s);
+}
- memcpy(ser->data, buf->data, SERIES_WIDE(buf) * len);
- ser->tail = len;
- TERM_SERIES(ser);
- return ser;
+//
+// Panic_Series_Debug: C
+//
+// The goal of this routine is to progressively reveal as much diagnostic
+// information about a series as possible. Since the routine will ultimately
+// crash anyway, it is okay if the diagnostics run code which might be
+// risky in an unstable state...though it is ideal if it can run to the end
+// so it can trigger Address Sanitizer or Valgrind's internal stack dump.
+//
+ATTRIBUTE_NO_RETURN void Panic_Series_Debug(REBSER *s)
+{
+ fflush(stdout);
+ fflush(stderr);
+
+ if (s->header.bits & NODE_FLAG_MANAGED)
+ printf("managed");
+ else
+ printf("unmanaged");
+ printf(" series was likely ");
+ if (s->header.bits & NODE_FLAG_FREE)
+ printf("freed");
+ else
+ printf("created");
+ printf(" during evaluator tick: %lu\n", cast(unsigned long, s->do_count));
+
+ fflush(stdout);
+
+ if (*s->guard == 1020) // should make valgrind or asan alert
+ panic ("series guard didn't trigger ASAN/valgrind trap");
+
+ OS_CRASH(
+ cb_cast("series guard didn't trigger ASAN/Valgrind trap\n"),
+ cb_cast("either not a REBSER, or you're not running ASAN/Valgrind\n")
+ );
+
+ while (TRUE)
+ NOOP; // just in case it didn't crash, don't return
+
+ DEAD_END;
}
+
+#endif
diff --git a/src/core/m-stacks.c b/src/core/m-stacks.c
new file mode 100644
index 0000000000..7b7acb5407
--- /dev/null
+++ b/src/core/m-stacks.c
@@ -0,0 +1,349 @@
+//
+// File: %m-stack.c
+// Summary: "data and function call stack implementation"
+// Section: memory
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+
+#include "sys-core.h"
+
+
+//
+// Startup_Stacks: C
+//
+void Startup_Stacks(REBCNT size)
+{
+ // We always keep one chunker around for the first chunk push, and prep
+ // one chunk so that the push and drop routines never worry about testing
+ // for the empty case.
+
+ TG_Root_Chunker = cast(
+ struct Reb_Chunker*,
+ Alloc_Mem(BASE_CHUNKER_SIZE + CS_CHUNKER_PAYLOAD)
+ );
+
+#if !defined(NDEBUG)
+ memset(TG_Root_Chunker, 0xBD, sizeof(struct Reb_Chunker));
+#endif
+
+ TG_Root_Chunker->next = NULL;
+ TG_Root_Chunker->size = CS_CHUNKER_PAYLOAD;
+ TG_Top_Chunk = cast(struct Reb_Chunk*, &TG_Root_Chunker->payload);
+ TG_Top_Chunk->prev = NULL;
+
+ // Zero values for initial chunk, also sets offset to 0
+ //
+ Init_Endlike_Header(&TG_Top_Chunk->header, 0);
+ TG_Top_Chunk->offset = 0;
+ TG_Top_Chunk->size = BASE_CHUNK_SIZE;
+
+ // Implicit termination trick, see notes on NODE_FLAG_END
+ //
+ Init_Endlike_Header(
+ &cast(
+ struct Reb_Chunk*, cast(REBYTE*, TG_Top_Chunk) + BASE_CHUNK_SIZE
+ )->header,
+ 0
+ );
+ assert(IS_END(&TG_Top_Chunk->values[0]));
+
+ // Start the data stack out with just one element in it, and make it an
+ // unreadable blank in the debug build. This helps avoid accidental
+ // reads and is easy to notice when it is overwritten. It also means
+ // that indices into the data stack can be unsigned (no need for -1 to
+ // mean empty, because 0 can)
+ //
+ // DS_PUSH checks what you're pushing isn't void, as most arrays can't
+ // contain them. But DS_PUSH_MAYBE_VOID allows you to, in case you
+ // are building a context varlist or similar.
+ //
+ DS_Array = Make_Array_Core(1, ARRAY_FLAG_VOIDS_LEGAL);
+ SET_UNREADABLE_BLANK(ARR_HEAD(DS_Array));
+
+ // The END marker will signal DS_PUSH that it has run out of space,
+ // and it will perform the allocation at that time.
+ //
+ TERM_ARRAY_LEN(DS_Array, 1);
+ ASSERT_ARRAY(DS_Array);
+
+ // Reuse the expansion logic that happens on a DS_PUSH to get the
+ // initial stack size. It requires you to be on an END to run.
+ //
+ DS_Index = 1;
+ DS_Movable_Base = KNOWN(ARR_HEAD(DS_Array)); // can't push RELVALs
+ Expand_Data_Stack_May_Fail(size);
+
+ // Now drop the hypothetical thing pushed that triggered the expand.
+ //
+ DS_DROP;
+
+ // Call stack (includes pending functions, parens...anything that sets
+ // up a `REBFRM` and calls Do_Core()) Singly linked.
+ //
+ TG_Frame_Stack = NULL;
+}
+
+
+//
+// Shutdown_Stacks: C
+//
+void Shutdown_Stacks(void)
+{
+ assert(FS_TOP == NULL);
+ assert(DSP == 0);
+ assert(IS_UNREADABLE_IF_DEBUG(ARR_HEAD(DS_Array)));
+
+ Free_Array(DS_Array);
+
+ assert(TG_Top_Chunk == cast(struct Reb_Chunk*, &TG_Root_Chunker->payload));
+
+ // Because we always keep one chunker of headroom allocated, and the
+ // push/drop is not designed to manage the last chunk, we *might* have
+ // that next chunk of headroom still allocated.
+ //
+ if (TG_Root_Chunker->next)
+ Free_Mem(TG_Root_Chunker->next, TG_Root_Chunker->next->size + BASE_CHUNKER_SIZE);
+
+ // OTOH we always have to free the root chunker.
+ //
+ Free_Mem(TG_Root_Chunker, TG_Root_Chunker->size + BASE_CHUNKER_SIZE);
+}
+
+
+//
+// Expand_Data_Stack_May_Fail: C
+//
+// The data stack maintains an invariant that you may never push an END to it.
+// So each push looks to see if it's pushing to a cell that contains an END
+// and if so requests an expansion.
+//
+// WARNING: This will invalidate any extant pointers to REBVALs living in
+// the stack. It is for this reason that stack access should be done by
+// REBDSP "data stack pointers" and not by REBVAL* across *any* operation
+// which could do a push or pop. (Currently stable w.r.t. pop but there may
+// be compaction at some point.)
+//
+void Expand_Data_Stack_May_Fail(REBCNT amount)
+{
+ REBCNT len_old = ARR_LEN(DS_Array);
+
+ // The current requests for expansion should only happen when the stack
+ // is at its end. Sanity check that.
+ //
+#if !defined(NDEBUG)
+ //
+ // Note: DS_TOP or DS_AT(DSP) would assert on END, calculate directly
+ //
+ REBVAL *end_top = DS_Movable_Base + DSP;
+ assert(IS_END(end_top));
+ assert(end_top == KNOWN(ARR_TAIL(DS_Array))); // can't push RELVALs
+ assert(end_top - KNOWN(ARR_HEAD(DS_Array)) == cast(int, len_old));
+#endif
+
+ // If adding in the requested amount would overflow the stack limit, then
+ // give a data stack overflow error.
+ //
+ if (SER_REST(SER(DS_Array)) + amount >= STACK_LIMIT)
+ Trap_Stack_Overflow();
+
+ Extend_Series(SER(DS_Array), amount);
+
+ // Update the global pointer representing the base of the stack that
+ // likely was moved by the above allocation. (It's not necessarily a
+ // huge win to cache it, but it turns data stack access from a double
+ // dereference into a single dereference in the common case, and it was
+ // how R3-Alpha did it).
+ //
+ DS_Movable_Base = KNOWN(ARR_HEAD(DS_Array)); // must do before using DS_TOP
+
+ // We fill in the data stack with "GC safe trash" (which is void in the
+ // release build, but will raise an alarm if VAL_TYPE() called on it in
+ // the debug build). In order to serve as a marker for the stack slot
+ // being available, it merely must not be IS_END()...
+
+ // again, DS_TOP or DS_AT(DSP) would assert on END, calculate directly
+ //
+ REBVAL *value = DS_Movable_Base + DSP;
+
+ REBCNT len_new = len_old + amount;
+ REBCNT n;
+ for (n = len_old; n < len_new; ++n) {
+ SET_UNREADABLE_BLANK(value);
+ ++value;
+ }
+
+ // Update the end marker to serve as the indicator for when the next
+ // stack push would need to expand.
+ //
+ TERM_ARRAY_LEN(DS_Array, len_new);
+ assert(value == ARR_TAIL(DS_Array));
+
+ ASSERT_ARRAY(DS_Array);
+}
+
+
+//
+// Pop_Stack_Values: C
+//
+// Pops computed values from the stack to make a new ARRAY.
+//
+REBARR *Pop_Stack_Values_Core(REBDSP dsp_start, REBUPT flags)
+{
+ REBARR *array = Copy_Values_Len_Shallow_Core(
+ DS_AT(dsp_start + 1), // start somewhere in the stack, end at DS_TOP
+ SPECIFIED, // data stack should be fully specified--no relative values
+ DSP - dsp_start, // len
+ flags
+ );
+
+ DS_DROP_TO(dsp_start);
+ return array;
+}
+
+
+//
+// Pop_Stack_Values_Reversed: C
+//
+// Pops computed values from the stack to make a new ARRAY, but reverses the
+// data so the last pushed item is the first in the array.
+//
+REBARR *Pop_Stack_Values_Reversed(REBDSP dsp_start)
+{
+ REBARR *array = Copy_Values_Len_Reversed_Shallow(
+ DS_TOP, // start at DS_TOP, work backwards somewhere in the stack
+ SPECIFIED, // data stack should be fully specified--no relative values
+ DSP - dsp_start // len
+ );
+
+ DS_DROP_TO(dsp_start);
+ return array;
+}
+
+
+//
+// Pop_Stack_Values_Into: C
+//
+// Pops computed values from the stack into an existing ANY-ARRAY. The
+// index of that array will be updated to the insertion tail (/INTO protocol)
+//
+void Pop_Stack_Values_Into(REBVAL *into, REBDSP dsp_start) {
+ REBCNT len = DSP - dsp_start;
+ REBVAL *values = KNOWN(ARR_AT(DS_Array, dsp_start + 1));
+
+ assert(ANY_ARRAY(into));
+ FAIL_IF_READ_ONLY_ARRAY(VAL_ARRAY(into));
+
+ VAL_INDEX(into) = Insert_Series(
+ SER(VAL_ARRAY(into)),
+ VAL_INDEX(into),
+ cast(REBYTE*, values), // stack only holds fully specified REBVALs
+ len // multiplied by width (sizeof(REBVAL)) in Insert_Series
+ );
+
+ DS_DROP_TO(dsp_start);
+}
+
+
+//
+// Reify_Frame_Context_Maybe_Fulfilling: C
+//
+// A Reb_Frame does not allocate a REBSER for its frame to be used in the
+// context by default. But one can be allocated on demand, even for a NATIVE!
+// in order to have a binding location for the debugger (for instance).
+// If it becomes necessary to create words bound into the frame that is
+// another case where the frame needs to be brought into existence.
+//
+// If there's already a frame this will return it, otherwise create it.
+//
+void Reify_Frame_Context_Maybe_Fulfilling(REBFRM *f) {
+ assert(Is_Any_Function_Frame(f)); // varargs reifies while still pending
+
+ if (f->varlist != NULL) {
+ //
+ // We have our function call's args in an array, but it is not yet
+ // a context. !!! Really this cannot reify if we're in arg gathering
+ // mode, calling MANAGE_ARRAY is illegal -- need test for that !!!
+ //
+ assert(NOT_SER_FLAG(f->varlist, ARRAY_FLAG_VARLIST));
+ SET_SER_FLAG(f->varlist, ARRAY_FLAG_VARLIST);
+
+ assert(IS_TRASH_DEBUG(ARR_AT(f->varlist, 0))); // we fill this in
+ assert(GET_SER_INFO(f->varlist, SERIES_INFO_HAS_DYNAMIC));
+ }
+ else {
+ f->varlist = Alloc_Singular_Array_Core(ARRAY_FLAG_VARLIST);
+ SET_SER_INFO(f->varlist, CONTEXT_INFO_STACK);
+ }
+
+ REBCTX *c = CTX(f->varlist);
+
+ // We do not Manage_Context, because we are reusing a word series here
+ // that has already been managed. The arglist array was managed when
+ // created and kept alive by Mark_Call_Frames
+ //
+ INIT_CTX_KEYLIST_SHARED(c, FUNC_PARAMLIST(FRM_UNDERLYING(f)));
+ ASSERT_ARRAY_MANAGED(CTX_KEYLIST(c));
+
+ // When in ET_FUNCTION or ET_LOOKBACK, the arglist will be marked safe from
+ // GC. It is managed because the pointer makes its way into bindings that
+ // ANY-WORD! values may have, and they need to not crash.
+ //
+ // !!! Note that theoretically pending mode arrays do not need GC
+ // access as no running code could get them, but the debugger is
+ // able to access this information. This is under review for how it
+ // might be stopped.
+ //
+ REBVAL *rootvar = SINK(ARR_HEAD(f->varlist));
+ VAL_RESET_HEADER(rootvar, REB_FRAME);
+ rootvar->payload.any_context.varlist = f->varlist;
+ rootvar->payload.any_context.phase = f->phase;
+ rootvar->extra.binding = f->binding;
+
+ SER(f->varlist)->misc.f = f;
+
+ // A reification of a frame for native code should not allow changing
+ // the values out from under it, because that could cause it to crash
+ // the interpreter. (Generally speaking, modification should only be
+ // possible in the debugger anyway.) For now, mark the array as
+ // running...which should not stop FRM_ARG from working in the native
+ // itself, but should stop modifications from user code.
+ //
+ if (f->flags.bits & DO_FLAG_NATIVE_HOLD)
+ SET_SER_INFO(f->varlist, SERIES_INFO_RUNNING);
+
+ MANAGE_ARRAY(f->varlist);
+
+#if !defined(NDEBUG)
+ //
+ // Variadics will reify the varlist even when the data is not quite
+ // ready; these need special handling in the GC code for marking frames.
+ // By the time the function actually runs, the data should be good.
+ //
+ if (NOT(Is_Function_Frame_Fulfilling(f)))
+ ASSERT_CONTEXT(c);
+ assert(NOT(CTX_VARS_UNAVAILABLE(c)));
+#endif
+}
diff --git a/src/core/n-control.c b/src/core/n-control.c
old mode 100644
new mode 100755
index 61e3fe0b5d..1c60886ce3
--- a/src/core/n-control.c
+++ b/src/core/n-control.c
@@ -1,774 +1,790 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: n-control.c
-** Summary: native functions for control flow
-** Section: natives
-** Author: Carl Sassenrath
-** Notes:
-** Warning: Do not cache pointer to stack ARGS (stack may expand).
-**
-***********************************************************************/
+//
+// File: %n-control.c
+// Summary: "native functions for control flow"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Control constructs in Ren-C differ from R3-Alpha in some ways:
+//
+// * If they do not run their body, they evaluate to void ("unset!") and not
+// blank ("none!"). Otherwise the last result of the body evaluation, as
+// in R3-Alpha and Rebol2...but this is forced to blank if it was void,
+// so that THEN and ELSE can distinguish whether a condition ran.
+//
+// * It is possible to ask the return result to not be "blankified", but
+// return the true value, with the /OPT refinement. This is specialized
+// as functions ending in *. (IF*, EITHER*, CASE*, SWITCH*...)
+//
+// * Other specializations exist returning a logic of whether the body ever
+// ran by using the /? refinement. So CASE? does not return the branch
+// values, just true or false based on whether a branch ran. This is
+// based on testing the result for void.
+//
+// * Zero-arity function values used as branches will be executed. Future
+// plans may allow for single-arity functions to be passed the condition,
+// see Run_Branch_Throws() for notes.
+//
+// * The /ONLY option suppresses execution of either FUNCTION! branches or
+// BLOCK! branches, instead evaluating to the raw function or block value.
+//
#include "sys-core.h"
-// Local flags used for Protect functions below:
-enum {
- PROT_SET,
- PROT_DEEP,
- PROT_HIDE,
- PROT_WORD,
-};
+//
+// if: native [
+//
+// {If TRUE? condition, return evaluation of branch value.}
+//
+// return: [ any-value!]
+// {void on FALSE?, branch result if TRUE? or BLANK! if void}
+// condition [any-value!]
+// branch [ any-value!]
+// {Evaluated if block or function and not /ONLY}
+// /only
+// "Return block and function branches instead of evaluating them"
+// /opt
+// "If branch runs and returns void, do not convert it to BLANK!"
+// ]
+//
+REBNATIVE(if)
+{
+ INCLUDE_PARAMS_OF_IF;
+
+ // Test is "safe", e.g. no literal blocks like `if [x] [...]`
+ //
+ if (IS_CONDITIONAL_TRUE_SAFE(ARG(condition))) {
+ if (Run_Branch_Throws(D_OUT, ARG(branch), REF(only)))
+ return R_OUT_IS_THROWN;
+
+ if (REF(opt))
+ return R_OUT;
+ return R_OUT_BLANK_IF_VOID;
+ }
+
+ return R_VOID;
+}
+
+
+//
+// unless: native [
+//
+// {If FALSE? condition, return evaluation of branch value.}
+//
+// return: [ any-value!]
+// {Void on FALSE?, branch result if TRUE? condition (may be void)}
+// condition [any-value!]
+// branch [ any-value!]
+// {Evaluated if block or function and not /ONLY}
+// /only
+// "Return block and function branches instead of evaluating them"
+// /opt
+// "If branch runs and returns void, do not convert it to BLANK!"
+// ]
+//
+REBNATIVE(unless)
+{
+ INCLUDE_PARAMS_OF_UNLESS;
+
+ // Test is "safe", e.g. no literal blocks like `unless [x] [...]`
+ //
+ if (NOT(IS_CONDITIONAL_TRUE_SAFE(ARG(condition)))) {
+ if (Run_Branch_Throws(D_OUT, ARG(branch), REF(only)))
+ return R_OUT_IS_THROWN;
+
+ if (REF(opt))
+ return R_OUT;
+ return R_OUT_BLANK_IF_VOID;
+ }
+
+ return R_VOID;
+}
+
+
+//
+// either: native [
+//
+// {If TRUE condition?, evaluate first branch, else evaluate second branch.}
+//
+// return: [ any-value!]
+// condition [any-value!]
+// true-branch [ any-value!]
+// false-branch [ any-value!]
+// /only
+// "Return block and function branches instead of evaluating them"
+// /opt
+// "Do not convert void branch results to BLANK!"
+// ]
+//
+REBNATIVE(either)
+{
+ INCLUDE_PARAMS_OF_EITHER;
+
+ // Test is "safe", e.g. no literal blocks like `either [x] [...] [...]`
+ //
+ if (IS_CONDITIONAL_TRUE_SAFE(ARG(condition))) {
+ if (Run_Branch_Throws(D_OUT, ARG(true_branch), REF(only)))
+ return R_OUT_IS_THROWN;
+ }
+ else {
+ if (Run_Branch_Throws(D_OUT, ARG(false_branch), REF(only)))
+ return R_OUT_IS_THROWN;
+ }
+
+ if (REF(opt))
+ return R_OUT;
+ return R_OUT_BLANK_IF_VOID;
+}
+
+
+//
+// all: native [
+//
+// {Short-circuiting variant of AND, using a block of expressions as input.}
+//
+// return: [ any-value!]
+// {Product of last evaluation if all TRUE?, else a BLANK! value.}
+// block [block!]
+// "Block of expressions. Void evaluations are ignored."
+// ]
+//
+REBNATIVE(all)
+{
+ INCLUDE_PARAMS_OF_ALL;
+
+ assert(IS_END(D_OUT)); // guaranteed by the evaluator
+
+ DECLARE_FRAME (f);
+ Push_Frame(f, ARG(block));
+
+ while (NOT_END(f->value)) {
+ if (Do_Next_In_Frame_Throws(D_CELL, f)) {
+ Drop_Frame(f);
+ Move_Value(D_OUT, D_CELL);
+ return R_OUT_IS_THROWN;
+ }
+
+ if (IS_VOID(D_CELL)) // voids do not "vote" true or false
+ continue;
+
+ if (IS_CONDITIONAL_FALSE(D_CELL)) { // a failed ALL returns BLANK!
+ Drop_Frame(f);
+ return R_BLANK;
+ }
+
+ Move_Value(D_OUT, D_CELL); // preserve (not overwritten by later voids)
+ }
+
+ Drop_Frame(f);
-
-/***********************************************************************
-**
-*/ void Protected(REBVAL *word)
-/*
-** Throw an error if word is protected.
-**
-***********************************************************************/
-{
- REBSER *frm;
- REBINT index = VAL_WORD_INDEX(word);
-
- if (index > 0) {
- frm = VAL_WORD_FRAME(word);
- if (VAL_PROTECTED(FRM_WORDS(frm)+index))
- Trap1(RE_LOCKED_WORD, word);
- }
- else if (index == 0) Trap0(RE_SELF_PROTECTED);
-}
-
-
-/***********************************************************************
-**
-*/ static void Protect_Word(REBVAL *value, REBCNT flags)
-/*
-***********************************************************************/
-{
- if (GET_FLAG(flags, PROT_WORD)) {
- if (GET_FLAG(flags, PROT_SET)) VAL_SET_OPT(value, OPTS_LOCK);
- else VAL_CLR_OPT(value, OPTS_LOCK);
- }
-
- if (GET_FLAG(flags, PROT_HIDE)) {
- if GET_FLAG(flags, PROT_SET) VAL_SET_OPT(value, OPTS_HIDE);
- else VAL_CLR_OPT(value, OPTS_HIDE);
- }
-}
-
-
-/***********************************************************************
-**
-*/ static void Protect_Value(REBVAL *value, REBCNT flags)
-/*
-** Anything that calls this must call Unmark() when done.
-**
-***********************************************************************/
-{
- if (ANY_SERIES(value) || IS_MAP(value))
- Protect_Series(value, flags);
- else if (IS_OBJECT(value) || IS_MODULE(value))
- Protect_Object(value, flags);
-}
-
-
-/***********************************************************************
-**
-*/ void Protect_Series(REBVAL *val, REBCNT flags)
-/*
-** Anything that calls this must call Unmark() when done.
-**
-***********************************************************************/
-{
- REBSER *series = VAL_SERIES(val);
-
- if (IS_MARK_SERIES(series)) return; // avoid loop
-
- if (GET_FLAG(flags, PROT_SET))
- PROTECT_SERIES(series);
- else
- UNPROTECT_SERIES(series);
-
- if (!ANY_BLOCK(val) || !GET_FLAG(flags, PROT_DEEP)) return;
-
- MARK_SERIES(series); // recursion protection
-
- for (val = VAL_BLK_DATA(val); NOT_END(val); val++) {
- Protect_Value(val, flags);
- }
-}
-
-
-/***********************************************************************
-**
-*/ void Protect_Object(REBVAL *value, REBCNT flags)
-/*
-** Anything that calls this must call Unmark() when done.
-**
-***********************************************************************/
-{
- REBSER *series = VAL_OBJ_FRAME(value);
-
- if (IS_MARK_SERIES(series)) return; // avoid loop
-
- if (GET_FLAG(flags, PROT_SET)) PROTECT_SERIES(series);
- else UNPROTECT_SERIES(series);
-
- for (value = FRM_WORDS(series)+1; NOT_END(value); value++) {
- Protect_Word(value, flags);
- }
-
- if (!GET_FLAG(flags, PROT_DEEP)) return;
-
- MARK_SERIES(series); // recursion protection
-
- for (value = FRM_VALUES(series)+1; NOT_END(value); value++) {
- Protect_Value(value, flags);
- }
-}
-
-
-/***********************************************************************
-**
-*/ static void Protect_Word_Value(REBVAL *word, REBCNT flags)
-/*
-***********************************************************************/
-{
- REBVAL *wrd;
- REBVAL *val;
-
- if (ANY_WORD(word) && HAS_FRAME(word) && VAL_WORD_INDEX(word) > 0) {
- wrd = FRM_WORDS(VAL_WORD_FRAME(word))+VAL_WORD_INDEX(word);
- Protect_Word(wrd, flags);
- if (GET_FLAG(flags, PROT_DEEP)) {
- val = Get_Var(word);
- Protect_Value(val, flags);
- Unmark(val);
- }
- }
- else if (ANY_PATH(word)) {
- REBCNT index;
- REBSER *obj;
- if (NZ(obj = Resolve_Path(word, &index))) {
- wrd = FRM_WORD(obj, index);
- Protect_Word(wrd, flags);
- if (GET_FLAG(flags, PROT_DEEP)) {
- Protect_Value(val = FRM_VALUE(obj, index), flags);
- Unmark(val);
- }
- }
- }
+ // If IS_END(out), no successes or failures found (all opt-outs)
+ //
+ return R_OUT_VOID_IF_UNWRITTEN;
}
-/***********************************************************************
-**
-*/ static int Protect(REBVAL *ds, REBCNT flags)
-/*
-** 1: value
-** 2: /deep - recursive
-** 3: /words - list of words
-** 4: /values - list of values
-** 5: /hide - hide variables
-**
-***********************************************************************/
-{
- REBVAL *val = D_ARG(1);
-
- // flags has PROT_SET bit (set or not)
-
- Check_Security(SYM_PROTECT, POL_WRITE, val);
-
- if (D_REF(2)) SET_FLAG(flags, PROT_DEEP);
- //if (D_REF(3)) SET_FLAG(flags, PROT_WORD);
-
- if (D_REF(5)) SET_FLAG(flags, PROT_HIDE);
- else SET_FLAG(flags, PROT_WORD); // there is no unhide
-
- if (IS_WORD(val) || IS_PATH(val)) {
- Protect_Word_Value(val, flags); // will unmark if deep
- return R_ARG1;
- }
-
- if (IS_BLOCK(val)) {
- if (D_REF(3)) { // /words
- for (val = VAL_BLK_DATA(val); NOT_END(val); val++)
- Protect_Word_Value(val, flags); // will unmark if deep
- return R_ARG1;
- }
- if (D_REF(4)) { // /values
- REBVAL *val2;
- for (val = VAL_BLK_DATA(val); NOT_END(val); val++) {
- Protect_Value(val2 = Get_Any_Var(val), flags);
- if (GET_FLAG(flags, PROT_DEEP)) Unmark(val2);
- }
- return R_ARG1;
- }
- }
-
- if (GET_FLAG(flags, PROT_HIDE)) Trap0(RE_BAD_REFINES);
-
- Protect_Value(val, flags);
-
- if (GET_FLAG(flags, PROT_DEEP)) Unmark(val);
-
- return R_ARG1;
-}
+//
+// any: native [
+//
+// {Short-circuiting version of OR, using a block of expressions as input.}
+//
+// return: [ any-value!]
+// {The first TRUE? evaluative result, or BLANK! value if all FALSE?}
+// block [block!]
+// "Block of expressions. Void evaluations are ignored."
+// ]
+//
+REBNATIVE(any)
+{
+ INCLUDE_PARAMS_OF_ANY;
+
+ DECLARE_FRAME (f);
+ Push_Frame(f, ARG(block));
+
+ REBOOL voted = FALSE;
+
+ while (NOT_END(f->value)) {
+ if (Do_Next_In_Frame_Throws(D_OUT, f)) {
+ Drop_Frame(f);
+ return R_OUT_IS_THROWN;
+ }
+
+ if (IS_VOID(D_OUT)) // voids do not "vote" true or false
+ continue;
+
+ if (IS_CONDITIONAL_TRUE(D_OUT)) { // successful ANY returns the value
+ Drop_Frame(f);
+ return R_OUT;
+ }
+ voted = TRUE; // signal at least one non-void result was seen
+ }
-/***********************************************************************
-**
-*/ REBNATIVE(also)
-/*
-***********************************************************************/
-{
- return R_ARG1;
-}
+ Drop_Frame(f);
+ if (voted)
+ return R_BLANK;
-/***********************************************************************
-**
-*/ REBNATIVE(all)
-/*
-***********************************************************************/
-{
- REBSER *block = VAL_SERIES(D_ARG(1));
- REBCNT index = VAL_INDEX(D_ARG(1));
-
- ds = 0;
- while (index < SERIES_TAIL(block)) {
- index = Do_Next(block, index, 0); // stack volatile
- ds = DS_POP; // volatile stack reference
- if (IS_FALSE(ds)) return R_NONE;
- if (THROWN(ds)) break;
- }
- if (ds == 0) return R_TRUE;
- return R_TOS1;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(any)
-/*
-***********************************************************************/
-{
- REBSER *block = VAL_SERIES(D_ARG(1));
- REBCNT index = VAL_INDEX(D_ARG(1));
-
- while (index < SERIES_TAIL(block)) {
- index = Do_Next(block, index, 0); // stack volatile
- ds = DS_POP; // volatile stack reference
- if (!IS_FALSE(ds) && !IS_UNSET(ds)) return R_TOS1;
- }
- return R_NONE;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(apply)
-/*
-***********************************************************************/
-{
- Apply_Block(D_ARG(1), D_ARG(2), !D_REF(3)); // stack volatile
- return R_TOS;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(attempt)
-/*
-***********************************************************************/
-{
- Try_Block(VAL_SERIES(D_ARG(1)), VAL_INDEX(D_ARG(1)));
- if (IS_ERROR(DS_NEXT) && !IS_THROW(DS_NEXT)) return R_NONE;
- return R_TOS1;
+ return R_VOID; // all opt-outs
}
-/***********************************************************************
-**
-*/ REBNATIVE(break)
-/*
-***********************************************************************/
-{
- REBVAL *value = 0;
-
- if (D_REF(1)) value = D_ARG(2); // /return
- SET_THROW(ds, RE_BREAK, value);
- return R_RET;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(case)
-/*
-***********************************************************************/
-{
- REBSER *block = VAL_SERIES(D_ARG(1));
- REBCNT index = VAL_INDEX(D_ARG(1));
- REBFLG all_flag = D_REF(2);
-
- while (index < SERIES_TAIL(block)) {
- //DSP = top; // reset stack -- not needed?
- index = Do_Next(block, index, 0);
- ds = DS_POP; // volatile stack reference
- if (IS_FALSE(ds)) index++;
- else {
- if (IS_UNSET(ds)) Trap0(RE_NO_RETURN);
- if (THROWN(ds)) return R_TOS1;
- if (index >= SERIES_TAIL(block)) return R_TRUE;
- index = Do_Next(block, index, 0);
- ds = DS_POP; // volatile stack reference
- if (IS_BLOCK(ds)) {
- ds = DO_BLK(ds);
- if (IS_UNSET(ds) && !all_flag) return R_TRUE;
- }
- if (THROWN(ds) || !all_flag || index >= SERIES_TAIL(block))
- return R_TOS1;
- }
- }
- return R_NONE;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(catch)
-/*
-***********************************************************************/
-{
- REBVAL *val;
- REBVAL *ret;
- REBCNT sym;
-
- if (D_REF(4)) { //QUIT
- if (Try_Block_Halt(VAL_SERIES(D_ARG(1)), VAL_INDEX(D_ARG(1)))) {
- // We are here because of a QUIT/HALT condition.
- ret = DS_NEXT;
- if (VAL_ERR_NUM(ret) == RE_QUIT)
- ret = VAL_ERR_VALUE(ret);
- else if (VAL_ERR_NUM(ret) == RE_HALT)
- Halt_Code(RE_HALT, 0);
- else
- Crash(RP_NO_CATCH);
- *DS_RETURN = *ret;
- return R_RET;
- }
- return R_TOS1;
- }
-
- // Evaluate the block:
- ret = DO_BLK(D_ARG(1));
-
- // If it is a throw, process it:
- if (IS_ERROR(ret) && VAL_ERR_NUM(ret) == RE_THROW) {
-
- // If a named throw, then check it:
- if (D_REF(2)) { // /name
-
- sym = VAL_ERR_SYM(ret);
- val = D_ARG(3); // name symbol
-
- // If name is the same word:
- if (IS_WORD(val) && sym == VAL_WORD_CANON(val)) goto got_err;
-
- // If it is a block of words:
- else if (IS_BLOCK(val)) {
- for (val = VAL_BLK_DATA(val); NOT_END(val); val++) {
- if (IS_WORD(val) && sym == VAL_WORD_CANON(val)) goto got_err;
- }
- }
- } else {
-got_err:
- *ds = *(VAL_ERR_VALUE(ret));
- return R_RET;
- }
- }
-
- return R_TOS1;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(throw)
-/*
-***********************************************************************/
-{
- SET_THROW(ds, RE_THROW, D_ARG(1));
- if (D_REF(2)) // /name
- VAL_ERR_SYM(ds) = VAL_WORD_SYM(D_ARG(3));
- return R_RET;
-}
-
+//
+// none: native [
+//
+// {Short circuiting version of NOR, using a block of expressions as input.}
+//
+// return: [ bar! blank!]
+// {TRUE if all expressions are FALSE?, or BLANK if any are TRUE?}
+// block [block!]
+// "Block of expressions. Void evaluations are ignored."
+// ]
+//
+REBNATIVE(none)
+//
+// !!! In order to reduce confusion and accidents in the near term, the
+// %mezz-legacy.r renames this to NONE-OF and makes NONE report an error.
+{
+ INCLUDE_PARAMS_OF_NONE;
+
+ DECLARE_FRAME (f);
+ Push_Frame(f, ARG(block));
-#ifdef not_used
-/***********************************************************************
-**
-*/ REBNATIVE(cause)
-/*
-***********************************************************************/
-{
- Throw_Error(VAL_ERR_OBJECT(D_ARG(1)));
- DEAD_END;
-}
-#endif
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(comment)
-/*
-***********************************************************************/
-{
- return R_UNSET;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(compose)
-/*
-** {Evaluates a block of expressions, only evaluating parens, and returns a block.}
-** value "Block to compose"
-** /deep "Compose nested blocks"
-** /only "Inserts a block value as a block"
-**
-***********************************************************************/
-{
- REBVAL *value = D_ARG(1);
-
- if (!IS_BLOCK(value)) return R_ARG1;
- Compose_Block(value, D_REF(2), D_REF(3), D_REF(4) ? D_ARG(5) : 0);
- return R_TOS;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(continue)
-/*
-***********************************************************************/
-{
- SET_THROW(ds, RE_CONTINUE, NONE_VALUE);
- return R_RET;
-}
-
-#ifdef removed
-/***********************************************************************
-**
-*/ REBNATIVE(disarm)
-/*
-***********************************************************************/
-{
- return R_ARG1;
-/*
- REBVAL *value = D_ARG(1);
-
- if (IS_ERROR(value)) VAL_SET(value, REB_OBJECT);
- *ds = *value;
- return R_RET;
-*/
-}
-#endif
-
-/***********************************************************************
-**
-*/ REBNATIVE(do)
-/*
-***********************************************************************/
-{
- REBVAL *value = D_ARG(1);
-
- switch (VAL_TYPE(value)) {
-
- case REB_BLOCK:
- case REB_PAREN:
- if (D_REF(4)) { // next
- VAL_INDEX(value) = Do_Next(VAL_SERIES(value), VAL_INDEX(value), 0);
- if (VAL_INDEX(value) == END_FLAG) {
- VAL_INDEX(value) = VAL_TAIL(value);
- Set_Var(D_ARG(5), value);
- return R_UNSET;
- }
- Set_Var(D_ARG(5), value); // "continuation" of block
- return R_TOS;
- }
- else DO_BLK(value);
- return R_TOS1;
-
- case REB_NATIVE:
- case REB_ACTION:
- case REB_COMMAND:
- case REB_REBCODE:
- case REB_OP:
- case REB_CLOSURE:
- case REB_FUNCTION:
- VAL_SET_OPT(value, OPTS_REVAL);
- return R_ARG1;
-
-// case REB_PATH: ? is it used?
-
- case REB_WORD:
- case REB_GET_WORD:
- *D_RET = *Get_Var(value);
- return R_RET;
-
- case REB_LIT_WORD:
- *D_RET = *value;
- SET_TYPE(D_RET, REB_WORD);
- return R_RET;
-
- case REB_ERROR:
- if (IS_THROW(value)) return R_ARG1;
- Throw_Error(VAL_ERR_OBJECT(value));
-
- case REB_BINARY:
- case REB_STRING:
- case REB_URL:
- case REB_FILE:
- // DO native and sys/do* must use same arg list:
- Do_Sys_Func(SYS_CTX_DO_P, value, D_ARG(2), D_ARG(3), D_ARG(4), D_ARG(5), 0);
- return R_TOS1;
-
- case REB_TASK:
- Do_Task(value);
- return R_ARG1;
-
- case REB_SET_WORD:
- Trap_Arg(value);
-
- default:
- return R_ARG1;
- }
-}
-
-
-#ifdef removed_b1505
-/***********************************************************************
-**
-*/ REBNATIVE(eval)
-/*
-***********************************************************************/
-{
- REBVAL *value = D_ARG(1);
-
- if (IS_BLOCK(value)) {DO_BLK(value); return R_TOS1;}
- if (IS_TASK(value)) Do_Task(value);
- return R_ARG1;
-}
-#endif
-
-/***********************************************************************
-**
-*/ REBNATIVE(either)
-/*
-***********************************************************************/
-{
- REBCNT argnum = IS_FALSE(D_ARG(1)) ? 3 : 2;
-
- if (IS_BLOCK(D_ARG(argnum)) && !D_REF(4) /* not using /ONLY */) {
- DO_BLK(D_ARG(argnum));
- return R_TOS1;
- } else {
- return argnum == 2 ? R_ARG2 : R_ARG3;
- }
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(exit)
-/*
-***********************************************************************/
-{
- SET_THROW(ds, RE_RETURN, 0);
- return R_RET;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(if)
-/*
-***********************************************************************/
-{
- if (IS_FALSE(D_ARG(1))) return R_NONE;
- if (IS_BLOCK(D_ARG(2)) && !D_REF(3) /* not using /ONLY */) {
- DO_BLK(D_ARG(2));
- return R_TOS1;
- } else {
- return R_ARG2;
- }
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(protect)
-/*
-***********************************************************************/
-{
- return Protect(ds, 1); // PROT_SET
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(unprotect)
-/*
-***********************************************************************/
-{
- SET_NONE(D_ARG(5)); // necessary, bogus, but no harm to stack
- return Protect(ds, 0);
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(reduce)
-/*
-***********************************************************************/
-{
- if (IS_BLOCK(D_ARG(1))) {
- REBSER *ser = VAL_SERIES(D_ARG(1));
- REBCNT index = VAL_INDEX(D_ARG(1));
- REBVAL *val = D_REF(5) ? D_ARG(6) : 0;
-
- if (D_REF(2))
- Reduce_Block_No_Set(ser, index, val);
- else if (D_REF(3))
- Reduce_Only(ser, index, D_ARG(4), val);
- else
- Reduce_Block(ser, index, val);
- return R_TOS;
- }
-
- return R_ARG1;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(return)
-/*
-** Returns a value from the current function. The error value
-** is built in the RETURN slot, with the arg being kept in
-** the ARG1 slot on the stack. As long as DSP is greater, both
-** values are safe from GC.
-**
-***********************************************************************/
-{
- REBVAL *arg = D_ARG(1);
-
- SET_THROW(ds, RE_RETURN, arg);
- return R_RET;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(switch)
-/*
-** value
-** cases [block!]
-** /default
-** case
-** /all {Check all cases}
-**
-***********************************************************************/
-{
- REBVAL *blk = VAL_BLK_DATA(D_ARG(2));
- REBVAL *result;
- REBOOL all = D_REF(5);
- REBOOL found = FALSE;
-
- // Find value in case block...
- for (; NOT_END(blk); blk++) {
- if (!IS_BLOCK(blk) && 0 == Cmp_Value(DS_ARG(1), blk, FALSE)) { // avoid stack move
- // Skip forward to block...
- for (; !IS_BLOCK(blk) && NOT_END(blk); blk++);
- if (IS_END(blk)) break;
- found = TRUE;
- // Evaluate the case block
- result = DO_BLK(blk);
- if (!all) return R_TOS1;
- if (THROWN(result) && Check_Error(result) >= 0) break;
- }
- }
-
- if (!found && IS_BLOCK(result = D_ARG(4))) {
- DO_BLK(result);
- return R_TOS1;
- }
-
- return R_NONE;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(try)
-/*
-***********************************************************************/
-{
- REBVAL value = *D_ARG(3); // TRY exception will trim the stack
- REBFLG except = D_REF(2);
-
- if (Try_Block(VAL_SERIES(D_ARG(1)), VAL_INDEX(D_ARG(1)))) {
- if (except) {
- if (IS_BLOCK(&value)) {
- DO_BLK(&value);
- }
- else { // do func[error] arg
- REBVAL arg = *DS_NEXT; // will get overwritten
- Apply_Func(0, &value, &arg, 0);
- }
- }
- }
-
- return R_TOS1;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(unless)
-/*
-***********************************************************************/
-{
- if (IS_FALSE(D_ARG(1))) {
- if (IS_BLOCK(D_ARG(2)) && !D_REF(3) /* not using /ONLY */) {
- DO_BLK(D_ARG(2));
- return R_TOS1;
- } else {
- return R_ARG2;
- }
- }
- return R_NONE;
+ REBOOL voted = FALSE;
+
+ while (NOT_END(f->value)) {
+ if (Do_Next_In_Frame_Throws(D_OUT, f)) {
+ Drop_Frame(f);
+ return R_OUT_IS_THROWN;
+ }
+
+ if (IS_VOID(D_OUT)) // voids do not "vote" true or false
+ continue;
+
+ if (IS_CONDITIONAL_TRUE(D_OUT)) { // any true results mean failure
+ Drop_Frame(f);
+ return R_BLANK;
+ }
+
+ voted = TRUE; // signal that at least one non-void result was seen
+ }
+
+ Drop_Frame(f);
+
+ if (voted)
+ return R_BAR;
+
+ return R_VOID; // all opt-outs
+}
+
+
+//
+// case: native [
+//
+// {Evaluates each condition, and when true, evaluates what follows it.}
+//
+// return: [ any-value!]
+// {Last matched case evaluation, or void if no cases matched}
+// cases [block!]
+// "Block of cases (conditions followed by branches)"
+// /all
+// {Evaluate all cases (do not stop at first TRUE? case)}
+// /only
+// "Return block and function branches instead of evaluating them"
+// /opt
+// "If branch runs and returns void, do not convert it to BLANK!"
+// ]
+//
+REBNATIVE(case)
+{
+ INCLUDE_PARAMS_OF_CASE; // ? is renamed as "q"
+
+ DECLARE_FRAME (f);
+ Push_Frame(f, ARG(cases));
+
+ // With the block argument pushed in the enumerator, that frame slot is
+ // available for scratch space in the rest of the routine.
+
+ while (NOT_END(f->value)) {
+ if (IS_BAR(f->value)) { // interstitial BAR! legal, `case [1 2 | 3 4]`
+ Fetch_Next_In_Frame(f);
+ continue;
+ }
+
+ // Perform a DO/NEXT's worth of evaluation on a "condition" to test
+
+ if (Do_Next_In_Frame_Throws(D_CELL, f)) {
+ Move_Value(D_OUT, D_CELL);
+ goto return_thrown;
+ }
+
+ if (IS_VOID(D_CELL)) // no void conditions allowed (as with IF)
+ fail (Error_No_Return_Raw());
+
+ if (IS_END(f->value)) // require conditions and branches in pairs
+ fail (Error_Past_End_Raw());
+
+ if (IS_BAR(f->value)) // BAR! out of sync between condition and branch
+ fail (Error_Bar_Hit_Mid_Case_Raw());
+
+ // Regardless of whether a "condition" was true or false, it's
+ // necessary to evaluate the next "branch" to know how far to skip:
+ //
+ // condition: true
+ // case [condition 10 + 20 true {hello}] ;-- returns 30
+ //
+ // condition: false
+ // case [condition 10 + 20 true {hello}] ;-- returns {hello}
+ //
+ // This uses the safe form, so you can't say `case [[x] [y]]` because
+ // the [x] condition is a literal block. However you can say
+ // `foo: [x] | case [foo [y]]`, since it is evaluated, or use a
+ // GROUP! as in `case [([x]) [y]]`.
+ //
+ if (NOT(IS_CONDITIONAL_TRUE_SAFE(D_CELL))) {
+ if (Do_Next_In_Frame_Throws(D_CELL, f)) {
+ Move_Value(D_OUT, D_CELL);
+ goto return_thrown;
+ }
+
+ continue;
+ }
+
+ // When the condition is TRUE?, CASE actually does a double evaluation
+ // if a block is yielded as the branch:
+ //
+ // stuff: [print "This will be printed"]
+ // case [true stuff]
+ //
+ // Similar to IF TRUE STUFF, so CASE can act like many IFs at once.
+
+ if (Do_Next_In_Frame_Throws(D_CELL, f)) {
+ Move_Value(D_OUT, D_CELL);
+ goto return_thrown;
+ }
+
+ // !!! Optimization note: if the previous evaluation had gone into
+ // D_OUT directly it could just stay there in some cases; and even
+ // block evaluation doesn't need the copy. Review how this shared
+ // code might get more efficient if the data were already in D_OUT.
+ //
+ if (Run_Branch_Throws(D_OUT, D_CELL, REF(only)))
+ goto return_thrown;
+
+ if (NOT(REF(all)))
+ goto return_matched;
+
+ // keep matching if /ALL
+ }
+
+ goto return_maybe_matched;
+
+return_maybe_matched: // CASE/ALL can get here even if D_OUT not written
+ Drop_Frame(f);
+ if (REF(opt))
+ return R_OUT_VOID_IF_UNWRITTEN; // user wants voids as-is
+ return R_OUT_VOID_IF_UNWRITTEN_BLANK_IF_VOID;
+
+return_matched:
+ Drop_Frame(f);
+ if (REF(opt))
+ return R_OUT; // user wants voids as-is
+ return R_OUT_BLANK_IF_VOID;
+
+return_thrown:
+ Drop_Frame(f);
+ return R_OUT_IS_THROWN;
+}
+
+
+//
+// switch: native [
+//
+// {Selects a choice and evaluates the block that follows it.}
+//
+// return: [ any-value!]
+// {Last case evaluation, or void if no cases matched}
+// value [any-value!]
+// "Target value"
+// cases [block!]
+// "Block of cases (comparison lists followed by block branches)"
+// /default
+// "Default case if no others found"
+// default-case
+// "Block to execute (or value to return)"
+// /all
+// "Evaluate all matches (not just first one)"
+// /strict
+// {Use STRICT-EQUAL? when comparing cases instead of EQUAL?}
+// /opt
+// "If branch runs and returns void, do not convert it to BLANK!"
+// ]
+//
+REBNATIVE(switch)
+{
+ INCLUDE_PARAMS_OF_SWITCH; // ? is renamed as "q"
+
+ DECLARE_FRAME (f);
+ Push_Frame(f, ARG(cases));
+
+ // The evaluator always initializes the out slot to an END marker. That
+ // makes sure it gets overwritten with a value (or void) before returning.
+ // But here SWITCH also lets END indicate no matching cases ran yet.
+
+ assert(IS_END(D_OUT));
+
+ REBVAL *value = ARG(value);
+
+ // For safety, notice if someone wrote `switch [x] [...]` with a literal
+ // block in source, as that is likely a mistake.
+ //
+ if (IS_BLOCK(value) && GET_VAL_FLAG(value, VALUE_FLAG_UNEVALUATED))
+ fail (Error_Block_Switch_Raw(value));
+
+ // Frame's extra D_CELL is free since the function has > 1 arg. Reuse it
+ // as a temporary GC-safe location for holding evaluations. This
+ // holds the last test so that `switch 9 [1 ["a"] 2 ["b"] "c"]` is "c".
+
+ Init_Void(D_CELL); // used for "fallout"
+
+ while (NOT_END(f->value)) {
+
+ // If a block is seen at this point, it doesn't correspond to any
+ // condition to match. If no more tests are run, let it suppress the
+ // feature of the last value "falling out" the bottom of the switch
+
+ if (IS_BLOCK(f->value)) {
+ Init_Void(D_CELL);
+ goto continue_loop;
+ }
+
+ // GROUP!, GET-WORD! and GET-PATH! are evaluated in Ren-C's SWITCH
+ // All other types are seen as-is (hence words act "quoted")
+
+ if (
+ IS_GROUP(f->value)
+ || IS_GET_WORD(f->value)
+ || IS_GET_PATH(f->value)
+ ){
+ if (Eval_Value_Core_Throws(D_CELL, f->value, f->specifier)) {
+ Move_Value(D_OUT, D_CELL);
+ goto return_thrown;
+ }
+ }
+ else
+ Derelativize(D_CELL, f->value, f->specifier);
+
+ // It's okay that we are letting the comparison change `value`
+ // here, because equality is supposed to be transitive. So if it
+ // changes 0.01 to 1% in order to compare it, anything 0.01 would
+ // have compared equal to so will 1%. (That's the idea, anyway,
+ // required for `a = b` and `b = c` to properly imply `a = c`.)
+ //
+ // !!! This means fallout can be modified from its intent. Rather
+ // than copy here, this is a reminder to review the mechanism by
+ // which equality is determined--and why it has to mutate.
+
+ if (!Compare_Modify_Values(ARG(value), D_CELL, REF(strict) ? 1 : 0))
+ goto continue_loop;
+
+ // Skip ahead to try and find a block, to treat as code for the match
+
+ do {
+ Fetch_Next_In_Frame(f);
+ if (IS_END(f->value))
+ goto return_defaulted;
+ } while (!IS_BLOCK(f->value));
+
+ // Run the code if it was found. Because it writes D_OUT with a value
+ // (or void), it won't be END--so we'll know at least one case has run.
+
+ REBSPC *derived; // goto would cross initialization
+ derived = Derive_Specifier(VAL_SPECIFIER(ARG(cases)), f->value);
+ if (Do_At_Throws(
+ D_OUT,
+ VAL_ARRAY(f->value),
+ VAL_INDEX(f->value),
+ derived
+ )) {
+ goto return_thrown;
+ }
+
+ // Only keep processing if the /ALL refinement was specified
+
+ if (NOT(REF(all)))
+ goto return_matched;
+
+ continue_loop:
+ Fetch_Next_In_Frame(f);
+ }
+
+ if (NOT_END(D_OUT)) // at least one case body's DO ran and overwrote D_OUT
+ goto return_matched;
+
+return_defaulted:
+ Drop_Frame(f);
+
+ if (REF(default)) {
+ const REBOOL only = FALSE; // !!! Should it use REF(only)?
+
+ if (Run_Branch_Throws(D_OUT, ARG(default_case), only))
+ goto return_thrown;
+
+ if (REF(opt))
+ return R_OUT;
+ return R_OUT_BLANK_IF_VOID;
+ }
+
+ Move_Value(D_OUT, D_CELL); // last test "falls out", might be void
+ return R_OUT;
+
+return_matched:
+ Drop_Frame(f);
+
+ if (REF(opt))
+ return R_OUT;
+ return R_OUT_BLANK_IF_VOID;
+
+return_thrown:
+ Drop_Frame(f);
+ return R_OUT_IS_THROWN;
+}
+
+
+//
+// catch: native [
+//
+// {Catches a throw from a block and returns its value.}
+//
+// return: [ any-value!]
+// block [block!] "Block to evaluate"
+// /name
+// "Catches a named throw" ;-- should it be called /named ?
+// names [block! word! function! object!]
+// "Names to catch (single name if not block)"
+// /quit
+// "Special catch for QUIT native"
+// /any
+// {Catch all throws except QUIT (can be used with /QUIT)}
+// /with
+// "Handle thrown case with code"
+// handler [block! function!]
+// "If FUNCTION!, spec matches [value name]"
+// /?
+// "Instead of result or catch, return LOGIC! of if a catch occurred"
+// ]
+//
+REBNATIVE(catch)
+//
+// There's a refinement for catching quits, and CATCH/ANY will not alone catch
+// it (you have to CATCH/ANY/QUIT). Currently the label for quitting is the
+// NATIVE! function value for QUIT.
+{
+ INCLUDE_PARAMS_OF_CATCH; // ? is renamed as "q"
+
+ // /ANY would override /NAME, so point out the potential confusion
+ //
+ if (REF(any) && REF(name))
+ fail (Error_Bad_Refines_Raw());
+
+ if (Do_Any_Array_At_Throws(D_OUT, ARG(block))) {
+ if (
+ (
+ REF(any)
+ && (!IS_FUNCTION(D_OUT) || VAL_FUNC_DISPATCHER(D_OUT) != &N_quit)
+ )
+ || (
+ REF(quit)
+ && (IS_FUNCTION(D_OUT) && VAL_FUNC_DISPATCHER(D_OUT) == &N_quit)
+ )
+ ) {
+ goto was_caught;
+ }
+
+ if (REF(name)) {
+ //
+ // We use equal? by way of Compare_Modify_Values, and re-use the
+ // refinement slots for the mutable space
+
+ REBVAL *temp1 = ARG(quit);
+ REBVAL *temp2 = ARG(any);
+
+ // !!! The reason we're copying isn't so the VALUE_FLAG_THROWN bit
+ // won't confuse the equality comparison...but would it have?
+
+ if (IS_BLOCK(ARG(names))) {
+ //
+ // Test all the words in the block for a match to catch
+
+ RELVAL *candidate = VAL_ARRAY_AT(ARG(names));
+ for (; NOT_END(candidate); candidate++) {
+ //
+ // !!! Should we test a typeset for illegal name types?
+ //
+ if (IS_BLOCK(candidate))
+ fail (ARG(names));
+
+ Derelativize(temp1, candidate, VAL_SPECIFIER(ARG(names)));
+ Move_Value(temp2, D_OUT);
+
+ // Return the THROW/NAME's arg if the names match
+ // !!! 0 means equal?, but strict-equal? might be better
+ //
+ if (Compare_Modify_Values(temp1, temp2, 0))
+ goto was_caught;
+ }
+ }
+ else {
+ Move_Value(temp1, ARG(names));
+ Move_Value(temp2, D_OUT);
+
+ // Return the THROW/NAME's arg if the names match
+ // !!! 0 means equal?, but strict-equal? might be better
+ //
+ if (Compare_Modify_Values(temp1, temp2, 0))
+ goto was_caught;
+ }
+ }
+ else {
+ // Return THROW's arg only if it did not have a /NAME supplied
+ //
+ if (IS_BLANK(D_OUT))
+ goto was_caught;
+ }
+
+ // Throw name is in D_OUT, thrown value is held task local
+ //
+ return R_OUT_IS_THROWN;
+ }
+
+ if (REF(q)) return R_FALSE;
+
+ return R_OUT;
+
+was_caught:
+ if (REF(with)) {
+ REBVAL *handler = ARG(handler);
+
+ // We again re-use the refinement slots, but this time as mutable
+ // space protected from GC for the handler's arguments
+ //
+ REBVAL *thrown_arg = ARG(any);
+ REBVAL *thrown_name = ARG(quit);
+
+ CATCH_THROWN(thrown_arg, D_OUT);
+ Move_Value(thrown_name, D_OUT); // THROWN bit cleared by CATCH_THROWN
+
+ if (IS_BLOCK(handler)) {
+ //
+ // There's no way to pass args to a block (so just DO it)
+ //
+ if (Do_Any_Array_At_Throws(D_OUT, ARG(handler)))
+ return R_OUT_IS_THROWN;
+
+ if (REF(q)) return R_TRUE;
+
+ return R_OUT;
+ }
+ else if (IS_FUNCTION(handler)) {
+ //
+ // This calls the function but only does a DO/NEXT. Hence the
+ // function might be arity 0, arity 1, or arity 2. If it has
+ // greater arity it will process more arguments.
+ //
+ if (Apply_Only_Throws(
+ D_OUT,
+ FALSE, // do not alert if handler doesn't consume all args
+ handler,
+ thrown_arg,
+ thrown_name,
+ END
+ )){
+ return R_OUT_IS_THROWN;
+ }
+
+ if (REF(q)) return R_TRUE;
+
+ return R_OUT;
+ }
+ }
+
+ // If no handler, just return the caught thing
+ //
+ CATCH_THROWN(D_OUT, D_OUT);
+
+ if (REF(q)) return R_TRUE;
+
+ return R_OUT;
+}
+
+
+//
+// throw: native [
+//
+// "Throws control back to a previous catch."
+//
+// value [ any-value!]
+// "Value returned from catch"
+// /name
+// "Throws to a named catch"
+// name-value [word! function! object!]
+// ]
+//
+REBNATIVE(throw)
+//
+// Choices are currently limited for what one can use as a "name" of a THROW.
+// Note blocks as names would conflict with the `name_list` feature in CATCH.
+//
+// !!! Should parameters be /NAMED and NAME ?
+{
+ INCLUDE_PARAMS_OF_THROW;
+
+ REBVAL *value = ARG(value);
+
+ if (IS_ERROR(value)) {
+ //
+ // We raise an alert from within the implementation of throw for
+ // trying to use it to trigger errors, because if THROW just didn't
+ // take errors in the spec it wouldn't guide what *to* use.
+ //
+ fail (Error_Use_Fail_For_Error_Raw(value));
+
+ // Note: Caller can put the ERROR! in a block or use some other
+ // such trick if it wants to actually throw an error.
+ // (Better than complicating via THROW/ERROR-IS-INTENTIONAL!)
+ }
+
+ if (REF(name))
+ Move_Value(D_OUT, ARG(name_value));
+ else {
+ // Blank values serve as representative of THROWN() means "no name"
+ //
+ Init_Blank(D_OUT);
+ }
+
+ CONVERT_NAME_TO_THROWN(D_OUT, value);
+ return R_OUT_IS_THROWN;
}
diff --git a/src/core/n-data.c b/src/core/n-data.c
old mode 100644
new mode 100755
index 4463705930..032e241d81
--- a/src/core/n-data.c
+++ b/src/core/n-data.c
@@ -1,1073 +1,1462 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: n-data.c
-** Summary: native functions for data and context
-** Section: natives
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %n-data.c
+// Summary: "native functions for data and context"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#ifdef REMOVED
-// Removed because it causes more trouble than the benefits it provides.
-/***********************************************************************
-**
-*/ REBNATIVE(alias)
-/*
-***********************************************************************/
+
+static REBOOL Check_Char_Range(REBVAL *val, REBINT limit)
{
- REBVAL *word = D_ARG(1); // word to alias
- REBVAL *alias = D_ARG(2); // new string (word does not work due to RESOLVE)
- REBCNT sym;
- REBVAL *wrd;
-
- // Make new word or use existing word:
-// if (IS_STRING(alias)) {
- REBYTE *bp;
- bp = Qualify_String(alias, 255, &sym, TRUE); // sym = len
- sym = Scan_Word(bp, sym);
-// }
-// else
-// sym = VAL_WORD_SYM(alias);
-
- // Word cannot already be used:
- wrd = BLK_SKIP(PG_Word_Table.series, sym);
- if (sym != VAL_SYM_CANON(wrd)) Trap1(RE_ALREADY_USED, alias);
-
- // Change the new word's canon pointer to the word provided:
- VAL_SYM_CANON(wrd) = VAL_WORD_CANON(word);
- VAL_SYM_ALIAS(wrd) = 0;
-
- // Return new word with prior word's same bindings:
- VAL_WORD_SYM(word) = sym;
- return R_ARG1;
+ if (IS_CHAR(val)) {
+ if (VAL_CHAR(val) > limit) return FALSE;
+ return TRUE;
+ }
+
+ if (IS_INTEGER(val)) {
+ if (VAL_INT64(val) > limit) return FALSE;
+ return TRUE;
+ }
+
+ REBCNT len = VAL_LEN_AT(val);
+ if (VAL_BYTE_SIZE(val)) {
+ REBYTE *bp = VAL_BIN_AT(val);
+ if (limit == 0xff) return TRUE; // by definition
+ for (; len > 0; len--, bp++)
+ if (*bp > limit) return FALSE;
+ }
+ else {
+ REBUNI *up = VAL_UNI_AT(val);
+ for (; len > 0; len--, up++)
+ if (*up > limit) return FALSE;
+ }
+
+ return TRUE;
}
-#endif
-static int Check_Char_Range(REBVAL *val, REBINT limit)
+
+//
+// ascii?: native [
+//
+// {Returns TRUE if value or string is in ASCII character range (below 128).}
+//
+// value [any-string! char! integer!]
+// ]
+//
+REBNATIVE(ascii_q)
{
- REBCNT len;
-
- if (IS_CHAR(val)) {
- if (VAL_CHAR(val) > limit) return R_FALSE;
- return R_TRUE;
- }
-
- if (IS_INTEGER(val)) {
- if (VAL_INT64(val) > limit) return R_FALSE;
- return R_TRUE;
- }
-
- len = VAL_LEN(val);
- if (VAL_BYTE_SIZE(val)) {
- REBYTE *bp = VAL_BIN_DATA(val);
- if (limit == 0xff) return R_TRUE; // by definition
- for (; len > 0; len--, bp++)
- if (*bp > limit) return R_FALSE;
- } else {
- REBUNI *up = VAL_UNI_DATA(val);
- for (; len > 0; len--, up++)
- if (*up > limit) return R_FALSE;
- }
-
- return R_TRUE;
+ INCLUDE_PARAMS_OF_ASCII_Q;
+
+ return R_FROM_BOOL(Check_Char_Range(ARG(value), 0x7f));
}
-/***********************************************************************
-**
-*/ REBNATIVE(asciiq)
-/*
-***********************************************************************/
+//
+// latin1?: native [
+//
+// {Returns TRUE if value or string is in Latin-1 character range (below 256).}
+//
+// value [any-string! char! integer!]
+// ]
+//
+REBNATIVE(latin1_q)
{
- return Check_Char_Range(D_ARG(1), 0x7f);
+ INCLUDE_PARAMS_OF_LATIN1_Q;
+
+ return R_FROM_BOOL(Check_Char_Range(ARG(value), 0xff));
}
-/***********************************************************************
-**
-*/ REBNATIVE(latin1q)
-/*
-***********************************************************************/
+//
+// verify: native [
+//
+// {Ensure conditions are TRUE?, even when not debugging (see also: ASSERT)}
+//
+// return: []
+// conditions [logic! block!]
+// {Block of conditions to evaluate, void and FALSE? trigger alerts}
+// ]
+//
+REBNATIVE(verify)
{
- return Check_Char_Range(D_ARG(1), 0xff);
+ INCLUDE_PARAMS_OF_VERIFY;
+
+ if (IS_LOGIC(ARG(conditions))) {
+ if (VAL_LOGIC(ARG(conditions)))
+ return R_VOID;
+
+ fail (Error_Verify_Failed_Raw(FALSE_VALUE));
+ }
+
+ DECLARE_FRAME (f);
+ Push_Frame(f, ARG(conditions));
+
+ DECLARE_LOCAL (temp);
+
+ while (NOT_END(f->value)) {
+ const RELVAL *start = f->value;
+ if (Do_Next_In_Frame_Throws(D_OUT, f)) {
+ Drop_Frame(f);
+ return R_OUT_IS_THROWN;
+ }
+
+ if (!IS_VOID(D_OUT) && IS_CONDITIONAL_TRUE(D_OUT))
+ continue;
+
+ Init_Block(
+ temp,
+ Copy_Values_Len_Shallow(start, f->specifier, f->value - start)
+ );
+
+ if (IS_VOID(D_OUT))
+ fail (Error_Verify_Void_Raw(temp));
+
+ fail (Error_Verify_Failed_Raw(temp));
+ }
+
+ Drop_Frame(f);
+ return R_VOID;
}
-/***********************************************************************
-**
-*/ static REBOOL Is_Of_Type(REBVAL *value, REBVAL *types)
-/*
-** Types can be: word or block. Each element must be either
-** a datatype or a typeset.
-**
-***********************************************************************/
-{
- REBVAL *val;
-
- val = IS_WORD(types) ? Get_Var(types) : types;
-
- if (IS_DATATYPE(val)) {
- return (VAL_DATATYPE(val) == (REBINT)VAL_TYPE(value));
- }
-
- if (IS_TYPESET(val)) {
- return (TYPE_CHECK(val, VAL_TYPE(value)));
- }
-
- if (IS_BLOCK(val)) {
- for (types = VAL_BLK_DATA(val); NOT_END(types); types++) {
- val = IS_WORD(types) ? Get_Var(types) : types;
- if (IS_DATATYPE(val))
- if (VAL_DATATYPE(val) == (REBINT)VAL_TYPE(value)) return TRUE;
- else if (IS_TYPESET(val))
- if (TYPE_CHECK(val, VAL_TYPE(value))) return TRUE;
- else
- Trap1(RE_INVALID_TYPE, Of_Type(val));
- }
- return FALSE;
- }
-
- Trap_Arg(types);
-
- return 0; // for compiler
+// Test used iteratively by MAYBE native. Returns R_BLANK if the test fails,
+// R_OUT if success, or R_OUT_IS_THROWN if a test throws.
+//
+inline static REB_R Do_Test_For_Maybe(
+ REBVAL *out,
+ const REBVAL *value,
+ const RELVAL *test
+) {
+ if (IS_DATATYPE(test)) {
+ if (VAL_TYPE_KIND(test) != VAL_TYPE(value))
+ return R_BLANK;
+ Move_Value(out, value);
+ return R_OUT;
+ }
+
+ if (IS_TYPESET(test)) {
+ if (!TYPE_CHECK(test, VAL_TYPE(value)))
+ return R_BLANK;
+ Move_Value(out, value);
+ return R_OUT;
+ }
+
+ if (IS_FUNCTION(test)) {
+ if (Apply_Only_Throws(out, TRUE, const_KNOWN(test), value, END))
+ return R_OUT_IS_THROWN;
+
+ if (IS_VOID(out))
+ fail (Error_No_Return_Raw());
+
+ if (IS_CONDITIONAL_FALSE(out))
+ return R_BLANK;
+
+ Move_Value(out, value);
+ return R_OUT;
+ }
+
+ fail (Error_Invalid_Type(VAL_TYPE(test)));
}
-/***********************************************************************
-**
-*/ REBNATIVE(assert)
-/*
-***********************************************************************/
+//
+// maybe: native [
+//
+// {Check value using tests (match types, TRUE? or FALSE?, filter function)}
+//
+// return: [ any-value!]
+// {The input value or BLANK! if no match, void if FALSE? and matched}
+// test [function! datatype! typeset! block! logic!]
+// value [ any-value!]
+// /?
+// "Return LOGIC! of match vs. pass-through of value or blank"
+// ]
+//
+REBNATIVE(maybe)
{
- REBVAL *value = D_ARG(1); // block, logic, or none
-
- if (!D_REF(2)) {
- REBSER *block = VAL_SERIES(value);
- REBCNT index = VAL_INDEX(value);
- REBCNT i;
-
- ds = 0;
- while (index < SERIES_TAIL(block)) {
- index = Do_Next(block, i = index, 0); // stack volatile
- ds = DS_POP; // volatile stack reference
- if (IS_FALSE(ds)) {
- Set_Block(ds, Copy_Block_Len(block, i, 3));
- Trap1(RE_ASSERT_FAILED, ds);
- }
- if (THROWN(ds)) return R_TOS1;
- }
- }
- else {
- // /types [var1 integer! var2 [integer! decimal!]]
- REBVAL *val;
- REBVAL *type;
-
- for (value = VAL_BLK_DATA(value); NOT_END(value); value += 2) {
- if (IS_WORD(value)) {
- val = Get_Var(value);
- }
- else if (IS_PATH(value)) {
- val = value;
- Do_Path(&val, 0);
- val = DS_POP; // volatile stack reference
- }
- else Trap_Arg(value);
-
- type = value+1;
- if (IS_END(type)) Trap0(RE_MISSING_ARG);
- if (IS_BLOCK(type) || IS_WORD(type) || IS_TYPESET(type) || IS_DATATYPE(type)) {
- if (!Is_Of_Type(val, type))
- Trap1(RE_WRONG_TYPE, value);
- }
- else Trap_Arg(type);
- }
- }
-
- return R_TRUE;
+ INCLUDE_PARAMS_OF_MAYBE; // ? is renamed as "q"
+
+ REBVAL *test = ARG(test);
+ REBVAL *value = ARG(value);
+
+ if (IS_LOGIC(test)) {
+ if (!IS_VOID(value) && VAL_LOGIC(test) == IS_CONDITIONAL_TRUE(value))
+ goto type_matched;
+ return REF(q) ? R_FALSE : R_BLANK;
+ }
+
+ REB_R r;
+ if (IS_BLOCK(test)) {
+ //
+ // !!! What should the behavior for `MAYBE [] ...` be? Should that be
+ // an error? People wouldn't write it literally, but could wind up
+ // with an empty array as the product of a COMPOSE or something.
+ // Consider it ambiguous for now and give back void...
+ //
+ r = R_VOID;
+
+ const RELVAL *item;
+ for (item = VAL_ARRAY_AT(test); NOT_END(item); ++item) {
+ r = Do_Test_For_Maybe(
+ D_OUT,
+ value,
+ IS_WORD(item)
+ ? Get_Opt_Var_May_Fail(item, VAL_SPECIFIER(test))
+ : item
+ );
+
+ if (r != R_BLANK)
+ goto type_matched;
+ }
+ }
+ else
+ r = Do_Test_For_Maybe(D_OUT, value, test);
+
+ if (r == R_OUT_IS_THROWN)
+ return r;
+
+ if (REF(q))
+ return r == R_BLANK ? R_FALSE : R_TRUE;
+
+ if (r == R_BLANK)
+ return r;
+
+ assert(r == R_OUT); // must have matched!
+
+type_matched:
+ if (REF(q))
+ return R_TRUE;
+
+ // Because there may be usages like `if maybe logic! x [print "logic!"]`,
+ // it would be bad to take in a FALSE and pass back a FALSE. This is
+ // why /? (and its specialization MAYBE?) exist, but to help avoid
+ // likely mistakes this returns a void.
+ //
+ if (IS_CONDITIONAL_FALSE(value))
+ return R_VOID;
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(as_pair)
-/*
-***********************************************************************/
+//
+// as-pair: native [
+//
+// "Combine X and Y values into a pair."
+//
+// x [any-number!]
+// y [any-number!]
+// ]
+//
+REBNATIVE(as_pair)
{
- REBVAL *val = D_ARG(1);
-
- VAL_SET(D_RET, REB_PAIR);
-
- if (IS_INTEGER(val)) {
- VAL_PAIR_X(D_RET) = (REBD32)VAL_INT64(val);
- }
- else {
- VAL_PAIR_X(D_RET) = (REBD32)VAL_DECIMAL(val);
- }
-
- val = D_ARG(2);
- if (IS_INTEGER(val)) {
- VAL_PAIR_Y(D_RET) = (REBD32)VAL_INT64(val);
- }
- else {
- VAL_PAIR_Y(D_RET) = (REBD32)VAL_DECIMAL(val);
- }
-
- return R_RET;
+ INCLUDE_PARAMS_OF_AS_PAIR;
+
+ REBVAL *x = ARG(x);
+ REBVAL *y = ARG(y);
+
+ SET_PAIR(
+ D_OUT,
+ IS_INTEGER(x) ? VAL_INT64(x) : VAL_DECIMAL(x),
+ IS_INTEGER(y) ? VAL_INT64(y) : VAL_DECIMAL(y)
+ );
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(bind)
-/*
-** 1 words
-** 2 context | word
-** 3 /copy
-** 4 /only
-** 5 /new
-** 6 /set
-**
-***********************************************************************/
+//
+// bind: native [
+//
+// "Binds words or words in arrays to the specified context."
+//
+// value [any-array! any-word!]
+// "A word or array (modified) (returned)"
+// target [any-word! any-context!]
+// "The target context or a word whose binding should be the target"
+// /copy
+// "Bind and return a deep copy of a block, don't modify original"
+// /only
+// "Bind only first block (not deep)"
+// /new
+// "Add to context any new words found"
+// /set
+// "Add to context any new set-words found"
+// ]
+//
+REBNATIVE(bind)
{
- REBVAL *arg;
- REBSER *blk;
- REBSER *frame;
- REBCNT flags;
- REBFLG rel = FALSE;
-
- flags = D_REF(4) ? 0 : BIND_DEEP;
- if (D_REF(5)) flags |= BIND_ALL;
- if (D_REF(6)) flags |= BIND_SET;
-
- // Get context from a word, object (or port);
- arg = D_ARG(2);
- if (IS_OBJECT(arg) || IS_MODULE(arg) || IS_PORT(arg))
- frame = VAL_OBJ_FRAME(arg);
- else { // word
- rel = (VAL_WORD_INDEX(arg) < 0);
- frame = VAL_WORD_FRAME(arg);
- if (!frame) Trap1(RE_NOT_DEFINED, arg);
- }
-
- // Block or word to bind:
- arg = D_ARG(1);
-
- // Bind single word:
- if (ANY_WORD(arg)) {
- if (rel) {
- Bind_Stack_Word(frame, arg);
- return R_ARG1;
- }
- if (!Bind_Word(frame, arg)) {
- if (flags & BIND_ALL)
- Append_Frame(frame, arg, 0); // not in context, so add it.
- else
- Trap1(RE_NOT_IN_CONTEXT, arg);
- }
- return R_ARG1;
- }
-
- // Copy block if necessary (/copy):
- blk = D_REF(3) ? Clone_Block_Value(arg) : VAL_SERIES(arg);
-// if (D_REF(3)) blk = Copy_Block_Deep(blk, VAL_INDEX(arg), VAL_TAIL(arg), COPY_DEEP);
- Set_Block_Index(D_RET, blk, D_REF(3) ? 0 : VAL_INDEX(arg));
-
- if (rel)
- Bind_Stack_Block(frame, blk); //!! needs deep
- else
- Bind_Block(frame, BLK_HEAD(blk), flags);
-
- return R_RET;
+ INCLUDE_PARAMS_OF_BIND;
+
+ REBVAL *value = ARG(value);
+ REBVAL *target = ARG(target);
+
+ REBCTX *context;
+
+ REBARR *array;
+ REBCNT flags = REF(only) ? BIND_0 : BIND_DEEP;
+
+ REBU64 bind_types = TS_ANY_WORD;
+
+ REBU64 add_midstream_types;
+ if (REF(new)) {
+ add_midstream_types = TS_ANY_WORD;
+ }
+ else if (REF(set)) {
+ add_midstream_types = FLAGIT_KIND(REB_SET_WORD);
+ }
+ else
+ add_midstream_types = 0;
+
+ if (ANY_CONTEXT(target)) {
+ //
+ // Get target from an OBJECT!, ERROR!, PORT!, MODULE!, FRAME!
+ //
+ context = VAL_CONTEXT(target);
+ }
+ else {
+ //
+ // Extract target from whatever word we were given
+ //
+ assert(ANY_WORD(target));
+ if (IS_WORD_UNBOUND(target))
+ fail (Error_Not_Bound_Raw(target));
+
+ // The word in hand may be a relatively bound one. To return a
+ // specific frame, this needs to ensure that the Reb_Frame's data
+ // is a real context, not just a chunk of data.
+ //
+ context = VAL_WORD_CONTEXT(target);
+ }
+
+ if (ANY_WORD(value)) {
+ //
+ // Bind a single word
+
+ if (Try_Bind_Word(context, value)) {
+ Move_Value(D_OUT, value);
+ return R_OUT;
+ }
+
+ // not in context, bind/new means add it if it's not.
+ //
+ if (REF(new) || (IS_SET_WORD(value) && REF(set))) {
+ Append_Context(context, value, NULL);
+ Move_Value(D_OUT, value);
+ return R_OUT;
+ }
+
+ fail (Error_Not_In_Context_Raw(ARG(value)));
+ }
+
+ // Copy block if necessary (/copy)
+ //
+ // !!! NOTE THIS IS IGNORING THE INDEX! If you ask to bind, it should
+ // bind forward only from the index you specified, leaving anything
+ // ahead of that point alone. Not changing it now when finding it
+ // because there could be code that depends on the existing (mis)behavior
+ // but it should be followed up on.
+ //
+ Move_Value(D_OUT, value);
+ if (REF(copy)) {
+ array = Copy_Array_At_Deep_Managed(
+ VAL_ARRAY(value), VAL_INDEX(value), VAL_SPECIFIER(value)
+ );
+ INIT_VAL_ARRAY(D_OUT, array); // warning: macro copies args
+ }
+ else
+ array = VAL_ARRAY(value);
+
+ Bind_Values_Core(
+ ARR_HEAD(array),
+ context,
+ bind_types,
+ add_midstream_types,
+ flags
+ );
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(boundq)
-/*
-***********************************************************************/
+//
+// context-of: native [
+//
+// "Returns the context in which a word is bound."
+//
+// word [any-word!]
+// ]
+//
+REBNATIVE(context_of)
{
- REBVAL *word = D_ARG(1);
+ INCLUDE_PARAMS_OF_CONTEXT_OF;
+
+ if (IS_WORD_UNBOUND(ARG(word))) return R_BLANK;
+
+ // Requesting the context of a word that is relatively bound may result
+ // in that word having a FRAME! incarnated as a REBSER node (if it
+ // was not already reified.)
+ //
+ // !!! Mechanically it is likely that in the future, all FRAME!s for
+ // user functions will be reified from the moment of invocation.
+ //
+ Move_Value(D_OUT, CTX_VALUE(VAL_WORD_CONTEXT(ARG(word))));
- if (!HAS_FRAME(word)) return R_NONE;
- if (VAL_WORD_INDEX(word) < 0) return R_TRUE;
- SET_OBJECT(D_RET, VAL_WORD_FRAME(word));
- return R_RET;
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(unbind)
-/*
-** word | context
-** /deep
-**
-***********************************************************************/
+//
+// any-value?: native [
+//
+// "Returns whether a data cell contains a value."
+//
+// cell [ any-value!]
+// ]
+//
+REBNATIVE(any_value_q)
{
- REBVAL *word = D_ARG(1);
+ INCLUDE_PARAMS_OF_ANY_VALUE_Q;
- if (ANY_WORD(word)) {
- UNBIND(word);
- }
- else {
- Unbind_Block(VAL_BLK_DATA(word), D_REF(2) != 0);
- }
-
- return R_ARG1;
+ if (IS_VOID(ARG(cell)))
+ return R_FALSE;
+ return R_TRUE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(collect_words)
-/*
-** 1 block
-** 3 /deep
-** 4 /set
-** 4 /ignore
-** 5 object | block
-**
-***********************************************************************/
+//
+// unbind: native [
+//
+// "Unbinds words from context."
+//
+// word [block! any-word!]
+// "A word or block (modified) (returned)"
+// /deep
+// "Process nested blocks"
+// ]
+//
+REBNATIVE(unbind)
{
- REBSER *words;
- REBCNT modes = 0;
- REBVAL *prior = 0;
- REBVAL *block;
- REBVAL *obj;
-
- block = VAL_BLK_DATA(D_ARG(1));
-
- if (D_REF(2)) modes |= BIND_DEEP;
- if (!D_REF(3)) modes |= BIND_ALL;
-
- // If ignore, then setup for it:
- if (D_REF(4)) {
- obj = D_ARG(5);
- if (ANY_OBJECT(obj))
- prior = BLK_SKIP(VAL_OBJ_WORDS(obj), 1);
- else if (IS_BLOCK(obj))
- prior = VAL_BLK_DATA(obj);
- // else stays 0
- }
-
- words = Collect_Block_Words(block, prior, modes);
- Set_Block(D_RET, words);
- return R_RET;
+ INCLUDE_PARAMS_OF_UNBIND;
+
+ REBVAL *word = ARG(word);
+
+ if (ANY_WORD(word))
+ Unbind_Any_Word(word);
+ else
+ Unbind_Values_Core(VAL_ARRAY_AT(word), NULL, REF(deep));
+
+ Move_Value(D_OUT, word);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(get)
-/*
-***********************************************************************/
+//
+// collect-words: native [
+//
+// {Collect unique words used in a block (used for context construction).}
+//
+// block [block!]
+// /deep
+// "Include nested blocks"
+// /set
+// "Only include set-words"
+// /ignore
+// "Ignore prior words"
+// hidden [any-context! block!]
+// "Words to ignore"
+// ]
+//
+REBNATIVE(collect_words)
{
- REBVAL *word = D_ARG(1);
- REBVAL *val;
-
- if (ANY_WORD(word)) {
- val = Get_Var(word);
- if (IS_FRAME(val)) {
- Init_Obj_Value(D_RET, VAL_WORD_FRAME(word));
- return R_RET;
- }
- if (!D_REF(2) && !IS_SET(val)) Trap1(RE_NO_VALUE, word);
- }
- else if (ANY_PATH(word)) {
- val = Do_Path(&word, 0);
- if (!val) val = DS_POP; // resides on stack
- if (!D_REF(2) && !IS_SET(val)) Trap1(RE_NO_VALUE, word); //!!!! word is modified
- }
- else if (IS_OBJECT(word)) {
- Assert_Public_Object(word);
- Set_Block(D_RET, Copy_Block(VAL_OBJ_FRAME(word), 1));
- return R_RET;
- }
- else val = word; // all other values
-
- *D_RET = *val;
- return R_RET;
+ INCLUDE_PARAMS_OF_COLLECT_WORDS;
+
+ REBARR *words;
+ REBCNT modes;
+ RELVAL *values = VAL_ARRAY_AT(ARG(block));
+ RELVAL *prior_values;
+
+ if (REF(set))
+ modes = COLLECT_ONLY_SET_WORDS;
+ else
+ modes = COLLECT_ANY_WORD;
+
+ if (REF(deep)) modes |= COLLECT_DEEP;
+
+ // If ignore, then setup for it:
+ if (REF(ignore)) {
+ if (ANY_CONTEXT(ARG(hidden))) {
+ //
+ // !!! These are typesets and not words. Is Collect_Words able
+ // to handle that?
+ //
+ prior_values = CTX_KEYS_HEAD(VAL_CONTEXT(ARG(hidden)));
+ }
+ else {
+ assert(IS_BLOCK(ARG(hidden)));
+ prior_values = VAL_ARRAY_AT(ARG(hidden));
+ }
+ }
+ else
+ prior_values = NULL;
+
+ words = Collect_Words(values, prior_values, modes);
+ Init_Block(D_OUT, words);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(in)
-/*
-***********************************************************************/
+//
+// get: native [
+//
+// {Gets the value of a word or path, or values of a context.}
+//
+// return: [ any-value!]
+// {If the source looks up to a value, that value--else void}
+// source [blank! any-word! any-path! block!]
+// {Word or path to get, or block of words or paths (blank is no-op)}
+// /opt
+// {Return void if no value instead of blank}
+// ]
+//
+REBNATIVE(get)
+//
+// Note: GET* cannot be the fundamental operation, because GET could not be
+// written for blocks (since voids can't be put in blocks, so they couldn't
+// be "blankified")
{
- REBVAL *val = D_ARG(1); // object, error, port, block
- REBVAL *word = D_ARG(2);
- REBCNT index;
- REBSER *frame;
-
- if (IS_BLOCK(val) || IS_PAREN(val)) {
- if (IS_WORD(word)) {
- REBVAL *v;
- REBCNT i;
- for (i = VAL_INDEX(val); i < VAL_TAIL(val); i++) {
- v = VAL_BLK_SKIP(val, i);
- v = Get_Simple_Value(v);
- if (IS_OBJECT(v)) {
- frame = VAL_OBJ_FRAME(v);
- index = Find_Word_Index(frame, VAL_WORD_SYM(word), FALSE);
- if (index > 0) {
- VAL_WORD_INDEX(word) = (REBCNT)index;
- VAL_WORD_FRAME(word) = frame;
- *D_RET = *word;
- return R_RET;
- }
- }
- }
- return R_NONE;
- }
- else Trap_Arg(word);
- }
-
- frame = IS_ERROR(val) ? VAL_ERR_OBJECT(val) : VAL_OBJ_FRAME(val);
-
- // Special form: IN object block
- if (IS_BLOCK(word) || IS_PAREN(word)) {
- Bind_Block(frame, VAL_BLK(word), BIND_DEEP);
- return R_ARG2;
- }
-
- index = Find_Word_Index(frame, VAL_WORD_SYM(word), FALSE);
-
- if (index > 0) {
- VAL_WORD_INDEX(word) = (REBCNT)index;
- VAL_WORD_FRAME(word) = frame;
- *D_RET = *word;
- } else
- return R_NONE;
- return R_RET;
+ INCLUDE_PARAMS_OF_GET;
+
+ RELVAL *source;
+ REBVAL *dest;
+ REBSPC *specifier;
+
+ REBARR *results;
+
+ if (IS_BLOCK(ARG(source))) {
+ //
+ // If a BLOCK! of gets are performed, voids cannot be put into the
+ // resulting BLOCK!. Hence for /OPT to be legal, it would have to
+ // give back a BLANK! or other placeholder. However, since GET-VALUE
+ // is built on GET/OPT, we defer the error until we actually encounter
+ // an unset variable...which produces that error case that could not
+ // be done by "checking the block for voids"
+
+ source = VAL_ARRAY_AT(ARG(source));
+ specifier = VAL_SPECIFIER(ARG(source));
+
+ results = Make_Array(VAL_LEN_AT(ARG(source)));
+ TERM_ARRAY_LEN(results, VAL_LEN_AT(ARG(source)));
+ dest = SINK(ARR_HEAD(results));
+ }
+ else {
+ // Move the argument into the single cell in the frame if it's not a
+ // block, so the same enumeration-up-to-an-END marker can work on it
+ // as for handling a block of items.
+ //
+ Move_Value(D_CELL, ARG(source));
+ source = D_CELL;
+ specifier = SPECIFIED;
+ dest = D_OUT;
+ results = NULL; // wasteful but avoids maybe-used-uninitalized warning
+ }
+
+ DECLARE_LOCAL (get_path_hack); // runs prep code, don't put inside loop
+
+ for (; NOT_END(source); ++source, ++dest) {
+ if (IS_BAR(source)) {
+ //
+ // `a: 10 | b: 20 | get [a | b]` will give back `[10 | 20]`.
+ // While seemingly not a very useful feature standalone, this
+ // compatibility with SET could come in useful so that blocks
+ // don't have to be rearranged to filter out BAR!s.
+ //
+ Init_Bar(dest);
+ }
+ else if (IS_BLANK(source)) {
+ Init_Void(dest); // may be turned to blank after loop, or error
+ }
+ else if (ANY_WORD(source)) {
+ Copy_Opt_Var_May_Fail(dest, source, specifier);
+ }
+ else if (ANY_PATH(source)) {
+ //
+ // Make sure the path does not contain any GROUP!s, because that
+ // would trigger evaluations. GET does not sound like something
+ // that should have such a side-effect, the user should go with
+ // a REDUCE operation if that's what they want.
+ //
+ RELVAL *temp = VAL_ARRAY_AT(source);
+ for (; NOT_END(temp); ++temp)
+ if (IS_GROUP(temp))
+ fail ("GROUP! can't be in paths with GET, use REDUCE");
+
+ // Piggy-back on the GET-PATH! mechanic by copying to a temp
+ // value and changing its type bits.
+ //
+ // !!! Review making a more efficient method of doing this.
+ //
+ Derelativize(get_path_hack, source, specifier);
+ VAL_SET_TYPE_BITS(get_path_hack, REB_GET_PATH);
+
+ // Here we DO it, which means that `get 'foo/bar` will act the
+ // same as `:foo/bar` for all types.
+ //
+ if (Do_Path_Throws_Core(
+ dest,
+ NULL,
+ get_path_hack,
+ SPECIFIED,
+ NULL
+ )){
+ // Should not be possible if there's no GROUP!
+ //
+ fail (Error_No_Catch_For_Throw(dest));
+ }
+ }
+
+ if (IS_VOID(dest)) {
+ if (REF(opt)) {
+ if (IS_BLOCK(ARG(source))) // can't put voids in blocks
+ fail (Error_No_Value_Core(source, specifier));
+ }
+ else
+ Init_Blank(dest);
+ }
+ }
+
+ if (IS_BLOCK(ARG(source)))
+ Init_Block(D_OUT, results);
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(not)
-/*
-***********************************************************************/
+//
+// to-value: native [
+//
+// {Turns voids into blanks, with ANY-VALUE! passing through. (See: OPT)}
+//
+// return: [any-value!]
+// value [ any-value!]
+// ]
+//
+REBNATIVE(to_value)
{
- return (IS_FALSE(D_ARG(1)) ? R_TRUE : R_FALSE);
+ INCLUDE_PARAMS_OF_TO_VALUE;
+
+ if (IS_VOID(ARG(value)))
+ return R_BLANK;
+
+ Move_Value(D_OUT, ARG(value));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(resolve)
-/*
-** 3 /only
-** 4 from
-** 5 /all
-** 6 /expand
-**
-***********************************************************************/
+//
+// opt: native [
+//
+// {Convert blanks to optionals. (See Also: TO-VALUE)}
+//
+// return: [ any-value!]
+// {void if input was a BLANK!, or original value otherwise}
+// value [ any-value!]
+// ]
+//
+REBNATIVE(opt)
{
- REBSER *target = VAL_OBJ_FRAME(D_ARG(1));
- REBSER *source = VAL_OBJ_FRAME(D_ARG(2));
- if (IS_INTEGER(D_ARG(4))) Int32s(D_ARG(4), 1); // check range and sign
- Resolve_Context(target, source, D_ARG(4), D_REF(5), D_REF(6)); // /from /all /expand
- return R_ARG1;
+ INCLUDE_PARAMS_OF_OPT;
+
+ if (IS_BLANK(ARG(value)))
+ return R_VOID;
+
+ Move_Value(D_OUT, ARG(value));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(set)
-/*
-** word [any-word! block! object!] {Word or words to set}
-** value [any-type!] {Value or block of values}
-** /any {Allows setting words to any value.}
-** /pad {For objects, if block is too short, remaining words are set to NONE.}
-**
-***********************************************************************/
+//
+// in: native [
+//
+// "Returns the word or block bound into the given context."
+//
+// context [any-context! block!]
+// word [any-word! block! group!] "(modified if series)"
+// ]
+//
+REBNATIVE(in)
+//
+// !!! The argument names here are bad... not necessarily a context and not
+// necessarily a word. `code` or `source` to be bound in a `target`, perhaps?
{
- REBVAL *word = D_ARG(1);
- REBVAL *val = D_ARG(2);
- REBVAL *tmp = NULL;
- REBOOL not_any = !D_REF(3);
- REBOOL is_blk = FALSE;
-
- if (not_any && !IS_SET(val))
- Trap1(RE_NEED_VALUE, word);
-
- if (ANY_WORD(word)) {
- Set_Var(word, val);
- return R_ARG2;
- }
-
- if (ANY_PATH(word)) {
- Do_Path(&word, val);
- return R_ARG2;
- }
-
- // Is value a block?
- if (IS_BLOCK(val)) {
- val = VAL_BLK_DATA(val);
- if (IS_END(val)) val = NONE_VALUE;
- else is_blk = TRUE;
- }
-
- // Is target an object?
- if (IS_OBJECT(word)) {
- Assert_Public_Object(word);
- // Check for protected or unset before setting anything.
- for (tmp = val, word = VAL_OBJ_WORD(word, 1); NOT_END(word); word++) { // skip self
- if (VAL_PROTECTED(word)) Trap1(RE_LOCKED_WORD, word);
- if (not_any && is_blk && !IS_END(tmp) && IS_UNSET(tmp++)) // won't advance past end
- Trap1(RE_NEED_VALUE, word);
- }
- for (word = VAL_OBJ_VALUES(D_ARG(1)) + 1; NOT_END(word); word++) { // skip self
- // WARNING: Unwinds that make it here are assigned. All unwinds
- // should be screened earlier (as is done in e.g. REDUCE, or for
- // function arguments) so they don't even get into this function.
- *word = *val;
- if (is_blk) {
- val++;
- if (IS_END(val)) {
- if (!D_REF(4)) break; // /pad not provided
- is_blk = FALSE;
- val = NONE_VALUE;
- }
- }
- }
- } else { // Set block of words:
- if (not_any && is_blk) { // Check for unset before setting anything.
- for (tmp = val, word = VAL_BLK_DATA(word); NOT_END(word) && NOT_END(tmp); word++, tmp++) {
- switch (VAL_TYPE(word)) {
- case REB_WORD:
- case REB_SET_WORD:
- case REB_LIT_WORD:
- if (!IS_SET(tmp)) Trap1(RE_NEED_VALUE, word);
- break;
- case REB_GET_WORD:
- if (!IS_SET(IS_WORD(tmp) ? Get_Var(tmp) : tmp)) Trap1(RE_NEED_VALUE, word);
- }
- }
- }
- for (word = VAL_BLK_DATA(D_ARG(1)); NOT_END(word); word++) {
- if (IS_WORD(word) || IS_SET_WORD(word) || IS_LIT_WORD(word)) Set_Var(word, val);
- else if (IS_GET_WORD(word))
- Set_Var(word, IS_WORD(val) ? Get_Var(val) : val);
- else Trap_Arg(word);
- if (is_blk) {
- val++;
- if (IS_END(val)) is_blk = FALSE, val = NONE_VALUE;
- }
- }
- }
-
- return R_ARG2;
+ INCLUDE_PARAMS_OF_IN;
+
+ REBVAL *val = ARG(context); // object, error, port, block
+ REBVAL *word = ARG(word);
+
+ DECLARE_LOCAL (safe);
+
+ if (IS_BLOCK(val) || IS_GROUP(val)) {
+ if (IS_WORD(word)) {
+ const REBVAL *v;
+ REBCNT i;
+ for (i = VAL_INDEX(val); i < VAL_LEN_HEAD(val); i++) {
+ Get_Simple_Value_Into(
+ safe,
+ VAL_ARRAY_AT_HEAD(val, i),
+ VAL_SPECIFIER(val)
+ );
+
+ v = safe;
+ if (IS_OBJECT(v)) {
+ REBCTX *context = VAL_CONTEXT(v);
+ REBCNT index = Find_Canon_In_Context(
+ context, VAL_WORD_CANON(word), FALSE
+ );
+ if (index != 0) {
+ CLEAR_VAL_FLAG(word, VALUE_FLAG_RELATIVE);
+ SET_VAL_FLAG(word, WORD_FLAG_BOUND);
+ INIT_WORD_CONTEXT(word, context);
+ INIT_WORD_INDEX(word, index);
+ Move_Value(D_OUT, word);
+ return R_OUT;
+ }
+ }
+ }
+ return R_BLANK;
+ }
+
+ fail (word);
+ }
+
+ REBCTX *context = VAL_CONTEXT(val);
+
+ // Special form: IN object block
+ if (IS_BLOCK(word) || IS_GROUP(word)) {
+ Bind_Values_Deep(VAL_ARRAY_HEAD(word), context);
+ Move_Value(D_OUT, word);
+ return R_OUT;
+ }
+
+ REBCNT index = Find_Canon_In_Context(context, VAL_WORD_CANON(word), FALSE);
+ if (index == 0)
+ return R_BLANK;
+
+ Init_Any_Word_Bound(
+ D_OUT,
+ VAL_TYPE(word),
+ VAL_WORD_SPELLING(word),
+ context,
+ index
+ );
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(typeq)
-/*
-***********************************************************************/
+//
+// resolve: native [
+//
+// {Copy context by setting values in the target from those in the source.}
+//
+// target [any-context!] "(modified)"
+// source [any-context!]
+// /only
+// "Only specific words (exports) or new words in target"
+// from [block! integer!]
+// "(index to tail)"
+// /all
+// "Set all words, even those in the target that already have a value"
+// /extend
+// "Add source words to the target if necessary"
+// ]
+//
+REBNATIVE(resolve)
{
- REBCNT type = VAL_TYPE(D_ARG(1));
-
- if (D_REF(2)) // /word
- Init_Word(D_RET, type+1);
- else
- Set_Datatype(D_RET, type);
- return R_RET;
+ INCLUDE_PARAMS_OF_RESOLVE;
+
+ if (IS_INTEGER(ARG(from))) {
+ // check range and sign
+ Int32s(ARG(from), 1);
+ }
+
+ UNUSED(REF(only)); // handled by noticing if ARG(from) is void
+ Resolve_Context(
+ VAL_CONTEXT(ARG(target)),
+ VAL_CONTEXT(ARG(source)),
+ ARG(from),
+ REF(all),
+ REF(extend)
+ );
+
+ Move_Value(D_OUT, ARG(target));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(unset)
-/*
-***********************************************************************/
+//
+// set: native [
+//
+// {Sets a word, path, or block of words and paths to specified value(s).}
+//
+// return: [ any-value!]
+// {Will be the values set to, or void if any set values are void}
+// target [blank! any-word! any-path! block!]
+// {Word or path, or block of words and paths (blanks are no-ops)}
+// value [ any-value!]
+// "Value or block of values"
+// /only
+// {If target and value are blocks, set each item to the same value}
+// /opt
+// {Treat void values as unsetting the target instead of an error}
+// /some
+// {Blank values (or values past end of block) are not set.}
+// /lookback
+// {Function uses evaluator lookahead to "look back" (see ENFIX)}
+// ]
+//
+REBNATIVE(set)
+//
+// !!! Note that r3-legacy has a SET which overrides this one at the moment
+//
+// Blocks are supported as:
+//
+// >> set [a b] [1 2]
+// >> print a
+// 1
+// >> print b
+// 2
+//
+// !!! Should the /LOOKBACK refinement be called /ENFIX?
{
- REBVAL *word = D_ARG(1);
- REBVAL *value;
-
- if (IS_WORD(word)) {
- if (VAL_WORD_FRAME(word)) {
- Protected(word);
- value = Get_Var(word);
- SET_UNSET(value);
- }
- } else {
- for (word = VAL_BLK_DATA(word); NOT_END(word); word++) {
- if (IS_WORD(word) && VAL_WORD_FRAME(word)) {
- Protected(word);
- value = Get_Var(word);
- SET_UNSET(value);
- }
- }
- }
- return R_RET;
+ INCLUDE_PARAMS_OF_SET;
+
+ const RELVAL *value;
+ REBSPC *value_specifier;
+
+ const RELVAL *target;
+ REBSPC *target_specifier;
+
+ REBOOL only;
+ if (IS_BLOCK(ARG(target))) {
+ //
+ // R3-Alpha and Red let you write `set [a b] 10`, since the thing
+ // you were setting to was not a block, would assume you meant to set
+ // all the values to that. BUT since you can set things to blocks,
+ // this has a bad characteristic of `set [a b] [10]` being treated
+ // differently, which can bite you if you `set [a b] value` for some
+ // generic value.
+ //
+ if (IS_BLOCK(ARG(value)) && NOT(REF(only))) {
+ //
+ // There is no need to check values for voidness in this case,
+ // since arrays cannot contain voids.
+ //
+ value = VAL_ARRAY_AT(ARG(value));
+ value_specifier = VAL_SPECIFIER(ARG(value));
+ only = FALSE;
+ }
+ else {
+ if (IS_VOID(ARG(value)) && NOT(REF(opt)))
+ fail (Error_No_Value(ARG(value)));
+
+ value = ARG(value);
+ value_specifier = SPECIFIED;
+ only = TRUE;
+ }
+
+ target = VAL_ARRAY_AT(ARG(target));
+ target_specifier = VAL_SPECIFIER(ARG(target));
+ }
+ else {
+ // Use the fact that D_CELL is implicitly terminated so that the
+ // loop below can share code between `set [a b] x` and `set a x`, by
+ // incrementing the target pointer and hitting an END marker
+ //
+ assert(
+ ANY_WORD(ARG(target))
+ || ANY_PATH(ARG(target))
+ || IS_BLANK(ARG(target))
+ );
+
+ Move_Value(D_CELL, ARG(target));
+ target = D_CELL;
+ target_specifier = SPECIFIED;
+
+ if (IS_VOID(ARG(value)) && NOT(REF(opt)))
+ fail (Error_No_Value(ARG(value)));
+
+ value = ARG(value);
+ value_specifier = SPECIFIED;
+ only = TRUE;
+ }
+
+ DECLARE_LOCAL (get_path_hack); // runs prep code, don't put inside loop
+
+ for (
+ ;
+ NOT_END(target);
+ ++target, only || IS_END(value) ? NOOP : (++value, NOOP)
+ ){
+ if (REF(some)) {
+ if (IS_END(value))
+ break; // won't be setting any further values
+ if (IS_BLANK(value))
+ continue;
+ }
+
+ if (IS_BAR(target)) {
+ if (NOT_END(value) || NOT(IS_BAR(value)))
+ fail ("BAR! can only line up with other BAR! in SET");
+ }
+ else if (IS_BLANK(target)) {
+ //
+ // Just skip it
+ }
+ else if (ANY_WORD(target)) {
+ if (REF(lookback) && NOT(IS_FUNCTION(ARG(value))))
+ fail ("Attempt to SET/LOOKBACK on a non-function");
+
+ REBVAL *var = Sink_Var_May_Fail(target, target_specifier);
+ Derelativize(
+ var,
+ IS_END(value) ? BLANK_VALUE : value,
+ value_specifier
+ );
+ if (REF(lookback))
+ SET_VAL_FLAG(var, VALUE_FLAG_ENFIXED);
+ }
+ else if (ANY_PATH(target)) {
+ //
+ // Make sure the path does not contain any GROUP!s, because that
+ // would trigger evaluations. SET does sound like it has a
+ // side effect (unlike GET), but you don't expect the side effect
+ // to do things like PRINT, which arbitrary code can do.
+ //
+ RELVAL *temp = VAL_ARRAY_AT(target);
+ for (; NOT_END(temp); ++temp)
+ if (IS_GROUP(temp))
+ fail ("GROUP! can't be in paths with SET");
+
+ // !!! For starters, just the word form is supported for lookback.
+ // Though you can't dispatch a lookback from a path, you should be
+ // able to set a word in a context to one.
+ //
+ if (REF(lookback))
+ fail ("Cannot currently SET/LOOKBACK on a PATH!");
+
+ DECLARE_LOCAL (specific);
+ if (IS_END(value))
+ Init_Blank(specific);
+ else
+ Derelativize(specific, value, value_specifier);
+
+ // Currently we have to tweak the bits of the path so that it's a
+ // GET-PATH!, since Do_Path is sensitive to the path type, and we
+ // want all to act the same.
+ //
+ Derelativize(get_path_hack, target, target_specifier);
+ VAL_SET_TYPE_BITS(get_path_hack, REB_GET_PATH);
+
+ if (
+ Do_Path_Throws_Core(
+ D_OUT,
+ NULL,
+ get_path_hack,
+ SPECIFIED,
+ specific
+ )
+ ){
+ fail (Error_No_Catch_For_Throw(D_OUT));
+ }
+
+ // If not a throw, then there is no result out of a setting a path
+ }
+ else
+ fail (Error_Invalid_Arg_Core(target, target_specifier));
+ }
+
+ Move_Value(D_OUT, ARG(value));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(valueq)
-/*
-***********************************************************************/
+//
+// type-of: native [
+//
+// "Returns the datatype of a value."
+//
+// value [ any-value!]
+// ]
+//
+REBNATIVE(type_of)
{
- REBVAL *value = D_ARG(1);
+ INCLUDE_PARAMS_OF_TYPE_OF;
+
+ enum Reb_Kind kind = VAL_TYPE(ARG(value));
+ if (kind == REB_MAX_VOID)
+ return R_BLANK;
- if (ANY_WORD(value) && !(value = Get_Var_No_Trap(value))) return R_FALSE;
- if (IS_UNSET(value)) return R_FALSE;
- return R_TRUE;
+ Val_Init_Datatype(D_OUT, kind);
+ return R_OUT;
}
-//** SERIES ************************************************************
-static int Do_Ordinal(REBVAL *ds, REBINT n)
+//
+// unset: native [
+//
+// {Unsets the value of a word (in its current context.)}
+//
+// return: []
+// target [any-word! block!]
+// "Word or block of words"
+// ]
+//
+REBNATIVE(unset)
{
- // Is only valid when returned from ACTION function itself.
- REBACT action = Value_Dispatch[VAL_TYPE(D_ARG(1))];
- DS_PUSH_INTEGER(n);
- //DSF_FUNC(ds) // needs to be set to PICK action!
- return action(ds, A_PICK); // returns R_RET and other cases
-}
+ INCLUDE_PARAMS_OF_UNSET;
-/***********************************************************************
-**
-*/ REBNATIVE(first)
-/*
-***********************************************************************/
-{
- return Do_Ordinal(ds, 1);
-}
+ REBVAL *target = ARG(target);
+ if (ANY_WORD(target)) {
+ REBVAL *var = Sink_Var_May_Fail(target, SPECIFIED);
+ Init_Void(var);
+ return R_VOID;
+ }
-/***********************************************************************
-**
-*/ REBNATIVE(second)
-/*
-***********************************************************************/
-{
- return Do_Ordinal(ds, 2);
-}
+ assert(IS_BLOCK(target));
+ RELVAL *word;
+ for (word = VAL_ARRAY_AT(target); NOT_END(word); ++word) {
+ if (!ANY_WORD(word))
+ fail (Error_Invalid_Arg_Core(word, VAL_SPECIFIER(target)));
-/***********************************************************************
-**
-*/ REBNATIVE(third)
-/*
-***********************************************************************/
-{
- return Do_Ordinal(ds, 3);
+ REBVAL *var = Sink_Var_May_Fail(word, VAL_SPECIFIER(target));
+ Init_Void(var);
+ }
+
+ return R_VOID;
}
-/***********************************************************************
-**
-*/ REBNATIVE(fourth)
-/*
-***********************************************************************/
+//
+// lookback?: native [
+//
+// {TRUE if looks up to a function and gets first argument before the call}
+//
+// source [any-word! any-path!]
+// ]
+//
+REBNATIVE(lookback_q)
{
- return Do_Ordinal(ds, 4);
-}
+ INCLUDE_PARAMS_OF_LOOKBACK_Q;
+ REBVAL *source = ARG(source);
-/***********************************************************************
-**
-*/ REBNATIVE(fifth)
-/*
-***********************************************************************/
-{
- return Do_Ordinal(ds, 5);
-}
+ if (ANY_WORD(source)) {
+ const REBVAL *var = Get_Var_Core(
+ source, SPECIFIED, GETVAR_READ_ONLY // may fail()
+ );
+ if (!IS_FUNCTION(var))
+ return R_FALSE;
-/***********************************************************************
-**
-*/ REBNATIVE(sixth)
-/*
-***********************************************************************/
-{
- return Do_Ordinal(ds, 6);
+ return R_FROM_BOOL(GET_VAL_FLAG(var, VALUE_FLAG_ENFIXED));
+ }
+ else {
+ assert(ANY_PATH(source));
+
+ // Not implemented yet...
+
+ fail ("LOOKBACK? testing is not currently implemented on PATH!");
+ }
}
-/***********************************************************************
-**
-*/ REBNATIVE(seventh)
-/*
-***********************************************************************/
+//
+// semiquoted?: native [
+//
+// {Discern if a function parameter came from an "active" evaluation.}
+//
+// parameter [word!]
+// ]
+//
+REBNATIVE(semiquoted_q)
+//
+// This operation is somewhat dodgy. So even though the flag is carried by
+// all values, and could be generalized in the system somehow to query on
+// anything--we don't. It's strictly for function parameters, and
+// even then it should be restricted to functions that have labeled
+// themselves as absolutely needing to do this for ergonomic reasons.
{
- return Do_Ordinal(ds, 7);
+ INCLUDE_PARAMS_OF_SEMIQUOTED_Q;
+
+ // !!! TBD: Enforce this is a function parameter (specific binding branch
+ // makes the test different, and easier)
+
+ const REBVAL *var = Get_Var_Core( // may fail
+ ARG(parameter), SPECIFIED, GETVAR_READ_ONLY
+ );
+ return R_FROM_BOOL(GET_VAL_FLAG(var, VALUE_FLAG_UNEVALUATED));
}
-/***********************************************************************
-**
-*/ REBNATIVE(eighth)
-/*
-***********************************************************************/
+//
+// semiquote: native [
+//
+// {Marks a function argument to be treated as if it had been literal source}
+//
+// value [any-value!]
+// ]
+//
+REBNATIVE(semiquote)
{
- return Do_Ordinal(ds, 8);
+ INCLUDE_PARAMS_OF_SEMIQUOTE;
+
+ Move_Value(D_OUT, ARG(value));
+
+ // We cannot set the VALUE_FLAG_UNEVALUATED bit here and make it stick,
+ // because the bit would just get cleared off by Do_Core when the
+ // function finished. So ask the evaluator to set the bit for us.
+
+ return R_OUT_UNEVALUATED;
}
-/***********************************************************************
-**
-*/ REBNATIVE(ninth)
-/*
-***********************************************************************/
+//
+// as: native [
+//
+// {Aliases the underlying data of one series to act as another of same class}
+//
+// type [datatype!]
+// value [any-series! any-word!]
+// ]
+//
+REBNATIVE(as)
{
- return Do_Ordinal(ds, 9);
+ INCLUDE_PARAMS_OF_AS;
+
+ enum Reb_Kind kind = VAL_TYPE_KIND(ARG(type));
+ REBVAL *value = ARG(value);
+
+ switch (kind) {
+ case REB_BLOCK:
+ case REB_GROUP:
+ case REB_PATH:
+ case REB_LIT_PATH:
+ case REB_GET_PATH:
+ if (!ANY_ARRAY(value))
+ fail (Error_Bad_Cast_Raw(value, ARG(type)));
+ break;
+
+ case REB_STRING:
+ case REB_TAG:
+ case REB_FILE:
+ case REB_URL:
+ if (!ANY_BINSTR(value) || IS_BINARY(value))
+ fail (Error_Bad_Cast_Raw(value, ARG(type)));
+ break;
+
+ case REB_WORD:
+ case REB_GET_WORD:
+ case REB_SET_WORD:
+ case REB_LIT_WORD:
+ case REB_ISSUE:
+ case REB_REFINEMENT:
+ if (!ANY_WORD(value))
+ fail (value);
+ break;
+
+ default:
+ fail (Error_Bad_Cast_Raw(value, ARG(type))); // all applicable types should be handled above
+ }
+
+ VAL_SET_TYPE_BITS(value, kind);
+ Move_Value(D_OUT, value);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(tenth)
-/*
-***********************************************************************/
+//
+// aliases?: native [
+//
+// {Return whether or not the underlying data of one value aliases another}
+//
+// value1 [any-series!]
+// value2 [any-series!]
+// ]
+//
+REBNATIVE(aliases_q)
{
- return Do_Ordinal(ds, 10);
+ INCLUDE_PARAMS_OF_ALIASES_Q;
+
+ if (VAL_SERIES(ARG(value1)) == VAL_SERIES(ARG(value2)))
+ return R_TRUE;
+
+ return R_FALSE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(last)
-/*
-***********************************************************************/
+// Common routine for both SET? and UNSET? Note that location is modified
+// into a GET-PATH! value if it is originally a path (okay for the natives,
+// since they can modify values in their frames.)
+//
+inline static REBOOL Is_Set_Modifies(REBVAL *location)
{
- REBVAL *val = D_ARG(1);
- REBACT action;
- REBCNT t;
-
- action = Value_Dispatch[VAL_TYPE(val)];
- if (ANY_SERIES(val)) {
- t = VAL_TAIL(val);
- VAL_INDEX(val) = 0;
- }
- else if (IS_TUPLE(val)) t = VAL_TUPLE_LEN(val);
- else if (IS_GOB(val)) {
- t = GOB_PANE(VAL_GOB(val)) ? GOB_TAIL(VAL_GOB(val)) : 0;
- VAL_GOB_INDEX(val) = 0;
- }
- else t = 0; // let the action throw the error
- DS_PUSH_INTEGER(t);
- return action(ds, A_PICK);
+ if (ANY_WORD(location)) {
+ //
+ // Note this will fail if unbound
+ //
+ const RELVAL *var = Get_Opt_Var_May_Fail(location, SPECIFIED);
+ if (IS_VOID(var))
+ return FALSE;
+ }
+ else {
+ assert(ANY_PATH(location));
+
+ #if !defined(NDEBUG)
+ REBDSP dsp_orig = DSP;
+ #endif
+
+ // !!! We shouldn't be evaluating but currently the path machinery
+ // doesn't "turn off" GROUP! evaluations for GET-PATH!.
+ //
+ VAL_SET_TYPE_BITS(location, REB_GET_PATH);
+
+ DECLARE_LOCAL (temp);
+ if (Do_Path_Throws_Core(
+ temp, NULL, location, VAL_SPECIFIER(location), NULL
+ )) {
+ // !!! Shouldn't be evaluating, much less throwing--so fail
+ //
+ fail (Error_No_Catch_For_Throw(temp));
+ }
+
+ // We did not pass in a symbol ID
+ //
+ assert(DSP == dsp_orig);
+ if (IS_VOID(temp))
+ return FALSE;
+ }
+
+ return TRUE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(first_add)
-/*
-***********************************************************************/
+//
+// set?: native/body [
+//
+// "Whether a bound word or path is set (!!! shouldn't eval GROUP!s)"
+//
+// location [any-word! any-path!]
+// ][
+// any-value? get/opt location
+// ]
+//
+REBNATIVE(set_q)
{
- REBVAL *value;
- REBCNT index;
- REBCNT tail;
-
- value = Get_Var(D_ARG(1));
-
- if (ANY_SERIES(value)) {
- tail = VAL_TAIL(value);
- }
- else if (IS_GOB(value)) {
- tail = GOB_PANE(VAL_GOB(value)) ? GOB_TAIL(VAL_GOB(value)) : 0;
- }
- else
- Trap_Arg(D_ARG(1)); // !! need better msg
-
- *D_ARG(1) = *value;
- index = VAL_INDEX(value); // same for VAL_GOB_INDEX
- if (index < tail) VAL_INDEX(value) = index + 1;
- return Do_Ordinal(ds, 1);
+ INCLUDE_PARAMS_OF_SET_Q;
+
+ return R_FROM_BOOL(Is_Set_Modifies(ARG(location)));
}
-/***********************************************************************
-**
-*/ REBNATIVE(_add_add)
-/*
-** i: ++ int
-** s: ++ series
-**
-***********************************************************************/
+//
+// unset?: native/body [
+//
+// "Whether a bound word or path is unset (!!! shouldn't eval GROUP!s)"
+//
+// location [any-word! any-path!]
+// ][
+// void? get/opt location
+// ]
+//
+REBNATIVE(unset_q)
{
- REBVAL *value;
- REBCNT n;
- REBVAL *word = D_ARG(1);
-
- value = Get_Var_Safe(word); // throws error
-
- *D_RET = *value;
-
- if (IS_INTEGER(value)) {
- VAL_INT64(value)++;
- }
- else if (ANY_SERIES(value)) {
- n = VAL_INDEX(value);
- if (n < VAL_TAIL(value)) VAL_INDEX(value) = n + 1;
- }
- else if (IS_DECIMAL(value)) {
- VAL_DECIMAL(value) += 1.0;
- }
- else
- Trap_Arg(D_ARG(1));
-
- return R_RET;
+ INCLUDE_PARAMS_OF_UNSET_Q;
+
+ return R_FROM_BOOL(NOT(Is_Set_Modifies(ARG(location))));
}
-/***********************************************************************
-**
-*/ REBNATIVE(__)
-/*
-** i: -- int
-** s: -- series
-**
-***********************************************************************/
+//
+// true?: native/body [
+//
+// "Returns true if a value can be used as true."
+//
+// value [any-value!] ; Note: No [ any-value!] - void must fail
+// ][
+// not not :val
+// ]
+//
+REBNATIVE(true_q)
{
- REBVAL *value;
- REBCNT n;
- REBVAL *word = D_ARG(1);
-
- value = Get_Var_Safe(word); // throws error
-
- *D_RET = *value;
-
- if (IS_INTEGER(value)) {
- VAL_INT64(value)--;
- }
- else if (ANY_SERIES(value)) {
- n = VAL_INDEX(value);
- if (n > 0) VAL_INDEX(value) = n - 1;
- }
- else if (IS_DECIMAL(value)) {
- VAL_DECIMAL(value) -= 1.0;
- }
- else
- Trap_Arg(D_ARG(1));
-
- return R_RET;
+ INCLUDE_PARAMS_OF_TRUE_Q;
+
+ return R_FROM_BOOL(IS_CONDITIONAL_TRUE(ARG(value)));
}
-/***********************************************************************
-**
-*/ REBNATIVE(dump)
-/*
-***********************************************************************/
+//
+// false?: native/body [
+//
+// "Returns false if a value is either LOGIC! false or a NONE!."
+//
+// value [any-value!] ; Note: No [ any-value!] - void must fail.
+// ][
+// either any [
+// blank? :value
+// :value = false
+// ][
+// true
+// ][
+// false
+// ]
+// ]
+//
+REBNATIVE(false_q)
{
-#ifdef _DEBUG
- REBVAL *arg = D_ARG(1);
-
- if (ANY_SERIES(arg))
- Dump_Series(VAL_SERIES(arg), "=>");
- else
- Dump_Values(arg, 1);
-#endif
- return R_ARG1;
+ INCLUDE_PARAMS_OF_FALSE_Q;
+
+ return R_FROM_BOOL(IS_CONDITIONAL_FALSE(ARG(value)));
}
-#ifdef not_fast_enough
-/***********************************************************************
-**
-**/ REBNATIVE(replace_all)
-/*
-***********************************************************************/
+//
+// quote: native/body [
+//
+// "Returns the value passed to it without evaluation."
+//
+// return: [any-value!]
+// :value [any-value!]
+// ][
+// if bar? :value [
+// fail "Cannot quote expression barrier" ;-- not actual error
+// ]
+// :value ;-- actually also sets unevaluated bit, how could a user do so?
+// ]
+//
+REBNATIVE(quote)
{
-#define BIT_CHAR(c) (((REBU64)1) << (c % 64))
- REBVAL *a1 = D_ARG(1);
- REBVAL *a2 = D_ARG(2);
- REBSER *ser = VAL_SERIES(a1);
- REBCNT tail = ser->tail;
- REBVAL *pats = VAL_BLK(a2);
- REBCNT tail2 = VAL_TAIL(a2);
- REBSER *outs;
- REBUNI chr;
- REBU64 chash = 0;
- REBCNT i, n;
- REBVAL *val;
-
- // Check substitution strings, and compute hash and size diff.
- n = 0;
- for (val = VAL_BLK(a2); NOT_END(val); val += 2) {
- if (VAL_TYPE(a1) != VAL_TYPE(val)) Trap0(RE_NOT_SAME_TYPE); // !! would be good to show it
- if (IS_END(val+1)) Trap0(RE_MISSING_ARG);
- if (VAL_TYPE(a1) != VAL_TYPE(val+1)) Trap0(RE_NOT_SAME_TYPE); // !! would be good to show it
- chr = GET_ANY_CHAR(VAL_SERIES(val), 0);
- chash |= BIT_CHAR(chr);
- n += 3 * (VAL_LEN(val+1) - VAL_LEN(val)); // assume it occurs three times
- }
-
- outs = Make_Unicode(VAL_LEN(a1) + n);
-
- for (i = VAL_INDEX(a1); i < tail; i++) {
- chr = GET_ANY_CHAR(ser, i);
- val = 0; // default for check below
- if (BIT_CHAR(chr) & chash) {
- for (val = VAL_BLK(a2); NOT_END(val); val += 2) {
- if (NOT_FOUND != Find_Str_Str(ser, 0, i, tail, 0, VAL_SERIES(val), 0, VAL_TAIL(val), AM_FIND_MATCH)) {
- Insert_String(outs, SERIES_TAIL(outs), VAL_SERIES(val+1), 0, VAL_TAIL(val+1), 0);
- i += VAL_TAIL(val) - 1;
- break;
- }
- }
- if (IS_END(val)) val = 0; // for test below
- }
- // If not found, just copy the character:
- if (!val) {
- n = SERIES_TAIL(outs);
- EXPAND_SERIES_TAIL(outs, 1);
- *UNI_SKIP(outs, n) = chr;
- }
- }
- UNI_TERM(outs); // Because we don't do it for single chars.
- Set_String(D_RET, outs);
- return R_RET;
+ INCLUDE_PARAMS_OF_QUOTE;
+
+ // Generally speaking, a hard quoting operation is permitted to quote
+ // BAR! if it really wants to. The general advice is to fail in this
+ // case, but it is not enforced.
+ //
+ if (IS_BAR(ARG(value)))
+ fail (Error_Expression_Barrier_Raw());
+
+ Move_Value(D_OUT, ARG(value));
+
+ // We cannot set the VALUE_FLAG_UNEVALUATED bit here and make it stick,
+ // because the bit would just get cleared off by Do_Core when the
+ // function finished. Ask evaluator to add the bit for us.
+
+ return R_OUT_UNEVALUATED;
}
-#endif
-/***********************************************************************
-**
-*/ static REBGOB *Map_Gob_Inner(REBGOB *gob, REBXYF *offset)
-/*
-** Map a higher level gob coordinate to a lower level.
-** Returns GOB and sets new offset pair.
-**
-***********************************************************************/
+//
+// void?: native/body [
+//
+// "Tells you if the argument is not a value (e.g. `void? do []` is TRUE)"
+//
+// value [ any-value!]
+// ][
+// blank? type-of :value
+// ]
+//
+REBNATIVE(void_q)
{
- REBD32 xo = offset->x;
- REBD32 yo = offset->y;
- REBINT n;
- REBINT len;
- REBGOB **gop;
- REBD32 x = 0;
- REBD32 y = 0;
- REBINT max_depth = 1000; // avoid infinite loops
-
- while (GOB_PANE(gob) && (max_depth-- > 0)) {
- len = GOB_TAIL(gob);
- gop = GOB_HEAD(gob) + len - 1;
- for (n = 0; n < len; n++, gop--) {
- if (
- (xo >= x + GOB_X(*gop)) &&
- (xo < x + GOB_X(*gop) + GOB_W(*gop)) &&
- (yo >= y + GOB_Y(*gop)) &&
- (yo < y + GOB_Y(*gop) + GOB_H(*gop))
- ){
- x += GOB_X(*gop);
- y += GOB_Y(*gop);
- gob = *gop;
- break;
- }
- }
- if (n >= len) break; // not found
- }
-
- offset->x -= x;
- offset->y -= y;
-
- return gob;
+ INCLUDE_PARAMS_OF_VOID_Q;
+
+ return R_FROM_BOOL(IS_VOID(ARG(value)));
}
-/***********************************************************************
-**
-*/ REBNATIVE(map_event)
-/*
-***********************************************************************/
+//
+// void: native/body [
+//
+// "Function returning no result (alternative for `()` or `do []`)"
+//
+// return: [] ;-- how to say no-value! ?
+// ][
+// ]
+//
+REBNATIVE(void)
{
- REBVAL *val = D_ARG(1);
- REBGOB *gob = VAL_EVENT_SER(val);
- REBXYF xy;
-
- if (gob && GET_FLAG(VAL_EVENT_FLAGS(val), EVF_HAS_XY)) {
- xy.x = (REBD32)VAL_EVENT_X(val);
- xy.y = (REBD32)VAL_EVENT_Y(val);
- VAL_EVENT_SER(val) = Map_Gob_Inner(gob, &xy);
- SET_EVENT_XY(val, ROUND_TO_INT(xy.x), ROUND_TO_INT(xy.y));
- }
- return R_ARG1;
+ UNUSED(frame_);
+ return R_VOID;
}
-/***********************************************************************
-**
-*/ static void Return_Gob_Pair(REBVAL *ds, REBGOB *gob, REBD32 x, REBD32 y)
-/*
-***********************************************************************/
+//
+// nothing?: native/body [
+//
+// "Returns TRUE if argument is either a NONE! or no value is passed in"
+//
+// value [ any-value!]
+// ][
+// any [
+// void? :value
+// blank? :value
+// ]
+// ]
+//
+REBNATIVE(nothing_q)
{
- REBSER *blk;
- REBVAL *val;
-
- blk = Make_Block(2);
- Set_Series(REB_BLOCK, ds, blk);
- val = Append_Value(blk);
- SET_GOB(val, gob);
- val = Append_Value(blk);
- VAL_SET(val, REB_PAIR);
- VAL_PAIR_X(val) = x;
- VAL_PAIR_Y(val) = y;
+ INCLUDE_PARAMS_OF_NOTHING_Q;
+
+ return R_FROM_BOOL(
+ LOGICAL(IS_BLANK(ARG(value)) || IS_VOID(ARG(value)))
+ );
}
-/***********************************************************************
-**
-*/ REBNATIVE(map_gob_offset)
-/*
-***********************************************************************/
+//
+// something?: native/body [
+//
+// "Returns TRUE if a value is passed in and it isn't a NONE!"
+//
+// value [ any-value!]
+// ][
+// all [
+// any-value? :value
+// not blank? value
+// ]
+// ]
+//
+REBNATIVE(something_q)
{
- REBGOB *gob = VAL_GOB(D_ARG(1));
- REBD32 xo = VAL_PAIR_X(D_ARG(2));
- REBD32 yo = VAL_PAIR_Y(D_ARG(2));
-
- if (D_REF(3)) { // reverse
- REBINT max_depth = 1000; // avoid infinite loops
- while (GOB_PARENT(gob) && (max_depth-- > 0) &&
- !GET_GOB_FLAG(gob, GOBF_WINDOW)){
- xo += GOB_X(gob);
- yo += GOB_Y(gob);
- gob = GOB_PARENT(gob);
- }
- }
- else {
- REBXYF xy;
- xy.x = VAL_PAIR_X(D_ARG(2));
- xy.y = VAL_PAIR_Y(D_ARG(2));
- gob = Map_Gob_Inner(gob, &xy);
- xo = xy.x;
- yo = xy.y;
- }
-
- Return_Gob_Pair(ds, gob, xo, yo);
-
- return R_RET;
+ INCLUDE_PARAMS_OF_SOMETHING_Q;
+
+ return R_FROM_BOOL(
+ NOT(IS_BLANK(ARG(value)) || IS_VOID(ARG(value)))
+ );
}
diff --git a/src/core/n-do.c b/src/core/n-do.c
new file mode 100644
index 0000000000..664319ea1e
--- /dev/null
+++ b/src/core/n-do.c
@@ -0,0 +1,539 @@
+//
+// File: %n-do.c
+// Summary: "native functions for DO, EVAL, APPLY"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Ren-C's philosophy of DO is that the argument to it represents a place to
+// find source code. Hence `DO 3` does not evaluate to the number 3, any
+// more than `DO "print hello"` would evaluate to `"print hello"`. If a
+// generalized evaluator is needed, use the special-purpose function EVAL.
+//
+// Note that although the code for running blocks and frames is implemented
+// here as C, the handler for processing STRING!, FILE!, TAG!, URL!, etc. is
+// dispatched out to some Rebol code. See `system/intrinsic/do*`.
+//
+
+#include "sys-core.h"
+
+
+//
+// eval: native [
+//
+// {(Special) Process received value *inline* as the evaluator loop would.}
+//
+// value [ any-value!]
+// {BLOCK! passes-thru, FUNCTION! runs, SET-WORD! assigns...}
+// /only
+// {Suppress evaluation on any ensuing arguments value consumes}
+// ]
+//
+REBNATIVE(eval)
+{
+ INCLUDE_PARAMS_OF_EVAL;
+
+ REBFRM *f = frame_; // implicit parameter to every dispatcher/native
+
+ Move_Value(&f->cell, ARG(value));
+
+ // Save the prefetched f->value for what would be the usual next
+ // item (including if it was an END marker) into f->pending.
+ // Then make f->value the address of the eval result.
+ //
+ // Since the evaluation result is a REBVAL and not a RELVAL, it
+ // is specific. This means the `f->specifier` (which can only
+ // specify values from the source array) won't ever be applied
+ // to it, since it only comes into play for IS_RELATIVE values.
+ //
+ f->pending = f->value;
+ SET_FRAME_VALUE(f, &f->cell); // SPECIFIED
+ f->eval_type = VAL_TYPE(f->value);
+
+ // The f->gotten (if any) was the fetch for the f->value we just
+ // put in pending...not the f->value we just set. Not only is
+ // it more expensive to hold onto that cache than to lose it,
+ // but an eval can do anything...so the f->gotten might wind
+ // up being completely different after the eval. So forget it.
+ //
+ f->gotten = END;
+
+ return REF(only) ? R_REEVALUATE_ONLY : R_REEVALUATE;
+}
+
+
+//
+// do: native [
+//
+// {Evaluates a block of source code (directly or fetched according to type)}
+//
+// return: [ any-value!]
+// source [
+// ;-- should DO accept an optional argument (chaining?)
+// blank! ;-- same question... necessary, or not?
+// block! ;-- source code in block form
+// string! ;-- source code in text form
+// binary! ;-- treated as UTF-8
+// url! ;-- load code from URL via protocol
+// file! ;-- load code from file on local disk
+// tag! ;-- proposed as module library tag name, hacked as demo
+// error! ;-- should use FAIL instead
+// function! ;-- will only run arity 0 functions (avoids DO variadic)
+// frame! ;-- acts like APPLY (voids are optionals, not unspecialized)
+// ]
+// /args
+// {If value is a script, this will set its system/script/args}
+// arg
+// "Args passed to a script (normally a string)"
+// /next
+// {Do next expression only, return it, update block variable}
+// var [any-word! blank!]
+// "If not blank, then a variable updated with new block position"
+// /only
+// "Don't catch QUIT (default behavior for BLOCK!)"
+// ]
+//
+REBNATIVE(do)
+{
+ INCLUDE_PARAMS_OF_DO;
+
+ REBVAL *source = ARG(source);
+
+ switch (VAL_TYPE(source)) {
+ case REB_MAX_VOID:
+ // useful for `do if ...` types of scenarios
+ return R_VOID;
+
+ case REB_BLANK:
+ // useful for `do all ...` types of scenarios
+ return R_BLANK;
+
+ case REB_BLOCK:
+ case REB_GROUP:
+ if (REF(next)) {
+ REBIXO indexor = DO_NEXT_MAY_THROW(
+ D_OUT,
+ VAL_ARRAY(source),
+ VAL_INDEX(source),
+ VAL_SPECIFIER(source)
+ );
+
+ if (indexor == THROWN_FLAG) {
+ //
+ // the throw should make the value irrelevant, but if caught
+ // then have it indicate the start of the thrown expression
+ //
+ if (!IS_BLANK(ARG(var))) {
+ Move_Value(
+ Sink_Var_May_Fail(ARG(var), SPECIFIED),
+ source
+ );
+ }
+
+ return R_OUT_IS_THROWN;
+ }
+
+ if (!IS_BLANK(ARG(var))) {
+ //
+ // "continuation" of block...turn END_FLAG into the end so it
+ // can test TAIL? as true to know the evaluation finished.
+ //
+ // !!! Is there merit to setting to NONE! instead? Easier to
+ // test and similar to FIND. On the downside, "lossy" in
+ // that after the DOs are finished the var can't be used to
+ // recover the series again...you'd have to save it.
+ //
+ if (indexor == END_FLAG)
+ VAL_INDEX(source) = VAL_LEN_HEAD(source);
+ else
+ VAL_INDEX(source) = cast(REBCNT, indexor);
+
+ Move_Value(
+ Sink_Var_May_Fail(ARG(var), SPECIFIED),
+ ARG(source)
+ );
+ }
+
+ return R_OUT;
+ }
+
+ if (Do_Any_Array_At_Throws(D_OUT, source))
+ return R_OUT_IS_THROWN;
+
+ return R_OUT;
+
+ case REB_BINARY:
+ case REB_STRING:
+ case REB_URL:
+ case REB_FILE:
+ case REB_TAG: {
+ //
+ // See code called in system/intrinsic/do*
+ //
+ const REBOOL fully = TRUE; // error if not all arguments consumed
+ if (Apply_Only_Throws(
+ D_OUT,
+ fully,
+ Sys_Func(SYS_CTX_DO_P),
+ source,
+ REF(args) ? TRUE_VALUE : FALSE_VALUE,
+ REF(args) ? ARG(arg) : BLANK_VALUE, // can't put void in block
+ REF(next) ? TRUE_VALUE : FALSE_VALUE,
+ REF(next) ? ARG(var) : BLANK_VALUE, // can't put void in block
+ REF(only) ? TRUE_VALUE : FALSE_VALUE,
+ END
+ )) {
+ return R_OUT_IS_THROWN;
+ }
+ return R_OUT; }
+
+ case REB_ERROR:
+ //
+ // FAIL is the preferred operation for triggering errors, as it has
+ // a natural behavior for blocks passed to construct readable messages
+ // and "FAIL X" more clearly communicates a failure than "DO X"
+ // does. However DO of an ERROR! would have to raise an error
+ // anyway, so it might as well raise the one it is given...and this
+ // allows the more complex logic of FAIL to be written in Rebol code.
+ //
+ fail (VAL_CONTEXT(source));
+
+ case REB_FUNCTION: {
+ //
+ // Ren-C will only run arity 0 functions from DO, otherwise EVAL
+ // must be used. Look for the first non-local parameter to tell.
+ //
+ REBVAL *param = FUNC_PARAMS_HEAD(VAL_FUNC(source));
+ while (
+ NOT_END(param)
+ && (VAL_PARAM_CLASS(param) == PARAM_CLASS_LOCAL)
+ ) {
+ ++param;
+ }
+ if (NOT_END(param))
+ fail (Error_Use_Eval_For_Eval_Raw());
+
+ if (Eval_Value_Throws(D_OUT, source))
+ return R_OUT_IS_THROWN;
+ return R_OUT;
+ }
+
+ case REB_FRAME: {
+ REBCTX *c = VAL_CONTEXT(source);
+
+ // To allow efficient applications, this does not make a copy of the
+ // FRAME!. This means the frame must not be currently running
+ // on the stack.
+ //
+ // !!! It may come to pass that a trick lets you reuse a stack context
+ // and unwind it as a kind of tail recursion to reuse it. But one would
+ // not want that strange voodoo to be what DO does on a FRAME!,
+ // it would have to be another operation (REDO ?)
+ //
+ if (CTX_FRAME_IF_ON_STACK(c) != NULL)
+ fail (Error_Do_Running_Frame_Raw());
+
+ // Right now all stack based contexts are either running (stopped by
+ // the above) or expired (in which case their values are unavailable).
+ //
+ if (CTX_VARS_UNAVAILABLE(c))
+ fail (Error_Do_Expired_Frame_Raw());
+
+ DECLARE_FRAME (f);
+
+ // Apply_Frame_Core sets up most of the Reb_Frame, but expects these
+ // arguments to be filled in.
+ //
+ f->out = D_OUT;
+ f->gotten = CTX_FRAME_FUNC_VALUE(VAL_CONTEXT(source));
+ f->original = f->phase = VAL_FUNC(f->gotten);
+ f->binding = VAL_BINDING(source);
+
+ f->varlist = CTX_VARLIST(VAL_CONTEXT(source)); // need w/NULL def
+ SER(f->varlist)->misc.f = f;
+
+ return Apply_Frame_Core(f, Canon(SYM___ANONYMOUS__), NULL); }
+
+ default:
+ break;
+ }
+
+ // Note: it is not possible to write a wrapper function in Rebol
+ // which can do what EVAL can do for types that consume arguments
+ // (like SET-WORD!, SET-PATH! and FUNCTION!). DO used to do this for
+ // functions only, EVAL generalizes it.
+ //
+ fail (Error_Use_Eval_For_Eval_Raw());
+}
+
+
+//
+// do-all: native [
+//
+// {Execute a series of BAR!-separated statements with error/quit recovery.}
+//
+// return: [ any-value!]
+// block [block!]
+// ]
+//
+REBNATIVE(do_all)
+//
+// !!! The name of this construct is under review, as well as whether it
+// should be a block-of-blocks or use BAR!. It was added to try and solve
+// a problem, but then not used--however some variant of this feature is
+// useful.
+{
+ INCLUDE_PARAMS_OF_DO_ALL;
+
+ // Holds either an error value that is raised, or the thrown value.
+ //
+ DECLARE_LOCAL (arg_or_error);
+ SET_END(arg_or_error);
+ PUSH_GUARD_VALUE(arg_or_error);
+
+ // If arg_or_error is not end, but thrown_name is an end, a throw tried
+ // to propagate, but was caught...but if thrown_name is an end and the
+ // arg_or_error is also not, it is an error which tried to propagate.
+ //
+ DECLARE_LOCAL (thrown_name);
+ SET_END(thrown_name);
+ PUSH_GUARD_VALUE(thrown_name);
+
+ DECLARE_FRAME (f);
+ Push_Frame(f, ARG(block));
+
+ // The trap must be pushed *after* the frame has been pushed, so that
+ // when a fail() happens it won't pop the running frame.
+ //
+ struct Reb_State state;
+ REBCTX *error;
+
+repush:
+ PUSH_TRAP(&error, &state);
+
+ // The first time through the following code 'error' will be NULL, but...
+ // `fail` can longjmp here, so 'error' won't be NULL *if* that happens!
+
+ if (error) {
+ if (NOT_END(arg_or_error)) { // already a throw or fail pending!
+ DECLARE_LOCAL (arg1);
+ if (IS_END(thrown_name)) {
+ assert(IS_ERROR(arg_or_error));
+ Move_Value(arg1, arg_or_error);
+ }
+ else {
+ CONVERT_NAME_TO_THROWN(thrown_name, arg_or_error);
+ Init_Error(arg1, Error_No_Catch_For_Throw(thrown_name));
+ }
+
+ DECLARE_LOCAL (arg2);
+ Init_Error(arg2, error);
+
+ fail (Error_Multiple_Do_Errors_Raw(arg1, arg2));
+ }
+
+ f->eval_type = REB_0; // invariant of Do_Next_In_Frame
+
+ assert(IS_END(thrown_name));
+ Init_Error(arg_or_error, error);
+
+ while (NOT_END(f->value) && NOT(IS_BAR(f->value)))
+ Fetch_Next_In_Frame(f);
+
+ goto repush;
+ }
+
+ Init_Void(D_OUT); // default return result of DO-ALL []
+
+ while (NOT_END(f->value)) {
+ if (IS_BAR(f->value)) {
+ //
+ // BAR! is handled explicitly, because you might have f->value as
+ // the BAR! in `| asdf`, call into the evaluator and get an error,
+ // yet then come back and still have f->value positioned at the
+ // BAR!. This comes from how child frames and optimizations work.
+ // Hence it's not easy to know where to skip forward to in case
+ // of an error.
+ //
+ // !!! Review if the invariant of Do_Next_In_Frame_Throws()
+ // should be changed. So far, this is the only routine affected,
+ // because no other functions try and "resume" a throwing/failing
+ // frame--as that's not generically possible unless you skip to
+ // the next BAR!, as this routine does.
+ //
+ Init_Void(D_OUT);
+ Fetch_Next_In_Frame(f);
+ continue;
+ }
+
+ if (Do_Next_In_Frame_Throws(D_OUT, f)) {
+ if (NOT_END(arg_or_error)) { // already a throw or fail pending!
+ DECLARE_LOCAL (arg1);
+ if (IS_END(thrown_name)) {
+ assert(IS_ERROR(arg_or_error));
+ Move_Value(arg1, arg_or_error);
+ }
+ else {
+ CONVERT_NAME_TO_THROWN(thrown_name, arg_or_error);
+ Init_Error(arg1, Error_No_Catch_For_Throw(thrown_name));
+ }
+
+ DECLARE_LOCAL (arg2);
+ Init_Error(arg2, Error_No_Catch_For_Throw(D_OUT));
+
+ // We're still inside the pushed trap for this throw. Have
+ // to drop the trap to avoid transmitting the error to the
+ // `if (error)` longjmp branch above!
+ //
+ DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
+
+ fail (Error_Multiple_Do_Errors_Raw(arg1, arg2));
+ }
+
+ CATCH_THROWN(arg_or_error, D_OUT);
+ Move_Value(thrown_name, D_OUT); // THROWN cleared by CATCH_THROWN
+
+ while (NOT_END(f->value) && NOT(IS_BAR(f->value)))
+ Fetch_Next_In_Frame(f);
+ }
+ }
+
+ Drop_Frame(f);
+
+ DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
+
+ DROP_GUARD_VALUE(thrown_name); // no GC (via Do_Core()) after this point
+ DROP_GUARD_VALUE(arg_or_error);
+
+ if (IS_END(arg_or_error)) { // no throws or errors tried to propagate
+ assert(IS_END(thrown_name));
+ return R_OUT;
+ }
+
+ if (NOT_END(thrown_name)) { // throw tried propagating, re-throw it
+ Move_Value(D_OUT, thrown_name);
+ CONVERT_NAME_TO_THROWN(D_OUT, arg_or_error);
+ return R_OUT_IS_THROWN;
+ }
+
+ assert(IS_ERROR(arg_or_error));
+ fail (VAL_CONTEXT(arg_or_error)); // error tried propagating, re-raise it
+}
+
+
+//
+// apply: native [
+//
+// {Invoke a function with all required arguments specified.}
+//
+// return: [ any-value!]
+// value [function! any-word! any-path!]
+// {Function or specifying word (preserves word name for debug info)}
+// def [block!]
+// {Frame definition block (will be bound and evaluated)}
+// ]
+//
+REBNATIVE(apply)
+{
+ INCLUDE_PARAMS_OF_APPLY;
+
+ REBVAL *def = ARG(def);
+
+ DECLARE_FRAME (f);
+
+#if !defined(NDEBUG)
+ RELVAL *first_def = VAL_ARRAY_AT(def);
+
+ // !!! Because APPLY has changed, help warn legacy usages by alerting
+ // if the first element of the block is not a SET-WORD!. A BAR! can
+ // subvert the warning: `apply :foo [| comment {This is a new APPLY} ...]`
+ //
+ if (NOT_END(first_def)) {
+ if (!IS_SET_WORD(first_def) && !IS_BAR(first_def)) {
+ fail (Error_Apply_Has_Changed_Raw());
+ }
+ }
+#endif
+
+ // We don't limit to taking a FUNCTION! value directly, because that loses
+ // the symbol (for debugging, errors, etc.) If caller passes a WORD!
+ // then we lookup the variable to get the function, but save the symbol.
+ //
+ REBSTR *name;
+ Get_If_Word_Or_Path_Arg(D_OUT, &name, ARG(value));
+ if (name == NULL)
+ name = Canon(SYM___ANONYMOUS__); // Do_Core requires non-NULL symbol
+
+ if (!IS_FUNCTION(D_OUT))
+ fail (Error_Apply_Non_Function_Raw(ARG(value))); // for SPECIALIZE too
+
+ f->gotten = D_OUT;
+ f->out = D_OUT;
+
+ return Apply_Frame_Core(f, name, def);
+}
+
+
+//
+// also: native [
+//
+// {Returns the first value, but also evaluates the second.}
+//
+// return: [ any-value!]
+// returned [ any-value!]
+// evaluated [ any-value!]
+// ]
+//
+REBNATIVE(also)
+{
+ INCLUDE_PARAMS_OF_ALSO;
+
+ UNUSED(PAR(evaluated)); // not used (but was evaluated)
+ Move_Value(D_OUT, ARG(returned));
+ return R_OUT;
+}
+
+
+//
+// comment: native [
+//
+// {Ignores the argument value.}
+//
+// return: []
+// {Nothing.}
+// :value [block! any-string! binary! any-scalar!]
+// "Literal value to be ignored."
+// ]
+//
+REBNATIVE(comment)
+{
+ INCLUDE_PARAMS_OF_COMMENT;
+
+ // All the work was already done (at the cost of setting up
+ // state that would just have to be torn down).
+
+ UNUSED(PAR(value)); // avoid unused variable warning
+ return R_VOID;
+}
diff --git a/src/core/n-error.c b/src/core/n-error.c
new file mode 100644
index 0000000000..a6122fcb8f
--- /dev/null
+++ b/src/core/n-error.c
@@ -0,0 +1,197 @@
+//
+// File: %n-error.c
+// Summary: "native functions for raising and trapping errors"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Note that the mechanism by which errors are raised is based on longjmp(),
+// and thus can interrupt stacks in progress. Trapping errors is only done
+// by those levels of the stack that have done a PUSH_TRAP (as opposed to
+// detecting thrown values, that is "cooperative" and "bubbles" up through
+// every stack level in its return slot, with no longjmp()).
+//
+
+#include "sys-core.h"
+
+
+//
+// trap: native [
+//
+// {Tries to DO a block, trapping error as return value (if one is raised).}
+//
+// return: [ any-value!]
+// block [block!]
+// /with
+// "Handle error case with code"
+// handler [block! function!]
+// "If FUNCTION!, spec allows [error [error!]]"
+// /?
+// "Instead of result or error, return LOGIC! of if a trap occurred"
+// ]
+//
+REBNATIVE(trap)
+{
+ INCLUDE_PARAMS_OF_TRAP; // ? is renamed as "q"
+
+ struct Reb_State state;
+ REBCTX *error;
+
+ PUSH_TRAP(&error, &state);
+
+ // The first time through the following code 'error' will be NULL, but...
+ // `fail` can longjmp here, so 'error' won't be NULL *if* that happens!
+
+ if (error) {
+ if (REF(with)) {
+ REBVAL *handler = ARG(handler);
+
+ if (IS_BLOCK(handler)) {
+ // There's no way to pass 'error' to a block (so just DO it)
+ if (Do_Any_Array_At_Throws(D_OUT, ARG(handler)))
+ return R_OUT_IS_THROWN;
+
+ if (REF(q))
+ return R_TRUE;
+
+ return R_OUT;
+ }
+ else {
+ assert (IS_FUNCTION(handler));
+
+ DECLARE_LOCAL (arg);
+ Init_Error(arg, error);
+
+ // Try passing the handler the ERROR! we trapped. Passing
+ // FALSE for `fully` means it will not raise an error if
+ // the handler happens to be arity 0.
+ //
+ if (Apply_Only_Throws(D_OUT, FALSE, handler, arg, END))
+ return R_OUT_IS_THROWN;
+
+ if (REF(q))
+ return R_TRUE;
+
+ return R_OUT;
+ }
+ }
+
+ if (REF(q)) return R_TRUE;
+
+ Init_Error(D_OUT, error);
+ return R_OUT;
+ }
+
+ if (Do_Any_Array_At_Throws(D_OUT, ARG(block))) {
+ // Note that we are interested in when errors are raised, which
+ // causes a tricky C longjmp() to the code above. Yet a THROW
+ // is different from that, and offers an opportunity to each
+ // DO'ing stack level along the way to CATCH the thrown value
+ // (with no need for something like the PUSH_TRAP above).
+ //
+ // We're being given that opportunity here, but doing nothing
+ // and just returning the THROWN thing for other stack levels
+ // to look at. For the construct which does let you catch a
+ // throw, see REBNATIVE(catch), which has code for this case.
+
+ DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
+ return R_OUT_IS_THROWN;
+ }
+
+ DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
+
+ if (REF(q)) return R_FALSE;
+
+ return R_OUT;
+}
+
+
+//
+// set-location-of-error: native [
+//
+// {Sets the WHERE, NEAR, FILE, and LINE fields of an error}
+//
+// return: []
+// error [error!]
+// location [frame! any-word!]
+// ]
+//
+REBNATIVE(set_location_of_error)
+{
+ INCLUDE_PARAMS_OF_SET_LOCATION_OF_ERROR;
+
+ REBCTX *context;
+ if (IS_WORD(ARG(location)))
+ context = VAL_WORD_CONTEXT(ARG(location));
+ else
+ context = VAL_CONTEXT(ARG(location));
+
+ REBFRM *where = CTX_FRAME_IF_ON_STACK(context);
+ if (where == NULL)
+ fail (Error_Frame_Not_On_Stack_Raw());
+
+ REBCTX *error = VAL_CONTEXT(ARG(error));
+ Set_Location_Of_Error(error, where);
+
+ return R_VOID;
+}
+
+
+//
+// attempt: native [
+//
+// {Tries to evaluate a block and returns result or NONE on error.}
+//
+// return: [ any-value!]
+// block [block!]
+// ]
+//
+REBNATIVE(attempt)
+{
+ INCLUDE_PARAMS_OF_ATTEMPT;
+
+ REBVAL *block = ARG(block);
+
+ struct Reb_State state;
+ REBCTX *error;
+
+ PUSH_TRAP(&error, &state);
+
+ // The first time through the following code 'error' will be NULL, but...
+ // `fail` can longjmp here, so 'error' won't be NULL *if* that happens!
+
+ if (error) return R_BLANK;
+
+ if (Do_Any_Array_At_Throws(D_OUT, block)) {
+ DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
+
+ // Throw name is in D_OUT, thrown value is held task local
+ return R_OUT_IS_THROWN;
+ }
+
+ DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
+
+ return R_OUT;
+}
diff --git a/src/core/n-function.c b/src/core/n-function.c
new file mode 100644
index 0000000000..c797b481dd
--- /dev/null
+++ b/src/core/n-function.c
@@ -0,0 +1,797 @@
+//
+// File: %n-function.c
+// Summary: "native functions for creating and interacting with functions"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Ren-C follows a concept of a single FUNCTION! type, instead of the
+// subcategories from Rebol2 and R3-Alpha. This simplifies matters from the
+// user's point of view, and also moves to the idea of a different C native
+// "dispatcher" functions which are attached to the function's definition
+// itself. Not only does this allow a variety of performant customized
+// native dispatchers, but having the dispatcher accessed through an indirect
+// pointer instead of in the function REBVALs themselves lets them be
+// dynamically changed. This is used by HIJACK and by user natives.
+//
+
+#include "sys-core.h"
+
+//
+// func: native [
+//
+// "Defines a user function with given spec and body."
+//
+// return: [function!]
+// spec [block!]
+// {Help string (opt) followed by arg words (and opt type + string)}
+// body [block!]
+// "The body block of the function"
+// ]
+//
+REBNATIVE(func)
+//
+// Native optimized implementation of a "definitional return" function
+// generator. See comments on Make_Function_May_Fail for full notes.
+{
+ INCLUDE_PARAMS_OF_FUNC;
+
+ REBFUN *fun = Make_Interpreted_Function_May_Fail(
+ ARG(spec), ARG(body), MKF_RETURN | MKF_KEYWORDS
+ );
+
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+ return R_OUT;
+}
+
+
+//
+// proc: native [
+//
+// "Defines a user function with given spec and body and no return result."
+//
+// return: [function!]
+// spec [block!]
+// {Help string (opt) followed by arg words (and opt type + string)}
+// body [block!]
+// "The body block of the function, use LEAVE to exit"
+// ]
+//
+REBNATIVE(proc)
+//
+// Short for "PROCedure"; inspired by the Pascal language's discernment in
+// terminology of a routine that returns a value vs. one that does not.
+// Provides convenient interface similar to FUNC that will not accidentally
+// leak values to the caller.
+{
+ INCLUDE_PARAMS_OF_PROC;
+
+ REBFUN *fun = Make_Interpreted_Function_May_Fail(
+ ARG(spec), ARG(body), MKF_LEAVE | MKF_KEYWORDS
+ );
+
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+ return R_OUT;
+}
+
+
+//
+// Make_Thrown_Exit_Value: C
+//
+// This routine will generate a THROWN() value that can be used to indicate
+// a desire to exit from a particular level in the stack with a value (or void)
+//
+// It is used in the implementation of the EXIT native.
+//
+void Make_Thrown_Exit_Value(
+ REBVAL *out,
+ const REBVAL *level, // FRAME!, FUNCTION! (or INTEGER! relative to frame)
+ const REBVAL *value,
+ REBFRM *frame // only required if level is INTEGER!
+) {
+ Move_Value(out, NAT_VALUE(exit));
+
+ if (IS_INTEGER(level)) {
+ REBCNT count = VAL_INT32(level);
+ if (count <= 0)
+ fail (Error_Invalid_Exit_Raw());
+
+ REBFRM *f = frame->prior;
+ for (; TRUE; f = f->prior) {
+ if (f == NULL)
+ fail (Error_Invalid_Exit_Raw());
+
+ if (NOT(Is_Any_Function_Frame(f))) continue; // only exit functions
+
+ if (Is_Function_Frame_Fulfilling(f)) continue; // not ready to exit
+
+ #if !defined(NDEBUG)
+ if (LEGACY(OPTIONS_DONT_EXIT_NATIVES))
+ if (NOT(IS_FUNCTION_INTERPRETED(FUNC_VALUE(f->phase))))
+ continue; // R3-Alpha would exit the first user function
+ #endif
+
+ --count;
+
+ if (count == 0) {
+ //
+ // We want the integer-based exits to identify frames uniquely.
+ // Without a context varlist, a frame can't be unique.
+ //
+ Context_For_Frame_May_Reify_Managed(f);
+ assert(f->varlist);
+ out->extra.binding = f->varlist;
+ break;
+ }
+ }
+ }
+ else if (IS_FRAME(level)) {
+ out->extra.binding = CTX_VARLIST(VAL_CONTEXT(level));
+ }
+ else {
+ assert(IS_FUNCTION(level));
+ out->extra.binding = VAL_FUNC_PARAMLIST(level);
+ }
+
+ CONVERT_NAME_TO_THROWN(out, value);
+}
+
+
+//
+// exit: native [
+//
+// {Leave enclosing function, or jump /FROM.}
+//
+// /with
+// "Result for enclosing state (default is no value)"
+// value [any-value!]
+// /from
+// "Jump the stack to return from a specific frame or call"
+// level [frame! function! integer!]
+// "Frame, function, or stack index to exit from"
+// ]
+//
+REBNATIVE(exit)
+//
+// EXIT is implemented via a THROWN() value that bubbles up through the stack.
+// Using EXIT's function REBVAL with a target `binding` field is the
+// protocol understood by Do_Core to catch a throw itself.
+//
+// !!! Allowing to pass an INTEGER! to exit from a function based on its
+// BACKTRACE number is a bit low-level, and perhaps should be restricted to
+// a debugging mode (though it is a useful tool in "code golf").
+{
+ INCLUDE_PARAMS_OF_EXIT;
+
+ UNUSED(REF(with)); // implied by non-void value
+
+ if (NOT(REF(from)))
+ Init_Integer(ARG(level), 1); // default--exit one function stack level
+
+ Make_Thrown_Exit_Value(D_OUT, ARG(level), ARG(value), frame_);
+
+ return R_OUT_IS_THROWN;
+}
+
+
+//
+// return: native [
+//
+// "Returns a value from a function."
+//
+// value [ any-value!]
+// ]
+//
+REBNATIVE(return)
+{
+ INCLUDE_PARAMS_OF_RETURN;
+
+ REBVAL *value = ARG(value);
+ REBFRM *f = frame_; // implicit parameter to REBNATIVE()
+
+ if (f->binding == NULL) // raw native, not a variant FUNCTION made
+ fail (Error_Return_Archetype_Raw());
+
+ // The frame this RETURN is being called from may well not be the target
+ // function of the return (that's why it's a "definitional return"). So
+ // examine the binding. Currently it can be either a FRAME!'s varlist or
+ // a FUNCTION! paramlist.
+
+ REBFUN *target =
+ IS_FUNCTION(ARR_HEAD(f->binding))
+ ? AS_FUNC(f->binding)
+ : AS_FUNC(CTX_KEYLIST(CTX(f->binding)));
+
+ REBVAL *typeset = FUNC_PARAM(target, FUNC_NUM_PARAMS(target));
+ assert(VAL_PARAM_SYM(typeset) == SYM_RETURN);
+
+ // Check to make sure the types match. If it were not done here, then
+ // the error would not point out the bad call...just the function that
+ // wound up catching it.
+ //
+ if (!TYPE_CHECK(typeset, VAL_TYPE(value)))
+ fail (Error_Bad_Return_Type(
+ f->label, // !!! Should climb stack to get real label?
+ VAL_TYPE(value)
+ ));
+
+ Move_Value(D_OUT, NAT_VALUE(exit)); // see also Make_Thrown_Exit_Value
+ D_OUT->extra.binding = f->binding;
+
+ CONVERT_NAME_TO_THROWN(D_OUT, value);
+ return R_OUT_IS_THROWN;
+}
+
+
+//
+// leave: native [
+//
+// "Leaves a procedure, giving no result to the caller."
+//
+// ]
+//
+REBNATIVE(leave)
+//
+// See notes on REBNATIVE(return)
+{
+ if (frame_->binding == NULL) // raw native, not a variant PROCEDURE made
+ fail (Error_Return_Archetype_Raw());
+
+ Move_Value(D_OUT, NAT_VALUE(exit)); // see also Make_Thrown_Exit_Value
+ D_OUT->extra.binding = frame_->binding;
+
+ CONVERT_NAME_TO_THROWN(D_OUT, VOID_CELL);
+ return R_OUT_IS_THROWN;
+}
+
+
+//
+// typechecker: native [
+//
+// {Function generator for an optimized typechecking routine.}
+//
+// return: [function!]
+// type [datatype! typeset!]
+// ]
+//
+REBNATIVE(typechecker)
+{
+ INCLUDE_PARAMS_OF_TYPECHECKER;
+
+ REBVAL *type = ARG(type);
+
+ REBARR *paramlist = Make_Array_Core(2, ARRAY_FLAG_PARAMLIST);
+
+ REBVAL *archetype = Alloc_Tail_Array(paramlist);
+ VAL_RESET_HEADER(archetype, REB_FUNCTION);
+ archetype->payload.function.paramlist = paramlist;
+ archetype->extra.binding = NULL;
+
+ REBVAL *param = Alloc_Tail_Array(paramlist);
+ Init_Typeset(param, ALL_64, Canon(SYM_VALUE));
+ INIT_VAL_PARAM_CLASS(param, PARAM_CLASS_NORMAL);
+
+ MANAGE_ARRAY(paramlist);
+
+ // for now, no help...use REDESCRIBE
+
+ SER(paramlist)->link.meta = NULL;
+
+ REBFUN *fun = Make_Function(
+ paramlist,
+ IS_DATATYPE(type)
+ ? &Datatype_Checker_Dispatcher
+ : &Typeset_Checker_Dispatcher,
+ NULL, // this is fundamental (no distinct underlying function)
+ NULL // not providing a specialization
+ );
+
+ *FUNC_BODY(fun) = *type;
+
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+
+ return R_OUT;
+}
+
+
+//
+// specialize: native [
+//
+// {Create a new function through partial or full specialization of another}
+//
+// return: [function!]
+// value [function! any-word! any-path!]
+// {Function or specifying word (preserves word name for debug info)}
+// def [block!]
+// {Definition for FRAME! fields for args and refinements}
+// ]
+//
+REBNATIVE(specialize)
+{
+ INCLUDE_PARAMS_OF_SPECIALIZE;
+
+ REBSTR *opt_name;
+
+ // We don't limit to taking a FUNCTION! value directly, because that loses
+ // the symbol (for debugging, errors, etc.) If caller passes a WORD!
+ // then we lookup the variable to get the function, but save the symbol.
+ //
+ DECLARE_LOCAL (specializee);
+ Get_If_Word_Or_Path_Arg(specializee, &opt_name, ARG(value));
+
+ if (!IS_FUNCTION(specializee))
+ fail (Error_Apply_Non_Function_Raw(ARG(value))); // for APPLY too
+
+ if (Specialize_Function_Throws(D_OUT, specializee, opt_name, ARG(def)))
+ return R_OUT_IS_THROWN;
+
+ return R_OUT;
+}
+
+
+//
+// chain: native [
+//
+// {Create a processing pipeline of functions that consume the last's result}
+//
+// return: [function!]
+// pipeline [block!]
+// {List of functions to apply. Reduced by default.}
+// /quote
+// {Do not reduce the pipeline--use the values as-is.}
+// ]
+//
+REBNATIVE(chain)
+{
+ INCLUDE_PARAMS_OF_CHAIN;
+
+ REBVAL *out = D_OUT; // plan ahead for factoring into Chain_Function(out..
+
+ REBVAL *pipeline = ARG(pipeline);
+ REBARR *chainees;
+ if (REF(quote)) {
+ chainees = COPY_ANY_ARRAY_AT_DEEP_MANAGED(pipeline);
+ }
+ else {
+ if (Reduce_Any_Array_Throws(out, pipeline, REDUCE_FLAG_DROP_BARS))
+ return R_OUT_IS_THROWN;
+
+ chainees = VAL_ARRAY(out); // should be all specific values
+ ASSERT_ARRAY_MANAGED(chainees);
+ }
+
+ REBVAL *first = KNOWN(ARR_HEAD(chainees));
+
+ // !!! Current validation is that all are functions. Should there be other
+ // checks? (That inputs match outputs in the chain?) Should it be
+ // a dialect and allow things other than functions?
+ //
+ REBVAL *check = first;
+ while (NOT_END(check)) {
+ if (!IS_FUNCTION(check))
+ fail (check);
+ ++check;
+ }
+
+ // The paramlist needs to be unique to designate this function, but
+ // will be identical typesets to the first function in the chain. It's
+ // [0] element must identify the function we're creating vs the original,
+ // however.
+ //
+ REBARR *paramlist = Copy_Array_Shallow(
+ VAL_FUNC_PARAMLIST(ARR_HEAD(chainees)), SPECIFIED
+ );
+ ARR_HEAD(paramlist)->payload.function.paramlist = paramlist;
+ SET_SER_FLAG(paramlist, ARRAY_FLAG_PARAMLIST);
+ MANAGE_ARRAY(paramlist);
+
+ // See %sysobj.r for `chained-meta:` object template
+
+ REBVAL *std_meta = Get_System(SYS_STANDARD, STD_CHAINED_META);
+ REBCTX *meta = Copy_Context_Shallow(VAL_CONTEXT(std_meta));
+
+ Init_Void(CTX_VAR(meta, STD_CHAINED_META_DESCRIPTION)); // default
+ Init_Block(CTX_VAR(meta, STD_CHAINED_META_CHAINEES), chainees);
+ //
+ // !!! There could be a system for preserving names in the chain, by
+ // accepting lit-words instead of functions--or even by reading the
+ // GET-WORD!s in the block. Consider for the future.
+ //
+ Init_Void(CTX_VAR(meta, STD_CHAINED_META_CHAINEE_NAMES));
+
+ MANAGE_ARRAY(CTX_VARLIST(meta));
+ SER(paramlist)->link.meta = meta;
+
+ REBFUN *fun = Make_Function(
+ paramlist,
+ &Chainer_Dispatcher,
+ VAL_FUNC(first), // cache in paramlist
+ NULL // not changing the specialization
+ );
+
+ // "body" is the chainees array, available to the dispatcher when called
+ //
+ Init_Block(FUNC_BODY(fun), chainees);
+
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+ assert(VAL_BINDING(D_OUT) == NULL);
+
+ return R_OUT;
+}
+
+
+//
+// adapt: native [
+//
+// {Create a variant of a function that preprocesses its arguments}
+//
+// return: [function!]
+// adaptee [function! any-word! any-path!]
+// {Function or specifying word (preserves word name for debug info)}
+// prelude [block!]
+// {Code to run in constructed frame before adapted function runs}
+// ]
+//
+REBNATIVE(adapt)
+{
+ INCLUDE_PARAMS_OF_ADAPT;
+
+ REBVAL *adaptee = ARG(adaptee);
+
+ REBSTR *opt_adaptee_name;
+ Get_If_Word_Or_Path_Arg(D_OUT, &opt_adaptee_name, adaptee);
+ if (!IS_FUNCTION(D_OUT))
+ fail (Error_Apply_Non_Function_Raw(adaptee));
+
+ Move_Value(adaptee, D_OUT);
+
+ // For the binding to be correct, the indices that the words use must be
+ // the right ones for the frame pushed. So if you adapt a specialization
+ // that has one parameter, and the function that underlies that has
+ // 10 parameters and the one parameter you're adapting to is it's 10th
+ // and not its 1st...that has to be taken into account.
+ //
+ // Hence you must bind relative to that deeper function...e.g. the function
+ // behind the frame of the specialization which gets pushed.
+ //
+ REBFUN *underlying = FUNC_UNDERLYING(VAL_FUNC(adaptee));
+
+ // !!! In a future branch it may be possible that specific binding allows
+ // a read-only input to be "viewed" with a relative binding, and no copy
+ // would need be made if input was R/O. For now, we copy to relativize.
+ //
+ REBARR *prelude = Copy_And_Bind_Relative_Deep_Managed(
+ ARG(prelude),
+ FUNC_PARAMLIST(underlying),
+ TS_ANY_WORD
+ );
+
+ // The paramlist needs to be unique to designate this function, but
+ // will be identical typesets to the original. It's [0] element must
+ // identify the function we're creating vs the original, however.
+ //
+ REBARR *paramlist = Copy_Array_Shallow(
+ VAL_FUNC_PARAMLIST(adaptee), SPECIFIED
+ );
+ ARR_HEAD(paramlist)->payload.function.paramlist = paramlist;
+ SET_SER_FLAG(paramlist, ARRAY_FLAG_PARAMLIST);
+ MANAGE_ARRAY(paramlist);
+
+ // See %sysobj.r for `adapted-meta:` object template
+
+ REBVAL *example = Get_System(SYS_STANDARD, STD_ADAPTED_META);
+
+ REBCTX *meta = Copy_Context_Shallow(VAL_CONTEXT(example));
+ Init_Void(CTX_VAR(meta, STD_ADAPTED_META_DESCRIPTION)); // default
+ Move_Value(CTX_VAR(meta, STD_ADAPTED_META_ADAPTEE), adaptee);
+ if (opt_adaptee_name == NULL)
+ Init_Void(CTX_VAR(meta, STD_ADAPTED_META_ADAPTEE_NAME));
+ else
+ Init_Word(
+ CTX_VAR(meta, STD_ADAPTED_META_ADAPTEE_NAME),
+ opt_adaptee_name
+ );
+
+ MANAGE_ARRAY(CTX_VARLIST(meta));
+ SER(paramlist)->link.meta = meta;
+
+ REBFUN *fun = Make_Function(
+ paramlist,
+ &Adapter_Dispatcher,
+ underlying, // cache in paramlist
+ NULL // not changing the specialization
+ );
+
+ // We need to store the 2 values describing the adaptation so that the
+ // dispatcher knows what to do when it gets called and inspects FUNC_BODY.
+ //
+ // [0] is the prelude BLOCK!, [1] is the FUNCTION! we've adapted.
+ //
+ REBARR *adaptation = Make_Array(2);
+
+ REBVAL *block = Alloc_Tail_Array(adaptation);
+ VAL_RESET_HEADER_EXTRA(block, REB_BLOCK, VALUE_FLAG_RELATIVE);
+ INIT_VAL_ARRAY(block, prelude);
+ VAL_INDEX(block) = 0;
+ INIT_RELATIVE(block, underlying);
+
+ Append_Value(adaptation, adaptee);
+
+ RELVAL *body = FUNC_BODY(fun);
+ VAL_RESET_HEADER_EXTRA(body, REB_BLOCK, VALUE_FLAG_RELATIVE);
+ INIT_VAL_ARRAY(body, adaptation);
+ VAL_INDEX(body) = 0;
+ INIT_RELATIVE(body, underlying);
+ MANAGE_ARRAY(adaptation);
+
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+ assert(VAL_BINDING(D_OUT) == NULL);
+
+ return R_OUT;
+}
+
+
+//
+// hijack: native [
+//
+// {Cause all existing references to a function to invoke another function.}
+//
+// return: [function! blank!]
+// {The hijacked function value, blank if self-hijack (no-op).}
+// victim [function! any-word! any-path!]
+// {Function value whose references are to be affected.}
+// hijacker [function! any-word! any-path!]
+// {The function to run in its place.}
+// ]
+//
+REBNATIVE(hijack)
+//
+// The HIJACK operation replaces one function completely with another, such
+// that references to the old function value will now call a new one.
+//
+// Hijacking a function does not change its interface--and cannot. While
+// it may seem tempting to use low-level tricks to keep the same paramlist
+// but add or remove parameters, parameter lists can be referenced many
+// places in the system (frames, specializations, adaptations) and can't
+// be corrupted...or the places that rely on their properties (number and
+// types of parameters) would get out of sync.
+//
+{
+ INCLUDE_PARAMS_OF_HIJACK;
+
+ DECLARE_LOCAL (victim);
+ REBSTR *opt_victim_name;
+ Get_If_Word_Or_Path_Arg(victim, &opt_victim_name, ARG(victim));
+ if (!IS_FUNCTION(victim))
+ fail ("Victim of HIJACK must be a FUNCTION!");
+
+ DECLARE_LOCAL (hijacker);
+ REBSTR *opt_hijacker_name;
+ Get_If_Word_Or_Path_Arg(hijacker, &opt_hijacker_name, ARG(hijacker));
+ if (!IS_FUNCTION(hijacker))
+ fail ("Hijacker in HIJACK must be a FUNCTION!");
+
+ if (VAL_FUNC(victim) == VAL_FUNC(hijacker)) {
+ //
+ // Permitting a no-op hijack has some applications...but offer a
+ // distinguished result for those who want to detect the condition.
+ //
+ return R_BLANK;
+ }
+
+ REBARR *victim_paramlist = VAL_FUNC_PARAMLIST(victim);
+ REBARR *hijacker_paramlist = VAL_FUNC_PARAMLIST(hijacker);
+
+ if (
+ LOGICAL(
+ FUNC_UNDERLYING(VAL_FUNC(hijacker))
+ == FUNC_UNDERLYING(VAL_FUNC(victim))
+ )
+ ){
+ // Should the underlying functions of the hijacker and victim match,
+ // that means any ADAPT or CHAIN or SPECIALIZE of the victim can
+ // work equally well if we just use the hijacker's dispatcher
+ // directly. This is a reasonably common case, and especially
+ // common when putting the originally hijacked function back.
+
+ SER(victim_paramlist)->misc.facade =
+ SER(hijacker_paramlist)->misc.facade;
+ SER(victim->payload.function.body_holder)->link.exemplar =
+ SER(hijacker->payload.function.body_holder)->link.exemplar;
+
+ *VAL_FUNC_BODY(victim) = *VAL_FUNC_BODY(hijacker);
+ SER(victim->payload.function.body_holder)->misc.dispatcher =
+ SER(hijacker->payload.function.body_holder)->misc.dispatcher;
+ }
+ else {
+ // A mismatch means there could be someone out there pointing at this
+ // function who expects it to have a different frame than it does.
+ // In case that someone needs to run the function with that frame,
+ // a proxy "shim" is needed.
+ //
+ // !!! It could be possible to do things here like test to see if
+ // frames were compatible in some way that could accelerate the
+ // process of building a new frame. But in general one basically
+ // needs to do a new function call.
+ //
+ Move_Value(VAL_FUNC_BODY(victim), hijacker);
+ SER(victim->payload.function.body_holder)->misc.dispatcher =
+ &Hijacker_Dispatcher;
+ }
+
+ // Proxy the meta information from the hijacker onto the paramlist
+ //
+ // !!! Should this add a note about the hijacking?
+ //
+ SER(victim_paramlist)->link.meta =
+ SER(hijacker_paramlist)->link.meta;
+
+ Move_Value(D_OUT, victim);
+ D_OUT->extra.binding = hijacker->extra.binding;
+
+ return R_OUT;
+}
+
+
+//
+// variadic?: native [
+//
+// {Returns TRUE if a function may take a variable number of arguments.}
+//
+// func [function!]
+// ]
+//
+REBNATIVE(variadic_q)
+{
+ INCLUDE_PARAMS_OF_VARIADIC_Q;
+
+ REBVAL *param = VAL_FUNC_PARAMS_HEAD(ARG(func));
+ for (; NOT_END(param); ++param) {
+ if (GET_VAL_FLAG(param, TYPESET_FLAG_VARIADIC))
+ return R_TRUE;
+ }
+
+ return R_FALSE;
+}
+
+
+//
+// tighten: native [
+//
+// {Returns alias of a function whose "normal" args are gathered "tightly"}
+//
+// return: [function!]
+// action [function!]
+// ]
+//
+REBNATIVE(tighten)
+//
+// This routine exists to avoid the overhead of a user-function stub where
+// all the parameters are #tight, e.g. the behavior of R3-Alpha's OP!s.
+// So `+: enfix tighten :add` is a faster equivalent of:
+//
+// +: enfix func [#arg1 [any-value!] #arg2 [any-value!] [
+// add :arg1 :arg2
+// ]
+//
+// But also, the parameter types and help notes are kept in sync.
+//
+{
+ INCLUDE_PARAMS_OF_TIGHTEN;
+
+ REBFUN *original = VAL_FUNC(ARG(action));
+
+ // Copy the paramlist, which serves as the function's unique identity,
+ // and set the tight flag on all the parameters.
+
+ REBARR *paramlist = Copy_Array_Shallow(
+ FUNC_PARAMLIST(original),
+ SPECIFIED // no relative values in parameter lists
+ );
+ SET_SER_FLAG(paramlist, ARRAY_FLAG_PARAMLIST); // flags not auto-copied
+
+ RELVAL *param = ARR_AT(paramlist, 1); // first parameter (0 is FUNCTION!)
+ for (; NOT_END(param); ++param) {
+ enum Reb_Param_Class pclass = VAL_PARAM_CLASS(param);
+ if (pclass == PARAM_CLASS_NORMAL)
+ INIT_VAL_PARAM_CLASS(param, PARAM_CLASS_TIGHT);
+ }
+
+ RELVAL *rootparam = ARR_HEAD(paramlist);
+ CLEAR_VAL_FLAGS(rootparam, FUNC_FLAG_CACHED_MASK);
+ rootparam->payload.function.paramlist = paramlist;
+ rootparam->extra.binding = NULL;
+
+ // !!! This does not make a unique copy of the meta information context.
+ // Hence updates to the title/parameter-descriptions/etc. of the tightened
+ // function will affect the original, and vice-versa.
+ //
+ SER(paramlist)->link.meta = FUNC_META(original);
+
+ MANAGE_ARRAY(paramlist);
+
+ REBFUN *fun = Make_Function(
+ paramlist,
+ FUNC_DISPATCHER(original),
+ original, // used to set the initial facade (overridden below)
+ NULL // don't add any specialization beyond the original
+ );
+
+ // We're reusing the original dispatcher, so we also reuse the original
+ // function body.
+ //
+ *FUNC_BODY(fun) = *FUNC_BODY(original);
+
+ // Our function has a new identity, but we don't want to be using that
+ // identity for the pushed frame. If we did that, then if the underlying
+ // function were interpreted, we would have to make a copy of its body
+ // and rebind it to the new paramlist. HOWEVER we want the new tightened
+ // parameter specification to take effect--and that's not reflected in
+ // the original paramlist, e.g. the one to which that block is bound.
+ //
+ // So here's the clever part: functions allow you to offer a "facade"
+ // which is an array compatible with the original underlying function,
+ // but with stricter parameter types and different parameter classes.
+ // So just as the paramlist got transformed, transform the facade.
+
+ REBARR *facade = Copy_Array_Shallow(
+ FUNC_FACADE(original),
+ SPECIFIED // no relative values in facades, either
+ );
+ RELVAL *facade_param = ARR_AT(facade, 1);
+ for (; NOT_END(facade_param); ++facade_param) {
+ //
+ // !!! Technically we probably shouldn't be modifying the parameter
+ // classes of any arguments that were specialized out or otherwise
+ // not present in the original; but it shouldn't really matter.
+ // Once this function's layer has finished, the lower levels will
+ // refer to their own facades.
+ //
+ enum Reb_Param_Class pclass = VAL_PARAM_CLASS(facade_param);
+ if (pclass == PARAM_CLASS_NORMAL)
+ INIT_VAL_PARAM_CLASS(facade_param, PARAM_CLASS_TIGHT);
+ }
+
+ MANAGE_ARRAY(facade);
+
+ // Note: Do NOT set the ARRAY_FLAG_PARAMLIST on this facade. It holds
+ // whatever function value in the [0] slot the original had, and that is
+ // used for the identity of the "underlying function". (In order to make
+ // this a real FUNCTION!'s paramlist, the paramlist in the [0] slot would
+ // have to be equal to the facade's pointer.)
+ //
+ SER(paramlist)->misc.facade = facade;
+
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+
+ // Currently esoteric case if someone chose to tighten a definitional
+ // return, so `return 1 + 2` would return 1 instead of 3. Would need to
+ // preserve the binding of the incoming value, which is never present in
+ // the canon value of the function.
+ //
+ D_OUT->extra.binding = ARG(action)->extra.binding;
+
+ return R_OUT;
+}
diff --git a/src/core/n-graphics.c b/src/core/n-graphics.c
deleted file mode 100644
index 9653f87735..0000000000
--- a/src/core/n-graphics.c
+++ /dev/null
@@ -1,300 +0,0 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: n-graphics.c
-** Summary: native functions for graphical objects
-** Section: natives
-** Author: Carl Sassenrath
-** Notes:
-** Obsolete: Graphics is now implemented as an R3 extension.
-**
-***********************************************************************/
-
-#include "sys-core.h"
-
-
-#ifdef MOVED_TO_EXTENSION
-/***********************************************************************
-**
-*/ REBFLG Find_Gob_Tree(REBGOB *gob, REBGOB *tgob)
-/*
-** Scan a gob tree for the target gob. Return true or false.
-** Gob MUST have a pane (check for it first).
-**
-***********************************************************************/
-{
- REBGOB **gp;
- REBINT n;
-
- gp = GOB_HEAD(gob);
-
- for (n = GOB_TAIL(gob); n > 0; n--, gp++) {
- if (*gp == tgob) return TRUE;
- if (GOB_PANE(*gp) && Find_Gob_Tree(*gp, tgob)) return TRUE;
- }
-
- return FALSE;
-}
-
-/***********************************************************************
-**
-*/ REBNATIVE(show)
-/*
-***********************************************************************/
-{
-#ifndef NO_GRAPHICS
- REBVAL *val = D_ARG(1);
- REBVAL *val2;
- REBVAL *head;
- REBINT dsp; // temporarily store it on stack
-
- if (IS_GOB(val)) OS_SHOW_GOB(VAL_GOB(val));
- else if (IS_BLOCK(val)) {
- dsp = DSP + 1;
-
- // Reduce all words and paths of the GOB type.
- // THIS STAYS ON THE STACK (because stack is not used)
- Reduce_Type_Stack(VAL_SERIES(val), VAL_INDEX(val), REB_GOB);
-
- head = DS_GET(dsp);
-
- // Optimize: remove any gobs that are in subgobs.
- // Set all gobs in block as showable:
- for (val = head; NOT_END(val); val++) {
- if (IS_GOB(val)) VAL_SET_OPT(val, OPTS_TEMP);
- }
-
- // Foreach gob in block, scan for it in all gobs:
- for (val = head; NOT_END(val); val++) {
- if (IS_GOB(val)
- && GOB_PANE(VAL_GOB(val))
- && VAL_GET_OPT(val, OPTS_TEMP)
- ) {
- for (val2 = head; NOT_END(val2); val2++) {
- if (val != val2
- && IS_GOB(val2)
- && VAL_GET_OPT(val2, OPTS_TEMP)
- && Find_Gob_Tree(VAL_GOB(val), VAL_GOB(val2))
- ) {
- VAL_CLR_OPT(val2, OPTS_TEMP); // do not show it
- // break; // Keep going, can be: show [A B C A] (rare)
- }
- }
- }
- }
- // Show those that are left:
- for (val = head; NOT_END(val); val++) {
- if (VAL_GET_OPT(val, OPTS_TEMP)) {
- OS_SHOW_GOB(VAL_GOB(val));
- VAL_CLR_OPT(val, OPTS_TEMP);
- }
-// else {
-// Print("No-show: %r", val);
-// }
- }
- DSP = dsp - 1; // reset stack
- }
- else OS_SHOW_GOB(0);
-#endif
-
- return R_ARG1;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE (size_text)
-/*
-***********************************************************************/
-{
-#ifndef NO_GRAPHICS
- REBGOB *gob = VAL_GOB(D_ARG(1));
- REBPAR xy;
-
- if (!IS_GOB_TEXT(gob) && !IS_GOB_STRING(gob)) Trap_Arg(D_ARG(1)); //!!! better error
-
- OS_SIZE_TEXT(gob, &xy);
-
- VAL_SET(D_RET, REB_PAIR);
- VAL_PAIR(D_RET) = xy;
-#endif
- return R_RET;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE (caret_to_offset)
-/*
-***********************************************************************/
-{
-#ifndef NO_GRAPHICS
- REBGOB *gob = VAL_GOB(D_ARG(1));
- REBVAL *arg1 = D_ARG(2);
- REBVAL *arg2 = D_ARG(3);
- REBPAR xy;
- REBINT element;
- REBINT position;
-
- if (!IS_GOB_TEXT(gob) && !IS_GOB_STRING(gob)) Trap_Arg(D_ARG(1)); //!!! better error
-
- if (IS_INTEGER(arg1))
- element = Int32(arg1);
- else if (IS_BLOCK(arg1))
- element = VAL_INDEX(arg1);
-
- if (IS_INTEGER(arg2))
- position = Int32(arg2);
- else if (IS_STRING(arg2))
- position = VAL_INDEX(arg2);
-
- if (element < 0) Trap_Arg(arg1);
- if (position < 0) Trap_Arg(arg2);
-
- OS_CARET_TO_OFFSET(gob, &xy, element, position);
-
- VAL_SET(D_RET, REB_PAIR);
- VAL_PAIR(D_RET) = xy;
-#endif
- return R_RET;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE (offset_to_caret)
-/*
-***********************************************************************/
-{
-#ifndef NO_GRAPHICS
- REBGOB *gob = VAL_GOB(D_ARG(1));
- REBPAR xy = VAL_PAIR(D_ARG(2));
- REBINT element;
- REBINT position;
- REBSER *ser;
- REBVAL *val;
-
- if (!IS_GOB_TEXT(gob) && !IS_GOB_STRING(gob)) Trap_Arg(D_ARG(1)); //!!! better error
-
- OS_OFFSET_TO_CARET(gob, xy, &element, &position);
-
- if (IS_GOB_STRING(gob)) {
- Set_Series(REB_STRING, D_RET, GOB_CONTENT(gob));
- VAL_INDEX(D_RET) = position;
- } else {
- ser = Copy_Block(GOB_CONTENT(gob), 0);
- Set_Series(REB_BLOCK, D_RET, ser);
- if ((REBCNT)element < ser->tail) {
- VAL_INDEX(D_RET) = element;
- val = BLK_SKIP(ser, element);
- if (IS_WORD(val)) {
- val = Get_Var(val);
- *BLK_SKIP(ser, element) = *val;
- val = BLK_SKIP(ser, element);
- }
- if (ANY_STR(val)) {
- VAL_INDEX(val) = position;
- return R_RET;
- }
- }
- return R_NONE;
- }
-#endif
- return R_RET;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(draw)
-/*
-***********************************************************************/
-{
-#ifndef NO_GRAPHICS
- REBVAL *arg = D_ARG(1);
- REBVAL *image;
- REBINT err;
- REBSER *ser;
-
- if (IS_IMAGE(arg)) image = arg;
- else image = Make_Image(VAL_PAIR_X(arg), VAL_PAIR_Y(arg));
-
- *D_RET = *image;
- if (err = OS_DRAW_IMAGE(VAL_SERIES(image), ser = At_Head(D_ARG(2)))) {
- Trap_Word(RE_DIALECT, SYM_DRAW, BLK_SKIP(ser, (-err)-1));
- }
-#endif
- return R_RET;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(effect)
-/*
-***********************************************************************/
-{
-#ifndef NO_GRAPHICS
- REBVAL *arg = D_ARG(1);
- REBVAL *image;
- REBINT err;
- REBSER *ser;
-
- if (IS_IMAGE(arg)) image = arg;
- else image = Make_Image(VAL_PAIR_X(arg), VAL_PAIR_Y(arg));
-
- *D_RET = *image;
- if (err = OS_EFFECT_IMAGE(VAL_SERIES(image), ser = At_Head(D_ARG(2)))) {
- Trap_Word(RE_DIALECT, SYM_DRAW, BLK_SKIP(ser, (-err)-1));
- }
-#endif
- return R_RET;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(cursor)
-/*
-***********************************************************************/
-{
-#ifndef NO_GRAPHICS
- REBVAL *arg = D_ARG(1);
- REBINT n = 0;
-
- if (IS_INTEGER(arg)) n = Int32(arg);
- else if (IS_NONE(arg)) n = 0;
- else n = -1;
-
- OS_CURSOR_IMAGE(n, (n < 0) ? VAL_SERIES(arg) : 0);
-#endif
- return R_UNSET;
-}
-#endif
-
-/***********************************************************************
-**
-*/ void Trap_Image()
-/*
-***********************************************************************/
-{
- Trap0(RE_BAD_MEDIA);
-}
diff --git a/src/core/n-io.c b/src/core/n-io.c
old mode 100644
new mode 100755
index 08dd50e842..105aa1ee7d
--- a/src/core/n-io.c
+++ b/src/core/n-io.c
@@ -1,833 +1,930 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: n-io.c
-** Summary: native functions for input and output
-** Section: natives
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %n-io.c
+// Summary: "native functions for input and output"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-//#define HELPER
-
/** Helper Functions **************************************************/
-#ifdef HELPER
-// Used for file loading during very early development.
-static REBSER *Read_All_File(char *fname)
-{
- REBREQ file;
- REBSER *ser = 0;
-
- CLEAR(&file, sizeof(file));
-
- file.clen = sizeof(file);
- file.device = RDI_FILE;
- file.file.path = fname;
-
- SET_FLAG(file.modes, RFM_READ);
-
- OS_DO_DEVICE(&file, RDC_OPEN);
-
- if (file.error) return 0;
- ser = Make_Binary((REBCNT)(file.file.size));
-
- file.data = BIN_DATA(ser);
- file.length = (REBCNT)(file.file.size);
+//
+// form: native [
+//
+// "Converts a value to a human-readable string."
+//
+// value [ any-value!]
+// "The value to form"
+// ]
+//
+REBNATIVE(form)
+{
+ INCLUDE_PARAMS_OF_FORM;
- OS_DO_DEVICE(&file, RDC_READ);
+ REBVAL *value = ARG(value);
- if (file.error) {
- ser = 0;
- }
- else {
- ser->tail = file.actual;
- STR_TERM(ser);
- }
+ Init_String(D_OUT, Copy_Form_Value(value, 0));
- OS_DO_DEVICE(&file, RDC_CLOSE);
- return ser;
+ return R_OUT;
}
-#endif
-/***********************************************************************
-**
-*/ REBNATIVE(echo)
-/*
-***********************************************************************/
+//
+// mold: native [
+//
+// "Converts a value to a REBOL-readable string."
+//
+// value [any-value!]
+// "The value to mold"
+// /only
+// {For a block value, mold only its contents, no outer []}
+// /all
+// "Use construction syntax"
+// /flat
+// "No indentation"
+// ]
+//
+REBNATIVE(mold)
{
- REBVAL *val = D_ARG(1);
- REBSER *ser = 0;
+ INCLUDE_PARAMS_OF_MOLD;
- Echo_File(0);
+ REB_MOLD mo;
+ CLEARS(&mo);
+ if (REF(all)) SET_FLAG(mo.opts, MOPT_MOLD_ALL);
+ if (REF(flat)) SET_FLAG(mo.opts, MOPT_INDENT);
- if (IS_FILE(val))
- ser = Value_To_OS_Path(val);
- else if (IS_LOGIC(val) && IS_TRUE(val))
- ser = To_Local_Path("output.txt", 10, FALSE, TRUE);
+ Push_Mold(&mo);
- if (ser) {
- if (!Echo_File((REBCHR*)(ser->data))) Trap1(RE_CANNOT_OPEN, val);
- }
+ if (REF(only) && IS_BLOCK(ARG(value))) SET_FLAG(mo.opts, MOPT_ONLY);
- return R_RET;
-}
+ Mold_Value(&mo, ARG(value), TRUE);
+ Init_String(D_OUT, Pop_Molded_String(&mo));
-/***********************************************************************
-**
-*/ REBNATIVE(form)
-/*
-** Converts a value to a REBOL readable string.
-** value "The value to mold"
-** /only "For a block value, give only contents, no outer [ ]"
-** /all "Mold in serialized format"
-** /flat "No line indentation"
-**
-***********************************************************************/
-{
- Set_String(D_RET, Copy_Form_Value(D_ARG(1), 0));
- return R_RET;
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(mold)
-/*
-** Converts a value to a REBOL readable string.
-** value "The value to mold"
-** /only "For a block value, give only contents, no outer [ ]"
-** /all "Mold in serialized format"
-** /flat "No line indentation"
-**
-***********************************************************************/
+//
+// write-stdout: native [
+//
+// "Write text to standard output, or raw BINARY! (for control codes / CGI)"
+//
+// return: []
+// value [string! char! binary!]
+// "Text to write, if a STRING! or CHAR! is converted to OS format"
+// ]
+//
+REBNATIVE(write_stdout)
{
- REBVAL *val = D_ARG(1);
- REB_MOLD mo = {0};
+ INCLUDE_PARAMS_OF_WRITE_STDOUT;
+
+ REBVAL *v = ARG(value);
+
+ if (IS_BINARY(v)) { // raw output
+ Prin_OS_String(VAL_BIN_AT(v), VAL_LEN_AT(v), OPT_ENC_RAW);
+ }
+ else if (IS_CHAR(v)) { // useful for `write-stdout newline`, etc.
+ Prin_OS_String(&VAL_CHAR(v), 1, OPT_ENC_UNISRC | OPT_ENC_CRLF_MAYBE);
+ }
+ else { // string output translated to OS format
+ assert(IS_STRING(v));
+ if (VAL_BYTE_SIZE(v))
+ Prin_OS_String(VAL_BIN_AT(v), VAL_LEN_AT(v), OPT_ENC_CRLF_MAYBE);
+ else
+ Prin_OS_String(
+ VAL_UNI_AT(v),
+ VAL_LEN_AT(v),
+ OPT_ENC_UNISRC | OPT_ENC_CRLF_MAYBE
+ );
+ }
+
+ return R_VOID;
+}
- if (D_REF(3)) SET_FLAG(mo.opts, MOPT_MOLD_ALL);
- if (D_REF(4)) SET_FLAG(mo.opts, MOPT_INDENT);
- Reset_Mold(&mo);
+//
+// new-line: native [
+//
+// {Sets or clears the new-line marker within a block or group.}
+//
+// position [block! group!]
+// "Position to change marker (modified)"
+// mark
+// "Set TRUE for newline"
+// /all
+// "Set/clear marker to end of series"
+// /skip
+// {Set/clear marker periodically to the end of the series}
+// size [integer!]
+// ]
+//
+REBNATIVE(new_line)
+{
+ INCLUDE_PARAMS_OF_NEW_LINE;
- if (D_REF(2) && IS_BLOCK(val)) SET_FLAG(mo.opts, MOPT_ONLY);
+ RELVAL *value = VAL_ARRAY_AT(ARG(position));
+ REBOOL mark = IS_CONDITIONAL_TRUE(ARG(mark));
+ REBINT skip = 0;
+ REBCNT n;
- Mold_Value(&mo, val, TRUE);
+ if (REF(all)) skip = 1;
- Set_String(D_RET, Copy_String(mo.series, 0, -1));
+ if (REF(skip)) {
+ skip = Int32s(ARG(size), 1);
+ if (skip < 1) skip = 1;
+ }
- return R_RET;
-}
+ for (n = 0; NOT_END(value); n++, value++) {
+ if ((skip != 0) && (n % skip != 0)) continue;
+ if (mark)
+ SET_VAL_FLAG(value, VALUE_FLAG_LINE);
+ else
+ CLEAR_VAL_FLAG(value, VALUE_FLAG_LINE);
-/***********************************************************************
-**
-*/ REBNATIVE(print)
-/*
-***********************************************************************/
-{
- REBVAL *value = D_ARG(1);
+ if (skip == 0) break;
+ }
- if (IS_BLOCK(value)) Reduce_Block(VAL_SERIES(value), VAL_INDEX(value), 0);
- Print_Value(DS_TOP, 0, 0);
- return R_UNSET; // reloads ds
+ Move_Value(D_OUT, ARG(position));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(prin)
-/*
-***********************************************************************/
+//
+// new-line?: native [
+//
+// {Returns the state of the new-line marker within a block or group.}
+//
+// position [block! group!] "Position to check marker"
+// ]
+//
+REBNATIVE(new_line_q)
{
- REBVAL *value = D_ARG(1);
-
- if (IS_BLOCK(value)) Reduce_Block(VAL_SERIES(value), VAL_INDEX(value), 0);
- Prin_Value(DS_TOP, 0, 0);
- return R_UNSET; // reloads ds
-}
+ INCLUDE_PARAMS_OF_NEW_LINE_Q;
+ if (GET_VAL_FLAG(VAL_ARRAY_AT(ARG(position)), VALUE_FLAG_LINE))
+ return R_TRUE;
-/***********************************************************************
-**
-*/ REBNATIVE(new_line)
-/*
-***********************************************************************/
-{
- REBVAL *value = D_ARG(1);
- REBVAL *val;
- REBOOL cond = IS_TRUE(D_ARG(2));
- REBCNT n;
- REBINT skip = -1;
-
- val = VAL_BLK_DATA(value);
- if (D_REF(3)) skip = 1; // all
- if (D_REF(4)) { // skip
- skip = Int32s(D_ARG(5), 1); // size
- if (skip < 1) skip = 1;
- }
- for (n = 0; NOT_END(val); n++, val++) {
- if (cond ^ (n % skip != 0))
- VAL_SET_LINE(val);
- else
- VAL_CLR_LINE(val);
- if (skip < 0) break;
- }
-
- return R_ARG1;
+ return R_FALSE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(new_lineq)
-/*
-***********************************************************************/
+//
+// now: native [
+//
+// "Returns current date and time with timezone adjustment."
+//
+// /year
+// "Returns year only"
+// /month
+// "Returns month only"
+// /day
+// "Returns day of the month only"
+// /time
+// "Returns time only"
+// /zone
+// "Returns time zone offset from UCT (GMT) only"
+// /date
+// "Returns date only"
+// /weekday
+// {Returns day of the week as integer (Monday is day 1)}
+// /yearday
+// "Returns day of the year (Julian)"
+// /precise
+// "High precision time"
+// /utc
+// "Universal time (no zone)"
+// ]
+//
+REBNATIVE(now)
{
- if VAL_GET_LINE(VAL_BLK_DATA(D_ARG(1))) return R_TRUE;
- return R_FALSE;
+ INCLUDE_PARAMS_OF_NOW;
+
+ REBVAL *ret = D_OUT;
+ OS_GET_TIME(D_OUT);
+
+ if (NOT(REF(precise))) {
+ //
+ // The "time" field is measured in nanoseconds, and the historical
+ // meaning of not using precise measurement was to use only the
+ // seconds portion (with the nanoseconds set to 0). This achieves
+ // that by extracting the seconds and then multiplying by nanoseconds.
+ //
+ VAL_NANO(ret) = SECS_TO_NANO(VAL_SECS(ret));
+ }
+
+ if (REF(utc)) {
+ VAL_ZONE(ret) = 0;
+ }
+ else {
+ if (
+ REF(year)
+ || REF(month)
+ || REF(day)
+ || REF(time)
+ || REF(date)
+ || REF(weekday)
+ || REF(yearday)
+ ){
+ Adjust_Date_Zone(ret, FALSE); // Add time zone, adjust date/time
+ }
+ }
+
+ REBINT n = -1;
+
+ if (REF(date)) {
+ VAL_NANO(ret) = NO_TIME;
+ VAL_ZONE(ret) = 0;
+ }
+ else if (REF(time)) {
+ VAL_RESET_HEADER(ret, REB_TIME);
+ }
+ else if (REF(zone)) {
+ VAL_RESET_HEADER(ret, REB_TIME);
+ VAL_NANO(ret) = VAL_ZONE(ret) * ZONE_MINS * MIN_SEC;
+ }
+ else if (REF(weekday))
+ n = Week_Day(VAL_DATE(ret));
+ else if (REF(yearday))
+ n = Julian_Date(VAL_DATE(ret));
+ else if (REF(year))
+ n = VAL_YEAR(ret);
+ else if (REF(month))
+ n = VAL_MONTH(ret);
+ else if (REF(day))
+ n = VAL_DAY(ret);
+
+ if (n > 0)
+ Init_Integer(ret, n);
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(now)
-/*
-** Return the current date and time with timezone adjustment.
-**
-** 1 /year {Returns year only.}
-** 2 /month {Returns month only.}
-** 3 /day {Returns day of the month only.}
-** 4 /time {Returns time only.}
-** 5 /zone {Returns time zone offset from GMT only.}
-** 6 /date {Returns date only.}
-** 7 /weekday {Returns day of the week as integer (Monday is day 1).}
-** 8 /yearday {Returns day of the year (Julian)}
-** 9 /precise {Higher precision}
-** 10 /utc {Universal time (no zone)}
-**
-***********************************************************************/
-{
- REBOL_DAT dat;
- REBINT n = -1;
- REBVAL *ret = D_RET;
-
- OS_GET_TIME(&dat);
- if (!D_REF(9)) dat.nano = 0; // Not /precise
- Set_Date(ret, &dat);
- Current_Year = dat.year;
-
- if (D_REF(10)) { // UTC
- VAL_ZONE(ret) = 0;
- }
- else {
- if (D_REF(1) || D_REF(2) || D_REF(3) || D_REF(4)
- || D_REF(6) || D_REF(7) || D_REF(8))
- Adjust_Date_Zone(ret, FALSE); // Add time zone, adjust date and time
- }
-
- // Check for /date, /time, /zone
- if (D_REF(6)) { // date
- VAL_TIME(ret) = NO_TIME;
- VAL_ZONE(ret) = 0;
- }
- else if (D_REF(4)) { // time
- //if (dat.time == ???) SET_NONE(ret);
- VAL_SET(ret, REB_TIME);
- }
- else if (D_REF(5)) { // zone
- VAL_SET(ret, REB_TIME);
- VAL_TIME(ret) = VAL_ZONE(ret) * ZONE_MINS * MIN_SEC;
- }
- else if (D_REF(7)) n = Week_Day(VAL_DATE(ret));
- else if (D_REF(8)) n = Julian_Date(VAL_DATE(ret));
- else if (D_REF(1)) n = VAL_YEAR(ret);
- else if (D_REF(2)) n = VAL_MONTH(ret);
- else if (D_REF(3)) n = VAL_DAY(ret);
-
- if (n > 0) SET_INTEGER(ret, n);
-
- return R_RET;
-}
-
+//
+// Milliseconds_From_Value: C
+//
+// Note that this routine is used by the SLEEP extension, as well as by WAIT.
+//
+REBCNT Milliseconds_From_Value(const RELVAL *v) {
+ REBINT msec;
-#ifdef HELPER
-/***********************************************************************
-**
-*/ REBNATIVE(read_file)
-/*
-***********************************************************************/
-{
- REBSER *ser;
+ switch (VAL_TYPE(v)) {
+ case REB_INTEGER:
+ msec = 1000 * Int32(v);
+ break;
- ser = VAL_SERIES(D_ARG(1));
+ case REB_DECIMAL:
+ msec = cast(REBINT, 1000 * VAL_DECIMAL(v));
+ break;
- ser = Read_All_File(STR_HEAD(ser));
- if (!ser) Trap1(RE_CANNOT_OPEN, D_ARG(1));
+ case REB_TIME:
+ msec = cast(REBINT, VAL_NANO(v) / (SEC_SEC / 1000));
+ break;
- Set_Binary(D_RET, ser);
+ default:
+ panic (NULL); // avoid uninitialized msec warning
+ }
- return R_RET;
+ if (msec < 0)
+ fail (Error_Out_Of_Range(const_KNOWN(v)));
-#ifdef unused
- if (D_REF(2)) // /binary
- Set_Binary(ret, ser);
- else {
- SERIES_TAIL(ser) = Convert_CRLF(STR_HEAD(ser), SERIES_TAIL(ser));
- if (D_REF(3)) // /lines
- Set_Block(ret, Convert_Lines(ser));
- else
- Set_String(ret, ser);
- }
- return R_RET;
-#endif
+ return cast(REBCNT, msec);
}
-#endif
-/***********************************************************************
-**
-*/ REBNATIVE(wait)
-/*
-***********************************************************************/
+//
+// wait: native [
+//
+// "Waits for a duration, port, or both."
+//
+// value [any-number! time! port! block! blank!]
+// /all
+// "Returns all in a block"
+// /only
+// {only check for ports given in the block to this function}
+// ]
+//
+REBNATIVE(wait)
{
- REBVAL *val = D_ARG(1);
- REBINT timeout = 0; // in milliseconds
- REBSER *ports = 0;
- REBINT n = 0;
-
- SET_NONE(D_RET);
-
- if (IS_BLOCK(val)) {
- Reduce_Block(VAL_SERIES(val), VAL_INDEX(val), 0); // [stack-move]
- ports = VAL_SERIES(DS_TOP); // volatile after
- DS_RELOAD(ds);
- for (val = BLK_HEAD(ports); NOT_END(val); val++) { // find timeout
- if (Pending_Port(val)) n++;
- if (IS_INTEGER(val) || IS_DECIMAL(val)) break;
- }
- if (IS_END(val)) {
- if (n == 0) return R_NONE; // has no pending ports!
- // SET_NONE(val); // no timeout -- BUG: unterminated block in GC
- }
- }
-
- switch (VAL_TYPE(val)) {
- case REB_INTEGER:
- timeout = 1000 * Int32(val);
- goto chk_neg;
-
- case REB_DECIMAL:
- timeout = (REBINT)(1000 * VAL_DECIMAL(val));
- goto chk_neg;
-
- case REB_TIME:
- timeout = (REBINT) (VAL_TIME(val) / (SEC_SEC / 1000));
-chk_neg:
- if (timeout < 0) Trap_Range(val);
- break;
-
- case REB_PORT:
- if (!Pending_Port(val)) return R_NONE;
- ports = Make_Block(1);
- Append_Val(ports, val);
- // fall thru...
- case REB_NONE:
- case REB_END:
- timeout = ALL_BITS; // wait for all windows
- break;
-
- default:
- Trap_Arg(val);
- }
-
- // Prevent GC on temp port block:
- // Note: Port block is always a copy of the block.
- if (ports) Set_Block(D_RET, ports);
-
- // Process port events [stack-move]:
- if (!Wait_Ports(ports, timeout)) return R_NONE;
- if (!ports) return R_NONE;
- DS_RELOAD(ds);
-
- // Determine what port(s) waked us:
- Sieve_Ports(ports);
-
- if (!D_REF(2)) { // not /all ports
- val = BLK_HEAD(ports);
- if (IS_PORT(val)) *D_RET = *val;
- else SET_NONE(D_RET);
- }
-
- return R_RET;
+ INCLUDE_PARAMS_OF_WAIT;
+
+ REBCNT timeout = 0; // in milliseconds
+ REBARR *ports = NULL;
+ REBINT n = 0;
+
+ Init_Blank(D_OUT);
+
+ RELVAL *val;
+ if (IS_BLOCK(ARG(value))) {
+ DECLARE_LOCAL (unsafe); // temporary not safe from GC
+
+ if (Reduce_Any_Array_Throws(
+ unsafe, ARG(value), REDUCE_FLAG_DROP_BARS
+ )){
+ Move_Value(D_OUT, unsafe);
+ return R_OUT_IS_THROWN;
+ }
+
+ ports = VAL_ARRAY(unsafe);
+ for (val = ARR_HEAD(ports); NOT_END(val); val++) { // find timeout
+ if (Pending_Port(KNOWN(val))) n++;
+ if (IS_INTEGER(val)
+ || IS_DECIMAL(val)
+ || IS_TIME(val)
+ )
+ break;
+ }
+ if (IS_END(val)) {
+ if (n == 0) return R_BLANK; // has no pending ports!
+ else timeout = ALL_BITS; // no timeout provided
+ // Init_Blank(val); // no timeout -- BUG: unterminated block in GC
+ }
+ }
+ else
+ val = ARG(value);
+
+ if (NOT_END(val)) {
+ switch (VAL_TYPE(val)) {
+ case REB_INTEGER:
+ case REB_DECIMAL:
+ case REB_TIME:
+ timeout = Milliseconds_From_Value(val);
+ break;
+
+ case REB_PORT:
+ if (!Pending_Port(KNOWN(val))) return R_BLANK;
+ ports = Make_Array(1);
+ Append_Value(ports, KNOWN(val));
+ // fall thru...
+ case REB_BLANK:
+ timeout = ALL_BITS; // wait for all windows
+ break;
+
+ default:
+ fail (Error_Invalid_Arg_Core(val, SPECIFIED));
+ }
+ }
+
+ // Prevent GC on temp port block:
+ // Note: Port block is always a copy of the block.
+ if (ports)
+ Init_Block(D_OUT, ports);
+
+ // Process port events [stack-move]:
+ if (!Wait_Ports(ports, timeout, REF(only))) {
+ Sieve_Ports(NULL); // just reset the waked list
+ return R_BLANK;
+ }
+ if (!ports) return R_BLANK;
+
+ // Determine what port(s) waked us:
+ Sieve_Ports(ports);
+
+ if (NOT(REF(all))) {
+ val = ARR_HEAD(ports);
+ if (IS_PORT(val))
+ Move_Value(D_OUT, KNOWN(val));
+ else
+ Init_Blank(D_OUT);
+ }
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(wake_up)
-/*
-** Calls port update for native actors.
-** Calls port awake function.
-**
-***********************************************************************/
+//
+// wake-up: native [
+//
+// "Awake and update a port with event."
+//
+// port [port!]
+// event [event!]
+// ]
+//
+REBNATIVE(wake_up)
+//
+// Calls port update for native actors.
+// Calls port awake function.
{
- REBVAL *val = D_ARG(1);
- REBSER *port = VAL_PORT(val);
-
- if (SERIES_TAIL(port) < STD_PORT_MAX) Crash(9910);
-
- val = OFV(port, STD_PORT_ACTOR);
- if (IS_NATIVE(val)) {
- Do_Port_Action(port, A_UPDATE); // uses current stack frame
- }
-
- val = OFV(port, STD_PORT_AWAKE);
- if (ANY_FUNC(val)) {
- val = Apply_Func(0, val, D_ARG(2), 0);
- if (!(IS_LOGIC(val) && VAL_LOGIC(val))) return R_FALSE;
- }
- return R_TRUE; // wake it up
-}
+ INCLUDE_PARAMS_OF_WAKE_UP;
+ REBCTX *port = VAL_CONTEXT(ARG(port));
+ FAIL_IF_BAD_PORT(port);
-/***********************************************************************
-**
-*/ REBNATIVE(to_rebol_file)
-/*
-***********************************************************************/
-{
- REBVAL *arg = D_ARG(1);
- REBSER *ser;
+ REBVAL *actor = CTX_VAR(port, STD_PORT_ACTOR);
+ if (Is_Native_Port_Actor(actor)) {
+ //
+ // We don't pass `actor` or `event` in, because we just pass the
+ // current call info. The port action can re-read the arguments.
+ //
+ Do_Port_Action(frame_, port, SYM_UPDATE);
+ }
- ser = Value_To_REBOL_Path(arg, 0);
- if (!ser) Trap_Arg(arg);
- Set_Series(REB_FILE, D_RET, ser);
+ REBOOL woke_up = TRUE; // start by assuming success
- return R_RET;
-}
+ REBVAL *awake = CTX_VAR(port, STD_PORT_AWAKE);
+ if (IS_FUNCTION(awake)) {
+ const REBOOL fully = TRUE; // error if not all arguments consumed
+ if (Apply_Only_Throws(D_OUT, fully, awake, ARG(event), END))
+ fail (Error_No_Catch_For_Throw(D_OUT));
-/***********************************************************************
-**
-*/ REBNATIVE(to_local_file)
-/*
-***********************************************************************/
-{
- REBVAL *arg = D_ARG(1);
- REBSER *ser;
-
- ser = Value_To_Local_Path(arg, D_REF(2));
- if (!ser) Trap_Arg(arg);
- Set_Series(REB_STRING, D_RET, ser);
+ if (NOT(IS_LOGIC(D_OUT) && VAL_LOGIC(D_OUT)))
+ woke_up = FALSE;
+ }
- return R_RET;
+ return R_FROM_BOOL(woke_up);
}
-/***********************************************************************
-**
-*/ REBNATIVE(what_dir)
-/*
-***********************************************************************/
+//
+// to-rebol-file: native [
+//
+// {Converts a local system file path to a REBOL file path.}
+//
+// path [file! string!]
+// ]
+//
+REBNATIVE(to_rebol_file)
{
- REBSER *ser;
- REBCHR *lpath;
- REBINT len;
+ INCLUDE_PARAMS_OF_TO_REBOL_FILE;
- len = OS_GET_CURRENT_DIR(&lpath);
- ser = To_REBOL_Path(lpath, len, OS_WIDE, TRUE); // allocates extra for end /
- ASSERT1(ser, RP_MISC); // should never happen
- OS_FREE(lpath);
- Set_Series(REB_FILE, D_RET, ser);
+ REBVAL *arg = ARG(path);
- return R_RET;
+ REBSER *ser = Value_To_REBOL_Path(arg, FALSE);
+ if (ser == NULL)
+ fail (arg);
+
+ Init_File(D_OUT, ser);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(change_dir)
-/*
-***********************************************************************/
+//
+// to-local-file: native [
+//
+// {Converts a REBOL file path to the local system file path.}
+//
+// path [file! string!]
+// /full
+// {Prepends current dir for full path (for relative paths only)}
+// ]
+//
+REBNATIVE(to_local_file)
{
- REBVAL *arg = D_ARG(1);
- REBSER *ser;
- REBINT n;
- REBVAL val;
-
- ser = Value_To_OS_Path(arg);
- if (!ser) Trap_Arg(arg); // !!! ERROR MSG
+ INCLUDE_PARAMS_OF_TO_LOCAL_FILE;
- Set_String(&val, ser); // may be unicode or utf-8
- Check_Security(SYM_FILE, POL_EXEC, &val);
+ REBVAL *arg = ARG(path);
- n = OS_SET_CURRENT_DIR((void*)ser->data); // use len for bool
- if (!n) Trap_Arg(arg); // !!! ERROR MSG
+ REBSER *ser = Value_To_Local_Path(arg, REF(full));
+ if (ser == NULL)
+ fail (arg);
- return R_ARG1;
+ Init_String(D_OUT, ser);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(browse)
-/*
-***********************************************************************/
+//
+// what-dir: native [
+// "Returns the current directory path."
+// ; No arguments
+// ]
+//
+REBNATIVE(what_dir)
{
- REBINT r;
- REBCHR *url = 0;
- REBVAL *arg = D_ARG(1);
+ REBVAL *current_path = Get_System(SYS_OPTIONS, OPTIONS_CURRENT_PATH);
+
+ if (IS_FILE(current_path) || IS_BLANK(current_path)) {
+ //
+ // !!! Because of the need to track a notion of "current path" which
+ // could be a URL! as well as a FILE!, the state is stored in the
+ // system options. For now--however--it is "duplicate" in the case
+ // of a FILE!, because the OS has its own tracked state. We let the
+ // OS state win for files if they have diverged somehow--because the
+ // code was already here and it would be more compatible. But
+ // reconsider the duplication.
+
+ REBCHR *lpath;
+ REBINT len = OS_GET_CURRENT_DIR(&lpath);
+
+ // allocates extra for end `/`
+ REBSER *ser = To_REBOL_Path(
+ lpath, len, PATH_OPT_SRC_IS_DIR | (OS_WIDE ? PATH_OPT_UNI_SRC : 0)
+ );
+
+ OS_FREE(lpath);
+
+ Init_File(current_path, ser); // refresh in case they diverged
+ }
+ else if (NOT(IS_URL(current_path))) {
+ //
+ // Lousy error, but ATM the user can directly edit system/options.
+ // They shouldn't be able to (or if they can, it should be validated)
+ //
+ fail (current_path);
+ }
+
+ // Note the expectation is that WHAT-DIR will return a value that can be
+ // mutated by the caller without affecting future calls to WHAT-DIR, so
+ // the variable holding the current path must be copied.
+ //
+ Init_Any_Series_At(
+ D_OUT,
+ VAL_TYPE(current_path),
+ Copy_Sequence(VAL_SERIES(current_path)),
+ VAL_INDEX(current_path)
+ );
+
+ return R_OUT;
+}
- Check_Security(SYM_BROWSE, POL_EXEC, arg);
- if (IS_NONE(arg))
- return R_UNSET;
+//
+// change-dir: native [
+//
+// {Changes the current path (where scripts with relative paths will be run).}
+//
+// path [file! url!]
+// ]
+//
+REBNATIVE(change_dir)
+{
+ INCLUDE_PARAMS_OF_CHANGE_DIR;
- url = Val_Str_To_OS(arg);
+ REBVAL *arg = ARG(path);
+ REBVAL *current_path = Get_System(SYS_OPTIONS, OPTIONS_CURRENT_PATH);
- r = OS_BROWSE(url, 0);
+ if (IS_URL(arg)) {
+ // There is no directory listing protocol for HTTP (although this
+ // needs to be methodized to work for SFTP etc.) So this takes
+ // your word for it for the moment that it's a valid "directory".
+ //
+ // !!! Should it at least check for a trailing `/`?
+ }
+ else {
+ assert(IS_FILE(arg));
- if (r == 0) Trap1(RE_CALL_FAIL, Make_OS_Error());
+ REBSER *ser = Value_To_OS_Path(arg, TRUE);
+ if (ser == NULL)
+ fail (arg);
- return R_UNSET;
-}
+ DECLARE_LOCAL (val);
+ Init_String(val, ser); // may be unicode or utf-8
+ Check_Security(Canon(SYM_FILE), POL_EXEC, val);
+ if (!OS_SET_CURRENT_DIR(SER_HEAD(REBCHR, ser)))
+ fail (arg);
+ }
-/***********************************************************************
-**
-*/ REBNATIVE(call)
-/*
-***********************************************************************/
-{
- REBINT r;
- REBCHR *cmd;
- REBVAL *arg = D_ARG(1);
-
- Check_Security(SYM_CALL, POL_EXEC, arg);
-
- cmd = Val_Str_To_OS(arg);
- r = OS_CREATE_PROCESS(cmd, D_REF(2) ? 1 : 0);
-
- if (D_REF(2)) {
- SET_INTEGER(D_RET, r);
- return R_RET;
- }
-
- if (r < 0) Trap1(RE_CALL_FAIL, Make_OS_Error());
- return R_NONE;
+ Move_Value(current_path, arg);
+
+ Move_Value(D_OUT, ARG(path));
+ return R_OUT;
}
-#ifdef not_used
-/***********************************************************************
-**
-*/ REBNATIVE(launch)
-/*
-***********************************************************************/
+//
+// String_List_To_Array: C
+//
+// Convert a series of null terminated strings to an array of strings
+// separated with '='.
+//
+static REBARR *String_List_To_Array(REBCHR *str)
{
- REBVAL *val = Get_System(SYS_OPTIONS, OPTIONS_BOOT);
- REBVAL *script = D_ARG(1);
- REBSER *cmd;
- REBINT r;
-
- Check_Security(SYM_CALL, POL_EXEC, script);
-
- if (ANY_STR(val)) {
- cmd = Make_Binary(VAL_LEN(val) + VAL_LEN(script) + 4);
- Append_Byte(cmd, '"');
- Append_Bytes(cmd, VAL_BIN_DATA(val));
- Append_Byte(cmd, '"');
- if (!IS_NONE(script)) {
- Append_Byte(cmd, ' ');
- Append_Bytes(cmd, VAL_BIN_DATA(script)); // !!! convert file
- }
- if (D_REF(2)) {
- Append_Byte(cmd, ' ');
- Append_Bytes(cmd, VAL_BIN_DATA(D_ARG(3)));
- }
- Print("Launching: %s", STR_HEAD(cmd));
- r = OS_CREATE_PROCESS(STR_HEAD(cmd), 0);
- if (r < 0) Trap1(RE_CALL_FAIL, Make_OS_Error());
- }
- return R_NONE;
+ REBCNT n;
+ REBCNT len = 0;
+ REBCHR *start = str;
+ REBCHR *eq;
+ REBARR *array;
+
+ while ((n = OS_STRLEN(str))) {
+ len++;
+ str += n + 1; // next
+ }
+
+ array = Make_Array(len * 2);
+
+ str = start;
+ while ((eq = OS_STRCHR(str+1, '=')) && (n = OS_STRLEN(str))) {
+ Init_String(Alloc_Tail_Array(array), Copy_OS_Str(str, eq - str));
+ Init_String(
+ Alloc_Tail_Array(array), Copy_OS_Str(eq + 1, n - (eq - str) - 1)
+ );
+ str += n + 1; // next
+ }
+
+ return array;
}
-#endif
-/***********************************************************************
-**
-*/ static REBSER *String_List_To_Block(REBCHR *str)
-/*
-** Convert a series of null terminated strings to
-** a block of strings separated with '='.
-**
-***********************************************************************/
+//
+// Block_To_String_List: C
+//
+// Convert block of values to a string that holds
+// a series of null terminated strings, followed
+// by a final terminating string.
+//
+REBSER *Block_To_String_List(REBVAL *blk)
{
- REBCNT n;
- REBCNT len = 0;
- REBCHR *start = str;
- REBCHR *eq;
- REBSER *blk;
-
- while (n = LEN_STR(str)) {
- len++;
- str += n + 1; // next
- }
+ RELVAL *value;
- blk = Make_Block(len*2);
+ REB_MOLD mo;
+ CLEARS(&mo);
- str = start;
- while (NZ(eq = FIND_CHR(str+1, '=')) && NZ(n = LEN_STR(str))) {
- Set_Series(REB_STRING, Append_Value(blk), Copy_OS_Str(str, eq-str));
- Set_Series(REB_STRING, Append_Value(blk), Copy_OS_Str(eq+1, n-(eq-str)-1));
- str += n + 1; // next
- }
+ Push_Mold(&mo);
- Block_As_Map(blk);
+ for (value = VAL_ARRAY_AT(blk); NOT_END(value); value++) {
+ Mold_Value(&mo, value, FALSE);
+ Append_Codepoint_Raw(mo.series, '\0');
+ }
+ Append_Codepoint_Raw(mo.series, '\0');
- return blk;
+ return Pop_Molded_String(&mo);
}
-#ifdef TO_WIN32
-/***********************************************************************
-**
-*/ REBSER *Block_To_String_List(REBVAL *blk)
-/*
-** Convert block of values to a string that holds
-** a series of null terminated strings, followed
-** by a final terminating string.
-**
-***********************************************************************/
+//
+// File_List_To_Array: C
+//
+// Convert file directory and file name list to block.
+//
+static REBARR *File_List_To_Array(const REBCHR *str)
{
- REB_MOLD mo = {0};
- REBVAL *value;
-
- Reset_Mold(&mo);
-
- for (value = VAL_BLK_DATA(blk); NOT_END(value); value++) {
- Mold_Value(&mo, value, 0);
- Append_Byte(mo.series, 0);
- }
- Append_Byte(mo.series, 0);
+ REBCNT n;
+ REBCNT len = 0;
+ const REBCHR *start = str;
+ REBARR *blk;
+ REBSER *dir;
+
+ while ((n = OS_STRLEN(str))) {
+ len++;
+ str += n + 1; // next
+ }
+
+ blk = Make_Array(len);
+
+ // First is a dir path or full file path:
+ str = start;
+ n = OS_STRLEN(str);
+
+ if (len == 1) { // First is full file path
+ dir = To_REBOL_Path(str, n, (OS_WIDE ? PATH_OPT_UNI_SRC : 0));
+ Init_File(Alloc_Tail_Array(blk), dir);
+ }
+ else { // First is dir path for the rest of the files
+#ifdef TO_WINDOWS /* directory followed by files */
+ assert(sizeof(wchar_t) == sizeof(REBCHR));
+ dir = To_REBOL_Path(
+ str,
+ n,
+ PATH_OPT_UNI_SRC | PATH_OPT_FORCE_UNI_DEST | PATH_OPT_SRC_IS_DIR
+ );
+ str += n + 1; // next
+ len = SER_LEN(dir);
+ while ((n = OS_STRLEN(str))) {
+ SET_SERIES_LEN(dir, len);
+ Append_Uni_Uni(dir, cast(const REBUNI*, str), n);
+ Init_File(Alloc_Tail_Array(blk), Copy_String_Slimming(dir, 0, -1));
+ str += n + 1; // next
+ }
+#else /* absolute pathes already */
+ str += n + 1;
+ while ((n = OS_STRLEN(str))) {
+ dir = To_REBOL_Path(str, n, (OS_WIDE ? PATH_OPT_UNI_SRC : 0));
+ Init_File(Alloc_Tail_Array(blk), Copy_String_Slimming(dir, 0, -1));
+ str += n + 1; // next
+ }
+#endif
+ }
- return Copy_Series(mo.series); // Unicode
+ return blk;
}
-/***********************************************************************
-**
-*/ static REBSER *File_List_To_Block(REBCHR *str)
-/*
-** Convert file directory and file name list to block.
-**
-***********************************************************************/
+//
+// request-file: native [
+//
+// {Asks user to select a file and returns full file path (or block of paths).}
+//
+// /save
+// "File save mode"
+// /multi
+// {Allows multiple file selection, returned as a block}
+// /file
+// name [file!]
+// "Default file name or directory"
+// /title
+// text [string!]
+// "Window title"
+// /filter
+// list [block!]
+// "Block of filters (filter-name filter)"
+// ]
+//
+REBNATIVE(request_file)
{
- REBCNT n;
- REBCNT len = 0;
- REBCHR *start = str;
- REBSER *blk;
- REBSER *dir;
-
- while (n = LEN_STR(str)) {
- len++;
- str += n + 1; // next
- }
-
- blk = Make_Block(len);
-
- // First is a dir path or full file path:
- str = start;
- n = LEN_STR(str);
-
- if (len == 1) { // First is full file path
- dir = To_REBOL_Path(str, n, -1, 0);
- Set_Series(REB_FILE, Append_Value(blk), dir);
- }
- else { // First is dir path for the rest of the files
- dir = To_REBOL_Path(str, n, -1, TRUE);
- str += n + 1; // next
- len = dir->tail;
- while (n = LEN_STR(str)) {
- dir->tail = len;
- Append_Uni_Uni(dir, str, n);
- Set_Series(REB_FILE, Append_Value(blk), Copy_String(dir, 0, -1));
- str += n + 1; // next
- }
- }
-
- return blk;
+ INCLUDE_PARAMS_OF_REQUEST_FILE;
+
+ // !!! This routine used to have an ENABLE_GC and DISABLE_GC
+ // reference. It is not clear what that was protecting, but
+ // this code should be reviewed with GC "torture mode", and
+ // if any values are being created which cannot be GC'd then
+ // they should be created without handing them over to GC with
+ // MANAGE_SERIES() instead.
+
+ REBRFR fr;
+ CLEARS(&fr);
+ fr.files = OS_ALLOC_N(REBCHR, MAX_FILE_REQ_BUF);
+ fr.len = MAX_FILE_REQ_BUF/sizeof(REBCHR) - 2;
+ fr.files[0] = OS_MAKE_CH('\0');
+
+ if (REF(save))
+ SET_FLAG(fr.flags, FRF_SAVE);
+ if (REF(multi))
+ SET_FLAG(fr.flags, FRF_MULTI);
+
+ if (REF(file)) {
+ REBSER *ser = Value_To_OS_Path(ARG(name), TRUE);
+ REBINT n = SER_LEN(ser);
+
+ fr.dir = SER_HEAD(REBCHR, ser);
+
+ if (OS_CH_VALUE(fr.dir[n - 1]) != OS_DIR_SEP) {
+ if (n + 2 > fr.len)
+ n = fr.len - 2;
+ OS_STRNCPY(
+ cast(REBCHR*, fr.files),
+ SER_HEAD(REBCHR, ser),
+ n
+ );
+ fr.files[n] = OS_MAKE_CH('\0');
+ }
+ }
+
+ if (REF(filter)) {
+ REBSER *ser = Block_To_String_List(ARG(list));
+ fr.filter = SER_HEAD(REBCHR, ser);
+ }
+
+ if (REF(title)) {
+ // !!! By passing NULL we don't get backing series to protect!
+ fr.title = Val_Str_To_OS_Managed(NULL, ARG(text));
+ }
+
+ if (OS_REQUEST_FILE(&fr)) {
+ if (GET_FLAG(fr.flags, FRF_MULTI)) {
+ REBARR *array = File_List_To_Array(fr.files);
+ Init_Block(D_OUT, array);
+ }
+ else {
+ REBSER *ser = To_REBOL_Path(
+ fr.files, OS_STRLEN(fr.files), (OS_WIDE ? PATH_OPT_UNI_SRC : 0)
+ );
+ Init_File(D_OUT, ser);
+ }
+ } else
+ Init_Blank(D_OUT);
+
+ OS_FREE(fr.files);
+
+ return R_OUT;
}
-#endif
-/***********************************************************************
-**
-*/ REBNATIVE(request_file)
-/*
-***********************************************************************/
+//
+// get-env: native [
+//
+// {Returns the value of an OS environment variable (for current process).}
+//
+// return: [string! blank!]
+// {The string of the environment variable, or blank if not set}
+// var [any-string! any-word!]
+// ]
+//
+REBNATIVE(get_env)
{
-#ifdef TO_WIN32
- REBRFR fr = {0};
- REBSER *ser;
- REBINT n;
-
- fr.files = OS_MAKE(MAX_FILE_REQ_BUF);
- fr.len = MAX_FILE_REQ_BUF/sizeof(REBCHR) - 2;
- fr.files[0] = 0;
-
- DISABLE_GC;
-
- if (D_REF(ARG_REQUEST_FILE_SAVE)) SET_FLAG(fr.flags, FRF_SAVE);
- if (D_REF(ARG_REQUEST_FILE_MULTI)) SET_FLAG(fr.flags, FRF_MULTI);
-
- if (D_REF(ARG_REQUEST_FILE_FILE)) {
- ser = Value_To_OS_Path(D_ARG(ARG_REQUEST_FILE_NAME));
- fr.dir = (REBCHR*)(ser->data);
- n = ser->tail;
- if (fr.dir[n-1] != OS_DIR_SEP) {
- if (n+2 > fr.len) n = fr.len - 2;
- COPY_STR(fr.files, (REBCHR*)(ser->data), n);
- fr.files[n] = 0;
- }
- }
-
- if (D_REF(ARG_REQUEST_FILE_FILTER)) {
- ser = Block_To_String_List(D_ARG(ARG_REQUEST_FILE_LIST));
- fr.filter = (REBCHR*)(ser->data);
- }
-
- if (D_REF(ARG_REQUEST_FILE_TITLE))
- fr.title = Val_Str_To_OS(D_ARG(ARG_REQUEST_FILE_TEXT));
-
- if (OS_REQUEST_FILE(&fr)) {
- if (GET_FLAG(fr.flags, FRF_MULTI)) {
- ser = File_List_To_Block(fr.files);
- Set_Block(D_RET, ser);
- }
- else {
- ser = To_REBOL_Path(fr.files, LEN_STR(fr.files), OS_WIDE, 0);
- Set_Series(REB_FILE, D_RET, ser);
- }
- } else
- ser = 0;
-
- ENABLE_GC;
- OS_FREE(fr.files);
-
- return ser ? R_RET : R_NONE;
-#else
- return R_NONE;
-#endif
-}
+ INCLUDE_PARAMS_OF_GET_ENV;
+ REBVAL *var = ARG(var);
-/***********************************************************************
-**
-*/ REBNATIVE(get_env)
-/*
-***********************************************************************/
-{
- REBCHR *cmd;
- REBINT lenplus;
- REBCHR *buf;
- REBVAL *arg = D_ARG(1);
+ Check_Security(Canon(SYM_ENVR), POL_READ, var);
- Check_Security(SYM_ENVR, POL_READ, arg);
+ if (ANY_WORD(var)) {
+ REBSER *copy = Copy_Form_Value(var, 0);
+ Init_String(var, copy);
+ }
- if (ANY_WORD(arg)) Set_String(arg, Copy_Form_Value(arg, 0));
- cmd = Val_Str_To_OS(arg);
+ // !!! By passing NULL we don't get backing series to protect!
+ REBCHR *os_var = Val_Str_To_OS_Managed(NULL, var);
- lenplus = OS_GET_ENV(cmd, (REBCHR*)0, 0);
- if (lenplus == 0) return R_NONE;
- if (lenplus < 0) return R_UNSET;
+ REBINT lenplus = OS_GET_ENV(NULL, os_var, 0);
+ if (lenplus < 0)
+ return R_BLANK;
+ if (lenplus == 0) {
+ Init_String(D_OUT, Copy_Sequence(VAL_SERIES(EMPTY_STRING)));
+ return R_OUT;
+ }
- // Two copies...is there a better way?
- buf = MAKE_STR(lenplus);
- OS_GET_ENV(cmd, buf, lenplus);
- Set_String(D_RET, Copy_OS_Str(buf, lenplus - 1));
- FREE_MEM(buf);
+ // Two copies...is there a better way?
+ REBCHR *buf = ALLOC_N(REBCHR, lenplus);
+ OS_GET_ENV(buf, os_var, lenplus);
+ Init_String(D_OUT, Copy_OS_Str(buf, lenplus - 1));
+ FREE_N(REBCHR, lenplus, buf);
- return R_RET;
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(set_env)
-/*
-***********************************************************************/
+//
+// set-env: native [
+//
+// {Sets value of operating system environment variable for current process.}
+//
+// var [any-string! any-word!]
+// "Variable to set"
+// value [string! blank!]
+// "Value to set, or a BLANK! to unset it"
+// ]
+//
+REBNATIVE(set_env)
{
- REBCHR *cmd;
- REBVAL *arg1 = D_ARG(1);
- REBVAL *arg2 = D_ARG(2);
- REBOOL success;
-
- Check_Security(SYM_ENVR, POL_WRITE, arg1);
-
- if (ANY_WORD(arg1)) Set_String(arg1, Copy_Form_Value(arg1, 0));
- cmd = Val_Str_To_OS(arg1);
-
- if (ANY_STR(arg2)) {
- REBCHR *value = Val_Str_To_OS(arg2);
- success = OS_SET_ENV(cmd, value);
- if (success) {
- // What function could reuse arg2 as-is?
- Set_String(D_RET, Copy_OS_Str(value, LEN_STR(value)));
- return R_RET;
- }
- return R_UNSET;
- }
-
- if (IS_NONE(arg2)) {
- success = OS_SET_ENV(cmd, 0);
- if (success)
- return R_NONE;
- return R_UNSET;
- }
-
- // is there any checking that native interface has not changed
- // out from under the expectations of the code?
-
- return R_UNSET;
+ INCLUDE_PARAMS_OF_SET_ENV;
+
+ REBVAL *var = ARG(var);
+ REBVAL *value = ARG(value);
+
+ Check_Security(Canon(SYM_ENVR), POL_WRITE, var);
+
+ if (ANY_WORD(var)) {
+ REBSER *copy = Copy_Form_Value(var, 0);
+ Init_String(var, copy);
+ }
+
+ // !!! By passing NULL we don't get backing series to protect!
+ REBCHR *os_var = Val_Str_To_OS_Managed(NULL, var);
+
+ if (ANY_STRING(value)) {
+ // !!! By passing NULL we don't get backing series to protect!
+ REBCHR *os_value = Val_Str_To_OS_Managed(NULL, value);
+ if (OS_SET_ENV(os_var, os_value)) {
+ // What function could reuse arg2 as-is?
+ Init_String(D_OUT, Copy_OS_Str(os_value, OS_STRLEN(os_value)));
+ return R_OUT;
+ }
+ return R_VOID;
+ }
+
+ assert(IS_BLANK(value));
+
+ if (OS_SET_ENV(os_var, NULL))
+ return R_BLANK;
+ return R_VOID;
}
-/***********************************************************************
-**
-*/ REBNATIVE(list_env)
-/*
-***********************************************************************/
+//
+// list-env: native [
+//
+// {Returns a map of OS environment variables (for current process).}
+//
+// ; No arguments
+// ]
+//
+REBNATIVE(list_env)
{
- REBCHR *result = OS_LIST_ENV();
-
- Set_Series(REB_MAP, D_RET, String_List_To_Block(result));
+ REBARR *array = String_List_To_Array(OS_LIST_ENV());
+ REBMAP *map = Mutate_Array_Into_Map(array);
+ Init_Map(D_OUT, map);
- return R_RET;
+ return R_OUT;
}
+
diff --git a/src/core/n-loop.c b/src/core/n-loop.c
old mode 100644
new mode 100755
index 18c1ae7efb..5576bafb0a
--- a/src/core/n-loop.c
+++ b/src/core/n-loop.c
@@ -1,686 +1,1317 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: n-loop.c
-** Summary: native functions for loops
-** Section: natives
-** Author: Carl Sassenrath
-** Notes:
-** Warning: Do not cache pointer to stack ARGS (stack may expand).
-**
-***********************************************************************/
+//
+// File: %n-loop.c
+// Summary: "native functions for loops"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
+#include "sys-int-funcs.h" //REB_I64_ADD_OF
+
+typedef enum {
+ LOOP_FOR_EACH,
+ LOOP_REMOVE_EACH,
+ LOOP_MAP_EACH,
+ LOOP_EVERY
+} LOOP_MODE;
+
+
+//
+// Catching_Break_Or_Continue: C
+//
+// Determines if a thrown value is either a break or continue. If so,
+// modifies `val` to be the throw's argument, sets `stop` flag if it
+// was a BREAK or BREAK/WITH, and returns TRUE.
+//
+// If FALSE is returned then the throw name `val` was not a break
+// or continue, and needs to be bubbled up or handled another way.
+//
+REBOOL Catching_Break_Or_Continue(REBVAL *val, REBOOL *stop)
+{
+ assert(THROWN(val));
+
+ // Throw /NAME-s used by CONTINUE and BREAK are the actual native
+ // function values of the routines themselves.
+ if (!IS_FUNCTION(val))
+ return FALSE;
+
+ if (VAL_FUNC_DISPATCHER(val) == &N_break) {
+ *stop = TRUE; // was BREAK or BREAK/WITH
+ CATCH_THROWN(val, val); // will be void if no /WITH was used
+ return TRUE;
+ }
+
+ if (VAL_FUNC_DISPATCHER(val) == &N_continue) {
+ *stop = FALSE; // was CONTINUE or CONTINUE/WITH
+ CATCH_THROWN(val, val); // will be void if no /WITH was used
+ return TRUE;
+ }
+
+ // Else: Let all other thrown values bubble up.
+ return FALSE;
+}
-/***********************************************************************
-**
-*/ static REBSER *Init_Loop(REBVAL *spec, REBVAL *body_blk, REBSER **fram)
-/*
-** Initialize standard for loops (copy block, make frame, bind).
-** Spec: WORD or [WORD ...]
-**
-***********************************************************************/
+//
+// break: native [
+//
+// {Exit the current iteration of a loop and stop iterating further.}
+//
+// /with
+// {Act as if loop body finished current evaluation with a value}
+// value [any-value!]
+// ]
+//
+REBNATIVE(break)
+//
+// BREAK is implemented via a THROWN() value that bubbles up through
+// the stack. It uses the value of its own native function as the
+// name of the throw, like `throw/name value :break`.
{
- REBSER *frame;
- REBINT len;
- REBVAL *word;
- REBVAL *vals;
- REBSER *body;
-
- // For :WORD format, get the var's value:
- if (IS_GET_WORD(spec)) spec = Get_Var(spec);
-
- // Hand-make a FRAME (done for for speed):
- len = IS_BLOCK(spec) ? VAL_LEN(spec) : 1;
- if (len == 0) Trap_Arg(spec);
- frame = Make_Frame(len);
- SET_SELFLESS(frame);
- SERIES_TAIL(frame) = len+1;
- SERIES_TAIL(FRM_WORD_SERIES(frame)) = len+1;
-
- // Setup for loop:
- word = FRM_WORD(frame, 1); // skip SELF
- vals = BLK_SKIP(frame, 1);
- if (IS_BLOCK(spec)) spec = VAL_BLK_DATA(spec);
-
- // Optimally create the FOREACH frame:
- while (len-- > 0) {
- if (!IS_WORD(spec) && !IS_SET_WORD(spec)) {
- // Prevent inconsistent GC state:
- Free_Series(FRM_WORD_SERIES(frame));
- Free_Series(frame);
- Trap_Arg(spec);
- }
- VAL_SET(word, VAL_TYPE(spec));
- VAL_BIND_SYM(word) = VAL_WORD_SYM(spec);
- VAL_BIND_TYPESET(word) = ALL_64;
- word++;
- SET_NONE(vals);
- vals++;
- spec++;
- }
- SET_END(word);
- SET_END(vals);
-
- body = Clone_Block_Value(body_blk);
- Bind_Block(frame, BLK_HEAD(body), BIND_DEEP);
-
- *fram = frame;
-
- return body;
+ INCLUDE_PARAMS_OF_BREAK;
+
+ Move_Value(D_OUT, NAT_VALUE(break));
+
+ CONVERT_NAME_TO_THROWN(D_OUT, REF(with) ? ARG(value) : VOID_CELL);
+
+ return R_OUT_IS_THROWN;
}
-/***********************************************************************
-**
-*/ static void Loop_Series(REBVAL *var, REBSER* body, REBVAL *start, REBINT ei, REBINT ii)
-/*
-***********************************************************************/
+//
+// continue: native [
+//
+// "Throws control back to top of loop for next iteration."
+//
+// /with
+// {Act as if loop body finished current evaluation with a value}
+// value [any-value!]
+// ]
+//
+REBNATIVE(continue)
+//
+// CONTINUE is implemented via a THROWN() value that bubbles up through
+// the stack. It uses the value of its own native function as the
+// name of the throw, like `throw/name value :continue`.
{
- REBVAL *result;
- REBINT si = VAL_INDEX(start);
- REBCNT type = VAL_TYPE(start);
-
- *var = *start;
-
- if (ei >= (REBINT)VAL_TAIL(start)) ei = (REBINT)VAL_TAIL(start);
- if (ei < 0) ei = 0;
-
- for (; (ii > 0) ? si <= ei : si >= ei; si += ii) {
- VAL_INDEX(var) = si;
- result = Do_Blk(body, 0);
- if (THROWN(result) && Check_Error(result) >= 0) break;
- if (VAL_TYPE(var) != type) Trap1(RE_INVALID_TYPE, var);
- si = VAL_INDEX(var);
- }
+ INCLUDE_PARAMS_OF_CONTINUE;
+
+ Move_Value(D_OUT, NAT_VALUE(continue));
+
+ CONVERT_NAME_TO_THROWN(D_OUT, REF(with) ? ARG(value) : VOID_CELL);
+
+ return R_OUT_IS_THROWN;
}
-/***********************************************************************
-**
-*/ static void Loop_Integer(REBVAL *var, REBSER* body, REBI64 start, REBI64 end, REBI64 incr)
-/*
-***********************************************************************/
-{
- REBVAL *result;
-
- VAL_SET(var, REB_INTEGER);
-
- for (; (incr > 0) ? start <= end : start >= end; start += incr) {
- VAL_INT64(var) = start;
- result = Do_Blk(body, 0);
- if (THROWN(result) && Check_Error(result) >= 0) break;
- if (!IS_INTEGER(var)) Trap_Type(var);
- start = VAL_INT64(var);
- }
+//
+// Copy_Body_Deep_Bound_To_New_Context: C
+//
+// Looping constructs which are parameterized by WORD!s to set each time
+// through the loop must copy the body in R3-Alpha's model. For instance:
+//
+// for-each [x y] [1 2 3] [print ["this body must be copied for" x y]]
+//
+// The reason is because the context in which X and Y live does not exist
+// prior to the execution of the FOR-EACH. And if the body were destructively
+// rebound, then this could mutate and disrupt bindings of code that was
+// intended to be reused.
+//
+// (Note that R3-Alpha was somewhat inconsistent on the idea of being
+// sensitive about non-destructively binding arguments in this way.
+// MAKE OBJECT! purposefully mutated bindings in the passed-in block.)
+//
+// The context is effectively an ordinary object, and outlives the loop:
+//
+// x-word: none
+// for-each x [1 2 3] [x-word: 'x | break]
+// get x-word ;-- returns 1
+//
+// !!! Ren-C managed to avoid deep copying function bodies yet still get
+// "specific binding" by means of "relative values" (RELVALs) and specifiers.
+// Extending this approach is hoped to be able to avoid the deep copy. It
+// may also be that the underlying data of the
+//
+// !!! With stack-backed contexts in Ren-C, it may be the case that the
+// chunk stack is used as backing memory for the loop, so it can be freed
+// when the loop is over and word lookups will error.
+//
+// Note that because we are copying the block in order to rebind it, the
+// ensuing loop code will `Do_At_Throws(out, body, 0);`. Starting at
+// zero is correct because the duplicate body has already had the
+// items before its VAL_INDEX() omitted.
+//
+static REBARR *Copy_Body_Deep_Bound_To_New_Context(
+ REBCTX **context_out,
+ const REBVAL *spec,
+ REBVAL *body
+) {
+ assert(IS_BLOCK(body));
+
+ REBINT num_vars = IS_BLOCK(spec) ? VAL_LEN_AT(spec) : 1;
+ if (num_vars == 0)
+ fail (spec);
+
+ REBCTX *context = Alloc_Context(REB_OBJECT, num_vars);
+ TERM_ARRAY_LEN(CTX_VARLIST(context), num_vars + 1);
+ TERM_ARRAY_LEN(CTX_KEYLIST(context), num_vars + 1);
+
+ REBVAL *key = CTX_KEYS_HEAD(context);
+ REBVAL *var = CTX_VARS_HEAD(context);
+
+ const RELVAL *item;
+ REBSPC *specifier;
+ if (IS_BLOCK(spec)) {
+ item = VAL_ARRAY_AT(spec);
+ specifier = VAL_SPECIFIER(spec);
+ }
+ else {
+ item = spec;
+ specifier = SPECIFIED;
+ }
+
+ while (num_vars-- > 0) {
+ if (!IS_WORD(item) && !IS_SET_WORD(item))
+ fail (Error_Invalid_Arg_Core(item, specifier));
+
+ Init_Typeset(key, ALL_64, VAL_WORD_SPELLING(item));
+ key++;
+
+ Init_Void(var);
+ var++;
+
+ ++item;
+ }
+
+ assert(IS_END(key)); // set above by TERM_ARRAY_LEN
+ assert(IS_END(var)); // ...same
+
+ REBARR *body_out = Copy_Array_At_Deep_Managed(
+ VAL_ARRAY(body), VAL_INDEX(body), VAL_SPECIFIER(body)
+ );
+ Bind_Values_Deep(ARR_HEAD(body_out), context);
+
+ *context_out = context;
+
+ return body_out;
}
-/***********************************************************************
-**
-*/ static void Loop_Number(REBVAL *var, REBSER* body, REBVAL *start, REBVAL *end, REBVAL *incr)
-/*
-***********************************************************************/
-{
- REBVAL *result;
- REBDEC s;
- REBDEC e;
- REBDEC i;
-
- if (IS_INTEGER(start)) s = (REBDEC)VAL_INT64(start);
- else if (IS_DECIMAL(start) || IS_PERCENT(start)) s = VAL_DECIMAL(start);
- else Trap_Arg(start);
-
- if (IS_INTEGER(end)) e = (REBDEC)VAL_INT64(end);
- else if (IS_DECIMAL(end) || IS_PERCENT(end)) e = VAL_DECIMAL(end);
- else Trap_Arg(end);
-
- if (IS_INTEGER(incr)) i = (REBDEC)VAL_INT64(incr);
- else if (IS_DECIMAL(incr) || IS_PERCENT(incr)) i = VAL_DECIMAL(incr);
- else Trap_Arg(incr);
-
- VAL_SET(var, REB_DECIMAL);
-
- for (; (i > 0.0) ? s <= e : s >= e; s += i) {
- VAL_DECIMAL(var) = s;
- result = Do_Blk(body, 0);
- if (THROWN(result) && Check_Error(result) >= 0) break;
- if (!IS_DECIMAL(var)) Trap_Type(var);
- s = VAL_DECIMAL(var);
- }
+//
+// Loop_Series_Common: C
+//
+static REB_R Loop_Series_Common(
+ REBVAL *out,
+ REBVAL *var,
+ REBARR *body,
+ REBVAL *start,
+ REBINT ei,
+ REBINT ii
+) {
+ assert(IS_END(out));
+
+ REBINT si = VAL_INDEX(start);
+ enum Reb_Kind type = VAL_TYPE(start);
+
+ Move_Value(var, start);
+
+ if (ei >= cast(REBINT, VAL_LEN_HEAD(start)))
+ ei = cast(REBINT, VAL_LEN_HEAD(start));
+
+ if (ei < 0) ei = 0;
+
+ for (; (ii > 0) ? si <= ei : si >= ei; si += ii) {
+ VAL_INDEX(var) = si;
+
+ // loop bodies are copies at the moment, so fully specified; there
+ // may be a point to making it more efficient by not always copying
+ //
+ if (Do_At_Throws(out, body, 0, SPECIFIED)) {
+ REBOOL stop;
+ if (Catching_Break_Or_Continue(out, &stop)) {
+ if (stop)
+ return R_BLANK;
+ goto next_iteration;
+ }
+ return R_OUT_IS_THROWN;
+ }
+
+ next_iteration:
+ if (VAL_TYPE(var) != type) fail (Error_Invalid_Type(VAL_TYPE(var)));
+ si = VAL_INDEX(var);
+ }
+
+ return R_OUT_VOID_IF_UNWRITTEN_TRUTHIFY;
}
-/***********************************************************************
-**
-*/ static int Loop_All(REBVAL *ds, REBINT mode)
-/*
-** 0: forall
-** 1: forskip
-**
-***********************************************************************/
-{
- REBVAL *var;
- REBSER *body;
- REBCNT bodi;
- REBSER *dat;
- REBINT idx;
- REBINT inc = 1;
- REBCNT type;
-
- var = Get_Var(D_ARG(1));
- if (IS_NONE(var)) return R_NONE;
-
- // Save the starting var value:
- *D_ARG(1) = *var;
-
- SET_NONE(D_RET);
-
- if (mode == 1) inc = Int32(D_ARG(2));
-
- type = VAL_TYPE(var);
- body = VAL_SERIES(D_ARG(mode+2));
- bodi = VAL_INDEX(D_ARG(mode+2));
-
- // Starting location when past end with negative skip:
- if (inc < 0 && VAL_INDEX(var) >= (REBINT)VAL_TAIL(var)) {
- VAL_INDEX(var) = (REBINT)VAL_TAIL(var) + inc;
- }
-
- // NOTE: This math only works for index in positive ranges!
-
- if (ANY_SERIES(var)) {
- while (TRUE) {
- dat = VAL_SERIES(var);
- idx = (REBINT)VAL_INDEX(var);
- if (idx < 0) break;
- if (idx >= (REBINT)SERIES_TAIL(dat)) {
- if (inc >= 0) break;
- idx = (REBINT)SERIES_TAIL(dat) + inc; // negative
- if (idx < 0) break;
- VAL_INDEX(var) = idx;
- }
-
- ds = Do_Blk(body, bodi); // (may move stack)
-
- if (THROWN(ds)) { // Break, throw, continue, error.
- if (Check_Error(ds) >= 0) {
- *DS_RETURN = *DS_NEXT;
- break;
- }
- }
- *DS_RETURN = *ds;
-
- if (VAL_TYPE(var) != type) Trap_Arg(var);
-
- VAL_INDEX(var) += inc;
- }
- }
- else Trap_Arg(var);
-
- // !!!!! ???? allowed to write VAR????
- *var = *DS_ARG(1);
-
- return R_RET;
+//
+// Loop_Integer_Common: C
+//
+static REB_R Loop_Integer_Common(
+ REBVAL *out,
+ REBVAL *var,
+ REBARR *body,
+ REBI64 start,
+ REBI64 end,
+ REBI64 incr
+) {
+ assert(IS_END(out));
+
+ VAL_RESET_HEADER(var, REB_INTEGER);
+
+ while ((incr > 0) ? start <= end : start >= end) {
+ VAL_INT64(var) = start;
+
+ if (Do_At_Throws(out, body, 0, SPECIFIED)) {
+ REBOOL stop;
+ if (Catching_Break_Or_Continue(out, &stop)) {
+ if (stop)
+ return R_BLANK;
+ goto next_iteration;
+ }
+ return R_OUT_IS_THROWN;
+ }
+
+ next_iteration:
+ if (!IS_INTEGER(var))
+ fail (Error_Invalid_Type(VAL_TYPE(var)));
+
+ start = VAL_INT64(var);
+
+ if (REB_I64_ADD_OF(start, incr, &start))
+ fail (Error_Overflow_Raw());
+ }
+
+ return R_OUT_VOID_IF_UNWRITTEN_TRUTHIFY;
}
-/***********************************************************************
-**
-*/ static int Loop_Each(REBVAL *ds, REBINT mode)
-/*
-** Supports these natives (modes):
-** 0: foreach
-** 1: remove-each
-** 2: map
-**
-***********************************************************************/
-{
- REBSER *body;
- REBVAL *vars;
- REBVAL *words;
- REBSER *frame;
- REBVAL *value;
- REBSER *series;
- REBSER *out; // output block (for MAP, mode = 2)
-
- REBINT index; // !!!! should these be REBCNT?
- REBINT tail;
- REBINT windex; // write
- REBINT rindex; // read
- REBINT err;
- REBCNT i;
- REBCNT j;
-
- value = D_ARG(2); // series
- if (IS_NONE(value)) return R_NONE;
-
- body = Init_Loop(D_ARG(1), D_ARG(3), &frame); // vars, body
- SET_OBJECT(D_ARG(1), frame); // keep GC safe
- Set_Block(D_ARG(3), body); // keep GC safe
-
- SET_NONE(D_RET);
- SET_NONE(DS_NEXT);
-
- // If it's MAP, create result block:
- if (mode == 2) {
- out = Make_Block(VAL_LEN(value));
- Set_Block(D_RET, out);
- }
-
- // Get series info:
- if (ANY_OBJECT(value)) {
- series = VAL_OBJ_FRAME(value);
- out = FRM_WORD_SERIES(series); // words (the out local reused)
- index = 1;
- //if (frame->tail > 3) Trap_Arg(FRM_WORD(frame, 3));
- }
- else if (IS_MAP(value)) {
- series = VAL_SERIES(value);
- index = 0;
- //if (frame->tail > 3) Trap_Arg(FRM_WORD(frame, 3));
- }
- else {
- series = VAL_SERIES(value);
- index = VAL_INDEX(value);
- if (index >= (REBINT)SERIES_TAIL(series)) {
- if (mode == 1) {
- SET_INTEGER(D_RET, 0);
- }
- return R_RET;
- }
- }
-
- windex = index;
-
- // Iterate over each value in the series block:
- while (index < (tail = SERIES_TAIL(series))) {
-
- rindex = index; // remember starting spot
- j = 0;
-
- // Set the FOREACH loop variables from the series:
- for (i = 1; i < frame->tail; i++) {
-
- vars = FRM_VALUE(frame, i);
- words = FRM_WORD(frame, i);
-
- // var spec is WORD
- if (IS_WORD(words)) {
-
- if (index < tail) {
-
- if (ANY_BLOCK(value)) {
- *vars = *BLK_SKIP(series, index);
- }
-
- else if (ANY_OBJECT(value)) {
- if (!VAL_GET_OPT(BLK_SKIP(out, index), OPTS_HIDE)) {
- // Alternate between word and value parts of object:
- if (j == 0) {
- Set_Word(vars, VAL_WORD_SYM(BLK_SKIP(out, index)), series, index);
- if (NOT_END(vars+1)) index--; // reset index for the value part
- }
- else if (j == 1)
- *vars = *BLK_SKIP(series, index);
- else
- Trap_Arg(words);
- j++;
- }
- else {
- // Do not evaluate this iteration
- index++;
- goto skip_hidden;
- }
- }
-
- else if (IS_VECTOR(value)) {
- Set_Vector_Value(vars, series, index);
- }
-
- else if (IS_MAP(value)) {
- REBVAL *val = BLK_SKIP(series, index | 1);
- if (!IS_NONE(val)) {
- if (j == 0) {
- *vars = *BLK_SKIP(series, index & ~1);
- if (IS_END(vars+1)) index++; // only words
- }
- else if (j == 1)
- *vars = *BLK_SKIP(series, index);
- else
- Trap_Arg(words);
- j++;
- }
- else {
- index += 2;
- goto skip_hidden;
- }
- }
-
- else { // A string or binary
- if (IS_BINARY(value)) {
- SET_INTEGER(vars, (REBI64)(BIN_HEAD(series)[index]));
- }
- else if (IS_IMAGE(value)) {
- Set_Tuple_Pixel(BIN_SKIP(series, index), vars);
- }
- else {
- VAL_SET(vars, REB_CHAR);
- VAL_CHAR(vars) = GET_ANY_CHAR(series, index);
- }
- }
- index++;
- }
- else SET_NONE(vars);
- }
-
- // var spec is WORD:
- else if (IS_SET_WORD(words)) {
- if (ANY_OBJECT(value) || IS_MAP(value)) {
- *vars = *value;
- } else {
- VAL_SET(vars, REB_BLOCK);
- VAL_SERIES(vars) = series;
- VAL_INDEX(vars) = index;
- }
- //if (index < tail) index++; // do not increment block.
- }
- else Trap_Arg(words);
- }
-
- ds = Do_Blk(body, 0);
-
- if (THROWN(ds)) {
- if ((err = Check_Error(ds)) >= 0) break;
- // else CONTINUE:
- if (mode == 1) SET_FALSE(ds); // keep the value (for mode == 1)
- } else {
- err = 0; // prevent later test against uninitialized value
- }
-
- if (mode > 0) {
- //if (ANY_OBJECT(value)) Trap_Types(words, REB_BLOCK, VAL_TYPE(value)); //check not needed
-
- // If FALSE return, copy values to the write location:
- if (mode == 1) { // remove-each
- if (IS_FALSE(ds)) {
- REBCNT wide = SERIES_WIDE(series);
- // memory areas may overlap, so use memmove and not memcpy!
- memmove(series->data + (windex * wide), series->data + (rindex * wide), (index - rindex) * wide);
- windex += index - rindex;
- // old: while (rindex < index) *BLK_SKIP(series, windex++) = *BLK_SKIP(series, rindex++);
- }
- }
- else
- if (!IS_UNSET(ds)) Append_Val(out, ds); // (mode == 2)
- }
-skip_hidden: ;
- }
+//
+// Loop_Number_Common: C
+//
+static REB_R Loop_Number_Common(
+ REBVAL *out,
+ REBVAL *var,
+ REBARR *body,
+ REBVAL *start,
+ REBVAL *end,
+ REBVAL *incr
+) {
+ assert(IS_END(out));
+
+ REBDEC s;
+ if (IS_INTEGER(start))
+ s = cast(REBDEC, VAL_INT64(start));
+ else if (IS_DECIMAL(start) || IS_PERCENT(start))
+ s = VAL_DECIMAL(start);
+ else
+ fail (start);
+
+ REBDEC e;
+ if (IS_INTEGER(end))
+ e = cast(REBDEC, VAL_INT64(end));
+ else if (IS_DECIMAL(end) || IS_PERCENT(end))
+ e = VAL_DECIMAL(end);
+ else
+ fail (end);
+
+ REBDEC i;
+ if (IS_INTEGER(incr))
+ i = cast(REBDEC, VAL_INT64(incr));
+ else if (IS_DECIMAL(incr) || IS_PERCENT(incr))
+ i = VAL_DECIMAL(incr);
+ else
+ fail (incr);
+
+ VAL_RESET_HEADER(var, REB_DECIMAL);
+
+ for (; (i > 0.0) ? s <= e : s >= e; s += i) {
+ VAL_DECIMAL(var) = s;
+
+ if (Do_At_Throws(out, body, 0, SPECIFIED)) {
+ REBOOL stop;
+ if (Catching_Break_Or_Continue(out, &stop)) {
+ if (stop)
+ return R_BLANK;
+ goto next_iteration;
+ }
+ return R_OUT_IS_THROWN;
+ }
+
+ next_iteration:
+ if (!IS_DECIMAL(var))
+ fail (Error_Invalid_Type(VAL_TYPE(var)));
+
+ s = VAL_DECIMAL(var);
+ }
+
+ return R_OUT_VOID_IF_UNWRITTEN_TRUTHIFY;
+}
- // Finish up:
- if (mode == 1) {
- // Remove hole (updates tail):
- if (windex < index) Remove_Series(series, windex, index - windex);
- SET_INTEGER(DS_RETURN, index - windex);
- return R_RET;
- }
- // If MAP and not BREAK/RETURN:
- if (mode == 2 && err != 2) return R_RET;
+//
+// Loop_Each: C
+//
+// Common implementation code of FOR-EACH, REMOVE-EACH, MAP-EACH, and EVERY.
+//
+// !!! This routine has been slowly clarifying since R3-Alpha, and can
+// likely be factored in a better way...pushing more per-native code into the
+// natives themselves.
+//
+static REB_R Loop_Each(REBFRM *frame_, LOOP_MODE mode)
+{
+ INCLUDE_PARAMS_OF_FOR_EACH;
+
+ REBVAL *data = ARG(data);
+ assert(!IS_VOID(data));
+
+ if (IS_BLANK(data))
+ return R_VOID;
+
+ REBOOL stop = FALSE;
+ REBOOL threw = FALSE; // did a non-BREAK or non-CONTINUE throw occur
+
+ assert(IS_END(D_OUT));
+ if (mode == LOOP_EVERY)
+ SET_END(D_CELL); // Final result is in D_CELL (last TRUE? or a BLANK!)
+
+ REBCTX *context;
+ REBARR *body_copy = Copy_Body_Deep_Bound_To_New_Context(
+ &context,
+ ARG(vars),
+ ARG(body)
+ );
+ Init_Object(ARG(vars), context); // keep GC safe
+ Init_Block(ARG(body), body_copy); // keep GC safe
+
+ // Currently the data stack is only used by MAP-EACH to accumulate results
+ // but it's faster to just save it than test the loop mode.
+ //
+ REBDSP dsp_orig = DSP;
+
+ // Extract the series and index being enumerated, based on data type
+
+ REBSER *series;
+ REBCNT index;
+ if (ANY_CONTEXT(data)) {
+ series = SER(CTX_VARLIST(VAL_CONTEXT(data)));
+ index = 1;
+ }
+ else if (IS_MAP(data)) {
+ series = VAL_SERIES(data);
+ index = 0;
+ }
+ else if (IS_DATATYPE(data)) {
+ //
+ // !!! Snapshotting the state is not particularly efficient. However,
+ // bulletproofing an enumeration of the system against possible GC
+ // would be difficult. And this is really just a debug/instrumentation
+ // feature anyway.
+ //
+ switch (VAL_TYPE_KIND(data)) {
+ case REB_FUNCTION:
+ series = SER(Snapshot_All_Functions());
+ index = 0;
+ PUSH_GUARD_ARRAY_CONTENTS(ARR(series));
+ break;
+
+ default:
+ fail ("FUNCTION! is the only datatype with global enumeration");
+ }
+ }
+ else {
+ series = VAL_SERIES(data);
+ index = VAL_INDEX(data);
+ if (index >= SER_LEN(series)) {
+ if (mode == LOOP_REMOVE_EACH) {
+ Init_Integer(D_OUT, 0);
+ return R_OUT;
+ }
+ else if (mode == LOOP_MAP_EACH) {
+ Init_Block(D_OUT, Make_Array(0));
+ return R_OUT;
+ }
+ return R_VOID;
+ }
+ }
+
+ REBCNT write_index = index;
+
+ // Iterate over each value in the data series block:
+
+ REBCNT tail;
+ while (index < (tail = SER_LEN(series))) {
+ REBCNT i;
+ REBCNT j = 0;
+
+ REBVAL *key = CTX_KEY(context, 1);
+ REBVAL *var = CTX_VAR(context, 1);
+
+ REBCNT read_index;
+
+ read_index = index; // remember starting spot
+
+ // Set the FOREACH loop variables from the series:
+ for (i = 1; NOT_END(key); i++, key++, var++) {
+
+ if (index >= tail) {
+ Init_Blank(var);
+ continue;
+ }
+
+ if (ANY_ARRAY(data)) {
+ Derelativize(
+ var,
+ ARR_AT(ARR(series), index),
+ VAL_SPECIFIER(data) // !!! always matches series?
+ );
+ }
+ else if (IS_DATATYPE(data)) {
+ Derelativize(
+ var,
+ ARR_AT(ARR(series), index),
+ SPECIFIED // array generated via data stack, all specific
+ );
+ }
+ else if (ANY_CONTEXT(data)) {
+ if (GET_VAL_FLAG(
+ VAL_CONTEXT_KEY(data, index), TYPESET_FLAG_HIDDEN
+ )) {
+ // Do not evaluate this iteration
+ index++;
+ goto skip_hidden;
+ }
+
+ // Alternate between word and value parts of object:
+ if (j == 0) {
+ Init_Any_Word_Bound(
+ var,
+ REB_WORD,
+ CTX_KEY_SPELLING(VAL_CONTEXT(data), index),
+ CTX(series),
+ index
+ );
+ if (NOT_END(var + 1)) {
+ // reset index for the value part
+ index--;
+ }
+ }
+ else if (j == 1) {
+ Derelativize(
+ var,
+ ARR_AT(ARR(series), index),
+ SPECIFIED // !!! it's a varlist
+ );
+ }
+ else {
+ // !!! Review this error (and this routine...)
+ DECLARE_LOCAL (key_name);
+ Init_Word(key_name, VAL_KEY_SPELLING(key));
+
+ fail (key_name);
+ }
+ j++;
+ }
+ else if (IS_VECTOR(data)) {
+ Set_Vector_Value(var, series, index);
+ }
+ else if (IS_MAP(data)) {
+ //
+ // MAP! does not store RELVALs
+ //
+ REBVAL *val = KNOWN(ARR_AT(ARR(series), index | 1));
+ if (!IS_VOID(val)) {
+ if (j == 0) {
+ Derelativize(
+ var,
+ ARR_AT(ARR(series), index & ~1),
+ SPECIFIED // maps always specified
+ );
+
+ if (IS_END(var + 1)) index++; // only words
+ }
+ else if (j == 1) {
+ Derelativize(
+ var,
+ ARR_AT(ARR(series), index),
+ SPECIFIED // maps always specified
+ );
+ }
+ else {
+ // !!! Review this error (and this routine...)
+ DECLARE_LOCAL (key_name);
+ Init_Word(key_name, VAL_KEY_SPELLING(key));
+
+ fail (key_name);
+ }
+ j++;
+ }
+ else {
+ index += 2;
+ goto skip_hidden;
+ }
+ }
+ else if (IS_BINARY(data)) {
+ Init_Integer(var, (REBI64)(BIN_HEAD(series)[index]));
+ }
+ else if (IS_IMAGE(data)) {
+ Set_Tuple_Pixel(BIN_AT(series, index), var);
+ }
+ else {
+ assert(IS_STRING(data));
+ VAL_RESET_HEADER(var, REB_CHAR);
+ VAL_CHAR(var) = GET_ANY_CHAR(series, index);
+ }
+ index++;
+ }
+
+ assert(IS_END(key) && IS_END(var));
+
+ if (index == read_index) {
+ // the word block has only set-words: for-each [a:] [1 2 3][]
+ index++;
+ }
+
+ if (Do_At_Throws(D_OUT, body_copy, 0, SPECIFIED)) { // copy, specified
+ if (!Catching_Break_Or_Continue(D_OUT, &stop)) {
+ // A non-loop throw, we should be bubbling up
+ threw = TRUE;
+ break;
+ }
+
+ // Fall through and process the D_OUT (unset if no /WITH) for
+ // this iteration. `stop` flag will be checked ater that.
+ }
+
+ switch (mode) {
+ case LOOP_FOR_EACH:
+ // no action needed after body is run
+ break;
+
+ case LOOP_REMOVE_EACH:
+ //
+ // If body evaluates to FALSE, preserve the slot. Do the same
+ // for a void body, since that should have the same behavior as
+ // a CONTINUE with no /WITH (which most sensibly does not do
+ // a removal.)
+ //
+ if (IS_VOID(D_OUT) || IS_CONDITIONAL_FALSE(D_OUT)) {
+ //
+ // memory areas may overlap, so use memmove and not memcpy!
+ //
+ // !!! This seems a slow way to do it, but there's probably
+ // not a lot that can be done as the series is expected to
+ // be in a good state for the next iteration of the body. :-/
+ //
+ memmove(
+ SER_AT_RAW(SER_WIDE(series), series, write_index),
+ SER_AT_RAW(SER_WIDE(series), series, read_index),
+ (index - read_index) * SER_WIDE(series)
+ );
+ write_index += index - read_index;
+ }
+ break;
+
+ case LOOP_MAP_EACH:
+ // anything that's not void will be added to the result
+ if (!IS_VOID(D_OUT))
+ DS_PUSH(D_OUT);
+ break;
+
+ case LOOP_EVERY:
+ if (IS_VOID(D_OUT)) {
+ // Unsets "opt out" of the vote, as with ANY and ALL
+ }
+ else if (IS_CONDITIONAL_FALSE(D_OUT))
+ Init_Blank(D_CELL); // at least one false means blank result
+ else if (IS_END(D_CELL) || !IS_BLANK(D_CELL))
+ Move_Value(D_CELL, D_OUT);
+ break;
+ default:
+ assert(FALSE);
+ }
+
+ if (stop) {
+ Init_Blank(D_OUT);
+ break;
+ }
- return R_TOS1;
+skip_hidden: ;
+ }
+
+ if (IS_DATATYPE(data)) {
+ //
+ // If asked to enumerate a datatype, we allocated a temporary array
+ // of all instances of that datatype. It has to be freed.
+ //
+ DROP_GUARD_ARRAY_CONTENTS(ARR(series));
+ Free_Array(ARR(series));
+ }
+
+ if (threw) {
+ // a non-BREAK and non-CONTINUE throw overrides any other return
+ // result we might give (generic THROW, RETURN, QUIT, etc.)
+
+ if (mode == LOOP_MAP_EACH)
+ DS_DROP_TO(dsp_orig);
+
+ return R_OUT_IS_THROWN;
+ }
+
+ // Note: This finalization will be run by finished loops as well as
+ // interrupted ones. So:
+ //
+ // map-each x [1 2 3 4] [if x = 3 [break]] => [1 2]
+ //
+ // map-each x [1 2 3 4] [if x = 3 [break/with "A"]] => [1 2 "A"]
+ //
+ // every x [1 3 6 12] [if x = 6 [break/with 7] even? x] => 7
+ //
+ // This provides the most flexibility in the loop's processing, because
+ // "override" logic already exists in the form of CATCH & THROW.
+
+#if !defined(NDEBUG)
+ if (LEGACY(OPTIONS_BREAK_WITH_OVERRIDES)) {
+ // In legacy R3-ALPHA, BREAK without a provided value did *not*
+ // override the result. It returned the partial results.
+ if (stop && NOT_END(D_OUT))
+ return R_OUT;
+ }
+#endif
+
+ if (stop)
+ return R_BLANK;
+
+ switch (mode) {
+ case LOOP_FOR_EACH:
+ return R_OUT_VOID_IF_UNWRITTEN_TRUTHIFY;
+
+ case LOOP_REMOVE_EACH:
+ // Remove hole (updates tail):
+ if (write_index < index)
+ Remove_Series(series, write_index, index - write_index);
+ Init_Integer(D_OUT, index - write_index);
+ return R_OUT;
+
+ case LOOP_MAP_EACH:
+ Init_Block(D_OUT, Pop_Stack_Values(dsp_orig));
+ return R_OUT;
+
+ case LOOP_EVERY:
+ if (threw)
+ return R_OUT_IS_THROWN;
+
+ if (IS_END(D_CELL))
+ return R_VOID; // all evaluations opted out
+
+ Move_Value(D_OUT, D_CELL);
+ return R_OUT; // should it be like R_OUT_VOID_IF_UNWRITTEN_TRUTHIFY?
+
+ default:
+ assert(FALSE);
+ }
+
+ DEAD_END;
}
-/***********************************************************************
-**
-*/ REBNATIVE(for)
-/*
-** FOR var start end bump [ body ]
-**
-***********************************************************************/
+//
+// for: native [
+//
+// {Evaluate a block over a range of values. (See also: REPEAT)}
+//
+// return: [ any-value!]
+// 'word [word!]
+// "Variable to hold current value"
+// start [any-series! any-number!]
+// "Starting value"
+// end [any-series! any-number!]
+// "Ending value"
+// bump [any-number!]
+// "Amount to skip each time"
+// body [block!]
+// "Block to evaluate"
+// ]
+//
+REBNATIVE(for)
{
- REBSER *body;
- REBSER *frame;
- REBVAL *var;
- REBVAL *start = D_ARG(2);
- REBVAL *end = D_ARG(3);
- REBVAL *incr = D_ARG(4);
-
- // Copy body block, make a frame, bind loop var to it:
- body = Init_Loop(D_ARG(1), D_ARG(5), &frame);
- var = FRM_VALUE(frame, 1); // safe: not on stack
- SET_OBJECT(D_ARG(1), frame); // keep GC safe
- Set_Block(D_ARG(5), body); // keep GC safe
-
- SET_NONE(DS_NEXT); // in case nothing below happens
-
- // NOTE: during loop, stack may expand, so references to stack
- // values must not be absolute.
-
- if (IS_INTEGER(start) && IS_INTEGER(end) && IS_INTEGER(incr)) {
- Loop_Integer(var, body, VAL_INT64(start),
- IS_DECIMAL(end) ? (REBI64)VAL_DECIMAL(end) : VAL_INT64(end), VAL_INT64(incr));
- }
- else if (ANY_SERIES(start)) {
- // Check that start and end are same type and series:
- //if (ANY_SERIES(end) && VAL_SERIES(start) != VAL_SERIES(end)) Trap_Arg(end);
- Loop_Series(var, body, start, ANY_SERIES(end) ? VAL_INDEX(end) : (Int32s(end, 1) - 1), Int32(incr));
- }
- else
- Loop_Number(var, body, start, end, incr);
-
- return R_TOS1;
+ INCLUDE_PARAMS_OF_FOR;
+
+ REBCTX *context;
+ REBARR *body_copy = Copy_Body_Deep_Bound_To_New_Context(
+ &context,
+ ARG(word),
+ ARG(body)
+ );
+ Init_Object(ARG(word), context); // keep GC safe
+ Init_Block(ARG(body), body_copy); // keep GC safe
+
+ REBVAL *var = CTX_VAR(context, 1);
+
+ if (
+ IS_INTEGER(ARG(start))
+ && IS_INTEGER(ARG(end))
+ && IS_INTEGER(ARG(bump))
+ ) {
+ return Loop_Integer_Common(
+ D_OUT,
+ var,
+ body_copy,
+ VAL_INT64(ARG(start)),
+ IS_DECIMAL(ARG(end))
+ ? (REBI64)VAL_DECIMAL(ARG(end))
+ : VAL_INT64(ARG(end)),
+ VAL_INT64(ARG(bump))
+ );
+ }
+ else if (ANY_SERIES(ARG(start))) {
+ if (ANY_SERIES(ARG(end))) {
+ return Loop_Series_Common(
+ D_OUT,
+ var,
+ body_copy,
+ ARG(start),
+ VAL_INDEX(ARG(end)),
+ Int32(ARG(bump))
+ );
+ }
+ else {
+ return Loop_Series_Common(
+ D_OUT,
+ var,
+ body_copy,
+ ARG(start),
+ Int32s(ARG(end), 1) - 1,
+ Int32(ARG(bump))
+ );
+ }
+ }
+
+ return Loop_Number_Common(
+ D_OUT, var, body_copy, ARG(start), ARG(end), ARG(bump)
+ );
+
}
-/***********************************************************************
-**
-*/ REBNATIVE(forall)
-/*
-***********************************************************************/
+//
+// for-skip: native [
+//
+// "Evaluates a block for periodic values in a series"
+//
+// return: [ any-value!]
+// {Last body result or BREAK value, will also be void if never run}
+// 'word [word! blank!]
+// "Word that refers to the series, set to positions in the series"
+// skip [integer!]
+// "Number of positions to skip each time"
+// body [block!]
+// "Block to evaluate each time"
+// ]
+//
+REBNATIVE(for_skip)
+//
+// !!! Should this fail on 0? It could be that the loop will break for some
+// other reason, and the author didn't wish to special case to rule out zero...
+// generality may dictate allowing it.
{
- return Loop_All(ds, 0);
+ INCLUDE_PARAMS_OF_FOR_SKIP;
+
+ REBVAL *word = ARG(word);
+
+ // Though we can only iterate on a series, BLANK! is used as a way of
+ // opting out. This could be useful, e.g. `for-next x (any ...) [...]`
+ //
+ if (IS_BLANK(word))
+ return R_VOID;
+
+ REBVAL *var = Get_Mutable_Var_May_Fail(word, SPECIFIED);
+
+ if (NOT(ANY_SERIES(var)))
+ fail (var);
+
+ REBINT skip = Int32(ARG(skip));
+
+ // Save the starting var value, assume `word` is a GC protected slot
+ //
+ Move_Value(word, var);
+
+ // Starting location when past end with negative skip:
+ //
+ if (skip < 0 && VAL_INDEX(var) >= VAL_LEN_HEAD(var))
+ VAL_INDEX(var) = VAL_LEN_HEAD(var) + skip;
+
+ while (TRUE) {
+ REBINT len = VAL_LEN_HEAD(var); // VAL_LEN_HEAD() always >= 0
+ REBINT index = VAL_INDEX(var); // (may have been set to < 0 below)
+
+ if (index < 0) break;
+ if (index >= len) {
+ if (skip >= 0) break;
+ index = len + skip; // negative
+ if (index < 0) break;
+ VAL_INDEX(var) = index;
+ }
+
+ if (Do_Any_Array_At_Throws(D_OUT, ARG(body))) {
+ REBOOL stop;
+ if (Catching_Break_Or_Continue(D_OUT, &stop)) {
+ if (stop) {
+ Move_Value(var, word);
+ return R_BLANK;
+ }
+ goto next_iteration;
+ }
+ return R_OUT_IS_THROWN;
+ }
+
+ next_iteration:
+ //
+ // !!! The code in the body is allowed to modify the var. However,
+ // R3-Alpha checked to make sure that the type of the var did not
+ // change. This seemed like an arbitrary limitation and Ren-C
+ // removed it, only checking that it's a series.
+ //
+ if (IS_BLANK(var))
+ return R_OUT;
+
+ if (NOT(ANY_SERIES(var)))
+ fail (var);
+
+ VAL_INDEX(var) += skip;
+ }
+
+ Move_Value(var, word);
+ return R_OUT_VOID_IF_UNWRITTEN_TRUTHIFY;
}
-/***********************************************************************
-**
-*/ REBNATIVE(forskip)
-/*
-***********************************************************************/
+//
+// forever: native [
+//
+// "Evaluates a block endlessly, until an interrupting throw/error/break."
+//
+// return: [ any-value!]
+// {Void if plain BREAK, or arbitrary value using BREAK/WITH}
+// body [block! function!]
+// "Block or function to evaluate each time"
+// ]
+//
+REBNATIVE(forever)
{
- return Loop_All(ds, 1);
+ INCLUDE_PARAMS_OF_FOREVER;
+
+ do {
+ const REBOOL only = FALSE;
+ if (Run_Branch_Throws(D_OUT, ARG(body), only)) {
+ REBOOL stop;
+ if (Catching_Break_Or_Continue(D_OUT, &stop)) {
+ if (stop)
+ return R_BLANK;
+ continue;
+ }
+ return R_OUT_IS_THROWN;
+ }
+ } while (TRUE);
+
+ DEAD_END;
}
-/***********************************************************************
-**
-*/ REBNATIVE(forever)
-/*
-***********************************************************************/
+//
+// for-each: native [
+//
+// "Evaluates a block for each value(s) in a series."
+//
+// return: [ any-value!]
+// {Last body result or BREAK value, will also be void if never run}
+// 'vars [word! block!]
+// "Word or block of words to set each time (local)"
+// data [any-series! any-context! map! blank! datatype!]
+// "The series to traverse"
+// body [block!]
+// "Block to evaluate each time"
+// ]
+//
+REBNATIVE(for_each)
{
- REBVAL *result;
-
- SET_NONE(DS_NEXT);
+ return Loop_Each(frame_, LOOP_FOR_EACH);
+}
- while (1) {
- result = DO_BLK(DS_ARG(1));
- if (THROWN(result) && Check_Error(result) >= 0) break;
- }
- return R_TOS1;
+//
+// remove-each: native [
+//
+// {Removes values for each block that returns true; returns removal count.}
+//
+// 'vars [word! block!]
+// "Word or block of words to set each time (local)"
+// data [any-series!]
+// "The series to traverse (modified)"
+// body [block!]
+// "Block to evaluate (return TRUE to remove)"
+// ]
+//
+REBNATIVE(remove_each)
+{
+ return Loop_Each(frame_, LOOP_REMOVE_EACH);
}
-/***********************************************************************
-**
-*/ REBNATIVE(foreach)
-/*
-** {Evaluates a block for each value(s) in a series.}
-** 'word [get-word! word! block!] {Word or block of words}
-** data [series!] {The series to traverse}
-** body [block!] {Block to evaluate each time}
-**
-***********************************************************************/
+//
+// map-each: native [
+//
+// {Evaluate a block for each value(s) in a series and collect as a block.}
+//
+// return: [block!]
+// {Collected block (BREAK/WITH can add a final result to block)}
+// 'vars [word! block!]
+// "Word or block of words to set each time (local)"
+// data [block! vector!]
+// "The series to traverse"
+// body [block!]
+// "Block to evaluate each time"
+// ]
+//
+REBNATIVE(map_each)
{
- return Loop_Each(ds, 0);
+ return Loop_Each(frame_, LOOP_MAP_EACH);
}
-/***********************************************************************
-**
-*/ REBNATIVE(remove_each)
-/*
-** 'word [get-word! word! block!] {Word or block of words}
-** data [series!] {The series to traverse}
-** body [block!] {Block to evaluate each time}
-**
-***********************************************************************/
+//
+// every: native [
+//
+// {Returns last TRUE? value if evaluating a block over a series is all TRUE?}
+//
+// return: [ any-value!]
+// {TRUE or BLANK! collected, or BREAK value, TRUE if never run.}
+// 'vars [word! block!]
+// "Word or block of words to set each time (local)"
+// data [any-series! any-context! map! blank! datatype!]
+// "The series to traverse"
+// body [block!]
+// "Block to evaluate each time"
+// ]
+//
+REBNATIVE(every)
{
- return Loop_Each(ds, 1);
+ return Loop_Each(frame_, LOOP_EVERY);
}
-/***********************************************************************
-**
-*/ REBNATIVE(map_each)
-/*
-** 'word [get-word! word! block!] {Word or block of words}
-** data [series!] {The series to traverse}
-** body [block!] {Block to evaluate each time}
-**
-***********************************************************************/
+//
+// loop: native [
+//
+// "Evaluates a block a specified number of times."
+//
+// return: [ any-value!]
+// {Last body result or BREAK value, will also be void if never run}
+// count [any-number! logic! blank!]
+// "Repetitions (true loops infinitely, FALSE? doesn't run)"
+// body [block! function!]
+// "Block to evaluate or function to run (may be a BRANCHER)."
+// ]
+//
+REBNATIVE(loop)
{
- return Loop_Each(ds, 2);
+ INCLUDE_PARAMS_OF_LOOP;
+
+ REBI64 count;
+
+ if (IS_CONDITIONAL_FALSE(ARG(count))) {
+ //
+ // A NONE! or LOGIC! FALSE means don't run the loop at all.
+ //
+ return R_VOID;
+ }
+
+ if (IS_LOGIC(ARG(count))) {
+ //
+ // (Must be TRUE). Run forever. As a micro-optimization we don't
+ // complicate the condition checking in the loop, but seed with a
+ // *very* large integer. In the off chance that we exhaust it, the
+ // code jumps up here, re-seeds it, and loops again.
+ //
+ restart:
+ count = MAX_I64;
+ }
+ else
+ count = Int64(ARG(count));
+
+ for (; count > 0; count--) {
+ const REBOOL only = FALSE;
+ if (Run_Branch_Throws(D_OUT, ARG(body), only)) {
+ REBOOL stop;
+ if (Catching_Break_Or_Continue(D_OUT, &stop)) {
+ if (stop)
+ return R_BLANK;
+ continue;
+ }
+ return R_OUT_IS_THROWN;
+ }
+ }
+
+ if (IS_LOGIC(ARG(count))) {
+ //
+ // Rare case, "infinite" loop exhausted MAX_I64 steps...
+ //
+ goto restart;
+ }
+
+ return R_OUT_VOID_IF_UNWRITTEN_TRUTHIFY;
}
-/***********************************************************************
-**
-*/ REBNATIVE(loop)
-/*
-***********************************************************************/
+//
+// repeat: native [
+//
+// {Evaluates a block a number of times or over a series.}
+//
+// return: [ any-value!]
+// {Last body result or BREAK value, will also be void if never run}
+// 'word [word!]
+// "Word to set each time"
+// value [any-number! any-series! blank!]
+// "Maximum number or series to traverse"
+// body [block!]
+// "Block to evaluate each time"
+// ]
+//
+REBNATIVE(repeat)
{
- REBI64 count = Int64(D_ARG(1));
- REBSER *block = VAL_SERIES(D_ARG(2));
- REBCNT index = VAL_INDEX(D_ARG(2));
-
- ds = 0;
- for (; count > 0; count--) {
- ds = Do_Blk(block, index);
- if (THROWN(ds)) {
- if (Check_Error(ds) >= 0) break;
- }
- }
- if (ds) return R_TOS1;
- return R_NONE;
+ INCLUDE_PARAMS_OF_REPEAT;
+
+ REBVAL *value = ARG(value);
+
+ if (IS_BLANK(value))
+ return R_VOID;
+
+ if (IS_DECIMAL(value) || IS_PERCENT(value))
+ Init_Integer(value, Int64(value));
+
+ REBCTX *context;
+ REBARR *copy = Copy_Body_Deep_Bound_To_New_Context(
+ &context,
+ ARG(word),
+ ARG(body)
+ );
+
+ REBVAL *var = CTX_VAR(context, 1);
+
+ Init_Object(ARG(word), context); // keep GC safe
+ Init_Block(ARG(body), copy); // keep GC safe
+
+ if (ANY_SERIES(value)) {
+ return Loop_Series_Common(
+ D_OUT, var, copy, value, VAL_LEN_HEAD(value) - 1, 1
+ );
+ }
+
+ assert(IS_INTEGER(value));
+
+ return Loop_Integer_Common(D_OUT, var, copy, 1, VAL_INT64(value), 1);
}
-/***********************************************************************
-**
-*/ REBNATIVE(repeat)
-/*
-** REPEAT var 123 [ body ]
-**
-***********************************************************************/
+// Common code for LOOP-WHILE & LOOP-UNTIL (same frame param layout)
+//
+inline static REB_R Loop_While_Until_Core(REBFRM *frame_, REBOOL trigger)
{
- REBSER *body;
- REBSER *frame;
- REBVAL *var;
- REBVAL *count = D_ARG(2);
+ INCLUDE_PARAMS_OF_LOOP_WHILE;
+
+ do {
+ skip_check:;
+
+ const REBOOL only = FALSE;
+ if (Run_Branch_Throws(D_OUT, ARG(body), only)) {
+ REBOOL stop;
+ if (Catching_Break_Or_Continue(D_OUT, &stop)) {
+ if (stop)
+ return R_BLANK;
+
+ // LOOP-UNTIL and LOOP-WITH follow the precedent that the way
+ // a CONTINUE/WITH works is to act as if the loop body
+ // returned the value passed to the WITH...and that a CONTINUE
+ // lacking a WITH acts as if the body returned a void.
+ //
+ // Since the condition and body are the same in this case,
+ // the implications are a little strange (though logical).
+ // CONTINUE/WITH FALSE will break a LOOP-WHILE, and
+ // CONTINUE/WITH TRUE breaks a LOOP-UNTIL.
+ //
+ if (IS_VOID(D_OUT))
+ goto skip_check;
+
+ goto perform_check;
+ }
+ return R_OUT_IS_THROWN;
+ }
+
+ // Since CONTINUE acts like reaching the end of the loop body with a
+ // void, the logical consequence is that reaching the end of *either*
+ // a LOOP-WHILE or a LOOP-UNTIL with a void just keeps going. This
+ // means that `loop-until [print "hi"]` and `loop-while [print "hi"]`
+ // are both infinite loops.
+ //
+ if (IS_VOID(D_OUT))
+ goto skip_check;
+
+ perform_check:;
+ } while (IS_CONDITIONAL_TRUE(D_OUT) == trigger);
+
+ // Though LOOP-UNTIL will always have a truthy result, LOOP-WHILE never
+ // will, and needs to have the result overwritten with something TRUE?
+ // so BAR! is used.
+ //
+ if (trigger == TRUE)
+ return R_BAR;
+
+ assert(IS_CONDITIONAL_TRUE(D_OUT));
+ return R_OUT;
+}
- if (IS_NONE(count)) return R_NONE;
- if (IS_DECIMAL(count) || IS_PERCENT(count)) {
- VAL_INT64(count) = Int64(count);
- VAL_SET(count, REB_INTEGER);
- }
+//
+// loop-while: native [
+//
+// "Evaluates a block while it is TRUE?"
+//
+// return: [ any-value!]
+// {Last body result or BREAK value.}
+// body [block! function!]
+// ]
+//
+REBNATIVE(loop_while)
+{
+ return Loop_While_Until_Core(frame_, TRUE);
+}
- body = Init_Loop(D_ARG(1), D_ARG(3), &frame);
- var = FRM_VALUE(frame, 1); // safe: not on stack
- SET_OBJECT(D_ARG(1), frame); // keep GC safe
- Set_Block(D_ARG(3), body); // keep GC safe
- SET_NONE(DS_NEXT); // in case nothing below happens
+//
+// loop-until: native [
+//
+// "Evaluates a block until it is TRUE?"
+//
+// return: [ any-value!]
+// {Last body result or BREAK value.}
+// body [block! function!]
+// ]
+//
+REBNATIVE(loop_until)
+//
+// !!! This function used to be called just UNTIL, but Ren-C retakes that for
+// the arity-2 complement to WHILE.
+{
+ return Loop_While_Until_Core(frame_, FALSE);
+}
- if (ANY_SERIES(count)) {
- Loop_Series(var, body, count, VAL_TAIL(count)-1, 1);
- }
- else if (IS_INTEGER(count)) {
- Loop_Integer(var, body, 1, VAL_INT64(count), 1);
- }
- return R_TOS1;
+// Common code for WHILE & UNTIL (same frame param layout)
+//
+inline static REB_R While_Until_Core(REBFRM *frame_, REBOOL trigger)
+{
+ INCLUDE_PARAMS_OF_WHILE;
+
+ const REBOOL only = FALSE; // while/only [cond] [body] is meaningless
+
+ assert(IS_END(D_OUT)); // guaranteed by the evaluator
+
+ do {
+ if (Run_Branch_Throws(D_CELL, ARG(condition), only)) {
+ //
+ // A while loop should only look for breaks and continues in its
+ // body, not in its condition. So `while [break] []` is a
+ // request to break the enclosing loop (or error if there is
+ // nothing to catch that break). Hence we bubble up the throw.
+ //
+ Move_Value(D_OUT, D_CELL);
+ return R_OUT_IS_THROWN;
+ }
+
+ if (IS_VOID(D_CELL))
+ fail (Error_No_Return_Raw());
+
+ if (IS_CONDITIONAL_TRUE(D_CELL) != trigger) {
+ //
+ // Successfully completed loops aren't allowed to return a
+ // FALSE? value, so they get BAR! as a truthy-result if the
+ // loop body ever ran... or void if it never did.
+ //
+ return R_OUT_VOID_IF_UNWRITTEN_TRUTHIFY;
+ }
+
+ if (Run_Branch_Throws(D_OUT, ARG(body), only)) {
+ REBOOL stop;
+ if (Catching_Break_Or_Continue(D_OUT, &stop)) {
+ if (stop)
+ return R_BLANK;
+
+ continue;
+ }
+ return R_OUT_IS_THROWN;
+ }
+
+ } while (TRUE);
}
-/***********************************************************************
-**
-*/ REBNATIVE(until)
-/*
-***********************************************************************/
+//
+// while: native [
+//
+// {While a condition block is TRUE?, evaluates another block.}
+//
+// return: [ any-value!]
+// {Last body result or BREAK value, will also be void if never run}
+// condition [block! function!]
+// body [block! function!]
+// ]
+//
+REBNATIVE(while)
{
- REBSER *b1 = VAL_SERIES(D_ARG(1));
- REBCNT i1 = VAL_INDEX(D_ARG(1));
-
- do {
-utop:
- ds = Do_Blk(b1, i1);
- if (IS_UNSET(ds)) Trap0(RE_NO_RETURN);
- if (THROWN(ds)) {
- if (Check_Error(ds) >= 0) break;
- goto utop;
- }
- } while (IS_FALSE(ds)); // Break, return errors fall out.
- return R_TOS1;
+ return While_Until_Core(frame_, TRUE);
}
-/***********************************************************************
-**
-*/ REBNATIVE(while)
-/*
-***********************************************************************/
+//
+// until: native [
+//
+// {Until a condition block is TRUE?, evaluates another block.}
+//
+// return: [ any-value!]
+// {Last body result or BREAK value, will also be void if never run}
+// condition [block! function!]
+// body [block! function!]
+// ]
+//
+REBNATIVE(until)
+//
+// !!! This arity-2 form of UNTIL is aliased to UNTIL-2 in the bootstrap, and
+// UNTIL is left undefined.
{
- REBSER *b1 = VAL_SERIES(D_ARG(1));
- REBCNT i1 = VAL_INDEX(D_ARG(1));
- REBSER *b2 = VAL_SERIES(D_ARG(2));
- REBCNT i2 = VAL_INDEX(D_ARG(2));
-
- SET_NONE(D_RET);
-
- do {
- ds = Do_Blk(b1, i1);
- if (IS_UNSET(ds) || IS_ERROR(ds)) { // Unset, break, throw, error.
- if (Check_Error(ds) >= 0) return R_TOS1;
- }
- if (!IS_TRUE(ds)) return R_RET;
- ds = Do_Blk(b2, i2);
- *DS_RETURN = *ds; // save here (to avoid GC during error handling)
- if (THROWN(ds)) { // Break, throw, continue, error.
- if (Check_Error(ds) >= 0) return R_TOS1;
- *DS_RETURN = *ds; // Check_Error modified it
- }
- } while (TRUE);
+ return While_Until_Core(frame_, FALSE);
}
diff --git a/src/core/n-math.c b/src/core/n-math.c
index 80a2afc9ef..6365f23295 100644
--- a/src/core/n-math.c
+++ b/src/core/n-math.c
@@ -1,68 +1,68 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: n-math.c
-** Summary: native functions for math
-** Section: natives
-** Author: Carl Sassenrath
-** Notes: See also: the numeric datatypes
-**
-***********************************************************************/
+//
+// File: %n-math.c
+// Summary: "native functions for math"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// See also: the numeric datatypes
+//
#include "sys-core.h"
-#include "tmp-comptypes.h"
#include "sys-deci-funcs.h"
#include
#include
-#define LOG2 0.6931471805599453
-#define EPS 2.718281828459045235360287471
+#define LOG2 0.6931471805599453
+#define EPS 2.718281828459045235360287471
-const double pi1 = 3.14159265358979323846;
-const double pi2 = 2.0 * 3.14159265358979323846;
+#ifndef PI
+ #define PI 3.14159265358979323846E0
+#endif
#ifndef DBL_EPSILON
-#define DBL_EPSILON 2.2204460492503131E-16
+ #define DBL_EPSILON 2.2204460492503131E-16
#endif
-#define AS_DECIMAL(n) (IS_INTEGER(n) ? (REBDEC)VAL_INT64(n) : VAL_DECIMAL(n))
+#define AS_DECIMAL(n) (IS_INTEGER(n) ? (REBDEC)VAL_INT64(n) : VAL_DECIMAL(n))
enum {SINE, COSINE, TANGENT};
-/***********************************************************************
-**
-*/ static REBDEC Trig_Value(REBVAL *ds, REBCNT which)
-/*
-** Convert integer arg, if present, to decimal and convert to radians
-** if necessary. Clip ranges for correct REBOL behavior.
-**
-***********************************************************************/
+//
+// Trig_Value: C
+//
+// Convert integer arg, if present, to decimal and convert to radians
+// if necessary. Clip ranges for correct REBOL behavior.
+//
+static REBDEC Trig_Value(const REBVAL *value, REBOOL degrees, REBCNT which)
{
- REBDEC dval;
-
- dval = AS_DECIMAL(D_ARG(1));
+ REBDEC dval = AS_DECIMAL(value);
- if (!D_REF(2)) {
+ if (degrees) {
/* get dval between -360.0 and 360.0 */
dval = fmod (dval, 360.0);
@@ -75,498 +75,875 @@ enum {SINE, COSINE, TANGENT};
/* get dval between -90.0 and 90.0 */
if (fabs (dval) > 90.0) dval = (dval < 0.0 ? -180.0 : 180.0) - dval;
}
- dval = dval * pi1 / 180.0; // to radians
+ dval = dval * PI / 180.0; // to radians
}
- return dval;
+ return dval;
}
-/***********************************************************************
-**
-*/ static void Arc_Trans(REBVAL *ds, REBCNT kind)
-/*
-***********************************************************************/
+//
+// Arc_Trans: C
+//
+static void Arc_Trans(REBVAL *out, const REBVAL *value, REBOOL degrees, REBCNT kind)
{
- REBDEC dval;
+ REBDEC dval = AS_DECIMAL(value);
+ if (kind != TANGENT && (dval < -1 || dval > 1)) fail (Error_Overflow_Raw());
- dval = AS_DECIMAL(D_ARG(1));
- if (kind != TANGENT && (dval < -1 || dval > 1)) Trap0(RE_OVERFLOW);
+ if (kind == SINE) dval = asin(dval);
+ else if (kind == COSINE) dval = acos(dval);
+ else dval = atan(dval);
- if (kind == SINE) dval = asin(dval);
- else if (kind == COSINE) dval = acos(dval);
- else dval = atan(dval);
+ if (degrees)
+ dval = dval * 180.0 / PI; // to degrees
- if (!D_REF(2)) dval = dval * 180.0 / pi1; // to degrees
-
- SET_DECIMAL(D_RET, dval);
+ Init_Decimal(out, dval);
}
-/***********************************************************************
-**
-*/ REBNATIVE(cosine)
-/*
-***********************************************************************/
+//
+// cosine: native [
+//
+// "Returns the trigonometric cosine."
+//
+// value [any-number!]
+// "In degrees by default"
+// /radians
+// "Value is specified in radians"
+// ]
+//
+REBNATIVE(cosine)
{
- REBDEC dval = cos(Trig_Value(ds, COSINE));
- if (fabs(dval) < DBL_EPSILON) dval = 0.0;
- SET_DECIMAL(D_RET, dval);
- return R_RET;
+ INCLUDE_PARAMS_OF_COSINE;
+
+ REBDEC dval = cos(Trig_Value(ARG(value), NOT(REF(radians)), COSINE));
+ if (fabs(dval) < DBL_EPSILON) dval = 0.0;
+ Init_Decimal(D_OUT, dval);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(sine)
-/*
-***********************************************************************/
+//
+// sine: native [
+//
+// "Returns the trigonometric sine."
+//
+// value [any-number!]
+// "In degrees by default"
+// /radians
+// "Value is specified in radians"
+// ]
+//
+REBNATIVE(sine)
{
- REBDEC dval = sin(Trig_Value(ds, SINE));
- if (fabs(dval) < DBL_EPSILON) dval = 0.0;
- SET_DECIMAL(D_RET, dval);
- return R_RET;
+ INCLUDE_PARAMS_OF_SINE;
+
+ REBDEC dval = sin(Trig_Value(ARG(value), NOT(REF(radians)), SINE));
+ if (fabs(dval) < DBL_EPSILON) dval = 0.0;
+ Init_Decimal(D_OUT, dval);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(tangent)
-/*
-***********************************************************************/
+//
+// tangent: native [
+//
+// "Returns the trigonometric tangent."
+//
+// value [any-number!]
+// "In degrees by default"
+// /radians
+// "Value is specified in radians"
+// ]
+//
+REBNATIVE(tangent)
{
- REBDEC dval = Trig_Value(ds, TANGENT);
- if (Eq_Decimal(fabs(dval), pi1 / 2.0)) Trap0(RE_OVERFLOW);
- SET_DECIMAL(D_RET, tan(dval));
- return R_RET;
-}
+ INCLUDE_PARAMS_OF_TANGENT;
+ REBDEC dval = Trig_Value(ARG(value), NOT(REF(radians)), TANGENT);
+ if (Eq_Decimal(fabs(dval), PI / 2.0))
+ fail (Error_Overflow_Raw());
-/***********************************************************************
-**
-*/ REBNATIVE(arccosine)
-/*
-***********************************************************************/
-{
- Arc_Trans(ds, COSINE);
- return R_RET;
+ Init_Decimal(D_OUT, tan(dval));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(arcsine)
-/*
-***********************************************************************/
+//
+// arccosine: native [
+//
+// {Returns the trigonometric arccosine (in degrees by default).}
+//
+// value [any-number!]
+// /radians
+// "Returns result in radians"
+// ]
+//
+REBNATIVE(arccosine)
{
- Arc_Trans(ds, SINE);
- return R_RET;
+ INCLUDE_PARAMS_OF_ARCCOSINE;
+
+ Arc_Trans(D_OUT, ARG(value), NOT(REF(radians)), COSINE);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(arctangent)
-/*
-***********************************************************************/
+//
+// arcsine: native [
+//
+// {Returns the trigonometric arcsine (in degrees by default).}
+//
+// value [any-number!]
+// /radians
+// "Returns result in radians"
+// ]
+//
+REBNATIVE(arcsine)
{
- Arc_Trans(ds, TANGENT);
- return R_RET;
+ INCLUDE_PARAMS_OF_ARCSINE;
+
+ Arc_Trans(D_OUT, ARG(value), NOT(REF(radians)), SINE);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(exp)
-/*
-***********************************************************************/
+//
+// arctangent: native [
+//
+// {Returns the trigonometric arctangent (in degrees by default).}
+//
+// value [any-number!]
+// /radians
+// "Returns result in radians"
+// ]
+//
+REBNATIVE(arctangent)
{
- REBDEC dval = AS_DECIMAL(D_ARG(1));
- static REBDEC eps = EPS;
+ INCLUDE_PARAMS_OF_ARCTANGENT;
- dval = pow(eps, dval);
-//!!!! Check_Overflow(dval);
- SET_DECIMAL(D_RET, dval);
- return R_RET;
+ Arc_Trans(D_OUT, ARG(value), NOT(REF(radians)), TANGENT);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(log_10)
-/*
-***********************************************************************/
+//
+// exp: native [
+//
+// {Raises E (the base of natural logarithm) to the power specified}
+//
+// power [any-number!]
+// ]
+//
+REBNATIVE(exp)
{
- REBDEC dval = AS_DECIMAL(D_ARG(1));
- if (dval <= 0) Trap0(RE_POSITIVE);
- SET_DECIMAL(D_RET, log10(dval));
- return R_RET;
+ INCLUDE_PARAMS_OF_EXP;
+
+ REBDEC dval = AS_DECIMAL(ARG(power));
+ static REBDEC eps = EPS;
+
+ dval = pow(eps, dval);
+//!!!! Check_Overflow(dval);
+ Init_Decimal(D_OUT, dval);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(log_2)
-/*
-***********************************************************************/
+//
+// log-10: native [
+//
+// "Returns the base-10 logarithm."
+//
+// value [any-number!]
+// ]
+//
+REBNATIVE(log_10)
{
- REBDEC dval = AS_DECIMAL(D_ARG(1));
- if (dval <= 0) Trap0(RE_POSITIVE);
- SET_DECIMAL(D_RET, log(dval) / LOG2);
- return R_RET;
+ INCLUDE_PARAMS_OF_LOG_10;
+
+ REBDEC dval = AS_DECIMAL(ARG(value));
+ if (dval <= 0) fail (Error_Positive_Raw());
+ Init_Decimal(D_OUT, log10(dval));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(log_e)
-/*
-***********************************************************************/
+//
+// log-2: native [
+//
+// "Return the base-2 logarithm."
+//
+// value [any-number!]
+// ]
+//
+REBNATIVE(log_2)
{
- REBDEC dval = AS_DECIMAL(D_ARG(1));
- if (dval <= 0) Trap0(RE_POSITIVE);
- SET_DECIMAL(D_RET, log(dval));
- return R_RET;
+ INCLUDE_PARAMS_OF_LOG_2;
+
+ REBDEC dval = AS_DECIMAL(ARG(value));
+ if (dval <= 0) fail (Error_Positive_Raw());
+ Init_Decimal(D_OUT, log(dval) / LOG2);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(square_root)
-/*
-***********************************************************************/
+//
+// log-e: native [
+//
+// {Returns the natural (base-E) logarithm of the given value}
+//
+// value [any-number!]
+// ]
+//
+REBNATIVE(log_e)
{
- REBDEC dval = AS_DECIMAL(D_ARG(1));
- if (dval < 0) Trap0(RE_POSITIVE);
- SET_DECIMAL(D_RET, sqrt(dval));
- return R_RET;
+ INCLUDE_PARAMS_OF_LOG_E;
+
+ REBDEC dval = AS_DECIMAL(ARG(value));
+ if (dval <= 0) fail (Error_Positive_Raw());
+ Init_Decimal(D_OUT, log(dval));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(shift)
-/*
-** shift int bits arithmetic or logical
-**
-***********************************************************************/
+//
+// square-root: native [
+//
+// "Returns the square root of a number."
+//
+// value [any-number!]
+// ]
+//
+REBNATIVE(square_root)
{
- REBI64 b = VAL_INT64(D_ARG(2));
- REBVAL *a = D_ARG(1);
- REBU64 c, d;
-
- if (b < 0) {
- // this is defined:
- c = -(REBU64)b;
- if (c >= 64) {
- if (D_REF(3)) VAL_INT64(a) = 0;
- else VAL_INT64(a) >>= 63;
- } else {
- if (D_REF(3)) VAL_UNT64(a) >>= c;
- else VAL_INT64(a) >>= (REBI64)c;
- }
- } else {
- if (b >= 64) {
- if (D_REF(3)) VAL_INT64(a) = 0;
- else if (VAL_INT64(a)) Trap0(RE_OVERFLOW);
- } else
- if (D_REF(3)) VAL_UNT64(a) <<= b;
- else {
- c = (REBU64)MIN_I64 >> b;
- d = VAL_INT64(a) < 0 ? -VAL_UNT64(a) : VAL_UNT64(a);
- if (c <= d)
- if ((c < d) || (VAL_INT64(a) >= 0)) Trap0(RE_OVERFLOW);
- else VAL_INT64(a) = MIN_I64;
- else
- VAL_INT64(a) <<= b;
- }
- }
- return R_ARG1;
+ INCLUDE_PARAMS_OF_SQUARE_ROOT;
+
+ REBDEC dval = AS_DECIMAL(ARG(value));
+ if (dval < 0) fail (Error_Positive_Raw());
+ Init_Decimal(D_OUT, sqrt(dval));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBINT Compare_Values(REBVAL *a, REBVAL *b, REBINT strictness)
-/*
-** Compare 2 values depending on level of strictness.
-** NOTE: MODIFIES a and b args.
-**
-** Strictness:
-** 0 - coersed equality
-** 1 - equivalence
-** 2 - strict equality
-** 3 - same (identical bits)
-**
-** -1 - greater or equal
-** -2 - greater
-**
-***********************************************************************/
+
+//
+// The SHIFT native uses negation of an unsigned number. Although the
+// operation is well-defined in the C language, it is usually a mistake.
+// MSVC warns about it, so temporarily disable that.
+//
+// !!! The usage of negation of unsigned in SHIFT is from R3-Alpha. Should it
+// be rewritten another way?
+//
+// http://stackoverflow.com/a/36349666/211160
+//
+#if defined(_MSC_VER) && _MSC_VER > 1800
+ #pragma warning (disable : 4146)
+#endif
+
+
+//
+// shift: native [
+//
+// {Shifts an integer left or right by a number of bits.}
+//
+// value [integer!]
+// bits [integer!]
+// "Positive for left shift, negative for right shift"
+// /logical
+// "Logical shift (sign bit ignored)"
+// ]
+//
+REBNATIVE(shift)
{
- REBCNT ta = VAL_TYPE(a);
- REBCNT tb = VAL_TYPE(b);
- REBCTF code;
- REBINT result;
-
- if (ta != tb) {
- if (strictness > 1) return FALSE;
-
- switch (ta) {
- case REB_INTEGER:
- if (tb == REB_DECIMAL || tb == REB_PERCENT) {
- SET_DECIMAL(a, (REBDEC)VAL_INT64(a));
- goto compare;
- }
- else if (tb == REB_MONEY) {
- SET_MONEY(a, int_to_deci(VAL_INT64(a)));
- goto compare;
- }
- else if (tb == REB_INTEGER) // special negative?, zero?, ...
- goto compare;
- break;
-
- case REB_DECIMAL:
- case REB_PERCENT:
- if (tb == REB_INTEGER) {
- SET_DECIMAL(b, (REBDEC)VAL_INT64(b));
- goto compare;
- }
- else if (tb == REB_MONEY) {
- SET_MONEY(a, decimal_to_deci(VAL_DECIMAL(a)));
- goto compare;
- }
- else if (tb == REB_DECIMAL || tb == REB_PERCENT) // equivalent types
- goto compare;
- break;
-
- case REB_MONEY:
- if (tb == REB_INTEGER) {
- SET_MONEY(b, int_to_deci(VAL_INT64(b)));
- goto compare;
- }
- if (tb == REB_DECIMAL || tb == REB_PERCENT) {
- SET_MONEY(b, decimal_to_deci(VAL_DECIMAL(b)));
- goto compare;
- }
- break;
-
- case REB_WORD:
- case REB_SET_WORD:
- case REB_GET_WORD:
- case REB_LIT_WORD:
- case REB_REFINEMENT:
- case REB_ISSUE:
- if (ANY_WORD(b)) goto compare;
- break;
-
- case REB_STRING:
- case REB_FILE:
- case REB_EMAIL:
- case REB_URL:
- case REB_TAG:
- if (ANY_STR(b)) goto compare;
- break;
- }
-
- if (strictness == 0 || strictness == 1) return FALSE;
- //if (strictness >= 2)
- Trap2(RE_INVALID_COMPARE, Of_Type(a), Of_Type(b));
- }
+ INCLUDE_PARAMS_OF_SHIFT;
+
+ REBI64 b = VAL_INT64(ARG(bits));
+ REBVAL *a = ARG(value);
+
+ if (b < 0) {
+ REBU64 c = - cast(REBU64, b); // defined, see note on #pragma above
+ if (c >= 64) {
+ if (REF(logical))
+ VAL_INT64(a) = 0;
+ else
+ VAL_INT64(a) >>= 63;
+ }
+ else {
+ if (REF(logical))
+ VAL_INT64(a) = cast(REBU64, VAL_INT64(a)) >> c;
+ else
+ VAL_INT64(a) >>= cast(REBI64, c);
+ }
+ }
+ else {
+ if (b >= 64) {
+ if (REF(logical))
+ VAL_INT64(a) = 0;
+ else if (VAL_INT64(a) != 0)
+ fail (Error_Overflow_Raw());
+ }
+ else {
+ if (REF(logical))
+ VAL_INT64(a) = cast(REBU64, VAL_INT64(a)) << b;
+ else {
+ REBU64 c = cast(REBU64, MIN_I64) >> b;
+ REBU64 d = VAL_INT64(a) < 0
+ ? - cast(REBU64, VAL_INT64(a)) // again, see #pragma
+ : cast(REBU64, VAL_INT64(a));
+ if (c <= d) {
+ if ((c < d) || (VAL_INT64(a) >= 0))
+ fail (Error_Overflow_Raw());
+
+ VAL_INT64(a) = MIN_I64;
+ }
+ else
+ VAL_INT64(a) <<= b;
+ }
+ }
+ }
-compare:
- // At this point, both args are of the same datatype.
- if (!(code = Compare_Types[VAL_TYPE(a)])) return FALSE;
- result = code(a, b, strictness);
- if (result < 0) Trap2(RE_INVALID_COMPARE, Of_Type(a), Of_Type(b));
- return result;
+ Move_Value(D_OUT, ARG(value));
+ return R_OUT;
}
-// EQUAL? < EQUIV? < STRICT-EQUAL? < SAME?
+// See above for the temporary disablement and reasoning.
+//
+#if defined(_MSC_VER) && _MSC_VER > 1800
+ #pragma warning (default : 4146)
+#endif
+
-/***********************************************************************
-**
-*/ REBNATIVE(equalq)
-/*
-***********************************************************************/
+// CT_Fail: C
+//
+REBINT CT_Fail(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- if (Compare_Values(D_ARG(1), D_ARG(2), 0)) return R_TRUE;
- return R_FALSE;
+ UNUSED(a);
+ UNUSED(b);
+ UNUSED(mode);
+
+ fail ("Datatype does not have type comparison handler registered");
}
-/***********************************************************************
-**
-*/ REBNATIVE(not_equalq)
-/*
-***********************************************************************/
+
+//
+// Compare_Modify_Values: C
+//
+// Compare 2 values depending on level of strictness. It leans
+// upon the per-type comparison functions (that have a more typical
+// interface of returning [1, 0, -1] and taking a CASE parameter)
+// but adds a layer of being able to check for specific types
+// of equality...which those comparison functions do not discern.
+//
+// Strictness:
+// 0 - coerced equality
+// 1 - strict equality
+//
+// -1 - greater or equal
+// -2 - greater
+//
+// !!! This routine (may) modify the value cells for 'a' and 'b' in
+// order to coerce them for easier comparison. Most usages are
+// in native code that can overwrite its argument values without
+// that being a problem, so it doesn't matter.
+//
+REBINT Compare_Modify_Values(RELVAL *a, RELVAL *b, REBINT strictness)
{
- if (Compare_Values(D_ARG(1), D_ARG(2), 0)) return R_FALSE;
- return R_TRUE;
+ REBCNT ta = VAL_TYPE(a);
+ REBCNT tb = VAL_TYPE(b);
+ REBCTF code;
+ REBINT result;
+
+ if (ta != tb) {
+ if (strictness == 1) return 0;
+
+ switch (ta) {
+ case REB_MAX_VOID:
+ return 0; // nothing coerces to void
+
+ case REB_INTEGER:
+ if (tb == REB_DECIMAL || tb == REB_PERCENT) {
+ REBDEC dec_a = cast(REBDEC, VAL_INT64(a));
+ Init_Decimal(a, dec_a);
+ goto compare;
+ }
+ else if (tb == REB_MONEY) {
+ deci amount = int_to_deci(VAL_INT64(a));
+ Init_Money(a, amount);
+ goto compare;
+ }
+ break;
+
+ case REB_DECIMAL:
+ case REB_PERCENT:
+ if (tb == REB_INTEGER) {
+ REBDEC dec_b = cast(REBDEC, VAL_INT64(b));
+ Init_Decimal(b, dec_b);
+ goto compare;
+ }
+ else if (tb == REB_MONEY) {
+ Init_Money(a, decimal_to_deci(VAL_DECIMAL(a)));
+ goto compare;
+ }
+ else if (tb == REB_DECIMAL || tb == REB_PERCENT) // equivalent types
+ goto compare;
+ break;
+
+ case REB_MONEY:
+ if (tb == REB_INTEGER) {
+ Init_Money(b, int_to_deci(VAL_INT64(b)));
+ goto compare;
+ }
+ if (tb == REB_DECIMAL || tb == REB_PERCENT) {
+ Init_Money(b, decimal_to_deci(VAL_DECIMAL(b)));
+ goto compare;
+ }
+ break;
+
+ case REB_WORD:
+ case REB_SET_WORD:
+ case REB_GET_WORD:
+ case REB_LIT_WORD:
+ case REB_REFINEMENT:
+ case REB_ISSUE:
+ if (ANY_WORD(b)) goto compare;
+ break;
+
+ case REB_STRING:
+ case REB_FILE:
+ case REB_EMAIL:
+ case REB_URL:
+ case REB_TAG:
+ if (ANY_STRING(b)) goto compare;
+ break;
+ }
+
+ if (strictness == 0) return 0;
+
+ fail (Error_Invalid_Compare_Raw(Type_Of(a), Type_Of(b)));
+ }
+
+ if (ta == REB_MAX_VOID) return 1; // voids always equal
+
+compare:
+ // At this point, both args are of the same datatype.
+ if (!(code = Compare_Types[VAL_TYPE(a)])) return 0;
+ result = code(a, b, strictness);
+ if (result < 0) fail (Error_Invalid_Compare_Raw(Type_Of(a), Type_Of(b)));
+ return result;
}
-/***********************************************************************
-**
-*/ REBNATIVE(equivq)
-/*
-***********************************************************************/
+
+// EQUAL? < EQUIV? < STRICT-EQUAL? < SAME?
+
+//
+// equal?: native [
+//
+// "Returns TRUE if the values are equal."
+//
+// value1 [ any-value!]
+// value2 [ any-value!]
+// ]
+//
+REBNATIVE(equal_q)
{
- if (Compare_Values(D_ARG(1), D_ARG(2), 1)) return R_TRUE;
- return R_FALSE;
+ INCLUDE_PARAMS_OF_EQUAL_Q;
+
+ if (Compare_Modify_Values(ARG(value1), ARG(value2), 0))
+ return R_TRUE;
+
+ return R_FALSE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(not_equivq)
-/*
-***********************************************************************/
+
+//
+// not-equal?: native [
+//
+// "Returns TRUE if the values are not equal."
+//
+// value1 [ any-value!]
+// value2 [ any-value!]
+// ]
+//
+REBNATIVE(not_equal_q)
{
- if (Compare_Values(D_ARG(1), D_ARG(2), 1)) return R_FALSE;
- return R_TRUE;
+ INCLUDE_PARAMS_OF_NOT_EQUAL_Q;
+
+ if (Compare_Modify_Values(ARG(value1), ARG(value2), 0))
+ return R_FALSE;
+
+ return R_TRUE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(strict_equalq)
-/*
-***********************************************************************/
+
+//
+// strict-equal?: native [
+//
+// "Returns TRUE if the values are strictly equal."
+//
+// value1 [ any-value!]
+// value2 [ any-value!]
+// ]
+//
+REBNATIVE(strict_equal_q)
{
- if (Compare_Values(D_ARG(1), D_ARG(2), 2)) return R_TRUE;
- return R_FALSE;
+ INCLUDE_PARAMS_OF_STRICT_EQUAL_Q;
+
+ if (Compare_Modify_Values(ARG(value1), ARG(value2), 1))
+ return R_TRUE;
+
+ return R_FALSE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(strict_not_equalq)
-/*
-***********************************************************************/
+
+//
+// strict-not-equal?: native [
+//
+// "Returns TRUE if the values are not strictly equal."
+//
+// value1 [ any-value!]
+// value2 [ any-value!]
+// ]
+//
+REBNATIVE(strict_not_equal_q)
{
- if (Compare_Values(D_ARG(1), D_ARG(2), 2)) return R_FALSE;
- return R_TRUE;
+ INCLUDE_PARAMS_OF_STRICT_NOT_EQUAL_Q;
+
+ if (Compare_Modify_Values(ARG(value1), ARG(value2), 1))
+ return R_FALSE;
+
+ return R_TRUE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(sameq)
-/*
-***********************************************************************/
+
+//
+// same?: native [
+//
+// "Returns TRUE if the values are identical."
+//
+// value1 [ any-value!]
+// value2 [ any-value!]
+// ]
+//
+REBNATIVE(same_q)
+//
+// This used to be "strictness mode 3" of Compare_Modify_Values. However,
+// folding SAME?-ness in required the comparisons to take REBVALs instead
+// of just REBVALs, when only a limited number of types supported it.
+// Rather than incur a cost for all comparisons, this handles the issue
+// specially for those types which support it.
{
- if (Compare_Values(D_ARG(1), D_ARG(2), 3)) return R_TRUE;
- return R_FALSE;
+ INCLUDE_PARAMS_OF_SAME_Q;
+
+ REBVAL *value1 = ARG(value1);
+ REBVAL *value2 = ARG(value2);
+
+ if (VAL_TYPE(value1) != VAL_TYPE(value2))
+ return R_FALSE; // can't be "same" value if not same type
+
+ if (IS_BITSET(value1)) {
+ //
+ // BITSET! only has a series, no index.
+ //
+ if (VAL_SERIES(value1) != VAL_SERIES(value2))
+ return R_FALSE;
+ return R_TRUE;
+ }
+
+ if (ANY_SERIES(value1) || IS_IMAGE(value1)) {
+ //
+ // ANY-SERIES! can only be the same if pointers and indices match.
+ //
+ if (VAL_SERIES(value1) != VAL_SERIES(value2))
+ return R_FALSE;
+ if (VAL_INDEX(value1) != VAL_INDEX(value2))
+ return R_FALSE;
+ return R_TRUE;
+ }
+
+ if (ANY_CONTEXT(value1)) {
+ //
+ // ANY-CONTEXT! are the same if the varlists match.
+ //
+ if (VAL_CONTEXT(value1) != VAL_CONTEXT(value2))
+ return R_FALSE;
+ return R_TRUE;
+ }
+
+ if (IS_MAP(value1)) {
+ //
+ // MAP! will be the same if the map pointer matches.
+ //
+ if (VAL_MAP(value1) != VAL_MAP(value2))
+ return R_FALSE;
+ return R_TRUE;
+ }
+
+ if (ANY_WORD(value1)) {
+ //
+ // ANY-WORD! must match in binding as well as be otherwise equal.
+ //
+ if (VAL_WORD_SPELLING(value1) != VAL_WORD_SPELLING(value2))
+ return R_FALSE;
+ if (IS_WORD_BOUND(value1) != IS_WORD_BOUND(value2))
+ return R_FALSE;
+ if (IS_WORD_BOUND(value1)) {
+ REBCTX *ctx1 = VAL_WORD_CONTEXT(value1);
+ REBCTX *ctx2 = VAL_WORD_CONTEXT(value2);
+ if (ctx1 != ctx2)
+ return R_FALSE;
+ }
+ return R_TRUE;
+ }
+
+ if (IS_DECIMAL(value1) || IS_PERCENT(value1)) {
+ //
+ // The tolerance on strict-equal? for decimals is apparently not
+ // a requirement of exactly the same bits.
+ //
+ if (
+ memcmp(
+ &VAL_DECIMAL(value1), &VAL_DECIMAL(value2), sizeof(REBDEC)
+ ) == 0
+ ){
+ return R_TRUE;
+ }
+
+ return R_FALSE;
+ }
+
+ if (IS_MONEY(value1)) {
+ //
+ // There is apparently a distinction between "strict equal" and "same"
+ // when it comes to the MONEY! type:
+ //
+ // >> strict-equal? $1 $1.0
+ // == true
+ //
+ // >> same? $1 $1.0
+ // == false
+ //
+ if (deci_is_same(VAL_MONEY_AMOUNT(value1), VAL_MONEY_AMOUNT(value2)))
+ return R_TRUE;
+ return R_FALSE;
+ }
+
+ // For other types, just fall through to strict equality comparison
+ //
+ if (Compare_Modify_Values(value1, value2, 1))
+ return R_TRUE;
+
+ return R_FALSE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(lesserq)
-/*
-***********************************************************************/
+
+//
+// lesser?: native [
+//
+// {Returns TRUE if the first value is less than the second value.}
+//
+// value1 value2
+// ]
+//
+REBNATIVE(lesser_q)
{
- if (Compare_Values(D_ARG(1), D_ARG(2), -1)) return R_FALSE;
- return R_TRUE;
+ INCLUDE_PARAMS_OF_LESSER_Q;
+
+ if (Compare_Modify_Values(ARG(value1), ARG(value2), -1))
+ return R_FALSE;
+
+ return R_TRUE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(lesser_or_equalq)
-/*
-***********************************************************************/
+
+//
+// lesser-or-equal?: native [
+//
+// {Returns TRUE if the first value is less than or equal to the second value.}
+//
+// value1 value2
+// ]
+//
+REBNATIVE(lesser_or_equal_q)
{
- if (Compare_Values(D_ARG(1), D_ARG(2), -2)) return R_FALSE;
- return R_TRUE;
+ INCLUDE_PARAMS_OF_LESSER_OR_EQUAL_Q;
+
+ if (Compare_Modify_Values(ARG(value1), ARG(value2), -2))
+ return R_FALSE;
+
+ return R_TRUE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(greaterq)
-/*
-***********************************************************************/
+
+//
+// greater?: native [
+//
+// {Returns TRUE if the first value is greater than the second value.}
+//
+// value1 value2
+// ]
+//
+REBNATIVE(greater_q)
{
- if (Compare_Values(D_ARG(1), D_ARG(2), -2)) return R_TRUE;
- return R_FALSE;
+ INCLUDE_PARAMS_OF_GREATER_Q;
+
+ if (Compare_Modify_Values(ARG(value1), ARG(value2), -2))
+ return R_TRUE;
+
+ return R_FALSE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(greater_or_equalq)
-/*
-***********************************************************************/
+
+//
+// greater-or-equal?: native [
+//
+// {Returns TRUE if the first value is greater than or equal to the second value.}
+//
+// value1 value2
+// ]
+//
+REBNATIVE(greater_or_equal_q)
{
- if (Compare_Values(D_ARG(1), D_ARG(2), -1)) return R_TRUE;
- return R_FALSE;
+ INCLUDE_PARAMS_OF_GREATER_OR_EQUAL_Q;
+
+ if (Compare_Modify_Values(ARG(value1), ARG(value2), -1))
+ return R_TRUE;
+
+ return R_FALSE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(maximum)
-/*
-***********************************************************************/
+
+//
+// maximum: native [
+//
+// "Returns the greater of the two values."
+//
+// value1 [any-scalar! date! any-series!]
+// value2 [any-scalar! date! any-series!]
+// ]
+//
+REBNATIVE(maximum)
{
- REBVAL a, b;
+ INCLUDE_PARAMS_OF_MAXIMUM;
- if (IS_PAIR(D_ARG(1)) || IS_PAIR(D_ARG(2)))
- return Min_Max_Pair(ds, 1);
+ const REBVAL *value1 = ARG(value1);
+ const REBVAL *value2 = ARG(value2);
- a = *D_ARG(1);
- b = *D_ARG(2);
- if (Compare_Values(&a, &b, -1)) return R_ARG1;
- return R_ARG2;
+ if (IS_PAIR(value1) || IS_PAIR(value2)) {
+ Min_Max_Pair(D_OUT, value1, value2, TRUE);
+ }
+ else {
+ DECLARE_LOCAL (coerced1);
+ Move_Value(coerced1, value1);
+ DECLARE_LOCAL (coerced2);
+ Move_Value(coerced2, value2);
+
+ if (Compare_Modify_Values(coerced1, coerced2, -1))
+ Move_Value(D_OUT, value1);
+ else
+ Move_Value(D_OUT, value2);
+ }
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(minimum)
-/*
-***********************************************************************/
+
+//
+// minimum: native [
+//
+// "Returns the lesser of the two values."
+//
+// value1 [any-scalar! date! any-series!]
+// value2 [any-scalar! date! any-series!]
+// ]
+//
+REBNATIVE(minimum)
{
- REBVAL a, b;
+ INCLUDE_PARAMS_OF_MINIMUM;
- if (IS_PAIR(D_ARG(1)) || IS_PAIR(D_ARG(2)))
- return Min_Max_Pair(ds, 0);
+ const REBVAL *value1 = ARG(value1);
+ const REBVAL *value2 = ARG(value2);
- a = *D_ARG(1);
- b = *D_ARG(2);
- if (Compare_Values(&a, &b, -1)) return R_ARG2;
- return R_ARG1;
+ if (IS_PAIR(ARG(value1)) || IS_PAIR(ARG(value2))) {
+ Min_Max_Pair(D_OUT, ARG(value1), ARG(value2), FALSE);
+ }
+ else {
+ DECLARE_LOCAL (coerced1);
+ Move_Value(coerced1, value1);
+ DECLARE_LOCAL (coerced2);
+ Move_Value(coerced2, value2);
+
+ if (Compare_Modify_Values(coerced1, coerced2, -1))
+ Move_Value(D_OUT, value2);
+ else
+ Move_Value(D_OUT, value1);
+ }
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(negativeq)
-/*
-***********************************************************************/
+
+//
+// negative?: native [
+//
+// "Returns TRUE if the number is negative."
+//
+// number [any-number! money! time! pair!]
+// ]
+//
+REBNATIVE(negative_q)
{
- REBVAL *val = &DS_Base[++DSP];
- CLEARS(val);
- VAL_SET(val, VAL_TYPE(D_ARG(1)));
- if (Compare_Values(D_ARG(1), D_ARG(2), -1)) return R_FALSE;
- return R_TRUE;
+ INCLUDE_PARAMS_OF_NEGATIVE_Q;
+
+ DECLARE_LOCAL (zero);
+ SET_ZEROED(zero, VAL_TYPE(ARG(number)));
+
+ if (Compare_Modify_Values(ARG(number), zero, -1))
+ return R_FALSE;
+
+ return R_TRUE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(positiveq)
-/*
-***********************************************************************/
+
+//
+// positive?: native [
+//
+// "Returns TRUE if the value is positive."
+//
+// number [any-number! money! time! pair!]
+// ]
+//
+REBNATIVE(positive_q)
{
- REBVAL *val = &DS_Base[++DSP];
- CLEARS(val);
- VAL_SET(val, VAL_TYPE(D_ARG(1)));
- if (Compare_Values(D_ARG(1), D_ARG(2), -2)) return R_TRUE;
- return R_FALSE;
+ INCLUDE_PARAMS_OF_POSITIVE_Q;
+
+ DECLARE_LOCAL (zero);
+ SET_ZEROED(zero, VAL_TYPE(ARG(number)));
+
+ if (Compare_Modify_Values(ARG(number), zero, -2))
+ return R_TRUE;
+
+ return R_FALSE;
}
-/***********************************************************************
-**
-*/ REBNATIVE(zeroq)
-/*
-***********************************************************************/
+
+//
+// zero?: native [
+//
+// {Returns TRUE if the value is zero (for its datatype).}
+//
+// value
+// ]
+//
+REBNATIVE(zero_q)
{
- REBCNT type = VAL_TYPE(D_ARG(1));
-
- if (type >= REB_INTEGER && type <= REB_TIME) {
- REBVAL *val = &DS_Base[++DSP];
- CLEARS(val);
- VAL_SET(val, type);
- if (Compare_Values(D_ARG(1), D_ARG(2), 1)) return R_TRUE;
- }
- return R_FALSE;
+ INCLUDE_PARAMS_OF_ZERO_Q;
+
+ enum Reb_Kind type = VAL_TYPE(ARG(value));
+
+ if (type >= REB_INTEGER && type <= REB_TIME) {
+ DECLARE_LOCAL (zero);
+ SET_ZEROED(zero, type);
+
+ if (Compare_Modify_Values(ARG(value), zero, 1))
+ return R_TRUE;
+ }
+ return R_FALSE;
}
diff --git a/src/core/n-native.c b/src/core/n-native.c
new file mode 100644
index 0000000000..c70a87a391
--- /dev/null
+++ b/src/core/n-native.c
@@ -0,0 +1,679 @@
+//
+// File: %n-native.c
+// Summary: {Implementation of "user natives" using an embedded C compiler}
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2016 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// A user native is a FUNCTION! whose body is not a Rebol block, but a textual
+// string of C code. It is compiled on the fly by an embedded C compiler
+// which is linked in with those Rebol builds supporting user natives:
+//
+// http://bellard.org/tcc
+//
+// Once the user native is compiled, it works exactly the same as the built-in
+// natives. However, the user can change the implementations without
+// rebuilding the interpreter itself. This makes it easier to just implement
+// part of a Rebol script in C for better performance.
+//
+// The preprocessed internal header file %sys-core.h will be inserted into
+// user source code, which makes all internal functions / macros available.
+// However, to use C runtime functions such as memcpy() etc, the library
+// libtcc1.a must be included. This library must be available in addition
+// to the interpreter executable.
+//
+// External libraries can also be used if proper 'library-path' and
+// 'library' are specified.
+//
+
+#include "sys-core.h"
+
+#if defined(WITH_TCC)
+//
+// libtcc provides the following functions:
+//
+// https://github.com/metaeducation/tcc/blob/mob/libtcc.h
+//
+// For a very simple example of usage of libtcc, see:
+//
+// https://github.com/metaeducation/tcc/blob/mob/tests/libtcc_test.c
+//
+#include "libtcc.h"
+
+extern const REBYTE core_header_source[];
+
+struct rebol_sym_func_t {
+ const char *name;
+ CFUNC *func;
+};
+
+struct rebol_sym_data_t {
+ const char *name;
+ void *data;
+};
+
+extern const struct rebol_sym_func_t rebol_sym_funcs[];
+extern const struct rebol_sym_data_t rebol_sym_data[];
+extern
+#ifdef __cplusplus
+"C"
+#endif
+const void *r3_libtcc1_symbols[];
+
+#define CHAR_HEAD(x) cs_cast(BIN_HEAD(x))
+
+
+static void tcc_error_report(void *ignored, const char *msg)
+{
+ UNUSED(ignored);
+
+ DECLARE_LOCAL (err);
+ REBSER *ser = Make_Binary(strlen(msg) + 2);
+ Append_Series(ser, cb_cast(msg), strlen(msg));
+ Init_String(err, ser);
+ fail (Error_Tcc_Error_Warn_Raw(err));
+}
+
+
+static int do_add_path(
+ TCCState *state,
+ const RELVAL *path,
+ int (*add)(TCCState *, const char *)
+) {
+ if (!VAL_BYTE_SIZE(path))
+ return -1;
+
+ int ret;
+ if (IS_FILE(path)) {
+ REBSER *lp = Value_To_Local_Path(KNOWN(m_cast(RELVAL*,path)), TRUE);
+ REBSER *bin = Make_UTF8_Binary(
+ UNI_HEAD(lp), SER_LEN(lp), 2, OPT_ENC_UNISRC
+ );
+ Free_Series(lp);
+ assert(SER_WIDE(bin) == 1);
+ ret = add(state, CHAR_HEAD(bin));
+ Free_Series(bin);
+ }
+ else {
+ assert(IS_STRING(path));
+ ret = add(state, CHAR_HEAD(VAL_SERIES(path)));
+ }
+ return ret;
+}
+
+
+static void do_set_path(
+ TCCState *state,
+ const RELVAL *path,
+ void (*set)(TCCState *, const char *)
+) {
+ if (!VAL_BYTE_SIZE(path))
+ return;
+
+ if (IS_FILE(path)) {
+ REBSER *lp = Value_To_Local_Path(KNOWN(m_cast(RELVAL*, path)), TRUE);
+ REBSER *bin = Make_UTF8_Binary(
+ UNI_HEAD(lp), SER_LEN(lp), 2, OPT_ENC_UNISRC
+ );
+ Free_Series(lp);
+ assert(SER_WIDE(bin) == 1);
+ set(state, CHAR_HEAD(bin));
+ Free_Series(bin);
+ }
+ else {
+ assert(IS_STRING(path));
+ set(state, CHAR_HEAD(VAL_SERIES(path)));
+ }
+}
+
+
+static REBCTX* add_path(
+ TCCState *state,
+ const RELVAL *path,
+ int (*add)(TCCState *, const char *),
+ enum REBOL_Errors err_code
+) {
+ if (path) {
+ if (IS_FILE(path) || IS_STRING(path)) {
+ if (do_add_path(state, path, add) < 0)
+ return Error(err_code, path);
+ }
+ else {
+ assert(IS_BLOCK(path));
+
+ RELVAL *item;
+ for (item = VAL_ARRAY_AT(path); NOT_END(item); ++item) {
+ if (!IS_FILE(item) && !IS_STRING(item))
+ return Error(err_code, item);
+
+ if (do_add_path(state, item, add) < 0)
+ return Error(err_code, item);
+ }
+ }
+ }
+
+ return NULL;
+}
+
+
+static void cleanup(const REBVAL *val)
+{
+ TCCState *state = VAL_HANDLE_POINTER(TCCState, val);
+ assert(state != NULL);
+ tcc_delete(state);
+}
+
+
+//
+// Pending_Native_Dispatcher: C
+//
+// The MAKE-NATIVE command doesn't actually compile the function directly.
+// Instead the source code is held onto, so that several user natives can
+// be compiled together by COMPILE.
+//
+// However, as a convenience, calling a pending user native will trigger a
+// simple COMPILE for just that one function, using default options.
+//
+REB_R Pending_Native_Dispatcher(REBFRM *f) {
+ REBARR *array = Make_Array(1);
+ Append_Value(array, FUNC_VALUE(f->phase));
+
+ DECLARE_LOCAL (natives);
+ Init_Block(natives, array);
+
+ assert(FUNC_DISPATCHER(f->phase) == &Pending_Native_Dispatcher);
+
+ if (Do_Va_Throws(f->out, NAT_VALUE(compile), &natives, END))
+ return R_OUT_IS_THROWN;
+
+ // Today's COMPILE doesn't return a result on success (just fails on
+ // errors), but if it changes to return one consider what to do with it.
+ //
+ assert(IS_VOID(f->out));
+
+ // Now that it's compiled, it should have replaced the dispatcher with a
+ // function pointer that lives in the TCC_State. Use REDO, and don't
+ // bother re-checking the argument types.
+ //
+ assert(FUNC_DISPATCHER(f->phase) != &Pending_Native_Dispatcher);
+ return R_REDO_UNCHECKED;
+}
+
+#endif
+
+
+//
+// make-native: native [
+//
+// {Create a "user native" function compiled from C source}
+//
+// return: [function!]
+// "Function value, will be compiled on demand or by COMPILE"
+// spec [block!]
+// "The spec of the native"
+// source [string!]
+// "C source of the native implementation"
+// /linkname
+// "Provide a specific linker name"
+// name [string!]
+// "Legal C identifier (default will be auto-generated)"
+// ]
+//
+REBNATIVE(make_native)
+{
+ INCLUDE_PARAMS_OF_MAKE_NATIVE;
+
+#if !defined(WITH_TCC)
+ UNUSED(ARG(spec));
+ UNUSED(ARG(source));
+ UNUSED(REF(linkname));
+ UNUSED(ARG(name));
+
+ fail (Error_Not_Tcc_Build_Raw());
+#else
+ REBVAL *source = ARG(source);
+
+ if (VAL_LEN_AT(source) == 0)
+ fail (Error_Tcc_Empty_Source_Raw());
+
+ REBFUN *fun = Make_Function(
+ Make_Paramlist_Managed_May_Fail(ARG(spec), MKF_NONE),
+ &Pending_Native_Dispatcher, // will be replaced e.g. by COMPILE
+ NULL, // no underlying function, this is fundamental
+ NULL // not providing a specialization
+ );
+
+ REBARR *info = Make_Array(3); // [source name tcc_state]
+
+ if (Is_Series_Frozen(VAL_SERIES(source)))
+ Append_Value(info, source); // no need to copy it...
+ else {
+ // have to copy it (might change before COMPILE is called)
+ //
+ Init_String(
+ Alloc_Tail_Array(info),
+ Copy_String_Slimming(
+ VAL_SERIES(source),
+ VAL_INDEX(source),
+ VAL_LEN_AT(source)
+ )
+ );
+ }
+
+ if (REF(linkname)) {
+ REBVAL *name = ARG(name);
+
+ if (Is_Series_Frozen(VAL_SERIES(name)))
+ Append_Value(info, name);
+ else {
+ Init_String(
+ Alloc_Tail_Array(info),
+ Copy_String_Slimming(
+ VAL_SERIES(name),
+ VAL_INDEX(name),
+ VAL_LEN_AT(name)
+ )
+ );
+ }
+ }
+ else {
+ // Auto-generate a linker name based on the numeric value of the
+ // function pointer. Just "N_" followed by the hexadecimal value.
+ // So 2 chars per byte, plus 2 for "N_", and account for the
+ // terminator (even though it's set implicitly).
+
+ REBCNT len = 2 + sizeof(REBFUN*) * 2;
+ REBSER *bin = Make_Binary(len + 1);
+ const char *src = cast(const char*, &fun);
+ REBYTE *dest = BIN_HEAD(bin);
+
+ *dest ='N';
+ ++dest;
+ *dest = '_';
+ ++dest;
+
+ REBCNT n = 0;
+ while (n < sizeof(REBFUN*)) {
+ Form_Hex2(dest, *src); // terminates each time
+ ++src;
+ dest += 2;
+ ++n;
+ }
+ TERM_BIN_LEN(bin, len);
+
+ Init_String(Alloc_Tail_Array(info), bin);
+ }
+
+ Init_Blank(Alloc_Tail_Array(info)); // no TCC_State, yet...
+
+ Init_Block(FUNC_BODY(fun), info);
+
+ // We need to remember this is a user native, because we won't over the
+ // long run be able to tell it is when the dispatcher is replaced with an
+ // arbitrary compiled function pointer!
+ //
+ SET_VAL_FLAG(FUNC_VALUE(fun), FUNC_FLAG_USER_NATIVE);
+
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+ return R_OUT;
+#endif
+}
+
+
+//
+// compile: native [
+//
+// {Compiles one or more native functions at the same time, with options.}
+//
+// return: []
+// natives [block!]
+// {Functions from MAKE-NATIVE or STRING!s of code.}
+// /options
+// flags [block!]
+// {
+// The block supports the following dialect:
+// include [block! path!]
+// "include path"
+// define [block!]
+// {define preprocessor symbols as "VAR=VAL" or "VAR"}
+// debug
+// "Add debugging information to the generated code?"
+// }
+// ]
+//
+REBNATIVE(compile)
+{
+ INCLUDE_PARAMS_OF_COMPILE;
+
+#if !defined(WITH_TCC)
+ UNUSED(ARG(natives));
+ UNUSED(REF(options));
+ UNUSED(ARG(flags));
+
+ fail (Error_Not_Tcc_Build_Raw());
+#else
+ REBVAL *natives = ARG(natives);
+
+ REBOOL debug = FALSE; // !!! not implemented yet
+
+ if (VAL_LEN_AT(ARG(natives)) == 0)
+ fail (Error_Tcc_Empty_Spec_Raw());
+
+ RELVAL *inc = NULL;
+ RELVAL *lib = NULL;
+ RELVAL *libdir = NULL;
+ RELVAL *options = NULL;
+ RELVAL *rundir = NULL;
+
+ if (REF(options)) {
+ RELVAL *val = VAL_ARRAY_AT(ARG(flags));
+
+ for (; NOT_END(val); ++val) {
+ if (!IS_WORD(val))
+ fail (Error_Tcc_Expect_Word_Raw(val));
+
+ switch (VAL_WORD_SYM(val)) {
+ case SYM_INCLUDE:
+ ++val;
+ if (!(IS_BLOCK(val) || IS_FILE(val) || ANY_STRING(val)))
+ fail (Error_Tcc_Invalid_Include_Raw(val));
+ inc = val;
+ break;
+
+ case SYM_DEBUG:
+ debug = TRUE;
+ break;
+
+ case SYM_OPTIONS:
+ ++val;
+ if (!ANY_STRING(val) || !VAL_BYTE_SIZE(val))
+ fail (Error_Tcc_Invalid_Options_Raw(val));
+ options = val;
+ break;
+
+ case SYM_RUNTIME_PATH:
+ ++val;
+ if (!(IS_FILE(val) || IS_STRING(val)))
+ fail (Error_Tcc_Invalid_Library_Path_Raw(val));
+ rundir = val;
+ break;
+
+ case SYM_LIBRARY_PATH:
+ ++val;
+ if (!(IS_BLOCK(val) || IS_FILE(val) || ANY_STRING(val)))
+ fail (Error_Tcc_Invalid_Library_Path_Raw(val));
+ libdir = val;
+ break;
+
+ case SYM_LIBRARY:
+ ++val;
+ if (!(IS_BLOCK(val) || IS_FILE(val) || ANY_STRING(val)))
+ fail (Error_Tcc_Invalid_Library_Raw(val));
+ lib = val;
+ break;
+
+ default:
+ fail (Error_Tcc_Not_Supported_Opt_Raw(val));
+ }
+ }
+ }
+
+ if (debug)
+ fail ("Debug builds of user natives are not yet implemented.");
+
+ // Using the "hot" mold buffer allows us to build the combined source in
+ // memory that is generally preallocated. This makes it not necessary
+ // to say in advance how large the buffer needs to be. However, currently
+ // the mold buffer is REBUNI wide characters, while TCC expects ASCII.
+ // Hence it has to be "popped" as UTF8 into a fresh series.
+ //
+ // !!! Future plans are to use "UTF-8 Everywhere", which would mean the
+ // mold buffer's data could be used directly.
+ //
+ // !!! Investigate how much UTF-8 support there is in TCC for strings/etc
+ //
+ REB_MOLD mo;
+ CLEARS(&mo);
+ Push_Mold(&mo);
+
+ // The core_header_source is %sys-core.h with all include files expanded
+ //
+ Append_Unencoded(mo.series, cs_cast(core_header_source));
+
+ // This prolog resets the line number count to 0 where the user source
+ // starts, in order to give more meaningful line numbers in errors
+ //
+ Append_Unencoded(mo.series, "\n# 0 \"user-source\" 1\n");
+
+ REBDSP dsp_orig = DSP;
+
+ // The user code is added next
+ //
+ RELVAL *item;
+ for (item = VAL_ARRAY_AT(natives); NOT_END(item); ++item) {
+ const RELVAL *var = item;
+ if (IS_WORD(item) || IS_GET_WORD(item)) {
+ var = Get_Opt_Var_May_Fail(item, VAL_SPECIFIER(natives));
+ if (IS_VOID(var))
+ fail (Error_No_Value_Core(item, VAL_SPECIFIER(natives)));
+ }
+
+ if (IS_FUNCTION(var)) {
+ assert(GET_VAL_FLAG(var, FUNC_FLAG_USER_NATIVE));
+
+ // Remember this function, because we're going to need to come
+ // back and fill in its dispatcher and TCC_State after the
+ // compilation...
+ //
+ DS_PUSH(const_KNOWN(var));
+
+ RELVAL *info = VAL_FUNC_BODY(var);
+ RELVAL *source = VAL_ARRAY_AT_HEAD(info, 0);
+ RELVAL *name = VAL_ARRAY_AT_HEAD(info, 1);
+
+ Append_Unencoded(mo.series, "REB_R ");
+ Append_String(
+ mo.series,
+ VAL_SERIES(name),
+ VAL_INDEX(name),
+ VAL_LEN_AT(name)
+ );
+ Append_Unencoded(mo.series, "(REBFRM *frame_)\n{\n");
+
+ REBVAL *param = VAL_FUNC_PARAMS_HEAD(var);
+ REBCNT num = 1;
+ for (; NOT_END(param); ++param) {
+ REBSTR *spelling = VAL_PARAM_SPELLING(param);
+
+ enum Reb_Param_Class pclass = VAL_PARAM_CLASS(param);
+ switch (pclass) {
+ case PARAM_CLASS_LOCAL:
+ case PARAM_CLASS_RETURN:
+ case PARAM_CLASS_LEAVE:
+ assert(FALSE); // natives shouldn't generally use these...
+ break;
+
+ case PARAM_CLASS_REFINEMENT:
+ case PARAM_CLASS_NORMAL:
+ case PARAM_CLASS_SOFT_QUOTE:
+ case PARAM_CLASS_HARD_QUOTE:
+ Append_Unencoded(mo.series, " ");
+ if (pclass == PARAM_CLASS_REFINEMENT)
+ Append_Unencoded(mo.series, "REFINE(");
+ else
+ Append_Unencoded(mo.series, "PARAM(");
+ Append_Int(mo.series, num);
+ ++num;
+ Append_Unencoded(mo.series, ", ");
+ Append_Unencoded(mo.series, cs_cast(STR_HEAD(spelling)));
+ Append_Unencoded(mo.series, ");\n");
+ break;
+
+ default:
+ assert(FALSE);
+ }
+ }
+ if (num != 1)
+ Append_Unencoded(mo.series, "\n");
+
+ Append_String(
+ mo.series,
+ VAL_SERIES(source),
+ VAL_INDEX(source),
+ VAL_LEN_AT(source)
+ );
+ Append_Unencoded(mo.series, "\n}\n\n");
+ }
+ else if (IS_STRING(var)) {
+ //
+ // A string is treated as just a fragment of code. This allows
+ // for writing things like C functions or macros that are shared
+ // between multiple user natives.
+ //
+ Append_String(
+ mo.series,
+ VAL_SERIES(var),
+ VAL_INDEX(var),
+ VAL_LEN_AT(var)
+ );
+ Append_Unencoded(mo.series, "\n");
+ }
+ else {
+ assert(FALSE);
+ }
+ }
+
+ REBSER *combined_src = Pop_Molded_UTF8(&mo);
+
+ TCCState *state = tcc_new();
+ if (!state)
+ fail (Error_Tcc_Construction_Raw());
+
+ tcc_set_error_func(state, NULL, tcc_error_report);
+
+ if (options) {
+ tcc_set_options(state, CHAR_HEAD(VAL_SERIES(options)));
+ }
+
+ REBCTX *err = NULL;
+
+ if ((err = add_path(state, inc, tcc_add_include_path, RE_TCC_INCLUDE)))
+ fail (err);
+
+ if (tcc_set_output_type(state, TCC_OUTPUT_MEMORY) < 0)
+ fail (Error_Tcc_Output_Type_Raw());
+
+ if (tcc_compile_string(state, CHAR_HEAD(combined_src)) < 0)
+ fail (Error_Tcc_Compile_Raw(natives));
+
+ Free_Series(combined_src);
+
+ // It is technically possible for ELF binaries to "--export-dynamic" (or
+ // -rdynamic in CMake) and make executables embed symbols for functions
+ // in them "like a DLL". However, we would like to make API symbols for
+ // Rebol available to the dynamically loaded code on all platforms, so
+ // this uses `tcc_add_symbol()` to work the same way on Windows/Linux/OSX
+ //
+ const struct rebol_sym_data_t *sym_data = &rebol_sym_data[0];
+ for (; sym_data->name != NULL; sym_data ++) {
+ if (tcc_add_symbol(state, sym_data->name, sym_data->data) < 0)
+ fail (Error_Tcc_Relocate_Raw());
+ }
+
+ const struct rebol_sym_func_t *sym_func = &rebol_sym_funcs[0];
+ for (; sym_func->name != NULL; sym_func ++) {
+ // ISO C++ forbids casting between pointer-to-function and
+ // pointer-to-object, use memcpy to circumvent.
+ void *ptr;
+ assert(sizeof(ptr) == sizeof(sym_func->func));
+ memcpy(&ptr, &sym_func->func, sizeof(ptr));
+ if (tcc_add_symbol(state, sym_func->name, ptr) < 0)
+ fail (Error_Tcc_Relocate_Raw());
+ }
+
+ // Add symbols in libtcc1, to avoid bundling with libtcc1.a
+ const void **sym = &r3_libtcc1_symbols[0];
+ for (; *sym != NULL; sym += 2) {
+ if (tcc_add_symbol(state, cast(const char*, *sym), *(sym + 1)) < 0)
+ fail (Error_Tcc_Relocate_Raw());
+ }
+
+ if ((err = add_path(
+ state, libdir, tcc_add_library_path, RE_TCC_LIBRARY_PATH
+ ))) {
+ fail (err);
+ }
+
+ if ((err = add_path(state, lib, tcc_add_library, RE_TCC_LIBRARY)))
+ fail(err);
+
+ if (rundir)
+ do_set_path(state, rundir, tcc_set_lib_path);
+
+ if (tcc_relocate(state, TCC_RELOCATE_AUTO) < 0)
+ fail (Error_Tcc_Relocate_Raw());
+
+ DECLARE_LOCAL (handle);
+ Init_Handle_Managed(
+ handle,
+ state, // "data" pointer
+ 0,
+ cleanup // called upon GC
+ );
+
+ // With compilation complete, find the matching linker names and get
+ // their function pointers to substitute in for the dispatcher.
+ //
+ while (DSP != dsp_orig) {
+ REBVAL *var = DS_TOP;
+
+ assert(IS_FUNCTION(var));
+ assert(GET_VAL_FLAG(var, FUNC_FLAG_USER_NATIVE));
+
+ RELVAL *info = VAL_FUNC_BODY(var);
+ RELVAL *name = VAL_ARRAY_AT_HEAD(info, 1);
+ RELVAL *stored_state = VAL_ARRAY_AT_HEAD(info, 2);
+
+ REBCNT index;
+ REBSER *utf8 = Temp_Bin_Str_Managed(name, &index, 0);
+
+ void *sym = tcc_get_symbol(state, cs_cast(BIN_AT(utf8, index)));
+ if (sym == NULL)
+ fail (Error_Tcc_Sym_Not_Found_Raw(name));
+
+ // ISO C++ forbids casting between pointer-to-function and
+ // pointer-to-object, use memcpy to circumvent.
+ REBNAT c_func;
+ assert(sizeof(c_func) == sizeof(void*));
+ memcpy(&c_func, &sym, sizeof(c_func));
+
+ FUNC_DISPATCHER(VAL_FUNC(var)) = c_func;
+ Move_Value(stored_state, handle);
+
+ DS_DROP;
+ }
+
+ return R_VOID;
+#endif
+}
diff --git a/src/core/n-protect.c b/src/core/n-protect.c
new file mode 100644
index 0000000000..42580dd62e
--- /dev/null
+++ b/src/core/n-protect.c
@@ -0,0 +1,490 @@
+//
+// File: %n-protect.c
+// Summary: "native functions for series and object field protection"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+
+#include "sys-core.h"
+
+
+//
+// Protect_Key: C
+//
+static void Protect_Key(REBCTX *context, REBCNT index, REBFLGS flags)
+{
+ REBVAL *var = CTX_VAR(context, index);
+
+ // Due to the fact that not all the bits in a value header are copied when
+ // Move_Value is done, it's possible to set the protection status of a
+ // variable on the value vs. the key. This means the keylist does not
+ // have to be modified, and hence it doesn't have to be made unique
+ // from any objects that were sharing it.
+ //
+ if (GET_FLAG(flags, PROT_WORD)) {
+ if (GET_FLAG(flags, PROT_SET))
+ SET_VAL_FLAG(var, VALUE_FLAG_PROTECTED);
+ else
+ CLEAR_VAL_FLAG(var, VALUE_FLAG_PROTECTED);
+ }
+
+ if (GET_FLAG(flags, PROT_HIDE)) {
+ //
+ // !!! For the moment, hiding is still implemented via typeset flags.
+ // Since PROTECT/HIDE is something of an esoteric feature, keep it
+ // that way for now, even though it means the keylist has to be
+ // made unique.
+ //
+ Ensure_Keylist_Unique_Invalidated(context);
+
+ REBVAL *key = CTX_KEY(context, index);
+
+ if (GET_FLAG(flags, PROT_SET))
+ SET_VAL_FLAGS(key, TYPESET_FLAG_HIDDEN | TYPESET_FLAG_UNBINDABLE);
+ else
+ CLEAR_VAL_FLAGS(
+ key, TYPESET_FLAG_HIDDEN | TYPESET_FLAG_UNBINDABLE
+ );
+ }
+}
+
+
+//
+// Protect_Value: C
+//
+// Anything that calls this must call Uncolor() when done.
+//
+void Protect_Value(RELVAL *value, REBFLGS flags)
+{
+ if (ANY_SERIES(value) || IS_MAP(value))
+ Protect_Series(VAL_SERIES(value), VAL_INDEX(value), flags);
+ else if (ANY_CONTEXT(value))
+ Protect_Context(VAL_CONTEXT(value), flags);
+}
+
+
+//
+// Protect_Series: C
+//
+// Anything that calls this must call Uncolor() when done.
+//
+void Protect_Series(REBSER *s, REBCNT index, REBFLGS flags)
+{
+ if (Is_Series_Black(s))
+ return; // avoid loop
+
+ if (GET_FLAG(flags, PROT_SET)) {
+ if (GET_FLAG(flags, PROT_FREEZE)) {
+ assert(GET_FLAG(flags, PROT_DEEP));
+ SET_SER_INFO(s, SERIES_INFO_FROZEN);
+ }
+ else
+ SET_SER_INFO(s, SERIES_INFO_PROTECTED);
+ }
+ else {
+ assert(!GET_FLAG(flags, PROT_FREEZE));
+ CLEAR_SER_INFO(s, SERIES_INFO_PROTECTED);
+ }
+
+ if (NOT_SER_FLAG(s, SERIES_FLAG_ARRAY) || !GET_FLAG(flags, PROT_DEEP))
+ return;
+
+ Flip_Series_To_Black(s); // recursion protection
+
+ RELVAL *val = ARR_AT(ARR(s), index);
+ for (; NOT_END(val); val++)
+ Protect_Value(val, flags);
+}
+
+
+//
+// Protect_Context: C
+//
+// Anything that calls this must call Uncolor() when done.
+//
+void Protect_Context(REBCTX *c, REBFLGS flags)
+{
+ if (Is_Series_Black(SER(CTX_VARLIST(c))))
+ return; // avoid loop
+
+ if (GET_FLAG(flags, PROT_SET)) {
+ if (GET_FLAG(flags, PROT_FREEZE)) {
+ assert(GET_FLAG(flags, PROT_DEEP));
+ SET_SER_INFO(CTX_VARLIST(c), SERIES_INFO_FROZEN);
+ }
+ else
+ SET_SER_INFO(CTX_VARLIST(c), SERIES_INFO_PROTECTED);
+ }
+ else {
+ assert(!GET_FLAG(flags, PROT_FREEZE));
+ CLEAR_SER_INFO(CTX_VARLIST(c), SERIES_INFO_PROTECTED);
+ }
+
+ if (!GET_FLAG(flags, PROT_DEEP)) return;
+
+ Flip_Series_To_Black(SER(CTX_VARLIST(c))); // for recursion
+
+ REBVAL *var = CTX_VARS_HEAD(c);
+ for (; NOT_END(var); ++var)
+ Protect_Value(var, flags);
+}
+
+
+//
+// Protect_Word_Value: C
+//
+static void Protect_Word_Value(REBVAL *word, REBFLGS flags)
+{
+ if (ANY_WORD(word) && IS_WORD_BOUND(word)) {
+ Protect_Key(VAL_WORD_CONTEXT(word), VAL_WORD_INDEX(word), flags);
+ if (GET_FLAG(flags, PROT_DEEP)) {
+ //
+ // Ignore existing mutability state so that it may be modified.
+ // Most routines should NOT do this!
+ //
+ REBVAL *var = Get_Var_Core(
+ word,
+ SPECIFIED,
+ GETVAR_READ_ONLY
+ );
+ Protect_Value(var, flags);
+ Uncolor(var);
+ }
+ }
+ else if (ANY_PATH(word)) {
+ REBCNT index;
+ REBCTX *context = Resolve_Path(word, &index);
+
+ if (context != NULL) {
+ Protect_Key(context, index, flags);
+ if (GET_FLAG(flags, PROT_DEEP)) {
+ REBVAL *var = CTX_VAR(context, index);
+ Protect_Value(var, flags);
+ Uncolor(var);
+ }
+ }
+ }
+}
+
+
+//
+// Protect_Unprotect_Core: C
+//
+// Common arguments between protect and unprotect:
+//
+static REB_R Protect_Unprotect_Core(REBFRM *frame_, REBFLGS flags)
+{
+ INCLUDE_PARAMS_OF_PROTECT;
+
+ UNUSED(PAR(hide)); // unused here, but processed in caller
+
+ REBVAL *value = ARG(value);
+
+ // flags has PROT_SET bit (set or not)
+
+ Check_Security(Canon(SYM_PROTECT), POL_WRITE, value);
+
+ if (REF(deep)) SET_FLAG(flags, PROT_DEEP);
+ //if (REF(words)) SET_FLAG(flags, PROT_WORD);
+
+ if (IS_WORD(value) || IS_PATH(value)) {
+ Protect_Word_Value(value, flags); // will unmark if deep
+ goto return_value_arg;
+ }
+
+ if (IS_BLOCK(value)) {
+ if (REF(words)) {
+ RELVAL *val;
+ for (val = VAL_ARRAY_AT(value); NOT_END(val); val++) {
+ DECLARE_LOCAL (word); // need binding, can't pass RELVAL
+ Derelativize(word, val, VAL_SPECIFIER(value));
+ Protect_Word_Value(word, flags); // will unmark if deep
+ }
+ goto return_value_arg;
+ }
+ if (REF(values)) {
+ REBVAL *var;
+ RELVAL *item;
+
+ DECLARE_LOCAL (safe);
+
+ for (item = VAL_ARRAY_AT(value); NOT_END(item); ++item) {
+ if (IS_WORD(item)) {
+ //
+ // Since we *are* PROTECT we allow ourselves to get mutable
+ // references to even protected values to protect them.
+ //
+ var = Get_Var_Core(
+ item,
+ VAL_SPECIFIER(value),
+ GETVAR_READ_ONLY
+ );
+ }
+ else if (IS_PATH(value)) {
+ if (Do_Path_Throws_Core(
+ safe, NULL, value, SPECIFIED, NULL
+ ))
+ fail (Error_No_Catch_For_Throw(safe));
+
+ var = safe;
+ }
+ else {
+ Move_Value(safe, value);
+ var = safe;
+ }
+
+ Protect_Value(var, flags);
+ if (GET_FLAG(flags, PROT_DEEP))
+ Uncolor(var);
+ }
+ goto return_value_arg;
+ }
+ }
+
+ if (GET_FLAG(flags, PROT_HIDE)) fail (Error_Bad_Refines_Raw());
+
+ Protect_Value(value, flags);
+
+ if (GET_FLAG(flags, PROT_DEEP))
+ Uncolor(value);
+
+return_value_arg:
+ Move_Value(D_OUT, ARG(value));
+ return R_OUT;
+}
+
+
+//
+// protect: native [
+//
+// {Protect a series or a variable from being modified.}
+//
+// value [word! any-series! bitset! map! object! module!]
+// /deep
+// "Protect all sub-series/objects as well"
+// /words
+// "Process list as words (and path words)"
+// /values
+// "Process list of values (implied GET)"
+// /hide
+// "Hide variables (avoid binding and lookup)"
+// ]
+//
+REBNATIVE(protect)
+{
+ INCLUDE_PARAMS_OF_PROTECT;
+
+ // Avoid unused parameter warnings (core routine handles them via frame)
+ //
+ UNUSED(PAR(value));
+ UNUSED(PAR(deep));
+ UNUSED(PAR(words));
+ UNUSED(PAR(values));
+
+ REBFLGS flags = FLAGIT(PROT_SET);
+
+ if (REF(hide))
+ SET_FLAG(flags, PROT_HIDE);
+ else
+ SET_FLAG(flags, PROT_WORD); // there is no unhide
+
+ return Protect_Unprotect_Core(frame_, flags);
+}
+
+
+//
+// unprotect: native [
+//
+// {Unprotect a series or a variable (it can again be modified).}
+//
+// value [word! any-series! bitset! map! object! module!]
+// /deep
+// "Protect all sub-series as well"
+// /words
+// "Block is a list of words"
+// /values
+// "Process list of values (implied GET)"
+// /hide
+// "HACK to make PROTECT and UNPROTECT have the same signature"
+// ]
+//
+REBNATIVE(unprotect)
+{
+ INCLUDE_PARAMS_OF_UNPROTECT;
+
+ // Avoid unused parameter warnings (core handles them via frame)
+ //
+ UNUSED(PAR(value));
+ UNUSED(PAR(deep));
+ UNUSED(PAR(words));
+ UNUSED(PAR(values));
+
+ if (REF(hide))
+ fail ("Cannot un-hide an object field once hidden");
+
+ return Protect_Unprotect_Core(frame_, FLAGIT(PROT_WORD));
+}
+
+
+//
+// Is_Value_Immutable: C
+//
+REBOOL Is_Value_Immutable(const RELVAL *v) {
+ if (
+ IS_BLANK(v)
+ || IS_BAR(v)
+ || IS_LIT_BAR(v)
+ || ANY_SCALAR(v)
+ || ANY_WORD(v)
+ ){
+ return TRUE;
+ }
+
+ if (ANY_ARRAY(v))
+ return Is_Array_Deeply_Frozen(VAL_ARRAY(v));
+
+ if (ANY_CONTEXT(v))
+ return Is_Context_Deeply_Frozen(VAL_CONTEXT(v));
+
+ if (ANY_SERIES(v))
+ return Is_Series_Frozen(VAL_SERIES(v));
+
+ return FALSE;
+}
+
+
+//
+// locked?: native [
+//
+// {Determine if the value is locked (deeply and permanently immutable)}
+//
+// return: [logic!]
+// value [any-value!]
+// ]
+//
+REBNATIVE(locked_q)
+{
+ INCLUDE_PARAMS_OF_LOCKED_Q;
+
+ return R_FROM_BOOL(Is_Value_Immutable(ARG(value)));
+}
+
+
+//
+// Ensure_Value_Immutable: C
+//
+void Ensure_Value_Immutable(REBVAL *v) {
+ if (Is_Value_Immutable(v))
+ return;
+
+ if (ANY_ARRAY(v))
+ Deep_Freeze_Array(VAL_ARRAY(v));
+ else if (ANY_CONTEXT(v))
+ Deep_Freeze_Context(VAL_CONTEXT(v));
+ else if (ANY_SERIES(v))
+ Freeze_Sequence(VAL_SERIES(v));
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(v))); // not yet implemented
+}
+
+
+//
+// lock: native [
+//
+// {Permanently lock values (if applicable) so they can be immutably shared.}
+//
+// value [any-value!]
+// {Value to lock (will be locked deeply if an ANY-ARRAY!)}
+// /clone
+// {Will lock a clone of the original (if not already immutable)}
+// ]
+//
+REBNATIVE(lock)
+//
+// !!! COPY in Rebol truncates before the index. You can't `y: copy next x`
+// and then `first back y` to get at a copy of the the original `first x`.
+//
+// This locking operation is opportunistic in terms of whether it actually
+// copies the data or not. But if it did just a normal COPY, it'd truncate,
+// while if it just passes the value through it does not truncate. So
+// `lock/copy x` wouldn't be semantically equivalent to `lock copy x` :-/
+//
+// So the strategy here is to go with a different option, CLONE. CLONE was
+// already being considered as an operation due to complaints about backward
+// compatibility if COPY were changed to /DEEP by default.
+//
+// The "freezing" bit can only be used on deep copies, so it would not make
+// sense to use with a shallow one. However, a truncating COPY/DEEP could
+// be made to have a version operating on read only data that reused a
+// subset of the data. This would use a "slice"; letting one series refer
+// into another, with a different starting point. That would complicate the
+// garbage collector because multiple REBSER would be referring into the same
+// data. So that's a possibility.
+{
+ INCLUDE_PARAMS_OF_LOCK;
+
+ REBVAL *v = ARG(value);
+
+ if (!REF(clone))
+ Move_Value(D_OUT, v);
+ else {
+ if (ANY_ARRAY(v)) {
+ Init_Any_Array_At(
+ D_OUT,
+ VAL_TYPE(v),
+ Copy_Array_Deep_Managed(
+ VAL_ARRAY(v),
+ VAL_SPECIFIER(v)
+ ),
+ VAL_INDEX(v)
+ );
+ }
+ else if (ANY_CONTEXT(v)) {
+ const REBOOL deep = TRUE;
+ const REBU64 types = TS_STD_SERIES;
+
+ Init_Any_Context(
+ D_OUT,
+ VAL_TYPE(v),
+ Copy_Context_Core(VAL_CONTEXT(v), deep, types)
+ );
+ }
+ else if (ANY_SERIES(v)) {
+ Init_Any_Series_At(
+ D_OUT,
+ VAL_TYPE(v),
+ Copy_Sequence(VAL_SERIES(v)),
+ VAL_INDEX(v)
+ );
+ }
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(v))); // not yet implemented
+ }
+
+ Ensure_Value_Immutable(D_OUT);
+
+ return R_OUT;
+}
diff --git a/src/core/n-reduce.c b/src/core/n-reduce.c
new file mode 100644
index 0000000000..b977c03f97
--- /dev/null
+++ b/src/core/n-reduce.c
@@ -0,0 +1,416 @@
+//
+// File: %n-reduce.h
+// Summary: {REDUCE and COMPOSE natives and associated service routines}
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+
+#include "sys-core.h"
+
+//
+// Reduce_Any_Array_Throws: C
+//
+// Reduce array from the index position specified in the value.
+//
+// If `into` then splice into the existing `out`. Otherwise, overwrite the
+// `out` with all values collected from the stack, into an array matching the
+// type of the input. So [1 + 1 2 + 2] => [3 4], and 1/+/1/2/+/2 => 3/4
+//
+// !!! This is not necessarily the best answer, it's just the mechanically
+// most obvious one.
+//
+REBOOL Reduce_Any_Array_Throws(
+ REBVAL *out,
+ REBVAL *any_array,
+ REBFLGS flags
+) {
+ assert(
+ NOT(flags & REDUCE_FLAG_KEEP_BARS)
+ == LOGICAL(flags & REDUCE_FLAG_DROP_BARS)
+ ); // only one should be true, but caller should be explicit of which
+
+ REBDSP dsp_orig = DSP;
+
+ DECLARE_FRAME (f);
+ Push_Frame(f, any_array);
+
+ DECLARE_LOCAL (reduced);
+
+ while (NOT_END(f->value)) {
+ if (IS_BAR(f->value)) {
+ if (flags & REDUCE_FLAG_KEEP_BARS) {
+ DS_PUSH_TRASH;
+ Quote_Next_In_Frame(DS_TOP, f);
+ }
+ else
+ Fetch_Next_In_Frame(f);
+
+ continue;
+ }
+
+ if (Do_Next_In_Frame_Throws(reduced, f)) {
+ Move_Value(out, reduced);
+ DS_DROP_TO(dsp_orig);
+ Drop_Frame(f);
+ return TRUE;
+ }
+
+ if (IS_VOID(reduced)) {
+ //
+ // !!! Review if there should be a form of reduce which allows
+ // void expressions. The general feeling is that it shouldn't
+ // be allowed by default, since N expressions would not make N
+ // results...and reduce is often used for positional purposes.
+ // Substituting anything (like a NONE!, or anything else) would
+ // perhaps be disingenuous.
+ //
+ fail (Error_Reduce_Made_Void_Raw());
+ }
+
+ DS_PUSH(reduced);
+ }
+
+ if (flags & REDUCE_FLAG_INTO)
+ Pop_Stack_Values_Into(out, dsp_orig);
+ else
+ Init_Any_Array(out, VAL_TYPE(any_array), Pop_Stack_Values(dsp_orig));
+
+ Drop_Frame(f);
+ return FALSE;
+}
+
+
+//
+// reduce: native [
+//
+// {Evaluates expressions and returns multiple results.}
+//
+// return: [ any-value!]
+// value [ any-value!]
+// {If BLOCK!, expressions are reduced, otherwise single value.}
+// /into
+// {Output results into a series with no intermediate storage}
+// target [any-array!]
+// ]
+//
+REBNATIVE(reduce)
+{
+ INCLUDE_PARAMS_OF_REDUCE;
+
+ REBVAL *value = ARG(value);
+
+ if (IS_VOID(value))
+ return R_VOID; // !!! Should this be allowed? (Red allows it)
+
+ if (IS_BLOCK(value)) {
+ if (REF(into))
+ Move_Value(D_OUT, ARG(target));
+
+ if (Reduce_Any_Array_Throws(
+ D_OUT,
+ value,
+ REF(into)
+ ? REDUCE_FLAG_INTO | REDUCE_FLAG_KEEP_BARS
+ : REDUCE_FLAG_KEEP_BARS
+ )){
+ return R_OUT_IS_THROWN;
+ }
+
+ return R_OUT;
+ }
+
+ // A single element should do what is effectively an evaluation but with
+ // no arguments. This is a change in behavior from R3-Alpha, which would
+ // just return the input as is, e.g. `reduce quote (1 + 2)` => (1 + 2).
+ //
+ // !!! Should the error be more "reduce-specific" if args were required?
+ //
+ if (Eval_Value_Throws(D_OUT, value))
+ return R_OUT_IS_THROWN;
+
+ if (NOT(REF(into)))
+ return R_OUT; // just return the evaluated item if no /INTO target
+
+ REBVAL *into = ARG(target);
+ assert(ANY_ARRAY(into));
+ FAIL_IF_READ_ONLY_ARRAY(VAL_ARRAY(into));
+
+ // Insert the single item into the target array at its current position,
+ // and return the position after the insertion (the /INTO convention)
+
+ VAL_INDEX(into) = Insert_Series(
+ SER(VAL_ARRAY(into)),
+ VAL_INDEX(into),
+ cast(REBYTE*, D_OUT),
+ 1 // multiplied by width (sizeof(REBVAL)) in Insert_Series
+ );
+
+ Move_Value(D_OUT, into);
+ return R_OUT;
+}
+
+
+//
+// Compose_Any_Array_Throws: C
+//
+// Compose a block from a block of un-evaluated values and GROUP! arrays that
+// are evaluated. This calls into Do_Core, so if 'into' is provided, then its
+// series must be protected from garbage collection.
+//
+// deep - recurse into sub-blocks
+// only - parens that return blocks are kept as blocks
+//
+// Writes result value at address pointed to by out.
+//
+REBOOL Compose_Any_Array_Throws(
+ REBVAL *out,
+ const REBVAL *any_array,
+ REBOOL deep,
+ REBOOL only,
+ REBOOL into
+) {
+ REBDSP dsp_orig = DSP;
+
+ DECLARE_FRAME (f);
+ Push_Frame(f, any_array);
+
+ DECLARE_LOCAL (composed);
+ DECLARE_LOCAL (specific);
+
+ while (NOT_END(f->value)) {
+ if (IS_GROUP(f->value)) {
+ //
+ // Evaluate the GROUP! at current position into `composed` cell.
+ //
+ REBSPC *derived = Derive_Specifier(f->specifier, f->value);
+ if (Do_At_Throws(
+ composed,
+ VAL_ARRAY(f->value),
+ VAL_INDEX(f->value),
+ derived
+ )){
+ Move_Value(out, composed);
+ DS_DROP_TO(dsp_orig);
+ Drop_Frame(f);
+ return TRUE;
+ }
+
+ Fetch_Next_In_Frame(f);
+
+ if (IS_BLOCK(composed) && !only) {
+ //
+ // compose [blocks ([a b c]) merge] => [blocks a b c merge]
+ //
+ RELVAL *push = VAL_ARRAY_AT(composed);
+ while (NOT_END(push)) {
+ //
+ // `evaluated` is known to be specific, but its specifier
+ // may be needed to derelativize its children.
+ //
+ DS_PUSH_RELVAL(push, VAL_SPECIFIER(composed));
+ push++;
+ }
+ }
+ else if (!IS_VOID(composed)) {
+ //
+ // compose [(1 + 2) inserts as-is] => [3 inserts as-is]
+ // compose/only [([a b c]) unmerged] => [[a b c] unmerged]
+ //
+ DS_PUSH(composed);
+ }
+ else {
+ //
+ // compose [(print "Voids *vanish*!")] => []
+ //
+ }
+ }
+ else if (deep) {
+ if (IS_BLOCK(f->value)) {
+ //
+ // compose/deep [does [(1 + 2)] nested] => [does [3] nested]
+
+ Derelativize(specific, f->value, f->specifier);
+
+ if (Compose_Any_Array_Throws(
+ composed,
+ specific,
+ TRUE,
+ only,
+ into
+ )) {
+ Move_Value(out, composed);
+ DS_DROP_TO(dsp_orig);
+ Drop_Frame(f);
+ return TRUE;
+ }
+
+ DS_PUSH(composed);
+ }
+ else {
+ if (ANY_ARRAY(f->value)) {
+ //
+ // compose [copy/(orig) (copy)] => [copy/(orig) (copy)]
+ // !!! path and second group are copies, first group isn't
+ //
+ REBSPC *derived = Derive_Specifier(f->specifier, f->value);
+ REBARR *copy = Copy_Array_Shallow(
+ VAL_ARRAY(f->value),
+ derived
+ );
+ DS_PUSH_TRASH;
+ Init_Any_Array_At(
+ DS_TOP, VAL_TYPE(f->value), copy, VAL_INDEX(f->value)
+ ); // ...manages
+ }
+ else
+ DS_PUSH_RELVAL(f->value, f->specifier);
+ }
+ Fetch_Next_In_Frame(f);
+ }
+ else {
+ //
+ // compose [[(1 + 2)] (reverse "wollahs")] => [[(1 + 2)] "shallow"]
+ //
+ DS_PUSH_RELVAL(f->value, f->specifier);
+ Fetch_Next_In_Frame(f);
+ }
+ }
+
+ if (into)
+ Pop_Stack_Values_Into(out, dsp_orig);
+ else
+ Init_Any_Array(out, VAL_TYPE(any_array), Pop_Stack_Values(dsp_orig));
+
+ Drop_Frame(f);
+ return FALSE;
+}
+
+
+//
+// compose: native [
+//
+// {Evaluates only the GROUP!s in a block of expressions, returning a block.}
+//
+// value
+// "Block to compose (or any other type evaluates to itself)"
+// ; ^-- is this sensible?
+// /deep
+// "Compose nested blocks"
+// /only
+// {Insert a block as a single value (not the contents of the block)}
+// /into
+// {Output results into a series with no intermediate storage}
+// out [any-array! any-string! binary!]
+// ]
+//
+REBNATIVE(compose)
+{
+ INCLUDE_PARAMS_OF_COMPOSE;
+
+ // !!! Should 'compose quote (a (1 + 2) b)' give back '(a 3 b)' ?
+ // What about 'compose quote a/(1 + 2)/b' ?
+ //
+ if (!IS_BLOCK(ARG(value))) {
+ Move_Value(D_OUT, ARG(value));
+ return R_OUT;
+ }
+
+ // Compose_Values_Throws() expects `out` to contain the target if it is
+ // passed TRUE as the `into` flag.
+ //
+ if (REF(into))
+ Move_Value(D_OUT, ARG(out));
+ else
+ assert(IS_END(D_OUT)); // !!! guaranteed, better signal than `into`?
+
+ if (Compose_Any_Array_Throws(
+ D_OUT,
+ ARG(value),
+ REF(deep),
+ REF(only),
+ REF(into)
+ )) {
+ return R_OUT_IS_THROWN;
+ }
+
+ return R_OUT;
+}
+
+
+enum FLATTEN_LEVEL {
+ FLATTEN_NOT,
+ FLATTEN_ONCE,
+ FLATTEN_DEEP
+};
+
+
+static void Flatten_Core(
+ RELVAL head[],
+ REBSPC *specifier,
+ enum FLATTEN_LEVEL level
+) {
+ RELVAL *item = head;
+ for (; NOT_END(item); ++item) {
+ if (IS_BLOCK(item) && level != FLATTEN_NOT) {
+ REBSPC *derived = Derive_Specifier(specifier, item);
+ Flatten_Core(
+ VAL_ARRAY_AT(item),
+ derived,
+ level == FLATTEN_ONCE ? FLATTEN_NOT : FLATTEN_DEEP
+ );
+ }
+ else
+ DS_PUSH_RELVAL(item, specifier);
+ }
+}
+
+
+//
+// flatten: native [
+//
+// {Flattens a block of blocks.}
+//
+// return: [block!]
+// {The flattened result block}
+// block [block!]
+// {The nested source block}
+// /deep
+// ]
+//
+REBNATIVE(flatten)
+{
+ INCLUDE_PARAMS_OF_FLATTEN;
+
+ REBDSP dsp_orig = DSP;
+
+ Flatten_Core(
+ VAL_ARRAY_AT(ARG(block)),
+ VAL_SPECIFIER(ARG(block)),
+ REF(deep) ? FLATTEN_DEEP : FLATTEN_ONCE
+ );
+
+ Init_Block(D_OUT, Pop_Stack_Values(dsp_orig));
+ return R_OUT;
+}
diff --git a/src/core/n-sets.c b/src/core/n-sets.c
index feede66255..caddca48a1 100644
--- a/src/core/n-sets.c
+++ b/src/core/n-sets.c
@@ -1,289 +1,535 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: n-sets.c
-** Summary: native functions for data sets
-** Section: natives
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %n-sets.c
+// Summary: "native functions for data sets"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
enum {
- SOP_BOTH, // combine and interate over both series
- SOP_CHECK, // check other series for value existence
- SOP_INVERT, // invert the result of the search
+ SOP_NONE = 0, // used by UNIQUE (other flags do not apply)
+ SOP_FLAG_BOTH = 1 << 0, // combine and interate over both series
+ SOP_FLAG_CHECK = 1 << 1, // check other series for value existence
+ SOP_FLAG_INVERT = 1 << 2 // invert the result of the search
};
-#define SET_OP_UNIQUE 0
-#define SET_OP_UNION FLAGIT(SOP_BOTH)
-#define SET_OP_INTERSECT FLAGIT(SOP_CHECK)
-#define SET_OP_EXCLUDE (FLAGIT(SOP_CHECK) | FLAGIT(SOP_INVERT))
-#define SET_OP_DIFFERENCE (FLAGIT(SOP_BOTH) | FLAGIT(SOP_CHECK) | FLAGIT(SOP_INVERT))
-
-/***********************************************************************
-**
-*/ static REBINT Do_Set_Operation(REBVAL *ds, REBCNT flags)
-/*
-** Do set operations on a series.
-**
-***********************************************************************/
-{
- REBVAL *val;
- REBVAL *val1;
- REBVAL *val2 = 0;
- REBSER *ser;
- REBSER *hser = 0; // hash table for series
- REBSER *retser; // return series
- REBSER *hret; // hash table for return series
- REBCNT i;
- REBINT h = TRUE;
- REBCNT skip = 1; // record size
- REBCNT cased = 0; // case sensitive when TRUE
-
- SET_NONE(D_RET);
- val1 = D_ARG(1);
- i = 2;
-
- // Check for second series argument:
- if (flags != SET_OP_UNIQUE) {
- val2 = D_ARG(i++);
- if (VAL_TYPE(val1) != VAL_TYPE(val2)) {
- Trap_Types(RE_EXPECT_VAL, VAL_TYPE(val1), VAL_TYPE(val2));
- }
- }
-
- // Refinements /case and /skip N
- cased = D_REF(i++); // cased
- if (D_REF(i++)) skip = Int32s(D_ARG(i), 1);
-
- switch (VAL_TYPE(val1)) {
-
- case REB_BLOCK:
- i = VAL_LEN(val1);
- // Setup result block:
- if (GET_FLAG(flags, SOP_BOTH)) i += VAL_LEN(val2);
- retser = BUF_EMIT; // use preallocated shared block
- Resize_Series(retser, i);
- hret = Make_Hash_Array(i); // allocated
-
- // Optimization note: !!
- // This code could be optimized for small blocks by not hashing them
- // and extending Find_Key to do a FIND on the value itself w/o the hash.
-
- do {
- // Check what is in series1 but not in series2:
- if (GET_FLAG(flags, SOP_CHECK))
- hser = Hash_Block(val2, cased);
-
- // Iterate over first series:
- ser = VAL_SERIES(val1);
- i = VAL_INDEX(val1);
- FOR_SER(ser, val, i, skip) {
- if (GET_FLAG(flags, SOP_CHECK)) {
- h = Find_Key(VAL_SERIES(val2), hser, val, skip, cased, 1) >= 0;
- if (GET_FLAG(flags, SOP_INVERT)) h = !h;
- }
- if (h) Find_Key(retser, hret, val, skip, cased, 2);
- }
-
- // Iterate over second series?
- if (NZ(i = GET_FLAG(flags, SOP_BOTH))) {
- val = val1;
- val1 = val2;
- val2 = val;
- CLR_FLAG(flags, SOP_BOTH);
- }
- } while (i);
-
- Set_Block(D_RET, Copy_Series(retser));
- RESET_TAIL(retser); // required - allow reuse
-
- break;
-
- case REB_BINARY:
- cased = TRUE;
- SET_TYPE(D_RET, REB_BINARY);
- case REB_STRING:
- i = VAL_LEN(val1);
- // Setup result block:
- if (GET_FLAG(flags, SOP_BOTH)) i += VAL_LEN(val2);
-
- retser = BUF_MOLD;
- Reset_Buffer(retser, i);
- RESET_TAIL(retser);
-
- do {
- REBUNI uc;
-
- cased = cased ? AM_FIND_CASE : 0;
-
- // Iterate over first series:
- ser = VAL_SERIES(val1);
- i = VAL_INDEX(val1);
- FOR_SER(ser, val, i, skip) {
- uc = GET_ANY_CHAR(ser, i);
- if (GET_FLAG(flags, SOP_CHECK)) {
- h = Find_Str_Char(VAL_SERIES(val2), 0, VAL_INDEX(val2), VAL_TAIL(val2), skip, uc, cased) != NOT_FOUND;
- if (GET_FLAG(flags, SOP_INVERT)) h = !h;
- }
- if (h && (Find_Str_Char(retser, 0, 0, SERIES_TAIL(retser), skip, uc, cased) == NOT_FOUND)) {
- Append_String(retser, ser, i, skip);
- }
- }
-
- // Iterate over second series?
- if (NZ(i = GET_FLAG(flags, SOP_BOTH))) {
- val = val1;
- val1 = val2;
- val2 = val;
- CLR_FLAG(flags, SOP_BOTH);
- }
- } while (i);
-
- ser = Copy_String(retser, 0, -1);
- if (IS_BINARY(D_RET))
- Set_Binary(D_RET, ser);
- else
- Set_String(D_RET, ser);
- break;
-
- case REB_BITSET:
- switch (flags) {
- case SET_OP_UNIQUE:
- return R_ARG1;
- case SET_OP_UNION:
- i = A_OR;
- break;
- case SET_OP_INTERSECT:
- i = A_AND;
- break;
- case SET_OP_DIFFERENCE:
- i = A_XOR;
- break;
- case SET_OP_EXCLUDE:
- i = 0; // special case
- break;
- }
- ser = Xandor_Binary(i, val1, val2);
- Set_Series(REB_BITSET, D_RET, ser);
- break;
-
- case REB_TYPESET:
- switch (flags) {
- case SET_OP_UNIQUE:
- break;
- case SET_OP_UNION:
- VAL_TYPESET(val1) |= VAL_TYPESET(val2);
- break;
- case SET_OP_INTERSECT:
- VAL_TYPESET(val1) &= VAL_TYPESET(val2);
- break;
- case SET_OP_DIFFERENCE:
- VAL_TYPESET(val1) ^= VAL_TYPESET(val2);
- break;
- case SET_OP_EXCLUDE:
- VAL_TYPESET(val1) &= ~VAL_TYPESET(val2);
- break;
- }
- return R_ARG1;
-
- default:
- Trap_Arg(val1);
- }
-
- return R_RET;
+//
+// Make_Set_Operation_Series: C
+//
+// Do set operations on a series. Case-sensitive if `cased` is TRUE.
+// `skip` is the record size.
+//
+static REBSER *Make_Set_Operation_Series(
+ const REBVAL *val1,
+ const REBVAL *val2,
+ REBFLGS flags,
+ REBOOL cased,
+ REBCNT skip
+) {
+ REBCNT i;
+ REBINT h = 1; // used for both logic true/false and hash check
+ REBOOL first_pass = TRUE; // are we in the first pass over the series?
+ REBSER *out_ser;
+
+ assert(ANY_SERIES(val1));
+
+ if (val2) {
+ assert(ANY_SERIES(val2));
+
+ if (ANY_ARRAY(val1)) {
+ if (!ANY_ARRAY(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+
+ // As long as they're both arrays, we're willing to do:
+ //
+ // >> union quote (a b c) 'b/d/e
+ // (a b c d e)
+ //
+ // The type of the result will match the first value.
+ }
+ else if (!IS_BINARY(val1)) {
+
+ // We will similarly do any two ANY-STRING! types:
+ //
+ // >> union "bde"
+ //
+
+ if (IS_BINARY(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+ }
+ else {
+ // Binaries only operate with other binaries
+
+ if (!IS_BINARY(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+ }
+ }
+
+ // Calculate `i` as maximum length of result block. The temporary buffer
+ // will be allocated at this size, but copied out at the exact size of
+ // the actual result.
+ //
+ i = VAL_LEN_AT(val1);
+ if (flags & SOP_FLAG_BOTH) i += VAL_LEN_AT(val2);
+
+ if (ANY_ARRAY(val1)) {
+ REBSER *hser = 0; // hash table for series
+ REBSER *hret; // hash table for return series
+
+ // The buffer used for building the return series. This creates
+ // a new buffer every time, but reusing one might be slightly more
+ // efficient.
+ //
+ REBSER *buffer = SER(Make_Array(i));
+ hret = Make_Hash_Sequence(i); // allocated
+
+ // Optimization note: !!
+ // This code could be optimized for small blocks by not hashing them
+ // and extending Find_Key to FIND on the value itself w/o the hash.
+
+ do {
+ REBARR *array1 = VAL_ARRAY(val1); // val1 and val2 swapped 2nd pass!
+
+ // Check what is in series1 but not in series2
+ //
+ if (flags & SOP_FLAG_CHECK)
+ hser = Hash_Block(val2, skip, cased);
+
+ // Iterate over first series
+ //
+ i = VAL_INDEX(val1);
+ for (; i < ARR_LEN(array1); i += skip) {
+ RELVAL *item = ARR_AT(array1, i);
+ if (flags & SOP_FLAG_CHECK) {
+ h = Find_Key_Hashed(
+ VAL_ARRAY(val2),
+ hser,
+ item,
+ VAL_SPECIFIER(val1),
+ skip,
+ cased,
+ 1
+ );
+ h = (h >= 0);
+ if (flags & SOP_FLAG_INVERT) h = !h;
+ }
+ if (h) {
+ Find_Key_Hashed(
+ ARR(buffer),
+ hret,
+ item,
+ VAL_SPECIFIER(val1),
+ skip,
+ cased,
+ 2
+ );
+ }
+ }
+
+ if (i != ARR_LEN(array1)) {
+ //
+ // In the current philosophy, the semantics of what to do
+ // with things like `intersect/skip [1 2 3] [7] 2` is too
+ // shaky to deal with, so an error is reported if it does
+ // not work out evenly to the skip size.
+ //
+ fail (Error_Block_Skip_Wrong_Raw());
+ }
+
+ if (flags & SOP_FLAG_CHECK)
+ Free_Series(hser);
+
+ if (!first_pass) break;
+ first_pass = FALSE;
+
+ // Iterate over second series?
+ //
+ if ((i = ((flags & SOP_FLAG_BOTH) != 0))) {
+ const REBVAL *temp = val1;
+ val1 = val2;
+ val2 = temp;
+ }
+ } while (i);
+
+ if (hret)
+ Free_Series(hret);
+
+ // The buffer may have been allocated too large, so copy it at the
+ // used capacity size
+ //
+ out_ser = SER(Copy_Array_Shallow(ARR(buffer), SPECIFIED));
+ Free_Array(ARR(buffer));
+ }
+ else {
+ REB_MOLD mo;
+ CLEARS(&mo);
+
+ if (IS_BINARY(val1)) {
+ //
+ // All binaries use "case-sensitive" comparison (e.g. each byte
+ // is treated distinctly)
+ //
+ cased = TRUE;
+ }
+
+ // ask mo.series to have at least `i` capacity beyond mo.start
+ //
+ mo.opts = MOPT_RESERVE;
+ mo.reserve = i;
+ Push_Mold(&mo);
+
+ do {
+ REBSER *ser = VAL_SERIES(val1); // val1 and val2 swapped 2nd pass!
+ REBUNI uc;
+
+ // Iterate over first series
+ //
+ i = VAL_INDEX(val1);
+ for (; i < SER_LEN(ser); i += skip) {
+ uc = GET_ANY_CHAR(ser, i);
+ if (flags & SOP_FLAG_CHECK) {
+ h = (NOT_FOUND != Find_Str_Char(
+ uc,
+ VAL_SERIES(val2),
+ 0,
+ VAL_INDEX(val2),
+ VAL_LEN_HEAD(val2),
+ skip,
+ cased ? AM_FIND_CASE : 0
+ ));
+
+ if (flags & SOP_FLAG_INVERT) h = !h;
+ }
+
+ if (!h) continue;
+
+ if (
+ NOT_FOUND == Find_Str_Char(
+ uc, // c2 (the character to find)
+ mo.series, // ser
+ mo.start, // head
+ mo.start, // index
+ SER_LEN(mo.series), // tail
+ skip, // skip
+ cased ? AM_FIND_CASE : 0 // flags
+ )
+ ) {
+ Append_String(mo.series, ser, i, skip);
+ }
+ }
+
+ if (!first_pass) break;
+ first_pass = FALSE;
+
+ // Iterate over second series?
+ //
+ if ((i = ((flags & SOP_FLAG_BOTH) != 0))) {
+ const REBVAL *temp = val1;
+ val1 = val2;
+ val2 = temp;
+ }
+ } while (i);
+
+ out_ser = Pop_Molded_String(&mo);
+ }
+
+ return out_ser;
}
-/***********************************************************************
-**
-*/ REBNATIVE(difference)
-/*
-** Set functions use this arg pattern:
-**
-** set1 [ series! bitset! date! ] "first set"
-** set2 [ series! bitset! date! ] "second set"
-** /case "case sensitive"
-** /skip "treat the series as records of fixed size"
-** size [integer!]
-**
-***********************************************************************/
+//
+// difference: native [
+//
+// "Returns the special difference of two values."
+//
+// series1 [any-array! any-string! binary! bitset! date! typeset!]
+// series2 [any-array! any-string! binary! bitset! date! typeset!]
+// /case
+// "Uses case-sensitive comparison"
+// /skip
+// "Treat the series as records of fixed size"
+// size [integer!]
+// ]
+//
+REBNATIVE(difference)
{
- REBVAL *val1, *val2;
-
- val1 = D_ARG(1);
- val2 = D_ARG(2);
-
- if (IS_DATE(val1) || IS_DATE(val2)) {
- if (!IS_DATE(val1)) Trap_Arg(val1);
- if (!IS_DATE(val2)) Trap_Arg(val2);
- Subtract_Date(val1, val2, D_RET);
- return R_RET;
- }
-
- return Do_Set_Operation(ds, SET_OP_DIFFERENCE);
+ INCLUDE_PARAMS_OF_DIFFERENCE;
+
+ REBVAL *val1 = ARG(series1);
+ REBVAL *val2 = ARG(series2);
+
+ // Plain SUBTRACT on dates has historically given a count of days.
+ // DIFFERENCE has been the way to get the time difference.
+ // !!! Is this sensible?
+ //
+ if (IS_DATE(val1) || IS_DATE(val2)) {
+ if (VAL_TYPE(val1) != VAL_TYPE(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+
+ Subtract_Date(val1, val2, D_OUT);
+ return R_OUT;
+ }
+
+ if (IS_BITSET(val1) || IS_BITSET(val2)) {
+ if (VAL_TYPE(val1) != VAL_TYPE(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+
+ Init_Bitset(D_OUT, Xandor_Binary(SYM_XOR_T, val1, val2));
+ return R_OUT;
+ }
+
+ if (IS_TYPESET(val1) || IS_TYPESET(val2)) {
+ if (VAL_TYPE(val1) != VAL_TYPE(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+
+ Move_Value(D_OUT, val1);
+ VAL_TYPESET_BITS(D_OUT) ^= VAL_TYPESET_BITS(val2);
+ return R_OUT;
+ }
+
+ Init_Any_Series(
+ D_OUT,
+ VAL_TYPE(val1),
+ Make_Set_Operation_Series(
+ val1,
+ val2,
+ SOP_FLAG_BOTH | SOP_FLAG_CHECK | SOP_FLAG_INVERT,
+ REF(case),
+ REF(skip) ? Int32s(ARG(size), 1) : 1
+ )
+ );
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(exclude)
-/*
-***********************************************************************/
+//
+// exclude: native [
+//
+// {Returns the first data set less the second data set.}
+//
+// series [any-array! any-string! binary! bitset! typeset!]
+// "original data"
+// exclusions [any-array! any-string! binary! bitset! typeset!]
+// "data to exclude from series"
+// /case
+// "Uses case-sensitive comparison"
+// /skip
+// "Treat the series as records of fixed size"
+// size [integer!]
+// ]
+//
+REBNATIVE(exclude)
{
- return Do_Set_Operation(ds, SET_OP_EXCLUDE);
+ INCLUDE_PARAMS_OF_EXCLUDE;
+
+ REBVAL *val1 = ARG(series);
+ REBVAL *val2 = ARG(exclusions);
+
+ if (IS_BITSET(val1) || IS_BITSET(val2)) {
+ if (VAL_TYPE(val1) != VAL_TYPE(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+
+ // !!! 0 was said to be a "special case" in original code
+ //
+ Init_Bitset(D_OUT, Xandor_Binary(0, val1, val2));
+ return R_OUT;
+ }
+
+ if (IS_TYPESET(val1) || IS_TYPESET(val2)) {
+ if (VAL_TYPE(val1) != VAL_TYPE(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+
+ Move_Value(D_OUT, val1);
+ VAL_TYPESET_BITS(D_OUT) &= ~VAL_TYPESET_BITS(val2);
+ return R_OUT;
+ }
+
+ Init_Any_Series(
+ D_OUT,
+ VAL_TYPE(val1),
+ Make_Set_Operation_Series(
+ val1,
+ val2,
+ SOP_FLAG_CHECK | SOP_FLAG_INVERT,
+ REF(case),
+ REF(skip) ? Int32s(ARG(size), 1) : 1
+ )
+ );
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(intersect)
-/*
-***********************************************************************/
+//
+// intersect: native [
+//
+// "Returns the intersection of two data series."
+//
+// series1 [any-array! any-string! binary! bitset! typeset!]
+// series2 [any-array! any-string! binary! bitset! typeset!]
+// /case
+// "Uses case-sensitive comparison"
+// /skip
+// "Treat the series as records of fixed size"
+// size [integer!]
+// ]
+//
+REBNATIVE(intersect)
{
- return Do_Set_Operation(ds, SET_OP_INTERSECT);
+ INCLUDE_PARAMS_OF_INTERSECT;
+
+ REBVAL *val1 = ARG(series1);
+ REBVAL *val2 = ARG(series2);
+
+ if (IS_BITSET(val1) || IS_BITSET(val2)) {
+ if (VAL_TYPE(val1) != VAL_TYPE(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+
+ Init_Bitset(D_OUT, Xandor_Binary(SYM_AND_T, val1, val2));
+ return R_OUT;
+ }
+
+ if (IS_TYPESET(val1) || IS_TYPESET(val2)) {
+ if (VAL_TYPE(val1) != VAL_TYPE(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+
+ Move_Value(D_OUT, val1);
+ VAL_TYPESET_BITS(D_OUT) &= VAL_TYPESET_BITS(val2);
+ return R_OUT;
+ }
+
+ Init_Any_Series(
+ D_OUT,
+ VAL_TYPE(val1),
+ Make_Set_Operation_Series(
+ val1,
+ val2,
+ SOP_FLAG_CHECK,
+ REF(case),
+ REF(skip) ? Int32s(ARG(size), 1) : 1
+ )
+ );
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(union)
-/*
-***********************************************************************/
+//
+// union: native [
+//
+// "Returns the union of two data series."
+//
+// series1 [any-array! any-string! binary! bitset! typeset!]
+// series2 [any-array! any-string! binary! bitset! typeset!]
+// /case
+// "Use case-sensitive comparison"
+// /skip
+// "Treat the series as records of fixed size"
+// size [integer!]
+// ]
+//
+REBNATIVE(union)
{
- return Do_Set_Operation(ds, SET_OP_UNION);
+ INCLUDE_PARAMS_OF_UNION;
+
+ REBVAL *val1 = ARG(series1);
+ REBVAL *val2 = ARG(series2);
+
+ if (IS_BITSET(val1) || IS_BITSET(val2)) {
+ if (VAL_TYPE(val1) != VAL_TYPE(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+
+ Init_Bitset(D_OUT, Xandor_Binary(SYM_OR_T, val1, val2));
+ return R_OUT;
+ }
+
+ if (IS_TYPESET(val1) || IS_TYPESET(val2)) {
+ if (VAL_TYPE(val1) != VAL_TYPE(val2))
+ fail (Error_Unexpected_Type(VAL_TYPE(val1), VAL_TYPE(val2)));
+
+ Move_Value(D_OUT, val1);
+ VAL_TYPESET_BITS(D_OUT) |= VAL_TYPESET_BITS(val2);
+ return R_OUT;
+ }
+
+ Init_Any_Series(
+ D_OUT,
+ VAL_TYPE(val1),
+ Make_Set_Operation_Series(
+ val1,
+ val2,
+ SOP_FLAG_BOTH,
+ REF(case),
+ REF(skip) ? Int32s(ARG(size), 1) : 1
+ )
+ );
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(unique)
-/*
-***********************************************************************/
+//
+// unique: native [
+//
+// "Returns the data set with duplicates removed."
+//
+// series [any-array! any-string! binary! bitset! typeset!]
+// /case
+// "Use case-sensitive comparison (except bitsets)"
+// /skip
+// "Treat the series as records of fixed size"
+// size [integer!]
+// ]
+//
+REBNATIVE(unique)
{
- return Do_Set_Operation(ds, SET_OP_UNIQUE);
+ INCLUDE_PARAMS_OF_UNIQUE;
+
+ REBVAL *val = ARG(series);
+
+ if (IS_BITSET(val) || IS_TYPESET(val)) {
+ //
+ // Bitsets and typesets already unique (by definition)
+ //
+ Move_Value(D_OUT, ARG(series));
+ return R_OUT;
+ }
+
+ Init_Any_Series(
+ D_OUT,
+ VAL_TYPE(val),
+ Make_Set_Operation_Series(
+ val,
+ NULL,
+ SOP_NONE,
+ REF(case),
+ REF(skip) ? Int32s(ARG(size), 1) : 1
+ )
+ );
+
+ return R_OUT;
}
-
-
diff --git a/src/core/n-strings.c b/src/core/n-strings.c
index f0aeb834ad..2c31a448e4 100644
--- a/src/core/n-strings.c
+++ b/src/core/n-strings.c
@@ -1,746 +1,1125 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: n-strings.c
-** Summary: native functions for strings
-** Section: natives
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %n-strings.c
+// Summary: "native functions for strings"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
#include "sys-deci-funcs.h"
+#include "sys-zlib.h"
/***********************************************************************
**
-** Hash Function Externs
+** Hash Function Externs
**
***********************************************************************/
-#ifndef SHA_DEFINED
-#ifdef HAS_SHA1
-REBYTE *SHA1(REBYTE *, REBCNT, REBYTE *);
-void SHA1_Init(void *c);
-void SHA1_Update(void *c, REBYTE *data, REBCNT len);
-void SHA1_Final(REBYTE *md, void *c);
-int SHA1_CtxSize(void);
-#endif
-#endif
+#if !defined(SHA_DEFINED) && defined(HAS_SHA1)
+ // make-headers.r outputs a prototype already, because it is used by cloak
+ // (triggers warning -Wredundant-decls)
+ // REBYTE *SHA1(REBYTE *, REBCNT, REBYTE *);
-#ifndef MD5_DEFINED
-#ifdef HAS_MD5
-REBYTE *MD5(REBYTE *, REBCNT, REBYTE *);
-void MD5_Init(void *c);
-void MD5_Update(void *c, REBYTE *data, REBCNT len);
-void MD5_Final(REBYTE *md, void *c);
-int MD5_CtxSize(void);
+ EXTERN_C void SHA1_Init(void *c);
+ EXTERN_C void SHA1_Update(void *c, REBYTE *data, REBCNT len);
+ EXTERN_C void SHA1_Final(REBYTE *md, void *c);
+ EXTERN_C int SHA1_CtxSize(void);
#endif
+
+#if !defined(MD5_DEFINED) && defined(HAS_MD5)
+ EXTERN_C void MD5_Init(void *c);
+ EXTERN_C void MD5_Update(void *c, REBYTE *data, REBCNT len);
+ EXTERN_C void MD5_Final(REBYTE *md, void *c);
+ EXTERN_C int MD5_CtxSize(void);
#endif
#ifdef HAS_MD4
-REBYTE *MD4(REBYTE *, REBCNT, REBYTE *);
-void MD4_Init(void *c);
-void MD4_Update(void *c, REBYTE *data, REBCNT len);
-void MD4_Final(REBYTE *md, void *c);
-int MD4_CtxSize(void);
+ REBYTE *MD4(REBYTE *, REBCNT, REBYTE *);
+
+ EXTERN_C void MD4_Init(void *c);
+ EXTERN_C void MD4_Update(void *c, REBYTE *data, REBCNT len);
+ EXTERN_ void MD4_Final(REBYTE *md, void *c);
+ EXTERN_C int MD4_CtxSize(void);
#endif
+
// Table of has functions and parameters:
-static struct digest {
- REBYTE *(*digest)(REBYTE *, REBCNT, REBYTE *);
- void (*init)(void *);
- void (*update)(void *, REBYTE *, REBCNT);
- void (*final)(REBYTE *, void *);
- int (*ctxsize)(void);
- REBINT index;
- REBINT len;
- REBINT hmacblock;
+static struct {
+ REBYTE *(*digest)(REBYTE *, REBCNT, REBYTE *);
+ void (*init)(void *);
+ void (*update)(void *, REBYTE *, REBCNT);
+ void (*final)(REBYTE *, void *);
+ int (*ctxsize)(void);
+ REBSYM sym;
+ REBINT len;
+ REBINT hmacblock;
} digests[] = {
#ifdef HAS_SHA1
- {SHA1, SHA1_Init, SHA1_Update, SHA1_Final, SHA1_CtxSize, SYM_SHA1, 20, 64},
+ {SHA1, SHA1_Init, SHA1_Update, SHA1_Final, SHA1_CtxSize, SYM_SHA1, 20, 64},
#endif
#ifdef HAS_MD4
- {MD4, MD4_Init, MD4_Update, MD4_Final, MD4_CtxSize, SYM_MD4, 16, 64},
+ {MD4, MD4_Init, MD4_Update, MD4_Final, MD4_CtxSize, SYM_MD4, 16, 64},
#endif
#ifdef HAS_MD5
- {MD5, MD5_Init, MD5_Update, MD5_Final, MD5_CtxSize, SYM_MD5, 16, 64},
+ {MD5, MD5_Init, MD5_Update, MD5_Final, MD5_CtxSize, SYM_MD5, 16, 64},
#endif
- {0}
+ {NULL, NULL, NULL, NULL, NULL, SYM_0, 0, 0}
};
-/***********************************************************************
-**
-*/ REBNATIVE(ajoin)
-/*
-***********************************************************************/
+//
+// delimit: native [
+//
+// {Joins a block of values into a new string with delimiters.}
+//
+// return: [string!]
+// block [block!]
+// delimiter [blank! char! string!]
+// ]
+//
+REBNATIVE(delimit)
{
- REBSER *str;
-
- str = Form_Reduce(VAL_SERIES(D_ARG(1)), VAL_INDEX(D_ARG(1)));
- if (!str) return R_TOS;
+ INCLUDE_PARAMS_OF_DELIMIT;
+
+ REBVAL *block = ARG(block);
+ REBVAL *delimiter = ARG(delimiter);
+
+ if (Form_Reduce_Throws(
+ D_OUT,
+ VAL_ARRAY(block),
+ VAL_INDEX(block),
+ VAL_SPECIFIER(block),
+ delimiter
+ )) {
+ return R_OUT_IS_THROWN;
+ }
+
+ return R_OUT;
+}
- Set_String(DS_RETURN, str); // not D_RET (stack modified)
- return R_RET;
+//
+// spelling-of: native [
+//
+// {Gives the delimiter-less spelling of words or strings}
+//
+// value [any-word! any-string!]
+// ]
+//
+REBNATIVE(spelling_of)
+{
+ INCLUDE_PARAMS_OF_SPELLING_OF;
+
+ REBVAL *value = ARG(value);
+
+ REBSER *series;
+
+ if (ANY_BINSTR(value)) {
+ assert(!IS_BINARY(value)); // Shouldn't accept binary types...
+
+ // Grab the data out of all string types, which has no delimiters
+ // included (they are added in the forming process)
+ //
+ series = Copy_String_Slimming(VAL_SERIES(value), VAL_INDEX(value), -1);
+ }
+ else {
+ // turn all words into regular words so they'll have no delimiters
+ // during the FORMing process. Use SET_TYPE and not reset header
+ // because the binding bits need to stay consistent
+ //
+ VAL_SET_TYPE_BITS(value, REB_WORD);
+ series = Copy_Mold_Value(value, 0 /* opts... MOPT_0? */);
+ }
+
+ Init_String(D_OUT, series);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(as_binary)
-/*
-***********************************************************************/
+//
+// checksum: native [
+//
+// "Computes a checksum, CRC, or hash."
+//
+// data [binary!]
+// "Bytes to checksum"
+// /part
+// limit
+// "Length of data"
+// /tcp
+// "Returns an Internet TCP 16-bit checksum"
+// /secure
+// "Returns a cryptographically secure checksum"
+// /hash
+// "Returns a hash value"
+// size [integer!]
+// "Size of the hash table"
+// /method
+// "Method to use"
+// word [word!]
+// "Methods: SHA1 MD5 CRC32"
+// /key
+// "Returns keyed HMAC value"
+// key-value [any-string!]
+// "Key to use"
+// ]
+//
+REBNATIVE(checksum)
{
- Trap0(RE_DEPRECATED);
-// *D_RET = *D_ARG(1);
-// VAL_SET(D_RET, REB_BINARY);
- return R_RET;
+ INCLUDE_PARAMS_OF_CHECKSUM;
+
+ REBVAL *arg = ARG(data);
+ REBYTE *data = VAL_RAW_DATA_AT(arg);
+ REBCNT wide = SER_WIDE(VAL_SERIES(arg));
+ REBCNT len = 0;
+
+ UNUSED(REF(part)); // checked by if limit is void
+ Partial1(arg, ARG(limit), &len);
+
+ REBSYM sym;
+ if (REF(method)) {
+ sym = VAL_WORD_SYM(ARG(word));
+ if (sym == SYM_0) // not in %words.r, no SYM_XXX constant
+ fail (ARG(word));
+ }
+ else
+ sym = SYM_SHA1;
+
+ // If method, secure, or key... find matching digest:
+ if (REF(method) || REF(secure) || REF(key)) {
+ if (sym == SYM_CRC32) {
+ if (REF(secure) || REF(key))
+ fail (Error_Bad_Refines_Raw());
+
+ // The CRC32() routine returns an unsigned 32-bit number and uses
+ // the full range of values. Yet Rebol chose to export this as
+ // a signed integer via checksum. Perhaps (?) to generate a value
+ // that could also be used by Rebol2, as it only had 32-bit
+ // signed INTEGER! available.
+ //
+ REBINT crc32 = cast(REBINT, CRC32(data, len));
+ Init_Integer(D_OUT, crc32);
+ return R_OUT;
+ }
+
+ if (sym == SYM_ADLER32) {
+ if (REF(secure) || REF(key))
+ fail (Error_Bad_Refines_Raw());
+
+ // adler32() is a Saphirion addition since 64-bit INTEGER! was
+ // available in Rebol3, and did not convert the unsigned result
+ // of the adler calculation to a signed integer.
+ //
+ uLong adler = z_adler32(0L, data, len);
+ Init_Integer(D_OUT, adler);
+ return R_OUT;
+ }
+
+ REBCNT i;
+ for (i = 0; i < sizeof(digests) / sizeof(digests[0]); i++) {
+ if (!SAME_SYM_NONZERO(digests[i].sym, sym))
+ continue;
+
+ REBSER *digest = Make_Series(digests[i].len + 1, sizeof(char));
+
+ if (NOT(REF(key)))
+ digests[i].digest(data, len, BIN_HEAD(digest));
+ else {
+ REBVAL *key = ARG(key_value);
+
+ int blocklen = digests[i].hmacblock;
+
+ REBYTE tmpdigest[20]; // size must be max of all digest[].len
+ REBYTE *keycp = VAL_BIN_AT(key);
+ int keylen = VAL_LEN_AT(key);
+ if (keylen > blocklen) {
+ digests[i].digest(keycp,keylen,tmpdigest);
+ keycp = tmpdigest;
+ keylen = digests[i].len;
+ }
+
+ REBYTE ipad[64]; // size must be max of all digest[].hmacblock
+ memset(ipad, 0, blocklen);
+ memcpy(ipad, keycp, keylen);
+
+ REBYTE opad[64]; // size must be max of all digest[].hmacblock
+ memset(opad, 0, blocklen);
+ memcpy(opad, keycp, keylen);
+
+ REBINT j;
+ for (j = 0; j < blocklen; j++) {
+ ipad[j] ^= 0x36; // !!! why do people write this kind of
+ opad[j] ^= 0x5c; // thing without a comment? !!! :-(
+ }
+
+ char *ctx = ALLOC_N(char, digests[i].ctxsize());
+ digests[i].init(ctx);
+ digests[i].update(ctx,ipad,blocklen);
+ digests[i].update(ctx, data, len);
+ digests[i].final(tmpdigest,ctx);
+ digests[i].init(ctx);
+ digests[i].update(ctx,opad,blocklen);
+ digests[i].update(ctx,tmpdigest,digests[i].len);
+ digests[i].final(BIN_HEAD(digest),ctx);
+
+ FREE_N(char, digests[i].ctxsize(), ctx);
+ }
+
+ TERM_BIN_LEN(digest, digests[i].len);
+ Init_Binary(D_OUT, digest);
+
+ return R_OUT;
+ }
+
+ fail (ARG(word));
+ }
+ else if (REF(tcp)) {
+ REBINT ipc = Compute_IPC(data, len);
+ Init_Integer(D_OUT, ipc);
+ }
+ else if (REF(hash)) {
+ REBINT sum = VAL_INT32(ARG(size));
+ if (sum <= 1)
+ sum = 1;
+
+ REBINT hash = Hash_String(data, len, wide) % sum;
+ Init_Integer(D_OUT, hash);
+ }
+ else {
+ REBINT crc = Compute_CRC(data, len);
+ Init_Integer(D_OUT, crc);
+ }
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(as_string)
-/*
-***********************************************************************/
+//
+// compress: native [
+//
+// "Compresses a string series and returns it."
+//
+// return: [binary!]
+// data [binary! string!]
+// "If string, it will be UTF8 encoded"
+// /part
+// limit
+// "Length of data (elements)"
+// /gzip
+// "Use GZIP checksum"
+// /only
+// {Do not store header or envelope information ("raw")}
+// ]
+//
+REBNATIVE(compress)
{
- Trap0(RE_DEPRECATED);
-// *D_RET = *D_ARG(1);
-// VAL_SET(D_RET, REB_STRING);
- return R_RET;
+ INCLUDE_PARAMS_OF_COMPRESS;
+
+ REBCNT len;
+ UNUSED(PAR(part)); // checked by if limit is void
+ Partial1(ARG(data), ARG(limit), &len);
+
+ REBCNT index;
+ REBSER *ser = Temp_Bin_Str_Managed(ARG(data), &index, &len);
+
+ Init_Binary(D_OUT, Compress(ser, index, len, REF(gzip), REF(only)));
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(checksum)
-/*
-** Computes checksum or hash value.
-**
-** Note: Currently BINARY only.
-**
-** Args:
-**
-** data [any-string!] {Data to checksum}
-** /part length
-** /tcp {Returns an Internet TCP 16-bit checksum.}
-** /secure {Returns a cryptographically secure checksum.}
-** /hash {Returns a hash value}
-** size [integer!] {Size of the hash table}
-** /method {Method to use}
-** word [word!] {Method: SHA1 MD5}
-** /key {Returns keyed HMAC value}
-** key-value [any-string!] {Key to use}
-**
-***********************************************************************/
+//
+// decompress: native [
+//
+// "Decompresses data."
+//
+// return: [binary!]
+// data [binary!]
+// "Data to decompress"
+// /part
+// lim ;-- /limit was a legacy name for a refinement
+// "Length of compressed data (must match end marker)"
+// /gzip
+// "Use GZIP checksum"
+// /limit
+// max
+// "Error out if result is larger than this"
+// /only
+// {Do not look for header or envelope information ("raw")}
+// ]
+//
+REBNATIVE(decompress)
{
- REBVAL *arg = D_ARG(ARG_CHECKSUM_DATA);
- REBINT sum;
- REBINT i;
- REBINT j;
- REBSER *digest;
- REBINT sym = SYM_SHA1;
- REBCNT len;
- REBYTE *data = VAL_BIN_DATA(arg);
-
- len = Partial1(arg, D_ARG(ARG_CHECKSUM_LENGTH));
-
- // Method word:
- if (D_REF(ARG_CHECKSUM_METHOD)) sym = VAL_WORD_CANON(D_ARG(ARG_CHECKSUM_WORD));
-
- // If method, secure, or key... find matching digest:
- if (D_REF(ARG_CHECKSUM_METHOD) || D_REF(ARG_CHECKSUM_SECURE) || D_REF(ARG_CHECKSUM_KEY)) {
-
- if (sym == SYM_CRC32) {
- if (D_REF(ARG_CHECKSUM_SECURE) || D_REF(ARG_CHECKSUM_KEY)) Trap0(RE_BAD_REFINES);
- i = CRC32(data, len);
- DS_RET_INT(i);
- return R_RET;
- }
-
- for (i = 0; i < sizeof(digests) / sizeof(digests[0]); i++) {
-
- if (digests[i].index == sym) {
-
- digest = Make_Series(digests[i].len, 1, FALSE);
- LABEL_SERIES(digest, "checksum digest");
-
- if (D_REF(ARG_CHECKSUM_KEY)) {
- REBYTE tmpdigest[20]; // Size must be max of all digest[].len;
- REBYTE ipad[64],opad[64]; // Size must be max of all digest[].hmacblock;
- void *ctx = Make_Mem(digests[i].ctxsize());
- REBVAL *key = D_ARG(ARG_CHECKSUM_KEY_VALUE);
- REBYTE *keycp = VAL_BIN_DATA(key);
- int keylen = VAL_LEN(key);
- int blocklen = digests[i].hmacblock;
-
- if (keylen > blocklen) {
- digests[i].digest(keycp,keylen,tmpdigest);
- keycp = tmpdigest;
- keylen = digests[i].len;
- }
-
- memset(ipad, 0, blocklen);
- memset(opad, 0, blocklen);
- memcpy(ipad, keycp, keylen);
- memcpy(opad, keycp, keylen);
-
- for (j = 0; j < blocklen; j++) {
- ipad[j]^=0x36;
- opad[j]^=0x5c;
- }
-
- digests[i].init(ctx);
- digests[i].update(ctx,ipad,blocklen);
- digests[i].update(ctx, data, len);
- digests[i].final(tmpdigest,ctx);
- digests[i].init(ctx);
- digests[i].update(ctx,opad,blocklen);
- digests[i].update(ctx,tmpdigest,digests[i].len);
- digests[i].final(BIN_HEAD(digest),ctx);
-
- Free_Mem(ctx, digests[i].ctxsize());
-
- } else {
- digests[i].digest(data, len, BIN_HEAD(digest));
- }
-
- SERIES_TAIL(digest) = digests[i].len;
- Set_Series(REB_BINARY, DS_RETURN, digest);
-
- return 0;
- }
- }
-
- Trap_Arg(D_ARG(ARG_CHECKSUM_WORD));
- }
- else if (D_REF(ARG_CHECKSUM_TCP)) { // /tcp
- i = Compute_IPC(data, len);
- }
- else if (D_REF(ARG_CHECKSUM_HASH)) { // /hash
- sum = VAL_INT32(D_ARG(ARG_CHECKSUM_SIZE)); // /size
- if (sum <= 1) sum = 1;
- i = Hash_String(data, len) % sum;
- }
- else {
- i = Compute_CRC(data, len);
- }
-
- DS_RET_INT(i);
-
- return R_RET;
+ INCLUDE_PARAMS_OF_DECOMPRESS;
+
+ REBVAL *data = ARG(data);
+
+ REBINT max;
+ if (REF(limit)) {
+ max = Int32s(ARG(max), 1);
+ if (max < 0)
+ return R_BLANK; // !!! Should negative limit be an error instead?
+ }
+ else
+ max = -1;
+
+ REBCNT len;
+ UNUSED(REF(part)); // implied by non-void lim
+ Partial1(data, ARG(lim), &len);
+
+ // This truncation rule used to be in Decompress, which passed len
+ // in as an extra parameter. This was the only call that used it.
+ //
+ if (len > BIN_LEN(VAL_SERIES(data)))
+ len = BIN_LEN(VAL_SERIES(data));
+
+
+ Init_Binary(D_OUT, Decompress(
+ BIN_HEAD(VAL_SERIES(data)) + VAL_INDEX(data),
+ len,
+ max,
+ REF(gzip),
+ REF(only)
+ ));
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(compress)
-/*
-** Binary and string (gets UTF8 converted).
-**
-***********************************************************************/
+//
+// debase: native [
+//
+// {Decodes binary-coded string (BASE-64 default) to binary value.}
+//
+// return: [binary!]
+// ;-- Comment said "we don't know the encoding" of the return binary
+// value [binary! string!]
+// "The string to decode"
+// /base
+// "Binary base to use"
+// base-value [integer!]
+// "The base to convert from: 64, 16, or 2"
+// ]
+//
+REBNATIVE(debase)
{
- REBSER *ser;
- REBCNT index;
- REBINT len;
+ INCLUDE_PARAMS_OF_DEBASE;
- len = Partial1(D_ARG(1), D_ARG(3));
+ REBCNT index;
+ REBCNT len = 0;
+ REBSER *ser = Temp_Bin_Str_Managed(ARG(value), &index, &len);
- ser = Prep_Bin_Str(D_ARG(1), &index, &len); // result may be a SHARED BUFFER!
+ REBINT base = 64;
+ if (REF(base))
+ base = VAL_INT32(ARG(base_value));
+ else
+ base = 64;
- Set_Binary(D_RET, Compress(ser, index, len, D_REF(4))); // /gzip
+ if (!Decode_Binary(D_OUT, BIN_AT(ser, index), len, base, 0))
+ fail (Error_Invalid_Data_Raw(ARG(value)));
- return R_RET;
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(decompress)
-/*
-** Binary only.
-**
-***********************************************************************/
+//
+// enbase: native [
+//
+// {Encodes data into a binary, hexadecimal, or base-64 ASCII string.}
+//
+// return: [string!]
+// value [binary! string!]
+// "If string, will be UTF8 encoded"
+// /base
+// "Binary base to use (BASE-64 default)"
+// base-value [integer!]
+// "The base to convert to: 64, 16, or 2"
+// ]
+//
+REBNATIVE(enbase)
{
- REBVAL *arg = D_ARG(1);
- REBINT limit = 0;
- REBINT len;
+ INCLUDE_PARAMS_OF_ENBASE;
+
+ REBINT base;
+ if (REF(base))
+ base = VAL_INT32(ARG(base_value));
+ else
+ base = 64;
- len = Partial1(D_ARG(1), D_ARG(3));
+ REBVAL *arg = ARG(value);
- if (D_REF(5)) limit = Int32s(D_ARG(6), 1); // /limit size
-
- Set_Binary(D_RET, Decompress(VAL_SERIES(arg), VAL_INDEX(arg), len, limit, D_REF(4))); // /gzip
+ // Will convert STRING!s to UTF-8 if necessary.
+ //
+ REBCNT index;
+ REBSER *temp = Temp_Bin_Str_Managed(arg, &index, NULL);
+ Init_Any_Series_At(arg, REB_BINARY, temp, index);
- return R_RET;
+ REBSER *ser;
+ switch (base) {
+ case 64:
+ ser = Encode_Base64(arg, 0, FALSE);
+ break;
+
+ case 16:
+ ser = Encode_Base16(arg, 0, FALSE);
+ break;
+
+ case 2:
+ ser = Encode_Base2(arg, 0, FALSE);
+ break;
+
+ default:
+ fail (ARG(base_value));
+ }
+
+ Init_String(D_OUT, ser);
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(construct)
-/*
-***********************************************************************/
+//
+// dehex: native [
+//
+// "Converts URL-style hex encoded (%xx) strings."
+//
+// value [any-string!] "The string to dehex"
+// ]
+//
+REBNATIVE(dehex)
{
- REBVAL *value = D_ARG(1);
- REBSER *parent = 0;
- REBSER *frame;
+ INCLUDE_PARAMS_OF_DEHEX;
+
+ REBCNT len = VAL_LEN_AT(ARG(value));
+ REBUNI uni;
+ REBSER *ser;
+
+ if (VAL_BYTE_SIZE(ARG(value))) {
+ REBYTE *bp = VAL_BIN_AT(ARG(value));
+ REBYTE *dp = Reset_Buffer(BYTE_BUF, len);
+
+ for (; len > 0; len--) {
+ if (*bp == '%' && len > 2 && Scan_Hex2(bp + 1, &uni, FALSE)) {
+ *dp++ = cast(REBYTE, uni);
+ bp += 3;
+ len -= 2;
+ }
+ else *dp++ = *bp++;
+ }
+
+ *dp = '\0';
+ ser = Copy_String_Slimming(BYTE_BUF, 0, dp - BIN_HEAD(BYTE_BUF));
+ }
+ else {
+ REBUNI *up = VAL_UNI_AT(ARG(value));
+ REBUNI *dp;
+ REB_MOLD mo;
+ CLEARS(&mo);
+
+ Push_Mold(&mo);
+
+ // Do a conservative expansion, assuming there are no %NNs in the
+ // series and the output string will be the same length as input
+ //
+ Expand_Series(mo.series, mo.start, len);
+
+ dp = UNI_AT(mo.series, mo.start); // Expand_Series may change pointer
+
+ for (; len > 0; len--) {
+ if (
+ *up == '%'
+ && len > 2
+ && Scan_Hex2(cast(REBYTE*, up + 1), dp, TRUE)
+ ) {
+ dp++;
+ up += 3;
+ len -= 2;
+ }
+ else *dp++ = *up++;
+ }
+
+ *dp = '\0';
+
+ // The delta in dp from the original pointer position tells us the
+ // actual size after the %NNs have been accounted for.
+ //
+ ser = Pop_Molded_String_Len(
+ &mo, cast(REBCNT, dp - UNI_AT(mo.series, mo.start))
+ );
+ }
+
+ Init_Any_Series(D_OUT, VAL_TYPE(ARG(value)), ser);
+
+ return R_OUT;
+}
- if (IS_STRING(value) || IS_BINARY(value)) {
- REBCNT index;
- // Just a guess at size:
- frame = Make_Block(10); // Use a std BUF_?
- Set_Block(D_RET, frame); // Keep safe
+//
+// deline: native [
+//
+// {Converts string terminators to standard format, e.g. CRLF to LF.}
+//
+// string [any-string!]
+// "Will be modified (unless /LINES used)"
+// /lines
+// {Return block of lines (works for LF, CR, CR-LF endings)}
+// ]
+//
+REBNATIVE(deline)
+{
+ INCLUDE_PARAMS_OF_DELINE;
+
+ REBVAL *val = ARG(string);
- // Convert string if necessary. Store back for safety.
- VAL_SERIES(value) = Prep_Bin_Str(value, &index, 0);
+ if (REF(lines)) {
+ Init_Block(D_OUT, Split_Lines(val));
+ return R_OUT;
+ }
- // !issue! Is this what we really want here?
- Scan_Net_Header(frame, VAL_BIN(value) + index);
- value = D_RET;
- }
+ REBINT len = VAL_LEN_AT(val);
- if (D_REF(2)) parent = VAL_OBJ_FRAME(D_ARG(3));
+ REBINT n;
+ if (VAL_BYTE_SIZE(val)) {
+ REBYTE *bp = VAL_BIN_AT(val);
+ n = Deline_Bytes(bp, len);
+ } else {
+ REBUNI *up = VAL_UNI_AT(val);
+ n = Deline_Uni(up, len);
+ }
- frame = Construct_Object(parent, VAL_BLK_DATA(value), D_REF(4));
- SET_OBJECT(D_RET, frame);
+ SET_SERIES_LEN(VAL_SERIES(val), VAL_LEN_HEAD(val) - (len - n));
- return R_RET;
+ Move_Value(D_OUT, ARG(string));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(debase)
-/*
-** Converts a binary base representation string to binary.
-** Input is a STRING, but BINARY is also accepted.
-** BINARY is returned. We don't know the encoding.
-**
-***********************************************************************/
+//
+// enline: native [
+//
+// {Converts string terminators to native OS format, e.g. LF to CRLF.}
+//
+// series [any-string! block!] "(modified)"
+// ]
+//
+REBNATIVE(enline)
{
- REBINT base = 64;
- REBSER *ser;
- REBCNT index;
- REBCNT len = 0;
-
- ser = Prep_Bin_Str(D_ARG(1), &index, &len); // result may be a SHARED BUFFER!
+ INCLUDE_PARAMS_OF_ENLINE;
- if (D_REF(2)) base = VAL_INT32(D_ARG(3)); // /base
+ REBVAL *val = ARG(series);
+ REBSER *ser = VAL_SERIES(val);
- if (!Decode_Binary(D_RET, BIN_SKIP(ser, index), len, base, 0))
- Trap1(RE_INVALID_DATA, D_ARG(1));
+ if (SER_LEN(ser)) {
+ if (VAL_BYTE_SIZE(val))
+ Enline_Bytes(ser, VAL_INDEX(val), VAL_LEN_AT(val));
+ else
+ Enline_Uni(ser, VAL_INDEX(val), VAL_LEN_AT(val));
+ }
- return R_RET;
+ Move_Value(D_OUT, ARG(series));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(enbase)
-/*
-** Converts a binary to a binary base representation STRING.
-** Input is BINARY or STRING (UTF8 encoded).
-**
-***********************************************************************/
+//
+// entab: native [
+//
+// "Converts spaces to tabs (default tab size is 4)."
+//
+// string [any-string!]
+// "(modified)"
+// /size
+// "Specifies the number of spaces per tab"
+// number [integer!]
+// ]
+//
+REBNATIVE(entab)
{
- REBINT base = 64;
- REBSER *ser;
- REBCNT index;
- REBVAL *arg = D_ARG(1);
+ INCLUDE_PARAMS_OF_ENTAB;
+
+ REBVAL *val = ARG(string);
- Set_Binary(arg, Prep_Bin_Str(arg, &index, 0)); // may be SHARED buffer
- VAL_INDEX(arg) = index;
+ REBCNT len = VAL_LEN_AT(val);
- if (D_REF(2)) base = VAL_INT32(D_ARG(3));
+ REBINT tabsize;
+ if (REF(size))
+ tabsize = Int32s(ARG(number), 1);
+ else
+ tabsize = TAB_SIZE;
- switch (base) {
- case 64:
- ser = Encode_Base64(arg, 0, FALSE);
- break;
- case 16:
- ser = Encode_Base16(arg, 0, FALSE);
- break;
- case 2:
- ser = Encode_Base2(arg, 0, FALSE);
- break;
- default:
- Trap_Arg(D_ARG(3));
- }
+ REBSER *ser;
+ if (VAL_BYTE_SIZE(val))
+ ser = Entab_Bytes(VAL_BIN(val), VAL_INDEX(val), len, tabsize);
+ else
+ ser = Entab_Unicode(VAL_UNI(val), VAL_INDEX(val), len, tabsize);
- Set_String(D_RET, ser);
+ Init_Any_Series(D_OUT, VAL_TYPE(val), ser);
- return R_RET;
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(decloak)
-/*
-** Input is BINARY only. Modifies input.
-**
-***********************************************************************/
+//
+// detab: native [
+//
+// "Converts tabs to spaces (default tab size is 4)."
+//
+// string [any-string!]
+// "(modified)"
+// /size
+// "Specifies the number of spaces per tab"
+// number [integer!]
+// ]
+//
+REBNATIVE(detab)
{
- REBVAL *data = D_ARG(1);
- REBVAL *key = D_ARG(2);
+ INCLUDE_PARAMS_OF_DETAB;
- if (!Cloak(TRUE, VAL_BIN_DATA(data), VAL_LEN(data), (REBYTE*)key, 0, D_REF(3)))
- Trap_Arg(key);
+ REBVAL *val = ARG(string);
- return R_ARG1;
-}
+ REBCNT len = VAL_LEN_AT(val);
+ REBINT tabsize;
+ if (REF(size))
+ tabsize = Int32s(ARG(number), 1);
+ else
+ tabsize = TAB_SIZE;
-/***********************************************************************
-**
-*/ REBNATIVE(encloak)
-/*
-** Input is BINARY only. Modifies input.
-**
-***********************************************************************/
-{
- REBVAL *data = D_ARG(1);
- REBVAL *key = D_ARG(2);
+ REBSER *ser;
+ if (VAL_BYTE_SIZE(val))
+ ser = Detab_Bytes(VAL_BIN(val), VAL_INDEX(val), len, tabsize);
+ else
+ ser = Detab_Unicode(VAL_UNI(val), VAL_INDEX(val), len, tabsize);
- if (!Cloak(FALSE, VAL_BIN_DATA(data), VAL_LEN(data), (REBYTE*)key, 0, D_REF(3)))
- Trap_Arg(key);
+ Init_Any_Series(D_OUT, VAL_TYPE(val), ser);
- return R_ARG1;
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(dehex)
-/*
-** Works for any string.
-**
-***********************************************************************/
+//
+// lowercase: native [
+//
+// "Converts string of characters to lowercase."
+//
+// string [any-string! char!]
+// "(modified if series)"
+// /part
+// "Limits to a given length or position"
+// limit [any-number! any-string!]
+// ]
+//
+REBNATIVE(lowercase)
{
- REBVAL *arg = D_ARG(1);
- REBINT len = (REBINT)VAL_LEN(arg); // due to len -= 2 below
- REBUNI n;
- REBSER *ser;
-
- if (VAL_BYTE_SIZE(arg)) {
- REBYTE *bp = VAL_BIN_DATA(arg);
- REBYTE *dp = Reset_Buffer(BUF_FORM, len);
+ INCLUDE_PARAMS_OF_LOWERCASE;
- for (; len > 0; len--) {
- if (*bp == '%' && len > 2 && Scan_Hex2(bp+1, &n, FALSE)) {
- *dp++ = (REBYTE)n;
- bp += 3;
- len -= 2;
- }
- else *dp++ = *bp++;
- }
+ UNUSED(REF(part)); // checked by if limit is void
+ Change_Case(D_OUT, ARG(string), ARG(limit), FALSE);
+ return R_OUT;
+}
- *dp = 0;
- ser = Copy_String(BUF_FORM, 0, dp - BIN_HEAD(BUF_FORM));
- }
- else {
- REBUNI *up = VAL_UNI_DATA(arg);
- REBUNI *dp = (REBUNI*)Reset_Buffer(BUF_MOLD, len);
- for (; len > 0; len--) {
- if (*up == '%' && len > 2 && Scan_Hex2((REBYTE*)(up+1), &n, TRUE)) {
- *dp++ = (REBUNI)n;
- up += 3;
- len -= 2;
- }
- else *dp++ = *up++;
- }
+//
+// uppercase: native [
+//
+// "Converts string of characters to uppercase."
+//
+// string [any-string! char!]
+// "(modified if series)"
+// /part
+// "Limits to a given length or position"
+// limit [any-number! any-string!]
+// ]
+//
+REBNATIVE(uppercase)
+{
+ INCLUDE_PARAMS_OF_UPPERCASE;
- *dp = 0;
- ser = Copy_String(BUF_MOLD, 0, dp - UNI_HEAD(BUF_MOLD));
- }
+ UNUSED(REF(part)); // checked by if limit is void
+ Change_Case(D_OUT, ARG(string), ARG(limit), TRUE);
+ return R_OUT;
+}
- Set_Series(VAL_TYPE(arg), D_RET, ser);
- return R_RET;
+//
+// to-hex: native [
+//
+// {Converts numeric value to a hex issue! datatype (with leading # and 0's).}
+//
+// value [integer! tuple!]
+// "Value to be converted"
+// /size
+// "Specify number of hex digits in result"
+// len [integer!]
+// ]
+//
+REBNATIVE(to_hex)
+{
+ INCLUDE_PARAMS_OF_TO_HEX;
+
+ REBVAL *arg = ARG(value);
+
+ REBYTE buffer[(MAX_TUPLE * 2) + 4]; // largest value possible
+
+ REBYTE *buf = &buffer[0];
+
+ REBINT len;
+ if (REF(size)) {
+ len = cast(REBINT, VAL_INT64(ARG(len)));
+ if (len < 0)
+ fail (ARG(len));
+ }
+ else
+ len = -1;
+
+ if (IS_INTEGER(arg)) {
+ if (len < 0 || len > MAX_HEX_LEN)
+ len = MAX_HEX_LEN;
+
+ Form_Hex_Pad(buf, VAL_INT64(arg), len);
+ }
+ else if (IS_TUPLE(arg)) {
+ REBINT n;
+ if (
+ len < 0
+ || len > 2 * cast(REBINT, MAX_TUPLE)
+ || len > 2 * VAL_TUPLE_LEN(arg)
+ ){
+ len = 2 * VAL_TUPLE_LEN(arg);
+ }
+ for (n = 0; n < VAL_TUPLE_LEN(arg); n++)
+ buf = Form_Hex2(buf, VAL_TUPLE(arg)[n]);
+ for (; n < 3; n++)
+ buf = Form_Hex2(buf, 0);
+ *buf = 0;
+ }
+ else
+ fail (arg);
+
+ if (NULL == Scan_Issue(D_OUT, &buffer[0], len))
+ fail (arg);
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(deline)
-/*
-** Convert CR or CRLF strings to just LF strings.
-**
-***********************************************************************/
+//
+// find-script: native [
+//
+// {Find a script header within a binary string. Returns starting position.}
+//
+// script [binary!]
+// ]
+//
+REBNATIVE(find_script)
{
- REBVAL *val = D_ARG(1);
- REBINT len = VAL_LEN(val);
- REBINT n;
+ INCLUDE_PARAMS_OF_FIND_SCRIPT;
+
+ REBVAL *arg = ARG(script);
+
+ REBINT n = What_UTF(VAL_BIN_AT(arg), VAL_LEN_AT(arg));
+
+ if (n != 0 && n != 8)
+ return R_BLANK; // UTF8 only
- if (D_REF(2)) { //lines
- Set_Block(D_RET, Split_Lines(val));
- return R_RET;
- }
+ if (n == 8)
+ VAL_INDEX(arg) += 3; // BOM8 length
- if (VAL_BYTE_SIZE(val)) {
- REBYTE *bp = VAL_BIN_DATA(val);
- n = Deline_Bytes(bp, len);
- } else {
- REBUNI *up = VAL_UNI_DATA(val);
- n = Deline_Uni(up, len);
- }
+ REBINT offset = Scan_Header(VAL_BIN_AT(arg), VAL_LEN_AT(arg));
+ if (offset == -1)
+ return R_BLANK;
- VAL_TAIL(val) -= (len - n);
+ VAL_INDEX(arg) += offset;
- return R_ARG1;
+ Move_Value(D_OUT, ARG(script));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(enline)
-/*
-** Convert LF to CRLF or native format.
-**
-***********************************************************************/
+//
+// utf?: native [
+//
+// {Returns UTF BOM (byte order marker) encoding; + for BE, - for LE.}
+//
+// data [binary!]
+// ]
+//
+REBNATIVE(utf_q)
{
- REBVAL *val = D_ARG(1);
- REBSER *ser = VAL_SERIES(val);
-
- if (SERIES_TAIL(ser)) {
- if (VAL_BYTE_SIZE(val))
- Enline_Bytes(ser, VAL_INDEX(val), VAL_LEN(val));
- else
- Enline_Uni(ser, VAL_INDEX(val), VAL_LEN(val));
- }
+ INCLUDE_PARAMS_OF_UTF_Q;
- return R_ARG1;
+ REBINT utf = What_UTF(VAL_BIN_AT(ARG(data)), VAL_LEN_AT(ARG(data)));
+ Init_Integer(D_OUT, utf);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(entab)
-/*
-** Modifies input.
-**
-***********************************************************************/
+//
+// invalid-utf8?: native [
+//
+// {Checks UTF-8 encoding; if correct, returns blank else position of error.}
+//
+// data [binary!]
+// ]
+//
+REBNATIVE(invalid_utf8_q)
{
- REBVAL *val = D_ARG(1);
- REBINT tabsize = TAB_SIZE;
- REBSER *ser;
- REBCNT len = VAL_LEN(val);
+ INCLUDE_PARAMS_OF_INVALID_UTF8_Q;
+
+ REBVAL *arg = ARG(data);
- if (D_REF(2)) tabsize = Int32s(D_ARG(3), 1);
+ REBYTE *bp = Check_UTF8(VAL_BIN_AT(arg), VAL_LEN_AT(arg));
+ if (bp == 0)
+ return R_BLANK;
- // Set up the copy buffer:
- if (VAL_BYTE_SIZE(val))
- ser = Entab_Bytes(VAL_BIN(val), VAL_INDEX(val), len, tabsize);
- else
- ser = Entab_Unicode(VAL_UNI(val), VAL_INDEX(val), len, tabsize);
+ VAL_INDEX(arg) = bp - VAL_BIN_HEAD(arg);
- Set_Series(VAL_TYPE(val), D_RET, ser);
-
- return R_RET;
+ Move_Value(D_OUT, arg);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(detab)
-/*
-***********************************************************************/
+#ifndef NDEBUG
+//
+// b_cast_: C
+//
+// Debug-only version of b_cast() that does type checking.
+// If you get a complaint you probably meant to use cb_cast().
+//
+REBYTE *b_cast_(char *s)
{
- REBVAL *val = D_ARG(1);
- REBINT tabsize = TAB_SIZE;
- REBSER *ser;
- REBCNT len = VAL_LEN(val);
-
- if (D_REF(2)) tabsize = Int32s(D_ARG(3), 1);
+ return cast(REBYTE *, s);
+}
- // Set up the copy buffer:
- if (VAL_BYTE_SIZE(val))
- ser = Detab_Bytes(VAL_BIN(val), VAL_INDEX(val), len, tabsize);
- else
- ser = Detab_Unicode(VAL_UNI(val), VAL_INDEX(val), len, tabsize);
- Set_Series(VAL_TYPE(val), D_RET, ser);
-
- return R_RET;
+//
+// cb_cast_: C
+//
+// Debug-only version of cb_cast() that does type checking.
+// If you get a complaint you probably meant to use b_cast().
+//
+const REBYTE *cb_cast_(const char *s)
+{
+ return cast(const REBYTE *, s);
}
-/***********************************************************************
-**
-*/ REBNATIVE(lowercase)
-/*
-***********************************************************************/
+//
+// s_cast_: C
+//
+// Debug-only version of s_cast() that does type checking.
+// If you get a complaint you probably meant to use cs_cast().
+//
+char *s_cast_(REBYTE *s)
{
- Change_Case(ds, D_ARG(1), D_ARG(3), FALSE);
- return R_RET;
+ return cast(char*, s);
}
-/***********************************************************************
-**
-*/ REBNATIVE(uppercase)
-/*
-***********************************************************************/
+//
+// cs_cast_: C
+//
+// Debug-only version of cs_cast() that does type checking.
+// If you get a complaint you probably meant to use s_cast().
+//
+const char *cs_cast_(const REBYTE *s)
{
- Change_Case(ds, D_ARG(1), D_ARG(3), TRUE);
- return R_RET;
+ return cast(const char *, s);
}
-/***********************************************************************
-**
-*/ REBNATIVE(to_hex)
-/*
-***********************************************************************/
+//
+// COPY_BYTES_: C
+//
+// Debug-only REBYTE-checked substitute for COPY_BYTES macro
+// If you meant characters, consider if you wanted strncpy()
+//
+REBYTE *COPY_BYTES_(REBYTE *dest, const REBYTE *src, size_t count)
{
- REBVAL *arg = D_ARG(1);
- REBINT len;
-// REBSER *series;
- REBYTE buffer[MAX_TUPLE*2+4]; // largest value possible
- REBYTE *buf;
-
-#ifdef removed
- if (IS_INTEGER(arg)) len = MAX_HEX_LEN;
- else if (IS_TUPLE(arg)) {
- len = VAL_TUPLE_LEN(arg);
- if (len < 3) len = 3;
- len *= 2;
- }
- else Trap_Arg(arg);
-
- else if (IS_DECIMAL(arg)) len = MAX_HEX_LEN;
- else if (IS_MONEY(arg)) len = 24;
- else if (IS_CHAR(arg)) len = (VAL_CHAR(arg) > 0x7f) ? 4 : 2;
-#endif
-
- buf = &buffer[0];
-
- len = -1;
- if (D_REF(2)) { // /size
- len = (REBINT) VAL_INT64(D_ARG(3));
- if (len < 0) Trap_Arg(D_ARG(3));
- }
- if (IS_INTEGER(arg)) { // || IS_DECIMAL(arg)) {
- if (len < 0 || len > MAX_HEX_LEN) len = MAX_HEX_LEN;
- Form_Hex_Pad(buf, VAL_INT64(arg), len);
- }
- else if (IS_TUPLE(arg)) {
- REBINT n;
- if (len < 0 || len > 2 * MAX_TUPLE || len > 2 * VAL_TUPLE_LEN(arg))
- len = 2 * VAL_TUPLE_LEN(arg);
- for (n = 0; n < VAL_TUPLE_LEN(arg); n++)
- buf = Form_Hex2(buf, VAL_TUPLE(arg)[n]);
- for (; n < 3; n++)
- buf = Form_Hex2(buf, 0);
- *buf = 0;
- }
- else Trap_Arg(arg);
-
-#ifdef removed
- else if (IS_CHAR(arg)) {
- REBSER *ser = Make_Binary(6);
- ser->tail = xEncode_UTF8_Char(BIN_HEAD(ser), VAL_CHAR(arg));
- for (len = 0; len < (signed)(ser->tail); len++)
- buf = Form_Hex2(buf, *BIN_SKIP(ser, len));
- len = ser->tail * 2;
- //Form_Hex_Pad(buf, VAL_CHAR(arg), len);
- }
- else if (IS_MONEY(arg)) {
- REBYTE tmp[12];
- deci_to_binary(&tmp[0], VAL_DECI(arg));
- for (len = 0; len < 12; len++)
- buf = Form_Hex2(buf, tmp[len]);
- len = 24;
- }
-#endif
+ return b_cast(strncpy(s_cast(dest), cs_cast(src), count));
+}
-// SERIES_TAIL(series) = len;
-// Set_Series(REB_ISSUE, D_RET, series);
- Init_Word(D_RET, Scan_Issue(&buffer[0], len));
- VAL_SET(D_RET, REB_ISSUE);
- return R_RET;
+//
+// LEN_BYTES_: C
+//
+// Debug-only REBYTE-checked substitute for LEN_BYTES macro
+// If you meant characters, consider if you wanted strlen()
+//
+size_t LEN_BYTES_(const REBYTE *str)
+{
+ return strlen(cs_cast(str));
}
-/***********************************************************************
-**
-*/ REBNATIVE(find_script)
-/*
-***********************************************************************/
+//
+// COMPARE_BYTES_: C
+//
+// Debug-only REBYTE-checked function for COMPARE_BYTES macro
+// If you meant characters, consider if you wanted strcmp()
+//
+int COMPARE_BYTES_(const REBYTE *lhs, const REBYTE *rhs)
{
- REBVAL *arg = D_ARG(1);
- REBINT n;
+ return strcmp(cs_cast(lhs), cs_cast(rhs));
+}
- n = What_UTF(VAL_BIN_DATA(arg), VAL_LEN(arg));
- if (n != 0 && n != 8) return R_NONE; // UTF8 only
+//
+// APPEND_BYTES_LIMIT_: C
+//
+// REBYTE-checked function for APPEND_BYTES_LIMIT macro in Debug
+// If you meant characters, you'll have to use strncat()/strlen()
+// (there's no single entry point for this purpose)
+//
+REBYTE *APPEND_BYTES_LIMIT_(REBYTE *dest, const REBYTE *src, size_t max)
+{
+ return b_cast(strncat(
+ s_cast(dest), cs_cast(src), MAX(max - LEN_BYTES(dest) - 1, 0)
+ ));
+}
- if (n == 8) VAL_INDEX(arg) += 3; // BOM8 length
- n = Scan_Header(VAL_BIN_DATA(arg), VAL_LEN(arg)); // returns offset
+//
+// OS_STRNCPY_: C
+//
+// Debug-only REBCHR-checked substitute for OS_STRNCPY macro
+//
+REBCHR *OS_STRNCPY_(REBCHR *dest, const REBCHR *src, size_t count)
+{
+#ifdef OS_WIDE_CHAR
+ return cast(REBCHR*,
+ wcsncpy(cast(wchar_t*, dest), cast(const wchar_t*, src), count)
+ );
+#else
+ #ifdef TO_OPENBSD
+ return cast(REBCHR*,
+ strlcpy(cast(char*, dest), cast(const char*, src), count)
+ );
+ #else
+ return cast(REBCHR*,
+ strncpy(cast(char*, dest), cast(const char*, src), count)
+ );
+ #endif
+#endif
+}
+
- if (n == -1) return R_NONE;
+//
+// OS_STRNCAT_: C
+//
+// Debug-only REBCHR-checked function for OS_STRNCAT macro
+//
+REBCHR *OS_STRNCAT_(REBCHR *dest, const REBCHR *src, size_t max)
+{
+#ifdef OS_WIDE_CHAR
+ return cast(REBCHR*,
+ wcsncat(cast(wchar_t*, dest), cast(const wchar_t*, src), max)
+ );
+#else
+ #ifdef TO_OPENBSD
+ return cast(REBCHR*,
+ strlcat(cast(char*, dest), cast(const char*, src), max)
+ );
+ #else
+ return cast(REBCHR*,
+ strncat(cast(char*, dest), cast(const char*, src), max)
+ );
+ #endif
+#endif
+}
- VAL_INDEX(arg) += n;
- return R_ARG1;
+//
+// OS_STRNCMP_: C
+//
+// Debug-only REBCHR-checked substitute for OS_STRNCMP macro
+//
+int OS_STRNCMP_(const REBCHR *lhs, const REBCHR *rhs, size_t max)
+{
+#ifdef OS_WIDE_CHAR
+ return wcsncmp(cast(const wchar_t*, lhs), cast(const wchar_t*, rhs), max);
+#else
+ return strncmp(cast(const char*, lhs), cast (const char*, rhs), max);
+#endif
}
-/***********************************************************************
-**
-*/ REBNATIVE(utfq)
-/*
-***********************************************************************/
+//
+// OS_STRLEN_: C
+//
+// Debug-only REBCHR-checked substitute for OS_STRLEN macro
+//
+size_t OS_STRLEN_(const REBCHR *str)
{
- REBINT utf = What_UTF(VAL_BIN_DATA(D_ARG(1)), VAL_LEN(D_ARG(1)));
- DS_RET_INT(utf);
- return R_RET;
+#ifdef OS_WIDE_CHAR
+ return wcslen(cast(const wchar_t*, str));
+#else
+ return strlen(cast(const char*, str));
+#endif
}
-/***********************************************************************
-**
-*/ REBNATIVE(invalid_utfq)
-/*
-***********************************************************************/
+//
+// OS_STRCHR_: C
+//
+// Debug-only REBCHR-checked function for OS_STRCHR macro
+//
+REBCHR *OS_STRCHR_(const REBCHR *str, REBCNT ch)
{
- REBVAL *arg = D_ARG(1);
- REBYTE *bp;
+ // We have to m_cast because C++ actually has a separate overloads of
+ // wcschr and strchr which will return a const pointer if the in pointer
+ // was const.
+#ifdef OS_WIDE_CHAR
+ return cast(REBCHR*,
+ m_cast(wchar_t*, wcschr(cast(const wchar_t*, str), ch))
+ );
+#else
+ return cast(REBCHR*,
+ m_cast(char*, strchr(cast(const char*, str), ch))
+ );
+#endif
+}
- bp = Check_UTF8(VAL_BIN_DATA(arg), VAL_LEN(arg));
- if (bp == 0) return R_NONE;
- VAL_INDEX(arg) = bp - VAL_BIN_HEAD(arg);
- return R_ARG1;
+//
+// OS_MAKE_CH_: C
+//
+// Debug-only REBCHR-checked function for OS_MAKE_CH macro
+//
+REBCHR OS_MAKE_CH_(REBCNT ch)
+{
+ REBCHR result;
+ result.num = ch;
+ return result;
}
+
+#endif
diff --git a/src/core/n-system.c b/src/core/n-system.c
index 624d5ba7e6..3b11dc7fa4 100644
--- a/src/core/n-system.c
+++ b/src/core/n-system.c
@@ -1,498 +1,428 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: n-system.c
-** Summary: native functions for system operations
-** Section: natives
-** Author: Carl Sassenrath
-** Notes:
-** GC WARNING: Do not cache pointer to stack ARGS (stack may expand).
-**
-***********************************************************************/
+//
+// File: %n-system.c
+// Summary: "native functions for system operations"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ REBNATIVE(halt)
-/*
-***********************************************************************/
+//
+// halt: native [
+//
+// "Stops evaluation and returns to the input prompt."
+//
+// ; No arguments
+// ]
+//
+REBNATIVE(halt)
{
- Halt_Code(RE_HALT, 0);
- DEAD_END;
+ UNUSED(frame_);
+ fail (VAL_CONTEXT(TASK_HALT_ERROR));
}
-/***********************************************************************
-**
-*/ REBNATIVE(quit)
-/*
-** 1: /return
-** 2: value
-** 3: /now
-**
-***********************************************************************/
+//
+// quit: native [
+//
+// {Stop evaluating and return control to command shell or calling script.}
+//
+// /with
+// {Yield a result (mapped to an integer if given to shell)}
+// value [any-value!]
+// "See: http://en.wikipedia.org/wiki/Exit_status"
+// ]
+//
+REBNATIVE(quit)
+//
+// QUIT is implemented via a THROWN() value that bubbles up through
+// the stack. It uses the value of its own native function as the
+// name of the throw, like `throw/name value :quit`.
{
- REBVAL *val = D_ARG(2);
-
- if (D_REF(3)) {
- REBINT n = 0;
- if (D_REF(1)) {
- if (IS_INTEGER(val)) n = Int32(val);
- else if (IS_TRUE(val)) n = 100;
- }
- OS_EXIT(n);
- }
-
- Halt_Code(RE_QUIT, val); // NONE if /return not set
- DEAD_END;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(recycle)
-/*
-***********************************************************************/
-{
- REBCNT count;
-
- if (D_REF(1)) { // /off
- GC_Active = FALSE;
- return R_UNSET;
- }
+ INCLUDE_PARAMS_OF_QUIT;
- if (D_REF(2)) {// /on
- GC_Active = TRUE;
- SET_INT32(TASK_BALLAST, VAL_INT32(TASK_MAX_BALLAST));
- }
+ Move_Value(D_OUT, NAT_VALUE(quit));
- if (D_REF(3)) {// /ballast
- *TASK_MAX_BALLAST = *D_ARG(4);
- SET_INT32(TASK_BALLAST, VAL_INT32(TASK_MAX_BALLAST));
- }
+ if (REF(with))
+ CONVERT_NAME_TO_THROWN(D_OUT, ARG(value));
+ else {
+ // Chosen to do it this way because returning to a calling script it
+ // will be no value by default, for parity with BREAK and EXIT without
+ // a /WITH. Long view would have RETURN work this way too: CC#2241
- if (D_REF(5)) { // torture
- GC_Active = TRUE;
- SET_INT32(TASK_BALLAST, 0);
- }
+ // void translated to 0 if it gets caught for the shell, see #2241
- count = Recycle();
+ CONVERT_NAME_TO_THROWN(D_OUT, VOID_CELL);
+ }
- DS_Ret_Int(count);
- return R_RET;
+ return R_OUT_IS_THROWN;
}
-/***********************************************************************
-**
-*/ REBNATIVE(stats)
-/*
-***********************************************************************/
+//
+// exit-rebol: native [
+//
+// {Stop the current Rebol interpreter, cannot be caught by CATCH/QUIT.}
+//
+// /with
+// {Yield a result (mapped to an integer if given to shell)}
+// value [any-value!]
+// "See: http://en.wikipedia.org/wiki/Exit_status"
+// ]
+//
+REBNATIVE(exit_rebol)
{
- REBI64 n;
- REBCNT flags = 0;
- REBVAL *stats;
-
- if (D_REF(3)) {
- VAL_TIME(ds) = OS_DELTA_TIME(PG_Boot_Time, 0) * 1000;
- VAL_SET(ds, REB_TIME);
- return R_RET;
- }
-
- if (D_REF(4)) {
- n = Eval_Cycles + Eval_Dose - Eval_Count;
- SET_INTEGER(ds, n);
- return R_RET;
- }
-
- if (D_REF(2)) {
- stats = Get_System(SYS_STANDARD, STD_STATS);
- *ds = *stats;
- if (IS_OBJECT(stats)) {
- stats = Get_Object(stats, 1);
-
- VAL_TIME(stats) = OS_DELTA_TIME(PG_Boot_Time, 0) * 1000;
- VAL_SET(stats, REB_TIME);
- stats++;
- SET_INTEGER(stats, Eval_Cycles + Eval_Dose - Eval_Count);
- stats++;
- SET_INTEGER(stats, Eval_Natives);
- stats++;
- SET_INTEGER(stats, Eval_Functions);
-
- stats++;
- SET_INTEGER(stats, PG_Reb_Stats->Series_Made);
- stats++;
- SET_INTEGER(stats, PG_Reb_Stats->Series_Freed);
- stats++;
- SET_INTEGER(stats, PG_Reb_Stats->Series_Expanded);
- stats++;
- SET_INTEGER(stats, PG_Reb_Stats->Series_Memory);
- stats++;
- SET_INTEGER(stats, PG_Reb_Stats->Recycle_Series_Total);
-
- stats++;
- SET_INTEGER(stats, PG_Reb_Stats->Blocks);
- stats++;
- SET_INTEGER(stats, PG_Reb_Stats->Objects);
-
- stats++;
- SET_INTEGER(stats, PG_Reb_Stats->Recycle_Counter);
- }
- return R_RET;
- }
-
- if (D_REF(1)) flags = 3;
- n = Inspect_Series(flags);
-
- DS_RET_INT(n);
-
- return R_RET;
-}
+ INCLUDE_PARAMS_OF_EXIT_REBOL;
-REBYTE *evoke_help = "Evoke values:\n"
- "[stack-size n] crash-dump delect\n"
- "watch-recycle watch-obj-copy crash\n"
- "1: watch expand\n"
- "2: check memory pools\n"
- "3: check bind table\n"
-;
-
-/***********************************************************************
-**
-*/ REBNATIVE(evoke)
-/*
-***********************************************************************/
-{
- REBVAL *arg = D_ARG(1);
- REBCNT len;
-
- Check_Security(SYM_DEBUG, POL_READ, 0);
-
- if (IS_BLOCK(arg)) {
- len = VAL_LEN(arg);
- arg = VAL_BLK_DATA(arg);
- }
- else len = 1;
-
- for (; len > 0; len--, arg++) {
- if (IS_WORD(arg)) {
- switch (VAL_WORD_CANON(arg)) {
- case SYM_DELECT:
- Trace_Delect(1);
- break;
- case SYM_CRASH_DUMP:
- Reb_Opts->crash_dump = TRUE;
- break;
- case SYM_WATCH_RECYCLE:
- Reb_Opts->watch_recycle = !Reb_Opts->watch_recycle;
- break;
- case SYM_WATCH_OBJ_COPY:
- Reb_Opts->watch_obj_copy = !Reb_Opts->watch_obj_copy;
- break;
- case SYM_STACK_SIZE:
- arg++;
- Expand_Stack(Int32s(arg, 1));
- break;
- case SYM_CRASH:
- Crash(9999);
- break;
- default:
- Out_Str(evoke_help, 1);
- }
- }
- if (IS_INTEGER(arg)) {
- switch (Int32(arg)) {
- case 0:
- Check_Memory();
- Check_Bind_Table();
- break;
- case 1:
- Reb_Opts->watch_expand = TRUE;
- break;
- case 2:
- Check_Memory();
- break;
- case 3:
- Check_Bind_Table();
- break;
- default:
- Out_Str(evoke_help, 1);
- }
- }
- }
-
- return R_UNSET;
-}
+ int code;
+ if (REF(with))
+ code = VAL_INT32(ARG(value));
+ else
+ code = EXIT_SUCCESS;
-#ifdef NOT_USED
-/***********************************************************************
-**
-*/ REBNATIVE(in_context)
-/*
-***********************************************************************/
-{
- REBVAL *value;
- value = D_ARG(1);
- VAL_OBJ_FRAME(ROOT_USER_CONTEXT) = VAL_OBJ_FRAME(value);
- return R_UNSET;
+ exit(code);
}
-#endif
-/***********************************************************************
-**
-*/ REBNATIVE(limit_usage)
-/*
-***********************************************************************/
-{
- REBCNT sym;
- sym = VAL_WORD_CANON(D_ARG(1));
-
- // Only gets set once:
- if (sym == SYM_EVAL) {
- if (Eval_Limit == 0) Eval_Limit = Int64(D_ARG(2));
- } else if (sym == SYM_MEMORY) {
- if (PG_Mem_Limit == 0) PG_Mem_Limit = Int64(D_ARG(2));
- }
- return R_UNSET;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(stack)
-/*
-** stack: native [
-** {Returns stack backtrace or other values.}
-** offset [integer!] "Relative backward offset"
-** /block "Block evaluation position"
-** /word "Function or object name, if known"
-** /func "Function value"
-** /args "Block of args (may be modified)"
-** /size "Current stack size (in value units)"
-** /depth "Stack depth (frames)"
-** /limit "Stack bounds (auto expanding)"
-** ]
-**
-***********************************************************************/
+//
+// recycle: native [
+//
+// "Recycles unused memory."
+//
+// return: [ integer!]
+// {Number of series nodes recycled (if applicable)}
+// /off
+// "Disable auto-recycling"
+// /on
+// "Enable auto-recycling"
+// /ballast
+// "Trigger for auto-recycle (memory used)"
+// size [integer!]
+// /torture
+// "Constant recycle (for internal debugging)"
+// /verbose
+// "Dump out information about series being recycled"
+// ]
+//
+REBNATIVE(recycle)
{
- REBINT index = VAL_INT32(D_ARG(1));
- REBVAL *sp;
- REBCNT len;
-
- Check_Security(SYM_DEBUG, POL_READ, 0);
-
- sp = Stack_Frame(index);
- if (!sp) return R_NONE;
-
- if (D_REF(2)) *D_RET = sp[1]; // block
- else if (D_REF(3)) Init_Word(D_RET, VAL_WORD_SYM(sp+2)); // word
- else if (D_REF(4)) *D_RET = sp[3]; // func
- else if (D_REF(5)) { // args
- len = 0;
- if (ANY_FUNC(sp+3)) len = VAL_FUNC_ARGC(sp+3)-1;
- sp += 4;
- Set_Block(D_RET, Copy_Values(sp, len));
- }
- else if (D_REF(6)) { // size
- SET_INTEGER(D_RET, DSP+1);
- }
- else if (D_REF(7)) { // depth
- SET_INTEGER(D_RET, Stack_Depth());
- }
- else if (D_REF(8)) { // limit
- SET_INTEGER(D_RET, SERIES_REST(DS_Series) + SERIES_BIAS(DS_Series));
- }
- else {
- Set_Block(D_RET, Make_Backtrace(index));
- }
-
- return R_RET;
+ INCLUDE_PARAMS_OF_RECYCLE;
+
+ if (REF(off)) {
+ GC_Disabled = TRUE;
+ return R_VOID;
+ }
+
+ if (REF(on)) {
+ GC_Disabled = FALSE;
+ VAL_INT64(TASK_BALLAST) = VAL_INT32(TASK_MAX_BALLAST);
+ }
+
+ if (REF(ballast)) {
+ Move_Value(TASK_MAX_BALLAST, ARG(size));
+ VAL_INT64(TASK_BALLAST) = VAL_INT32(TASK_MAX_BALLAST);
+ }
+
+ if (REF(torture)) {
+ GC_Disabled = TRUE;
+ VAL_INT64(TASK_BALLAST) = 0;
+ }
+
+ if (GC_Disabled)
+ return R_VOID; // don't give back misleading "0", since no recycle ran
+
+ REBCNT count;
+
+ if (REF(verbose)) {
+ #if defined(NDEBUG)
+ fail (Error_Debug_Only_Raw());
+ #else
+ REBSER *sweeplist = Make_Series(100, sizeof(REBNOD*));
+ count = Recycle_Core(FALSE, sweeplist);
+ assert(count == SER_LEN(sweeplist));
+
+ REBCNT index = 0;
+ for (index = 0; index < count; ++index) {
+ REBNOD *node = *SER_AT(REBNOD*, sweeplist, index);
+ PROBE(node);
+ }
+
+ Free_Series(sweeplist);
+
+ REBCNT recount = Recycle_Core(FALSE, NULL);
+ assert(recount == count);
+ #endif
+ }
+ else {
+ count = Recycle();
+ }
+
+ Init_Integer(D_OUT, count);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBNATIVE(check)
-/*
-***********************************************************************/
+//
+// stats: native [
+//
+// {Provides status and statistics information about the interpreter.}
+//
+// /show
+// "Print formatted results to console"
+// /profile
+// "Returns profiler object"
+// /timer
+// "High resolution time difference from start"
+// /evals
+// "Number of values evaluated by interpreter"
+// /dump-series
+// "Dump all series in pool"
+// pool-id [integer!]
+// "-1 for all pools"
+// ]
+//
+REBNATIVE(stats)
{
- REBVAL *val;
- REBSER *ser;
- REBCNT n;
-
- ser = VAL_SERIES(val = D_ARG(1));
- *D_RET = *val;
-
- if (ANY_BLOCK(val)) {
- for (n = 0; n < SERIES_TAIL(ser); n++) {
- if (IS_END(BLK_SKIP(ser, n))) goto err;
- }
- if (!IS_END(BLK_SKIP(ser, n))) goto err;
- }
- else {
- for (n = 0; n < SERIES_TAIL(ser); n++) {
- if (!*STR_SKIP(ser, n)) goto err;
- }
- if (*STR_SKIP(ser, n)) goto err;
- }
- return R_RET;
-err:
- Trap0(RE_BAD_SERIES);
- DEAD_END;
+ INCLUDE_PARAMS_OF_STATS;
+
+ if (REF(timer)) {
+ VAL_RESET_HEADER(D_OUT, REB_TIME);
+ VAL_NANO(D_OUT) = OS_DELTA_TIME(PG_Boot_Time, 0) * 1000;
+ return R_OUT;
+ }
+
+ if (REF(evals)) {
+ REBI64 n = Eval_Cycles + Eval_Dose - Eval_Count;
+ Init_Integer(D_OUT, n);
+ return R_OUT;
+ }
+
+#ifdef NDEBUG
+ UNUSED(REF(show));
+ UNUSED(REF(profile));
+ UNUSED(REF(dump_series));
+ UNUSED(ARG(pool_id));
+
+ fail (Error_Debug_Only_Raw());
+#else
+ if (REF(profile)) {
+ Move_Value(D_OUT, Get_System(SYS_STANDARD, STD_STATS));
+ if (IS_OBJECT(D_OUT)) {
+ REBVAL *stats = VAL_CONTEXT_VAR(D_OUT, 1);
+
+ VAL_RESET_HEADER(stats, REB_TIME);
+ VAL_NANO(stats) = OS_DELTA_TIME(PG_Boot_Time, 0) * 1000;
+ stats++;
+ Init_Integer(stats, Eval_Cycles + Eval_Dose - Eval_Count);
+ stats++;
+ Init_Integer(stats, 0); // no such thing as natives, only functions
+ stats++;
+ Init_Integer(stats, Eval_Functions);
+
+ stats++;
+ Init_Integer(stats, PG_Reb_Stats->Series_Made);
+ stats++;
+ Init_Integer(stats, PG_Reb_Stats->Series_Freed);
+ stats++;
+ Init_Integer(stats, PG_Reb_Stats->Series_Expanded);
+ stats++;
+ Init_Integer(stats, PG_Reb_Stats->Series_Memory);
+ stats++;
+ Init_Integer(stats, PG_Reb_Stats->Recycle_Series_Total);
+
+ stats++;
+ Init_Integer(stats, PG_Reb_Stats->Blocks);
+ stats++;
+ Init_Integer(stats, PG_Reb_Stats->Objects);
+
+ stats++;
+ Init_Integer(stats, PG_Reb_Stats->Recycle_Counter);
+ }
+
+ return R_OUT;
+ }
+
+ if (REF(dump_series)) {
+ REBVAL *pool_id = ARG(pool_id);
+ Dump_Series_In_Pool(VAL_INT32(pool_id));
+ return R_BLANK;
+ }
+
+ Init_Integer(D_OUT, Inspect_Series(REF(show)));
+
+ if (REF(show))
+ Dump_Pools();
+
+ return R_OUT;
+#endif
}
-/***********************************************************************
-**
-*/ REBNATIVE(ds)
-/*
-***********************************************************************/
+//
+// evoke: native [
+//
+// "Special guru meditations. (Not for beginners.)"
+//
+// chant [word! block! integer!]
+// "Single or block of words ('? to list)"
+// ]
+//
+REBNATIVE(evoke)
{
- Dump_Stack(0, 0);
- return R_UNSET;
-
- Dump_All(sizeof(REBVAL));
- return R_RET;
+ INCLUDE_PARAMS_OF_EVOKE;
+
+#ifdef NDEBUG
+ UNUSED(ARG(chant));
+
+ fail (Error_Debug_Only_Raw());
+#else
+ RELVAL *arg = ARG(chant);
+ REBCNT len;
+
+ Check_Security(Canon(SYM_DEBUG), POL_READ, 0);
+
+ if (IS_BLOCK(arg)) {
+ len = VAL_LEN_AT(arg);
+ arg = VAL_ARRAY_AT(arg);
+ }
+ else len = 1;
+
+ for (; len > 0; len--, arg++) {
+ if (IS_WORD(arg)) {
+ switch (VAL_WORD_SYM(arg)) {
+ case SYM_CRASH_DUMP:
+ Reb_Opts->crash_dump = TRUE;
+ break;
+
+ case SYM_WATCH_RECYCLE:
+ Reb_Opts->watch_recycle = NOT(Reb_Opts->watch_recycle);
+ break;
+
+ case SYM_CRASH:
+ panic ("evoke 'crash was executed");
+
+ default:
+ Debug_Fmt(RM_EVOKE_HELP);
+ }
+ }
+ if (IS_INTEGER(arg)) {
+ switch (Int32(arg)) {
+ case 0:
+ Check_Memory_Debug();
+ break;
+
+ case 1:
+ Reb_Opts->watch_expand = TRUE;
+ break;
+
+ default:
+ Debug_Fmt(RM_EVOKE_HELP);
+ }
+ }
+ }
+
+ return R_VOID;
+#endif
}
-/***********************************************************************
-**
-*/ REBNATIVE(do_codec)
-/*
-** Calls a codec handle with specific data:
-**
-** Args:
-** 1: codec: handle!
-** 2: action: word! (identify, decode, encode)
-** 3: data: binary! image! sound!
-** 4: option: (optional)
-**
-***********************************************************************/
+//
+// limit-usage: native [
+//
+// "Set a usage limit only once (used for SECURE)."
+//
+// field [word!]
+// "eval (count) or memory (bytes)"
+// limit [any-number!]
+// ]
+//
+REBNATIVE(limit_usage)
{
- REBCDI codi;
- REBVAL *val;
- REBINT result;
- REBSER *ser;
-
- CLEAR(&codi, sizeof(codi));
-
- codi.action = CODI_DECODE;
-
- val = D_ARG(3);
-
- switch (VAL_WORD_SYM(D_ARG(2))) {
-
- case SYM_IDENTIFY:
- codi.action = CODI_IDENTIFY;
- case SYM_DECODE:
- if (!IS_BINARY(val)) Trap1(RE_INVALID_ARG, val);
- codi.data = VAL_BIN_DATA(D_ARG(3));
- codi.len = VAL_LEN(D_ARG(3));
- break;
-
- case SYM_ENCODE:
- codi.action = CODI_ENCODE;
- if (IS_IMAGE(val)) {
- codi.bits = VAL_IMAGE_BITS(val);
- codi.w = VAL_IMAGE_WIDE(val);
- codi.h = VAL_IMAGE_HIGH(val);
- codi.alpha = Image_Has_Alpha(val, 0);
- }
- else
- Trap1(RE_INVALID_ARG, val);
- break;
-
- default:
- Trap1(RE_INVALID_ARG, D_ARG(2));
- }
-
- // Nasty alias, but it must be done:
- // !!! add a check to validate the handle as a codec!!!!
- result = ((codo) (VAL_HANDLE(D_ARG(1))))(&codi);
-
- if (codi.error != 0) {
- if (result == CODI_CHECK) return R_FALSE;
- Trap0(RE_BAD_MEDIA); // need better!!!
- }
-
- switch (result) {
-
- case CODI_CHECK:
- return R_TRUE;
-
- case CODI_BINARY: //used on encode
- case CODI_TEXT: //used on decode
- ser = Make_Binary(codi.len);
- ser->tail = codi.len;
- memcpy(BIN_HEAD(ser), codi.data, codi.len);
- Set_Binary(D_RET, ser);
- if (result != CODI_BINARY) VAL_SET(D_RET, REB_STRING);
-
- //don't free the text binary input buffer during decode (it's the 3rd arg value in fact)
- if (result == CODI_BINARY)
- // See notice in reb-codec.h on reb_codec_image
- Free_Mem(codi.data, codi.len);
- break;
-
- case CODI_IMAGE: //used on decode
- ser = Make_Image(codi.w, codi.h, TRUE); // Puts it into RETURN stack position
- memcpy(IMG_DATA(ser), codi.bits, codi.w * codi.h * 4);
- SET_IMAGE(D_RET, ser);
-
- // See notice in reb-codec.h on reb_codec_image
- Free_Mem(codi.bits, codi.w * codi.h * 4);
- break;
-
- case CODI_BLOCK:
- Set_Block(D_RET, codi.other);
- break;
-
- default:
- Trap0(RE_BAD_MEDIA); // need better!!!
- }
-
- return R_RET;
+ INCLUDE_PARAMS_OF_LIMIT_USAGE;
+
+ REBSYM sym = VAL_WORD_SYM(ARG(field));
+
+ // !!! comment said "Only gets set once"...why?
+ //
+ if (sym == SYM_EVAL) {
+ if (Eval_Limit == 0)
+ Eval_Limit = Int64(ARG(limit));
+ }
+ else if (sym == SYM_MEMORY) {
+ if (PG_Mem_Limit == 0)
+ PG_Mem_Limit = Int64(ARG(limit));
+ }
+ else
+ fail (ARG(field));
+
+ return R_VOID;
}
-/***********************************************************************
-**
-*/ REBNATIVE(selflessq)
-/*
-***********************************************************************/
+//
+// check: native [
+//
+// "Run an integrity check on a value in debug builds of the interpreter"
+//
+// value [ any-value!]
+// {System will terminate abnormally if this value is corrupt.}
+// ]
+//
+REBNATIVE(check)
+//
+// This forces an integrity check to run on a series. In R3-Alpha there was
+// no debug build, so this was a simple validity check and it returned an
+// error on not passing. But Ren-C is designed to have a debug build with
+// checks that aren't designed to fail gracefully. So this just runs that
+// assert rather than replicating code here that can "tolerate" a bad series.
+// Review the necessity of this native.
{
- REBVAL *val = D_ARG(1);
- REBSER *frm;
-
- if (ANY_WORD(val)) {
- if (VAL_WORD_INDEX(val) < 0) return R_TRUE;
- frm = VAL_WORD_FRAME(val);
- if (!frm) Trap1(RE_NOT_DEFINED, val);
- }
- else frm = VAL_OBJ_FRAME(D_ARG(1));
-
- return IS_SELFLESS(frm) ? R_TRUE : R_FALSE;
+ INCLUDE_PARAMS_OF_CHECK;
+
+#ifdef NDEBUG
+ UNUSED(ARG(value));
+
+ fail (Error_Debug_Only_Raw());
+#else
+ REBVAL *value = ARG(value);
+
+ // !!! Should call generic ASSERT_VALUE macro with more cases
+ //
+ if (ANY_SERIES(value)) {
+ ASSERT_SERIES(VAL_SERIES(value));
+ }
+ else if (ANY_CONTEXT(value)) {
+ ASSERT_CONTEXT(VAL_CONTEXT(value));
+ }
+ else if (IS_FUNCTION(value)) {
+ ASSERT_ARRAY(VAL_FUNC_PARAMLIST(value));
+ ASSERT_ARRAY(VAL_ARRAY(VAL_FUNC_BODY(value)));
+ }
+
+ return R_TRUE;
+#endif
}
diff --git a/src/core/n-textcodecs.c b/src/core/n-textcodecs.c
new file mode 100644
index 0000000000..82272cf545
--- /dev/null
+++ b/src/core/n-textcodecs.c
@@ -0,0 +1,356 @@
+//
+// File: %n-textcodec.c
+// Summary: "Native text codecs"
+// Section: natives
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// R3-Alpha had an incomplete model for doing codecs, that required C coding
+// to implement...even though the input and output types to DO-CODEC were
+// Rebol values. Under Ren-C these are done as plain FUNCTION!s, which can
+// be coded in either C as natives or Rebol.
+//
+// A few text codecs were included in R3-Alpha and kept for testing. They
+// were converted here into groups of native functions, but should be further
+// moved into an extension so they can be optional in the build.
+//
+
+#include "sys-core.h"
+
+
+//
+// identify-text?: native [
+//
+// {Codec for identifying BINARY! data for a .TXT file}
+//
+// return: [logic!]
+// data [binary!]
+// ]
+//
+REBNATIVE(identify_text_q)
+{
+ INCLUDE_PARAMS_OF_IDENTIFY_TEXT_Q;
+
+ UNUSED(ARG(data)); // see notes on decode-text
+
+ return R_TRUE;
+}
+
+
+//
+// decode-text: native [
+//
+// {Codec for decoding BINARY! data for a .TXT file}
+//
+// return: [string!]
+// data [binary!]
+// ]
+//
+REBNATIVE(decode_text)
+{
+ INCLUDE_PARAMS_OF_DECODE_TEXT;
+
+ // !!! The original code for R3-Alpha would simply alias the incoming
+ // binary as a string. This is essentially a Latin1 interpretation.
+ // For the moment that behavior is preserved, but what is *not* preserved
+ // is the idea of reusing the BINARY!--a copy is made.
+ //
+ // A more "intelligent" codec would do some kind of detection here, to
+ // figure out what format the text file was in. While Ren-C's commitment
+ // is to UTF-8 for source code, a .TXT file is a different beast, so
+ // having wider format support might be a good thing.
+
+ Init_String(D_OUT, Copy_Sequence_At_Position(ARG(data)));
+ return R_OUT;
+}
+
+
+//
+// encode-text: native [
+//
+// {Codec for encoding a .TXT file}
+//
+// return: [binary!]
+// string [string!]
+// ]
+//
+REBNATIVE(encode_text)
+{
+ INCLUDE_PARAMS_OF_ENCODE_TEXT;
+
+ if (NOT(VAL_BYTE_SIZE(ARG(string)))) {
+ //
+ // For the moment, only write out strings to .txt if they are Latin1.
+ // (Other support was unimplemented in R3-Alpha, and would just wind
+ // up writing garbage.)
+ //
+ fail ("Can only write out strings to .txt if they are Latin1.");
+ }
+
+ Init_Binary(D_OUT, Copy_Sequence_At_Position(ARG(string)));
+ return R_OUT;
+}
+
+
+static void Encode_Utf16_Core(
+ REBVAL *out,
+ const void *data, // may be REBYTE* or REBUNI*, depending on width
+ REBCNT len,
+ REBYTE wide,
+ REBOOL little_endian
+){
+ REBSER *bin = Make_Binary(sizeof(u16) * len);
+ u16* up = cast(u16*, BIN_HEAD(bin));
+
+ if (wide == 1) { // Latin1
+ REBCNT i = 0;
+ for (i = 0; i < len; i ++) {
+ #ifdef ENDIAN_LITTLE
+ if (little_endian) {
+ up[i] = cast(const char*, data)[i];
+ } else {
+ up[i] = cast(const char*, data)[i] << 8;
+ }
+ #elif defined (ENDIAN_BIG)
+ if (little_endian) {
+ up[i] = cast(const char*, data)[i] << 8;
+ } else {
+ up[i] = cast(const char*, data)[i];
+ }
+ #else
+ #error "Unsupported CPU endian"
+ #endif
+ }
+ }
+ else if (wide == 2) { // UCS2, which is close to UTF16 :-/
+ #ifdef ENDIAN_LITTLE
+ if (little_endian) {
+ memcpy(up, data, len * sizeof(u16));
+ } else {
+ REBCNT i = 0;
+ for (i = 0; i < len; i ++) {
+ REBUNI uni = cast(const REBUNI*, data)[i];
+ up[i] = ((uni & 0xff) << 8) | ((uni & 0xff00) >> 8);
+ }
+ }
+ #elif defined (ENDIAN_BIG)
+ if (little_endian) {
+ REBCNT i = 0;
+ for (i = 0; i < len; i ++) {
+ REBUNI uni = cast(const REBUNI*, data)[i];
+ up[i] = ((uni & 0xff) << 8) | ((uni & 0xff00) >> 8);
+ }
+ } else {
+ memcpy(up, data, len * sizeof(u16));
+ }
+ #else
+ #error "Unsupported CPU endian"
+ #endif
+ }
+ else {
+ fail ("Unicode width > 2 reserved for future expansion.");
+ }
+
+ TERM_BIN_LEN(bin, len * sizeof(u16));
+ Init_Binary(out, bin);
+}
+
+
+static void Decode_Utf16_Core(
+ REBVAL *out,
+ const REBYTE *data,
+ REBCNT len,
+ REBOOL little_endian
+){
+ REBSER *ser = Make_Unicode(len); // 2x too big (?)
+
+ REBINT size = Decode_UTF16(
+ UNI_HEAD(ser), data, len, little_endian, FALSE
+ );
+ SET_SERIES_LEN(ser, size);
+
+ if (size < 0) { // ASCII
+ size = -size;
+
+ REBSER *dst = Make_Binary(size);
+ Append_Uni_Bytes(dst, UNI_HEAD(ser), size);
+ Free_Series(ser);
+
+ ser = dst;
+ }
+
+ Init_String(out, ser);
+}
+
+
+//
+// identify-utf16le?: native [
+//
+// {Codec for identifying BINARY! data for a little-endian UTF16 file}
+//
+// return: [logic!]
+// data [binary!]
+// ]
+//
+REBNATIVE(identify_utf16le_q)
+{
+ INCLUDE_PARAMS_OF_IDENTIFY_UTF16LE_Q;
+
+ UNUSED(ARG(data)); // R3-Alpha just said it matched if extension matched
+
+ return R_TRUE;
+}
+
+
+//
+// decode-utf16le: native [
+//
+// {Codec for decoding BINARY! data for a little-endian UTF16 file}
+//
+// return: [string!]
+// data [binary!]
+// ]
+//
+REBNATIVE(decode_utf16le)
+{
+ INCLUDE_PARAMS_OF_DECODE_UTF16LE;
+
+ REBYTE *data = VAL_BIN_AT(ARG(data));
+ REBCNT len = VAL_LEN_AT(ARG(data));
+
+ const REBOOL little_endian = TRUE;
+
+ Decode_Utf16_Core(D_OUT, data, len, little_endian);
+ return R_OUT;
+}
+
+
+//
+// encode-utf16le: native [
+//
+// {Codec for encoding a little-endian UTF16 file}
+//
+// return: [binary!]
+// string [string!]
+// ]
+//
+REBNATIVE(encode_utf16le)
+{
+ INCLUDE_PARAMS_OF_ENCODE_UTF16LE;
+
+ void *data;
+ REBYTE wide;
+ if (VAL_BYTE_SIZE(ARG(string))) {
+ data = VAL_BIN_AT(ARG(string));
+ wide = 1;
+ }
+ else {
+ data = VAL_UNI_AT(ARG(string));
+ wide = 2;
+ }
+
+ REBCNT len = VAL_LEN_AT(ARG(string));
+
+ const REBOOL little_endian = TRUE;
+
+ Encode_Utf16_Core(D_OUT, data, len, wide, little_endian);
+ return R_OUT;
+}
+
+
+
+//
+// identify-utf16be?: native [
+//
+// {Codec for identifying BINARY! data for a big-endian UTF16 file}
+//
+// return: [logic!]
+// data [binary!]
+// ]
+//
+REBNATIVE(identify_utf16be_q)
+{
+ INCLUDE_PARAMS_OF_IDENTIFY_UTF16BE_Q;
+
+ UNUSED(ARG(data)); // R3-Alpha just said it matched if extension matched
+
+ return R_TRUE;
+}
+
+
+//
+// decode-utf16be: native [
+//
+// {Codec for decoding BINARY! data for a big-endian UTF16 file}
+//
+// return: [string!]
+// data [binary!]
+// ]
+//
+REBNATIVE(decode_utf16be)
+{
+ INCLUDE_PARAMS_OF_DECODE_UTF16BE;
+
+ REBYTE *data = VAL_BIN_AT(ARG(data));
+ REBCNT len = VAL_LEN_AT(ARG(data));
+
+ const REBOOL little_endian = FALSE;
+
+ Decode_Utf16_Core(D_OUT, data, len, little_endian);
+ return R_OUT;
+}
+
+
+//
+// encode-utf16be: native [
+//
+// {Codec for encoding a big-endian UTF16 file}
+//
+// return: [binary!]
+// string [string!]
+// ]
+//
+REBNATIVE(encode_utf16be)
+{
+ INCLUDE_PARAMS_OF_ENCODE_UTF16BE;
+
+ void *data;
+ REBYTE wide;
+ if (VAL_BYTE_SIZE(ARG(string))) {
+ data = VAL_BIN_AT(ARG(string));
+ wide = 1;
+ }
+ else {
+ data = VAL_UNI_AT(ARG(string));
+ wide = 2;
+ }
+
+ REBCNT len = VAL_LEN_AT(ARG(string));
+
+ const REBOOL little_endian = FALSE;
+
+ Encode_Utf16_Core(D_OUT, data, len, wide, little_endian);
+ return R_OUT;
+}
diff --git a/src/core/p-clipboard.c b/src/core/p-clipboard.c
index 3ae6e995f5..f327b5e98e 100644
--- a/src/core/p-clipboard.c
+++ b/src/core/p-clipboard.c
@@ -1,159 +1,255 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: p-clipboard.c
-** Summary: clipboard port interface
-** Section: ports
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %p-clipboard.c
+// Summary: "clipboard port interface"
+// Section: ports
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ static int Clipboard_Actor(REBVAL *ds, REBSER *port, REBCNT action)
-/*
-***********************************************************************/
+//
+// Clipboard_Actor: C
+//
+static REB_R Clipboard_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
{
- REBREQ *req;
- REBINT result;
- REBVAL *arg;
- REBCNT refs; // refinement argument flags
- REBINT len;
- REBSER *ser;
-
- Validate_Port(port, action);
-
- arg = D_ARG(2);
-
- req = Use_Port_State(port, RDI_CLIPBOARD, sizeof(REBREQ));
-
- switch (action) {
-
- case A_READ:
- // This device is opened on the READ:
- if (!IS_OPEN(req)) {
- if (OS_DO_DEVICE(req, RDC_OPEN)) Trap_Port(RE_CANNOT_OPEN, port, req->error);
- }
- // Issue the read request:
- CLR_FLAG(req->flags, RRF_WIDE); // allow byte or wide chars
- result = OS_DO_DEVICE(req, RDC_READ);
- if (result < 0) Trap_Port(RE_READ_ERROR, port, req->error);
-
- // Copy and set the string result:
- arg = OFV(port, STD_PORT_DATA);
-
- // If wide, correct length:
- len = req->actual;
- if (GET_FLAG(req->flags, RRF_WIDE)) len /= sizeof(REBUNI);
-
- // Copy the string (convert to latin-8 if it fits):
- Set_String(arg, Copy_OS_Str(req->data, len));
-
- OS_FREE(req->data); // release the copy buffer
- req->data = 0;
- *D_RET = *arg;
- return R_RET;
-
- case A_WRITE:
- if (!IS_STRING(arg) && !IS_BINARY(arg)) Trap1(RE_INVALID_PORT_ARG, arg);
- // This device is opened on the WRITE:
- if (!IS_OPEN(req)) {
- if (OS_DO_DEVICE(req, RDC_OPEN)) Trap_Port(RE_CANNOT_OPEN, port, req->error);
- }
-
- refs = Find_Refines(ds, ALL_WRITE_REFS);
-
- // Handle /part refinement:
- len = VAL_LEN(arg);
- if (refs & AM_WRITE_PART && VAL_INT32(D_ARG(ARG_WRITE_LENGTH)) < len)
- len = VAL_INT32(D_ARG(ARG_WRITE_LENGTH));
-
- // If bytes, see if we can fit it:
- if (SERIES_WIDE(VAL_SERIES(arg)) == 1) {
+ REBINT result;
+ REBVAL *arg;
+ REBINT len;
+ REBSER *ser;
+
+ arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+
+ REBREQ *req = Ensure_Port_State(port, RDI_CLIPBOARD);
+
+ switch (action) {
+ case SYM_UPDATE:
+ // Update the port object after a READ or WRITE operation.
+ // This is normally called by the WAKE-UP function.
+ arg = CTX_VAR(port, STD_PORT_DATA);
+ if (req->command == RDC_READ) {
+ // this could be executed twice:
+ // once for an event READ, once for the CLOSE following the READ
+ if (!req->common.data) return R_BLANK;
+ len = req->actual;
+ if (GET_FLAG(req->flags, RRF_WIDE)) {
+ // convert to UTF8, so that it can be converted back to string!
+ Init_Binary(arg, Make_UTF8_Binary(
+ req->common.data,
+ len / sizeof(REBUNI),
+ 0,
+ OPT_ENC_UNISRC
+ ));
+ }
+ else {
+ REBSER *ser = Make_Binary(len);
+ memcpy(BIN_HEAD(ser), req->common.data, len);
+ SET_SERIES_LEN(ser, len);
+ Init_Binary(arg, ser);
+ }
+ OS_FREE(req->common.data); // release the copy buffer
+ req->common.data = 0;
+ }
+ else if (req->command == RDC_WRITE) {
+ Init_Blank(arg); // Write is done.
+ }
+ return R_BLANK;
+
+ case SYM_READ: {
+ INCLUDE_PARAMS_OF_READ;
+
+ UNUSED(PAR(source)); // already accounted for
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(seek)) {
+ UNUSED(ARG(index));
+ fail (Error_Bad_Refines_Raw());
+ }
+ UNUSED(PAR(string)); // handled in dispatcher
+ UNUSED(PAR(lines)); // handled in dispatcher
+
+ // This device is opened on the READ:
+ if (!IS_OPEN(req)) {
+ if (OS_DO_DEVICE(req, RDC_OPEN))
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, req->error));
+ }
+ // Issue the read request:
+ CLR_FLAG(req->flags, RRF_WIDE); // allow byte or wide chars
+ result = OS_DO_DEVICE(req, RDC_READ);
+ if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, req->error));
+ if (result > 0) return R_BLANK; /* pending */
+
+ // Copy and set the string result:
+ arg = CTX_VAR(port, STD_PORT_DATA);
+
+ len = req->actual;
+ if (GET_FLAG(req->flags, RRF_WIDE)) {
+ // convert to UTF8, so that it can be converted back to string!
+ Init_Binary(arg, Make_UTF8_Binary(
+ req->common.data,
+ len / sizeof(REBUNI),
+ 0,
+ OPT_ENC_UNISRC
+ ));
+ }
+ else {
+ REBSER *ser = Make_Binary(len);
+ memcpy(BIN_HEAD(ser), req->common.data, len);
+ SET_SERIES_LEN(ser, len);
+ Init_Binary(arg, ser);
+ }
+
+ Move_Value(D_OUT, arg);
+ return R_OUT; }
+
+ case SYM_WRITE: {
+ INCLUDE_PARAMS_OF_WRITE;
+
+ UNUSED(PAR(destination));
+ UNUSED(PAR(data)); // used as arg
+
+ if (REF(seek)) {
+ UNUSED(ARG(index));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(append))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(allow)) {
+ UNUSED(ARG(access));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(lines))
+ fail (Error_Bad_Refines_Raw());
+
+ if (!IS_STRING(arg) && !IS_BINARY(arg))
+ fail (Error_Invalid_Port_Arg_Raw(arg));
+
+ // This device is opened on the WRITE:
+ if (!IS_OPEN(req)) {
+ if (OS_DO_DEVICE(req, RDC_OPEN))
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, req->error));
+ }
+
+ // Handle /part refinement:
+ len = VAL_LEN_AT(arg);
+ if (REF(part) && VAL_INT32(ARG(limit)) < len)
+ len = VAL_INT32(ARG(limit));
+
+ // If bytes, see if we can fit it:
+ if (SER_WIDE(VAL_SERIES(arg)) == 1) {
#ifdef ARG_STRINGS_ALLOWED
- if (Is_Not_ASCII(VAL_BIN_DATA(arg), len)) {
- Set_String(arg, Copy_Bytes_To_Unicode(VAL_BIN_DATA(arg), len));
- } else
- req->data = VAL_BIN_DATA(arg);
+ if (!All_Bytes_ASCII(VAL_BIN_AT(arg), len)) {
+ REBSER *copy = Copy_Bytes_To_Unicode(VAL_BIN_AT(arg), len);
+ Init_String(arg, copy);
+ } else
+ req->common.data = VAL_BIN_AT(arg);
#endif
- // Temp conversion:!!!
- ser = Make_Unicode(len);
- len = Decode_UTF8(UNI_HEAD(ser), VAL_BIN_DATA(arg), len, FALSE);
- SERIES_TAIL(ser) = len = abs(len);
- UNI_TERM(ser);
- Set_String(arg, ser);
- req->data = (REBYTE*) UNI_HEAD(ser);
- SET_FLAG(req->flags, RRF_WIDE);
- }
- else
- // If unicode (may be from above conversion), handle it:
- if (SERIES_WIDE(VAL_SERIES(arg)) == sizeof(REBUNI)) {
- req->data = (REBYTE *)VAL_UNI_DATA(arg);
- SET_FLAG(req->flags, RRF_WIDE);
- }
-
- // Temp!!!
- req->length = len * sizeof(REBUNI);
-
- // Setup the write:
- *OFV(port, STD_PORT_DATA) = *arg; // keep it GC safe
- req->actual = 0;
-
- result = OS_DO_DEVICE(req, RDC_WRITE);
- SET_NONE(OFV(port, STD_PORT_DATA)); // GC can collect it
-
- if (result < 0) Trap_Port(RE_WRITE_ERROR, port, req->error);
- //if (result == DR_DONE) SET_NONE(OFV(port, STD_PORT_DATA));
- break;
-
- case A_OPEN:
- if (OS_DO_DEVICE(req, RDC_OPEN)) Trap_Port(RE_CANNOT_OPEN, port, req->error);
- break;
-
- case A_CLOSE:
- OS_DO_DEVICE(req, RDC_CLOSE);
- break;
-
- case A_OPENQ:
- if (IS_OPEN(req)) return R_TRUE;
- return R_FALSE;
-
- default:
- Trap_Action(REB_PORT, action);
- }
-
- return R_ARG1; // port
+ // Temp conversion:!!!
+ ser = Make_Unicode(len);
+ len = Decode_UTF8_Negative_If_Latin1(
+ UNI_HEAD(ser), VAL_BIN_AT(arg), len, FALSE
+ );
+ len = abs(len);
+ TERM_UNI_LEN(ser, len);
+ Init_String(arg, ser);
+ req->common.data = cast(REBYTE*, UNI_HEAD(ser));
+ SET_FLAG(req->flags, RRF_WIDE);
+ }
+ else
+ // If unicode (may be from above conversion), handle it:
+ if (SER_WIDE(VAL_SERIES(arg)) == sizeof(REBUNI)) {
+ req->common.data = cast(REBYTE *, VAL_UNI_AT(arg));
+ SET_FLAG(req->flags, RRF_WIDE);
+ }
+
+ // Temp!!!
+ req->length = len * sizeof(REBUNI);
+
+ // Setup the write:
+ Move_Value(CTX_VAR(port, STD_PORT_DATA), arg); // keep it GC safe
+ req->actual = 0;
+
+ result = OS_DO_DEVICE(req, RDC_WRITE);
+ Init_Blank(CTX_VAR(port, STD_PORT_DATA)); // GC can collect it
+
+ if (result < 0) fail (Error_On_Port(RE_WRITE_ERROR, port, req->error));
+ //if (result == DR_DONE) Init_Blank(CTX_VAR(port, STD_PORT_DATA));
+ break; }
+
+ case SYM_OPEN: {
+ INCLUDE_PARAMS_OF_OPEN;
+
+ UNUSED(PAR(spec));
+ if (REF(new))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(read))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(write))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(seek))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(allow)) {
+ UNUSED(ARG(access));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ if (OS_DO_DEVICE(req, RDC_OPEN))
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, req->error));
+ break; }
+
+ case SYM_CLOSE:
+ OS_DO_DEVICE(req, RDC_CLOSE);
+ break;
+
+ case SYM_OPEN_Q:
+ if (IS_OPEN(req)) return R_TRUE;
+ return R_FALSE;
+
+ default:
+ fail (Error_Illegal_Action(REB_PORT, action));
+ }
+
+ Move_Value(D_OUT, D_ARG(1)); // port
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ void Init_Clipboard_Scheme(void)
-/*
-***********************************************************************/
+//
+// get-clipboard-actor-handle: native [
+//
+// {Retrieve handle to the native actor for clipboard}
+//
+// return: [handle!]
+// ]
+//
+REBNATIVE(get_clipboard_actor_handle)
{
- Register_Scheme(SYM_CLIPBOARD, 0, Clipboard_Actor);
+ Make_Port_Actor_Handle(D_OUT, &Clipboard_Actor);
+ return R_OUT;
}
diff --git a/src/core/p-console.c b/src/core/p-console.c
index 23ae491226..a35af87696 100644
--- a/src/core/p-console.c
+++ b/src/core/p-console.c
@@ -1,31 +1,32 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: p-console.c
-** Summary: console port interface
-** Section: ports
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %p-console.c
+// Summary: "console port interface"
+// Section: ports
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
@@ -39,108 +40,99 @@
#define MAKE_OS_BUFFER Make_Binary
#endif
-/***********************************************************************
-**
-*/ static int Console_Actor(REBVAL *ds, REBSER *port, REBCNT action)
-/*
-***********************************************************************/
+//
+// Console_Actor: C
+//
+static REB_R Console_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
{
- REBREQ *req;
- REBINT result;
- REBVAL *arg = D_ARG(2);
- REBSER *ser;
-
- Validate_Port(port, action);
-
- arg = D_ARG(2);
- *D_RET = *D_ARG(1);
-
- req = Use_Port_State(port, RDI_STDIO, sizeof(REBREQ));
-
- switch (action) {
-
- case A_READ:
-
- // If not open, open it:
- if (!IS_OPEN(req)) {
- if (OS_DO_DEVICE(req, RDC_OPEN)) Trap_Port(RE_CANNOT_OPEN, port, req->error);
- }
-
- // If no buffer, create a buffer:
- arg = OFV(port, STD_PORT_DATA);
- if (!IS_STRING(arg) && !IS_BINARY(arg)) {
- Set_Binary(arg, MAKE_OS_BUFFER(OUT_BUF_SIZE));
- }
- ser = VAL_SERIES(arg);
- RESET_SERIES(ser);
-
- req->data = BIN_HEAD(ser);
- req->length = SERIES_AVAIL(ser);
-
-#ifdef nono
- // Is the buffer large enough?
- req->length = SERIES_AVAIL(ser); // space available
- if (req->length < OUT_BUF_SIZE/2) Extend_Series(ser, OUT_BUF_SIZE);
- req->length = SERIES_AVAIL(ser);
-
- // Don't make buffer too large: Bug #174 ?????
- if (req->length > 1024) req->length = 1024; //???
- req->data = STR_TAIL(ser); // write at tail //???
- if (SERIES_TAIL(ser) == 0) req->actual = 0; //???
-#endif
-
- result = OS_DO_DEVICE(req, RDC_READ);
- if (result < 0) Trap_Port(RE_READ_ERROR, port, req->error);
-
-#ifdef nono
- // Does not belong here!!
- // Remove or replace CRs:
- result = 0;
- for (n = 0; n < req->actual; n++) {
- chr = GET_ANY_CHAR(ser, n);
- if (chr == CR) {
- chr = LF;
- // Skip LF if it follows:
- if ((n+1) < req->actual &&
- LF == GET_ANY_CHAR(ser, n+1)) n++;
- }
- SET_ANY_CHAR(ser, result, chr);
- result++;
- }
-#endif
- // Another copy???
- //Set_String(ds, Copy_OS_Str((void *)(ser->data), result));
- Set_Binary(ds, Copy_Bytes(req->data, req->actual));
- break;
-
- case A_OPEN:
- // ?? why???
- //if (OS_DO_DEVICE(req, RDC_OPEN)) Trap_Port(RE_CANNOT_OPEN, port);
- SET_OPEN(req);
- break;
-
- case A_CLOSE:
- SET_CLOSED(req);
- //OS_DO_DEVICE(req, RDC_CLOSE);
- break;
-
- case A_OPENQ:
- if (IS_OPEN(req)) return R_TRUE;
- return R_FALSE;
-
- default:
- Trap_Action(REB_PORT, action);
- }
-
- return R_RET;
+ REBINT result;
+ REBVAL *arg;
+ REBSER *ser;
+
+ arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+ Move_Value(D_OUT, D_ARG(1));
+
+ REBREQ *req = Ensure_Port_State(port, RDI_STDIO);
+
+ switch (action) {
+
+ case SYM_READ: {
+ INCLUDE_PARAMS_OF_READ;
+
+ UNUSED(PAR(source));
+
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(seek)) {
+ UNUSED(ARG(index));
+ fail (Error_Bad_Refines_Raw());
+ }
+ UNUSED(PAR(string)); // handled in dispatcher
+ UNUSED(PAR(lines)); // handled in dispatcher
+
+ // If not open, open it:
+ if (!IS_OPEN(req)) {
+ if (OS_DO_DEVICE(req, RDC_OPEN))
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, req->error));
+ }
+
+ // If no buffer, create a buffer:
+ arg = CTX_VAR(port, STD_PORT_DATA);
+ if (!IS_STRING(arg) && !IS_BINARY(arg)) {
+ Init_Binary(arg, Make_Binary(OUT_BUF_SIZE));
+ }
+ ser = VAL_SERIES(arg);
+ SET_SERIES_LEN(ser, 0);
+ TERM_SERIES(ser);
+
+ // !!! May be a 2-byte wide series on Windows for wide chars, in
+ // which case the length is not bytes?? (Can't use BIN_DATA here
+ // because that asserts width is 1...)
+ //
+ req->common.data = SER_DATA_RAW(ser);
+ req->length = SER_AVAIL(ser);
+
+ result = OS_DO_DEVICE(req, RDC_READ);
+ if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, req->error));
+
+ // !!! Among many confusions in this file, it said "Another copy???"
+ //Init_String(D_OUT, Copy_OS_Str(ser->data, result));
+ Init_Binary(D_OUT, Copy_Bytes(req->common.data, req->actual));
+ break; }
+
+ case SYM_OPEN: {
+ SET_OPEN(req);
+ break; }
+
+ case SYM_CLOSE:
+ SET_CLOSED(req);
+ //OS_DO_DEVICE(req, RDC_CLOSE);
+ break;
+
+ case SYM_OPEN_Q:
+ if (IS_OPEN(req)) return R_TRUE;
+ return R_FALSE;
+
+ default:
+ fail (Error_Illegal_Action(REB_PORT, action));
+ }
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ void Init_Console_Scheme(void)
-/*
-***********************************************************************/
+//
+// get-console-actor-handle: native [
+//
+// {Retrieve handle to the native actor for console}
+//
+// return: [handle!]
+// ]
+//
+REBNATIVE(get_console_actor_handle)
{
- Register_Scheme(SYM_CONSOLE, 0, Console_Actor);
+ Make_Port_Actor_Handle(D_OUT, &Console_Actor);
+ return R_OUT;
}
diff --git a/src/core/p-dir.c b/src/core/p-dir.c
index 2984e68fdc..dd0bc2c604 100644
--- a/src/core/p-dir.c
+++ b/src/core/p-dir.c
@@ -1,31 +1,32 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: p-dir.c
-** Summary: file directory port interface
-** Section: ports
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %p-dir.c
+// Summary: "file directory port interface"
+// Section: ports
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
@@ -33,330 +34,332 @@
#define REMOVE_TAIL_SLASH (1<<10)
-/***********************************************************************
-**
-*/ static int Read_Dir(REBREQ *dir, REBSER *files)
-/*
-** Provide option to get file info too.
-** Provide option to prepend dir path.
-** Provide option to use wildcards.
-**
-***********************************************************************/
+//
+// Read_Dir: C
+//
+// Provide option to get file info too.
+// Provide option to prepend dir path.
+// Provide option to use wildcards.
+//
+static int Read_Dir(struct devreq_file *dir, REBARR *files)
{
- REBINT result;
- REBCNT len;
- REBSER *fname;
- REBSER *name;
- REBREQ file;
-
- RESET_TAIL(files);
- CLEARS(&file);
-
- // Temporary filename storage:
- fname = BUF_OS_STR;
- file.file.path = (REBCHR*)Reset_Buffer(fname, MAX_FILE_NAME);
-
- SET_FLAG(dir->modes, RFM_DIR);
-
- dir->data = (REBYTE*)(&file);
-
- while ((result = OS_DO_DEVICE(dir, RDC_READ)) == 0 && !GET_FLAG(dir->flags, RRF_DONE)) {
- len = LEN_STR(file.file.path);
- if (GET_FLAG(file.modes, RFM_DIR)) len++;
- name = Copy_OS_Str(file.file.path, len);
- if (GET_FLAG(file.modes, RFM_DIR))
- SET_ANY_CHAR(name, name->tail-1, '/');
- Set_Series(REB_FILE, Append_Value(files), name);
- }
-
- if (result < 0 && dir->error != -RFE_OPEN_FAIL
- && (FIND_CHR(dir->file.path, '*') || FIND_CHR(dir->file.path, '?')))
- result = 0; // no matches found, but not an error
-
- return result;
+ REBINT result;
+ REBCNT len;
+ REBSER *fname;
+ REBSER *name;
+ struct devreq_file file;
+ REBREQ *req = AS_REBREQ(dir);
+
+ TERM_ARRAY_LEN(files, 0);
+ CLEARS(&file);
+
+ // Temporary filename storage; native OS API character size (REBCHR) varies
+ //
+ fname = Make_Series(MAX_FILE_NAME, sizeof(REBCHR));
+ file.path = SER_HEAD(REBCHR, fname);
+
+ SET_FLAG(req->modes, RFM_DIR);
+
+ req->common.data = cast(REBYTE*, &file);
+
+ while (
+ (result = OS_DO_DEVICE(req, RDC_READ)) == 0
+ && !GET_FLAG(req->flags, RRF_DONE)
+ ) {
+ len = OS_STRLEN(file.path);
+ if (GET_FLAG(file.devreq.modes, RFM_DIR)) len++;
+ name = Copy_OS_Str(file.path, len);
+ if (GET_FLAG(file.devreq.modes, RFM_DIR))
+ SET_ANY_CHAR(name, SER_LEN(name) - 1, '/');
+ Init_File(Alloc_Tail_Array(files), name);
+ }
+
+ if (result < 0 && req->error != -RFE_OPEN_FAIL
+ && (
+ OS_STRCHR(dir->path, '*')
+ || OS_STRCHR(dir->path, '?')
+ )
+ ) {
+ result = 0; // no matches found, but not an error
+ }
+
+ Free_Series(fname);
+
+ return result;
}
-#ifdef REMOVED
-// It's problematic. See blog. Moved to mezz.
-
-/***********************************************************************
-**
-*/ REBNATIVE(dirq)
-/*
-** Refinements:
-** /any -- allow * and ? wildcards
-**
-** Patterns:
-** abc/ is true
-** abc/*.r is true
-** abc/?.r is true
-** abc - ask the file system
-**
-***********************************************************************/
-{
- REBVAL *path = D_ARG(1);
- REBINT len;
- REBINT i;
- REBCNT dot;
- REBUNI c;
- REBSER *ser = VAL_SERIES(path);
-
- if (!ANY_STR(path)) return R_FALSE;
-
- len = (REBINT)VAL_LEN(path);
- if (len == 0) return R_FALSE;
-
- // We cannot tell from above, so we must check it (if file):
- if (IS_FILE(path)) {
- REBSER *ser;
- REBREQ file;
-
- CLEARS(&file);
- ser = Value_To_OS_Path(path);
- file.file.path = (REBCHR*)(ser->data);
- file.device = RDI_FILE;
- len = OS_DO_DEVICE(&file, RDC_QUERY);
- FREE_SERIES(ser);
- if (len == DR_DONE && GET_FLAG(file.modes, RFM_DIR)) return R_TRUE;
- }
-
- // Search backward for abc/, abc/def, abc/*, etc:
- len = (REBINT)VAL_LEN(path);
- dot = 0;
- for (i = 0; i < len; i++) {
- c = GET_ANY_CHAR(ser, VAL_TAIL(path)-1-i);
- if (c == '/' || c == '\\') {
- if (i == 0 || dot) return R_TRUE;
- break;
- }
- if (c == '.') {
- if (i == 0 || dot) dot = 1;
- }
- else dot = 0;
- if ((c == '*' || c == '?') && D_REF(2)) return R_TRUE;
- }
-
- return R_FALSE;
-}
-#endif
-
-
-/***********************************************************************
-**
-*/ static void Init_Dir_Path(REBREQ *dir, REBVAL *path, REBINT wild, REBCNT policy)
-/*
-** Convert REBOL dir path to file system path.
-** On Windows, we will also need to append a * if necessary.
-**
-** ARGS:
-** Wild:
-** 0 - no wild cards, path must end in / else error
-** 1 - accept wild cards * and ?, and * if need
-** -1 - not wild, if path does not end in /, add it
-**
-***********************************************************************/
+//
+// Init_Dir_Path: C
+//
+// Convert REBOL dir path to file system path.
+// On Windows, we will also need to append a * if necessary.
+//
+// ARGS:
+// Wild:
+// 0 - no wild cards, path must end in / else error
+// 1 - accept wild cards * and ?, and * if need
+// -1 - not wild, if path does not end in /, add it
+//
+static void Init_Dir_Path(struct devreq_file *dir, REBVAL *path, REBINT wild, REBCNT policy)
{
- REBINT len;
- REBSER *ser;
- //REBYTE *flags;
-
- SET_FLAG(dir->modes, RFM_DIR);
-
- // We depend on To_Local_Path giving us 2 extra chars for / and *
- ser = Value_To_OS_Path(path);
- len = ser->tail;
- dir->file.path = (REBCHR*)(ser->data);
-
- Secure_Port(SYM_FILE, dir, path, ser);
-
- if (len == 1 && dir->file.path[0] == '.') {
- if (wild > 0) {
- dir->file.path[0] = '*';
- dir->file.path[1] = 0;
- }
- }
- else if (len == 2 && dir->file.path[0] == '.' && dir->file.path[1] == '.') {
- // Insert * if needed:
- if (wild > 0) {
- dir->file.path[len++] = '/';
- dir->file.path[len++] = '*';
- dir->file.path[len] = 0;
- }
- }
- else if (dir->file.path[len-1] == '/' || dir->file.path[len-1] == '\\') {
- if (policy & REMOVE_TAIL_SLASH) {
- dir->file.path[len-1] = 0;
- }
- else {
- // Insert * if needed:
- if (wild > 0) {
- dir->file.path[len++] = '*';
- dir->file.path[len] = 0;
- }
- }
- } else {
- // Path did not end with /, so we better be wild:
- if (wild == 0) {
- ///OS_FREE(dir->file.path);
- Trap1(RE_BAD_FILE_PATH, path);
- }
- else if (wild < 0) {
- dir->file.path[len++] = OS_DIR_SEP;
- dir->file.path[len] = 0;
- }
- }
+ REBINT len;
+ REBSER *ser;
+ //REBYTE *flags;
+ REBREQ *req = AS_REBREQ(dir);
+
+ SET_FLAG(req->modes, RFM_DIR);
+
+ // We depend on To_Local_Path giving us 2 extra chars for / and *
+ ser = Value_To_OS_Path(path, TRUE);
+ len = SER_LEN(ser);
+ dir->path = SER_HEAD(REBCHR, ser);
+
+ Secure_Port(SYM_FILE, req, path, ser);
+
+ if (len == 1 && OS_CH_EQUAL(dir->path[0], '.')) {
+ if (wild > 0) {
+ dir->path[0] = OS_MAKE_CH('*');
+ dir->path[1] = OS_MAKE_CH('\0');
+ }
+ }
+ else if (
+ len == 2
+ && OS_CH_EQUAL(dir->path[0], '.')
+ && OS_CH_EQUAL(dir->path[1], '.')
+ ) {
+ // Insert * if needed:
+ if (wild > 0) {
+ dir->path[len++] = OS_MAKE_CH('/');
+ dir->path[len++] = OS_MAKE_CH('*');
+ dir->path[len] = OS_MAKE_CH('\0');
+ }
+ }
+ else if (
+ OS_CH_EQUAL(dir->path[len-1], '/')
+ || OS_CH_EQUAL(dir->path[len-1], '\\')
+ ) {
+ if ((policy & REMOVE_TAIL_SLASH) && len > 1) {
+ dir->path[len-1] = OS_MAKE_CH('\0');
+ }
+ else {
+ // Insert * if needed:
+ if (wild > 0) {
+ dir->path[len++] = OS_MAKE_CH('*');
+ dir->path[len] = OS_MAKE_CH('\0');
+ }
+ }
+ } else {
+ // Path did not end with /, so we better be wild:
+ if (wild == 0) {
+ // !!! Comment said `OS_FREE(dir->path);` (needed?)
+ fail (Error_Bad_File_Path_Raw(path));
+ }
+ else if (wild < 0) {
+ dir->path[len++] = OS_MAKE_CH(OS_DIR_SEP);
+ dir->path[len] = OS_MAKE_CH('\0');
+ }
+ }
}
-/***********************************************************************
-**
-*/ static int Dir_Actor(REBVAL *ds, REBSER *port, REBCNT action)
-/*
-** Internal port handler for file directories.
-**
-***********************************************************************/
+//
+// Dir_Actor: C
+//
+// Internal port handler for file directories.
+//
+static REB_R Dir_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
{
- REBVAL *spec;
- REBVAL *path;
- REBVAL *state;
- REBREQ dir;
- REBCNT args = 0;
- REBINT result;
- REBCNT len;
- //REBYTE *flags;
-
- Validate_Port(port, action);
-
- *D_RET = *D_ARG(1);
- CLEARS(&dir);
-
- // Validate and fetch relevant PORT fields:
- spec = BLK_SKIP(port, STD_PORT_SPEC);
- if (!IS_OBJECT(spec)) Trap1(RE_INVALID_SPEC, spec);
- path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
- if (!path) Trap1(RE_INVALID_SPEC, spec);
-
- if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
- else if (!IS_FILE(path)) Trap1(RE_INVALID_SPEC, path);
-
- state = BLK_SKIP(port, STD_PORT_STATE); // if block, then port is open.
-
- //flags = Security_Policy(SYM_FILE, path);
-
- // Get or setup internal state data:
- dir.port = port;
- dir.device = RDI_FILE;
-
- switch (action) {
-
- case A_READ:
- //Trap_Security(flags[POL_READ], POL_READ, path);
- args = Find_Refines(ds, ALL_READ_REFS);
- if (!IS_BLOCK(state)) { // !!! ignores /SKIP and /PART, for now
- Init_Dir_Path(&dir, path, 1, POL_READ);
- Set_Block(state, Make_Block(7)); // initial guess
- result = Read_Dir(&dir, VAL_SERIES(state));
- ///OS_FREE(dir.file.path);
- if (result < 0) Trap_Port(RE_CANNOT_OPEN, port, dir.error);
- *D_RET = *state;
- SET_NONE(state);
- } else {
- len = VAL_BLK_LEN(state);
- // !!? Why does this need to copy the block??
- Set_Block(D_RET, Copy_Block_Values(VAL_SERIES(state), 0, len, TS_STRING));
- }
- break;
-
- case A_CREATE:
- //Trap_Security(flags[POL_WRITE], POL_WRITE, path);
- if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
-create:
- Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
- result = OS_DO_DEVICE(&dir, RDC_CREATE);
- ///OS_FREE(dir.file.path);
- if (result < 0) Trap1(RE_NO_CREATE, path);
- if (action == A_CREATE) return R_ARG2;
- SET_NONE(state);
- break;
-
- case A_RENAME:
- if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
- else {
- REBSER *target;
-
- Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
- // Convert file name to OS format:
- if (!(target = Value_To_OS_Path(D_ARG(2)))) Trap1(RE_BAD_FILE_PATH, D_ARG(2));
- dir.data = BIN_DATA(target);
- OS_DO_DEVICE(&dir, RDC_RENAME);
- Free_Series(target);
- if (dir.error) Trap1(RE_NO_RENAME, path);
- }
- break;
-
- case A_DELETE:
- //Trap_Security(flags[POL_WRITE], POL_WRITE, path);
- SET_NONE(state);
- Init_Dir_Path(&dir, path, 0, POL_WRITE);
- // !!! add *.r deletion
- // !!! add recursive delete (?)
- result = OS_DO_DEVICE(&dir, RDC_DELETE);
- ///OS_FREE(dir.file.path);
- if (result < 0) Trap1(RE_NO_DELETE, path);
- return R_ARG2;
-
- case A_OPEN:
- // !! If open fails, what if user does a READ w/o checking for error?
- if (IS_BLOCK(state)) Trap1(RE_ALREADY_OPEN, path); // already open
- //Trap_Security(flags[POL_READ], POL_READ, path);
- args = Find_Refines(ds, ALL_OPEN_REFS);
- if (args & AM_OPEN_NEW) goto create;
- //if (args & ~AM_OPEN_READ) Trap1(RE_INVALID_SPEC, path);
- Set_Block(state, Make_Block(7));
- Init_Dir_Path(&dir, path, 1, POL_READ);
- result = Read_Dir(&dir, VAL_SERIES(state));
- ///OS_FREE(dir.file.path);
- if (result < 0) Trap_Port(RE_CANNOT_OPEN, port, dir.error);
- break;
-
- case A_OPENQ:
- if (IS_BLOCK(state)) return R_TRUE;
- return R_FALSE;
-
- case A_CLOSE:
- SET_NONE(state);
- break;
-
- case A_QUERY:
- //Trap_Security(flags[POL_READ], POL_READ, path);
- SET_NONE(state);
- Init_Dir_Path(&dir, path, -1, REMOVE_TAIL_SLASH | POL_READ);
- if (OS_DO_DEVICE(&dir, RDC_QUERY) < 0) return R_NONE;
- Ret_Query_File(port, &dir, D_RET);
- ///OS_FREE(dir.file.path);
- break;
-
- //-- Port Series Actions (only called if opened as a port)
-
- case A_LENGTHQ:
- len = IS_BLOCK(state) ? VAL_BLK_LEN(state) : 0;
- SET_INTEGER(D_RET, len);
- break;
-
- default:
- Trap_Action(REB_PORT, action);
- }
-
- return R_RET;
+ REBVAL *spec;
+ REBVAL *path;
+ REBVAL *state;
+ struct devreq_file dir;
+ REBINT result;
+ REBCNT len;
+ //REBYTE *flags;
+
+ Move_Value(D_OUT, D_ARG(1));
+ CLEARS(&dir);
+
+ // Validate and fetch relevant PORT fields:
+ spec = CTX_VAR(port, STD_PORT_SPEC);
+ if (!IS_OBJECT(spec)) fail (Error_Invalid_Spec_Raw(spec));
+ path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
+ if (!path) fail (Error_Invalid_Spec_Raw(spec));
+
+ if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
+ else if (!IS_FILE(path)) fail (Error_Invalid_Spec_Raw(path));
+
+ state = CTX_VAR(port, STD_PORT_STATE); // if block, then port is open.
+
+ //flags = Security_Policy(SYM_FILE, path);
+
+ // Get or setup internal state data:
+ dir.devreq.port = port;
+ dir.devreq.device = RDI_FILE;
+
+ switch (action) {
+
+ case SYM_READ: {
+ INCLUDE_PARAMS_OF_READ;
+
+ UNUSED(PAR(source));
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(seek)) {
+ UNUSED(ARG(index));
+ fail (Error_Bad_Refines_Raw());
+ }
+ UNUSED(PAR(string)); // handled in dispatcher
+ UNUSED(PAR(lines)); // handled in dispatcher
+
+ if (!IS_BLOCK(state)) { // !!! ignores /SKIP and /PART, for now
+ Init_Dir_Path(&dir, path, 1, POL_READ);
+ Init_Block(state, Make_Array(7)); // initial guess
+ result = Read_Dir(&dir, VAL_ARRAY(state));
+ if (result < 0)
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, dir.devreq.error));
+ Move_Value(D_OUT, state);
+ Init_Blank(state);
+ }
+ else {
+ // !!! This copies the strings in the block, shallowly. What is
+ // the purpose of doing this? Why copy at all?
+ Init_Block(
+ D_OUT,
+ Copy_Array_Core_Managed(
+ VAL_ARRAY(state),
+ 0, // at
+ VAL_SPECIFIER(state),
+ VAL_ARRAY_LEN_AT(state), // tail
+ 0, // extra
+ FALSE, // !deep
+ TS_STRING // types
+ )
+ );
+ }
+ break; }
+
+ case SYM_CREATE:
+ if (IS_BLOCK(state))
+ fail (Error_Already_Open_Raw(path));
+ create:
+ Init_Dir_Path(
+ &dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH
+ ); // Sets RFM_DIR too
+ result = OS_DO_DEVICE(&dir.devreq, RDC_CREATE);
+ if (result < 0)
+ fail (Error_No_Create_Raw(path));
+ if (action == SYM_CREATE) {
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT;
+ }
+ Init_Blank(state);
+ break;
+
+ case SYM_RENAME:
+ if (IS_BLOCK(state)) fail (Error_Already_Open_Raw(path));
+ else {
+ REBSER *target;
+
+ Init_Dir_Path(&dir, path, 0, POL_WRITE | REMOVE_TAIL_SLASH); // Sets RFM_DIR too
+ // Convert file name to OS format:
+ if (!(target = Value_To_OS_Path(D_ARG(2), TRUE)))
+ fail (Error_Bad_File_Path_Raw(D_ARG(2)));
+ dir.devreq.common.data = BIN_HEAD(target);
+ OS_DO_DEVICE(&dir.devreq, RDC_RENAME);
+ Free_Series(target);
+ if (dir.devreq.error) fail (Error_No_Rename_Raw(path));
+ }
+ break;
+
+ case SYM_DELETE:
+ //Trap_Security(flags[POL_WRITE], POL_WRITE, path);
+ Init_Blank(state);
+ Init_Dir_Path(&dir, path, 0, POL_WRITE);
+ // !!! add *.r deletion
+ // !!! add recursive delete (?)
+ result = OS_DO_DEVICE(&dir.devreq, RDC_DELETE);
+ ///OS_FREE(dir.file.path);
+ if (result < 0) fail (Error_No_Delete_Raw(path));
+ // !!! Returned D_ARG(2) before, but there is no second argument :-/
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT;
+
+ case SYM_OPEN: {
+ INCLUDE_PARAMS_OF_OPEN;
+
+ UNUSED(PAR(spec));
+ if (REF(read))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(write))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(seek))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(allow)) {
+ UNUSED(ARG(access));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ // !! If open fails, what if user does a READ w/o checking for error?
+ if (IS_BLOCK(state))
+ fail (Error_Already_Open_Raw(path));
+
+ if (REF(new))
+ goto create;
+
+ Init_Block(state, Make_Array(7));
+ Init_Dir_Path(&dir, path, 1, POL_READ);
+ result = Read_Dir(&dir, VAL_ARRAY(state));
+
+ if (result < 0)
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, dir.devreq.error));
+ break; }
+
+ case SYM_OPEN_Q:
+ if (IS_BLOCK(state)) return R_TRUE;
+ return R_FALSE;
+
+ case SYM_CLOSE:
+ Init_Blank(state);
+ break;
+
+ case SYM_QUERY:
+ //Trap_Security(flags[POL_READ], POL_READ, path);
+ Init_Blank(state);
+ Init_Dir_Path(&dir, path, -1, REMOVE_TAIL_SLASH | POL_READ);
+ if (OS_DO_DEVICE(&dir.devreq, RDC_QUERY) < 0) return R_BLANK;
+ Ret_Query_File(port, &dir, D_OUT);
+ ///OS_FREE(dir.file.path);
+ break;
+
+ //-- Port Series Actions (only called if opened as a port)
+
+ case SYM_LENGTH_OF:
+ len = IS_BLOCK(state) ? VAL_ARRAY_LEN_AT(state) : 0;
+ Init_Integer(D_OUT, len);
+ break;
+
+ default:
+ fail (Error_Illegal_Action(REB_PORT, action));
+ }
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ void Init_Dir_Scheme(void)
-/*
-***********************************************************************/
+//
+// get-dir-actor-handle: native [
+//
+// {Retrieve handle to the native actor for directories}
+//
+// return: [handle!]
+// ]
+//
+REBNATIVE(get_dir_actor_handle)
{
- Register_Scheme(SYM_DIR, 0, Dir_Actor);
+ Make_Port_Actor_Handle(D_OUT, &Dir_Actor);
+ return R_OUT;
}
diff --git a/src/core/p-dns.c b/src/core/p-dns.c
index 1367074719..d270146baf 100644
--- a/src/core/p-dns.c
+++ b/src/core/p-dns.c
@@ -1,144 +1,210 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: p-dns.c
-** Summary: DNS port interface
-** Section: ports
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %p-dns.c
+// Summary: "DNS port interface"
+// Section: ports
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
#include "reb-net.h"
-/***********************************************************************
-**
-*/ static int DNS_Actor(REBVAL *ds, REBSER *port, REBCNT action)
-/*
-***********************************************************************/
+//
+// DNS_Actor: C
+//
+static REB_R DNS_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
{
- REBVAL *spec;
- REBREQ *sock;
- REBINT result;
- REBVAL *arg;
- REBCNT len;
- REBOOL sync = FALSE; // act synchronously
- REBVAL tmp;
-
- Validate_Port(port, action);
-
- arg = D_ARG(2);
- *D_RET = *D_ARG(1);
-
- sock = Use_Port_State(port, RDI_DNS, sizeof(*sock));
- spec = OFV(port, STD_PORT_SPEC);
- if (!IS_OBJECT(spec)) Trap0(RE_INVALID_PORT);
-
- sock->timeout = 4000; // where does this go? !!!
-
- switch (action) {
-
- case A_READ:
- if (!IS_OPEN(sock)) {
- if (OS_DO_DEVICE(sock, RDC_OPEN)) Trap_Port(RE_CANNOT_OPEN, port, sock->error);
- sync = TRUE;
- }
-
- arg = Obj_Value(spec, STD_PORT_SPEC_NET_HOST);
-
- if (IS_TUPLE(arg) && Scan_Tuple(VAL_BIN(arg), strlen(VAL_BIN(arg)), &tmp)) {
- SET_FLAG(sock->modes, RST_REVERSE);
- memcpy(&sock->net.remote_ip, VAL_TUPLE(&tmp), 4);
- }
- else if (IS_STRING(arg)) {
- sock->data = VAL_BIN(arg);
- }
- else Trap_Port(RE_INVALID_SPEC, port, -10);
-
- result = OS_DO_DEVICE(sock, RDC_READ);
- if (result < 0) Trap_Port(RE_READ_ERROR, port, sock->error);
-
- // Wait for it...
- if (sync && result == DR_PEND) {
- for (len = 0; GET_FLAG(sock->flags, RRF_PENDING) && len < 10; len++) {
- OS_WAIT(2000, 0);
- }
- len = 1;
- goto pick;
- }
- if (result == DR_DONE) {
- len = 1;
- goto pick;
- }
- break;
-
- case A_PICK: // FIRST - return result
- if (!IS_OPEN(sock)) Trap_Port(RE_NOT_OPEN, port, -12);
- len = Get_Num_Arg(arg); // Position
-pick:
- if (len == 1) {
- if (!sock->net.host_info || !GET_FLAG(sock->flags, RRF_DONE)) return R_NONE;
- if (sock->error) {
- OS_DO_DEVICE(sock, RDC_CLOSE);
- Trap_Port(RE_READ_ERROR, port, sock->error);
- }
- if (GET_FLAG(sock->modes, RST_REVERSE)) {
- Set_String(D_RET, Copy_Bytes(sock->data, LEN_BYTES(sock->data)));
- } else {
- Set_Tuple(D_RET, (REBYTE*)&sock->net.remote_ip, 4);
- }
- OS_DO_DEVICE(sock, RDC_CLOSE);
- } else Trap_Range(arg);
- break;
-
- case A_OPEN:
- if (OS_DO_DEVICE(sock, RDC_OPEN)) Trap_Port(RE_CANNOT_OPEN, port, -12);
- break;
-
- case A_CLOSE:
- OS_DO_DEVICE(sock, RDC_CLOSE);
- break;
-
- case A_OPENQ:
- if (IS_OPEN(sock)) return R_TRUE;
- return R_FALSE;
-
- case A_UPDATE:
- return R_NONE;
-
- default:
- Trap_Action(REB_PORT, action);
- }
-
- return R_RET;
+ REBVAL *spec;
+ REBINT result;
+ REBVAL *arg;
+ REBCNT len;
+ REBOOL sync = FALSE; // act synchronously
+
+ arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+ Move_Value(D_OUT, D_ARG(1));
+
+ REBREQ *sock = Ensure_Port_State(port, RDI_DNS);
+ spec = CTX_VAR(port, STD_PORT_SPEC);
+ if (!IS_OBJECT(spec)) fail (Error_Invalid_Port_Raw());
+
+ sock->timeout = 4000; // where does this go? !!!
+
+ switch (action) {
+
+ case SYM_READ: {
+ INCLUDE_PARAMS_OF_READ;
+
+ UNUSED(PAR(source));
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ if (REF(seek)) {
+ UNUSED(ARG(index));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ UNUSED(PAR(string)); // handled in dispatcher
+ UNUSED(PAR(lines)); // handled in dispatcher
+
+ if (!IS_OPEN(sock)) {
+ if (OS_DO_DEVICE(sock, RDC_OPEN))
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, sock->error));
+ sync = TRUE;
+ }
+
+ arg = Obj_Value(spec, STD_PORT_SPEC_NET_HOST);
+
+ // A DNS read e.g. of `read dns://66.249.66.140` should do a reverse
+ // lookup. The scheme handler may pass in either a TUPLE! or a string
+ // that scans to a tuple, at this time (currently uses a string)
+ //
+ if (IS_TUPLE(arg)) {
+ SET_FLAG(sock->modes, RST_REVERSE);
+ memcpy(&(DEVREQ_NET(sock)->remote_ip), VAL_TUPLE(arg), 4);
+ }
+ else if (IS_STRING(arg)) {
+ REBCNT index = VAL_INDEX(arg);
+ REBCNT len = VAL_LEN_AT(arg);
+ REBSER *utf8 = Temp_Bin_Str_Managed(arg, &index, &len);
+
+ DECLARE_LOCAL (tmp);
+ if (Scan_Tuple(tmp, BIN_AT(utf8, index), len) != NULL) {
+ SET_FLAG(sock->modes, RST_REVERSE);
+ memcpy(&(DEVREQ_NET(sock)->remote_ip), VAL_TUPLE(tmp), 4);
+ }
+ else
+ sock->common.data = VAL_BIN(arg); // lookup string's IP address
+ }
+ else
+ fail (Error_On_Port(RE_INVALID_SPEC, port, -10));
+
+ result = OS_DO_DEVICE(sock, RDC_READ);
+ if (result < 0)
+ fail (Error_On_Port(RE_READ_ERROR, port, sock->error));
+
+ if (sync && result == DR_PEND) {
+ assert(FALSE); // asynchronous R3-Alpha DNS code removed
+ len = 0;
+ for (; GET_FLAG(sock->flags, RRF_PENDING) && len < 10; ++len) {
+ OS_WAIT(2000, 0);
+ }
+ len = 1;
+ goto pick;
+ }
+ if (result == DR_DONE) {
+ len = 1;
+ goto pick;
+ }
+ break; }
+
+ case SYM_PICK_P: // FIRST - return result
+ if (!IS_OPEN(sock))
+ fail (Error_On_Port(RE_NOT_OPEN, port, -12));
+
+ len = Get_Num_From_Arg(arg); // Position
+ pick:
+ if (len != 1)
+ fail (Error_Out_Of_Range(arg));
+
+ assert(GET_FLAG(sock->flags, RRF_DONE)); // R3-Alpha async DNS removed
+
+ if (sock->error) {
+ OS_DO_DEVICE(sock, RDC_CLOSE);
+ fail (Error_On_Port(RE_READ_ERROR, port, sock->error));
+ }
+
+ if (DEVREQ_NET(sock)->host_info == NULL) {
+ Init_Blank(D_OUT); // HOST_NOT_FOUND or NO_ADDRESS blank vs. error
+ return R_OUT; // READ action currently required to use R_OUTs
+ }
+
+ if (GET_FLAG(sock->modes, RST_REVERSE)) {
+ Init_String(
+ D_OUT,
+ Copy_Bytes(sock->common.data, LEN_BYTES(sock->common.data))
+ );
+ }
+ else {
+ Set_Tuple(D_OUT, cast(REBYTE*, &DEVREQ_NET(sock)->remote_ip), 4);
+ }
+ OS_DO_DEVICE(sock, RDC_CLOSE);
+ break;
+
+ case SYM_OPEN: {
+ INCLUDE_PARAMS_OF_OPEN;
+
+ UNUSED(PAR(spec));
+ if (REF(new))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(read))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(write))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(seek))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(allow)) {
+ UNUSED(ARG(access));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ if (OS_DO_DEVICE(sock, RDC_OPEN))
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, -12));
+ break; }
+
+ case SYM_CLOSE:
+ OS_DO_DEVICE(sock, RDC_CLOSE);
+ break;
+
+ case SYM_OPEN_Q:
+ if (IS_OPEN(sock)) return R_TRUE;
+ return R_FALSE;
+
+ case SYM_UPDATE:
+ return R_BLANK;
+
+ default:
+ fail (Error_Illegal_Action(REB_PORT, action));
+ }
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ void Init_DNS_Scheme(void)
-/*
-***********************************************************************/
+//
+// get-dns-actor-handle: native [
+//
+// {Retrieve handle to the native actor for DNS}
+//
+// return: [handle!]
+// ]
+//
+REBNATIVE(get_dns_actor_handle)
{
- Register_Scheme(SYM_DNS, 0, DNS_Actor);
+ Make_Port_Actor_Handle(D_OUT, &DNS_Actor);
+ return R_OUT;
}
diff --git a/src/core/p-event.c b/src/core/p-event.c
index 0a32a1f162..e5cc1657dd 100644
--- a/src/core/p-event.c
+++ b/src/core/p-event.c
@@ -1,202 +1,278 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: p-event.c
-** Summary: event port interface
-** Section: ports
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %p-event.c
+// Summary: "event port interface"
+// Section: ports
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
/*
Basics:
- Ports use requests to control devices.
- Devices do their best, and return when no more is possible.
- Progs call WAIT to check if devices have changed.
- If devices changed, modifies request, and sends event.
- If no devices changed, timeout happens.
- On REBOL side, we scan event queue.
- If we find an event, we call its port/awake function.
+ Ports use requests to control devices.
+ Devices do their best, and return when no more is possible.
+ Progs call WAIT to check if devices have changed.
+ If devices changed, modifies request, and sends event.
+ If no devices changed, timeout happens.
+ On REBOL side, we scan event queue.
+ If we find an event, we call its port/awake function.
- Different cases exist:
+ Different cases exist:
- 1. wait for time only
+ 1. wait for time only
- 2. wait for ports and time. Need a master wait list to
- merge with the list provided this function.
+ 2. wait for ports and time. Need a master wait list to
+ merge with the list provided this function.
- 3. wait for windows to close - check each time we process
- a close event.
+ 3. wait for windows to close - check each time we process
+ a close event.
- 4. what to do on console ESCAPE interrupt? Can use catch it?
+ 4. what to do on console ESCAPE interrupt? Can use catch it?
- 5. how dow we relate events back to their ports?
+ 5. how dow we relate events back to their ports?
- 6. async callbacks
+ 6. async callbacks
*/
#include "sys-core.h"
-REBREQ *req; //!!! move this global
-
-
-/***********************************************************************
-**
-*/ REBVAL *Append_Event()
-/*
-** Append an event to the end of the current event port queue.
-** Return a pointer to the event value.
-**
-** Note: this function may be called from out of environment,
-** so do NOT extend the event queue here. If it does not have
-** space, return 0. (Should it overwrite or wrap???)
-**
-***********************************************************************/
+REBREQ *req; //!!! move this global
+
+#define EVENTS_LIMIT 0xFFFF //64k
+#define EVENTS_CHUNK 128
+
+//
+// Append_Event: C
+//
+// Append an event to the end of the current event port queue.
+// Return a pointer to the event value.
+//
+// Note: this function may be called from out of environment,
+// so do NOT extend the event queue here. If it does not have
+// space, return 0. (Should it overwrite or wrap???)
+//
+REBVAL *Append_Event(void)
{
- REBVAL *port;
- REBVAL *value;
- REBVAL *state;
+ REBVAL *port = Get_System(SYS_PORTS, PORTS_SYSTEM);
+ if (!IS_PORT(port)) return 0; // verify it is a port object
- port = Get_System(SYS_PORTS, PORTS_SYSTEM);
- if (!IS_PORT(port)) return 0; // verify it is a port object
+ // Get queue block:
+ REBVAL *state = VAL_CONTEXT_VAR(port, STD_PORT_STATE);
+ if (!IS_BLOCK(state)) return 0;
- // Get queue block:
- state = VAL_BLK_SKIP(port, STD_PORT_STATE);
- if (!IS_BLOCK(state)) return 0;
+ // Append to tail if room:
+ if (SER_FULL(VAL_SERIES(state))) {
+ if (VAL_LEN_HEAD(state) > EVENTS_LIMIT)
+ panic (state);
- // Append to tail if room:
- if (SERIES_FULL(VAL_SERIES(state))) Crash(RP_MAX_EVENTS);
- VAL_TAIL(state)++;
- value = VAL_BLK_TAIL(state);
- SET_END(value);
- value--;
- SET_NONE(value);
+ Extend_Series(VAL_SERIES(state), EVENTS_CHUNK);
+ }
+ TERM_ARRAY_LEN(VAL_ARRAY(state), VAL_LEN_HEAD(state) + 1);
- //Dump_Series(VAL_SERIES(state), "state");
- //Print("Tail: %d %d", VAL_TAIL(state), nn++);
+ REBVAL *value = SINK(ARR_LAST(VAL_ARRAY(state)));
+ Init_Blank(value);
- return value;
+ return value;
}
-/***********************************************************************
-**
-*/ static int Event_Actor(REBVAL *ds, REBSER *port, REBCNT action)
-/*
-** Internal port handler for events.
-**
-***********************************************************************/
+//
+// Find_Last_Event: C
+//
+// Find the last event in the queue by the model
+// Check its type, if it matches, then return the event or NULL
+//
+REBVAL *Find_Last_Event(REBINT model, REBINT type)
{
- REBVAL *spec;
- REBVAL *state;
- REBCNT result;
- REBVAL *arg;
- REBVAL save_port;
-
- Validate_Port(port, action);
-
- arg = D_ARG(2);
- *D_RET = *D_ARG(1);
-
- // Validate and fetch relevant PORT fields:
- state = BLK_SKIP(port, STD_PORT_STATE);
- spec = BLK_SKIP(port, STD_PORT_SPEC);
- if (!IS_OBJECT(spec)) Trap1(RE_INVALID_SPEC, spec);
-
- // Get or setup internal state data:
- if (!IS_BLOCK(state)) Set_Block(state, Make_Block(127));
-
- switch (action) {
-
- case A_UPDATE:
- return R_NONE;
-
- // Normal block actions done on events:
- case A_POKE:
- if (!IS_EVENT(D_ARG(3))) Trap_Arg(D_ARG(3));
- goto act_blk;
- case A_INSERT:
- case A_APPEND:
- //case A_PATH: // not allowed: port/foo is port object field access
- //case A_PATH_SET: // not allowed: above
- if (!IS_EVENT(arg)) Trap_Arg(arg);
- case A_PICK:
+ REBVAL *port;
+ RELVAL *value;
+ REBVAL *state;
+
+ port = Get_System(SYS_PORTS, PORTS_SYSTEM);
+ if (!IS_PORT(port)) return NULL; // verify it is a port object
+
+ // Get queue block:
+ state = VAL_CONTEXT_VAR(port, STD_PORT_STATE);
+ if (!IS_BLOCK(state)) return NULL;
+
+ value = VAL_ARRAY_TAIL(state) - 1;
+ for (; value >= VAL_ARRAY_HEAD(state); --value) {
+ if (VAL_EVENT_MODEL(value) == model) {
+ if (VAL_EVENT_TYPE(value) == type) {
+ return KNOWN(value);
+ } else {
+ return NULL;
+ }
+ }
+ }
+
+ return NULL;
+}
+
+//
+// Event_Actor: C
+//
+// Internal port handler for events.
+//
+static REB_R Event_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
+{
+ REBVAL *spec;
+ REBVAL *state;
+ REB_R result;
+ REBVAL *arg;
+
+ DECLARE_LOCAL (save_port);
+
+ arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+ Move_Value(D_OUT, D_ARG(1));
+
+ // Validate and fetch relevant PORT fields:
+ state = CTX_VAR(port, STD_PORT_STATE);
+ spec = CTX_VAR(port, STD_PORT_SPEC);
+ if (!IS_OBJECT(spec)) fail (Error_Invalid_Spec_Raw(spec));
+
+ // Get or setup internal state data:
+ if (!IS_BLOCK(state))
+ Init_Block(state, Make_Array(EVENTS_CHUNK - 1));
+
+ switch (action) {
+
+ case SYM_UPDATE:
+ return R_BLANK;
+
+ // Normal block actions done on events:
+ case SYM_POKE:
+ if (!IS_EVENT(D_ARG(3)))
+ fail (D_ARG(3));
+ goto act_blk;
+ case SYM_INSERT:
+ case SYM_APPEND:
+ //case A_PATH: // not allowed: port/foo is port object field access
+ //case A_PATH_SET: // not allowed: above
+ if (!IS_EVENT(arg))
+ fail (arg);
+ // falls through
+ case SYM_PICK_P:
act_blk:
- save_port = *D_ARG(1); // save for return
- *D_ARG(1) = *state;
- result = T_Block(ds, action);
- SET_SIGNAL(SIG_EVENT_PORT);
- if (action == A_INSERT || action == A_APPEND || action == A_REMOVE) {
- *D_RET = save_port;
- break;
- }
- return result; // return condition
-
- case A_CLEAR:
- VAL_TAIL(state) = 0;
- VAL_BLK_TERM(state);
- CLR_SIGNAL(SIG_EVENT_PORT);
- break;
-
- case A_LENGTHQ:
- SET_INTEGER(D_RET, VAL_TAIL(state));
- break;
-
- case A_OPEN:
- if (!req) { //!!!
- req = OS_MAKE_DEVREQ(RDI_EVENT);
- if (req) {
- SET_OPEN(req);
- OS_DO_DEVICE(req, RDC_CONNECT); // stays queued
- }
- }
- break;
-
- case A_CLOSE:
- OS_ABORT_DEVICE(req);
- OS_DO_DEVICE(req, RDC_CLOSE);
- // free req!!!
- SET_CLOSED(req);
- req = 0;
- break;
-
- case A_FIND: // add it
-
- default:
- Trap_Action(REB_PORT, action);
- }
-
- return R_RET;
+ Move_Value(save_port, D_ARG(1)); // save for return
+ Move_Value(D_ARG(1), state);
+ result = T_Array(frame_, action);
+ SET_SIGNAL(SIG_EVENT_PORT);
+ if (
+ action == SYM_INSERT
+ || action == SYM_APPEND
+ || action == SYM_REMOVE
+ ){
+ Move_Value(D_OUT, save_port);
+ break;
+ }
+ return result; // return condition
+
+ case SYM_CLEAR:
+ TERM_ARRAY_LEN(VAL_ARRAY(state), 0);
+ CLR_SIGNAL(SIG_EVENT_PORT);
+ break;
+
+ case SYM_LENGTH_OF:
+ Init_Integer(D_OUT, VAL_LEN_HEAD(state));
+ break;
+
+ case SYM_OPEN: {
+ INCLUDE_PARAMS_OF_OPEN;
+
+ UNUSED(PAR(spec));
+ if (REF(new))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(read))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(write))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(seek))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(allow)) {
+ UNUSED(ARG(access));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ if (!req) { //!!!
+ req = OS_MAKE_DEVREQ(RDI_EVENT);
+ if (req) {
+ SET_OPEN(req);
+ OS_DO_DEVICE(req, RDC_CONNECT); // stays queued
+ }
+ }
+ break; }
+
+ case SYM_CLOSE:
+ OS_ABORT_DEVICE(req);
+ OS_DO_DEVICE(req, RDC_CLOSE);
+ // free req!!!
+ SET_CLOSED(req);
+ req = 0;
+ break;
+
+ case SYM_FIND: // add it
+
+ default:
+ fail (Error_Illegal_Action(REB_PORT, action));
+ }
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ void Init_Event_Scheme(void)
-/*
-***********************************************************************/
+//
+// Startup_Event_Scheme: C
+//
+void Startup_Event_Scheme(void)
+{
+ req = 0; // move to port struct
+}
+
+
+//
+// Shutdown_Event_Scheme: C
+//
+void Shutdown_Event_Scheme(void)
+{
+ if (req) {
+ OS_FREE(req);
+ req = NULL;
+ }
+}
+
+
+//
+// get-event-actor-handle: native [
+//
+// {Retrieve handle to the native actor for events (system, event, callback)}
+//
+// return: [handle!]
+// ]
+//
+REBNATIVE(get_event_actor_handle)
{
- req = 0; // move to port struct
- Register_Scheme(SYM_SYSTEM, 0, Event_Actor);
- Register_Scheme(SYM_EVENT, 0, Event_Actor);
- Register_Scheme(SYM_CALLBACK, 0, Event_Actor);
+ Make_Port_Actor_Handle(D_OUT, &Event_Actor);
+ return R_OUT;
}
diff --git a/src/core/p-file.c b/src/core/p-file.c
index 5532746c48..a3035aaf9b 100644
--- a/src/core/p-file.c
+++ b/src/core/p-file.c
@@ -1,31 +1,32 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: p-file.c
-** Summary: file port interface
-** Section: ports
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %p-file.c
+// Summary: "file port interface"
+// Section: ports
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
@@ -36,107 +37,113 @@
#define MAX_READ_MASK 0x7FFFFFFF // max size per chunk
-/***********************************************************************
-**
-*/ static void Setup_File(REBREQ *file, REBCNT args, REBVAL *path)
-/*
-** Convert native action refinements to file modes.
-**
-***********************************************************************/
+//
+// Setup_File: C
+//
+// Convert native action refinements to file modes.
+//
+static void Setup_File(struct devreq_file *file, REBFLGS flags, REBVAL *path)
{
- REBSER *ser;
+ REBSER *ser;
+ REBREQ *req = AS_REBREQ(file);
- if (args & AM_OPEN_WRITE) SET_FLAG(file->modes, RFM_WRITE);
- if (args & AM_OPEN_READ) SET_FLAG(file->modes, RFM_READ);
- if (args & AM_OPEN_SEEK) SET_FLAG(file->modes, RFM_SEEK);
+ if (flags & AM_OPEN_WRITE) SET_FLAG(req->modes, RFM_WRITE);
+ if (flags & AM_OPEN_READ) SET_FLAG(req->modes, RFM_READ);
+ if (flags & AM_OPEN_SEEK) SET_FLAG(req->modes, RFM_SEEK);
- if (args & AM_OPEN_NEW) {
- SET_FLAG(file->modes, RFM_NEW);
- if (!(args & AM_OPEN_WRITE)) Trap1(RE_BAD_FILE_MODE, path);
- }
+ if (flags & AM_OPEN_NEW) {
+ SET_FLAG(req->modes, RFM_NEW);
+ if (NOT(flags & AM_OPEN_WRITE))
+ fail (Error_Bad_File_Mode_Raw(path));
+ }
- // Convert file name to OS format, let it GC later.
- if (!(ser = Value_To_OS_Path(path)))
- Trap1(RE_BAD_FILE_PATH, path);
-
- file->file.path = (REBCHR*)(ser->data);
+ if (!(ser = Value_To_OS_Path(path, TRUE)))
+ fail (Error_Bad_File_Path_Raw(path));
- SET_FLAG(file->modes, RFM_NAME_MEM);
+ // !!! Original comment said "Convert file name to OS format, let
+ // it GC later." Then it grabs the series data from inside of it.
+ // It's not clear what lifetime req->file.path is supposed to have,
+ // and saying "good until whenever the GC runs" is not rigorous.
+ // The series should be kept manual and freed when the data is
+ // no longer used, or the managed series saved in a GC-safe place
+ // as long as the bytes are needed.
+ //
+ MANAGE_SERIES(ser);
- Secure_Port(SYM_FILE, file, path, ser);
-}
+ file->path = SER_HEAD(REBCHR, ser);
+ SET_FLAG(req->modes, RFM_NAME_MEM);
-/***********************************************************************
-**
-*/ static void Cleanup_File(REBREQ *file)
-/*
-***********************************************************************/
-{
- if (GET_FLAG(file->modes, RFM_NAME_MEM)) {
- //NOTE: file->file.path will get GC'd
- file->file.path = 0;
- CLR_FLAG(file->modes, RFM_NAME_MEM);
- }
- SET_CLOSED(file);
+ Secure_Port(SYM_FILE, req, path, ser);
}
-/***********************************************************************
-**
-*/ static void Set_File_Date(REBREQ *file, REBVAL *val)
-/*
-** Set a value with the UTC date of a file.
-**
-***********************************************************************/
+//
+// Cleanup_File: C
+//
+static void Cleanup_File(struct devreq_file *file)
{
- REBOL_DAT dat;
-
- OS_FILE_TIME(file, &dat);
- Set_Date(val, &dat);
+ REBREQ *req = AS_REBREQ(file);
+
+ if (GET_FLAG(req->modes, RFM_NAME_MEM)) {
+ //NOTE: file->path will get GC'd
+ file->path = 0;
+ CLR_FLAG(req->modes, RFM_NAME_MEM);
+ }
+ SET_CLOSED(req);
}
-/***********************************************************************
-**
-*/ void Ret_Query_File(REBSER *port, REBREQ *file, REBVAL *ret)
-/*
-** Query file and set RET value to resulting STD_FILE_INFO object.
-**
-***********************************************************************/
+//
+// Ret_Query_File: C
+//
+// Query file and set RET value to resulting STD_FILE_INFO object.
+//
+void Ret_Query_File(REBCTX *port, struct devreq_file *file, REBVAL *ret)
{
- REBVAL *info = In_Object(port, STD_PORT_SCHEME, STD_SCHEME_INFO, 0);
- REBSER *obj;
- REBSER *ser;
+ REBREQ *req = AS_REBREQ(file);
- if (!info || !IS_OBJECT(info)) Trap_Port(RE_INVALID_SPEC, port, -10);
+ REBVAL *info = In_Object(port, STD_PORT_SCHEME, STD_SCHEME_INFO, 0);
- obj = CLONE_OBJECT(VAL_OBJ_FRAME(info));
+ if (!info || !IS_OBJECT(info))
+ fail (Error_On_Port(RE_INVALID_SPEC, port, -10));
- SET_OBJECT(ret, obj);
- Init_Word(OFV(obj, STD_FILE_INFO_TYPE), GET_FLAG(file->modes, RFM_DIR) ? SYM_DIR : SYM_FILE);
- SET_INTEGER(OFV(obj, STD_FILE_INFO_SIZE), file->file.size);
- Set_File_Date(file, OFV(obj, STD_FILE_INFO_DATE));
+ REBCTX *context = Copy_Context_Shallow(VAL_CONTEXT(info));
- ser = To_REBOL_Path(file->file.path, 0, OS_WIDE, 0);
+ Init_Object(ret, context);
+ Init_Word(
+ CTX_VAR(context, STD_FILE_INFO_TYPE),
+ GET_FLAG(req->modes, RFM_DIR) ? Canon(SYM_DIR) : Canon(SYM_FILE)
+ );
+ Init_Integer(
+ CTX_VAR(context, STD_FILE_INFO_SIZE), file->size
+ );
+ OS_FILE_TIME(CTX_VAR(context, STD_FILE_INFO_DATE), file);
- Set_Series(REB_FILE, OFV(obj, STD_FILE_INFO_NAME), ser);
+ REBSER *ser = To_REBOL_Path(
+ file->path, 0, (OS_WIDE ? PATH_OPT_UNI_SRC : 0)
+ );
+
+ Init_File(CTX_VAR(context, STD_FILE_INFO_NAME), ser);
}
-/***********************************************************************
-**
-*/ static void Open_File_Port(REBSER *port, REBREQ *file, REBVAL *path)
-/*
-** Open a file port.
-**
-***********************************************************************/
+//
+// Open_File_Port: C
+//
+// Open a file port.
+//
+static void Open_File_Port(REBCTX *port, struct devreq_file *file, REBVAL *path)
{
- if (Is_Port_Open(port)) Trap1(RE_ALREADY_OPEN, path);
+ REBREQ *req = AS_REBREQ(file);
+
+ if (Is_Port_Open(port))
+ fail (Error_Already_Open_Raw(path));
- if (OS_DO_DEVICE(file, RDC_OPEN) < 0) Trap_Port(RE_CANNOT_OPEN, port, file->error);
+ if (OS_DO_DEVICE(req, RDC_OPEN) < 0)
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, req->error));
- Set_Port_Open(port, TRUE);
+ Set_Port_Open(port, TRUE);
}
@@ -150,445 +157,482 @@ REBINT Mode_Syms[] = {
SYM_WORLD_READ,
SYM_WORLD_WRITE,
SYM_WORLD_EXECUTE,
- 0
+ 0
};
-/***********************************************************************
-**
-*/ static REBCNT Get_Mode_Id(REBVAL *word)
-/*
-***********************************************************************/
-{
- REBCNT id = 0;
- if (IS_WORD(word)) {
- id = Find_Int(&Mode_Syms[0], VAL_WORD_CANON(word));
- if (id == NOT_FOUND) Trap_Arg(word);
- }
- return id;
-}
+//
+// Read_File_Port: C
+//
+// Read from a file port.
+//
+static void Read_File_Port(
+ REBVAL *out,
+ REBCTX *port,
+ struct devreq_file *file,
+ REBVAL *path,
+ REBFLGS flags,
+ REBCNT len
+) {
+#ifdef NDEBUG
+ UNUSED(path);
+#else
+ assert(IS_FILE(path));
+#endif
+ UNUSED(flags);
+ REBREQ *req = AS_REBREQ(file);
-/***********************************************************************
-**
-*/ static REBCNT Set_Mode_Value(REBREQ *file, REBCNT mode, REBVAL *val)
-/*
-***********************************************************************/
-{
- return 0;
-}
+ REBSER *ser = Make_Binary(len); // read result buffer
+ Init_Binary(out, ser);
+ // Do the read, check for errors:
+ req->common.data = BIN_HEAD(ser);
+ req->length = len;
+ if (OS_DO_DEVICE(req, RDC_READ) < 0)
+ fail (Error_On_Port(RE_READ_ERROR, port, req->error));
-/***********************************************************************
-**
-*/ static void Read_File_Port(REBSER *port, REBREQ *file, REBVAL *path, REBCNT args, REBCNT len)
-/*
-** Read from a file port.
-**
-***********************************************************************/
-{
- REBSER *ser;
- REBVAL *ds = DS_RETURN;
-
- // Allocate read result buffer:
- ser = Make_Binary(len);
- Set_Series(REB_BINARY, ds, ser); //??? what if already set?
-
- // Do the read, check for errors:
- file->data = BIN_HEAD(ser);
- file->length = len;
- if (OS_DO_DEVICE(file, RDC_READ) < 0) Trap_Port(RE_READ_ERROR, port, file->error);
- SERIES_TAIL(ser) = file->actual;
- STR_TERM(ser);
-
- // Convert to string or block of strings.
- // NOTE: This code is incorrect for files read in chunks!!!
- if (args & (AM_READ_STRING | AM_READ_LINES)) {
- ser = Decode_UTF_String(BIN_HEAD(ser), file->actual, -1);
- Set_String(ds, ser);
- if (args & AM_READ_LINES) Set_Block(ds, Split_Lines(ds));
- }
+ SET_SERIES_LEN(ser, req->actual);
+ TERM_SEQUENCE(ser);
}
-/***********************************************************************
-**
-*/ static void Write_File_Port(REBREQ *file, REBVAL *data, REBCNT len, REBCNT args)
-/*
-***********************************************************************/
+//
+// Write_File_Port: C
+//
+static void Write_File_Port(struct devreq_file *file, REBVAL *data, REBCNT len, REBOOL lines)
{
- REBSER *ser;
-
- if (IS_BLOCK(data)) {
- // Form the values of the block
- // !! Could be made more efficient if we broke the FORM
- // into 32K chunks for writing.
- REB_MOLD mo = {0};
- Reset_Mold(&mo);
- if (args & AM_WRITE_LINES) {
- mo.opts = 1 << MOPT_LINES;
- }
- Mold_Value(&mo, data, 0);
- Set_String(data, mo.series); // fall into next section
- len = SERIES_TAIL(mo.series);
- }
-
- // Auto convert string to UTF-8
- if (IS_STRING(data)) {
- ser = Encode_UTF8_Value(data, len, ENCF_OS_CRLF);
- file->data = ser? BIN_HEAD(ser) : VAL_BIN_DATA(data); // No encoding may be needed
- len = SERIES_TAIL(ser);
- }
- else {
- file->data = VAL_BIN_DATA(data);
- }
- file->length = len;
- OS_DO_DEVICE(file, RDC_WRITE);
+ REBSER *ser;
+ REBREQ *req = AS_REBREQ(file);
+
+ if (IS_BLOCK(data)) {
+ // Form the values of the block
+ // !! Could be made more efficient if we broke the FORM
+ // into 32K chunks for writing.
+ REB_MOLD mo;
+ CLEARS(&mo);
+ Push_Mold(&mo);
+ if (lines)
+ mo.opts = 1 << MOPT_LINES;
+ Mold_Value(&mo, data, FALSE);
+ Init_String(data, Pop_Molded_String(&mo)); // fall to next section
+ len = VAL_LEN_HEAD(data);
+ }
+
+ // Auto convert string to UTF-8
+ if (IS_STRING(data)) {
+ ser = Make_UTF8_From_Any_String(data, len, OPT_ENC_CRLF_MAYBE);
+ MANAGE_SERIES(ser);
+ req->common.data = BIN_HEAD(ser);
+ len = SER_LEN(ser);
+ }
+ else {
+ req->common.data = VAL_BIN_AT(data);
+ }
+ req->length = len;
+ OS_DO_DEVICE(req, RDC_WRITE);
}
-/***********************************************************************
-**
-*/ static REBCNT Set_Length(const REBVAL *ds, const REBREQ *file, const REBCNT arg)
-/*
-** Computes the length of data based on the argument number
-** provided for the ARG_*_PART stack value (which, when there,
-** is always followed by the size).
-**
-** Note: converts 64bit number to 32bit. The requested size
-** can never be greater than 4GB.
-**
-***********************************************************************/
+//
+// Set_Length: C
+//
+// Note: converts 64bit number to 32bit. The requested size
+// can never be greater than 4GB. If limit isn't negative it
+// constrains the size of the requested read.
+//
+static REBCNT Set_Length(const struct devreq_file *file, REBI64 limit)
{
- REBI64 len; // maximum size
- REBI64 cnt;
- int what_if_it_changed;
-
- // Compute and bound bytes remaining:
- len = file->file.size - file->file.index; // already read
- if (len < 0) return 0;
- len &= MAX_READ_MASK; // limit the size
-
- // Return requested length:
- if (!D_REF(arg)) return (REBCNT)len;
-
- // Limit size of requested read:
- cnt = VAL_INT64(D_ARG(arg+1));
- if (cnt > len) return (REBCNT)len;
- return (REBCNT)cnt;
+ REBI64 len;
+
+ // Compute and bound bytes remaining:
+ len = file->size - file->index; // already read
+ if (len < 0) return 0;
+ len &= MAX_READ_MASK; // limit the size
+
+ // Return requested length:
+ if (limit < 0) return (REBCNT)len;
+
+ // Limit size of requested read:
+ if (limit > len) return cast(REBCNT, len);
+ return cast(REBCNT, limit);
}
-/***********************************************************************
-**
-*/ static void Set_Seek(REBREQ *file, REBVAL *arg)
-/*
-** Computes the number of bytes that should be skipped.
-**
-***********************************************************************/
+//
+// Set_Seek: C
+//
+// Computes the number of bytes that should be skipped.
+//
+static void Set_Seek(struct devreq_file *file, REBVAL *arg)
{
- REBI64 cnt;
+ REBI64 cnt;
+ REBREQ *req = AS_REBREQ(file);
- cnt = Int64s(arg, 0);
+ cnt = Int64s(arg, 0);
- if (cnt > file->file.size) cnt = file->file.size;
+ if (cnt > file->size) cnt = file->size;
- file->file.index = cnt;
+ file->index = cnt;
- SET_FLAG(file->modes, RFM_RESEEK); // force a seek
+ SET_FLAG(req->modes, RFM_RESEEK); // force a seek
}
-/***********************************************************************
-**
-*/ static int File_Actor(REBVAL *ds, REBSER *port, REBCNT action)
-/*
-** Internal port handler for files.
-**
-***********************************************************************/
+//
+// File_Actor: C
+//
+// Internal port handler for files.
+//
+static REB_R File_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
{
- REBVAL *spec;
- REBVAL *path;
- REBREQ *file = 0;
- REBCNT args = 0;
- REBCNT len;
- REBOOL opened = FALSE; // had to be opened (shortcut case)
-
- //Print("FILE ACTION: %r", Get_Action_Word(action));
-
- Validate_Port(port, action);
-
- *D_RET = *D_ARG(1);
-
- // Validate PORT fields:
- spec = BLK_SKIP(port, STD_PORT_SPEC);
- if (!IS_OBJECT(spec)) Trap1(RE_INVALID_SPEC, spec);
- path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
- if (!path) Trap1(RE_INVALID_SPEC, spec);
-
- if (IS_URL(path)) path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
- else if (!IS_FILE(path)) Trap1(RE_INVALID_SPEC, path);
-
- // Get or setup internal state data:
- file = (REBREQ*)Use_Port_State(port, RDI_FILE, sizeof(*file));
-
- switch (action) {
-
- case A_READ:
- args = Find_Refines(ds, ALL_READ_REFS);
-
- // Handle the READ %file shortcut case:
- if (!IS_OPEN(file)) {
- REBCNT nargs = AM_OPEN_READ;
- if (args & AM_READ_SEEK) nargs |= AM_OPEN_SEEK;
- Setup_File(file, nargs, path);
- Open_File_Port(port, file, path);
- opened = TRUE;
- }
-
- if (args & AM_READ_SEEK) Set_Seek(file, D_ARG(ARG_READ_INDEX));
- len = Set_Length(ds, file, ARG_READ_PART);
- Read_File_Port(port, file, path, args, len);
-
- if (opened) {
- OS_DO_DEVICE(file, RDC_CLOSE);
- Cleanup_File(file);
- Free_Port_State(port);
- }
-
- if (file->error) Trap_Port(RE_READ_ERROR, port, file->error);
- break;
-
- case A_APPEND:
- file->file.index = file->file.size;
- SET_FLAG(file->modes, RFM_RESEEK);
-
- case A_WRITE:
- args = Find_Refines(ds, ALL_WRITE_REFS);
- spec = D_ARG(2); // data (binary, string, or block)
-
- // Handle the READ %file shortcut case:
- if (!IS_OPEN(file)) {
- REBCNT nargs = AM_OPEN_WRITE;
- if (args & AM_WRITE_SEEK || args & AM_WRITE_APPEND) nargs |= AM_OPEN_SEEK;
- else nargs |= AM_OPEN_NEW;
- Setup_File(file, nargs, path);
- Open_File_Port(port, file, path);
- opened = TRUE;
- }
- else {
- if (!GET_FLAG(file->modes, RFM_WRITE)) Trap1(RE_READ_ONLY, path);
- }
-
- // Setup for /append or /seek:
- if (args & AM_WRITE_APPEND) {
- file->file.index = -1; // append
- SET_FLAG(file->modes, RFM_RESEEK);
- }
- if (args & AM_WRITE_SEEK) Set_Seek(file, D_ARG(ARG_WRITE_INDEX));
-
- // Determine length. Clip /PART to size of string if needed.
- len = VAL_LEN(spec);
- if (args & AM_WRITE_PART) {
- REBCNT n = Int32s(D_ARG(ARG_WRITE_LENGTH), 0);
- if (n <= len) len = n;
- }
-
- Write_File_Port(file, spec, len, args);
-
- if (opened) {
- OS_DO_DEVICE(file, RDC_CLOSE);
- Cleanup_File(file);
- Free_Port_State(port);
- }
-
- if (file->error) Trap1(RE_WRITE_ERROR, path);
- break;
-
- case A_OPEN:
- args = Find_Refines(ds, ALL_OPEN_REFS);
- // Default file modes if not specified:
- if (!(args & (AM_OPEN_READ | AM_OPEN_WRITE))) args |= (AM_OPEN_READ | AM_OPEN_WRITE);
- Setup_File(file, args, path);
- Open_File_Port(port, file, path); // !!! needs to change file modes to R/O if necessary
- break;
-
- case A_COPY:
- if (!IS_OPEN(file)) Trap1(RE_NOT_OPEN, path); //!!!! wrong msg
- len = Set_Length(ds, file, 2);
- Read_File_Port(port, file, path, args, len);
- break;
-
- case A_OPENQ:
- if (IS_OPEN(file)) return R_TRUE;
- return R_FALSE;
-
- case A_CLOSE:
- if (IS_OPEN(file)) {
- OS_DO_DEVICE(file, RDC_CLOSE);
- Cleanup_File(file);
- Free_Port_State(port);
- }
- break;
-
- case A_DELETE:
- if (IS_OPEN(file)) Trap1(RE_NO_DELETE, path);
- Setup_File(file, 0, path);
- if (OS_DO_DEVICE(file, RDC_DELETE) < 0 ) Trap1(RE_NO_DELETE, path);
- break;
-
- case A_RENAME:
- if (IS_OPEN(file)) Trap1(RE_NO_RENAME, path);
- else {
- REBSER *target;
-
- Setup_File(file, 0, path);
-
- // Convert file name to OS format:
- if (!(target = Value_To_OS_Path(D_ARG(2))))
- Trap1(RE_BAD_FILE_PATH, D_ARG(2));
- file->data = BIN_DATA(target);
- OS_DO_DEVICE(file, RDC_RENAME);
- Free_Series(target);
- if (file->error) Trap1(RE_NO_RENAME, path);
- }
- break;
-
- case A_CREATE:
- // !!! should it leave file open???
- if (!IS_OPEN(file)) {
- Setup_File(file, AM_OPEN_WRITE | AM_OPEN_NEW, path);
- if (OS_DO_DEVICE(file, RDC_CREATE) < 0) Trap_Port(RE_CANNOT_OPEN, port, file->error);
- OS_DO_DEVICE(file, RDC_CLOSE);
- }
- break;
-
- case A_QUERY:
- if (!IS_OPEN(file)) {
- Setup_File(file, 0, path);
- if (OS_DO_DEVICE(file, RDC_QUERY) < 0) return R_NONE;
- }
- Ret_Query_File(port, file, D_RET);
- // !!! free file path?
- break;
-
- case A_MODIFY:
- Set_Mode_Value(file, Get_Mode_Id(D_ARG(2)), D_ARG(3));
- if (!IS_OPEN(file)) {
- Setup_File(file, 0, path);
- if (OS_DO_DEVICE(file, RDC_MODIFY) < 0) return R_NONE;
- }
- return R_TRUE;
- break;
-
- case A_INDEXQ:
- SET_INTEGER(D_RET, file->file.index + 1);
- break;
-
- case A_LENGTHQ:
- SET_INTEGER(D_RET, file->file.size - file->file.index); // !clip at zero
- break;
-
- case A_HEAD:
- file->file.index = 0;
- goto seeked;
-
- case A_TAIL:
- file->file.index = file->file.size;
- goto seeked;
-
- case A_NEXT:
- file->file.index++;
- goto seeked;
-
- case A_BACK:
- if (file->file.index > 0) file->file.index--;
- goto seeked;
-
- case A_SKIP:
- file->file.index += Get_Num_Arg(D_ARG(2));
- goto seeked;
-
- case A_HEADQ:
- DECIDE(file->file.index == 0);
-
- case A_TAILQ:
- DECIDE(file->file.index >= file->file.size);
-
- case A_PASTQ:
- DECIDE(file->file.index > file->file.size);
-
- case A_CLEAR:
- // !! check for write enabled?
- SET_FLAG(file->modes, RFM_RESEEK);
- SET_FLAG(file->modes, RFM_TRUNCATE);
- file->length = 0;
- if (OS_DO_DEVICE(file, RDC_WRITE) < 0) Trap1(RE_WRITE_ERROR, path);
- break;
-
- /* Not yet implemented:
- A_AT, // 38
- A_PICK, // 41
- A_PATH, // 42
- A_PATH_SET, // 43
- A_FIND, // 44
- A_SELECT, // 45
- A_TAKE, // 49
- A_INSERT, // 50
- A_REMOVE, // 52
- A_CHANGE, // 53
- A_POKE, // 54
- A_QUERY, // 64
- A_FLUSH, // 65
- */
-
- default:
- Trap_Action(REB_PORT, action);
- }
-
- return R_RET;
-
-seeked:
- SET_FLAG(file->modes, RFM_RESEEK);
- return R_ARG1;
-
-is_true:
- return R_TRUE;
-
-is_false:
- return R_FALSE;
+ REBVAL *spec = CTX_VAR(port, STD_PORT_SPEC);
+ if (!IS_OBJECT(spec))
+ fail (Error_Invalid_Spec_Raw(spec));
+
+ REBVAL *path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
+ if (!path)
+ fail (Error_Invalid_Spec_Raw(spec));
+
+ if (IS_URL(path))
+ path = Obj_Value(spec, STD_PORT_SPEC_HEAD_PATH);
+ else if (!IS_FILE(path))
+ fail (Error_Invalid_Spec_Raw(path));
+
+ REBREQ *req = Ensure_Port_State(port, RDI_FILE);
+ struct devreq_file *file = DEVREQ_FILE(req);
+
+ // !!! R3-Alpha never implemented quite a number of operations on files,
+ // including FLUSH, POKE, etc.
+
+ switch (action) {
+
+ case SYM_READ: {
+ INCLUDE_PARAMS_OF_READ;
+
+ UNUSED(PAR(source));
+ UNUSED(PAR(string)); // handled in dispatcher
+ UNUSED(PAR(lines)); // handled in dispatcher
+
+ REBFLGS flags = 0;
+
+ // Handle the READ %file shortcut case, where the FILE! has been
+ // converted into a PORT! but has not been opened yet.
+
+ REBOOL opened;
+ if (IS_OPEN(req))
+ opened = FALSE; // was already open
+ else {
+ REBCNT nargs = AM_OPEN_READ;
+ if (REF(seek))
+ nargs |= AM_OPEN_SEEK;
+ Setup_File(file, nargs, path);
+ Open_File_Port(port, file, path);
+ opened = TRUE; // had to be opened (shortcut case)
+ }
+
+ if (REF(seek))
+ Set_Seek(file, ARG(index));
+
+ REBCNT len = Set_Length(file, REF(part) ? VAL_INT64(ARG(limit)) : -1);
+ Read_File_Port(D_OUT, port, file, path, flags, len);
+
+ if (opened) {
+ OS_DO_DEVICE(req, RDC_CLOSE);
+ Cleanup_File(file);
+ }
+
+ if (req->error)
+ fail (Error_On_Port(RE_READ_ERROR, port, req->error));
+
+ return R_OUT; }
+
+ case SYM_APPEND:
+ //
+ // !!! This is hacky, but less hacky than falling through to SYM_WRITE
+ // assuming the frame is the same for APPEND and WRITE (which is what
+ // R3-Alpha did). Review.
+ //
+ return Retrigger_Append_As_Write(frame_);
+
+ case SYM_WRITE: {
+ INCLUDE_PARAMS_OF_WRITE;
+
+ UNUSED(PAR(destination));
+
+ if (REF(allow)) {
+ UNUSED(ARG(access));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ REBVAL *data = ARG(data); // binary, string, or block
+
+ // Handle the WRITE %file shortcut case, where the FILE! is converted
+ // to a PORT! but it hasn't been opened yet.
+
+ REBOOL opened;
+ if (IS_OPEN(req)) {
+ if (!GET_FLAG(req->modes, RFM_WRITE))
+ fail (Error_Read_Only_Raw(path));
+
+ opened = FALSE; // already open
+ }
+ else {
+ REBCNT nargs = AM_OPEN_WRITE;
+ if (REF(seek) || REF(append))
+ nargs |= AM_OPEN_SEEK;
+ else
+ nargs |= AM_OPEN_NEW;
+ Setup_File(file, nargs, path);
+ Open_File_Port(port, file, path);
+ opened = TRUE;
+ }
+
+ if (REF(append)) {
+ file->index = -1; // append
+ SET_FLAG(req->modes, RFM_RESEEK);
+ }
+ if (REF(seek))
+ Set_Seek(file, ARG(index));
+
+ // Determine length. Clip /PART to size of string if needed.
+ REBCNT len = VAL_LEN_AT(data);
+ if (REF(part)) {
+ REBCNT n = Int32s(ARG(limit), 0);
+ if (n <= len) len = n;
+ }
+
+ Write_File_Port(file, data, len, REF(lines));
+
+ if (opened) {
+ OS_DO_DEVICE(req, RDC_CLOSE);
+ Cleanup_File(file);
+ }
+
+ if (req->error) {
+ DECLARE_LOCAL(i);
+ Init_Integer(i, req->error);
+ fail (Error_Write_Error_Raw(path, i));
+ }
+
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_OPEN: {
+ INCLUDE_PARAMS_OF_OPEN;
+
+ UNUSED(PAR(spec));
+ if (REF(allow)) {
+ UNUSED(ARG(access));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ REBFLGS flags = (
+ (REF(new) ? AM_OPEN_NEW : 0)
+ | (REF(read) || NOT(REF(write)) ? AM_OPEN_READ : 0)
+ | (REF(write) || NOT(REF(read)) ? AM_OPEN_WRITE : 0)
+ | (REF(seek) ? AM_OPEN_SEEK : 0)
+ | (REF(allow) ? AM_OPEN_ALLOW : 0)
+ );
+ Setup_File(file, flags, path);
+
+ // !!! need to change file modes to R/O if necessary
+
+ Open_File_Port(port, file, path);
+
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_COPY: {
+ INCLUDE_PARAMS_OF_COPY;
+
+ UNUSED(PAR(value));
+ if (REF(deep))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(types)) {
+ UNUSED(ARG(kinds));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ if (!IS_OPEN(req))
+ fail (Error_Not_Open_Raw(path)); // !!! wrong msg
+
+ REBCNT len = Set_Length(file, REF(part) ? VAL_INT64(ARG(limit)) : -1);
+ REBFLGS flags = 0;
+ Read_File_Port(D_OUT, port, file, path, flags, len);
+ return R_OUT; }
+
+ case SYM_OPEN_Q:
+ return R_FROM_BOOL(IS_OPEN(req));
+
+ case SYM_CLOSE: {
+ INCLUDE_PARAMS_OF_CLOSE;
+ UNUSED(PAR(port));
+
+ if (IS_OPEN(req)) {
+ OS_DO_DEVICE(req, RDC_CLOSE);
+ Cleanup_File(file);
+ }
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_DELETE: {
+ INCLUDE_PARAMS_OF_DELETE;
+ UNUSED(PAR(port));
+
+ if (IS_OPEN(req))
+ fail (Error_No_Delete_Raw(path));
+ Setup_File(file, 0, path);
+ if (OS_DO_DEVICE(req, RDC_DELETE) < 0)
+ fail (Error_No_Delete_Raw(path));
+
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_RENAME: {
+ INCLUDE_PARAMS_OF_RENAME;
+
+ if (IS_OPEN(req))
+ fail (Error_No_Rename_Raw(path));
+
+ Setup_File(file, 0, path);
+
+ // Convert file name to OS format:
+ //
+ REBSER *target = Value_To_OS_Path(ARG(to), TRUE);
+ if (target == NULL)
+ fail (Error_Bad_File_Path_Raw(ARG(to)));
+ req->common.data = BIN_HEAD(target);
+ OS_DO_DEVICE(req, RDC_RENAME);
+ Free_Series(target);
+ if (req->error)
+ fail (Error_No_Rename_Raw(path));
+
+ Move_Value(D_OUT, ARG(from));
+ return R_OUT; }
+
+ case SYM_CREATE: {
+ if (!IS_OPEN(req)) {
+ Setup_File(file, AM_OPEN_WRITE | AM_OPEN_NEW, path);
+ if (OS_DO_DEVICE(req, RDC_CREATE) < 0)
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, req->error));
+ OS_DO_DEVICE(req, RDC_CLOSE);
+ }
+
+ // !!! should it leave file open???
+
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_QUERY: {
+ INCLUDE_PARAMS_OF_QUERY;
+
+ UNUSED(PAR(target));
+ if (REF(mode)) {
+ UNUSED(ARG(field));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ if (!IS_OPEN(req)) {
+ Setup_File(file, 0, path);
+ if (OS_DO_DEVICE(req, RDC_QUERY) < 0) return R_BLANK;
+ }
+ Ret_Query_File(port, file, D_OUT);
+
+ // !!! free file path?
+
+ return R_OUT; }
+
+ case SYM_MODIFY: {
+ INCLUDE_PARAMS_OF_MODIFY;
+
+ UNUSED(PAR(target));
+ UNUSED(PAR(field));
+ UNUSED(PAR(value));
+
+ // !!! Set_Mode_Value() was called here, but a no-op in R3-Alpha
+ if (!IS_OPEN(req)) {
+ Setup_File(file, 0, path);
+ if (OS_DO_DEVICE(req, RDC_MODIFY) < 0) return R_BLANK;
+ }
+ return R_TRUE; }
+
+ case SYM_INDEX_OF:
+ Init_Integer(D_OUT, file->index + 1);
+ return R_OUT;
+
+ case SYM_LENGTH_OF:
+ //
+ // Comment said "clip at zero"
+ ///
+ Init_Integer(D_OUT, file->size - file->index);
+ return R_OUT;
+
+ case SYM_HEAD_OF: {
+ file->index = 0;
+ SET_FLAG(req->modes, RFM_RESEEK);
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_TAIL_OF: {
+ file->index = file->size;
+ SET_FLAG(req->modes, RFM_RESEEK);
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_SKIP: {
+ INCLUDE_PARAMS_OF_SKIP;
+
+ UNUSED(PAR(series));
+
+ file->index += Get_Num_From_Arg(ARG(offset));
+ SET_FLAG(req->modes, RFM_RESEEK);
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_HEAD_Q:
+ return R_FROM_BOOL(LOGICAL(file->index == 0));
+
+ case SYM_TAIL_Q:
+ return R_FROM_BOOL(
+ LOGICAL(file->index >= file->size)
+ );
+
+ case SYM_PAST_Q:
+ return R_FROM_BOOL(
+ LOGICAL(file->index > file->size)
+ );
+
+ case SYM_CLEAR:
+ // !! check for write enabled?
+ SET_FLAG(req->modes, RFM_RESEEK);
+ SET_FLAG(req->modes, RFM_TRUNCATE);
+ req->length = 0;
+ if (OS_DO_DEVICE(req, RDC_WRITE) < 0) {
+ DECLARE_LOCAL(i);
+ Init_Integer(i, req->error);
+ fail (Error_Write_Error_Raw(path, i));
+ }
+ return R_OUT;
+
+ default:
+ break;
+ }
+
+ fail (Error_Illegal_Action(REB_PORT, action));
}
-/***********************************************************************
-**
-*/ void Init_File_Scheme(void)
-/*
-** Associate the FILE:// scheme with the above native
-** actions. This will later be used by SET-SCHEME when
-** the scheme is initialized.
-**
-***********************************************************************/
+//
+// get-file-actor-handle: native [
+//
+// {Retrieve handle to the native actor for files}
+//
+// return: [handle!]
+// ]
+//
+REBNATIVE(get_file_actor_handle)
{
- Register_Scheme(SYM_FILE, 0, File_Actor);
+ Make_Port_Actor_Handle(D_OUT, &File_Actor);
+ return R_OUT;
}
-
-
-#ifdef low_usage
- // was in Read_File above...
- if (args & AM_READ_LINES) {
- REBYTE *bp = BIN_HEAD(ser);
- REBYTE *lp;
- REBSER *blk = Make_Block(1 + Count_Lines(bp, len));
- REBVAL *val = Append_Value(blk);
- Set_Binary(val, ser); // temp - keep it save from GC
- Set_Block(ds, blk); // accounts for GC
- while (*bp) {
- lp = bp;
- len = Next_Line(&bp);
- val = Append_Value(blk);
- Set_String(val, Decode_UTF8_Series(lp, len));
- }
- Remove_Series(blk, 0, 1); // remove temp binary
- }
-#endif
diff --git a/src/core/p-net.c b/src/core/p-net.c
index 54c0ab9ebe..688ac7c0a2 100644
--- a/src/core/p-net.c
+++ b/src/core/p-net.c
@@ -1,31 +1,32 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: p-net.c
-** Summary: network port interface
-** Section: ports
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %p-net.c
+// Summary: "network port interface"
+// Section: ports
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
@@ -34,271 +35,512 @@
#define NET_BUF_SIZE 32*1024
-/***********************************************************************
-**
-*/ static void Ret_Query_Net(REBSER *port, REBREQ *sock, REBVAL *ret)
-/*
-***********************************************************************/
+enum Transport_Types {
+ TRANSPORT_TCP,
+ TRANSPORT_UDP
+};
+
+//
+// Ret_Query_Net: C
+//
+static void Ret_Query_Net(REBCTX *port, struct devreq_net *sock, REBVAL *out)
+{
+ REBVAL *std_info = In_Object(port, STD_PORT_SCHEME, STD_SCHEME_INFO, 0);
+ REBCTX *info;
+
+ if (!std_info || !IS_OBJECT(std_info))
+ fail (Error_On_Port(RE_INVALID_SPEC, port, -10));
+
+ info = Copy_Context_Shallow(VAL_CONTEXT(std_info));
+
+ Set_Tuple(
+ CTX_VAR(info, STD_NET_INFO_LOCAL_IP),
+ cast(REBYTE*, &sock->local_ip),
+ 4
+ );
+ Init_Integer(
+ CTX_VAR(info, STD_NET_INFO_LOCAL_PORT),
+ sock->local_port
+ );
+
+ Set_Tuple(
+ CTX_VAR(info, STD_NET_INFO_REMOTE_IP),
+ cast(REBYTE*, &sock->remote_ip),
+ 4
+ );
+ Init_Integer(
+ CTX_VAR(info, STD_NET_INFO_REMOTE_PORT),
+ sock->remote_port
+ );
+
+ Init_Object(out, info);
+}
+
+
+//
+// Accept_New_Port: C
+//
+// Clone a listening port as a new accept port.
+//
+static void Accept_New_Port(REBVAL *out, REBCTX *port, struct devreq_net *sock)
+{
+ struct devreq_net *nsock;
+ REBREQ *req = AS_REBREQ(sock);
+
+ // Get temp sock struct created by the device:
+ nsock = cast(struct devreq_net*, req->common.sock);
+ if (!nsock) return; // false alarm
+ req->common.sock = AS_REBREQ(nsock)->next;
+ REBREQ *nreq = AS_REBREQ(nsock);
+ nreq->common.data = 0;
+ nreq->next = 0;
+
+ // Create a new port using ACCEPT request passed by sock->common.sock:
+ port = Copy_Context_Shallow(port);
+ Init_Port(out, port); // Also for GC protect
+
+ Init_Blank(CTX_VAR(port, STD_PORT_DATA)); // just to be sure.
+ Init_Blank(CTX_VAR(port, STD_PORT_STATE)); // just to be sure.
+
+ // Copy over the new sock data:
+ sock = cast(struct devreq_net*, Ensure_Port_State(port, RDI_NET));
+ *sock = *nsock;
+ AS_REBREQ(sock)->port = port;
+ OS_FREE(nsock); // allocated by dev_net.c (MT issues?)
+}
+
+//
+// Transport_Actor: C
+//
+static REB_R Transport_Actor(
+ REBFRM *frame_,
+ REBCTX *port,
+ REBSYM action,
+ enum Transport_Types proto
+) {
+ // Initialize the IO request
+ //
+ REBREQ *sock = Ensure_Port_State(port, RDI_NET);
+ if (proto == TRANSPORT_UDP)
+ SET_FLAG(sock->modes, RST_UDP);
+
+ REBVAL *spec = CTX_VAR(port, STD_PORT_SPEC);
+ if (!IS_OBJECT(spec))
+ fail (Error_Invalid_Port_Raw());
+
+ // sock->timeout = 4000; // where does this go? !!!
+
+ // !!! Comment said "HOW TO PREVENT OVERWRITE DURING BUSY OPERATION!!!
+ // Should it just ignore it or cause an error?"
+
+ // Actions for an unopened socket:
+
+ if (!IS_OPEN(sock)) {
+
+ switch (action) { // Ordered by frequency
+
+ case SYM_OPEN: {
+ REBVAL *arg = Obj_Value(spec, STD_PORT_SPEC_NET_HOST);
+ REBVAL *val = Obj_Value(spec, STD_PORT_SPEC_NET_PORT_ID);
+
+ if (OS_DO_DEVICE(sock, RDC_OPEN))
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, -12));
+ SET_OPEN(sock);
+
+ // Lookup host name (an extra TCP device step):
+ if (IS_STRING(arg)) {
+ sock->common.data = VAL_BIN(arg);
+ DEVREQ_NET(sock)->remote_port =
+ IS_INTEGER(val) ? VAL_INT32(val) : 80;
+
+ // Note: sets remote_ip field
+ //
+ REBINT result = OS_DO_DEVICE(sock, RDC_LOOKUP);
+ if (result < 0)
+ fail (Error_On_Port(RE_NO_CONNECT, port, sock->error));
+
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT;
+ }
+ else if (IS_TUPLE(arg)) { // Host IP specified:
+ DEVREQ_NET(sock)->remote_port =
+ IS_INTEGER(val) ? VAL_INT32(val) : 80;
+ memcpy(&(DEVREQ_NET(sock)->remote_ip), VAL_TUPLE(arg), 4);
+ break;
+ }
+ else if (IS_BLANK(arg)) { // No host, must be a LISTEN socket:
+ SET_FLAG(sock->modes, RST_LISTEN);
+ sock->common.sock = 0; // where ACCEPT requests are queued
+ DEVREQ_NET(sock)->local_port =
+ IS_INTEGER(val) ? VAL_INT32(val) : 8000;
+ break;
+ }
+ else
+ fail (Error_On_Port(RE_INVALID_SPEC, port, -10));
+ break; }
+
+ case SYM_CLOSE:
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT;
+
+ case SYM_OPEN_Q:
+ return R_FALSE;
+
+ case SYM_UPDATE: // allowed after a close
+ break;
+
+ default:
+ fail (Error_On_Port(RE_NOT_OPEN, port, -12));
+ }
+ }
+
+ // Actions for an open socket:
+
+ switch (action) { // Ordered by frequency
+
+ case SYM_UPDATE: {
+ //
+ // Update the port object after a READ or WRITE operation.
+ // This is normally called by the WAKE-UP function.
+ //
+ REBVAL *port_data = CTX_VAR(port, STD_PORT_DATA);
+ if (sock->command == RDC_READ) {
+ if (ANY_BINSTR(port_data)) {
+ SET_SERIES_LEN(
+ VAL_SERIES(port_data),
+ VAL_LEN_HEAD(port_data) + sock->actual
+ );
+ }
+ }
+ else if (sock->command == RDC_WRITE) {
+ Init_Blank(port_data); // Write is done.
+ }
+ return R_BLANK; }
+
+ case SYM_READ: {
+ INCLUDE_PARAMS_OF_READ;
+
+ UNUSED(PAR(source));
+
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(seek)) {
+ UNUSED(ARG(index));
+ fail (Error_Bad_Refines_Raw());
+ }
+ UNUSED(PAR(string)); // handled in dispatcher
+ UNUSED(PAR(lines)); // handled in dispatcher
+
+ // Read data into a buffer, expanding the buffer if needed.
+ // If no length is given, program must stop it at some point.
+ if (
+ !GET_FLAG(sock->modes, RST_UDP)
+ && !GET_FLAG(sock->state, RSM_CONNECT)
+ ) {
+ fail (Error_On_Port(RE_NOT_CONNECTED, port, -15));
+ }
+
+ // Setup the read buffer (allocate a buffer if needed):
+ //
+ REBVAL *port_data = CTX_VAR(port, STD_PORT_DATA);
+ REBSER *buffer;
+ if (!IS_STRING(port_data) && !IS_BINARY(port_data)) {
+ buffer = Make_Binary(NET_BUF_SIZE);
+ Init_Binary(port_data, buffer);
+ }
+ else {
+ buffer = VAL_SERIES(port_data);
+ assert(BYTE_SIZE(buffer));
+
+ if (SER_AVAIL(buffer) < NET_BUF_SIZE/2)
+ Extend_Series(buffer, NET_BUF_SIZE);
+ }
+
+ sock->length = SER_AVAIL(buffer);
+ sock->common.data = BIN_TAIL(buffer); // write at tail
+ sock->actual = 0; // actual for THIS read (not for total)
+
+ // Note: recv can happen immediately
+ //
+ REBINT result = OS_DO_DEVICE(sock, RDC_READ);
+ if (result < 0)
+ fail (Error_On_Port(RE_READ_ERROR, port, sock->error));
+
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_WRITE: {
+ INCLUDE_PARAMS_OF_WRITE;
+
+ UNUSED(PAR(destination));
+
+ if (REF(seek)) {
+ UNUSED(ARG(index));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(append))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(allow)) {
+ UNUSED(ARG(access));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(lines))
+ fail (Error_Bad_Refines_Raw());
+
+ // Write the entire argument string to the network.
+ // The lower level write code continues until done.
+
+ if (
+ !GET_FLAG(sock->modes, RST_UDP)
+ && !GET_FLAG(sock->state, RSM_CONNECT)
+ ){
+ fail (Error_On_Port(RE_NOT_CONNECTED, port, -15));
+ }
+
+ // Determine length. Clip /PART to size of string if needed.
+ REBVAL *data = ARG(data);
+
+ REBCNT len = VAL_LEN_AT(data);
+ if (REF(part)) {
+ REBCNT n = Int32s(ARG(limit), 0);
+ if (n <= len)
+ len = n;
+ }
+
+ // Setup the write:
+
+ Move_Value(CTX_VAR(port, STD_PORT_DATA), data); // keep it GC safe
+ sock->length = len;
+ sock->common.data = VAL_BIN_AT(data);
+ sock->actual = 0;
+
+ // Note: send can happen immediately
+ //
+ REBINT result = OS_DO_DEVICE(sock, RDC_WRITE);
+ if (result < 0)
+ fail (Error_On_Port(RE_WRITE_ERROR, port, sock->error));
+
+ if (result == DR_DONE)
+ Init_Blank(CTX_VAR(port, STD_PORT_DATA));
+
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_PICK_P: {
+ INCLUDE_PARAMS_OF_PICK_P;
+ UNUSED(PAR(location));
+
+ // FIRST server-port returns new port connection.
+ //
+ REBCNT len = Get_Num_From_Arg(ARG(picker));
+ if (len == 1 && GET_FLAG(sock->modes, RST_LISTEN) && sock->common.data)
+ Accept_New_Port(SINK(D_OUT), port, DEVREQ_NET(sock));
+ else
+ fail (Error_Out_Of_Range(ARG(picker)));
+ return R_OUT; }
+
+ case SYM_QUERY: {
+ //
+ // Get specific information - the scheme's info object.
+ // Special notation allows just getting part of the info.
+ //
+ Ret_Query_Net(port, DEVREQ_NET(sock), D_OUT);
+ return R_OUT; }
+
+ case SYM_OPEN_Q:
+ //
+ // Connect for clients, bind for servers:
+ //
+ return R_FROM_BOOL (
+ LOGICAL(sock->state & ((1 << RSM_CONNECT) | (1 << RSM_BIND)))
+ );
+
+ case SYM_CLOSE: {
+ if (IS_OPEN(sock)) {
+ OS_DO_DEVICE(sock, RDC_CLOSE);
+ SET_CLOSED(sock);
+ }
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_LENGTH_OF: {
+ REBVAL *port_data = CTX_VAR(port, STD_PORT_DATA);
+ Init_Integer(
+ D_OUT,
+ ANY_SERIES(port_data) ? VAL_LEN_HEAD(port_data) : 0
+ );
+ return R_OUT; }
+
+ case SYM_OPEN: {
+ REBINT result = OS_DO_DEVICE(sock, RDC_CONNECT);
+ if (result < 0)
+ fail (Error_On_Port(RE_NO_CONNECT, port, sock->error));
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ case SYM_DELETE: {
+ //
+ // !!! Comment said "Temporary to TEST error handler!"
+ //
+ REBVAL *event = Append_Event(); // sets signal
+ VAL_RESET_HEADER(event, REB_EVENT); // has more space, if needed
+ VAL_EVENT_TYPE(event) = EVT_ERROR;
+ VAL_EVENT_DATA(event) = 101;
+ VAL_EVENT_REQ(event) = sock;
+ Move_Value(D_OUT, CTX_VALUE(port));
+ return R_OUT; }
+
+ default:
+ break;
+ }
+
+ fail (Error_Illegal_Action(REB_PORT, action));
+}
+
+
+//
+// TCP_Actor: C
+//
+static REB_R TCP_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
{
- REBVAL *info = In_Object(port, STD_PORT_SCHEME, STD_SCHEME_INFO, 0);
- REBSER *obj;
+ return Transport_Actor(frame_, port, action, TRANSPORT_TCP);
+}
+
- if (!info || !IS_OBJECT(info)) Trap_Port(RE_INVALID_SPEC, port, -10);
+//
+// UDP_Actor: C
+//
+static REB_R UDP_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
+{
+ return Transport_Actor(frame_, port, action, TRANSPORT_UDP);
+}
- obj = CLONE_OBJECT(VAL_OBJ_FRAME(info));
- SET_OBJECT(ret, obj);
- Set_Tuple(OFV(obj, STD_NET_INFO_LOCAL_IP), (REBYTE*)&sock->net.local_ip, 4);
- Set_Tuple(OFV(obj, STD_NET_INFO_REMOTE_IP), (REBYTE*)&sock->net.remote_ip, 4);
- SET_INTEGER(OFV(obj, STD_NET_INFO_LOCAL_PORT), sock->net.local_port);
- SET_INTEGER(OFV(obj, STD_NET_INFO_REMOTE_PORT), sock->net.remote_port);
+//
+// get-tcp-actor-handle: native [
+//
+// {Retrieve handle to the native actor for TCP}
+//
+// return: [handle!]
+// ]
+//
+REBNATIVE(get_tcp_actor_handle)
+{
+ Make_Port_Actor_Handle(D_OUT, &TCP_Actor);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ static void Accept_New_Port(REBVAL *ds, REBSER *port, REBREQ *sock)
-/*
-** Clone a listening port as a new accept port.
-**
-***********************************************************************/
+//
+// get-udp-actor-handle: native [
+//
+// {Retrieve handle to the native actor for UDP}
+//
+// return: [handle!]
+// ]
+//
+REBNATIVE(get_udp_actor_handle)
{
- REBREQ *nsock;
-
- // Get temp sock struct created by the device:
- nsock = sock->sock;
- if (!nsock) return; // false alarm
- sock->sock = nsock->next;
- nsock->data = 0;
- nsock->next = 0;
-
- // Create a new port using ACCEPT request passed by sock->sock:
- port = Copy_Block(port, 0);
- SET_PORT(DS_RETURN, port); // Also for GC protect
- SET_NONE(OFV(port, STD_PORT_DATA)); // just to be sure.
- SET_NONE(OFV(port, STD_PORT_STATE)); // just to be sure.
-
- // Copy over the new sock data:
- sock = Use_Port_State(port, RDI_NET, sizeof(*sock));
- *sock = *nsock;
- sock->clen = sizeof(*sock);
- sock->port = port;
- OS_FREE(nsock); // allocated by dev_net.c (MT issues?)
+ Make_Port_Actor_Handle(D_OUT, &UDP_Actor);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ static int TCP_Actor(REBVAL *ds, REBSER *port, REBCNT action)
-/*
-***********************************************************************/
+//
+// set-udp-multicast: native [
+//
+// {Join (or leave) an IPv4 multicast group}
+//
+// return: []
+// port [port!]
+// {An open UDP port}
+// group [tuple!]
+// {Multicast group to join (224.0.0.0 to 239.255.255.255)}
+// member [tuple!]
+// {Member to add to multicast group (use 0.0.0.0 for INADDR_ANY)}
+// /drop
+// {Leave the group (default is to add)}
+// ]
+//
+REBNATIVE(set_udp_multicast)
+//
+// !!! SET-MODES was never standardized or implemented for R3-Alpha, so there
+// was no RDC_MODIFY written. While it is tempting to just go ahead and
+// start writing `setsockopt` calls right here in this file, that would mean
+// adding platform-sensitive network includes into the core.
+//
+// Ultimately, the desire is that ports would be modules--consisting of some
+// Rebol code, and some C code (possibly with platform-conditional libs).
+// This is the direction for the extension model, where the artificial limit
+// of having "native port actors" that can't just do the OS calls they want
+// will disappear.
+//
+// Until that happens, we want to pass this through to the Reb_Device layer
+// somehow. It's not easy to see how to modify this "REBREQ" which is
+// actually *the port's state* to pass it the necessary information for this
+// request. Hence the cheat is just to pass it the frame, and then let
+// Reb_Device implementations go ahead and use the extension API to pick
+// that frame apart.
{
- REBREQ *sock; // IO request
- REBVAL *spec; // port spec
- REBVAL *arg; // action argument value
- REBVAL *val; // e.g. port number value
- REBINT result; // IO result
- REBCNT refs; // refinement argument flags
- REBCNT len; // generic length
- REBSER *ser; // simplifier
-
- Validate_Port(port, action);
-
- *D_RET = *D_ARG(1);
- arg = D_ARG(2);
- refs = 0;
-
- sock = Use_Port_State(port, RDI_NET, sizeof(*sock));
- //Debug_Fmt("Sock: %x", sock);
- spec = OFV(port, STD_PORT_SPEC);
- if (!IS_OBJECT(spec)) Trap0(RE_INVALID_PORT);
-
- // sock->timeout = 4000; // where does this go? !!!
-
- // HOW TO PREVENT OVERWRITE DURING BUSY OPERATION!!!
- // Should it just ignore it or cause an error?
-
- // Actions for an unopened socket:
- if (!IS_OPEN(sock)) {
-
- switch (action) { // Ordered by frequency
-
- case A_OPEN:
-
- arg = Obj_Value(spec, STD_PORT_SPEC_NET_HOST);
- val = Obj_Value(spec, STD_PORT_SPEC_NET_PORT_ID);
-
- if (OS_DO_DEVICE(sock, RDC_OPEN)) Trap_Port(RE_CANNOT_OPEN, port, -12);
- SET_OPEN(sock);
-
- // Lookup host name (an extra TCP device step):
- if (IS_STRING(arg)) {
- sock->data = VAL_BIN(arg);
- sock->net.remote_port = IS_INTEGER(val) ? VAL_INT32(val) : 80;
- result = OS_DO_DEVICE(sock, RDC_LOOKUP); // sets remote_ip field
- if (result < 0) Trap_Port(RE_NO_CONNECT, port, sock->error);
- return R_RET;
- }
-
- // Host IP specified:
- else if (IS_TUPLE(arg)) {
- sock->net.remote_port = IS_INTEGER(val) ? VAL_INT32(val) : 80;
- memcpy(&sock->net.remote_ip, VAL_TUPLE(arg), 4);
- break;
- }
-
- // No host, must be a LISTEN socket:
- else if (IS_NONE(arg)) {
- SET_FLAG(sock->modes, RST_LISTEN);
- sock->data = 0; // where ACCEPT requests are queued
- sock->net.local_port = IS_INTEGER(val) ? VAL_INT32(val) : 8000;
- break;
- }
- else Trap_Port(RE_INVALID_SPEC, port, -10);
-
- case A_CLOSE:
- return R_RET;
-
- case A_OPENQ:
- return R_FALSE;
-
- case A_UPDATE: // allowed after a close
- break;
-
- default:
- Trap_Port(RE_NOT_OPEN, port, -12);
- }
- }
-
- // Actions for an open socket:
- switch (action) { // Ordered by frequency
-
- case A_UPDATE:
- // Update the port object after a READ or WRITE operation.
- // This is normally called by the WAKE-UP function.
- arg = OFV(port, STD_PORT_DATA);
- if (sock->command == RDC_READ) {
- if (ANY_BINSTR(arg)) VAL_TAIL(arg) += sock->actual;
- }
- else if (sock->command == RDC_WRITE) {
- SET_NONE(arg); // Write is done.
- }
- return R_NONE;
-
- case A_READ:
- // Read data into a buffer, expanding the buffer if needed.
- // If no length is given, program must stop it at some point.
- refs = Find_Refines(ds, ALL_READ_REFS);
- if (!GET_FLAG(sock->state, RSM_CONNECT)) Trap_Port(RE_NOT_CONNECTED, port, -15);
-
- // Setup the read buffer (allocate a buffer if needed):
- arg = OFV(port, STD_PORT_DATA);
- if (!IS_STRING(arg) && !IS_BINARY(arg)) {
- Set_Binary(arg, Make_Binary(NET_BUF_SIZE));
- }
- ser = VAL_SERIES(arg);
- sock->length = SERIES_AVAIL(ser); // space available
- if (sock->length < NET_BUF_SIZE/2) Extend_Series(ser, NET_BUF_SIZE);
- sock->length = SERIES_AVAIL(ser);
- sock->data = STR_TAIL(ser); // write at tail
- //if (SERIES_TAIL(ser) == 0)
- sock->actual = 0; // Actual for THIS read, not for total.
-
- //Print("(max read length %d)", sock->length);
- result = OS_DO_DEVICE(sock, RDC_READ); // recv can happen immediately
- if (result < 0) Trap_Port(RE_READ_ERROR, port, sock->error);
- break;
-
- case A_WRITE:
- // Write the entire argument string to the network.
- // The lower level write code continues until done.
-
- refs = Find_Refines(ds, ALL_WRITE_REFS);
- if (!GET_FLAG(sock->state, RSM_CONNECT)) Trap_Port(RE_NOT_CONNECTED, port, -15);
-
- // Determine length. Clip /PART to size of string if needed.
- spec = D_ARG(2);
- len = VAL_LEN(spec);
- if (refs & AM_WRITE_PART) {
- REBCNT n = Int32s(D_ARG(ARG_WRITE_LENGTH), 0);
- if (n <= len) len = n;
- }
-
- // Setup the write:
- *OFV(port, STD_PORT_DATA) = *spec; // keep it GC safe
- sock->length = len;
- sock->data = VAL_BIN_DATA(spec);
- sock->actual = 0;
-
- //Print("(write length %d)", len);
- result = OS_DO_DEVICE(sock, RDC_WRITE); // send can happen immediately
- if (result < 0) Trap_Port(RE_WRITE_ERROR, port, sock->error);
- if (result == DR_DONE) SET_NONE(OFV(port, STD_PORT_DATA));
- break;
-
- case A_PICK:
- // FIRST server-port returns new port connection.
- len = Get_Num_Arg(arg); // Position
- if (len == 1 && GET_FLAG(sock->modes, RST_LISTEN) && sock->data)
- Accept_New_Port(ds, port, sock); // sets D_RET
- else
- Trap_Range(arg);
- break;
-
- case A_QUERY:
- // Get specific information - the scheme's info object.
- // Special notation allows just getting part of the info.
- Ret_Query_Net(port, sock, D_RET);
- break;
-
- case A_OPENQ:
- // Connect for clients, bind for servers:
- if (sock->state & ((1<error);
- break;
- //Trap_Port(RE_ALREADY_OPEN, port);
-
- case A_DELETE: // Temporary to TEST error handler!
- {
- REBVAL *event = Append_Event(); // sets signal
- VAL_SET(event, REB_EVENT); // (has more space, if we need it)
- VAL_EVENT_TYPE(event) = EVT_ERROR;
- VAL_EVENT_DATA(event) = 101;
- VAL_EVENT_REQ(event) = sock;
- }
- break;
-
- default:
- Trap_Action(REB_PORT, action);
- }
-
- return R_RET;
+ INCLUDE_PARAMS_OF_SET_UDP_MULTICAST;
+
+ REBCTX *port = VAL_CONTEXT(ARG(port));
+ REBREQ *sock = Ensure_Port_State(port, RDI_NET);
+
+ sock->common.data = cast(REBYTE*, frame_);
+
+ // sock->command is going to just be RDC_MODIFY, so all there is to go
+ // by is the data and flags. Since RFC3171 specifies IPv4 multicast
+ // address space...how about that?
+ //
+ sock->flags = 3171;
+
+ UNUSED(ARG(group));
+ UNUSED(ARG(member));
+ UNUSED(REF(drop));
+
+ REBINT result = OS_DO_DEVICE(sock, RDC_MODIFY);
+ if (result < 0)
+ fail ("SET-UDP-MULTICAST failure"); // can device layer just fail()?
+
+ return R_VOID;
}
-/***********************************************************************
-**
-*/ void Init_TCP_Scheme(void)
-/*
-***********************************************************************/
+//
+// set-udp-ttl: native [
+//
+// {Set the TTL of a UDP port}
+//
+// return: []
+// port [port!]
+// {An open UDP port}
+// ttl [integer!]
+// {0 = local machine only, 1 = subnet (default), or up to 255}
+// ]
+//
+REBNATIVE(set_udp_ttl)
{
- Register_Scheme(SYM_TCP, 0, TCP_Actor);
+ INCLUDE_PARAMS_OF_SET_UDP_TTL;
+
+ REBCTX *port = VAL_CONTEXT(ARG(port));
+ REBREQ *sock = Ensure_Port_State(port, RDI_NET);
+
+ sock->common.data = cast(REBYTE*, frame_);
+
+ // sock->command is going to just be RDC_MODIFY, so all there is to go
+ // by is the data and flags. Since RFC2365 specifies IPv4 multicast
+ // administrative boundaries...how about that?
+ //
+ sock->flags = 2365;
+
+ UNUSED(ARG(ttl));
+
+ REBINT result = OS_DO_DEVICE(sock, RDC_MODIFY);
+ if (result < 0)
+ fail ("SET-UDP-TTL failure"); // can device layer just fail()?
+
+ return R_VOID;
}
diff --git a/src/core/p-serial.c b/src/core/p-serial.c
new file mode 100644
index 0000000000..c38e579269
--- /dev/null
+++ b/src/core/p-serial.c
@@ -0,0 +1,294 @@
+//
+// File: %p-serial.c
+// Summary: "serial port interface"
+// Section: ports
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2013 REBOL Technologies
+// Copyright 2013-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+
+#include "sys-core.h"
+#include "reb-evtypes.h"
+
+#define MAX_SERIAL_DEV_PATH 128
+
+//
+// Serial_Actor: C
+//
+static REB_R Serial_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
+{
+ REBVAL *spec; // port spec
+ REBVAL *arg; // action argument value
+ REBINT result; // IO result
+ REBCNT len; // generic length
+ REBSER *ser; // simplifier
+ REBVAL *path;
+
+ Move_Value(D_OUT, D_ARG(1));
+
+ // Validate PORT fields:
+ spec = CTX_VAR(port, STD_PORT_SPEC);
+ if (!IS_OBJECT(spec)) fail (Error_Invalid_Port_Raw());
+ path = Obj_Value(spec, STD_PORT_SPEC_HEAD_REF);
+ if (!path) fail (Error_Invalid_Spec_Raw(spec));
+
+ //if (!IS_FILE(path)) fail (Error_Invalid_Spec_Raw(path));
+
+ REBREQ *req = Ensure_Port_State(port, RDI_SERIAL);
+ struct devreq_serial *serial = DEVREQ_SERIAL(req);
+
+ // Actions for an unopened serial port:
+ if (!IS_OPEN(req)) {
+
+ switch (action) {
+
+ case SYM_OPEN:
+ arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PATH);
+ if (! (IS_FILE(arg) || IS_STRING(arg) || IS_BINARY(arg)))
+ fail (Error_Invalid_Port_Arg_Raw(arg));
+
+ serial->path = ALLOC_N(REBCHR, MAX_SERIAL_DEV_PATH);
+ OS_STRNCPY(
+ serial->path,
+ //
+ // !!! This is assuming VAL_DATA contains native chars.
+ // Should it? (2 bytes on windows, 1 byte on linux/mac)
+ //
+ SER_AT(REBCHR, VAL_SERIES(arg), VAL_INDEX(arg)),
+ MAX_SERIAL_DEV_PATH
+ );
+ arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_SPEED);
+ if (! IS_INTEGER(arg))
+ fail (Error_Invalid_Port_Arg_Raw(arg));
+
+ serial->baud = VAL_INT32(arg);
+ //Secure_Port(SYM_SERIAL, ???, path, ser);
+ arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_DATA_SIZE);
+ if (!IS_INTEGER(arg)
+ || VAL_INT64(arg) < 5
+ || VAL_INT64(arg) > 8
+ ) {
+ fail (Error_Invalid_Port_Arg_Raw(arg));
+ }
+ serial->data_bits = VAL_INT32(arg);
+
+ arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_STOP_BITS);
+ if (!IS_INTEGER(arg)
+ || VAL_INT64(arg) < 1
+ || VAL_INT64(arg) > 2
+ ) {
+ fail (Error_Invalid_Port_Arg_Raw(arg));
+ }
+ serial->stop_bits = VAL_INT32(arg);
+
+ arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_PARITY);
+ if (IS_BLANK(arg)) {
+ serial->parity = SERIAL_PARITY_NONE;
+ } else {
+ if (!IS_WORD(arg))
+ fail (Error_Invalid_Port_Arg_Raw(arg));
+
+ switch (VAL_WORD_SYM(arg)) {
+ case SYM_ODD:
+ serial->parity = SERIAL_PARITY_ODD;
+ break;
+ case SYM_EVEN:
+ serial->parity = SERIAL_PARITY_EVEN;
+ break;
+ default:
+ fail (Error_Invalid_Port_Arg_Raw(arg));
+ }
+ }
+
+ arg = Obj_Value(spec, STD_PORT_SPEC_SERIAL_FLOW_CONTROL);
+ if (IS_BLANK(arg)) {
+ serial->flow_control = SERIAL_FLOW_CONTROL_NONE;
+ } else {
+ if (!IS_WORD(arg))
+ fail (Error_Invalid_Port_Arg_Raw(arg));
+
+ switch (VAL_WORD_SYM(arg)) {
+ case SYM_HARDWARE:
+ serial->flow_control = SERIAL_FLOW_CONTROL_HARDWARE;
+ break;
+ case SYM_SOFTWARE:
+ serial->flow_control = SERIAL_FLOW_CONTROL_SOFTWARE;
+ break;
+ default:
+ fail (Error_Invalid_Port_Arg_Raw(arg));
+ }
+ }
+
+ if (OS_DO_DEVICE(req, RDC_OPEN))
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, -12));
+ SET_OPEN(req);
+ return R_OUT;
+
+ case SYM_CLOSE:
+ return R_OUT;
+
+ case SYM_OPEN_Q:
+ return R_FALSE;
+
+ default:
+ fail (Error_On_Port(RE_NOT_OPEN, port, -12));
+ }
+ }
+
+ // Actions for an open socket:
+ switch (action) {
+
+ case SYM_READ: {
+ INCLUDE_PARAMS_OF_READ;
+
+ UNUSED(PAR(source));
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(seek)) {
+ UNUSED(ARG(index));
+ fail (Error_Bad_Refines_Raw());
+ }
+ UNUSED(PAR(string)); // handled in dispatcher
+ UNUSED(PAR(lines)); // handled in dispatcher
+
+ // Setup the read buffer (allocate a buffer if needed):
+ arg = CTX_VAR(port, STD_PORT_DATA);
+ if (!IS_STRING(arg) && !IS_BINARY(arg)) {
+ Init_Binary(arg, Make_Binary(32000));
+ }
+ ser = VAL_SERIES(arg);
+ req->length = SER_AVAIL(ser); // space available
+ if (req->length < 32000/2) Extend_Series(ser, 32000);
+ req->length = SER_AVAIL(ser);
+
+ // This used STR_TAIL (obsolete, equivalent to BIN_TAIL) but was it
+ // sure the series was byte sized? Added in a check.
+ assert(BYTE_SIZE(ser));
+ req->common.data = BIN_TAIL(ser); // write at tail
+
+ //if (SER_LEN(ser) == 0)
+ req->actual = 0; // Actual for THIS read, not for total.
+#ifdef DEBUG_SERIAL
+ printf("(max read length %d)", req->length);
+#endif
+ result = OS_DO_DEVICE(req, RDC_READ); // recv can happen immediately
+ if (result < 0) fail (Error_On_Port(RE_READ_ERROR, port, req->error));
+#ifdef DEBUG_SERIAL
+ for (len = 0; len < req->actual; len++) {
+ if (len % 16 == 0) printf("\n");
+ printf("%02x ", req->common.data[len]);
+ }
+ printf("\n");
+#endif
+ Move_Value(D_OUT, arg);
+ return R_OUT; }
+
+ case SYM_WRITE: {
+ INCLUDE_PARAMS_OF_WRITE;
+
+ UNUSED(PAR(destination));
+
+ if (REF(seek)) {
+ UNUSED(ARG(index));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(append))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(allow)) {
+ UNUSED(ARG(access));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(lines))
+ fail (Error_Bad_Refines_Raw());
+
+ // Determine length. Clip /PART to size of string if needed.
+ REBVAL *data = ARG(data);
+ len = VAL_LEN_AT(data);
+ if (REF(part)) {
+ REBCNT n = Int32s(ARG(limit), 0);
+ if (n <= len) len = n;
+ }
+
+ // Setup the write:
+ Move_Value(CTX_VAR(port, STD_PORT_DATA), data); // keep it GC safe
+ req->length = len;
+ req->common.data = VAL_BIN_AT(data);
+ req->actual = 0;
+
+ //Print("(write length %d)", len);
+ result = OS_DO_DEVICE(req, RDC_WRITE); // send can happen immediately
+ if (result < 0)
+ fail (Error_On_Port(RE_WRITE_ERROR, port, req->error));
+ break; }
+
+ case SYM_UPDATE:
+ // Update the port object after a READ or WRITE operation.
+ // This is normally called by the WAKE-UP function.
+ arg = CTX_VAR(port, STD_PORT_DATA);
+ if (req->command == RDC_READ) {
+ if (ANY_BINSTR(arg)) {
+ SET_SERIES_LEN(
+ VAL_SERIES(arg),
+ VAL_LEN_HEAD(arg) + req->actual
+ );
+ }
+ }
+ else if (req->command == RDC_WRITE) {
+ Init_Blank(arg); // Write is done.
+ }
+ return R_BLANK;
+
+ case SYM_OPEN_Q:
+ return R_TRUE;
+
+ case SYM_CLOSE:
+ if (IS_OPEN(req)) {
+ OS_DO_DEVICE(req, RDC_CLOSE);
+ SET_CLOSED(req);
+ }
+ break;
+
+ default:
+ fail (Error_Illegal_Action(REB_PORT, action));
+ }
+
+ return R_OUT;
+}
+
+
+//
+// get-serial-actor-handle: native [
+//
+// {Retrieve handle to the native actor for the serial port}
+//
+// return: [handle!]
+// ]
+//
+REBNATIVE(get_serial_actor_handle)
+{
+ Make_Port_Actor_Handle(D_OUT, &Serial_Actor);
+ return R_OUT;
+}
diff --git a/src/core/p-signal.c b/src/core/p-signal.c
new file mode 100644
index 0000000000..09e8bbbff9
--- /dev/null
+++ b/src/core/p-signal.c
@@ -0,0 +1,304 @@
+//
+// File: %p-signal.c
+// Summary: "signal port interface"
+// Section: ports
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2014 Atronix Engineering, Inc.
+// Copyright 2014-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+
+#include "sys-core.h"
+
+#ifdef HAS_POSIX_SIGNAL
+#include
+
+static void update(struct devreq_posix_signal *signal, REBINT len, REBVAL *arg)
+{
+ REBREQ *req = AS_REBREQ(signal);
+ const siginfo_t *sig = cast(siginfo_t *, req->common.data);
+ int i = 0;
+ const REBYTE signal_no[] = "signal-no";
+ const REBYTE code[] = "code";
+ const REBYTE source_pid[] = "source-pid";
+ const REBYTE source_uid[] = "source-uid";
+
+ Extend_Series(VAL_SERIES(arg), len);
+
+ for (i = 0; i < len; i ++) {
+ REBCTX *obj = Alloc_Context(REB_OBJECT, 8);
+ REBVAL *val = Append_Context(
+ obj, NULL, Intern_UTF8_Managed(signal_no, LEN_BYTES(signal_no))
+ );
+ Init_Integer(val, sig[i].si_signo);
+
+ val = Append_Context(
+ obj, NULL, Intern_UTF8_Managed(code, LEN_BYTES(code))
+ );
+ Init_Integer(val, sig[i].si_code);
+ val = Append_Context(
+ obj, NULL, Intern_UTF8_Managed(source_pid, LEN_BYTES(source_pid))
+ );
+ Init_Integer(val, sig[i].si_pid);
+ val = Append_Context(
+ obj, NULL, Intern_UTF8_Managed(source_uid, LEN_BYTES(source_uid))
+ );
+ Init_Integer(val, sig[i].si_uid);
+
+ Init_Object(Alloc_Tail_Array(VAL_ARRAY(arg)), obj);
+ }
+
+ req->actual = 0; /* avoid duplicate updates */
+}
+
+static int sig_word_num(REBSTR *canon)
+{
+ switch (STR_SYMBOL(canon)) {
+ case SYM_SIGALRM:
+ return SIGALRM;
+ case SYM_SIGABRT:
+ return SIGABRT;
+ case SYM_SIGBUS:
+ return SIGBUS;
+ case SYM_SIGCHLD:
+ return SIGCHLD;
+ case SYM_SIGCONT:
+ return SIGCONT;
+ case SYM_SIGFPE:
+ return SIGFPE;
+ case SYM_SIGHUP:
+ return SIGHUP;
+ case SYM_SIGILL:
+ return SIGILL;
+ case SYM_SIGINT:
+ return SIGINT;
+/* can't be caught
+ case SYM_SIGKILL:
+ return SIGKILL;
+*/
+ case SYM_SIGPIPE:
+ return SIGPIPE;
+ case SYM_SIGQUIT:
+ return SIGQUIT;
+ case SYM_SIGSEGV:
+ return SIGSEGV;
+/* can't be caught
+ case SYM_SIGSTOP:
+ return SIGSTOP;
+*/
+ case SYM_SIGTERM:
+ return SIGTERM;
+ case SYM_SIGTTIN:
+ return SIGTTIN;
+ case SYM_SIGTTOU:
+ return SIGTTOU;
+ case SYM_SIGUSR1:
+ return SIGUSR1;
+ case SYM_SIGUSR2:
+ return SIGUSR2;
+ case SYM_SIGTSTP:
+ return SIGTSTP;
+ case SYM_SIGPOLL:
+ return SIGPOLL;
+ case SYM_SIGPROF:
+ return SIGPROF;
+ case SYM_SIGSYS:
+ return SIGSYS;
+ case SYM_SIGTRAP:
+ return SIGTRAP;
+ case SYM_SIGURG:
+ return SIGURG;
+ case SYM_SIGVTALRM:
+ return SIGVTALRM;
+ case SYM_SIGXCPU:
+ return SIGXCPU;
+ case SYM_SIGXFSZ:
+ return SIGXFSZ;
+ default: {
+ DECLARE_LOCAL (word);
+ Init_Word(word, canon);
+
+ fail (Error_Invalid_Spec_Raw(word));
+ }
+ }
+}
+
+//
+// Signal_Actor: C
+//
+static REB_R Signal_Actor(REBFRM *frame_, REBCTX *port, REBSYM action)
+{
+ REBINT result;
+ REBVAL *arg;
+ REBINT len;
+ REBSER *ser;
+ REBVAL *spec;
+ REBVAL *val;
+ RELVAL *sig;
+
+ REBREQ *req = Ensure_Port_State(port, RDI_SIGNAL);
+ struct devreq_posix_signal *signal = DEVREQ_POSIX_SIGNAL(req);
+ spec = CTX_VAR(port, STD_PORT_SPEC);
+
+ if (!IS_OPEN(req)) {
+ switch (action) {
+ case SYM_READ:
+ case SYM_OPEN:
+ val = Obj_Value(spec, STD_PORT_SPEC_SIGNAL_MASK);
+ if (!IS_BLOCK(val))
+ fail (Error_Invalid_Spec_Raw(val));
+
+ sigemptyset(&signal->mask);
+ for(sig = VAL_ARRAY_AT_HEAD(val, 0); NOT_END(sig); sig ++) {
+ if (IS_WORD(sig)) {
+ /* handle the special word "ALL" */
+ if (VAL_WORD_SYM(sig) == SYM_ALL) {
+ if (sigfillset(&signal->mask) < 0) {
+ // !!! Needs better error
+ fail (Error_Invalid_Spec_Raw(sig));
+ }
+ break;
+ }
+
+ if (
+ sigaddset(
+ &signal->mask,
+ sig_word_num(VAL_WORD_CANON(sig))
+ ) < 0
+ ) {
+ fail (Error_Invalid_Spec_Raw(sig));
+ }
+ }
+ else
+ fail (Error_Invalid_Spec_Raw(sig));
+ }
+
+ if (OS_DO_DEVICE(req, RDC_OPEN))
+ fail (Error_On_Port(RE_CANNOT_OPEN, port, req->error));
+ if (action == SYM_OPEN) {
+ Move_Value(D_OUT, D_ARG(1)); // port
+ return R_OUT;
+ }
+ break;
+
+ case SYM_CLOSE:
+ return R_OUT;
+
+ case SYM_OPEN_Q:
+ return R_FALSE;
+
+ case SYM_UPDATE: // allowed after a close
+ break;
+
+ default:
+ fail (Error_On_Port(RE_NOT_OPEN, port, -12));
+ }
+ }
+
+ switch (action) {
+ case SYM_UPDATE:
+ // Update the port object after a READ or WRITE operation.
+ // This is normally called by the WAKE-UP function.
+ arg = CTX_VAR(port, STD_PORT_DATA);
+ if (req->command == RDC_READ) {
+ len = req->actual;
+ if (len > 0) {
+ update(signal, len, arg);
+ }
+ }
+ return R_BLANK;
+
+ case SYM_READ:
+ // This device is opened on the READ:
+ // Issue the read request:
+ arg = CTX_VAR(port, STD_PORT_DATA);
+
+ len = req->length = 8;
+ ser = Make_Binary(len * sizeof(siginfo_t));
+ req->common.data = BIN_HEAD(ser);
+ result = OS_DO_DEVICE(req, RDC_READ);
+ if (result < 0) {
+ Free_Series(ser);
+ fail (Error_On_Port(RE_READ_ERROR, port, req->error));
+ }
+
+ arg = CTX_VAR(port, STD_PORT_DATA);
+ if (!IS_BLOCK(arg))
+ Init_Block(arg, Make_Array(len));
+
+ len = req->actual;
+
+ if (len > 0) {
+ update(signal, len, arg);
+ Free_Series(ser);
+ Move_Value(D_OUT, arg);
+ return R_OUT;
+ } else {
+ Free_Series(ser);
+ return R_BLANK;
+ }
+
+ case SYM_CLOSE:
+ OS_DO_DEVICE(req, RDC_CLOSE);
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT;
+
+ case SYM_OPEN_Q:
+ return R_TRUE;
+
+ case SYM_OPEN: {
+ fail (Error_Already_Open_Raw(D_ARG(1)));
+ }
+
+ default:
+ fail (Error_Illegal_Action(REB_PORT, action));
+ }
+
+ return R_OUT;
+}
+
+#endif //HAS_POSIX_SIGNAL
+
+
+//
+// get-signal-actor-handle: native [
+//
+// {Retrieve handle to the native actor for POSIX signals}
+//
+// return: [handle!]
+// ]
+//
+REBNATIVE(get_signal_actor_handle)
+//
+// !!! The native scanner isn't smart enough to notice REBNATIVE() inside a
+// disabled #ifdef, so a definition for this has to be provided... even if
+// it's not a build where it should be available.
+{
+#ifdef HAS_POSIX_SIGNAL
+ Make_Port_Actor_Handle(D_OUT, &Signal_Actor);
+ return R_OUT;
+#else
+ UNUSED(frame_);
+ fail ("GET-SIGNAL-ACTOR-HANDLE only works in builds with POSIX signals");
+#endif
+}
diff --git a/src/core/p-timer.c b/src/core/p-timer.c
index ba5b614852..b4a84d569b 100644
--- a/src/core/p-timer.c
+++ b/src/core/p-timer.c
@@ -1,128 +1,142 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: p-timer.c
-** Summary: timer port interface
-** Section: ports
-** Author: Carl Sassenrath
-** Notes: NOT IMPLEMENTED
-**
-***********************************************************************/
+//
+// File: %p-timer.c
+// Summary: "timer port interface"
+// Section: ports
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// NOT IMPLEMENTED
+//
/*
- General idea of usage:
-
- t: open timer://name
- write t 10 ; set timer - also allow: 1.23 1:23
- wait t
- clear t ; reset or delete?
- read t ; get timer value
- t/awake: func [event] [print "timer!"]
- one-shot vs restart timer
+ General idea of usage:
+
+ t: open timer://name
+ write t 10 ; set timer - also allow: 1.23 1:23
+ wait t
+ clear t ; reset or delete?
+ read t ; get timer value
+ t/awake: func [event] [print "timer!"]
+ one-shot vs restart timer
*/
#include "sys-core.h"
-/***********************************************************************
-**
-*/ static int Event_Actor(REBVAL *ds, REBSER *port, REBCNT action)
-/*
-***********************************************************************/
+//
+// Timer_Actor: C
+//
+static REB_R Timer_Actor(REBFRM *frame_, REBCTX *port, REBCNT action)
{
- REBVAL *spec;
- REBVAL *state;
- REBCNT result;
- REBVAL *arg;
- REBVAL save_port;
-
- Validate_Port(port, action);
-
- arg = D_ARG(2);
- *D_RET = *D_ARG(1);
-
- // Validate and fetch relevant PORT fields:
- state = BLK_SKIP(port, STD_PORT_STATE);
- spec = BLK_SKIP(port, STD_PORT_SPEC);
- if (!IS_OBJECT(spec)) Trap1(RE_INVALID_SPEC, spec);
-
- // Get or setup internal state data:
- if (!IS_BLOCK(state)) Set_Block(state, Make_Block(127));
-
- switch (action) {
-
- case A_UPDATE:
- return R_NONE;
-
- // Normal block actions done on events:
- case A_POKE:
- if (!IS_EVENT(D_ARG(3))) Trap_Arg(D_ARG(3));
- goto act_blk;
- case A_INSERT:
- case A_APPEND:
- //case A_PATH: // not allowed: port/foo is port object field access
- //case A_PATH_SET: // not allowed: above
- if (!IS_EVENT(arg)) Trap_Arg(arg);
- case A_PICK:
+ REBVAL *spec;
+ REBVAL *state;
+ REBCNT result;
+ REBVAL *arg;
+
+ DECLARE_LOCAL (save_port);
+
+ arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+ Move_Value(D_OUT, D_ARG(1));
+
+ // Validate and fetch relevant PORT fields:
+ state = CTX_VAR(port, STD_PORT_STATE);
+ spec = CTX_VAR(port, STD_PORT_SPEC);
+ if (!IS_OBJECT(spec)) fail (Error_Invalid_Spec_Raw(spec));
+
+ // Get or setup internal state data:
+ if (!IS_BLOCK(state))
+ Init_Block(state, Make_Array(127));
+
+ switch (action) {
+
+ case SYM_UPDATE:
+ return R_BLANK;
+
+ // Normal block actions done on events:
+ case SYM_POKE:
+ if (NOT(IS_EVENT(D_ARG(3))))
+ fail (D_ARG(3));
+ goto act_blk;
+ case SYM_INSERT:
+ case SYM_APPEND:
+ //case SYM_PATH: // not allowed: port/foo is port object field access
+ //case SYM_PATH_SET: // not allowed: above
+ if (NOT(IS_EVENT(arg)))
+ fail (arg);
+ case SYM_PICK_P:
act_blk:
- save_port = *D_ARG(1); // save for return
- *D_ARG(1) = *state;
- result = T_Block(ds, action);
- SET_FLAG(Eval_Signals, SIG_EVENT_PORT);
- if (action == A_INSERT || action == A_APPEND || action == A_REMOVE) {
- *D_RET = save_port;
- break;
- }
- return result; // return condition
-
- case A_CLEAR:
- VAL_TAIL(state) = 0;
- VAL_BLK_TERM(state);
- CLR_FLAG(Eval_Signals, SIG_EVENT_PORT);
- break;
-
- case A_LENGTHQ:
- SET_INTEGER(D_RET, VAL_TAIL(state));
- break;
-
- case A_OPEN:
- if (!req) { //!!!
- req = OS_MAKE_DEVREQ(RDI_EVENT);
- SET_OPEN(req);
- OS_DO_DEVICE(req, RDC_CONNECT); // stays queued
- }
- break;
-
- default:
- Trap_Action(REB_PORT, action);
- }
-
- return R_RET;
+ Move_Value(&save_port, D_ARG(1)); // save for return
+ Move_Value(D_ARG(1), state);
+ result = T_Block(ds, action);
+ SET_SIGNAL(SIG_EVENT_PORT);
+ if (
+ action == SYM_INSERT
+ || action == SYM_APPEND
+ || action == SYM_REMOVE
+ ){
+ Move_Value(D_OUT, save_port);
+ break;
+ }
+ return result; // return condition
+
+ case SYM_CLEAR:
+ RESET_ARRAY(state);
+ CLR_FLAG(Eval_Signals, SIG_EVENT_PORT);
+ break;
+
+ case SYM_LENGTH_OF:
+ Init_Integer(D_OUT, VAL_LEN_HEAD(state));
+ break;
+
+ case SYM_OPEN: {
+ INCLUDE_PARAMS_OF_OPEN;
+ if (!req) { //!!!
+ req = OS_MAKE_DEVREQ(RDI_EVENT);
+ SET_OPEN(req);
+ OS_DO_DEVICE(req, RDC_CONNECT); // stays queued
+ }
+ break; }
+
+ default:
+ fail (Error_Illegal_Action(REB_PORT, action));
+ }
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ void Init_Timer_Scheme(void)
-/*
-***********************************************************************/
+// !!! Timer code is currently not used
+//x
+//x get-timer-actor-handle: native [
+//x
+//x {Retrieve handle to the native actor for timer features}
+//x
+//x return: [handle!]
+//x ]
+//x
+REBNATIVE(get_timer_actor_handle)
{
- Register_Scheme(SYM_TIMER, 0, Event_Actor);
+ Make_Port_Actor_Handle(D_OUT, &Timer_Actor);
+ return R_OUT;
}
diff --git a/src/core/s-cases.c b/src/core/s-cases.c
index 131fdb538a..10352e3989 100644
--- a/src/core/s-cases.c
+++ b/src/core/s-cases.c
@@ -1,940 +1,951 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: s-cases.c
-** Summary: unicode string case handling
-** Section: strings
-** Notes:
-**
-***********************************************************************/
+//
+// File: %s-cases.c
+// Summary: "unicode string case handling"
+// Section: strings
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
// Unicode 5.0 case folding table:
-static short const Char_Cases[] = {
- 0x0041, 0x0061, // LATIN CAPITAL LETTER A
- 0x0042, 0x0062, // LATIN CAPITAL LETTER B
- 0x0043, 0x0063, // LATIN CAPITAL LETTER C
- 0x0044, 0x0064, // LATIN CAPITAL LETTER D
- 0x0045, 0x0065, // LATIN CAPITAL LETTER E
- 0x0046, 0x0066, // LATIN CAPITAL LETTER F
- 0x0047, 0x0067, // LATIN CAPITAL LETTER G
- 0x0048, 0x0068, // LATIN CAPITAL LETTER H
- 0x0049, 0x0069, // LATIN CAPITAL LETTER I
- 0x004A, 0x006A, // LATIN CAPITAL LETTER J
- 0x004B, 0x006B, // LATIN CAPITAL LETTER K
- 0x004C, 0x006C, // LATIN CAPITAL LETTER L
- 0x004D, 0x006D, // LATIN CAPITAL LETTER M
- 0x004E, 0x006E, // LATIN CAPITAL LETTER N
- 0x004F, 0x006F, // LATIN CAPITAL LETTER O
- 0x0050, 0x0070, // LATIN CAPITAL LETTER P
- 0x0051, 0x0071, // LATIN CAPITAL LETTER Q
- 0x0052, 0x0072, // LATIN CAPITAL LETTER R
- 0x0053, 0x0073, // LATIN CAPITAL LETTER S
- 0x0054, 0x0074, // LATIN CAPITAL LETTER T
- 0x0055, 0x0075, // LATIN CAPITAL LETTER U
- 0x0056, 0x0076, // LATIN CAPITAL LETTER V
- 0x0057, 0x0077, // LATIN CAPITAL LETTER W
- 0x0058, 0x0078, // LATIN CAPITAL LETTER X
- 0x0059, 0x0079, // LATIN CAPITAL LETTER Y
- 0x005A, 0x007A, // LATIN CAPITAL LETTER Z
- 0x00B5, 0x03BC, // MICRO SIGN
- 0x00C0, 0x00E0, // LATIN CAPITAL LETTER A WITH GRAVE
- 0x00C1, 0x00E1, // LATIN CAPITAL LETTER A WITH ACUTE
- 0x00C2, 0x00E2, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX
- 0x00C3, 0x00E3, // LATIN CAPITAL LETTER A WITH TILDE
- 0x00C4, 0x00E4, // LATIN CAPITAL LETTER A WITH DIAERESIS
- 0x00C5, 0x00E5, // LATIN CAPITAL LETTER A WITH RING ABOVE
- 0x00C6, 0x00E6, // LATIN CAPITAL LETTER AE
- 0x00C7, 0x00E7, // LATIN CAPITAL LETTER C WITH CEDILLA
- 0x00C8, 0x00E8, // LATIN CAPITAL LETTER E WITH GRAVE
- 0x00C9, 0x00E9, // LATIN CAPITAL LETTER E WITH ACUTE
- 0x00CA, 0x00EA, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX
- 0x00CB, 0x00EB, // LATIN CAPITAL LETTER E WITH DIAERESIS
- 0x00CC, 0x00EC, // LATIN CAPITAL LETTER I WITH GRAVE
- 0x00CD, 0x00ED, // LATIN CAPITAL LETTER I WITH ACUTE
- 0x00CE, 0x00EE, // LATIN CAPITAL LETTER I WITH CIRCUMFLEX
- 0x00CF, 0x00EF, // LATIN CAPITAL LETTER I WITH DIAERESIS
- 0x00D0, 0x00F0, // LATIN CAPITAL LETTER ETH
- 0x00D1, 0x00F1, // LATIN CAPITAL LETTER N WITH TILDE
- 0x00D2, 0x00F2, // LATIN CAPITAL LETTER O WITH GRAVE
- 0x00D3, 0x00F3, // LATIN CAPITAL LETTER O WITH ACUTE
- 0x00D4, 0x00F4, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX
- 0x00D5, 0x00F5, // LATIN CAPITAL LETTER O WITH TILDE
- 0x00D6, 0x00F6, // LATIN CAPITAL LETTER O WITH DIAERESIS
- 0x00D8, 0x00F8, // LATIN CAPITAL LETTER O WITH STROKE
- 0x00D9, 0x00F9, // LATIN CAPITAL LETTER U WITH GRAVE
- 0x00DA, 0x00FA, // LATIN CAPITAL LETTER U WITH ACUTE
- 0x00DB, 0x00FB, // LATIN CAPITAL LETTER U WITH CIRCUMFLEX
- 0x00DC, 0x00FC, // LATIN CAPITAL LETTER U WITH DIAERESIS
- 0x00DD, 0x00FD, // LATIN CAPITAL LETTER Y WITH ACUTE
- 0x00DE, 0x00FE, // LATIN CAPITAL LETTER THORN
- 0x0100, 0x0101, // LATIN CAPITAL LETTER A WITH MACRON
- 0x0102, 0x0103, // LATIN CAPITAL LETTER A WITH BREVE
- 0x0104, 0x0105, // LATIN CAPITAL LETTER A WITH OGONEK
- 0x0106, 0x0107, // LATIN CAPITAL LETTER C WITH ACUTE
- 0x0108, 0x0109, // LATIN CAPITAL LETTER C WITH CIRCUMFLEX
- 0x010A, 0x010B, // LATIN CAPITAL LETTER C WITH DOT ABOVE
- 0x010C, 0x010D, // LATIN CAPITAL LETTER C WITH CARON
- 0x010E, 0x010F, // LATIN CAPITAL LETTER D WITH CARON
- 0x0110, 0x0111, // LATIN CAPITAL LETTER D WITH STROKE
- 0x0112, 0x0113, // LATIN CAPITAL LETTER E WITH MACRON
- 0x0114, 0x0115, // LATIN CAPITAL LETTER E WITH BREVE
- 0x0116, 0x0117, // LATIN CAPITAL LETTER E WITH DOT ABOVE
- 0x0118, 0x0119, // LATIN CAPITAL LETTER E WITH OGONEK
- 0x011A, 0x011B, // LATIN CAPITAL LETTER E WITH CARON
- 0x011C, 0x011D, // LATIN CAPITAL LETTER G WITH CIRCUMFLEX
- 0x011E, 0x011F, // LATIN CAPITAL LETTER G WITH BREVE
- 0x0120, 0x0121, // LATIN CAPITAL LETTER G WITH DOT ABOVE
- 0x0122, 0x0123, // LATIN CAPITAL LETTER G WITH CEDILLA
- 0x0124, 0x0125, // LATIN CAPITAL LETTER H WITH CIRCUMFLEX
- 0x0126, 0x0127, // LATIN CAPITAL LETTER H WITH STROKE
- 0x0128, 0x0129, // LATIN CAPITAL LETTER I WITH TILDE
- 0x012A, 0x012B, // LATIN CAPITAL LETTER I WITH MACRON
- 0x012C, 0x012D, // LATIN CAPITAL LETTER I WITH BREVE
- 0x012E, 0x012F, // LATIN CAPITAL LETTER I WITH OGONEK
- 0x0132, 0x0133, // LATIN CAPITAL LIGATURE IJ
- 0x0134, 0x0135, // LATIN CAPITAL LETTER J WITH CIRCUMFLEX
- 0x0136, 0x0137, // LATIN CAPITAL LETTER K WITH CEDILLA
- 0x0139, 0x013A, // LATIN CAPITAL LETTER L WITH ACUTE
- 0x013B, 0x013C, // LATIN CAPITAL LETTER L WITH CEDILLA
- 0x013D, 0x013E, // LATIN CAPITAL LETTER L WITH CARON
- 0x013F, 0x0140, // LATIN CAPITAL LETTER L WITH MIDDLE DOT
- 0x0141, 0x0142, // LATIN CAPITAL LETTER L WITH STROKE
- 0x0143, 0x0144, // LATIN CAPITAL LETTER N WITH ACUTE
- 0x0145, 0x0146, // LATIN CAPITAL LETTER N WITH CEDILLA
- 0x0147, 0x0148, // LATIN CAPITAL LETTER N WITH CARON
- 0x014A, 0x014B, // LATIN CAPITAL LETTER ENG
- 0x014C, 0x014D, // LATIN CAPITAL LETTER O WITH MACRON
- 0x014E, 0x014F, // LATIN CAPITAL LETTER O WITH BREVE
- 0x0150, 0x0151, // LATIN CAPITAL LETTER O WITH DOUBLE ACUTE
- 0x0152, 0x0153, // LATIN CAPITAL LIGATURE OE
- 0x0154, 0x0155, // LATIN CAPITAL LETTER R WITH ACUTE
- 0x0156, 0x0157, // LATIN CAPITAL LETTER R WITH CEDILLA
- 0x0158, 0x0159, // LATIN CAPITAL LETTER R WITH CARON
- 0x015A, 0x015B, // LATIN CAPITAL LETTER S WITH ACUTE
- 0x015C, 0x015D, // LATIN CAPITAL LETTER S WITH CIRCUMFLEX
- 0x015E, 0x015F, // LATIN CAPITAL LETTER S WITH CEDILLA
- 0x0160, 0x0161, // LATIN CAPITAL LETTER S WITH CARON
- 0x0162, 0x0163, // LATIN CAPITAL LETTER T WITH CEDILLA
- 0x0164, 0x0165, // LATIN CAPITAL LETTER T WITH CARON
- 0x0166, 0x0167, // LATIN CAPITAL LETTER T WITH STROKE
- 0x0168, 0x0169, // LATIN CAPITAL LETTER U WITH TILDE
- 0x016A, 0x016B, // LATIN CAPITAL LETTER U WITH MACRON
- 0x016C, 0x016D, // LATIN CAPITAL LETTER U WITH BREVE
- 0x016E, 0x016F, // LATIN CAPITAL LETTER U WITH RING ABOVE
- 0x0170, 0x0171, // LATIN CAPITAL LETTER U WITH DOUBLE ACUTE
- 0x0172, 0x0173, // LATIN CAPITAL LETTER U WITH OGONEK
- 0x0174, 0x0175, // LATIN CAPITAL LETTER W WITH CIRCUMFLEX
- 0x0176, 0x0177, // LATIN CAPITAL LETTER Y WITH CIRCUMFLEX
- 0x0178, 0x00FF, // LATIN CAPITAL LETTER Y WITH DIAERESIS
- 0x0179, 0x017A, // LATIN CAPITAL LETTER Z WITH ACUTE
- 0x017B, 0x017C, // LATIN CAPITAL LETTER Z WITH DOT ABOVE
- 0x017D, 0x017E, // LATIN CAPITAL LETTER Z WITH CARON
- 0x017F, 0x0073, // LATIN SMALL LETTER LONG S
- 0x0181, 0x0253, // LATIN CAPITAL LETTER B WITH HOOK
- 0x0182, 0x0183, // LATIN CAPITAL LETTER B WITH TOPBAR
- 0x0184, 0x0185, // LATIN CAPITAL LETTER TONE SIX
- 0x0186, 0x0254, // LATIN CAPITAL LETTER OPEN O
- 0x0187, 0x0188, // LATIN CAPITAL LETTER C WITH HOOK
- 0x0189, 0x0256, // LATIN CAPITAL LETTER AFRICAN D
- 0x018A, 0x0257, // LATIN CAPITAL LETTER D WITH HOOK
- 0x018B, 0x018C, // LATIN CAPITAL LETTER D WITH TOPBAR
- 0x018E, 0x01DD, // LATIN CAPITAL LETTER REVERSED E
- 0x018F, 0x0259, // LATIN CAPITAL LETTER SCHWA
- 0x0190, 0x025B, // LATIN CAPITAL LETTER OPEN E
- 0x0191, 0x0192, // LATIN CAPITAL LETTER F WITH HOOK
- 0x0193, 0x0260, // LATIN CAPITAL LETTER G WITH HOOK
- 0x0194, 0x0263, // LATIN CAPITAL LETTER GAMMA
- 0x0196, 0x0269, // LATIN CAPITAL LETTER IOTA
- 0x0197, 0x0268, // LATIN CAPITAL LETTER I WITH STROKE
- 0x0198, 0x0199, // LATIN CAPITAL LETTER K WITH HOOK
- 0x019C, 0x026F, // LATIN CAPITAL LETTER TURNED M
- 0x019D, 0x0272, // LATIN CAPITAL LETTER N WITH LEFT HOOK
- 0x019F, 0x0275, // LATIN CAPITAL LETTER O WITH MIDDLE TILDE
- 0x01A0, 0x01A1, // LATIN CAPITAL LETTER O WITH HORN
- 0x01A2, 0x01A3, // LATIN CAPITAL LETTER OI
- 0x01A4, 0x01A5, // LATIN CAPITAL LETTER P WITH HOOK
- 0x01A6, 0x0280, // LATIN LETTER YR
- 0x01A7, 0x01A8, // LATIN CAPITAL LETTER TONE TWO
- 0x01A9, 0x0283, // LATIN CAPITAL LETTER ESH
- 0x01AC, 0x01AD, // LATIN CAPITAL LETTER T WITH HOOK
- 0x01AE, 0x0288, // LATIN CAPITAL LETTER T WITH RETROFLEX HOOK
- 0x01AF, 0x01B0, // LATIN CAPITAL LETTER U WITH HORN
- 0x01B1, 0x028A, // LATIN CAPITAL LETTER UPSILON
- 0x01B2, 0x028B, // LATIN CAPITAL LETTER V WITH HOOK
- 0x01B3, 0x01B4, // LATIN CAPITAL LETTER Y WITH HOOK
- 0x01B5, 0x01B6, // LATIN CAPITAL LETTER Z WITH STROKE
- 0x01B7, 0x0292, // LATIN CAPITAL LETTER EZH
- 0x01B8, 0x01B9, // LATIN CAPITAL LETTER EZH REVERSED
- 0x01BC, 0x01BD, // LATIN CAPITAL LETTER TONE FIVE
- 0x01C4, 0x01C6, // LATIN CAPITAL LETTER DZ WITH CARON
- 0x01C5, 0x01C6, // LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON
- 0x01C7, 0x01C9, // LATIN CAPITAL LETTER LJ
- 0x01C8, 0x01C9, // LATIN CAPITAL LETTER L WITH SMALL LETTER J
- 0x01CA, 0x01CC, // LATIN CAPITAL LETTER NJ
- 0x01CB, 0x01CC, // LATIN CAPITAL LETTER N WITH SMALL LETTER J
- 0x01CD, 0x01CE, // LATIN CAPITAL LETTER A WITH CARON
- 0x01CF, 0x01D0, // LATIN CAPITAL LETTER I WITH CARON
- 0x01D1, 0x01D2, // LATIN CAPITAL LETTER O WITH CARON
- 0x01D3, 0x01D4, // LATIN CAPITAL LETTER U WITH CARON
- 0x01D5, 0x01D6, // LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON
- 0x01D7, 0x01D8, // LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE
- 0x01D9, 0x01DA, // LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON
- 0x01DB, 0x01DC, // LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE
- 0x01DE, 0x01DF, // LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON
- 0x01E0, 0x01E1, // LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON
- 0x01E2, 0x01E3, // LATIN CAPITAL LETTER AE WITH MACRON
- 0x01E4, 0x01E5, // LATIN CAPITAL LETTER G WITH STROKE
- 0x01E6, 0x01E7, // LATIN CAPITAL LETTER G WITH CARON
- 0x01E8, 0x01E9, // LATIN CAPITAL LETTER K WITH CARON
- 0x01EA, 0x01EB, // LATIN CAPITAL LETTER O WITH OGONEK
- 0x01EC, 0x01ED, // LATIN CAPITAL LETTER O WITH OGONEK AND MACRON
- 0x01EE, 0x01EF, // LATIN CAPITAL LETTER EZH WITH CARON
- 0x01F1, 0x01F3, // LATIN CAPITAL LETTER DZ
- 0x01F2, 0x01F3, // LATIN CAPITAL LETTER D WITH SMALL LETTER Z
- 0x01F4, 0x01F5, // LATIN CAPITAL LETTER G WITH ACUTE
- 0x01F6, 0x0195, // LATIN CAPITAL LETTER HWAIR
- 0x01F7, 0x01BF, // LATIN CAPITAL LETTER WYNN
- 0x01F8, 0x01F9, // LATIN CAPITAL LETTER N WITH GRAVE
- 0x01FA, 0x01FB, // LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE
- 0x01FC, 0x01FD, // LATIN CAPITAL LETTER AE WITH ACUTE
- 0x01FE, 0x01FF, // LATIN CAPITAL LETTER O WITH STROKE AND ACUTE
- 0x0200, 0x0201, // LATIN CAPITAL LETTER A WITH DOUBLE GRAVE
- 0x0202, 0x0203, // LATIN CAPITAL LETTER A WITH INVERTED BREVE
- 0x0204, 0x0205, // LATIN CAPITAL LETTER E WITH DOUBLE GRAVE
- 0x0206, 0x0207, // LATIN CAPITAL LETTER E WITH INVERTED BREVE
- 0x0208, 0x0209, // LATIN CAPITAL LETTER I WITH DOUBLE GRAVE
- 0x020A, 0x020B, // LATIN CAPITAL LETTER I WITH INVERTED BREVE
- 0x020C, 0x020D, // LATIN CAPITAL LETTER O WITH DOUBLE GRAVE
- 0x020E, 0x020F, // LATIN CAPITAL LETTER O WITH INVERTED BREVE
- 0x0210, 0x0211, // LATIN CAPITAL LETTER R WITH DOUBLE GRAVE
- 0x0212, 0x0213, // LATIN CAPITAL LETTER R WITH INVERTED BREVE
- 0x0214, 0x0215, // LATIN CAPITAL LETTER U WITH DOUBLE GRAVE
- 0x0216, 0x0217, // LATIN CAPITAL LETTER U WITH INVERTED BREVE
- 0x0218, 0x0219, // LATIN CAPITAL LETTER S WITH COMMA BELOW
- 0x021A, 0x021B, // LATIN CAPITAL LETTER T WITH COMMA BELOW
- 0x021C, 0x021D, // LATIN CAPITAL LETTER YOGH
- 0x021E, 0x021F, // LATIN CAPITAL LETTER H WITH CARON
- 0x0220, 0x019E, // LATIN CAPITAL LETTER N WITH LONG RIGHT LEG
- 0x0222, 0x0223, // LATIN CAPITAL LETTER OU
- 0x0224, 0x0225, // LATIN CAPITAL LETTER Z WITH HOOK
- 0x0226, 0x0227, // LATIN CAPITAL LETTER A WITH DOT ABOVE
- 0x0228, 0x0229, // LATIN CAPITAL LETTER E WITH CEDILLA
- 0x022A, 0x022B, // LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON
- 0x022C, 0x022D, // LATIN CAPITAL LETTER O WITH TILDE AND MACRON
- 0x022E, 0x022F, // LATIN CAPITAL LETTER O WITH DOT ABOVE
- 0x0230, 0x0231, // LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON
- 0x0232, 0x0233, // LATIN CAPITAL LETTER Y WITH MACRON
- 0x023A, 0x2C65, // LATIN CAPITAL LETTER A WITH STROKE
- 0x023B, 0x023C, // LATIN CAPITAL LETTER C WITH STROKE
- 0x023D, 0x019A, // LATIN CAPITAL LETTER L WITH BAR
- 0x023E, 0x2C66, // LATIN CAPITAL LETTER T WITH DIAGONAL STROKE
- 0x0241, 0x0242, // LATIN CAPITAL LETTER GLOTTAL STOP
- 0x0243, 0x0180, // LATIN CAPITAL LETTER B WITH STROKE
- 0x0244, 0x0289, // LATIN CAPITAL LETTER U BAR
- 0x0245, 0x028C, // LATIN CAPITAL LETTER TURNED V
- 0x0246, 0x0247, // LATIN CAPITAL LETTER E WITH STROKE
- 0x0248, 0x0249, // LATIN CAPITAL LETTER J WITH STROKE
- 0x024A, 0x024B, // LATIN CAPITAL LETTER SMALL Q WITH HOOK TAIL
- 0x024C, 0x024D, // LATIN CAPITAL LETTER R WITH STROKE
- 0x024E, 0x024F, // LATIN CAPITAL LETTER Y WITH STROKE
- 0x0345, 0x03B9, // COMBINING GREEK YPOGEGRAMMENI
- 0x0386, 0x03AC, // GREEK CAPITAL LETTER ALPHA WITH TONOS
- 0x0388, 0x03AD, // GREEK CAPITAL LETTER EPSILON WITH TONOS
- 0x0389, 0x03AE, // GREEK CAPITAL LETTER ETA WITH TONOS
- 0x038A, 0x03AF, // GREEK CAPITAL LETTER IOTA WITH TONOS
- 0x038C, 0x03CC, // GREEK CAPITAL LETTER OMICRON WITH TONOS
- 0x038E, 0x03CD, // GREEK CAPITAL LETTER UPSILON WITH TONOS
- 0x038F, 0x03CE, // GREEK CAPITAL LETTER OMEGA WITH TONOS
- 0x0391, 0x03B1, // GREEK CAPITAL LETTER ALPHA
- 0x0392, 0x03B2, // GREEK CAPITAL LETTER BETA
- 0x0393, 0x03B3, // GREEK CAPITAL LETTER GAMMA
- 0x0394, 0x03B4, // GREEK CAPITAL LETTER DELTA
- 0x0395, 0x03B5, // GREEK CAPITAL LETTER EPSILON
- 0x0396, 0x03B6, // GREEK CAPITAL LETTER ZETA
- 0x0397, 0x03B7, // GREEK CAPITAL LETTER ETA
- 0x0398, 0x03B8, // GREEK CAPITAL LETTER THETA
- 0x0399, 0x03B9, // GREEK CAPITAL LETTER IOTA
- 0x039A, 0x03BA, // GREEK CAPITAL LETTER KAPPA
- 0x039B, 0x03BB, // GREEK CAPITAL LETTER LAMDA
- 0x039C, 0x03BC, // GREEK CAPITAL LETTER MU
- 0x039D, 0x03BD, // GREEK CAPITAL LETTER NU
- 0x039E, 0x03BE, // GREEK CAPITAL LETTER XI
- 0x039F, 0x03BF, // GREEK CAPITAL LETTER OMICRON
- 0x03A0, 0x03C0, // GREEK CAPITAL LETTER PI
- 0x03A1, 0x03C1, // GREEK CAPITAL LETTER RHO
- 0x03A3, 0x03C3, // GREEK CAPITAL LETTER SIGMA
- 0x03A4, 0x03C4, // GREEK CAPITAL LETTER TAU
- 0x03A5, 0x03C5, // GREEK CAPITAL LETTER UPSILON
- 0x03A6, 0x03C6, // GREEK CAPITAL LETTER PHI
- 0x03A7, 0x03C7, // GREEK CAPITAL LETTER CHI
- 0x03A8, 0x03C8, // GREEK CAPITAL LETTER PSI
- 0x03A9, 0x03C9, // GREEK CAPITAL LETTER OMEGA
- 0x03AA, 0x03CA, // GREEK CAPITAL LETTER IOTA WITH DIALYTIKA
- 0x03AB, 0x03CB, // GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA
- 0x03C2, 0x03C3, // GREEK SMALL LETTER FINAL SIGMA
- 0x03D0, 0x03B2, // GREEK BETA SYMBOL
- 0x03D1, 0x03B8, // GREEK THETA SYMBOL
- 0x03D5, 0x03C6, // GREEK PHI SYMBOL
- 0x03D6, 0x03C0, // GREEK PI SYMBOL
- 0x03D8, 0x03D9, // GREEK LETTER ARCHAIC KOPPA
- 0x03DA, 0x03DB, // GREEK LETTER STIGMA
- 0x03DC, 0x03DD, // GREEK LETTER DIGAMMA
- 0x03DE, 0x03DF, // GREEK LETTER KOPPA
- 0x03E0, 0x03E1, // GREEK LETTER SAMPI
- 0x03E2, 0x03E3, // COPTIC CAPITAL LETTER SHEI
- 0x03E4, 0x03E5, // COPTIC CAPITAL LETTER FEI
- 0x03E6, 0x03E7, // COPTIC CAPITAL LETTER KHEI
- 0x03E8, 0x03E9, // COPTIC CAPITAL LETTER HORI
- 0x03EA, 0x03EB, // COPTIC CAPITAL LETTER GANGIA
- 0x03EC, 0x03ED, // COPTIC CAPITAL LETTER SHIMA
- 0x03EE, 0x03EF, // COPTIC CAPITAL LETTER DEI
- 0x03F0, 0x03BA, // GREEK KAPPA SYMBOL
- 0x03F1, 0x03C1, // GREEK RHO SYMBOL
- 0x03F4, 0x03B8, // GREEK CAPITAL THETA SYMBOL
- 0x03F5, 0x03B5, // GREEK LUNATE EPSILON SYMBOL
- 0x03F7, 0x03F8, // GREEK CAPITAL LETTER SHO
- 0x03F9, 0x03F2, // GREEK CAPITAL LUNATE SIGMA SYMBOL
- 0x03FA, 0x03FB, // GREEK CAPITAL LETTER SAN
- 0x03FD, 0x037B, // GREEK CAPITAL REVERSED LUNATE SIGMA SYMBOL
- 0x03FE, 0x037C, // GREEK CAPITAL DOTTED LUNATE SIGMA SYMBOL
- 0x03FF, 0x037D, // GREEK CAPITAL REVERSED DOTTED LUNATE SIGMA SYMBOL
- 0x0400, 0x0450, // CYRILLIC CAPITAL LETTER IE WITH GRAVE
- 0x0401, 0x0451, // CYRILLIC CAPITAL LETTER IO
- 0x0402, 0x0452, // CYRILLIC CAPITAL LETTER DJE
- 0x0403, 0x0453, // CYRILLIC CAPITAL LETTER GJE
- 0x0404, 0x0454, // CYRILLIC CAPITAL LETTER UKRAINIAN IE
- 0x0405, 0x0455, // CYRILLIC CAPITAL LETTER DZE
- 0x0406, 0x0456, // CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I
- 0x0407, 0x0457, // CYRILLIC CAPITAL LETTER YI
- 0x0408, 0x0458, // CYRILLIC CAPITAL LETTER JE
- 0x0409, 0x0459, // CYRILLIC CAPITAL LETTER LJE
- 0x040A, 0x045A, // CYRILLIC CAPITAL LETTER NJE
- 0x040B, 0x045B, // CYRILLIC CAPITAL LETTER TSHE
- 0x040C, 0x045C, // CYRILLIC CAPITAL LETTER KJE
- 0x040D, 0x045D, // CYRILLIC CAPITAL LETTER I WITH GRAVE
- 0x040E, 0x045E, // CYRILLIC CAPITAL LETTER SHORT U
- 0x040F, 0x045F, // CYRILLIC CAPITAL LETTER DZHE
- 0x0410, 0x0430, // CYRILLIC CAPITAL LETTER A
- 0x0411, 0x0431, // CYRILLIC CAPITAL LETTER BE
- 0x0412, 0x0432, // CYRILLIC CAPITAL LETTER VE
- 0x0413, 0x0433, // CYRILLIC CAPITAL LETTER GHE
- 0x0414, 0x0434, // CYRILLIC CAPITAL LETTER DE
- 0x0415, 0x0435, // CYRILLIC CAPITAL LETTER IE
- 0x0416, 0x0436, // CYRILLIC CAPITAL LETTER ZHE
- 0x0417, 0x0437, // CYRILLIC CAPITAL LETTER ZE
- 0x0418, 0x0438, // CYRILLIC CAPITAL LETTER I
- 0x0419, 0x0439, // CYRILLIC CAPITAL LETTER SHORT I
- 0x041A, 0x043A, // CYRILLIC CAPITAL LETTER KA
- 0x041B, 0x043B, // CYRILLIC CAPITAL LETTER EL
- 0x041C, 0x043C, // CYRILLIC CAPITAL LETTER EM
- 0x041D, 0x043D, // CYRILLIC CAPITAL LETTER EN
- 0x041E, 0x043E, // CYRILLIC CAPITAL LETTER O
- 0x041F, 0x043F, // CYRILLIC CAPITAL LETTER PE
- 0x0420, 0x0440, // CYRILLIC CAPITAL LETTER ER
- 0x0421, 0x0441, // CYRILLIC CAPITAL LETTER ES
- 0x0422, 0x0442, // CYRILLIC CAPITAL LETTER TE
- 0x0423, 0x0443, // CYRILLIC CAPITAL LETTER U
- 0x0424, 0x0444, // CYRILLIC CAPITAL LETTER EF
- 0x0425, 0x0445, // CYRILLIC CAPITAL LETTER HA
- 0x0426, 0x0446, // CYRILLIC CAPITAL LETTER TSE
- 0x0427, 0x0447, // CYRILLIC CAPITAL LETTER CHE
- 0x0428, 0x0448, // CYRILLIC CAPITAL LETTER SHA
- 0x0429, 0x0449, // CYRILLIC CAPITAL LETTER SHCHA
- 0x042A, 0x044A, // CYRILLIC CAPITAL LETTER HARD SIGN
- 0x042B, 0x044B, // CYRILLIC CAPITAL LETTER YERU
- 0x042C, 0x044C, // CYRILLIC CAPITAL LETTER SOFT SIGN
- 0x042D, 0x044D, // CYRILLIC CAPITAL LETTER E
- 0x042E, 0x044E, // CYRILLIC CAPITAL LETTER YU
- 0x042F, 0x044F, // CYRILLIC CAPITAL LETTER YA
- 0x0460, 0x0461, // CYRILLIC CAPITAL LETTER OMEGA
- 0x0462, 0x0463, // CYRILLIC CAPITAL LETTER YAT
- 0x0464, 0x0465, // CYRILLIC CAPITAL LETTER IOTIFIED E
- 0x0466, 0x0467, // CYRILLIC CAPITAL LETTER LITTLE YUS
- 0x0468, 0x0469, // CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS
- 0x046A, 0x046B, // CYRILLIC CAPITAL LETTER BIG YUS
- 0x046C, 0x046D, // CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS
- 0x046E, 0x046F, // CYRILLIC CAPITAL LETTER KSI
- 0x0470, 0x0471, // CYRILLIC CAPITAL LETTER PSI
- 0x0472, 0x0473, // CYRILLIC CAPITAL LETTER FITA
- 0x0474, 0x0475, // CYRILLIC CAPITAL LETTER IZHITSA
- 0x0476, 0x0477, // CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT
- 0x0478, 0x0479, // CYRILLIC CAPITAL LETTER UK
- 0x047A, 0x047B, // CYRILLIC CAPITAL LETTER ROUND OMEGA
- 0x047C, 0x047D, // CYRILLIC CAPITAL LETTER OMEGA WITH TITLO
- 0x047E, 0x047F, // CYRILLIC CAPITAL LETTER OT
- 0x0480, 0x0481, // CYRILLIC CAPITAL LETTER KOPPA
- 0x048A, 0x048B, // CYRILLIC CAPITAL LETTER SHORT I WITH TAIL
- 0x048C, 0x048D, // CYRILLIC CAPITAL LETTER SEMISOFT SIGN
- 0x048E, 0x048F, // CYRILLIC CAPITAL LETTER ER WITH TICK
- 0x0490, 0x0491, // CYRILLIC CAPITAL LETTER GHE WITH UPTURN
- 0x0492, 0x0493, // CYRILLIC CAPITAL LETTER GHE WITH STROKE
- 0x0494, 0x0495, // CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK
- 0x0496, 0x0497, // CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER
- 0x0498, 0x0499, // CYRILLIC CAPITAL LETTER ZE WITH DESCENDER
- 0x049A, 0x049B, // CYRILLIC CAPITAL LETTER KA WITH DESCENDER
- 0x049C, 0x049D, // CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE
- 0x049E, 0x049F, // CYRILLIC CAPITAL LETTER KA WITH STROKE
- 0x04A0, 0x04A1, // CYRILLIC CAPITAL LETTER BASHKIR KA
- 0x04A2, 0x04A3, // CYRILLIC CAPITAL LETTER EN WITH DESCENDER
- 0x04A4, 0x04A5, // CYRILLIC CAPITAL LIGATURE EN GHE
- 0x04A6, 0x04A7, // CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK
- 0x04A8, 0x04A9, // CYRILLIC CAPITAL LETTER ABKHASIAN HA
- 0x04AA, 0x04AB, // CYRILLIC CAPITAL LETTER ES WITH DESCENDER
- 0x04AC, 0x04AD, // CYRILLIC CAPITAL LETTER TE WITH DESCENDER
- 0x04AE, 0x04AF, // CYRILLIC CAPITAL LETTER STRAIGHT U
- 0x04B0, 0x04B1, // CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE
- 0x04B2, 0x04B3, // CYRILLIC CAPITAL LETTER HA WITH DESCENDER
- 0x04B4, 0x04B5, // CYRILLIC CAPITAL LIGATURE TE TSE
- 0x04B6, 0x04B7, // CYRILLIC CAPITAL LETTER CHE WITH DESCENDER
- 0x04B8, 0x04B9, // CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE
- 0x04BA, 0x04BB, // CYRILLIC CAPITAL LETTER SHHA
- 0x04BC, 0x04BD, // CYRILLIC CAPITAL LETTER ABKHASIAN CHE
- 0x04BE, 0x04BF, // CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER
- 0x04C0, 0x04CF, // CYRILLIC LETTER PALOCHKA
- 0x04C1, 0x04C2, // CYRILLIC CAPITAL LETTER ZHE WITH BREVE
- 0x04C3, 0x04C4, // CYRILLIC CAPITAL LETTER KA WITH HOOK
- 0x04C5, 0x04C6, // CYRILLIC CAPITAL LETTER EL WITH TAIL
- 0x04C7, 0x04C8, // CYRILLIC CAPITAL LETTER EN WITH HOOK
- 0x04C9, 0x04CA, // CYRILLIC CAPITAL LETTER EN WITH TAIL
- 0x04CB, 0x04CC, // CYRILLIC CAPITAL LETTER KHAKASSIAN CHE
- 0x04CD, 0x04CE, // CYRILLIC CAPITAL LETTER EM WITH TAIL
- 0x04D0, 0x04D1, // CYRILLIC CAPITAL LETTER A WITH BREVE
- 0x04D2, 0x04D3, // CYRILLIC CAPITAL LETTER A WITH DIAERESIS
- 0x04D4, 0x04D5, // CYRILLIC CAPITAL LIGATURE A IE
- 0x04D6, 0x04D7, // CYRILLIC CAPITAL LETTER IE WITH BREVE
- 0x04D8, 0x04D9, // CYRILLIC CAPITAL LETTER SCHWA
- 0x04DA, 0x04DB, // CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS
- 0x04DC, 0x04DD, // CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS
- 0x04DE, 0x04DF, // CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS
- 0x04E0, 0x04E1, // CYRILLIC CAPITAL LETTER ABKHASIAN DZE
- 0x04E2, 0x04E3, // CYRILLIC CAPITAL LETTER I WITH MACRON
- 0x04E4, 0x04E5, // CYRILLIC CAPITAL LETTER I WITH DIAERESIS
- 0x04E6, 0x04E7, // CYRILLIC CAPITAL LETTER O WITH DIAERESIS
- 0x04E8, 0x04E9, // CYRILLIC CAPITAL LETTER BARRED O
- 0x04EA, 0x04EB, // CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS
- 0x04EC, 0x04ED, // CYRILLIC CAPITAL LETTER E WITH DIAERESIS
- 0x04EE, 0x04EF, // CYRILLIC CAPITAL LETTER U WITH MACRON
- 0x04F0, 0x04F1, // CYRILLIC CAPITAL LETTER U WITH DIAERESIS
- 0x04F2, 0x04F3, // CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE
- 0x04F4, 0x04F5, // CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS
- 0x04F6, 0x04F7, // CYRILLIC CAPITAL LETTER GHE WITH DESCENDER
- 0x04F8, 0x04F9, // CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS
- 0x04FA, 0x04FB, // CYRILLIC CAPITAL LETTER GHE WITH STROKE AND HOOK
- 0x04FC, 0x04FD, // CYRILLIC CAPITAL LETTER HA WITH HOOK
- 0x04FE, 0x04FF, // CYRILLIC CAPITAL LETTER HA WITH STROKE
- 0x0500, 0x0501, // CYRILLIC CAPITAL LETTER KOMI DE
- 0x0502, 0x0503, // CYRILLIC CAPITAL LETTER KOMI DJE
- 0x0504, 0x0505, // CYRILLIC CAPITAL LETTER KOMI ZJE
- 0x0506, 0x0507, // CYRILLIC CAPITAL LETTER KOMI DZJE
- 0x0508, 0x0509, // CYRILLIC CAPITAL LETTER KOMI LJE
- 0x050A, 0x050B, // CYRILLIC CAPITAL LETTER KOMI NJE
- 0x050C, 0x050D, // CYRILLIC CAPITAL LETTER KOMI SJE
- 0x050E, 0x050F, // CYRILLIC CAPITAL LETTER KOMI TJE
- 0x0510, 0x0511, // CYRILLIC CAPITAL LETTER REVERSED ZE
- 0x0512, 0x0513, // CYRILLIC CAPITAL LETTER EL WITH HOOK
- 0x0531, 0x0561, // ARMENIAN CAPITAL LETTER AYB
- 0x0532, 0x0562, // ARMENIAN CAPITAL LETTER BEN
- 0x0533, 0x0563, // ARMENIAN CAPITAL LETTER GIM
- 0x0534, 0x0564, // ARMENIAN CAPITAL LETTER DA
- 0x0535, 0x0565, // ARMENIAN CAPITAL LETTER ECH
- 0x0536, 0x0566, // ARMENIAN CAPITAL LETTER ZA
- 0x0537, 0x0567, // ARMENIAN CAPITAL LETTER EH
- 0x0538, 0x0568, // ARMENIAN CAPITAL LETTER ET
- 0x0539, 0x0569, // ARMENIAN CAPITAL LETTER TO
- 0x053A, 0x056A, // ARMENIAN CAPITAL LETTER ZHE
- 0x053B, 0x056B, // ARMENIAN CAPITAL LETTER INI
- 0x053C, 0x056C, // ARMENIAN CAPITAL LETTER LIWN
- 0x053D, 0x056D, // ARMENIAN CAPITAL LETTER XEH
- 0x053E, 0x056E, // ARMENIAN CAPITAL LETTER CA
- 0x053F, 0x056F, // ARMENIAN CAPITAL LETTER KEN
- 0x0540, 0x0570, // ARMENIAN CAPITAL LETTER HO
- 0x0541, 0x0571, // ARMENIAN CAPITAL LETTER JA
- 0x0542, 0x0572, // ARMENIAN CAPITAL LETTER GHAD
- 0x0543, 0x0573, // ARMENIAN CAPITAL LETTER CHEH
- 0x0544, 0x0574, // ARMENIAN CAPITAL LETTER MEN
- 0x0545, 0x0575, // ARMENIAN CAPITAL LETTER YI
- 0x0546, 0x0576, // ARMENIAN CAPITAL LETTER NOW
- 0x0547, 0x0577, // ARMENIAN CAPITAL LETTER SHA
- 0x0548, 0x0578, // ARMENIAN CAPITAL LETTER VO
- 0x0549, 0x0579, // ARMENIAN CAPITAL LETTER CHA
- 0x054A, 0x057A, // ARMENIAN CAPITAL LETTER PEH
- 0x054B, 0x057B, // ARMENIAN CAPITAL LETTER JHEH
- 0x054C, 0x057C, // ARMENIAN CAPITAL LETTER RA
- 0x054D, 0x057D, // ARMENIAN CAPITAL LETTER SEH
- 0x054E, 0x057E, // ARMENIAN CAPITAL LETTER VEW
- 0x054F, 0x057F, // ARMENIAN CAPITAL LETTER TIWN
- 0x0550, 0x0580, // ARMENIAN CAPITAL LETTER REH
- 0x0551, 0x0581, // ARMENIAN CAPITAL LETTER CO
- 0x0552, 0x0582, // ARMENIAN CAPITAL LETTER YIWN
- 0x0553, 0x0583, // ARMENIAN CAPITAL LETTER PIWR
- 0x0554, 0x0584, // ARMENIAN CAPITAL LETTER KEH
- 0x0555, 0x0585, // ARMENIAN CAPITAL LETTER OH
- 0x0556, 0x0586, // ARMENIAN CAPITAL LETTER FEH
- 0x10A0, 0x2D00, // GEORGIAN CAPITAL LETTER AN
- 0x10A1, 0x2D01, // GEORGIAN CAPITAL LETTER BAN
- 0x10A2, 0x2D02, // GEORGIAN CAPITAL LETTER GAN
- 0x10A3, 0x2D03, // GEORGIAN CAPITAL LETTER DON
- 0x10A4, 0x2D04, // GEORGIAN CAPITAL LETTER EN
- 0x10A5, 0x2D05, // GEORGIAN CAPITAL LETTER VIN
- 0x10A6, 0x2D06, // GEORGIAN CAPITAL LETTER ZEN
- 0x10A7, 0x2D07, // GEORGIAN CAPITAL LETTER TAN
- 0x10A8, 0x2D08, // GEORGIAN CAPITAL LETTER IN
- 0x10A9, 0x2D09, // GEORGIAN CAPITAL LETTER KAN
- 0x10AA, 0x2D0A, // GEORGIAN CAPITAL LETTER LAS
- 0x10AB, 0x2D0B, // GEORGIAN CAPITAL LETTER MAN
- 0x10AC, 0x2D0C, // GEORGIAN CAPITAL LETTER NAR
- 0x10AD, 0x2D0D, // GEORGIAN CAPITAL LETTER ON
- 0x10AE, 0x2D0E, // GEORGIAN CAPITAL LETTER PAR
- 0x10AF, 0x2D0F, // GEORGIAN CAPITAL LETTER ZHAR
- 0x10B0, 0x2D10, // GEORGIAN CAPITAL LETTER RAE
- 0x10B1, 0x2D11, // GEORGIAN CAPITAL LETTER SAN
- 0x10B2, 0x2D12, // GEORGIAN CAPITAL LETTER TAR
- 0x10B3, 0x2D13, // GEORGIAN CAPITAL LETTER UN
- 0x10B4, 0x2D14, // GEORGIAN CAPITAL LETTER PHAR
- 0x10B5, 0x2D15, // GEORGIAN CAPITAL LETTER KHAR
- 0x10B6, 0x2D16, // GEORGIAN CAPITAL LETTER GHAN
- 0x10B7, 0x2D17, // GEORGIAN CAPITAL LETTER QAR
- 0x10B8, 0x2D18, // GEORGIAN CAPITAL LETTER SHIN
- 0x10B9, 0x2D19, // GEORGIAN CAPITAL LETTER CHIN
- 0x10BA, 0x2D1A, // GEORGIAN CAPITAL LETTER CAN
- 0x10BB, 0x2D1B, // GEORGIAN CAPITAL LETTER JIL
- 0x10BC, 0x2D1C, // GEORGIAN CAPITAL LETTER CIL
- 0x10BD, 0x2D1D, // GEORGIAN CAPITAL LETTER CHAR
- 0x10BE, 0x2D1E, // GEORGIAN CAPITAL LETTER XAN
- 0x10BF, 0x2D1F, // GEORGIAN CAPITAL LETTER JHAN
- 0x10C0, 0x2D20, // GEORGIAN CAPITAL LETTER HAE
- 0x10C1, 0x2D21, // GEORGIAN CAPITAL LETTER HE
- 0x10C2, 0x2D22, // GEORGIAN CAPITAL LETTER HIE
- 0x10C3, 0x2D23, // GEORGIAN CAPITAL LETTER WE
- 0x10C4, 0x2D24, // GEORGIAN CAPITAL LETTER HAR
- 0x10C5, 0x2D25, // GEORGIAN CAPITAL LETTER HOE
- 0x1E00, 0x1E01, // LATIN CAPITAL LETTER A WITH RING BELOW
- 0x1E02, 0x1E03, // LATIN CAPITAL LETTER B WITH DOT ABOVE
- 0x1E04, 0x1E05, // LATIN CAPITAL LETTER B WITH DOT BELOW
- 0x1E06, 0x1E07, // LATIN CAPITAL LETTER B WITH LINE BELOW
- 0x1E08, 0x1E09, // LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE
- 0x1E0A, 0x1E0B, // LATIN CAPITAL LETTER D WITH DOT ABOVE
- 0x1E0C, 0x1E0D, // LATIN CAPITAL LETTER D WITH DOT BELOW
- 0x1E0E, 0x1E0F, // LATIN CAPITAL LETTER D WITH LINE BELOW
- 0x1E10, 0x1E11, // LATIN CAPITAL LETTER D WITH CEDILLA
- 0x1E12, 0x1E13, // LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW
- 0x1E14, 0x1E15, // LATIN CAPITAL LETTER E WITH MACRON AND GRAVE
- 0x1E16, 0x1E17, // LATIN CAPITAL LETTER E WITH MACRON AND ACUTE
- 0x1E18, 0x1E19, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW
- 0x1E1A, 0x1E1B, // LATIN CAPITAL LETTER E WITH TILDE BELOW
- 0x1E1C, 0x1E1D, // LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE
- 0x1E1E, 0x1E1F, // LATIN CAPITAL LETTER F WITH DOT ABOVE
- 0x1E20, 0x1E21, // LATIN CAPITAL LETTER G WITH MACRON
- 0x1E22, 0x1E23, // LATIN CAPITAL LETTER H WITH DOT ABOVE
- 0x1E24, 0x1E25, // LATIN CAPITAL LETTER H WITH DOT BELOW
- 0x1E26, 0x1E27, // LATIN CAPITAL LETTER H WITH DIAERESIS
- 0x1E28, 0x1E29, // LATIN CAPITAL LETTER H WITH CEDILLA
- 0x1E2A, 0x1E2B, // LATIN CAPITAL LETTER H WITH BREVE BELOW
- 0x1E2C, 0x1E2D, // LATIN CAPITAL LETTER I WITH TILDE BELOW
- 0x1E2E, 0x1E2F, // LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE
- 0x1E30, 0x1E31, // LATIN CAPITAL LETTER K WITH ACUTE
- 0x1E32, 0x1E33, // LATIN CAPITAL LETTER K WITH DOT BELOW
- 0x1E34, 0x1E35, // LATIN CAPITAL LETTER K WITH LINE BELOW
- 0x1E36, 0x1E37, // LATIN CAPITAL LETTER L WITH DOT BELOW
- 0x1E38, 0x1E39, // LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON
- 0x1E3A, 0x1E3B, // LATIN CAPITAL LETTER L WITH LINE BELOW
- 0x1E3C, 0x1E3D, // LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW
- 0x1E3E, 0x1E3F, // LATIN CAPITAL LETTER M WITH ACUTE
- 0x1E40, 0x1E41, // LATIN CAPITAL LETTER M WITH DOT ABOVE
- 0x1E42, 0x1E43, // LATIN CAPITAL LETTER M WITH DOT BELOW
- 0x1E44, 0x1E45, // LATIN CAPITAL LETTER N WITH DOT ABOVE
- 0x1E46, 0x1E47, // LATIN CAPITAL LETTER N WITH DOT BELOW
- 0x1E48, 0x1E49, // LATIN CAPITAL LETTER N WITH LINE BELOW
- 0x1E4A, 0x1E4B, // LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW
- 0x1E4C, 0x1E4D, // LATIN CAPITAL LETTER O WITH TILDE AND ACUTE
- 0x1E4E, 0x1E4F, // LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS
- 0x1E50, 0x1E51, // LATIN CAPITAL LETTER O WITH MACRON AND GRAVE
- 0x1E52, 0x1E53, // LATIN CAPITAL LETTER O WITH MACRON AND ACUTE
- 0x1E54, 0x1E55, // LATIN CAPITAL LETTER P WITH ACUTE
- 0x1E56, 0x1E57, // LATIN CAPITAL LETTER P WITH DOT ABOVE
- 0x1E58, 0x1E59, // LATIN CAPITAL LETTER R WITH DOT ABOVE
- 0x1E5A, 0x1E5B, // LATIN CAPITAL LETTER R WITH DOT BELOW
- 0x1E5C, 0x1E5D, // LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON
- 0x1E5E, 0x1E5F, // LATIN CAPITAL LETTER R WITH LINE BELOW
- 0x1E60, 0x1E61, // LATIN CAPITAL LETTER S WITH DOT ABOVE
- 0x1E62, 0x1E63, // LATIN CAPITAL LETTER S WITH DOT BELOW
- 0x1E64, 0x1E65, // LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE
- 0x1E66, 0x1E67, // LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE
- 0x1E68, 0x1E69, // LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE
- 0x1E6A, 0x1E6B, // LATIN CAPITAL LETTER T WITH DOT ABOVE
- 0x1E6C, 0x1E6D, // LATIN CAPITAL LETTER T WITH DOT BELOW
- 0x1E6E, 0x1E6F, // LATIN CAPITAL LETTER T WITH LINE BELOW
- 0x1E70, 0x1E71, // LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW
- 0x1E72, 0x1E73, // LATIN CAPITAL LETTER U WITH DIAERESIS BELOW
- 0x1E74, 0x1E75, // LATIN CAPITAL LETTER U WITH TILDE BELOW
- 0x1E76, 0x1E77, // LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW
- 0x1E78, 0x1E79, // LATIN CAPITAL LETTER U WITH TILDE AND ACUTE
- 0x1E7A, 0x1E7B, // LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS
- 0x1E7C, 0x1E7D, // LATIN CAPITAL LETTER V WITH TILDE
- 0x1E7E, 0x1E7F, // LATIN CAPITAL LETTER V WITH DOT BELOW
- 0x1E80, 0x1E81, // LATIN CAPITAL LETTER W WITH GRAVE
- 0x1E82, 0x1E83, // LATIN CAPITAL LETTER W WITH ACUTE
- 0x1E84, 0x1E85, // LATIN CAPITAL LETTER W WITH DIAERESIS
- 0x1E86, 0x1E87, // LATIN CAPITAL LETTER W WITH DOT ABOVE
- 0x1E88, 0x1E89, // LATIN CAPITAL LETTER W WITH DOT BELOW
- 0x1E8A, 0x1E8B, // LATIN CAPITAL LETTER X WITH DOT ABOVE
- 0x1E8C, 0x1E8D, // LATIN CAPITAL LETTER X WITH DIAERESIS
- 0x1E8E, 0x1E8F, // LATIN CAPITAL LETTER Y WITH DOT ABOVE
- 0x1E90, 0x1E91, // LATIN CAPITAL LETTER Z WITH CIRCUMFLEX
- 0x1E92, 0x1E93, // LATIN CAPITAL LETTER Z WITH DOT BELOW
- 0x1E94, 0x1E95, // LATIN CAPITAL LETTER Z WITH LINE BELOW
- 0x1E9B, 0x1E61, // LATIN SMALL LETTER LONG S WITH DOT ABOVE
- 0x1EA0, 0x1EA1, // LATIN CAPITAL LETTER A WITH DOT BELOW
- 0x1EA2, 0x1EA3, // LATIN CAPITAL LETTER A WITH HOOK ABOVE
- 0x1EA4, 0x1EA5, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE
- 0x1EA6, 0x1EA7, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE
- 0x1EA8, 0x1EA9, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE
- 0x1EAA, 0x1EAB, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE
- 0x1EAC, 0x1EAD, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW
- 0x1EAE, 0x1EAF, // LATIN CAPITAL LETTER A WITH BREVE AND ACUTE
- 0x1EB0, 0x1EB1, // LATIN CAPITAL LETTER A WITH BREVE AND GRAVE
- 0x1EB2, 0x1EB3, // LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE
- 0x1EB4, 0x1EB5, // LATIN CAPITAL LETTER A WITH BREVE AND TILDE
- 0x1EB6, 0x1EB7, // LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW
- 0x1EB8, 0x1EB9, // LATIN CAPITAL LETTER E WITH DOT BELOW
- 0x1EBA, 0x1EBB, // LATIN CAPITAL LETTER E WITH HOOK ABOVE
- 0x1EBC, 0x1EBD, // LATIN CAPITAL LETTER E WITH TILDE
- 0x1EBE, 0x1EBF, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE
- 0x1EC0, 0x1EC1, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE
- 0x1EC2, 0x1EC3, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE
- 0x1EC4, 0x1EC5, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE
- 0x1EC6, 0x1EC7, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW
- 0x1EC8, 0x1EC9, // LATIN CAPITAL LETTER I WITH HOOK ABOVE
- 0x1ECA, 0x1ECB, // LATIN CAPITAL LETTER I WITH DOT BELOW
- 0x1ECC, 0x1ECD, // LATIN CAPITAL LETTER O WITH DOT BELOW
- 0x1ECE, 0x1ECF, // LATIN CAPITAL LETTER O WITH HOOK ABOVE
- 0x1ED0, 0x1ED1, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE
- 0x1ED2, 0x1ED3, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE
- 0x1ED4, 0x1ED5, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE
- 0x1ED6, 0x1ED7, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE
- 0x1ED8, 0x1ED9, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW
- 0x1EDA, 0x1EDB, // LATIN CAPITAL LETTER O WITH HORN AND ACUTE
- 0x1EDC, 0x1EDD, // LATIN CAPITAL LETTER O WITH HORN AND GRAVE
- 0x1EDE, 0x1EDF, // LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE
- 0x1EE0, 0x1EE1, // LATIN CAPITAL LETTER O WITH HORN AND TILDE
- 0x1EE2, 0x1EE3, // LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW
- 0x1EE4, 0x1EE5, // LATIN CAPITAL LETTER U WITH DOT BELOW
- 0x1EE6, 0x1EE7, // LATIN CAPITAL LETTER U WITH HOOK ABOVE
- 0x1EE8, 0x1EE9, // LATIN CAPITAL LETTER U WITH HORN AND ACUTE
- 0x1EEA, 0x1EEB, // LATIN CAPITAL LETTER U WITH HORN AND GRAVE
- 0x1EEC, 0x1EED, // LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE
- 0x1EEE, 0x1EEF, // LATIN CAPITAL LETTER U WITH HORN AND TILDE
- 0x1EF0, 0x1EF1, // LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW
- 0x1EF2, 0x1EF3, // LATIN CAPITAL LETTER Y WITH GRAVE
- 0x1EF4, 0x1EF5, // LATIN CAPITAL LETTER Y WITH DOT BELOW
- 0x1EF6, 0x1EF7, // LATIN CAPITAL LETTER Y WITH HOOK ABOVE
- 0x1EF8, 0x1EF9, // LATIN CAPITAL LETTER Y WITH TILDE
- 0x1F08, 0x1F00, // GREEK CAPITAL LETTER ALPHA WITH PSILI
- 0x1F09, 0x1F01, // GREEK CAPITAL LETTER ALPHA WITH DASIA
- 0x1F0A, 0x1F02, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA
- 0x1F0B, 0x1F03, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA
- 0x1F0C, 0x1F04, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA
- 0x1F0D, 0x1F05, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA
- 0x1F0E, 0x1F06, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI
- 0x1F0F, 0x1F07, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI
- 0x1F18, 0x1F10, // GREEK CAPITAL LETTER EPSILON WITH PSILI
- 0x1F19, 0x1F11, // GREEK CAPITAL LETTER EPSILON WITH DASIA
- 0x1F1A, 0x1F12, // GREEK CAPITAL LETTER EPSILON WITH PSILI AND VARIA
- 0x1F1B, 0x1F13, // GREEK CAPITAL LETTER EPSILON WITH DASIA AND VARIA
- 0x1F1C, 0x1F14, // GREEK CAPITAL LETTER EPSILON WITH PSILI AND OXIA
- 0x1F1D, 0x1F15, // GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA
- 0x1F28, 0x1F20, // GREEK CAPITAL LETTER ETA WITH PSILI
- 0x1F29, 0x1F21, // GREEK CAPITAL LETTER ETA WITH DASIA
- 0x1F2A, 0x1F22, // GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA
- 0x1F2B, 0x1F23, // GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA
- 0x1F2C, 0x1F24, // GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA
- 0x1F2D, 0x1F25, // GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA
- 0x1F2E, 0x1F26, // GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI
- 0x1F2F, 0x1F27, // GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI
- 0x1F38, 0x1F30, // GREEK CAPITAL LETTER IOTA WITH PSILI
- 0x1F39, 0x1F31, // GREEK CAPITAL LETTER IOTA WITH DASIA
- 0x1F3A, 0x1F32, // GREEK CAPITAL LETTER IOTA WITH PSILI AND VARIA
- 0x1F3B, 0x1F33, // GREEK CAPITAL LETTER IOTA WITH DASIA AND VARIA
- 0x1F3C, 0x1F34, // GREEK CAPITAL LETTER IOTA WITH PSILI AND OXIA
- 0x1F3D, 0x1F35, // GREEK CAPITAL LETTER IOTA WITH DASIA AND OXIA
- 0x1F3E, 0x1F36, // GREEK CAPITAL LETTER IOTA WITH PSILI AND PERISPOMENI
- 0x1F3F, 0x1F37, // GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI
- 0x1F48, 0x1F40, // GREEK CAPITAL LETTER OMICRON WITH PSILI
- 0x1F49, 0x1F41, // GREEK CAPITAL LETTER OMICRON WITH DASIA
- 0x1F4A, 0x1F42, // GREEK CAPITAL LETTER OMICRON WITH PSILI AND VARIA
- 0x1F4B, 0x1F43, // GREEK CAPITAL LETTER OMICRON WITH DASIA AND VARIA
- 0x1F4C, 0x1F44, // GREEK CAPITAL LETTER OMICRON WITH PSILI AND OXIA
- 0x1F4D, 0x1F45, // GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA
- 0x1F59, 0x1F51, // GREEK CAPITAL LETTER UPSILON WITH DASIA
- 0x1F5B, 0x1F53, // GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA
- 0x1F5D, 0x1F55, // GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA
- 0x1F5F, 0x1F57, // GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI
- 0x1F68, 0x1F60, // GREEK CAPITAL LETTER OMEGA WITH PSILI
- 0x1F69, 0x1F61, // GREEK CAPITAL LETTER OMEGA WITH DASIA
- 0x1F6A, 0x1F62, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA
- 0x1F6B, 0x1F63, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA
- 0x1F6C, 0x1F64, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA
- 0x1F6D, 0x1F65, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA
- 0x1F6E, 0x1F66, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI
- 0x1F6F, 0x1F67, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI
- 0x1F88, 0x1F80, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI
- 0x1F89, 0x1F81, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI
- 0x1F8A, 0x1F82, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI
- 0x1F8B, 0x1F83, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI
- 0x1F8C, 0x1F84, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI
- 0x1F8D, 0x1F85, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI
- 0x1F8E, 0x1F86, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
- 0x1F8F, 0x1F87, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
- 0x1F98, 0x1F90, // GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI
- 0x1F99, 0x1F91, // GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI
- 0x1F9A, 0x1F92, // GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI
- 0x1F9B, 0x1F93, // GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI
- 0x1F9C, 0x1F94, // GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI
- 0x1F9D, 0x1F95, // GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI
- 0x1F9E, 0x1F96, // GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
- 0x1F9F, 0x1F97, // GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
- 0x1FA8, 0x1FA0, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI
- 0x1FA9, 0x1FA1, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI
- 0x1FAA, 0x1FA2, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI
- 0x1FAB, 0x1FA3, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI
- 0x1FAC, 0x1FA4, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI
- 0x1FAD, 0x1FA5, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI
- 0x1FAE, 0x1FA6, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
- 0x1FAF, 0x1FA7, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
- 0x1FB8, 0x1FB0, // GREEK CAPITAL LETTER ALPHA WITH VRACHY
- 0x1FB9, 0x1FB1, // GREEK CAPITAL LETTER ALPHA WITH MACRON
- 0x1FBA, 0x1F70, // GREEK CAPITAL LETTER ALPHA WITH VARIA
- 0x1FBB, 0x1F71, // GREEK CAPITAL LETTER ALPHA WITH OXIA
- 0x1FBC, 0x1FB3, // GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI
- 0x1FBE, 0x03B9, // GREEK PROSGEGRAMMENI
- 0x1FC8, 0x1F72, // GREEK CAPITAL LETTER EPSILON WITH VARIA
- 0x1FC9, 0x1F73, // GREEK CAPITAL LETTER EPSILON WITH OXIA
- 0x1FCA, 0x1F74, // GREEK CAPITAL LETTER ETA WITH VARIA
- 0x1FCB, 0x1F75, // GREEK CAPITAL LETTER ETA WITH OXIA
- 0x1FCC, 0x1FC3, // GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
- 0x1FD8, 0x1FD0, // GREEK CAPITAL LETTER IOTA WITH VRACHY
- 0x1FD9, 0x1FD1, // GREEK CAPITAL LETTER IOTA WITH MACRON
- 0x1FDA, 0x1F76, // GREEK CAPITAL LETTER IOTA WITH VARIA
- 0x1FDB, 0x1F77, // GREEK CAPITAL LETTER IOTA WITH OXIA
- 0x1FE8, 0x1FE0, // GREEK CAPITAL LETTER UPSILON WITH VRACHY
- 0x1FE9, 0x1FE1, // GREEK CAPITAL LETTER UPSILON WITH MACRON
- 0x1FEA, 0x1F7A, // GREEK CAPITAL LETTER UPSILON WITH VARIA
- 0x1FEB, 0x1F7B, // GREEK CAPITAL LETTER UPSILON WITH OXIA
- 0x1FEC, 0x1FE5, // GREEK CAPITAL LETTER RHO WITH DASIA
- 0x1FF8, 0x1F78, // GREEK CAPITAL LETTER OMICRON WITH VARIA
- 0x1FF9, 0x1F79, // GREEK CAPITAL LETTER OMICRON WITH OXIA
- 0x1FFA, 0x1F7C, // GREEK CAPITAL LETTER OMEGA WITH VARIA
- 0x1FFB, 0x1F7D, // GREEK CAPITAL LETTER OMEGA WITH OXIA
- 0x1FFC, 0x1FF3, // GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
- 0x2126, 0x03C9, // OHM SIGN
- 0x212A, 0x006B, // KELVIN SIGN
- 0x212B, 0x00E5, // ANGSTROM SIGN
- 0x2132, 0x214E, // TURNED CAPITAL F
- 0x2160, 0x2170, // ROMAN NUMERAL ONE
- 0x2161, 0x2171, // ROMAN NUMERAL TWO
- 0x2162, 0x2172, // ROMAN NUMERAL THREE
- 0x2163, 0x2173, // ROMAN NUMERAL FOUR
- 0x2164, 0x2174, // ROMAN NUMERAL FIVE
- 0x2165, 0x2175, // ROMAN NUMERAL SIX
- 0x2166, 0x2176, // ROMAN NUMERAL SEVEN
- 0x2167, 0x2177, // ROMAN NUMERAL EIGHT
- 0x2168, 0x2178, // ROMAN NUMERAL NINE
- 0x2169, 0x2179, // ROMAN NUMERAL TEN
- 0x216A, 0x217A, // ROMAN NUMERAL ELEVEN
- 0x216B, 0x217B, // ROMAN NUMERAL TWELVE
- 0x216C, 0x217C, // ROMAN NUMERAL FIFTY
- 0x216D, 0x217D, // ROMAN NUMERAL ONE HUNDRED
- 0x216E, 0x217E, // ROMAN NUMERAL FIVE HUNDRED
- 0x216F, 0x217F, // ROMAN NUMERAL ONE THOUSAND
- 0x2183, 0x2184, // ROMAN NUMERAL REVERSED ONE HUNDRED
- 0x24B6, 0x24D0, // CIRCLED LATIN CAPITAL LETTER A
- 0x24B7, 0x24D1, // CIRCLED LATIN CAPITAL LETTER B
- 0x24B8, 0x24D2, // CIRCLED LATIN CAPITAL LETTER C
- 0x24B9, 0x24D3, // CIRCLED LATIN CAPITAL LETTER D
- 0x24BA, 0x24D4, // CIRCLED LATIN CAPITAL LETTER E
- 0x24BB, 0x24D5, // CIRCLED LATIN CAPITAL LETTER F
- 0x24BC, 0x24D6, // CIRCLED LATIN CAPITAL LETTER G
- 0x24BD, 0x24D7, // CIRCLED LATIN CAPITAL LETTER H
- 0x24BE, 0x24D8, // CIRCLED LATIN CAPITAL LETTER I
- 0x24BF, 0x24D9, // CIRCLED LATIN CAPITAL LETTER J
- 0x24C0, 0x24DA, // CIRCLED LATIN CAPITAL LETTER K
- 0x24C1, 0x24DB, // CIRCLED LATIN CAPITAL LETTER L
- 0x24C2, 0x24DC, // CIRCLED LATIN CAPITAL LETTER M
- 0x24C3, 0x24DD, // CIRCLED LATIN CAPITAL LETTER N
- 0x24C4, 0x24DE, // CIRCLED LATIN CAPITAL LETTER O
- 0x24C5, 0x24DF, // CIRCLED LATIN CAPITAL LETTER P
- 0x24C6, 0x24E0, // CIRCLED LATIN CAPITAL LETTER Q
- 0x24C7, 0x24E1, // CIRCLED LATIN CAPITAL LETTER R
- 0x24C8, 0x24E2, // CIRCLED LATIN CAPITAL LETTER S
- 0x24C9, 0x24E3, // CIRCLED LATIN CAPITAL LETTER T
- 0x24CA, 0x24E4, // CIRCLED LATIN CAPITAL LETTER U
- 0x24CB, 0x24E5, // CIRCLED LATIN CAPITAL LETTER V
- 0x24CC, 0x24E6, // CIRCLED LATIN CAPITAL LETTER W
- 0x24CD, 0x24E7, // CIRCLED LATIN CAPITAL LETTER X
- 0x24CE, 0x24E8, // CIRCLED LATIN CAPITAL LETTER Y
- 0x24CF, 0x24E9, // CIRCLED LATIN CAPITAL LETTER Z
- 0x2C00, 0x2C30, // GLAGOLITIC CAPITAL LETTER AZU
- 0x2C01, 0x2C31, // GLAGOLITIC CAPITAL LETTER BUKY
- 0x2C02, 0x2C32, // GLAGOLITIC CAPITAL LETTER VEDE
- 0x2C03, 0x2C33, // GLAGOLITIC CAPITAL LETTER GLAGOLI
- 0x2C04, 0x2C34, // GLAGOLITIC CAPITAL LETTER DOBRO
- 0x2C05, 0x2C35, // GLAGOLITIC CAPITAL LETTER YESTU
- 0x2C06, 0x2C36, // GLAGOLITIC CAPITAL LETTER ZHIVETE
- 0x2C07, 0x2C37, // GLAGOLITIC CAPITAL LETTER DZELO
- 0x2C08, 0x2C38, // GLAGOLITIC CAPITAL LETTER ZEMLJA
- 0x2C09, 0x2C39, // GLAGOLITIC CAPITAL LETTER IZHE
- 0x2C0A, 0x2C3A, // GLAGOLITIC CAPITAL LETTER INITIAL IZHE
- 0x2C0B, 0x2C3B, // GLAGOLITIC CAPITAL LETTER I
- 0x2C0C, 0x2C3C, // GLAGOLITIC CAPITAL LETTER DJERVI
- 0x2C0D, 0x2C3D, // GLAGOLITIC CAPITAL LETTER KAKO
- 0x2C0E, 0x2C3E, // GLAGOLITIC CAPITAL LETTER LJUDIJE
- 0x2C0F, 0x2C3F, // GLAGOLITIC CAPITAL LETTER MYSLITE
- 0x2C10, 0x2C40, // GLAGOLITIC CAPITAL LETTER NASHI
- 0x2C11, 0x2C41, // GLAGOLITIC CAPITAL LETTER ONU
- 0x2C12, 0x2C42, // GLAGOLITIC CAPITAL LETTER POKOJI
- 0x2C13, 0x2C43, // GLAGOLITIC CAPITAL LETTER RITSI
- 0x2C14, 0x2C44, // GLAGOLITIC CAPITAL LETTER SLOVO
- 0x2C15, 0x2C45, // GLAGOLITIC CAPITAL LETTER TVRIDO
- 0x2C16, 0x2C46, // GLAGOLITIC CAPITAL LETTER UKU
- 0x2C17, 0x2C47, // GLAGOLITIC CAPITAL LETTER FRITU
- 0x2C18, 0x2C48, // GLAGOLITIC CAPITAL LETTER HERU
- 0x2C19, 0x2C49, // GLAGOLITIC CAPITAL LETTER OTU
- 0x2C1A, 0x2C4A, // GLAGOLITIC CAPITAL LETTER PE
- 0x2C1B, 0x2C4B, // GLAGOLITIC CAPITAL LETTER SHTA
- 0x2C1C, 0x2C4C, // GLAGOLITIC CAPITAL LETTER TSI
- 0x2C1D, 0x2C4D, // GLAGOLITIC CAPITAL LETTER CHRIVI
- 0x2C1E, 0x2C4E, // GLAGOLITIC CAPITAL LETTER SHA
- 0x2C1F, 0x2C4F, // GLAGOLITIC CAPITAL LETTER YERU
- 0x2C20, 0x2C50, // GLAGOLITIC CAPITAL LETTER YERI
- 0x2C21, 0x2C51, // GLAGOLITIC CAPITAL LETTER YATI
- 0x2C22, 0x2C52, // GLAGOLITIC CAPITAL LETTER SPIDERY HA
- 0x2C23, 0x2C53, // GLAGOLITIC CAPITAL LETTER YU
- 0x2C24, 0x2C54, // GLAGOLITIC CAPITAL LETTER SMALL YUS
- 0x2C25, 0x2C55, // GLAGOLITIC CAPITAL LETTER SMALL YUS WITH TAIL
- 0x2C26, 0x2C56, // GLAGOLITIC CAPITAL LETTER YO
- 0x2C27, 0x2C57, // GLAGOLITIC CAPITAL LETTER IOTATED SMALL YUS
- 0x2C28, 0x2C58, // GLAGOLITIC CAPITAL LETTER BIG YUS
- 0x2C29, 0x2C59, // GLAGOLITIC CAPITAL LETTER IOTATED BIG YUS
- 0x2C2A, 0x2C5A, // GLAGOLITIC CAPITAL LETTER FITA
- 0x2C2B, 0x2C5B, // GLAGOLITIC CAPITAL LETTER IZHITSA
- 0x2C2C, 0x2C5C, // GLAGOLITIC CAPITAL LETTER SHTAPIC
- 0x2C2D, 0x2C5D, // GLAGOLITIC CAPITAL LETTER TROKUTASTI A
- 0x2C2E, 0x2C5E, // GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
- 0x2C60, 0x2C61, // LATIN CAPITAL LETTER L WITH DOUBLE BAR
- 0x2C62, 0x026B, // LATIN CAPITAL LETTER L WITH MIDDLE TILDE
- 0x2C63, 0x1D7D, // LATIN CAPITAL LETTER P WITH STROKE
- 0x2C64, 0x027D, // LATIN CAPITAL LETTER R WITH TAIL
- 0x2C67, 0x2C68, // LATIN CAPITAL LETTER H WITH DESCENDER
- 0x2C69, 0x2C6A, // LATIN CAPITAL LETTER K WITH DESCENDER
- 0x2C6B, 0x2C6C, // LATIN CAPITAL LETTER Z WITH DESCENDER
- 0x2C75, 0x2C76, // LATIN CAPITAL LETTER HALF H
- 0x2C80, 0x2C81, // COPTIC CAPITAL LETTER ALFA
- 0x2C82, 0x2C83, // COPTIC CAPITAL LETTER VIDA
- 0x2C84, 0x2C85, // COPTIC CAPITAL LETTER GAMMA
- 0x2C86, 0x2C87, // COPTIC CAPITAL LETTER DALDA
- 0x2C88, 0x2C89, // COPTIC CAPITAL LETTER EIE
- 0x2C8A, 0x2C8B, // COPTIC CAPITAL LETTER SOU
- 0x2C8C, 0x2C8D, // COPTIC CAPITAL LETTER ZATA
- 0x2C8E, 0x2C8F, // COPTIC CAPITAL LETTER HATE
- 0x2C90, 0x2C91, // COPTIC CAPITAL LETTER THETHE
- 0x2C92, 0x2C93, // COPTIC CAPITAL LETTER IAUDA
- 0x2C94, 0x2C95, // COPTIC CAPITAL LETTER KAPA
- 0x2C96, 0x2C97, // COPTIC CAPITAL LETTER LAULA
- 0x2C98, 0x2C99, // COPTIC CAPITAL LETTER MI
- 0x2C9A, 0x2C9B, // COPTIC CAPITAL LETTER NI
- 0x2C9C, 0x2C9D, // COPTIC CAPITAL LETTER KSI
- 0x2C9E, 0x2C9F, // COPTIC CAPITAL LETTER O
- 0x2CA0, 0x2CA1, // COPTIC CAPITAL LETTER PI
- 0x2CA2, 0x2CA3, // COPTIC CAPITAL LETTER RO
- 0x2CA4, 0x2CA5, // COPTIC CAPITAL LETTER SIMA
- 0x2CA6, 0x2CA7, // COPTIC CAPITAL LETTER TAU
- 0x2CA8, 0x2CA9, // COPTIC CAPITAL LETTER UA
- 0x2CAA, 0x2CAB, // COPTIC CAPITAL LETTER FI
- 0x2CAC, 0x2CAD, // COPTIC CAPITAL LETTER KHI
- 0x2CAE, 0x2CAF, // COPTIC CAPITAL LETTER PSI
- 0x2CB0, 0x2CB1, // COPTIC CAPITAL LETTER OOU
- 0x2CB2, 0x2CB3, // COPTIC CAPITAL LETTER DIALECT-P ALEF
- 0x2CB4, 0x2CB5, // COPTIC CAPITAL LETTER OLD COPTIC AIN
- 0x2CB6, 0x2CB7, // COPTIC CAPITAL LETTER CRYPTOGRAMMIC EIE
- 0x2CB8, 0x2CB9, // COPTIC CAPITAL LETTER DIALECT-P KAPA
- 0x2CBA, 0x2CBB, // COPTIC CAPITAL LETTER DIALECT-P NI
- 0x2CBC, 0x2CBD, // COPTIC CAPITAL LETTER CRYPTOGRAMMIC NI
- 0x2CBE, 0x2CBF, // COPTIC CAPITAL LETTER OLD COPTIC OOU
- 0x2CC0, 0x2CC1, // COPTIC CAPITAL LETTER SAMPI
- 0x2CC2, 0x2CC3, // COPTIC CAPITAL LETTER CROSSED SHEI
- 0x2CC4, 0x2CC5, // COPTIC CAPITAL LETTER OLD COPTIC SHEI
- 0x2CC6, 0x2CC7, // COPTIC CAPITAL LETTER OLD COPTIC ESH
- 0x2CC8, 0x2CC9, // COPTIC CAPITAL LETTER AKHMIMIC KHEI
- 0x2CCA, 0x2CCB, // COPTIC CAPITAL LETTER DIALECT-P HORI
- 0x2CCC, 0x2CCD, // COPTIC CAPITAL LETTER OLD COPTIC HORI
- 0x2CCE, 0x2CCF, // COPTIC CAPITAL LETTER OLD COPTIC HA
- 0x2CD0, 0x2CD1, // COPTIC CAPITAL LETTER L-SHAPED HA
- 0x2CD2, 0x2CD3, // COPTIC CAPITAL LETTER OLD COPTIC HEI
- 0x2CD4, 0x2CD5, // COPTIC CAPITAL LETTER OLD COPTIC HAT
- 0x2CD6, 0x2CD7, // COPTIC CAPITAL LETTER OLD COPTIC GANGIA
- 0x2CD8, 0x2CD9, // COPTIC CAPITAL LETTER OLD COPTIC DJA
- 0x2CDA, 0x2CDB, // COPTIC CAPITAL LETTER OLD COPTIC SHIMA
- 0x2CDC, 0x2CDD, // COPTIC CAPITAL LETTER OLD NUBIAN SHIMA
- 0x2CDE, 0x2CDF, // COPTIC CAPITAL LETTER OLD NUBIAN NGI
- 0x2CE0, 0x2CE1, // COPTIC CAPITAL LETTER OLD NUBIAN NYI
- 0x2CE2, 0x2CE3, // COPTIC CAPITAL LETTER OLD NUBIAN WAU
- 0, 0
+static const REBUNI Char_Cases[] = {
+ 0x0041, 0x0061, // LATIN CAPITAL LETTER A
+ 0x0042, 0x0062, // LATIN CAPITAL LETTER B
+ 0x0043, 0x0063, // LATIN CAPITAL LETTER C
+ 0x0044, 0x0064, // LATIN CAPITAL LETTER D
+ 0x0045, 0x0065, // LATIN CAPITAL LETTER E
+ 0x0046, 0x0066, // LATIN CAPITAL LETTER F
+ 0x0047, 0x0067, // LATIN CAPITAL LETTER G
+ 0x0048, 0x0068, // LATIN CAPITAL LETTER H
+ 0x0049, 0x0069, // LATIN CAPITAL LETTER I
+ 0x004A, 0x006A, // LATIN CAPITAL LETTER J
+ 0x004B, 0x006B, // LATIN CAPITAL LETTER K
+ 0x004C, 0x006C, // LATIN CAPITAL LETTER L
+ 0x004D, 0x006D, // LATIN CAPITAL LETTER M
+ 0x004E, 0x006E, // LATIN CAPITAL LETTER N
+ 0x004F, 0x006F, // LATIN CAPITAL LETTER O
+ 0x0050, 0x0070, // LATIN CAPITAL LETTER P
+ 0x0051, 0x0071, // LATIN CAPITAL LETTER Q
+ 0x0052, 0x0072, // LATIN CAPITAL LETTER R
+ 0x0053, 0x0073, // LATIN CAPITAL LETTER S
+ 0x0054, 0x0074, // LATIN CAPITAL LETTER T
+ 0x0055, 0x0075, // LATIN CAPITAL LETTER U
+ 0x0056, 0x0076, // LATIN CAPITAL LETTER V
+ 0x0057, 0x0077, // LATIN CAPITAL LETTER W
+ 0x0058, 0x0078, // LATIN CAPITAL LETTER X
+ 0x0059, 0x0079, // LATIN CAPITAL LETTER Y
+ 0x005A, 0x007A, // LATIN CAPITAL LETTER Z
+ 0x00B5, 0x03BC, // MICRO SIGN
+ 0x00C0, 0x00E0, // LATIN CAPITAL LETTER A WITH GRAVE
+ 0x00C1, 0x00E1, // LATIN CAPITAL LETTER A WITH ACUTE
+ 0x00C2, 0x00E2, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+ 0x00C3, 0x00E3, // LATIN CAPITAL LETTER A WITH TILDE
+ 0x00C4, 0x00E4, // LATIN CAPITAL LETTER A WITH DIAERESIS
+ 0x00C5, 0x00E5, // LATIN CAPITAL LETTER A WITH RING ABOVE
+ 0x00C6, 0x00E6, // LATIN CAPITAL LETTER AE
+ 0x00C7, 0x00E7, // LATIN CAPITAL LETTER C WITH CEDILLA
+ 0x00C8, 0x00E8, // LATIN CAPITAL LETTER E WITH GRAVE
+ 0x00C9, 0x00E9, // LATIN CAPITAL LETTER E WITH ACUTE
+ 0x00CA, 0x00EA, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+ 0x00CB, 0x00EB, // LATIN CAPITAL LETTER E WITH DIAERESIS
+ 0x00CC, 0x00EC, // LATIN CAPITAL LETTER I WITH GRAVE
+ 0x00CD, 0x00ED, // LATIN CAPITAL LETTER I WITH ACUTE
+ 0x00CE, 0x00EE, // LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+ 0x00CF, 0x00EF, // LATIN CAPITAL LETTER I WITH DIAERESIS
+ 0x00D0, 0x00F0, // LATIN CAPITAL LETTER ETH
+ 0x00D1, 0x00F1, // LATIN CAPITAL LETTER N WITH TILDE
+ 0x00D2, 0x00F2, // LATIN CAPITAL LETTER O WITH GRAVE
+ 0x00D3, 0x00F3, // LATIN CAPITAL LETTER O WITH ACUTE
+ 0x00D4, 0x00F4, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+ 0x00D5, 0x00F5, // LATIN CAPITAL LETTER O WITH TILDE
+ 0x00D6, 0x00F6, // LATIN CAPITAL LETTER O WITH DIAERESIS
+ 0x00D8, 0x00F8, // LATIN CAPITAL LETTER O WITH STROKE
+ 0x00D9, 0x00F9, // LATIN CAPITAL LETTER U WITH GRAVE
+ 0x00DA, 0x00FA, // LATIN CAPITAL LETTER U WITH ACUTE
+ 0x00DB, 0x00FB, // LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+ 0x00DC, 0x00FC, // LATIN CAPITAL LETTER U WITH DIAERESIS
+ 0x00DD, 0x00FD, // LATIN CAPITAL LETTER Y WITH ACUTE
+ 0x00DE, 0x00FE, // LATIN CAPITAL LETTER THORN
+ 0x0100, 0x0101, // LATIN CAPITAL LETTER A WITH MACRON
+ 0x0102, 0x0103, // LATIN CAPITAL LETTER A WITH BREVE
+ 0x0104, 0x0105, // LATIN CAPITAL LETTER A WITH OGONEK
+ 0x0106, 0x0107, // LATIN CAPITAL LETTER C WITH ACUTE
+ 0x0108, 0x0109, // LATIN CAPITAL LETTER C WITH CIRCUMFLEX
+ 0x010A, 0x010B, // LATIN CAPITAL LETTER C WITH DOT ABOVE
+ 0x010C, 0x010D, // LATIN CAPITAL LETTER C WITH CARON
+ 0x010E, 0x010F, // LATIN CAPITAL LETTER D WITH CARON
+ 0x0110, 0x0111, // LATIN CAPITAL LETTER D WITH STROKE
+ 0x0112, 0x0113, // LATIN CAPITAL LETTER E WITH MACRON
+ 0x0114, 0x0115, // LATIN CAPITAL LETTER E WITH BREVE
+ 0x0116, 0x0117, // LATIN CAPITAL LETTER E WITH DOT ABOVE
+ 0x0118, 0x0119, // LATIN CAPITAL LETTER E WITH OGONEK
+ 0x011A, 0x011B, // LATIN CAPITAL LETTER E WITH CARON
+ 0x011C, 0x011D, // LATIN CAPITAL LETTER G WITH CIRCUMFLEX
+ 0x011E, 0x011F, // LATIN CAPITAL LETTER G WITH BREVE
+ 0x0120, 0x0121, // LATIN CAPITAL LETTER G WITH DOT ABOVE
+ 0x0122, 0x0123, // LATIN CAPITAL LETTER G WITH CEDILLA
+ 0x0124, 0x0125, // LATIN CAPITAL LETTER H WITH CIRCUMFLEX
+ 0x0126, 0x0127, // LATIN CAPITAL LETTER H WITH STROKE
+ 0x0128, 0x0129, // LATIN CAPITAL LETTER I WITH TILDE
+ 0x012A, 0x012B, // LATIN CAPITAL LETTER I WITH MACRON
+ 0x012C, 0x012D, // LATIN CAPITAL LETTER I WITH BREVE
+ 0x012E, 0x012F, // LATIN CAPITAL LETTER I WITH OGONEK
+ 0x0132, 0x0133, // LATIN CAPITAL LIGATURE IJ
+ 0x0134, 0x0135, // LATIN CAPITAL LETTER J WITH CIRCUMFLEX
+ 0x0136, 0x0137, // LATIN CAPITAL LETTER K WITH CEDILLA
+ 0x0139, 0x013A, // LATIN CAPITAL LETTER L WITH ACUTE
+ 0x013B, 0x013C, // LATIN CAPITAL LETTER L WITH CEDILLA
+ 0x013D, 0x013E, // LATIN CAPITAL LETTER L WITH CARON
+ 0x013F, 0x0140, // LATIN CAPITAL LETTER L WITH MIDDLE DOT
+ 0x0141, 0x0142, // LATIN CAPITAL LETTER L WITH STROKE
+ 0x0143, 0x0144, // LATIN CAPITAL LETTER N WITH ACUTE
+ 0x0145, 0x0146, // LATIN CAPITAL LETTER N WITH CEDILLA
+ 0x0147, 0x0148, // LATIN CAPITAL LETTER N WITH CARON
+ 0x014A, 0x014B, // LATIN CAPITAL LETTER ENG
+ 0x014C, 0x014D, // LATIN CAPITAL LETTER O WITH MACRON
+ 0x014E, 0x014F, // LATIN CAPITAL LETTER O WITH BREVE
+ 0x0150, 0x0151, // LATIN CAPITAL LETTER O WITH DOUBLE ACUTE
+ 0x0152, 0x0153, // LATIN CAPITAL LIGATURE OE
+ 0x0154, 0x0155, // LATIN CAPITAL LETTER R WITH ACUTE
+ 0x0156, 0x0157, // LATIN CAPITAL LETTER R WITH CEDILLA
+ 0x0158, 0x0159, // LATIN CAPITAL LETTER R WITH CARON
+ 0x015A, 0x015B, // LATIN CAPITAL LETTER S WITH ACUTE
+ 0x015C, 0x015D, // LATIN CAPITAL LETTER S WITH CIRCUMFLEX
+ 0x015E, 0x015F, // LATIN CAPITAL LETTER S WITH CEDILLA
+ 0x0160, 0x0161, // LATIN CAPITAL LETTER S WITH CARON
+ 0x0162, 0x0163, // LATIN CAPITAL LETTER T WITH CEDILLA
+ 0x0164, 0x0165, // LATIN CAPITAL LETTER T WITH CARON
+ 0x0166, 0x0167, // LATIN CAPITAL LETTER T WITH STROKE
+ 0x0168, 0x0169, // LATIN CAPITAL LETTER U WITH TILDE
+ 0x016A, 0x016B, // LATIN CAPITAL LETTER U WITH MACRON
+ 0x016C, 0x016D, // LATIN CAPITAL LETTER U WITH BREVE
+ 0x016E, 0x016F, // LATIN CAPITAL LETTER U WITH RING ABOVE
+ 0x0170, 0x0171, // LATIN CAPITAL LETTER U WITH DOUBLE ACUTE
+ 0x0172, 0x0173, // LATIN CAPITAL LETTER U WITH OGONEK
+ 0x0174, 0x0175, // LATIN CAPITAL LETTER W WITH CIRCUMFLEX
+ 0x0176, 0x0177, // LATIN CAPITAL LETTER Y WITH CIRCUMFLEX
+ 0x0178, 0x00FF, // LATIN CAPITAL LETTER Y WITH DIAERESIS
+ 0x0179, 0x017A, // LATIN CAPITAL LETTER Z WITH ACUTE
+ 0x017B, 0x017C, // LATIN CAPITAL LETTER Z WITH DOT ABOVE
+ 0x017D, 0x017E, // LATIN CAPITAL LETTER Z WITH CARON
+ 0x017F, 0x0073, // LATIN SMALL LETTER LONG S
+ 0x0181, 0x0253, // LATIN CAPITAL LETTER B WITH HOOK
+ 0x0182, 0x0183, // LATIN CAPITAL LETTER B WITH TOPBAR
+ 0x0184, 0x0185, // LATIN CAPITAL LETTER TONE SIX
+ 0x0186, 0x0254, // LATIN CAPITAL LETTER OPEN O
+ 0x0187, 0x0188, // LATIN CAPITAL LETTER C WITH HOOK
+ 0x0189, 0x0256, // LATIN CAPITAL LETTER AFRICAN D
+ 0x018A, 0x0257, // LATIN CAPITAL LETTER D WITH HOOK
+ 0x018B, 0x018C, // LATIN CAPITAL LETTER D WITH TOPBAR
+ 0x018E, 0x01DD, // LATIN CAPITAL LETTER REVERSED E
+ 0x018F, 0x0259, // LATIN CAPITAL LETTER SCHWA
+ 0x0190, 0x025B, // LATIN CAPITAL LETTER OPEN E
+ 0x0191, 0x0192, // LATIN CAPITAL LETTER F WITH HOOK
+ 0x0193, 0x0260, // LATIN CAPITAL LETTER G WITH HOOK
+ 0x0194, 0x0263, // LATIN CAPITAL LETTER GAMMA
+ 0x0196, 0x0269, // LATIN CAPITAL LETTER IOTA
+ 0x0197, 0x0268, // LATIN CAPITAL LETTER I WITH STROKE
+ 0x0198, 0x0199, // LATIN CAPITAL LETTER K WITH HOOK
+ 0x019C, 0x026F, // LATIN CAPITAL LETTER TURNED M
+ 0x019D, 0x0272, // LATIN CAPITAL LETTER N WITH LEFT HOOK
+ 0x019F, 0x0275, // LATIN CAPITAL LETTER O WITH MIDDLE TILDE
+ 0x01A0, 0x01A1, // LATIN CAPITAL LETTER O WITH HORN
+ 0x01A2, 0x01A3, // LATIN CAPITAL LETTER OI
+ 0x01A4, 0x01A5, // LATIN CAPITAL LETTER P WITH HOOK
+ 0x01A6, 0x0280, // LATIN LETTER YR
+ 0x01A7, 0x01A8, // LATIN CAPITAL LETTER TONE TWO
+ 0x01A9, 0x0283, // LATIN CAPITAL LETTER ESH
+ 0x01AC, 0x01AD, // LATIN CAPITAL LETTER T WITH HOOK
+ 0x01AE, 0x0288, // LATIN CAPITAL LETTER T WITH RETROFLEX HOOK
+ 0x01AF, 0x01B0, // LATIN CAPITAL LETTER U WITH HORN
+ 0x01B1, 0x028A, // LATIN CAPITAL LETTER UPSILON
+ 0x01B2, 0x028B, // LATIN CAPITAL LETTER V WITH HOOK
+ 0x01B3, 0x01B4, // LATIN CAPITAL LETTER Y WITH HOOK
+ 0x01B5, 0x01B6, // LATIN CAPITAL LETTER Z WITH STROKE
+ 0x01B7, 0x0292, // LATIN CAPITAL LETTER EZH
+ 0x01B8, 0x01B9, // LATIN CAPITAL LETTER EZH REVERSED
+ 0x01BC, 0x01BD, // LATIN CAPITAL LETTER TONE FIVE
+ 0x01C4, 0x01C6, // LATIN CAPITAL LETTER DZ WITH CARON
+ 0x01C5, 0x01C6, // LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON
+ 0x01C7, 0x01C9, // LATIN CAPITAL LETTER LJ
+ 0x01C8, 0x01C9, // LATIN CAPITAL LETTER L WITH SMALL LETTER J
+ 0x01CA, 0x01CC, // LATIN CAPITAL LETTER NJ
+ 0x01CB, 0x01CC, // LATIN CAPITAL LETTER N WITH SMALL LETTER J
+ 0x01CD, 0x01CE, // LATIN CAPITAL LETTER A WITH CARON
+ 0x01CF, 0x01D0, // LATIN CAPITAL LETTER I WITH CARON
+ 0x01D1, 0x01D2, // LATIN CAPITAL LETTER O WITH CARON
+ 0x01D3, 0x01D4, // LATIN CAPITAL LETTER U WITH CARON
+ 0x01D5, 0x01D6, // LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON
+ 0x01D7, 0x01D8, // LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE
+ 0x01D9, 0x01DA, // LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON
+ 0x01DB, 0x01DC, // LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE
+ 0x01DE, 0x01DF, // LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON
+ 0x01E0, 0x01E1, // LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON
+ 0x01E2, 0x01E3, // LATIN CAPITAL LETTER AE WITH MACRON
+ 0x01E4, 0x01E5, // LATIN CAPITAL LETTER G WITH STROKE
+ 0x01E6, 0x01E7, // LATIN CAPITAL LETTER G WITH CARON
+ 0x01E8, 0x01E9, // LATIN CAPITAL LETTER K WITH CARON
+ 0x01EA, 0x01EB, // LATIN CAPITAL LETTER O WITH OGONEK
+ 0x01EC, 0x01ED, // LATIN CAPITAL LETTER O WITH OGONEK AND MACRON
+ 0x01EE, 0x01EF, // LATIN CAPITAL LETTER EZH WITH CARON
+ 0x01F1, 0x01F3, // LATIN CAPITAL LETTER DZ
+ 0x01F2, 0x01F3, // LATIN CAPITAL LETTER D WITH SMALL LETTER Z
+ 0x01F4, 0x01F5, // LATIN CAPITAL LETTER G WITH ACUTE
+ 0x01F6, 0x0195, // LATIN CAPITAL LETTER HWAIR
+ 0x01F7, 0x01BF, // LATIN CAPITAL LETTER WYNN
+ 0x01F8, 0x01F9, // LATIN CAPITAL LETTER N WITH GRAVE
+ 0x01FA, 0x01FB, // LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE
+ 0x01FC, 0x01FD, // LATIN CAPITAL LETTER AE WITH ACUTE
+ 0x01FE, 0x01FF, // LATIN CAPITAL LETTER O WITH STROKE AND ACUTE
+ 0x0200, 0x0201, // LATIN CAPITAL LETTER A WITH DOUBLE GRAVE
+ 0x0202, 0x0203, // LATIN CAPITAL LETTER A WITH INVERTED BREVE
+ 0x0204, 0x0205, // LATIN CAPITAL LETTER E WITH DOUBLE GRAVE
+ 0x0206, 0x0207, // LATIN CAPITAL LETTER E WITH INVERTED BREVE
+ 0x0208, 0x0209, // LATIN CAPITAL LETTER I WITH DOUBLE GRAVE
+ 0x020A, 0x020B, // LATIN CAPITAL LETTER I WITH INVERTED BREVE
+ 0x020C, 0x020D, // LATIN CAPITAL LETTER O WITH DOUBLE GRAVE
+ 0x020E, 0x020F, // LATIN CAPITAL LETTER O WITH INVERTED BREVE
+ 0x0210, 0x0211, // LATIN CAPITAL LETTER R WITH DOUBLE GRAVE
+ 0x0212, 0x0213, // LATIN CAPITAL LETTER R WITH INVERTED BREVE
+ 0x0214, 0x0215, // LATIN CAPITAL LETTER U WITH DOUBLE GRAVE
+ 0x0216, 0x0217, // LATIN CAPITAL LETTER U WITH INVERTED BREVE
+ 0x0218, 0x0219, // LATIN CAPITAL LETTER S WITH COMMA BELOW
+ 0x021A, 0x021B, // LATIN CAPITAL LETTER T WITH COMMA BELOW
+ 0x021C, 0x021D, // LATIN CAPITAL LETTER YOGH
+ 0x021E, 0x021F, // LATIN CAPITAL LETTER H WITH CARON
+ 0x0220, 0x019E, // LATIN CAPITAL LETTER N WITH LONG RIGHT LEG
+ 0x0222, 0x0223, // LATIN CAPITAL LETTER OU
+ 0x0224, 0x0225, // LATIN CAPITAL LETTER Z WITH HOOK
+ 0x0226, 0x0227, // LATIN CAPITAL LETTER A WITH DOT ABOVE
+ 0x0228, 0x0229, // LATIN CAPITAL LETTER E WITH CEDILLA
+ 0x022A, 0x022B, // LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON
+ 0x022C, 0x022D, // LATIN CAPITAL LETTER O WITH TILDE AND MACRON
+ 0x022E, 0x022F, // LATIN CAPITAL LETTER O WITH DOT ABOVE
+ 0x0230, 0x0231, // LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON
+ 0x0232, 0x0233, // LATIN CAPITAL LETTER Y WITH MACRON
+ 0x023A, 0x2C65, // LATIN CAPITAL LETTER A WITH STROKE
+ 0x023B, 0x023C, // LATIN CAPITAL LETTER C WITH STROKE
+ 0x023D, 0x019A, // LATIN CAPITAL LETTER L WITH BAR
+ 0x023E, 0x2C66, // LATIN CAPITAL LETTER T WITH DIAGONAL STROKE
+ 0x0241, 0x0242, // LATIN CAPITAL LETTER GLOTTAL STOP
+ 0x0243, 0x0180, // LATIN CAPITAL LETTER B WITH STROKE
+ 0x0244, 0x0289, // LATIN CAPITAL LETTER U BAR
+ 0x0245, 0x028C, // LATIN CAPITAL LETTER TURNED V
+ 0x0246, 0x0247, // LATIN CAPITAL LETTER E WITH STROKE
+ 0x0248, 0x0249, // LATIN CAPITAL LETTER J WITH STROKE
+ 0x024A, 0x024B, // LATIN CAPITAL LETTER SMALL Q WITH HOOK TAIL
+ 0x024C, 0x024D, // LATIN CAPITAL LETTER R WITH STROKE
+ 0x024E, 0x024F, // LATIN CAPITAL LETTER Y WITH STROKE
+ 0x0345, 0x03B9, // COMBINING GREEK YPOGEGRAMMENI
+ 0x0386, 0x03AC, // GREEK CAPITAL LETTER ALPHA WITH TONOS
+ 0x0388, 0x03AD, // GREEK CAPITAL LETTER EPSILON WITH TONOS
+ 0x0389, 0x03AE, // GREEK CAPITAL LETTER ETA WITH TONOS
+ 0x038A, 0x03AF, // GREEK CAPITAL LETTER IOTA WITH TONOS
+ 0x038C, 0x03CC, // GREEK CAPITAL LETTER OMICRON WITH TONOS
+ 0x038E, 0x03CD, // GREEK CAPITAL LETTER UPSILON WITH TONOS
+ 0x038F, 0x03CE, // GREEK CAPITAL LETTER OMEGA WITH TONOS
+ 0x0391, 0x03B1, // GREEK CAPITAL LETTER ALPHA
+ 0x0392, 0x03B2, // GREEK CAPITAL LETTER BETA
+ 0x0393, 0x03B3, // GREEK CAPITAL LETTER GAMMA
+ 0x0394, 0x03B4, // GREEK CAPITAL LETTER DELTA
+ 0x0395, 0x03B5, // GREEK CAPITAL LETTER EPSILON
+ 0x0396, 0x03B6, // GREEK CAPITAL LETTER ZETA
+ 0x0397, 0x03B7, // GREEK CAPITAL LETTER ETA
+ 0x0398, 0x03B8, // GREEK CAPITAL LETTER THETA
+ 0x0399, 0x03B9, // GREEK CAPITAL LETTER IOTA
+ 0x039A, 0x03BA, // GREEK CAPITAL LETTER KAPPA
+ 0x039B, 0x03BB, // GREEK CAPITAL LETTER LAMDA
+ 0x039C, 0x03BC, // GREEK CAPITAL LETTER MU
+ 0x039D, 0x03BD, // GREEK CAPITAL LETTER NU
+ 0x039E, 0x03BE, // GREEK CAPITAL LETTER XI
+ 0x039F, 0x03BF, // GREEK CAPITAL LETTER OMICRON
+ 0x03A0, 0x03C0, // GREEK CAPITAL LETTER PI
+ 0x03A1, 0x03C1, // GREEK CAPITAL LETTER RHO
+ 0x03A3, 0x03C3, // GREEK CAPITAL LETTER SIGMA
+ 0x03A4, 0x03C4, // GREEK CAPITAL LETTER TAU
+ 0x03A5, 0x03C5, // GREEK CAPITAL LETTER UPSILON
+ 0x03A6, 0x03C6, // GREEK CAPITAL LETTER PHI
+ 0x03A7, 0x03C7, // GREEK CAPITAL LETTER CHI
+ 0x03A8, 0x03C8, // GREEK CAPITAL LETTER PSI
+ 0x03A9, 0x03C9, // GREEK CAPITAL LETTER OMEGA
+ 0x03AA, 0x03CA, // GREEK CAPITAL LETTER IOTA WITH DIALYTIKA
+ 0x03AB, 0x03CB, // GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA
+ 0x03C2, 0x03C3, // GREEK SMALL LETTER FINAL SIGMA
+ 0x03D0, 0x03B2, // GREEK BETA SYMBOL
+ 0x03D1, 0x03B8, // GREEK THETA SYMBOL
+ 0x03D5, 0x03C6, // GREEK PHI SYMBOL
+ 0x03D6, 0x03C0, // GREEK PI SYMBOL
+ 0x03D8, 0x03D9, // GREEK LETTER ARCHAIC KOPPA
+ 0x03DA, 0x03DB, // GREEK LETTER STIGMA
+ 0x03DC, 0x03DD, // GREEK LETTER DIGAMMA
+ 0x03DE, 0x03DF, // GREEK LETTER KOPPA
+ 0x03E0, 0x03E1, // GREEK LETTER SAMPI
+ 0x03E2, 0x03E3, // COPTIC CAPITAL LETTER SHEI
+ 0x03E4, 0x03E5, // COPTIC CAPITAL LETTER FEI
+ 0x03E6, 0x03E7, // COPTIC CAPITAL LETTER KHEI
+ 0x03E8, 0x03E9, // COPTIC CAPITAL LETTER HORI
+ 0x03EA, 0x03EB, // COPTIC CAPITAL LETTER GANGIA
+ 0x03EC, 0x03ED, // COPTIC CAPITAL LETTER SHIMA
+ 0x03EE, 0x03EF, // COPTIC CAPITAL LETTER DEI
+ 0x03F0, 0x03BA, // GREEK KAPPA SYMBOL
+ 0x03F1, 0x03C1, // GREEK RHO SYMBOL
+ 0x03F4, 0x03B8, // GREEK CAPITAL THETA SYMBOL
+ 0x03F5, 0x03B5, // GREEK LUNATE EPSILON SYMBOL
+ 0x03F7, 0x03F8, // GREEK CAPITAL LETTER SHO
+ 0x03F9, 0x03F2, // GREEK CAPITAL LUNATE SIGMA SYMBOL
+ 0x03FA, 0x03FB, // GREEK CAPITAL LETTER SAN
+ 0x03FD, 0x037B, // GREEK CAPITAL REVERSED LUNATE SIGMA SYMBOL
+ 0x03FE, 0x037C, // GREEK CAPITAL DOTTED LUNATE SIGMA SYMBOL
+ 0x03FF, 0x037D, // GREEK CAPITAL REVERSED DOTTED LUNATE SIGMA SYMBOL
+ 0x0400, 0x0450, // CYRILLIC CAPITAL LETTER IE WITH GRAVE
+ 0x0401, 0x0451, // CYRILLIC CAPITAL LETTER IO
+ 0x0402, 0x0452, // CYRILLIC CAPITAL LETTER DJE
+ 0x0403, 0x0453, // CYRILLIC CAPITAL LETTER GJE
+ 0x0404, 0x0454, // CYRILLIC CAPITAL LETTER UKRAINIAN IE
+ 0x0405, 0x0455, // CYRILLIC CAPITAL LETTER DZE
+ 0x0406, 0x0456, // CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I
+ 0x0407, 0x0457, // CYRILLIC CAPITAL LETTER YI
+ 0x0408, 0x0458, // CYRILLIC CAPITAL LETTER JE
+ 0x0409, 0x0459, // CYRILLIC CAPITAL LETTER LJE
+ 0x040A, 0x045A, // CYRILLIC CAPITAL LETTER NJE
+ 0x040B, 0x045B, // CYRILLIC CAPITAL LETTER TSHE
+ 0x040C, 0x045C, // CYRILLIC CAPITAL LETTER KJE
+ 0x040D, 0x045D, // CYRILLIC CAPITAL LETTER I WITH GRAVE
+ 0x040E, 0x045E, // CYRILLIC CAPITAL LETTER SHORT U
+ 0x040F, 0x045F, // CYRILLIC CAPITAL LETTER DZHE
+ 0x0410, 0x0430, // CYRILLIC CAPITAL LETTER A
+ 0x0411, 0x0431, // CYRILLIC CAPITAL LETTER BE
+ 0x0412, 0x0432, // CYRILLIC CAPITAL LETTER VE
+ 0x0413, 0x0433, // CYRILLIC CAPITAL LETTER GHE
+ 0x0414, 0x0434, // CYRILLIC CAPITAL LETTER DE
+ 0x0415, 0x0435, // CYRILLIC CAPITAL LETTER IE
+ 0x0416, 0x0436, // CYRILLIC CAPITAL LETTER ZHE
+ 0x0417, 0x0437, // CYRILLIC CAPITAL LETTER ZE
+ 0x0418, 0x0438, // CYRILLIC CAPITAL LETTER I
+ 0x0419, 0x0439, // CYRILLIC CAPITAL LETTER SHORT I
+ 0x041A, 0x043A, // CYRILLIC CAPITAL LETTER KA
+ 0x041B, 0x043B, // CYRILLIC CAPITAL LETTER EL
+ 0x041C, 0x043C, // CYRILLIC CAPITAL LETTER EM
+ 0x041D, 0x043D, // CYRILLIC CAPITAL LETTER EN
+ 0x041E, 0x043E, // CYRILLIC CAPITAL LETTER O
+ 0x041F, 0x043F, // CYRILLIC CAPITAL LETTER PE
+ 0x0420, 0x0440, // CYRILLIC CAPITAL LETTER ER
+ 0x0421, 0x0441, // CYRILLIC CAPITAL LETTER ES
+ 0x0422, 0x0442, // CYRILLIC CAPITAL LETTER TE
+ 0x0423, 0x0443, // CYRILLIC CAPITAL LETTER U
+ 0x0424, 0x0444, // CYRILLIC CAPITAL LETTER EF
+ 0x0425, 0x0445, // CYRILLIC CAPITAL LETTER HA
+ 0x0426, 0x0446, // CYRILLIC CAPITAL LETTER TSE
+ 0x0427, 0x0447, // CYRILLIC CAPITAL LETTER CHE
+ 0x0428, 0x0448, // CYRILLIC CAPITAL LETTER SHA
+ 0x0429, 0x0449, // CYRILLIC CAPITAL LETTER SHCHA
+ 0x042A, 0x044A, // CYRILLIC CAPITAL LETTER HARD SIGN
+ 0x042B, 0x044B, // CYRILLIC CAPITAL LETTER YERU
+ 0x042C, 0x044C, // CYRILLIC CAPITAL LETTER SOFT SIGN
+ 0x042D, 0x044D, // CYRILLIC CAPITAL LETTER E
+ 0x042E, 0x044E, // CYRILLIC CAPITAL LETTER YU
+ 0x042F, 0x044F, // CYRILLIC CAPITAL LETTER YA
+ 0x0460, 0x0461, // CYRILLIC CAPITAL LETTER OMEGA
+ 0x0462, 0x0463, // CYRILLIC CAPITAL LETTER YAT
+ 0x0464, 0x0465, // CYRILLIC CAPITAL LETTER IOTIFIED E
+ 0x0466, 0x0467, // CYRILLIC CAPITAL LETTER LITTLE YUS
+ 0x0468, 0x0469, // CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS
+ 0x046A, 0x046B, // CYRILLIC CAPITAL LETTER BIG YUS
+ 0x046C, 0x046D, // CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS
+ 0x046E, 0x046F, // CYRILLIC CAPITAL LETTER KSI
+ 0x0470, 0x0471, // CYRILLIC CAPITAL LETTER PSI
+ 0x0472, 0x0473, // CYRILLIC CAPITAL LETTER FITA
+ 0x0474, 0x0475, // CYRILLIC CAPITAL LETTER IZHITSA
+ 0x0476, 0x0477, // CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT
+ 0x0478, 0x0479, // CYRILLIC CAPITAL LETTER UK
+ 0x047A, 0x047B, // CYRILLIC CAPITAL LETTER ROUND OMEGA
+ 0x047C, 0x047D, // CYRILLIC CAPITAL LETTER OMEGA WITH TITLO
+ 0x047E, 0x047F, // CYRILLIC CAPITAL LETTER OT
+ 0x0480, 0x0481, // CYRILLIC CAPITAL LETTER KOPPA
+ 0x048A, 0x048B, // CYRILLIC CAPITAL LETTER SHORT I WITH TAIL
+ 0x048C, 0x048D, // CYRILLIC CAPITAL LETTER SEMISOFT SIGN
+ 0x048E, 0x048F, // CYRILLIC CAPITAL LETTER ER WITH TICK
+ 0x0490, 0x0491, // CYRILLIC CAPITAL LETTER GHE WITH UPTURN
+ 0x0492, 0x0493, // CYRILLIC CAPITAL LETTER GHE WITH STROKE
+ 0x0494, 0x0495, // CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK
+ 0x0496, 0x0497, // CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER
+ 0x0498, 0x0499, // CYRILLIC CAPITAL LETTER ZE WITH DESCENDER
+ 0x049A, 0x049B, // CYRILLIC CAPITAL LETTER KA WITH DESCENDER
+ 0x049C, 0x049D, // CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE
+ 0x049E, 0x049F, // CYRILLIC CAPITAL LETTER KA WITH STROKE
+ 0x04A0, 0x04A1, // CYRILLIC CAPITAL LETTER BASHKIR KA
+ 0x04A2, 0x04A3, // CYRILLIC CAPITAL LETTER EN WITH DESCENDER
+ 0x04A4, 0x04A5, // CYRILLIC CAPITAL LIGATURE EN GHE
+ 0x04A6, 0x04A7, // CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK
+ 0x04A8, 0x04A9, // CYRILLIC CAPITAL LETTER ABKHASIAN HA
+ 0x04AA, 0x04AB, // CYRILLIC CAPITAL LETTER ES WITH DESCENDER
+ 0x04AC, 0x04AD, // CYRILLIC CAPITAL LETTER TE WITH DESCENDER
+ 0x04AE, 0x04AF, // CYRILLIC CAPITAL LETTER STRAIGHT U
+ 0x04B0, 0x04B1, // CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE
+ 0x04B2, 0x04B3, // CYRILLIC CAPITAL LETTER HA WITH DESCENDER
+ 0x04B4, 0x04B5, // CYRILLIC CAPITAL LIGATURE TE TSE
+ 0x04B6, 0x04B7, // CYRILLIC CAPITAL LETTER CHE WITH DESCENDER
+ 0x04B8, 0x04B9, // CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE
+ 0x04BA, 0x04BB, // CYRILLIC CAPITAL LETTER SHHA
+ 0x04BC, 0x04BD, // CYRILLIC CAPITAL LETTER ABKHASIAN CHE
+ 0x04BE, 0x04BF, // CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER
+ 0x04C0, 0x04CF, // CYRILLIC LETTER PALOCHKA
+ 0x04C1, 0x04C2, // CYRILLIC CAPITAL LETTER ZHE WITH BREVE
+ 0x04C3, 0x04C4, // CYRILLIC CAPITAL LETTER KA WITH HOOK
+ 0x04C5, 0x04C6, // CYRILLIC CAPITAL LETTER EL WITH TAIL
+ 0x04C7, 0x04C8, // CYRILLIC CAPITAL LETTER EN WITH HOOK
+ 0x04C9, 0x04CA, // CYRILLIC CAPITAL LETTER EN WITH TAIL
+ 0x04CB, 0x04CC, // CYRILLIC CAPITAL LETTER KHAKASSIAN CHE
+ 0x04CD, 0x04CE, // CYRILLIC CAPITAL LETTER EM WITH TAIL
+ 0x04D0, 0x04D1, // CYRILLIC CAPITAL LETTER A WITH BREVE
+ 0x04D2, 0x04D3, // CYRILLIC CAPITAL LETTER A WITH DIAERESIS
+ 0x04D4, 0x04D5, // CYRILLIC CAPITAL LIGATURE A IE
+ 0x04D6, 0x04D7, // CYRILLIC CAPITAL LETTER IE WITH BREVE
+ 0x04D8, 0x04D9, // CYRILLIC CAPITAL LETTER SCHWA
+ 0x04DA, 0x04DB, // CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS
+ 0x04DC, 0x04DD, // CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS
+ 0x04DE, 0x04DF, // CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS
+ 0x04E0, 0x04E1, // CYRILLIC CAPITAL LETTER ABKHASIAN DZE
+ 0x04E2, 0x04E3, // CYRILLIC CAPITAL LETTER I WITH MACRON
+ 0x04E4, 0x04E5, // CYRILLIC CAPITAL LETTER I WITH DIAERESIS
+ 0x04E6, 0x04E7, // CYRILLIC CAPITAL LETTER O WITH DIAERESIS
+ 0x04E8, 0x04E9, // CYRILLIC CAPITAL LETTER BARRED O
+ 0x04EA, 0x04EB, // CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS
+ 0x04EC, 0x04ED, // CYRILLIC CAPITAL LETTER E WITH DIAERESIS
+ 0x04EE, 0x04EF, // CYRILLIC CAPITAL LETTER U WITH MACRON
+ 0x04F0, 0x04F1, // CYRILLIC CAPITAL LETTER U WITH DIAERESIS
+ 0x04F2, 0x04F3, // CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE
+ 0x04F4, 0x04F5, // CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS
+ 0x04F6, 0x04F7, // CYRILLIC CAPITAL LETTER GHE WITH DESCENDER
+ 0x04F8, 0x04F9, // CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS
+ 0x04FA, 0x04FB, // CYRILLIC CAPITAL LETTER GHE WITH STROKE AND HOOK
+ 0x04FC, 0x04FD, // CYRILLIC CAPITAL LETTER HA WITH HOOK
+ 0x04FE, 0x04FF, // CYRILLIC CAPITAL LETTER HA WITH STROKE
+ 0x0500, 0x0501, // CYRILLIC CAPITAL LETTER KOMI DE
+ 0x0502, 0x0503, // CYRILLIC CAPITAL LETTER KOMI DJE
+ 0x0504, 0x0505, // CYRILLIC CAPITAL LETTER KOMI ZJE
+ 0x0506, 0x0507, // CYRILLIC CAPITAL LETTER KOMI DZJE
+ 0x0508, 0x0509, // CYRILLIC CAPITAL LETTER KOMI LJE
+ 0x050A, 0x050B, // CYRILLIC CAPITAL LETTER KOMI NJE
+ 0x050C, 0x050D, // CYRILLIC CAPITAL LETTER KOMI SJE
+ 0x050E, 0x050F, // CYRILLIC CAPITAL LETTER KOMI TJE
+ 0x0510, 0x0511, // CYRILLIC CAPITAL LETTER REVERSED ZE
+ 0x0512, 0x0513, // CYRILLIC CAPITAL LETTER EL WITH HOOK
+ 0x0531, 0x0561, // ARMENIAN CAPITAL LETTER AYB
+ 0x0532, 0x0562, // ARMENIAN CAPITAL LETTER BEN
+ 0x0533, 0x0563, // ARMENIAN CAPITAL LETTER GIM
+ 0x0534, 0x0564, // ARMENIAN CAPITAL LETTER DA
+ 0x0535, 0x0565, // ARMENIAN CAPITAL LETTER ECH
+ 0x0536, 0x0566, // ARMENIAN CAPITAL LETTER ZA
+ 0x0537, 0x0567, // ARMENIAN CAPITAL LETTER EH
+ 0x0538, 0x0568, // ARMENIAN CAPITAL LETTER ET
+ 0x0539, 0x0569, // ARMENIAN CAPITAL LETTER TO
+ 0x053A, 0x056A, // ARMENIAN CAPITAL LETTER ZHE
+ 0x053B, 0x056B, // ARMENIAN CAPITAL LETTER INI
+ 0x053C, 0x056C, // ARMENIAN CAPITAL LETTER LIWN
+ 0x053D, 0x056D, // ARMENIAN CAPITAL LETTER XEH
+ 0x053E, 0x056E, // ARMENIAN CAPITAL LETTER CA
+ 0x053F, 0x056F, // ARMENIAN CAPITAL LETTER KEN
+ 0x0540, 0x0570, // ARMENIAN CAPITAL LETTER HO
+ 0x0541, 0x0571, // ARMENIAN CAPITAL LETTER JA
+ 0x0542, 0x0572, // ARMENIAN CAPITAL LETTER GHAD
+ 0x0543, 0x0573, // ARMENIAN CAPITAL LETTER CHEH
+ 0x0544, 0x0574, // ARMENIAN CAPITAL LETTER MEN
+ 0x0545, 0x0575, // ARMENIAN CAPITAL LETTER YI
+ 0x0546, 0x0576, // ARMENIAN CAPITAL LETTER NOW
+ 0x0547, 0x0577, // ARMENIAN CAPITAL LETTER SHA
+ 0x0548, 0x0578, // ARMENIAN CAPITAL LETTER VO
+ 0x0549, 0x0579, // ARMENIAN CAPITAL LETTER CHA
+ 0x054A, 0x057A, // ARMENIAN CAPITAL LETTER PEH
+ 0x054B, 0x057B, // ARMENIAN CAPITAL LETTER JHEH
+ 0x054C, 0x057C, // ARMENIAN CAPITAL LETTER RA
+ 0x054D, 0x057D, // ARMENIAN CAPITAL LETTER SEH
+ 0x054E, 0x057E, // ARMENIAN CAPITAL LETTER VEW
+ 0x054F, 0x057F, // ARMENIAN CAPITAL LETTER TIWN
+ 0x0550, 0x0580, // ARMENIAN CAPITAL LETTER REH
+ 0x0551, 0x0581, // ARMENIAN CAPITAL LETTER CO
+ 0x0552, 0x0582, // ARMENIAN CAPITAL LETTER YIWN
+ 0x0553, 0x0583, // ARMENIAN CAPITAL LETTER PIWR
+ 0x0554, 0x0584, // ARMENIAN CAPITAL LETTER KEH
+ 0x0555, 0x0585, // ARMENIAN CAPITAL LETTER OH
+ 0x0556, 0x0586, // ARMENIAN CAPITAL LETTER FEH
+ 0x10A0, 0x2D00, // GEORGIAN CAPITAL LETTER AN
+ 0x10A1, 0x2D01, // GEORGIAN CAPITAL LETTER BAN
+ 0x10A2, 0x2D02, // GEORGIAN CAPITAL LETTER GAN
+ 0x10A3, 0x2D03, // GEORGIAN CAPITAL LETTER DON
+ 0x10A4, 0x2D04, // GEORGIAN CAPITAL LETTER EN
+ 0x10A5, 0x2D05, // GEORGIAN CAPITAL LETTER VIN
+ 0x10A6, 0x2D06, // GEORGIAN CAPITAL LETTER ZEN
+ 0x10A7, 0x2D07, // GEORGIAN CAPITAL LETTER TAN
+ 0x10A8, 0x2D08, // GEORGIAN CAPITAL LETTER IN
+ 0x10A9, 0x2D09, // GEORGIAN CAPITAL LETTER KAN
+ 0x10AA, 0x2D0A, // GEORGIAN CAPITAL LETTER LAS
+ 0x10AB, 0x2D0B, // GEORGIAN CAPITAL LETTER MAN
+ 0x10AC, 0x2D0C, // GEORGIAN CAPITAL LETTER NAR
+ 0x10AD, 0x2D0D, // GEORGIAN CAPITAL LETTER ON
+ 0x10AE, 0x2D0E, // GEORGIAN CAPITAL LETTER PAR
+ 0x10AF, 0x2D0F, // GEORGIAN CAPITAL LETTER ZHAR
+ 0x10B0, 0x2D10, // GEORGIAN CAPITAL LETTER RAE
+ 0x10B1, 0x2D11, // GEORGIAN CAPITAL LETTER SAN
+ 0x10B2, 0x2D12, // GEORGIAN CAPITAL LETTER TAR
+ 0x10B3, 0x2D13, // GEORGIAN CAPITAL LETTER UN
+ 0x10B4, 0x2D14, // GEORGIAN CAPITAL LETTER PHAR
+ 0x10B5, 0x2D15, // GEORGIAN CAPITAL LETTER KHAR
+ 0x10B6, 0x2D16, // GEORGIAN CAPITAL LETTER GHAN
+ 0x10B7, 0x2D17, // GEORGIAN CAPITAL LETTER QAR
+ 0x10B8, 0x2D18, // GEORGIAN CAPITAL LETTER SHIN
+ 0x10B9, 0x2D19, // GEORGIAN CAPITAL LETTER CHIN
+ 0x10BA, 0x2D1A, // GEORGIAN CAPITAL LETTER CAN
+ 0x10BB, 0x2D1B, // GEORGIAN CAPITAL LETTER JIL
+ 0x10BC, 0x2D1C, // GEORGIAN CAPITAL LETTER CIL
+ 0x10BD, 0x2D1D, // GEORGIAN CAPITAL LETTER CHAR
+ 0x10BE, 0x2D1E, // GEORGIAN CAPITAL LETTER XAN
+ 0x10BF, 0x2D1F, // GEORGIAN CAPITAL LETTER JHAN
+ 0x10C0, 0x2D20, // GEORGIAN CAPITAL LETTER HAE
+ 0x10C1, 0x2D21, // GEORGIAN CAPITAL LETTER HE
+ 0x10C2, 0x2D22, // GEORGIAN CAPITAL LETTER HIE
+ 0x10C3, 0x2D23, // GEORGIAN CAPITAL LETTER WE
+ 0x10C4, 0x2D24, // GEORGIAN CAPITAL LETTER HAR
+ 0x10C5, 0x2D25, // GEORGIAN CAPITAL LETTER HOE
+ 0x1E00, 0x1E01, // LATIN CAPITAL LETTER A WITH RING BELOW
+ 0x1E02, 0x1E03, // LATIN CAPITAL LETTER B WITH DOT ABOVE
+ 0x1E04, 0x1E05, // LATIN CAPITAL LETTER B WITH DOT BELOW
+ 0x1E06, 0x1E07, // LATIN CAPITAL LETTER B WITH LINE BELOW
+ 0x1E08, 0x1E09, // LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE
+ 0x1E0A, 0x1E0B, // LATIN CAPITAL LETTER D WITH DOT ABOVE
+ 0x1E0C, 0x1E0D, // LATIN CAPITAL LETTER D WITH DOT BELOW
+ 0x1E0E, 0x1E0F, // LATIN CAPITAL LETTER D WITH LINE BELOW
+ 0x1E10, 0x1E11, // LATIN CAPITAL LETTER D WITH CEDILLA
+ 0x1E12, 0x1E13, // LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW
+ 0x1E14, 0x1E15, // LATIN CAPITAL LETTER E WITH MACRON AND GRAVE
+ 0x1E16, 0x1E17, // LATIN CAPITAL LETTER E WITH MACRON AND ACUTE
+ 0x1E18, 0x1E19, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW
+ 0x1E1A, 0x1E1B, // LATIN CAPITAL LETTER E WITH TILDE BELOW
+ 0x1E1C, 0x1E1D, // LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE
+ 0x1E1E, 0x1E1F, // LATIN CAPITAL LETTER F WITH DOT ABOVE
+ 0x1E20, 0x1E21, // LATIN CAPITAL LETTER G WITH MACRON
+ 0x1E22, 0x1E23, // LATIN CAPITAL LETTER H WITH DOT ABOVE
+ 0x1E24, 0x1E25, // LATIN CAPITAL LETTER H WITH DOT BELOW
+ 0x1E26, 0x1E27, // LATIN CAPITAL LETTER H WITH DIAERESIS
+ 0x1E28, 0x1E29, // LATIN CAPITAL LETTER H WITH CEDILLA
+ 0x1E2A, 0x1E2B, // LATIN CAPITAL LETTER H WITH BREVE BELOW
+ 0x1E2C, 0x1E2D, // LATIN CAPITAL LETTER I WITH TILDE BELOW
+ 0x1E2E, 0x1E2F, // LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE
+ 0x1E30, 0x1E31, // LATIN CAPITAL LETTER K WITH ACUTE
+ 0x1E32, 0x1E33, // LATIN CAPITAL LETTER K WITH DOT BELOW
+ 0x1E34, 0x1E35, // LATIN CAPITAL LETTER K WITH LINE BELOW
+ 0x1E36, 0x1E37, // LATIN CAPITAL LETTER L WITH DOT BELOW
+ 0x1E38, 0x1E39, // LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON
+ 0x1E3A, 0x1E3B, // LATIN CAPITAL LETTER L WITH LINE BELOW
+ 0x1E3C, 0x1E3D, // LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW
+ 0x1E3E, 0x1E3F, // LATIN CAPITAL LETTER M WITH ACUTE
+ 0x1E40, 0x1E41, // LATIN CAPITAL LETTER M WITH DOT ABOVE
+ 0x1E42, 0x1E43, // LATIN CAPITAL LETTER M WITH DOT BELOW
+ 0x1E44, 0x1E45, // LATIN CAPITAL LETTER N WITH DOT ABOVE
+ 0x1E46, 0x1E47, // LATIN CAPITAL LETTER N WITH DOT BELOW
+ 0x1E48, 0x1E49, // LATIN CAPITAL LETTER N WITH LINE BELOW
+ 0x1E4A, 0x1E4B, // LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW
+ 0x1E4C, 0x1E4D, // LATIN CAPITAL LETTER O WITH TILDE AND ACUTE
+ 0x1E4E, 0x1E4F, // LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS
+ 0x1E50, 0x1E51, // LATIN CAPITAL LETTER O WITH MACRON AND GRAVE
+ 0x1E52, 0x1E53, // LATIN CAPITAL LETTER O WITH MACRON AND ACUTE
+ 0x1E54, 0x1E55, // LATIN CAPITAL LETTER P WITH ACUTE
+ 0x1E56, 0x1E57, // LATIN CAPITAL LETTER P WITH DOT ABOVE
+ 0x1E58, 0x1E59, // LATIN CAPITAL LETTER R WITH DOT ABOVE
+ 0x1E5A, 0x1E5B, // LATIN CAPITAL LETTER R WITH DOT BELOW
+ 0x1E5C, 0x1E5D, // LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON
+ 0x1E5E, 0x1E5F, // LATIN CAPITAL LETTER R WITH LINE BELOW
+ 0x1E60, 0x1E61, // LATIN CAPITAL LETTER S WITH DOT ABOVE
+ 0x1E62, 0x1E63, // LATIN CAPITAL LETTER S WITH DOT BELOW
+ 0x1E64, 0x1E65, // LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE
+ 0x1E66, 0x1E67, // LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE
+ 0x1E68, 0x1E69, // LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE
+ 0x1E6A, 0x1E6B, // LATIN CAPITAL LETTER T WITH DOT ABOVE
+ 0x1E6C, 0x1E6D, // LATIN CAPITAL LETTER T WITH DOT BELOW
+ 0x1E6E, 0x1E6F, // LATIN CAPITAL LETTER T WITH LINE BELOW
+ 0x1E70, 0x1E71, // LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW
+ 0x1E72, 0x1E73, // LATIN CAPITAL LETTER U WITH DIAERESIS BELOW
+ 0x1E74, 0x1E75, // LATIN CAPITAL LETTER U WITH TILDE BELOW
+ 0x1E76, 0x1E77, // LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW
+ 0x1E78, 0x1E79, // LATIN CAPITAL LETTER U WITH TILDE AND ACUTE
+ 0x1E7A, 0x1E7B, // LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS
+ 0x1E7C, 0x1E7D, // LATIN CAPITAL LETTER V WITH TILDE
+ 0x1E7E, 0x1E7F, // LATIN CAPITAL LETTER V WITH DOT BELOW
+ 0x1E80, 0x1E81, // LATIN CAPITAL LETTER W WITH GRAVE
+ 0x1E82, 0x1E83, // LATIN CAPITAL LETTER W WITH ACUTE
+ 0x1E84, 0x1E85, // LATIN CAPITAL LETTER W WITH DIAERESIS
+ 0x1E86, 0x1E87, // LATIN CAPITAL LETTER W WITH DOT ABOVE
+ 0x1E88, 0x1E89, // LATIN CAPITAL LETTER W WITH DOT BELOW
+ 0x1E8A, 0x1E8B, // LATIN CAPITAL LETTER X WITH DOT ABOVE
+ 0x1E8C, 0x1E8D, // LATIN CAPITAL LETTER X WITH DIAERESIS
+ 0x1E8E, 0x1E8F, // LATIN CAPITAL LETTER Y WITH DOT ABOVE
+ 0x1E90, 0x1E91, // LATIN CAPITAL LETTER Z WITH CIRCUMFLEX
+ 0x1E92, 0x1E93, // LATIN CAPITAL LETTER Z WITH DOT BELOW
+ 0x1E94, 0x1E95, // LATIN CAPITAL LETTER Z WITH LINE BELOW
+ 0x1E9B, 0x1E61, // LATIN SMALL LETTER LONG S WITH DOT ABOVE
+ 0x1EA0, 0x1EA1, // LATIN CAPITAL LETTER A WITH DOT BELOW
+ 0x1EA2, 0x1EA3, // LATIN CAPITAL LETTER A WITH HOOK ABOVE
+ 0x1EA4, 0x1EA5, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE
+ 0x1EA6, 0x1EA7, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE
+ 0x1EA8, 0x1EA9, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE
+ 0x1EAA, 0x1EAB, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE
+ 0x1EAC, 0x1EAD, // LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW
+ 0x1EAE, 0x1EAF, // LATIN CAPITAL LETTER A WITH BREVE AND ACUTE
+ 0x1EB0, 0x1EB1, // LATIN CAPITAL LETTER A WITH BREVE AND GRAVE
+ 0x1EB2, 0x1EB3, // LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE
+ 0x1EB4, 0x1EB5, // LATIN CAPITAL LETTER A WITH BREVE AND TILDE
+ 0x1EB6, 0x1EB7, // LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW
+ 0x1EB8, 0x1EB9, // LATIN CAPITAL LETTER E WITH DOT BELOW
+ 0x1EBA, 0x1EBB, // LATIN CAPITAL LETTER E WITH HOOK ABOVE
+ 0x1EBC, 0x1EBD, // LATIN CAPITAL LETTER E WITH TILDE
+ 0x1EBE, 0x1EBF, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE
+ 0x1EC0, 0x1EC1, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE
+ 0x1EC2, 0x1EC3, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE
+ 0x1EC4, 0x1EC5, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE
+ 0x1EC6, 0x1EC7, // LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW
+ 0x1EC8, 0x1EC9, // LATIN CAPITAL LETTER I WITH HOOK ABOVE
+ 0x1ECA, 0x1ECB, // LATIN CAPITAL LETTER I WITH DOT BELOW
+ 0x1ECC, 0x1ECD, // LATIN CAPITAL LETTER O WITH DOT BELOW
+ 0x1ECE, 0x1ECF, // LATIN CAPITAL LETTER O WITH HOOK ABOVE
+ 0x1ED0, 0x1ED1, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE
+ 0x1ED2, 0x1ED3, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE
+ 0x1ED4, 0x1ED5, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE
+ 0x1ED6, 0x1ED7, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE
+ 0x1ED8, 0x1ED9, // LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW
+ 0x1EDA, 0x1EDB, // LATIN CAPITAL LETTER O WITH HORN AND ACUTE
+ 0x1EDC, 0x1EDD, // LATIN CAPITAL LETTER O WITH HORN AND GRAVE
+ 0x1EDE, 0x1EDF, // LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE
+ 0x1EE0, 0x1EE1, // LATIN CAPITAL LETTER O WITH HORN AND TILDE
+ 0x1EE2, 0x1EE3, // LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW
+ 0x1EE4, 0x1EE5, // LATIN CAPITAL LETTER U WITH DOT BELOW
+ 0x1EE6, 0x1EE7, // LATIN CAPITAL LETTER U WITH HOOK ABOVE
+ 0x1EE8, 0x1EE9, // LATIN CAPITAL LETTER U WITH HORN AND ACUTE
+ 0x1EEA, 0x1EEB, // LATIN CAPITAL LETTER U WITH HORN AND GRAVE
+ 0x1EEC, 0x1EED, // LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE
+ 0x1EEE, 0x1EEF, // LATIN CAPITAL LETTER U WITH HORN AND TILDE
+ 0x1EF0, 0x1EF1, // LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW
+ 0x1EF2, 0x1EF3, // LATIN CAPITAL LETTER Y WITH GRAVE
+ 0x1EF4, 0x1EF5, // LATIN CAPITAL LETTER Y WITH DOT BELOW
+ 0x1EF6, 0x1EF7, // LATIN CAPITAL LETTER Y WITH HOOK ABOVE
+ 0x1EF8, 0x1EF9, // LATIN CAPITAL LETTER Y WITH TILDE
+ 0x1F08, 0x1F00, // GREEK CAPITAL LETTER ALPHA WITH PSILI
+ 0x1F09, 0x1F01, // GREEK CAPITAL LETTER ALPHA WITH DASIA
+ 0x1F0A, 0x1F02, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA
+ 0x1F0B, 0x1F03, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA
+ 0x1F0C, 0x1F04, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA
+ 0x1F0D, 0x1F05, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA
+ 0x1F0E, 0x1F06, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI
+ 0x1F0F, 0x1F07, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI
+ 0x1F18, 0x1F10, // GREEK CAPITAL LETTER EPSILON WITH PSILI
+ 0x1F19, 0x1F11, // GREEK CAPITAL LETTER EPSILON WITH DASIA
+ 0x1F1A, 0x1F12, // GREEK CAPITAL LETTER EPSILON WITH PSILI AND VARIA
+ 0x1F1B, 0x1F13, // GREEK CAPITAL LETTER EPSILON WITH DASIA AND VARIA
+ 0x1F1C, 0x1F14, // GREEK CAPITAL LETTER EPSILON WITH PSILI AND OXIA
+ 0x1F1D, 0x1F15, // GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA
+ 0x1F28, 0x1F20, // GREEK CAPITAL LETTER ETA WITH PSILI
+ 0x1F29, 0x1F21, // GREEK CAPITAL LETTER ETA WITH DASIA
+ 0x1F2A, 0x1F22, // GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA
+ 0x1F2B, 0x1F23, // GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA
+ 0x1F2C, 0x1F24, // GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA
+ 0x1F2D, 0x1F25, // GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA
+ 0x1F2E, 0x1F26, // GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI
+ 0x1F2F, 0x1F27, // GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI
+ 0x1F38, 0x1F30, // GREEK CAPITAL LETTER IOTA WITH PSILI
+ 0x1F39, 0x1F31, // GREEK CAPITAL LETTER IOTA WITH DASIA
+ 0x1F3A, 0x1F32, // GREEK CAPITAL LETTER IOTA WITH PSILI AND VARIA
+ 0x1F3B, 0x1F33, // GREEK CAPITAL LETTER IOTA WITH DASIA AND VARIA
+ 0x1F3C, 0x1F34, // GREEK CAPITAL LETTER IOTA WITH PSILI AND OXIA
+ 0x1F3D, 0x1F35, // GREEK CAPITAL LETTER IOTA WITH DASIA AND OXIA
+ 0x1F3E, 0x1F36, // GREEK CAPITAL LETTER IOTA WITH PSILI AND PERISPOMENI
+ 0x1F3F, 0x1F37, // GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI
+ 0x1F48, 0x1F40, // GREEK CAPITAL LETTER OMICRON WITH PSILI
+ 0x1F49, 0x1F41, // GREEK CAPITAL LETTER OMICRON WITH DASIA
+ 0x1F4A, 0x1F42, // GREEK CAPITAL LETTER OMICRON WITH PSILI AND VARIA
+ 0x1F4B, 0x1F43, // GREEK CAPITAL LETTER OMICRON WITH DASIA AND VARIA
+ 0x1F4C, 0x1F44, // GREEK CAPITAL LETTER OMICRON WITH PSILI AND OXIA
+ 0x1F4D, 0x1F45, // GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA
+ 0x1F59, 0x1F51, // GREEK CAPITAL LETTER UPSILON WITH DASIA
+ 0x1F5B, 0x1F53, // GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA
+ 0x1F5D, 0x1F55, // GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA
+ 0x1F5F, 0x1F57, // GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI
+ 0x1F68, 0x1F60, // GREEK CAPITAL LETTER OMEGA WITH PSILI
+ 0x1F69, 0x1F61, // GREEK CAPITAL LETTER OMEGA WITH DASIA
+ 0x1F6A, 0x1F62, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA
+ 0x1F6B, 0x1F63, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA
+ 0x1F6C, 0x1F64, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA
+ 0x1F6D, 0x1F65, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA
+ 0x1F6E, 0x1F66, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI
+ 0x1F6F, 0x1F67, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI
+ 0x1F88, 0x1F80, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI
+ 0x1F89, 0x1F81, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI
+ 0x1F8A, 0x1F82, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI
+ 0x1F8B, 0x1F83, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI
+ 0x1F8C, 0x1F84, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI
+ 0x1F8D, 0x1F85, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI
+ 0x1F8E, 0x1F86, // GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
+ 0x1F8F, 0x1F87, // GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
+ 0x1F98, 0x1F90, // GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI
+ 0x1F99, 0x1F91, // GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI
+ 0x1F9A, 0x1F92, // GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI
+ 0x1F9B, 0x1F93, // GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI
+ 0x1F9C, 0x1F94, // GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI
+ 0x1F9D, 0x1F95, // GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI
+ 0x1F9E, 0x1F96, // GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
+ 0x1F9F, 0x1F97, // GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
+ 0x1FA8, 0x1FA0, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI
+ 0x1FA9, 0x1FA1, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI
+ 0x1FAA, 0x1FA2, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI
+ 0x1FAB, 0x1FA3, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI
+ 0x1FAC, 0x1FA4, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI
+ 0x1FAD, 0x1FA5, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI
+ 0x1FAE, 0x1FA6, // GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI
+ 0x1FAF, 0x1FA7, // GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI
+ 0x1FB8, 0x1FB0, // GREEK CAPITAL LETTER ALPHA WITH VRACHY
+ 0x1FB9, 0x1FB1, // GREEK CAPITAL LETTER ALPHA WITH MACRON
+ 0x1FBA, 0x1F70, // GREEK CAPITAL LETTER ALPHA WITH VARIA
+ 0x1FBB, 0x1F71, // GREEK CAPITAL LETTER ALPHA WITH OXIA
+ 0x1FBC, 0x1FB3, // GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI
+ 0x1FBE, 0x03B9, // GREEK PROSGEGRAMMENI
+ 0x1FC8, 0x1F72, // GREEK CAPITAL LETTER EPSILON WITH VARIA
+ 0x1FC9, 0x1F73, // GREEK CAPITAL LETTER EPSILON WITH OXIA
+ 0x1FCA, 0x1F74, // GREEK CAPITAL LETTER ETA WITH VARIA
+ 0x1FCB, 0x1F75, // GREEK CAPITAL LETTER ETA WITH OXIA
+ 0x1FCC, 0x1FC3, // GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI
+ 0x1FD8, 0x1FD0, // GREEK CAPITAL LETTER IOTA WITH VRACHY
+ 0x1FD9, 0x1FD1, // GREEK CAPITAL LETTER IOTA WITH MACRON
+ 0x1FDA, 0x1F76, // GREEK CAPITAL LETTER IOTA WITH VARIA
+ 0x1FDB, 0x1F77, // GREEK CAPITAL LETTER IOTA WITH OXIA
+ 0x1FE8, 0x1FE0, // GREEK CAPITAL LETTER UPSILON WITH VRACHY
+ 0x1FE9, 0x1FE1, // GREEK CAPITAL LETTER UPSILON WITH MACRON
+ 0x1FEA, 0x1F7A, // GREEK CAPITAL LETTER UPSILON WITH VARIA
+ 0x1FEB, 0x1F7B, // GREEK CAPITAL LETTER UPSILON WITH OXIA
+ 0x1FEC, 0x1FE5, // GREEK CAPITAL LETTER RHO WITH DASIA
+ 0x1FF8, 0x1F78, // GREEK CAPITAL LETTER OMICRON WITH VARIA
+ 0x1FF9, 0x1F79, // GREEK CAPITAL LETTER OMICRON WITH OXIA
+ 0x1FFA, 0x1F7C, // GREEK CAPITAL LETTER OMEGA WITH VARIA
+ 0x1FFB, 0x1F7D, // GREEK CAPITAL LETTER OMEGA WITH OXIA
+ 0x1FFC, 0x1FF3, // GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI
+ 0x2126, 0x03C9, // OHM SIGN
+ 0x212A, 0x006B, // KELVIN SIGN
+ 0x212B, 0x00E5, // ANGSTROM SIGN
+ 0x2132, 0x214E, // TURNED CAPITAL F
+ 0x2160, 0x2170, // ROMAN NUMERAL ONE
+ 0x2161, 0x2171, // ROMAN NUMERAL TWO
+ 0x2162, 0x2172, // ROMAN NUMERAL THREE
+ 0x2163, 0x2173, // ROMAN NUMERAL FOUR
+ 0x2164, 0x2174, // ROMAN NUMERAL FIVE
+ 0x2165, 0x2175, // ROMAN NUMERAL SIX
+ 0x2166, 0x2176, // ROMAN NUMERAL SEVEN
+ 0x2167, 0x2177, // ROMAN NUMERAL EIGHT
+ 0x2168, 0x2178, // ROMAN NUMERAL NINE
+ 0x2169, 0x2179, // ROMAN NUMERAL TEN
+ 0x216A, 0x217A, // ROMAN NUMERAL ELEVEN
+ 0x216B, 0x217B, // ROMAN NUMERAL TWELVE
+ 0x216C, 0x217C, // ROMAN NUMERAL FIFTY
+ 0x216D, 0x217D, // ROMAN NUMERAL ONE HUNDRED
+ 0x216E, 0x217E, // ROMAN NUMERAL FIVE HUNDRED
+ 0x216F, 0x217F, // ROMAN NUMERAL ONE THOUSAND
+ 0x2183, 0x2184, // ROMAN NUMERAL REVERSED ONE HUNDRED
+ 0x24B6, 0x24D0, // CIRCLED LATIN CAPITAL LETTER A
+ 0x24B7, 0x24D1, // CIRCLED LATIN CAPITAL LETTER B
+ 0x24B8, 0x24D2, // CIRCLED LATIN CAPITAL LETTER C
+ 0x24B9, 0x24D3, // CIRCLED LATIN CAPITAL LETTER D
+ 0x24BA, 0x24D4, // CIRCLED LATIN CAPITAL LETTER E
+ 0x24BB, 0x24D5, // CIRCLED LATIN CAPITAL LETTER F
+ 0x24BC, 0x24D6, // CIRCLED LATIN CAPITAL LETTER G
+ 0x24BD, 0x24D7, // CIRCLED LATIN CAPITAL LETTER H
+ 0x24BE, 0x24D8, // CIRCLED LATIN CAPITAL LETTER I
+ 0x24BF, 0x24D9, // CIRCLED LATIN CAPITAL LETTER J
+ 0x24C0, 0x24DA, // CIRCLED LATIN CAPITAL LETTER K
+ 0x24C1, 0x24DB, // CIRCLED LATIN CAPITAL LETTER L
+ 0x24C2, 0x24DC, // CIRCLED LATIN CAPITAL LETTER M
+ 0x24C3, 0x24DD, // CIRCLED LATIN CAPITAL LETTER N
+ 0x24C4, 0x24DE, // CIRCLED LATIN CAPITAL LETTER O
+ 0x24C5, 0x24DF, // CIRCLED LATIN CAPITAL LETTER P
+ 0x24C6, 0x24E0, // CIRCLED LATIN CAPITAL LETTER Q
+ 0x24C7, 0x24E1, // CIRCLED LATIN CAPITAL LETTER R
+ 0x24C8, 0x24E2, // CIRCLED LATIN CAPITAL LETTER S
+ 0x24C9, 0x24E3, // CIRCLED LATIN CAPITAL LETTER T
+ 0x24CA, 0x24E4, // CIRCLED LATIN CAPITAL LETTER U
+ 0x24CB, 0x24E5, // CIRCLED LATIN CAPITAL LETTER V
+ 0x24CC, 0x24E6, // CIRCLED LATIN CAPITAL LETTER W
+ 0x24CD, 0x24E7, // CIRCLED LATIN CAPITAL LETTER X
+ 0x24CE, 0x24E8, // CIRCLED LATIN CAPITAL LETTER Y
+ 0x24CF, 0x24E9, // CIRCLED LATIN CAPITAL LETTER Z
+ 0x2C00, 0x2C30, // GLAGOLITIC CAPITAL LETTER AZU
+ 0x2C01, 0x2C31, // GLAGOLITIC CAPITAL LETTER BUKY
+ 0x2C02, 0x2C32, // GLAGOLITIC CAPITAL LETTER VEDE
+ 0x2C03, 0x2C33, // GLAGOLITIC CAPITAL LETTER GLAGOLI
+ 0x2C04, 0x2C34, // GLAGOLITIC CAPITAL LETTER DOBRO
+ 0x2C05, 0x2C35, // GLAGOLITIC CAPITAL LETTER YESTU
+ 0x2C06, 0x2C36, // GLAGOLITIC CAPITAL LETTER ZHIVETE
+ 0x2C07, 0x2C37, // GLAGOLITIC CAPITAL LETTER DZELO
+ 0x2C08, 0x2C38, // GLAGOLITIC CAPITAL LETTER ZEMLJA
+ 0x2C09, 0x2C39, // GLAGOLITIC CAPITAL LETTER IZHE
+ 0x2C0A, 0x2C3A, // GLAGOLITIC CAPITAL LETTER INITIAL IZHE
+ 0x2C0B, 0x2C3B, // GLAGOLITIC CAPITAL LETTER I
+ 0x2C0C, 0x2C3C, // GLAGOLITIC CAPITAL LETTER DJERVI
+ 0x2C0D, 0x2C3D, // GLAGOLITIC CAPITAL LETTER KAKO
+ 0x2C0E, 0x2C3E, // GLAGOLITIC CAPITAL LETTER LJUDIJE
+ 0x2C0F, 0x2C3F, // GLAGOLITIC CAPITAL LETTER MYSLITE
+ 0x2C10, 0x2C40, // GLAGOLITIC CAPITAL LETTER NASHI
+ 0x2C11, 0x2C41, // GLAGOLITIC CAPITAL LETTER ONU
+ 0x2C12, 0x2C42, // GLAGOLITIC CAPITAL LETTER POKOJI
+ 0x2C13, 0x2C43, // GLAGOLITIC CAPITAL LETTER RITSI
+ 0x2C14, 0x2C44, // GLAGOLITIC CAPITAL LETTER SLOVO
+ 0x2C15, 0x2C45, // GLAGOLITIC CAPITAL LETTER TVRIDO
+ 0x2C16, 0x2C46, // GLAGOLITIC CAPITAL LETTER UKU
+ 0x2C17, 0x2C47, // GLAGOLITIC CAPITAL LETTER FRITU
+ 0x2C18, 0x2C48, // GLAGOLITIC CAPITAL LETTER HERU
+ 0x2C19, 0x2C49, // GLAGOLITIC CAPITAL LETTER OTU
+ 0x2C1A, 0x2C4A, // GLAGOLITIC CAPITAL LETTER PE
+ 0x2C1B, 0x2C4B, // GLAGOLITIC CAPITAL LETTER SHTA
+ 0x2C1C, 0x2C4C, // GLAGOLITIC CAPITAL LETTER TSI
+ 0x2C1D, 0x2C4D, // GLAGOLITIC CAPITAL LETTER CHRIVI
+ 0x2C1E, 0x2C4E, // GLAGOLITIC CAPITAL LETTER SHA
+ 0x2C1F, 0x2C4F, // GLAGOLITIC CAPITAL LETTER YERU
+ 0x2C20, 0x2C50, // GLAGOLITIC CAPITAL LETTER YERI
+ 0x2C21, 0x2C51, // GLAGOLITIC CAPITAL LETTER YATI
+ 0x2C22, 0x2C52, // GLAGOLITIC CAPITAL LETTER SPIDERY HA
+ 0x2C23, 0x2C53, // GLAGOLITIC CAPITAL LETTER YU
+ 0x2C24, 0x2C54, // GLAGOLITIC CAPITAL LETTER SMALL YUS
+ 0x2C25, 0x2C55, // GLAGOLITIC CAPITAL LETTER SMALL YUS WITH TAIL
+ 0x2C26, 0x2C56, // GLAGOLITIC CAPITAL LETTER YO
+ 0x2C27, 0x2C57, // GLAGOLITIC CAPITAL LETTER IOTATED SMALL YUS
+ 0x2C28, 0x2C58, // GLAGOLITIC CAPITAL LETTER BIG YUS
+ 0x2C29, 0x2C59, // GLAGOLITIC CAPITAL LETTER IOTATED BIG YUS
+ 0x2C2A, 0x2C5A, // GLAGOLITIC CAPITAL LETTER FITA
+ 0x2C2B, 0x2C5B, // GLAGOLITIC CAPITAL LETTER IZHITSA
+ 0x2C2C, 0x2C5C, // GLAGOLITIC CAPITAL LETTER SHTAPIC
+ 0x2C2D, 0x2C5D, // GLAGOLITIC CAPITAL LETTER TROKUTASTI A
+ 0x2C2E, 0x2C5E, // GLAGOLITIC CAPITAL LETTER LATINATE MYSLITE
+ 0x2C60, 0x2C61, // LATIN CAPITAL LETTER L WITH DOUBLE BAR
+ 0x2C62, 0x026B, // LATIN CAPITAL LETTER L WITH MIDDLE TILDE
+ 0x2C63, 0x1D7D, // LATIN CAPITAL LETTER P WITH STROKE
+ 0x2C64, 0x027D, // LATIN CAPITAL LETTER R WITH TAIL
+ 0x2C67, 0x2C68, // LATIN CAPITAL LETTER H WITH DESCENDER
+ 0x2C69, 0x2C6A, // LATIN CAPITAL LETTER K WITH DESCENDER
+ 0x2C6B, 0x2C6C, // LATIN CAPITAL LETTER Z WITH DESCENDER
+ 0x2C75, 0x2C76, // LATIN CAPITAL LETTER HALF H
+ 0x2C80, 0x2C81, // COPTIC CAPITAL LETTER ALFA
+ 0x2C82, 0x2C83, // COPTIC CAPITAL LETTER VIDA
+ 0x2C84, 0x2C85, // COPTIC CAPITAL LETTER GAMMA
+ 0x2C86, 0x2C87, // COPTIC CAPITAL LETTER DALDA
+ 0x2C88, 0x2C89, // COPTIC CAPITAL LETTER EIE
+ 0x2C8A, 0x2C8B, // COPTIC CAPITAL LETTER SOU
+ 0x2C8C, 0x2C8D, // COPTIC CAPITAL LETTER ZATA
+ 0x2C8E, 0x2C8F, // COPTIC CAPITAL LETTER HATE
+ 0x2C90, 0x2C91, // COPTIC CAPITAL LETTER THETHE
+ 0x2C92, 0x2C93, // COPTIC CAPITAL LETTER IAUDA
+ 0x2C94, 0x2C95, // COPTIC CAPITAL LETTER KAPA
+ 0x2C96, 0x2C97, // COPTIC CAPITAL LETTER LAULA
+ 0x2C98, 0x2C99, // COPTIC CAPITAL LETTER MI
+ 0x2C9A, 0x2C9B, // COPTIC CAPITAL LETTER NI
+ 0x2C9C, 0x2C9D, // COPTIC CAPITAL LETTER KSI
+ 0x2C9E, 0x2C9F, // COPTIC CAPITAL LETTER O
+ 0x2CA0, 0x2CA1, // COPTIC CAPITAL LETTER PI
+ 0x2CA2, 0x2CA3, // COPTIC CAPITAL LETTER RO
+ 0x2CA4, 0x2CA5, // COPTIC CAPITAL LETTER SIMA
+ 0x2CA6, 0x2CA7, // COPTIC CAPITAL LETTER TAU
+ 0x2CA8, 0x2CA9, // COPTIC CAPITAL LETTER UA
+ 0x2CAA, 0x2CAB, // COPTIC CAPITAL LETTER FI
+ 0x2CAC, 0x2CAD, // COPTIC CAPITAL LETTER KHI
+ 0x2CAE, 0x2CAF, // COPTIC CAPITAL LETTER PSI
+ 0x2CB0, 0x2CB1, // COPTIC CAPITAL LETTER OOU
+ 0x2CB2, 0x2CB3, // COPTIC CAPITAL LETTER DIALECT-P ALEF
+ 0x2CB4, 0x2CB5, // COPTIC CAPITAL LETTER OLD COPTIC AIN
+ 0x2CB6, 0x2CB7, // COPTIC CAPITAL LETTER CRYPTOGRAMMIC EIE
+ 0x2CB8, 0x2CB9, // COPTIC CAPITAL LETTER DIALECT-P KAPA
+ 0x2CBA, 0x2CBB, // COPTIC CAPITAL LETTER DIALECT-P NI
+ 0x2CBC, 0x2CBD, // COPTIC CAPITAL LETTER CRYPTOGRAMMIC NI
+ 0x2CBE, 0x2CBF, // COPTIC CAPITAL LETTER OLD COPTIC OOU
+ 0x2CC0, 0x2CC1, // COPTIC CAPITAL LETTER SAMPI
+ 0x2CC2, 0x2CC3, // COPTIC CAPITAL LETTER CROSSED SHEI
+ 0x2CC4, 0x2CC5, // COPTIC CAPITAL LETTER OLD COPTIC SHEI
+ 0x2CC6, 0x2CC7, // COPTIC CAPITAL LETTER OLD COPTIC ESH
+ 0x2CC8, 0x2CC9, // COPTIC CAPITAL LETTER AKHMIMIC KHEI
+ 0x2CCA, 0x2CCB, // COPTIC CAPITAL LETTER DIALECT-P HORI
+ 0x2CCC, 0x2CCD, // COPTIC CAPITAL LETTER OLD COPTIC HORI
+ 0x2CCE, 0x2CCF, // COPTIC CAPITAL LETTER OLD COPTIC HA
+ 0x2CD0, 0x2CD1, // COPTIC CAPITAL LETTER L-SHAPED HA
+ 0x2CD2, 0x2CD3, // COPTIC CAPITAL LETTER OLD COPTIC HEI
+ 0x2CD4, 0x2CD5, // COPTIC CAPITAL LETTER OLD COPTIC HAT
+ 0x2CD6, 0x2CD7, // COPTIC CAPITAL LETTER OLD COPTIC GANGIA
+ 0x2CD8, 0x2CD9, // COPTIC CAPITAL LETTER OLD COPTIC DJA
+ 0x2CDA, 0x2CDB, // COPTIC CAPITAL LETTER OLD COPTIC SHIMA
+ 0x2CDC, 0x2CDD, // COPTIC CAPITAL LETTER OLD NUBIAN SHIMA
+ 0x2CDE, 0x2CDF, // COPTIC CAPITAL LETTER OLD NUBIAN NGI
+ 0x2CE0, 0x2CE1, // COPTIC CAPITAL LETTER OLD NUBIAN NYI
+ 0x2CE2, 0x2CE3, // COPTIC CAPITAL LETTER OLD NUBIAN WAU
+ 0, 0
};
-/***********************************************************************
-**
-*/ void Init_Char_Cases(void)
-/*
-** Initialize the Unicode character casing tables.
-** These tables support simple 1-to-1 casing methods.
-**
-***********************************************************************/
+//
+// Init_Char_Cases: C
+//
+// Initialize the Unicode character casing tables.
+// These tables support simple 1-to-1 casing methods.
+//
+void Init_Char_Cases(void)
{
- const REBUNI *up;
- int n;
+ const REBUNI *up;
+ int n;
- // Init whitespace table:
- White_Chars = Make_Mem(34);
- memset(White_Chars, 1, 33); // All white chars: NL, CR, BS, etc...
- White_Chars[' '] = 3; // space
- White_Chars['\t'] = 3; // space
- White_Chars[0] = 0; // special
+ // Init whitespace table:
+ White_Chars = ALLOC_N(REBYTE, 34);
+ memset(White_Chars, 1, 33); // All white chars: NL, CR, BS, etc...
+ White_Chars[cast(REBYTE, ' ')] = 3; // space
+ White_Chars[cast(REBYTE, '\t')] = 3; // tab
+ White_Chars[0] = 0; // special
- // Casing tables:
- Upper_Cases = Make_Mem(UNICODE_CASES * sizeof(REBUNI));
- Lower_Cases = Make_Mem(UNICODE_CASES * sizeof(REBUNI));
+ // Casing tables:
+ Upper_Cases = ALLOC_N(REBUNI, UNICODE_CASES);
+ Lower_Cases = ALLOC_N(REBUNI, UNICODE_CASES);
- for (n = 0; n < UNICODE_CASES; n++) {
- UP_CASE(n) = n;
- LO_CASE(n) = n;
- }
+ for (n = 0; n < UNICODE_CASES; n++) {
+ UP_CASE(n) = n;
+ LO_CASE(n) = n;
+ }
- for (up = &Char_Cases[0]; *up; up += 2) {
- //ASSERT2(UP_CASE(up[1]) == up[1], 910);
- // Only map if not already set (multiple mappings exist):
- if (UP_CASE(up[1]) == up[1]) UP_CASE(up[1]) = up[0];
- if (LO_CASE(up[1]) == up[1]) LO_CASE(up[0]) = up[1];
- }
+ for (up = &Char_Cases[0]; *up; up += 2) {
+ //assert(UP_CASE(up[1]) == up[1], 910);
+ // Only map if not already set (multiple mappings exist):
+ if (UP_CASE(up[1]) == up[1]) UP_CASE(up[1]) = up[0];
+ if (LO_CASE(up[1]) == up[1]) LO_CASE(up[0]) = up[1];
+ }
}
+
+//
+// Shutdown_Char_Cases: C
+//
+void Shutdown_Char_Cases(void)
+{
+ FREE_N(REBUNI, UNICODE_CASES, Upper_Cases);
+ FREE_N(REBUNI, UNICODE_CASES, Lower_Cases);
+ FREE_N(REBYTE, 34, White_Chars);
+}
diff --git a/src/core/s-crc.c b/src/core/s-crc.c
index 640c604b05..4b409964f1 100644
--- a/src/core/s-crc.c
+++ b/src/core/s-crc.c
@@ -1,906 +1,615 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: s-crc.c
-** Summary: CRC computation
-** Section: strings
-** Author: Carl Sassenrath (REBOL interface sections)
-** Notes:
-**
-***********************************************************************/
+//
+// File: %s-crc.c
+// Summary: "CRC computation"
+// Section: strings
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
#define CRC_DEFINED
-#define CRCBITS 24 /* may be 16, 24, or 32 */
-#define MASK_CRC(crc) ((crc) & 0x00ffffffL) /* if CRCBITS is 24 */
-#define CRCHIBIT ((REBCNT) (1L<<(CRCBITS-1))) /* 0x8000 if CRCBITS is 16 */
+#define CRCBITS 24 /* may be 16, 24, or 32 */
+#define MASK_CRC(crc) ((crc) & I32_C(0x00ffffff)) /* if CRCBITS is 24 */
+#define CRCHIBIT ((REBCNT) (I32_C(1)<<(CRCBITS-1))) /* 0x8000 if CRCBITS is 16 */
#define CRCSHIFTS (CRCBITS-8)
-#define CCITTCRC 0x1021 /* CCITT's 16-bit CRC generator polynomial */
-#define PRZCRC 0x864cfb /* PRZ's 24-bit CRC generator polynomial */
-#define CRCINIT 0xB704CE /* Init value for CRC accumulator */
+#define CCITTCRC 0x1021 /* CCITT's 16-bit CRC generator polynomial */
+#define PRZCRC 0x864cfb /* PRZ's 24-bit CRC generator polynomial */
+#define CRCINIT 0xB704CE /* Init value for CRC accumulator */
static REBCNT *CRC_Table;
-/***********************************************************************
-**
-*/ static REBCNT Generate_CRC(REBYTE ch, REBCNT poly, REBCNT accum)
-/*
-** Simulates CRC hardware circuit. Generates true CRC
-** directly, without requiring extra NULL bytes to be appended
-** to the message. Returns new updated CRC accumulator.
-**
-** These CRC functions are derived from code in chapter 19 of the book
-** "C Programmer's Guide to Serial Communications", by Joe Campbell.
-** Generalized to any CRC width by Philip Zimmermann.
-**
-** CRC-16 X^16 + X^15 + X^2 + 1
-** CRC-CCITT X^16 + X^12 + X^2 + 1
-**
-** Notes on making a good 24-bit CRC:
-** The primitive irreducible polynomial of degree 23 over GF(2),
-** 040435651 (octal), comes from Appendix C of "Error Correcting Codes,
-** 2nd edition" by Peterson and Weldon, page 490. This polynomial was
-** chosen for its uniform density of ones and zeros, which has better
-** error detection properties than polynomials with a minimal number of
-** nonzero terms. Multiplying this primitive degree-23 polynomial by
-** the polynomial x+1 yields the additional property of detecting any
-** odd number of bits in error, which means it adds parity. This
-** approach was recommended by Neal Glover.
-**
-** To multiply the polynomial 040435651 by x+1, shift it left 1 bit and
-** bitwise add (xor) the unshifted version back in. Dropping the unused
-** upper bit (bit 24) produces a CRC-24 generator bitmask of 041446373
-** octal, or 0x864cfb hex.
-**
-** You can detect spurious leading zeros or framing errors in the
-** message by initializing the CRC accumulator to some agreed-upon
-** nonzero "random-like" value, but this is a bit nonstandard.
-**
-***********************************************************************/
+//
+// Generate_CRC: C
+//
+// Simulates CRC hardware circuit. Generates true CRC
+// directly, without requiring extra NULL bytes to be appended
+// to the message. Returns new updated CRC accumulator.
+//
+// These CRC functions are derived from code in chapter 19 of the book
+// "C Programmer's Guide to Serial Communications", by Joe Campbell.
+// Generalized to any CRC width by Philip Zimmermann.
+//
+// CRC-16 X^16 + X^15 + X^2 + 1
+// CRC-CCITT X^16 + X^12 + X^2 + 1
+//
+// Notes on making a good 24-bit CRC:
+// The primitive irreducible polynomial of degree 23 over GF(2),
+// 040435651 (octal), comes from Appendix C of "Error Correcting Codes,
+// 2nd edition" by Peterson and Weldon, page 490. This polynomial was
+// chosen for its uniform density of ones and zeros, which has better
+// error detection properties than polynomials with a minimal number of
+// nonzero terms. Multiplying this primitive degree-23 polynomial by
+// the polynomial x+1 yields the additional property of detecting any
+// odd number of bits in error, which means it adds parity. This
+// approach was recommended by Neal Glover.
+//
+// To multiply the polynomial 040435651 by x+1, shift it left 1 bit and
+// bitwise add (xor) the unshifted version back in. Dropping the unused
+// upper bit (bit 24) produces a CRC-24 generator bitmask of 041446373
+// octal, or 0x864cfb hex.
+//
+// You can detect spurious leading zeros or framing errors in the
+// message by initializing the CRC accumulator to some agreed-upon
+// nonzero "random-like" value, but this is a bit nonstandard.
+//
+static REBCNT Generate_CRC(REBYTE ch, REBCNT poly, REBCNT accum)
{
- REBINT i;
- REBCNT data;
-
- data = ch;
- data <<= CRCSHIFTS; /* shift data to line up with MSB of accum */
- i = 8; /* counts 8 bits of data */
- do { /* if MSB of (data XOR accum) is TRUE, shift and subtract poly */
- if ((data ^ accum) & CRCHIBIT) accum = (accum<<1) ^ poly;
- else accum <<= 1;
- data <<= 1;
- } while (--i); /* counts 8 bits of data */
- return (MASK_CRC(accum));
+ REBINT i;
+ REBCNT data;
+
+ data = ch;
+ data <<= CRCSHIFTS; /* shift data to line up with MSB of accum */
+ i = 8; /* counts 8 bits of data */
+ do { /* if MSB of (data XOR accum) is TRUE, shift and subtract poly */
+ if ((data ^ accum) & CRCHIBIT) accum = (accum<<1) ^ poly;
+ else accum <<= 1;
+ data <<= 1;
+ } while (--i); /* counts 8 bits of data */
+ return (MASK_CRC(accum));
}
-/***********************************************************************
-**
-*/ static void Make_CRC_Table(REBCNT poly)
-/*
-** Derives a CRC lookup table from the CRC polynomial.
-** The table is used later by crcupdate function given below.
-** Only needs to be called once at the dawn of time.
-**
-***********************************************************************/
+//
+// Make_CRC_Table: C
+//
+// Derives a CRC lookup table from the CRC polynomial.
+// The table is used later by crcupdate function given below.
+// Only needs to be called once at the dawn of time.
+//
+static void Make_CRC_Table(REBCNT poly)
{
- REBINT i;
+ REBINT i;
- FOREACH (i, 256) CRC_Table[i] = Generate_CRC((REBYTE) i, poly, 0);
+ for (i = 0; i < 256; i++)
+ CRC_Table[i] = Generate_CRC(cast(REBYTE, i), poly, 0);
}
-/***********************************************************************
-**
-*/ REBINT Compute_CRC(REBYTE *str, REBCNT len)
-/*
-***********************************************************************/
+//
+// Compute_CRC: C
+//
+// Rebol had canonized signed numbers for CRCs, and the signed logic
+// actually does turn high bytes into negative numbers so they
+// subtract instead of add *during* the calculation. Hence the casts
+// are necessary so long as compatibility with the historical results
+// of the CHECKSUM native is needed.
+//
+REBINT Compute_CRC(REBYTE *str, REBCNT len)
{
- REBYTE n;
- REBINT crc = (REBINT)len + (REBINT)((REBYTE)(*str));
+ REBINT crc = cast(REBINT, len) + cast(REBINT, cast(REBYTE, *str));
- for (; len > 0; len--) {
- n = (REBYTE)((crc >> CRCSHIFTS) ^ (REBYTE)(*str++));
- crc = MASK_CRC(crc << 8) ^ (REBINT)CRC_Table[n];
- }
+ for (; len > 0; len--) {
+ REBYTE n = cast(REBYTE, (crc >> CRCSHIFTS) ^ cast(REBYTE, *str++));
- return crc;
+ // Left shift math must use unsigned to avoid undefined behavior
+ // http://stackoverflow.com/q/3784996/211160
+ crc = cast(REBINT, MASK_CRC(cast(REBCNT, crc) << 8) ^ CRC_Table[n]);
+ }
+
+ return crc;
}
-/***********************************************************************
-**
-*/ REBINT Hash_String(REBYTE *str, REBCNT len)
-/*
-** Return a case insensitive hash value for the string. The
-** string does not have to be zero terminated and UTF8 is ok.
-**
-***********************************************************************/
+//
+// Hash_Word: C
+//
+// Return a case insensitive hash value for the string.
+//
+REBINT Hash_Word(const REBYTE *str, REBCNT len)
{
- REBYTE n;
- REBINT hash = (REBINT)len + (REBINT)((REBYTE)LO_CASE(*str));
-
- for (; len > 0; len--) {
- n = (REBYTE)((hash >> CRCSHIFTS) ^ (REBYTE)LO_CASE(*str++));
- hash = MASK_CRC(hash << 8) ^ (REBINT)CRC_Table[n];
- }
+ REBINT hash =
+ cast(REBINT, len) + cast(REBINT, cast(REBYTE, LO_CASE(*str)));
- return hash;
-}
+ for (; len > 0; str++, len--) {
+ REBUNI n = *str;
+ if (n >= 0x80) {
+ str = Back_Scan_UTF8_Char(&n, str, &len);
+ assert(str); // UTF8 should have already been verified good
+ }
-/***********************************************************************
-**
-*/ REBINT Hash_Word(REBYTE *str, REBINT len)
-/*
-** Return a case insensitive hash value for the string.
-**
-***********************************************************************/
-{
- REBINT m, n;
- REBINT hash;
- REBCNT ulen;
+ // Optimize `n = cast(REBYTE, LO_CASE(n))` (drop upper 8 bits)
+ // !!! Is this actually faster?
+ if (n < UNICODE_CASES)
+ n = cast(REBYTE, LO_CASE(n));
+ else
+ n = cast(REBYTE, n);
- if (len < 0) len = LEN_BYTES(str);
+ n = cast(REBYTE, (hash >> CRCSHIFTS) ^ n);
- hash = (REBINT)len + (REBINT)((REBYTE)LO_CASE(*str));
+ // Left shift math must use unsigned to avoid undefined behavior
+ // http://stackoverflow.com/q/3784996/211160
+ hash = cast(REBINT, MASK_CRC(cast(REBCNT, hash) << 8) ^ CRC_Table[n]);
+ }
- ulen = (REBCNT)len; // so the & operation later isn't for the wrong type
+ return hash;
+}
- for (; ulen > 0; str++, ulen--) {
- n = *str;
- if (n > 127 && NZ(m = Decode_UTF8_Char(&str, &ulen))) n = m; // mods str, ulen
- if (n < UNICODE_CASES) n = LO_CASE(n);
- n = (REBYTE)((hash >> CRCSHIFTS) ^ (REBYTE)n); // drop upper 8 bits
- hash = MASK_CRC(hash << 8) ^ (REBINT)CRC_Table[n];
- }
+static u32 *crc32_table = 0;
- return hash;
-}
+static void Make_CRC32_Table(void);
-/***********************************************************************
-**
-*/ REBINT Hash_Value(REBVAL *val, REBCNT hash_size)
-/*
-** Return a case insensitive hash value for any value.
-**
-** Result will be > 0 and < hash_size, except if
-** datatype cannot be hashed, a 0 is returned.
-**
-***********************************************************************/
+//
+// Hash_Value: C
+//
+// Return a case insensitive hash value for any value.
+//
+// Fails if datatype cannot be hashed. Note that the specifier is not used
+// in hashing, because it is not used in comparisons either.
+//
+REBCNT Hash_Value(const RELVAL *v)
{
- REBCNT ret;
-
- switch(VAL_TYPE(val)) {
-
- case REB_WORD:
- case REB_SET_WORD:
- case REB_GET_WORD:
- case REB_LIT_WORD:
- case REB_REFINEMENT:
- case REB_ISSUE:
- ret = VAL_WORD_CANON(val);
- break;
-
- case REB_BINARY:
- case REB_STRING:
- case REB_FILE:
- case REB_EMAIL:
- case REB_URL:
- case REB_TAG:
- ret = Hash_String(VAL_BIN_DATA(val), Val_Byte_Len(val));
- break;
-
- case REB_LOGIC:
- ret = VAL_LOGIC(val) ? (hash_size/5) : (2*hash_size/5);
- break;
-
- case REB_INTEGER:
- case REB_DECIMAL: // depends on INT64 sharing the DEC64 bits
- ret = (REBCNT)(VAL_INT64(val) >> 32) ^ ((REBCNT)VAL_INT64(val));
- break;
-
- case REB_CHAR:
- ret = VAL_CHAR(val) << 15; // avoid running into WORD hashes
- break;
-
- case REB_MONEY:
- ret = VAL_ALL_BITS(val)[0] ^ VAL_ALL_BITS(val)[1] ^ VAL_ALL_BITS(val)[2];
- break;
-
- case REB_TIME:
- case REB_DATE:
- ret = (REBCNT)(VAL_TIME(val) ^ (VAL_TIME(val) / SEC_SEC));
- if (IS_DATE(val)) ret ^= VAL_DATE(val).bits;
- break;
-
- case REB_TUPLE:
- ret = Hash_String(VAL_TUPLE(val), VAL_TUPLE_LEN(val));
- break;
-
- case REB_PAIR:
- ret = VAL_ALL_BITS(val)[0] ^ VAL_ALL_BITS(val)[1];
- break;
-
- case REB_OBJECT:
- ret = ((REBCNT)VAL_OBJ_FRAME(val)) >> 4;
- break;
-
- case REB_DATATYPE:
- ret = Hash_Word(Get_Sym_Name(VAL_DATATYPE(val)+1), -1);
- break;
-
- case REB_NONE:
- ret = 1;
- break;
-
- case REB_UNSET:
- ret = 0;
- break;
-
- default:
- return 0; //ret = 3 * (hash_size/5);
- }
-
- return 1 + ((hash_size-1) & ret);
+ REBCNT ret;
+
+ switch(VAL_TYPE(v)) {
+ case REB_MAX_VOID:
+ //
+ // While a void might technically be hashed, it can't be a value *or*
+ // a key in a map.
+ //
+ panic (NULL);
+
+ case REB_BAR:
+ case REB_LIT_BAR:
+ case REB_BLANK:
+ ret = 0;
+ break;
+
+ case REB_LOGIC:
+ ret = VAL_LOGIC(v) ? 1 : 0;
+ break;
+
+ case REB_INTEGER:
+ //
+ // R3-Alpha XOR'd with (VAL_INT64(val) >> 32). But: "XOR with high
+ // bits collapses -1 with 0 etc. (If your key k is |k| < 2^32 high
+ // bits are 0-informative." -Giulio
+ //
+ ret = cast(REBCNT, VAL_INT64(v));
+ break;
+
+ case REB_DECIMAL:
+ case REB_PERCENT:
+ // depends on INT64 sharing the DEC64 bits
+ ret = (VAL_INT64(v) >> 32) ^ (VAL_INT64(v));
+ break;
+
+ case REB_MONEY:
+ ret = VAL_ALL_BITS(v)[0] ^ VAL_ALL_BITS(v)[1] ^ v->extra.m0;
+ break;
+
+ case REB_CHAR:
+ ret = LO_CASE(VAL_CHAR(v));
+ break;
+
+ case REB_PAIR:
+ ret = (VAL_ALL_BITS(v)[0] << 16)
+ ^ (VAL_ALL_BITS(v)[0] >> 16)
+ ^ (VAL_ALL_BITS(v)[1]);
+ break;
+
+ case REB_TUPLE:
+ ret = Hash_String(VAL_TUPLE(v), VAL_TUPLE_LEN(v), 1);
+ break;
+
+ case REB_TIME:
+ case REB_DATE:
+ ret = cast(REBCNT, VAL_NANO(v) ^ (VAL_NANO(v) / SEC_SEC));
+ if (IS_DATE(v))
+ ret ^= VAL_DATE(v).bits;
+ break;
+
+ case REB_BINARY:
+ case REB_STRING:
+ case REB_FILE:
+ case REB_EMAIL:
+ case REB_URL:
+ case REB_TAG:
+ ret = Hash_String(
+ VAL_RAW_DATA_AT(v),
+ VAL_LEN_HEAD(v),
+ SER_WIDE(VAL_SERIES(v))
+ );
+ break;
+
+ case REB_BLOCK:
+ case REB_GROUP:
+ case REB_PATH:
+ case REB_SET_PATH:
+ case REB_GET_PATH:
+ case REB_LIT_PATH:
+ //
+ // !!! Lame hash just to get it working. There will be lots of
+ // collisions. Intentionally bad to avoid writing something that
+ // is less obviously not thought out.
+ //
+ // Whatever hash is used must be able to match lax equality. So it
+ // could hash all the values case-insensitively, or the first N values,
+ // or something.
+ //
+ // Note that if there is a way to mutate this array, there will be
+ // problems. Do not hash mutable arrays unless you are sure hashings
+ // won't cross a mutation.
+ //
+ ret = ARR_LEN(VAL_ARRAY(v));
+ break;
+
+ case REB_DATATYPE: {
+ REBSTR *canon = Canon(VAL_TYPE_SYM(v));
+ ret = Hash_Word(STR_HEAD(canon), STR_NUM_BYTES(canon));
+ break; }
+
+ case REB_BITSET:
+ case REB_IMAGE:
+ case REB_VECTOR:
+ case REB_TYPESET:
+ //
+ // These types are currently not supported.
+ //
+ // !!! Why not?
+ //
+ fail (Error_Invalid_Type(VAL_TYPE(v)));
+
+ case REB_WORD:
+ case REB_SET_WORD:
+ case REB_GET_WORD:
+ case REB_LIT_WORD:
+ case REB_REFINEMENT:
+ case REB_ISSUE: {
+ //
+ // Note that the canon symbol may change for a group of word synonyms
+ // if that canon is GC'd--it picks another synonym. Thus the pointer
+ // of the canon cannot be used as a long term hash. A case insensitive
+ // hashing of the word spelling itself is needed.
+ //
+ // !!! Should this hash be cached on the words somehow, e.g. in the
+ // data payload before the actual string?
+ //
+ REBSTR *spelling = VAL_WORD_SPELLING(v);
+ ret = Hash_Word(STR_HEAD(spelling), STR_NUM_BYTES(spelling));
+ break; }
+
+ case REB_FUNCTION:
+ //
+ // Because function equality is by identity only and they are
+ // immutable once created, it is legal to put them in hashes. The
+ // VAL_FUNC is the paramlist series, guaranteed unique per function
+ //
+ ret = cast(REBCNT, cast(REBUPT, VAL_FUNC(v)) >> 4);
+ break;
+
+ case REB_FRAME:
+ case REB_MODULE:
+ case REB_ERROR:
+ case REB_PORT:
+ case REB_OBJECT:
+ //
+ // !!! ANY-CONTEXT has a uniquely identifying context pointer for that
+ // context. However, this does not help with "natural =" comparison
+ // as the hashing will be for SAME? contexts only:
+ //
+ // http://stackoverflow.com/a/33577210/211160
+ //
+ // Allowing object keys to be OBJECT! and then comparing by field
+ // values creates problems for hashing if that object is mutable.
+ // However, since it was historically allowed it is allowed for
+ // all ANY-CONTEXT! types at the moment.
+ //
+ ret = cast(REBCNT, cast(REBUPT, VAL_CONTEXT(v)) >> 4);
+ break;
+
+ case REB_MAP:
+ //
+ // Looking up a map in a map is fairly analogous to looking up an
+ // object in a map. If one is permitted, so should the other be.
+ // (Again this will just find the map by identity, not by comparing
+ // the values of one against the values of the other...)
+ //
+ ret = cast(REBCNT, cast(REBUPT, VAL_MAP(v)) >> 4);
+ break;
+
+ case REB_GOB:
+ case REB_EVENT:
+ case REB_HANDLE:
+ case REB_STRUCT:
+ case REB_LIBRARY:
+ //
+ // !!! Review hashing behavior or needs of these types if necessary.
+ //
+ fail (Error_Invalid_Type(VAL_TYPE(v)));
+
+ default:
+ // The list above should be comprehensive. panic in order to keep
+ // there from being an uninitialized ret warning.
+ //
+ panic (NULL);
+ }
+
+ return ret ^ crc32_table[VAL_TYPE(v)];
}
-/***********************************************************************
-**
-*/ REBSER *Make_Hash_Array(REBCNT len)
-/*
-***********************************************************************/
+//
+// Make_Hash_Sequence: C
+//
+REBSER *Make_Hash_Sequence(REBCNT len)
{
- REBCNT n;
- REBSER *ser;
+ REBCNT n = Get_Hash_Prime(len * 2); // best when 2X # of keys
+ if (n == 0) {
+ DECLARE_LOCAL (temp);
+ Init_Integer(temp, len);
- n = Get_Hash_Prime(len * 2); // best when 2X # of keys
- if (!n) Trap_Num(RE_SIZE_LIMIT, len);
+ fail (Error_Size_Limit_Raw(temp));
+ }
- ser = Make_Series(n + 1, sizeof(REBCNT), FALSE);
- LABEL_SERIES(ser, "make hash array");
- Clear_Series(ser);
- ser->tail = n;
+ REBSER *ser = Make_Series(n + 1, sizeof(REBCNT));
+ Clear_Series(ser);
+ SET_SERIES_LEN(ser, n);
- return ser;
+ return ser;
}
-/***********************************************************************
-**
-*/ REBSER *Hash_Block(REBVAL *block, REBCNT cased)
-/*
-** Hash ALL values of a block. Return hash array series.
-** Used for SET logic (unique, union, etc.)
-**
-** Note: hash array contents (indexes) are 1-based!
-**
-***********************************************************************/
+//
+// Init_Map: C
+//
+// A map has an additional hash element hidden in the ->extra
+// field of the REBSER which needs to be given to memory
+// management as well.
+//
+void Init_Map(REBVAL *out, REBMAP *map)
{
- REBCNT n;
- REBCNT key;
- REBSER *hser;
- REBCNT *hashes;
- REBSER *series = VAL_SERIES(block);
-
- // Create the hash array (integer indexes):
- hser = Make_Hash_Array(VAL_LEN(block));
- hashes = (REBCNT*)hser->data;
-
- for (n = VAL_INDEX(block); n < series->tail; n++) {
- key = Find_Key(series, hser, BLK_SKIP(series, n), 1, cased, 0);
- hashes[key] = n + 1;
- }
-
- return hser;
-}
+ if (MAP_HASHLIST(map))
+ ENSURE_SERIES_MANAGED(MAP_HASHLIST(map));
+ ENSURE_ARRAY_MANAGED(MAP_PAIRLIST(map));
-/***********************************************************************
-**
-*/ void Init_CRC(void)
-/*
-***********************************************************************/
-{
- CRC_Table = Make_Mem(sizeof(REBCNT) * 256);
- Make_CRC_Table(PRZCRC);
+ VAL_RESET_HEADER(out, REB_MAP);
+ out->extra.binding = (REBARR*)SPECIFIED; // !!! cast() gripes, investigate
+ out->payload.any_series.series = SER(MAP_PAIRLIST(map));
+ out->payload.any_series.index = 0;
}
-/***********************************************************************
-**
-*/ REBINT Compute_IPC(REBYTE *data, REBCNT length)
-/*
-** Compute an IP checksum given some data and a length.
-** Used only on BINARY values.
-**
-***********************************************************************/
+//
+// Hash_Block: C
+//
+// Hash ALL values of a block. Return hash array series.
+// Used for SET logic (unique, union, etc.)
+//
+// Note: hash array contents (indexes) are 1-based!
+//
+REBSER *Hash_Block(const REBVAL *block, REBCNT skip, REBOOL cased)
{
- REBCNT lSum = 0; // stores the summation
- REBYTE *up = data;
-
- while (length > 1) {
- lSum += (up[0] << 8) | up[1];
- up += 2;
- length -= 2;
- }
-
- // Handle the odd byte if necessary
- if (length) lSum += *up;
-
- // Add back the carry outs from the 16 bits to the low 16 bits
- lSum = (lSum >> 16) + (lSum & 0xffff); // Add high-16 to low-16
- lSum += (lSum >> 16); // Add carry
- return (REBINT)( (~lSum) & 0xffff); // 1's complement, then truncate
+ REBCNT n;
+ REBSER *hashlist;
+ REBCNT *hashes;
+ REBARR *array = VAL_ARRAY(block);
+ RELVAL *value;
+
+ // Create the hash array (integer indexes):
+ hashlist = Make_Hash_Sequence(VAL_LEN_AT(block));
+ hashes = SER_HEAD(REBCNT, hashlist);
+
+ value = VAL_ARRAY_AT(block);
+ if (IS_END(value))
+ return hashlist;
+
+ n = VAL_INDEX(block);
+ while (TRUE) {
+ REBCNT skip_index = skip;
+
+ REBCNT hash = Find_Key_Hashed(
+ array, hashlist, value, VAL_SPECIFIER(block), 1, cased, 0
+ );
+ hashes[hash] = (n / skip) + 1;
+
+ while (skip_index != 0) {
+ value++;
+ n++;
+ skip_index--;
+
+ if (IS_END(value)) {
+ if (skip_index != 0) {
+ //
+ // !!! It's not clear what to do when hashing something
+ // for a skip index when the number isn't evenly divisible
+ // by that amount. It means a hash lookup will find
+ // something, but it won't be a "full record". Just as
+ // we have to check for ENDs inside the hashed-to material
+ // here, later code would have to check also.
+ //
+ // The conservative thing to do here is to error. If a
+ // compelling coherent behavior and rationale in the
+ // rest of the code can be established. But more likely
+ // than not, this will catch bugs in callers vs. be
+ // a roadblock to them.
+ //
+ fail (Error_Block_Skip_Wrong_Raw());
+ }
+
+ return hashlist;
+ }
+ }
+ }
+
+ DEAD_END;
}
-
-
-static u32 *crc32_table = 0;
-
-static void Make_CRC32_Table(void) {
- unsigned long c;
- int n,k;
-
- crc32_table = Make_Mem(256 * sizeof(u32));
-
- for(n=0;n<256;n++) {
- c=(unsigned long)n;
- for(k=0;k<8;k++) {
- if(c&1)
- c=0xedb88320L^(c>>1);
- else
- c=c>>1;
- }
- crc32_table[n]=c;
- }
-}
-
-REBCNT Update_CRC32(u32 crc, REBYTE *buf, int len) {
- u32 c = ~crc;
- int n;
-
- if(!crc32_table) Make_CRC32_Table();
-
- for(n = 0; n < len; n++)
- c = crc32_table[(c^buf[n])&0xff]^(c>>8);
-
- return ~c;
-}
-
-/***********************************************************************
-**
-*/ REBCNT CRC32(REBYTE *buf, REBCNT len)
-/*
-***********************************************************************/
+//
+// Compute_IPC: C
+//
+// Compute an IP checksum given some data and a length.
+// Used only on BINARY values.
+//
+REBINT Compute_IPC(REBYTE *data, REBCNT length)
{
- return Update_CRC32(0x00000000L, buf, len);
+ REBCNT lSum = 0; // stores the summation
+ REBYTE *up = data;
+
+ while (length > 1) {
+ lSum += (up[0] << 8) | up[1];
+ up += 2;
+ length -= 2;
+ }
+
+ // Handle the odd byte if necessary
+ if (length) lSum += *up;
+
+ // Add back the carry outs from the 16 bits to the low 16 bits
+ lSum = (lSum >> 16) + (lSum & 0xffff); // Add high-16 to low-16
+ lSum += (lSum >> 16); // Add carry
+ return (REBINT)( (~lSum) & 0xffff); // 1's complement, then truncate
}
-
-#ifdef ndef
-Header File
-// CRCdemo.h
-
-protected:
- ULONG crc32_table[256]; // Lookup table array
- void Init_CRC32_Table(); // Builds lookup table array
- ULONG Reflect(ULONG ref, char ch); // Reflects CRC bits in the lookup table
- int Get_CRC(CString& text); // Creates a CRC from a text string
-
-
-Source File
-// CRCdemo.cpp
-
-void CRCdemo::Init_CRC32_Table()
-{// Call this function only once to initialize the CRC table.
-
- // This is the official polynomial used by CRC-32
- // in PKZip, WinZip and Ethernet.
- ULONG ulPolynomial = 0x04c11db7;
-
- // 256 values representing ASCII character codes.
- for(int i = 0; i <= 0xFF; i++)
- {
- crc32_table[i]=Reflect(i, 8) << 24;
- for (int j = 0; j < 8; j++)
- crc32_table[i] = (crc32_table[i] << 1) ^ (crc32_table[i] & (1 << 31) ? ulPolynomial : 0);
- crc32_table[i] = Reflect(crc32_table[i], 32);
- }
+static void Make_CRC32_Table(void) {
+ u32 c;
+ int n,k;
+
+ crc32_table = ALLOC_N(u32, 256);
+
+ for(n=0;n<256;n++) {
+ c=(u32)n;
+ for(k=0;k<8;k++) {
+ if(c&1)
+ c=U32_C(0xedb88320)^(c>>1);
+ else
+ c=c>>1;
+ }
+ crc32_table[n]=c;
+ }
}
-ULONG CRCdemo::Reflect(ULONG ref, char ch)
-{// Used only by Init_CRC32_Table().
- ULONG value(0);
+REBCNT Update_CRC32(u32 crc, REBYTE *buf, int len) {
+ u32 c = ~crc;
+ int n;
- // Swap bit 0 for bit 7
- // bit 1 for bit 6, etc.
- for(int i = 1; i < (ch + 1); i++)
- {
- if(ref & 1)
- value |= 1 << (ch - i);
- ref >>= 1;
- }
- return value;
-}
+ for(n = 0; n < len; n++)
+ c = crc32_table[(c^buf[n])&0xff]^(c>>8);
-int CRCdemo::Get_CRC(CString& text)
-{ // Pass a text string to this function and it will return the CRC.
-
- // Once the lookup table has been filled in by the two functions above,
- // this function creates all CRCs using only the lookup table.
- // Note that CString is an MFC class.
- // If you don't have MFC, use the function below instead.
-
- // Be sure to use unsigned variables,
- // because negative values introduce high bits
- // where zero bits are required.
-
- // Start out with all bits set high.
- ULONG ulCRC(0xffffffff);
- int len;
- unsigned char* buffer;
-
- // Get the length.
- len = text.GetLength();
- // Save the text in the buffer.
- buffer = (unsigned char*)(LPCTSTR)text;
- // Perform the algorithm on each character
- // in the string, using the lookup table values.
- while(len--)
- ulCRC = (ulCRC >> 8) ^ crc32_table[(ulCRC & 0xFF) ^ *buffer++];
- // Exclusive OR the result with the beginning value.
- return ulCRC ^ 0xffffffff;
+ return ~c;
}
-If you don't have an MFC compiler, you can substitute this function, which doesn't use a CString. Just change the declaration in the header file to: int Get_CRC(char* text); // Creates a CRC from a text string
-
-int CRCdemo::Get_CRC(char* text)
-{// Pass a text string to this function and it will return the CRC.
-
- // Once the lookup table has been filled in by the two functions above,
- // this function creates all CRCs using only the lookup table.
-
- // Be sure to use unsigned variables,
- // because negative values introduce high bits
- // where zero bits are required.
-
- // Start out with all bits set high.
- ULONG ulCRC(0xffffffff);
- int len;
- unsigned char* buffer;
-
- // Get the length.
- len = LEN_BYTES(text);
- // Save the text in the buffer.
- buffer = (unsigned char*)text;
- // Perform the algorithm on each character
- // in the string, using the lookup table values.
- while(len--)
- ulCRC = (ulCRC >> 8) ^ crc32_table[(ulCRC & 0xFF) ^ *buffer++];
- // Exclusive OR the result with the beginning value.
- return ulCRC ^ 0xffffffff;
-}
-
-//----------------
-
-/*
- * crc32.c
- * This code is in the public domain; copyright abandoned.
- * Liability for non-performance of this code is limited to the amount
- * you paid for it. Since it is distributed for free, your refund will
- * be very very small. If it breaks, you get to keep both pieces.
- */
-
-#include "crc32.h"
-
-#if __GNUC__ >= 3 /* 2.x has "attribute", but only 3.0 has "pure */
-#define attribute(x) __attribute__(x)
-#else
-#define attribute(x)
-#endif
-
-/*
- * There are multiple 16-bit CRC polynomials in common use, but this is
- * *the* standard CRC-32 polynomial, first popularized by Ethernet.
- * x^32+x^26+x^23+x^22+x^16+x^12+x^11+x^10+x^8+x^7+x^5+x^4+x^2+x^1+x^0
- */
-#define CRCPOLY_LE 0xedb88320
-#define CRCPOLY_BE 0x04c11db7
-
-/* How many bits at a time to use. Requires a table of 4< 8 || CRC_LE_BITS < 1 || CRC_LE_BITS & CRC_LE_BITS-1
-# error CRC_LE_BITS must be a power of 2 between 1 and 8
-#endif
-
-#if CRC_LE_BITS == 1
-/*
- * In fact, the table-based code will work in this case, but it can be
- * simplified by inlining the table in ?: form.
- */
-#define crc32init_le()
-#define crc32cleanup_le()
-/**
- * crc32_le() - Calculate bitwise little-endian Ethernet AUTODIN II CRC32
- * @crc - seed value for computation. ~0 for Ethernet, sometimes 0 for
- * other uses, or the previous crc32 value if computing incrementally.
- * @p - pointer to buffer over which CRC is run
- * @len - length of buffer @p
- *
- */
-uint32_t attribute((pure)) crc32_le(uint32_t crc, unsigned char const *p, size_t len)
+//
+// CRC32: C
+//
+REBCNT CRC32(REBYTE *buf, REBCNT len)
{
- int i;
- while (len--) {
- crc ^= *p++;
- for (i = 0; i < 8; i++)
- crc = (crc >> 1) ^ ((crc & 1) ? CRCPOLY_LE : 0);
- }
- return crc;
-}
-#else /* Table-based approach */
-
-static uint32_t *crc32table_le;
-/**
- * crc32init_le() - allocate and initialize LE table data
- *
- * crc is the crc of the byte i; other entries are filled in based on the
- * fact that crctable[i^j] = crctable[i] ^ crctable[j].
- *
- */
-static int
-crc32init_le(void)
-{
- unsigned i, j;
- uint32_t crc = 1;
-
- crc32table_le =
- malloc((1 << CRC_LE_BITS) * sizeof(uint32_t));
- if (!crc32table_le)
- return 1;
- crc32table_le[0] = 0;
-
- for (i = 1 << (CRC_LE_BITS - 1); i; i >>= 1) {
- crc = (crc >> 1) ^ ((crc & 1) ? CRCPOLY_LE : 0);
- for (j = 0; j < 1 << CRC_LE_BITS; j += 2 * i)
- crc32table_le[i + j] = crc ^ crc32table_le[j];
- }
- return 0;
+ return Update_CRC32(U32_C(0x00000000), buf, len);
}
-/**
- * crc32cleanup_le(): free LE table data
- */
-static void
-crc32cleanup_le(void)
-{
- if (crc32table_le) free(crc32table_le);
- crc32table_le = NULL;
-}
-/**
- * crc32_le() - Calculate bitwise little-endian Ethernet AUTODIN II CRC32
- * @crc - seed value for computation. ~0 for Ethernet, sometimes 0 for
- * other uses, or the previous crc32 value if computing incrementally.
- * @p - pointer to buffer over which CRC is run
- * @len - length of buffer @p
- *
- */
-uint32_t attribute((pure)) crc32_le(uint32_t crc, unsigned char const *p, size_t len)
-{
- while (len--) {
-# if CRC_LE_BITS == 8
- crc = (crc >> 8) ^ crc32table_le[(crc ^ *p++) & 255];
-# elif CRC_LE_BITS == 4
- crc ^= *p++;
- crc = (crc >> 4) ^ crc32table_le[crc & 15];
- crc = (crc >> 4) ^ crc32table_le[crc & 15];
-# elif CRC_LE_BITS == 2
- crc ^= *p++;
- crc = (crc >> 2) ^ crc32table_le[crc & 3];
- crc = (crc >> 2) ^ crc32table_le[crc & 3];
- crc = (crc >> 2) ^ crc32table_le[crc & 3];
- crc = (crc >> 2) ^ crc32table_le[crc & 3];
-# endif
- }
- return crc;
-}
-#endif
-
-/*
- * Big-endian CRC computation. Used with serial bit streams sent
- * msbit-first. Be sure to use cpu_to_be32() to append the computed CRC.
- */
-#if CRC_BE_BITS > 8 || CRC_BE_BITS < 1 || CRC_BE_BITS & CRC_BE_BITS-1
-# error CRC_BE_BITS must be a power of 2 between 1 and 8
-#endif
-
-#if CRC_BE_BITS == 1
-/*
- * In fact, the table-based code will work in this case, but it can be
- * simplified by inlining the table in ?: form.
- */
-#define crc32init_be()
-#define crc32cleanup_be()
-
-/**
- * crc32_be() - Calculate bitwise big-endian Ethernet AUTODIN II CRC32
- * @crc - seed value for computation. ~0 for Ethernet, sometimes 0 for
- * other uses, or the previous crc32 value if computing incrementally.
- * @p - pointer to buffer over which CRC is run
- * @len - length of buffer @p
- *
- */
-uint32_t attribute((pure)) crc32_be(uint32_t crc, unsigned char const *p, size_t len)
-{
- int i;
- while (len--) {
- crc ^= *p++ << 24;
- for (i = 0; i < 8; i++)
- crc =
- (crc << 1) ^ ((crc & 0x80000000) ? CRCPOLY_BE :
- 0);
- }
- return crc;
+//
+// Hash_String: C
+//
+// Return a 32-bit case insensitive hash value for the string. The
+// string does not have to be zero terminated and UTF8 is ok.
+//
+REBINT Hash_String(
+ const void *data, // REBYTE* or REBUNI*
+ REBCNT len, // chars, not bytes
+ REBCNT wide // 1 = byte-sized, 2 = Unicode
+) {
+ u32 c = 0x00000000;
+ u32 c2 = 0x00000000; // don't change, see [1] below
+ REBCNT n;
+ const REBYTE *b = cast(const REBYTE*, data);
+ const REBUNI *u = cast(const REBUNI*, data);
+
+ if(!crc32_table) Make_CRC32_Table();
+
+ if (wide == 1) {
+ for(n = 0; n < len; n++) {
+ c = (c >> 8) ^ crc32_table[(c ^ LO_CASE(b[n])) & 0xff];
+ }
+ } else if (wide == 2) {
+ for(n = 0; n < len; n++) {
+ c = (c >> 8) ^ crc32_table[(c ^ LO_CASE(u[n])) & 0xff];
+
+ c2 = (c2 >> 8) ^ crc32_table[
+ (c2 ^ (LO_CASE(u[n]) >> 8)) & 0xff
+ ];
+ }
+ }
+ else
+ assert(wide == 1 || wide == 2);
+
+ // [1] If wide = 2 but all chars <= 0xFF then c2 = 0, and c is the same
+ // as wide = 1
+ //
+ c ^= c2;
+
+ return cast(REBINT,~c);
}
-#else /* Table-based approach */
-static uint32_t *crc32table_be;
-/**
- * crc32init_be() - allocate and initialize BE table data
- */
-static int
-crc32init_be(void)
+//
+// Startup_CRC: C
+//
+void Startup_CRC(void)
{
- unsigned i, j;
- uint32_t crc = 0x80000000;
-
- crc32table_be =
- malloc((1 << CRC_BE_BITS) * sizeof(uint32_t));
- if (!crc32table_be)
- return 1;
- crc32table_be[0] = 0;
-
- for (i = 1; i < 1 << CRC_BE_BITS; i <<= 1) {
- crc = (crc << 1) ^ ((crc & 0x80000000) ? CRCPOLY_BE : 0);
- for (j = 0; j < i; j++)
- crc32table_be[i + j] = crc ^ crc32table_be[j];
- }
- return 0;
-}
+ CRC_Table = ALLOC_N(REBCNT, 256);
+ Make_CRC_Table(PRZCRC);
-/**
- * crc32cleanup_be(): free BE table data
- */
-static void
-crc32cleanup_be(void)
-{
- if (crc32table_be) free(crc32table_be);
- crc32table_be = NULL;
+ Make_CRC32_Table();
}
-/**
- * crc32_be() - Calculate bitwise big-endian Ethernet AUTODIN II CRC32
- * @crc - seed value for computation. ~0 for Ethernet, sometimes 0 for
- * other uses, or the previous crc32 value if computing incrementally.
- * @p - pointer to buffer over which CRC is run
- * @len - length of buffer @p
- *
- */
-uint32_t attribute((pure)) crc32_be(uint32_t crc, unsigned char const *p, size_t len)
+//
+// Shutdown_CRC: C
+//
+void Shutdown_CRC(void)
{
- while (len--) {
-# if CRC_BE_BITS == 8
- crc = (crc << 8) ^ crc32table_be[(crc >> 24) ^ *p++];
-# elif CRC_BE_BITS == 4
- crc ^= *p++ << 24;
- crc = (crc << 4) ^ crc32table_be[crc >> 28];
- crc = (crc << 4) ^ crc32table_be[crc >> 28];
-# elif CRC_BE_BITS == 2
- crc ^= *p++ << 24;
- crc = (crc << 2) ^ crc32table_be[crc >> 30];
- crc = (crc << 2) ^ crc32table_be[crc >> 30];
- crc = (crc << 2) ^ crc32table_be[crc >> 30];
- crc = (crc << 2) ^ crc32table_be[crc >> 30];
-# endif
- }
- return crc;
-}
-#endif
-
-/*
- * A brief CRC tutorial.
- *
- * A CRC is a long-division remainder. You add the CRC to the message,
- * and the whole thing (message+CRC) is a multiple of the given
- * CRC polynomial. To check the CRC, you can either check that the
- * CRC matches the recomputed value, *or* you can check that the
- * remainder computed on the message+CRC is 0. This latter approach
- * is used by a lot of hardware implementations, and is why so many
- * protocols put the end-of-frame flag after the CRC.
- *
- * It's actually the same long division you learned in school, except that
- * - We're working in binary, so the digits are only 0 and 1, and
- * - When dividing polynomials, there are no carries. Rather than add and
- * subtract, we just xor. Thus, we tend to get a bit sloppy about
- * the difference between adding and subtracting.
- *
- * A 32-bit CRC polynomial is actually 33 bits long. But since it's
- * 33 bits long, bit 32 is always going to be set, so usually the CRC
- * is written in hex with the most significant bit omitted. (If you're
- * familiar with the IEEE 754 floating-point format, it's the same idea.)
- *
- * Note that a CRC is computed over a string of *bits*, so you have
- * to decide on the endianness of the bits within each byte. To get
- * the best error-detecting properties, this should correspond to the
- * order they're actually sent. For example, standard RS-232 serial is
- * little-endian; the most significant bit (sometimes used for parity)
- * is sent last. And when appending a CRC word to a message, you should
- * do it in the right order, matching the endianness.
- *
- * Just like with ordinary division, the remainder is always smaller than
- * the divisor (the CRC polynomial) you're dividing by. Each step of the
- * division, you take one more digit (bit) of the dividend and append it
- * to the current remainder. Then you figure out the appropriate multiple
- * of the divisor to subtract to being the remainder back into range.
- * In binary, it's easy - it has to be either 0 or 1, and to make the
- * XOR cancel, it's just a copy of bit 32 of the remainder.
- *
- * When computing a CRC, we don't care about the quotient, so we can
- * throw the quotient bit away, but subtract the appropriate multiple of
- * the polynomial from the remainder and we're back to where we started,
- * ready to process the next bit.
- *
- * A big-endian CRC written this way would be coded like:
- * for (i = 0; i < input_bits; i++) {
- * multiple = remainder & 0x80000000 ? CRCPOLY : 0;
- * remainder = (remainder << 1 | next_input_bit()) ^ multiple;
- * }
- * Notice how, to get at bit 32 of the shifted remainder, we look
- * at bit 31 of the remainder *before* shifting it.
- *
- * But also notice how the next_input_bit() bits we're shifting into
- * the remainder don't actually affect any decision-making until
- * 32 bits later. Thus, the first 32 cycles of this are pretty boring.
- * Also, to add the CRC to a message, we need a 32-bit-long hole for it at
- * the end, so we have to add 32 extra cycles shifting in zeros at the
- * end of every message,
- *
- * So the standard trick is to rearrage merging in the next_input_bit()
- * until the moment it's needed. Then the first 32 cycles can be precomputed,
- * and merging in the final 32 zero bits to make room for the CRC can be
- * skipped entirely.
- * This changes the code to:
- * for (i = 0; i < input_bits; i++) {
- * remainder ^= next_input_bit() << 31;
- * multiple = (remainder & 0x80000000) ? CRCPOLY : 0;
- * remainder = (remainder << 1) ^ multiple;
- * }
- * With this optimization, the little-endian code is simpler:
- * for (i = 0; i < input_bits; i++) {
- * remainder ^= next_input_bit();
- * multiple = (remainder & 1) ? CRCPOLY : 0;
- * remainder = (remainder >> 1) ^ multiple;
- * }
- *
- * Note that the other details of endianness have been hidden in CRCPOLY
- * (which must be bit-reversed) and next_input_bit().
- *
- * However, as long as next_input_bit is returning the bits in a sensible
- * order, we can actually do the merging 8 or more bits at a time rather
- * than one bit at a time:
- * for (i = 0; i < input_bytes; i++) {
- * remainder ^= next_input_byte() << 24;
- * for (j = 0; j < 8; j++) {
- * multiple = (remainder & 0x80000000) ? CRCPOLY : 0;
- * remainder = (remainder << 1) ^ multiple;
- * }
- * }
- * Or in little-endian:
- * for (i = 0; i < input_bytes; i++) {
- * remainder ^= next_input_byte();
- * for (j = 0; j < 8; j++) {
- * multiple = (remainder & 1) ? CRCPOLY : 0;
- * remainder = (remainder << 1) ^ multiple;
- * }
- * }
- * If the input is a multiple of 32 bits, you can even XOR in a 32-bit
- * word at a time and increase the inner loop count to 32.
- *
- * You can also mix and match the two loop styles, for example doing the
- * bulk of a message byte-at-a-time and adding bit-at-a-time processing
- * for any fractional bytes at the end.
- *
- * The only remaining optimization is to the byte-at-a-time table method.
- * Here, rather than just shifting one bit of the remainder to decide
- * in the correct multiple to subtract, we can shift a byte at a time.
- * This produces a 40-bit (rather than a 33-bit) intermediate remainder,
- * but again the multiple of the polynomial to subtract depends only on
- * the high bits, the high 8 bits in this case.
- *
- * The multile we need in that case is the low 32 bits of a 40-bit
- * value whose high 8 bits are given, and which is a multiple of the
- * generator polynomial. This is simply the CRC-32 of the given
- * one-byte message.
- *
- * Two more details: normally, appending zero bits to a message which
- * is already a multiple of a polynomial produces a larger multiple of that
- * polynomial. To enable a CRC to detect this condition, it's common to
- * invert the CRC before appending it. This makes the remainder of the
- * message+crc come out not as zero, but some fixed non-zero value.
- *
- * The same problem applies to zero bits prepended to the message, and
- * a similar solution is used. Instead of starting with a remainder of
- * 0, an initial remainder of all ones is used. As long as you start
- * the same way on decoding, it doesn't make a difference.
- */
-
-
-/**
- * init_crc32(): generates CRC32 tables
- *
- * On successful initialization, use count is increased.
- * This guarantees that the library functions will stay resident
- * in memory, and prevents someone from 'rmmod crc32' while
- * a driver that needs it is still loaded.
- * This also greatly simplifies drivers, as there's no need
- * to call an initialization/cleanup function from each driver.
- * Since crc32.o is a library module, there's no requirement
- * that the user can unload it.
- */
-int
-init_crc32(void)
-{
- int rc1, rc2, rc;
- rc1 = crc32init_le();
- rc2 = crc32init_be();
- rc = rc1 || rc2;
- return rc;
-}
+ FREE_N(u32, 256, crc32_table);
-/**
- * cleanup_crc32(): frees crc32 data when no longer needed
- */
-void
-cleanup_crc32(void)
-{
- crc32cleanup_le();
- crc32cleanup_be();
+ FREE_N(REBCNT, 256, CRC_Table);
}
-
-#endif
diff --git a/src/core/s-file.c b/src/core/s-file.c
index 3c73299558..404052b7ff 100644
--- a/src/core/s-file.c
+++ b/src/core/s-file.c
@@ -1,275 +1,314 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: s-file.c
-** Summary: file and path string handling
-** Section: strings
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %s-file.c
+// Summary: "file and path string handling"
+// Section: strings
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#define FN_PAD 2 // pad file name len for adding /, /*, and /?
+#define FN_PAD 2 // pad file name len for adding /, /*, and /?
-/***********************************************************************
-**
-*/ REBSER *To_REBOL_Path(void *bp, REBCNT len, REBINT uni, REBFLG dir)
-/*
-** Convert local filename to a REBOL filename.
-**
-** Allocate and return a new series with the converted path.
-** Return 0 on error.
-**
-** Reduces width when possible.
-** Adds extra space at end for appending a dir /*
-**
-** REBDIFF: No longer appends current dir to volume when no
-** root slash is provided (that odd MSDOS c:file case).
-**
-***********************************************************************/
+//
+// To_REBOL_Path: C
+//
+// Convert local filename to a REBOL filename.
+//
+// Allocate and return a new series with the converted path.
+// Return NULL on error.
+//
+// Reduces width when possible to byte-size from unicode, unless the flag
+// PATH_OPT_FORCE_UNI_DEST is used.
+//
+// Adds extra space at end for appending a dir /(star)
+// (Note: don't put actual star, as "/" "*" ends this comment)
+//
+// REBDIFF: No longer appends current dir to volume when no
+// root slash is provided (that odd MSDOS c:file case).
+//
+REBSER *To_REBOL_Path(const void *p, REBCNT len, REBFLGS flags)
{
- REBOOL colon = 0; // have we hit a ':' yet?
- REBOOL slash = 0; // have we hit a '/' yet?
- REBUNI c;
- REBSER *dst;
- REBCNT n;
- REBCNT i;
+#ifdef TO_WINDOWS
+ REBOOL saw_colon = FALSE; // have we hit a ':' yet?
+ REBOOL saw_slash = FALSE; // have we hit a '/' yet?
+#endif
+
+ REBUNI c;
+ REBSER *dst;
+ REBCNT n;
+ REBCNT i;
+ REBOOL unicode = LOGICAL(flags & PATH_OPT_UNI_SRC);
+
+ const REBYTE *bp = unicode ? NULL : cast(const REBYTE *, p);
+
+ const REBUNI *up = unicode ? cast(const REBUNI *, p) : NULL;
- if (len == 0)
- len = uni ? wcslen((REBUNI*)bp) : LEN_BYTES((REBYTE*)bp);
-
- n = 0;
- dst = ((uni == -1) || (uni && Is_Wide((REBUNI*)bp, len)))
- ? Make_Unicode(len+FN_PAD) : Make_Binary(len+FN_PAD);
+ if (len == 0)
+ len = unicode ? Strlen_Uni(up) : LEN_BYTES(bp);
- for (i = 0; i < len;) {
- c = uni ? ((REBUNI*)bp)[i] : ((REBYTE*)bp)[i];
- i++;
- if (c == ':') {
- // Handle the vol:dir/file format:
- if (colon || slash) return 0; // no prior : or / allowed
- colon = 1;
- if (i < len) {
- c = uni ? ((REBUNI*)bp)[i] : ((REBYTE*)bp)[i];
- if (c == '\\' || c == '/') i++; // skip / in foo:/file
- }
- c = '/'; // replace : with a /
- }
- else if (c == '\\' || c== '/') {
- if (slash > 0) continue;
- c = '/';
- slash = 1;
- }
- else slash = 0;
- SET_ANY_CHAR(dst, n++, c);
- }
- if (dir && c != '/') { // watch for %/c/ case
- SET_ANY_CHAR(dst, n++, '/');
- }
- SERIES_TAIL(dst) = n;
- TERM_SERIES(dst);
+ n = 0;
- // Change C:/ to /C/ (and C:X to /C/X):
- if (colon) Insert_Char(dst, 0, (REBCNT)'/');
+ // The default is to scan unicode input to see if it contains any
+ // codepoints over 0xFF, and if not make a byte-sized result string.
+ // But this can be overridden with PATH_OPT_FORCE_UNI_DEST if (for
+ // instance) the target is going to be used as a Win32 native string.
+ //
+ assert(
+ (flags & PATH_OPT_FORCE_UNI_DEST)
+ ? LOGICAL(flags & PATH_OPT_UNI_SRC)
+ : TRUE
+ );
+ dst = ((flags & PATH_OPT_FORCE_UNI_DEST) || (unicode && Is_Wide(up, len)))
+ ? Make_Unicode(len + FN_PAD)
+ : Make_Binary(len + FN_PAD);
+
+ c = '\0'; // for test after loop (in case loop does not run)
+ for (i = 0; i < len;) {
+ c = unicode ? up[i] : bp[i];
+ i++;
+#ifdef TO_WINDOWS
+ if (c == ':') {
+ // Handle the vol:dir/file format:
+ if (saw_colon || saw_slash) return NULL; // no prior : or / allowed
+ saw_colon = TRUE;
+ if (i < len) {
+ c = unicode ? up[i] : bp[i];
+ if (c == '\\' || c == '/') i++; // skip / in foo:/file
+ }
+ c = '/'; // replace : with a /
+ }
+ else if (c == '\\' || c== '/') {
+ if (saw_slash) continue;
+ c = '/';
+ saw_slash = TRUE;
+ }
+ else saw_slash = FALSE;
+#endif
+ SET_ANY_CHAR(dst, n++, c);
+ }
+ if ((flags & PATH_OPT_SRC_IS_DIR) && c != '/') { // watch for %/c/ case
+ SET_ANY_CHAR(dst, n++, '/');
+ }
+ TERM_SEQUENCE_LEN(dst, n);
+
+#ifdef TO_WINDOWS
+ // Change C:/ to /C/ (and C:X to /C/X):
+ if (saw_colon) Insert_Char(dst, 0, '/');
+#endif
- return dst;
+ return dst;
}
-/***********************************************************************
-**
-*/ REBSER *Value_To_REBOL_Path(REBVAL *val, REBOOL dir)
-/*
-** Helper to above function.
-**
-***********************************************************************/
+//
+// Value_To_REBOL_Path: C
+//
+// Helper to above function.
+//
+REBSER *Value_To_REBOL_Path(REBVAL *val, REBOOL is_dir)
{
- ASSERT1(ANY_BINSTR(val), RP_MISC);
- return To_REBOL_Path(VAL_DATA(val), VAL_LEN(val), (REBOOL)!VAL_BYTE_SIZE(val), dir);
+ assert(ANY_BINSTR(val));
+ return To_REBOL_Path(
+ VAL_RAW_DATA_AT(val),
+ VAL_LEN_AT(val),
+ (
+ (VAL_BYTE_SIZE(val) ? 0 : PATH_OPT_UNI_SRC)
+ | (is_dir ? PATH_OPT_SRC_IS_DIR : 0)
+ )
+ );
}
-/***********************************************************************
-**
-*/ REBSER *To_Local_Path(void *bp, REBCNT len, REBOOL uni, REBFLG full)
-/*
-** Convert REBOL filename to a local filename.
-**
-** Allocate and return a new series with the converted path.
-** Return 0 on error.
-**
-** Adds extra space at end for appending a dir /*
-** Expands width for OS's that require it.
-**
-***********************************************************************/
+//
+// To_Local_Path: C
+//
+// Convert REBOL filename to a local filename.
+//
+// Allocate and return a new series with the converted path.
+// Return 0 on error.
+//
+// Adds extra space at end for appending a dir /(star)
+// (Note: don't put actual star, as "/" "*" ends this comment)
+//
+// Expands width for OS's that require it.
+//
+REBSER *To_Local_Path(const void *p, REBCNT len, REBOOL unicode, REBOOL full)
{
- REBUNI c, d;
- REBSER *dst;
- REBCNT i = 0;
- REBCNT n = 0;
- REBUNI *out;
- REBCHR *lpath;
- REBCNT l = 0;
+ REBUNI c;
+ REBSER *dst;
+ REBCNT i = 0;
+ REBCNT n = 0;
+ REBUNI *out;
+ REBCHR *lpath;
+ REBCNT l = 0;
+ const REBYTE *bp = unicode ? NULL : cast(const REBYTE *, p);
+ const REBUNI *up = unicode ? cast(const REBUNI *, p) : NULL;
- if (len == 0)
- len = uni ? wcslen((REBUNI*)bp) : LEN_BYTES((REBYTE*)bp);
+ if (len == 0)
+ len = unicode ? Strlen_Uni(up) : LEN_BYTES(bp);
- // Prescan for: /c/dir = c:/dir, /vol/dir = //vol/dir, //dir = ??
- c = GET_CHAR_UNI(uni, bp, i);
- if (c == '/') { // %/
- dst = Make_Unicode(len+FN_PAD);
- out = UNI_HEAD(dst);
-#ifdef TO_WIN32
- i++;
- if (i < len) {
- c = GET_CHAR_UNI(uni, bp, i);
- i++;
- }
- if (c != '/') { // %/c or %/c/ but not %/ %// %//c
- // peek ahead for a '/':
- d = '/';
- if (i < len) d = GET_CHAR_UNI(uni, bp, i);
- if (d == '/') { // %/c/ => "c:/"
- i++;
- out[n++] = c;
- out[n++] = ':';
- }
- else {
- out[n++] = OS_DIR_SEP; // %/cc %//cc => "//cc"
- i--;
- }
- }
+ // Prescan for: /c/dir = c:/dir, /vol/dir = //vol/dir, //dir = ??
+ c = unicode ? up[i] : bp[i];
+ if (c == '/') { // %/
+ dst = Make_Unicode(len+FN_PAD);
+ out = UNI_HEAD(dst);
+#ifdef TO_WINDOWS
+ i++;
+ if (i < len) {
+ c = unicode ? up[i] : bp[i];
+ i++;
+ }
+ if (c != '/') { // %/c or %/c/ but not %/ %// %//c
+ // peek ahead for a '/':
+ REBUNI d = '/';
+ if (i < len)
+ d = unicode ? up[i] : bp[i];
+ if (d == '/') { // %/c/ => "c:/"
+ i++;
+ out[n++] = c;
+ out[n++] = ':';
+ }
+ else {
+ out[n++] = OS_DIR_SEP; // %/cc %//cc => "//cc"
+ i--;
+ }
+ }
#endif
- out[n++] = OS_DIR_SEP;
- }
- else {
- if (full) l = OS_GET_CURRENT_DIR(&lpath);
- dst = Make_Unicode(l + len + FN_PAD); // may be longer (if lpath is encoded)
- if (full) {
-#ifdef TO_WIN32
- Append_Uni_Uni(dst, lpath, l);
+ out[n++] = OS_DIR_SEP;
+ }
+ else {
+ if (full) l = OS_GET_CURRENT_DIR(&lpath);
+ dst = Make_Unicode(l + len + FN_PAD); // may be longer (if lpath is encoded)
+ if (full) {
+#ifdef TO_WINDOWS
+ assert(sizeof(REBCHR) == sizeof(REBUNI));
+ Append_Uni_Uni(dst, cast(const REBUNI*, lpath), l);
#else
- REBINT clen = Decode_UTF8(UNI_HEAD(dst), lpath, l, FALSE);
- dst->tail = abs(clen);
- //Append_Bytes(dst, lpath);
+ REBINT clen = Decode_UTF8_Negative_If_Latin1(
+ UNI_HEAD(dst), cast(const REBYTE*, lpath), l, FALSE
+ );
+ SET_SERIES_LEN(dst, abs(clen));
+ //Append_Unencoded(dst, lpath);
#endif
- Append_Byte(dst, OS_DIR_SEP);
- OS_FREE(lpath);
- }
- out = UNI_HEAD(dst);
- n = SERIES_TAIL(dst);
- }
+ Append_Codepoint_Raw(dst, OS_DIR_SEP);
+ OS_FREE(lpath);
+ }
+ out = UNI_HEAD(dst);
+ n = SER_LEN(dst);
+ }
- // Prescan each file segment for: . .. directory names:
- // (Note the top of this loop always follows / or start)
- while (i < len) {
- if (full) {
- // Peek for: . ..
- c = GET_CHAR_UNI(uni, bp, i);
- if (c == '.') { // .
- i++;
- c = GET_CHAR_UNI(uni, bp, i);
- if (c == '.') { // ..
- c = GET_CHAR_UNI(uni, bp, i+1);
- if (c == 0 || c == '/') { // ../ or ..
- i++;
- // backup a dir
- n -= (n > 2) ? 2 : n;
- for (; n > 0 && out[n] != OS_DIR_SEP; n--);
- c = c ? 0 : OS_DIR_SEP; // add / if necessary
- }
- // fall through on invalid ..x combination:
- }
- else { // .a or . or ./
- if (c == '/') {
- i++;
- c = 0; // ignore it
- }
- else if (c) c = '.'; // for store below
- }
- if (c) out[n++] = c;
- }
- }
- for (; i < len; i++) {
- c = GET_CHAR_UNI(uni, bp, i);
- if (c == '/') {
- if (n == 0 || out[n-1] != OS_DIR_SEP) out[n++] = OS_DIR_SEP;
- i++;
- break;
- }
- out[n++] = c;
- }
- }
- out[n] = 0;
- SERIES_TAIL(dst) = n;
-// TERM_SERIES(dst);
-// Debug_Uni(dst);
+ // Prescan each file segment for: . .. directory names:
+ // (Note the top of this loop always follows / or start)
+ while (i < len) {
+ // each iteration takes care of one segment of the path, i.e. stops after OS_DIR_SEP
+ if (full) {
+ // Peek for: . ..
+ c = unicode ? up[i] : bp[i];
+ if (c == '.') { // .
+ i++;
+ c = unicode ? up[i] : bp[i];
+ if (c == '.') { // ..
+ c = unicode ? up[i + 1] : bp[i + 1];
+ if (c == 0 || c == '/') { // ../ or ..
+ i++;
+ // backup a dir
+ n -= (n > 2) ? 2 : n;
+ for (; n > 0 && out[n] != OS_DIR_SEP; n--);
+ c = c ? 0 : OS_DIR_SEP; // add / if necessary
+ }
+ // fall through on invalid ..x combination:
+ }
+ else { // .a or . or ./
+ if (c == '/') {
+ c = 0; // ignore it
+ }
+ else if (c) c = '.'; // for store below
+ }
+ if (c) out[n++] = c;
+ }
+ }
+ for (; i < len; i++) {
+ c = unicode ? up[i] : bp[i];
+ if (c == '/') {
+ if (n == 0 || out[n-1] != OS_DIR_SEP) out[n++] = OS_DIR_SEP;
+ i++;
+ break;
+ }
+ out[n++] = c;
+ }
+ }
+ out[n] = 0;
+ SET_SERIES_LEN(dst, n);
+ ASSERT_SERIES_TERM(dst);
- return dst;
+ return dst;
}
-/***********************************************************************
-**
-*/ REBSER *Value_To_Local_Path(REBVAL *val, REBFLG full)
-/*
-** Helper to above function.
-**
-***********************************************************************/
+//
+// Value_To_Local_Path: C
+//
+// Helper to above function.
+//
+REBSER *Value_To_Local_Path(REBVAL *val, REBOOL full)
{
- ASSERT1(ANY_BINSTR(val), RP_MISC);
- return To_Local_Path(VAL_DATA(val), VAL_LEN(val), (REBOOL)!VAL_BYTE_SIZE(val), full);
+ assert(ANY_BINSTR(val));
+ return To_Local_Path(
+ VAL_RAW_DATA_AT(val), VAL_LEN_AT(val), NOT(VAL_BYTE_SIZE(val)), full
+ );
}
-/***********************************************************************
-**
-*/ REBSER *Value_To_OS_Path(REBVAL *val)
-/*
-** Helper to above function.
-**
-***********************************************************************/
+//
+// Value_To_OS_Path: C
+//
+// Helper to above function.
+//
+REBSER *Value_To_OS_Path(const REBVAL *val, REBOOL full)
{
- REBSER *ser; // will be unicode size
-#ifndef TO_WIN32
- REBSER *bin;
- REBCNT n;
+ REBSER *ser; // will be unicode size
+#ifndef TO_WINDOWS
+ REBSER *bin;
#endif
- ASSERT1(ANY_BINSTR(val), RP_MISC);
+ assert(ANY_BINSTR(val));
- ser = To_Local_Path(VAL_DATA(val), VAL_LEN(val), (REBOOL)!VAL_BYTE_SIZE(val), TRUE);
+ ser = To_Local_Path(
+ VAL_RAW_DATA_AT(val), VAL_LEN_AT(val), NOT(VAL_BYTE_SIZE(val)), full
+ );
-#ifndef TO_WIN32
- // Posix needs UTF8 conversion:
- n = Length_As_UTF8(UNI_HEAD(ser), SERIES_TAIL(ser), TRUE, OS_CRLF);
- bin = Make_Binary(n + FN_PAD);
- Encode_UTF8(BIN_HEAD(bin), n+FN_PAD, UNI_HEAD(ser), &n, TRUE, OS_CRLF);
- SERIES_TAIL(bin) = n;
- TERM_SERIES(bin);
- ser = bin;
+#ifndef TO_WINDOWS
+ // Posix needs UTF8 conversion:
+ bin = Make_UTF8_Binary(
+ UNI_HEAD(ser), SER_LEN(ser), FN_PAD, OPT_ENC_UNISRC
+ );
+ Free_Series(ser);
+ ser = bin;
#endif
- return ser;
+ return ser;
}
diff --git a/src/core/s-find.c b/src/core/s-find.c
index 9d5bf6f184..d1fa9e0843 100644
--- a/src/core/s-find.c
+++ b/src/core/s-find.c
@@ -1,573 +1,761 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: s-find.c
-** Summary: string search and comparison
-** Section: strings
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %s-find.c
+// Summary: "string search and comparison"
+// Section: strings
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ REBINT Compare_Binary_Vals(REBVAL *v1, REBVAL *v2)
-/*
-** Compare two binary values.
-**
-** Compares bytes, not chars. Return the difference.
-**
-** Used for: Binary comparision function
-**
-***********************************************************************/
+//
+// Compare_Binary_Vals: C
+//
+// Compare two binary values.
+//
+// Compares bytes, not chars. Return the difference.
+//
+// Used for: Binary comparision function
+//
+REBINT Compare_Binary_Vals(const RELVAL *v1, const RELVAL *v2)
{
- REBCNT l1 = VAL_LEN(v1);
- REBCNT l2 = VAL_LEN(v2);
- REBCNT len = MIN(l1, l2);
- REBINT n;
-
- if (IS_IMAGE(v1)) len *= 4;
-
- n = memcmp(VAL_BIN_DATA(v1), VAL_BIN_DATA(v2), len);
-
- if (n != 0) return n;
-
- return l1 - l2;
+ REBCNT l1 = VAL_LEN_AT(v1);
+ REBCNT l2 = VAL_LEN_AT(v2);
+ REBCNT len = MIN(l1, l2);
+ REBINT n;
+
+ if (IS_IMAGE(v1)) len *= 4;
+
+ // Image is not "byte size" (note multiplied by 4 above) but still calls
+ // binary compare...can't use VAL_BIN_AT as long as it does, because
+ // that asserts BYTE_SIZE().
+ //
+ n = memcmp(
+ SER_AT_RAW(SER_WIDE(VAL_SERIES(v1)), VAL_SERIES(v1), VAL_INDEX(v1)),
+ SER_AT_RAW(SER_WIDE(VAL_SERIES(v2)), VAL_SERIES(v2), VAL_INDEX(v2)),
+ len
+ );
+
+ if (n != 0) return n;
+
+ return l1 - l2;
}
-/***********************************************************************
-**
-*/ REBINT Compare_Bytes(REBYTE *b1, REBYTE *b2, REBCNT len, REBOOL uncase)
-/*
-** Compare two byte-wide strings. Return lexical difference.
-**
-** Uncase: compare is case-insensitive.
-**
-***********************************************************************/
+//
+// Compare_Bytes: C
+//
+// Compare two byte-wide strings. Return lexical difference.
+//
+// Uncase: compare is case-insensitive.
+//
+REBINT Compare_Bytes(const REBYTE *b1, const REBYTE *b2, REBCNT len, REBOOL uncase)
{
- REBINT d;
+ REBINT d;
- for (; len > 0; len--, b1++, b2++) {
+ for (; len > 0; len--, b1++, b2++) {
- if (uncase)
- d = LO_CASE(*b1) - LO_CASE(*b2);
- else
- d = *b1 - *b2;
+ if (uncase)
+ d = LO_CASE(*b1) - LO_CASE(*b2);
+ else
+ d = *b1 - *b2;
- if (d != 0) return d;
- }
+ if (d != 0) return d;
+ }
- return 0;
+ return 0;
}
-/***********************************************************************
-**
-*/ REBYTE *Match_Bytes(REBYTE *src, REBYTE *pat)
-/*
-** Compare two binary strings. Return where the first differed.
-** Case insensitive.
-**
-***********************************************************************/
+//
+// Match_Bytes: C
+//
+// Compare two binary strings. Return where the first differed.
+// Case insensitive.
+//
+const REBYTE *Match_Bytes(const REBYTE *src, const REBYTE *pat)
{
- while (*src && *pat) {
- if (LO_CASE(*src++) != LO_CASE(*pat++)) return 0;
- }
+ while (*src && *pat) {
+ if (LO_CASE(*src++) != LO_CASE(*pat++)) return 0;
+ }
- if (*pat) return 0; // if not at end of pat, then error
+ if (*pat) return 0; // if not at end of pat, then error
- return src;
+ return src;
}
-/***********************************************************************
-**
-*/ REBFLG Match_Sub_Path(REBSER *s1, REBSER *s2)
-/*
-** Compare two file path series, regardless of char size.
-** Return TRUE if s1 is a subpath of s2.
-** Case insensitive.
-**
-***********************************************************************/
+//
+// Match_Sub_Path: C
+//
+// Compare two file path series, regardless of char size.
+// Return TRUE if s1 is a subpath of s2.
+// Case insensitive.
+//
+REBOOL Match_Sub_Path(REBSER *s1, REBSER *s2)
{
- REBCNT len = s1->tail;
- REBCNT n;
- REBUNI c1 = 0;
- REBUNI c2;
-
-// Debug_Series(s1);
-// Debug_Series(s2);
+ REBCNT len = SER_LEN(s1);
+ REBCNT n;
+ REBUNI c1 = 0;
+ REBUNI c2;
- // s1 len must be <= s2 len
- if (len > s2->tail) return FALSE;
+ // s1 len must be <= s2 len
+ if (len > SER_LEN(s2)) return FALSE;
- for (n = 0; n < len; n++) { // includes terminator
+ for (n = 0; n < len; n++) { // includes terminator
- c1 = GET_ANY_CHAR(s1, n);
- c2 = GET_ANY_CHAR(s2, n);
+ c1 = GET_ANY_CHAR(s1, n);
+ c2 = GET_ANY_CHAR(s2, n);
- if (c1 < UNICODE_CASES) c1 = LO_CASE(c1);
- if (c2 < UNICODE_CASES) c2 = LO_CASE(c2);
+ if (c1 < UNICODE_CASES) c1 = LO_CASE(c1);
+ if (c2 < UNICODE_CASES) c2 = LO_CASE(c2);
- if (c1 != c2) break;
- }
+ if (c1 != c2) break;
+ }
- // a/b matches: a/b, a/b/, a/b/c
- c2 = GET_ANY_CHAR(s2, n);
- return (
- n >= len // all chars matched
- && // Must be at end or at dir sep:
- (c1 == '/' || c1 == '\\'
- || c2 == 0 || c2 == '/' || c2 == '\\')
- );
+ // a/b matches: a/b, a/b/, a/b/c
+ c2 = GET_ANY_CHAR(s2, n);
+ return LOGICAL(
+ n >= len // all chars matched
+ && // Must be at end or at dir sep:
+ (c1 == '/' || c1 == '\\'
+ || c2 == 0 || c2 == '/' || c2 == '\\')
+ );
}
-/***********************************************************************
-**
-*/ REBINT Compare_Uni_Byte(REBUNI *u1, REBYTE *b2, REBCNT len, REBOOL uncase)
-/*
-** Compare unicode and byte-wide strings. Return lexical difference.
-**
-** Uncase: compare is case-insensitive.
-**
-***********************************************************************/
+//
+// Compare_Uni_Byte: C
+//
+// Compare unicode and byte-wide strings. Return lexical difference.
+//
+// Uncase: compare is case-insensitive.
+//
+REBINT Compare_Uni_Byte(REBUNI *u1, REBYTE *b2, REBCNT len, REBOOL uncase)
{
- REBINT d;
- REBUNI c1;
- REBUNI c2;
+ REBINT d;
+ REBUNI c1;
+ REBUNI c2;
- for (; len > 0; len--) {
+ for (; len > 0; len--) {
- c1 = *u1++;
- c2 = *b2++;
+ c1 = *u1++;
+ c2 = *b2++;
- if (uncase && c1 < UNICODE_CASES)
- d = LO_CASE(c1) - LO_CASE(c2);
- else
- d = c1 - c2;
+ if (uncase && c1 < UNICODE_CASES)
+ d = LO_CASE(c1) - LO_CASE(c2);
+ else
+ d = c1 - c2;
- if (d != 0) return d;
- }
+ if (d != 0) return d;
+ }
- return 0;
+ return 0;
}
-/***********************************************************************
-**
-*/ REBINT Compare_Uni_Str(REBUNI *u1, REBUNI *u2, REBCNT len, REBOOL uncase)
-/*
-** Compare two unicode-wide strings. Return lexical difference.
-**
-** Uncase: compare is case-insensitive.
-**
-***********************************************************************/
+//
+// Compare_Uni_Str: C
+//
+// Compare two unicode-wide strings. Return lexical difference.
+//
+// Uncase: compare is case-insensitive.
+//
+REBINT Compare_Uni_Str(REBUNI *u1, REBUNI *u2, REBCNT len, REBOOL uncase)
{
- REBINT d;
- REBUNI c1;
- REBUNI c2;
+ REBINT d;
+ REBUNI c1;
+ REBUNI c2;
- for (; len > 0; len--) {
+ for (; len > 0; len--) {
- c1 = *u1++;
- c2 = *u2++;
+ c1 = *u1++;
+ c2 = *u2++;
- if (uncase && c1 < UNICODE_CASES && c2 < UNICODE_CASES)
- d = LO_CASE(c1) - LO_CASE(c2);
- else
- d = c1 - c2;
+ if (uncase && c1 < UNICODE_CASES && c2 < UNICODE_CASES)
+ d = LO_CASE(c1) - LO_CASE(c2);
+ else
+ d = c1 - c2;
- if (d != 0) return d;
- }
+ if (d != 0) return d;
+ }
- return 0;
+ return 0;
}
-/***********************************************************************
-**
-*/ REBINT Compare_String_Vals(REBVAL *v1, REBVAL *v2, REBOOL uncase)
-/*
-** Compare two string values. Either can be byte or unicode wide.
-**
-** Uncase: compare is case-insensitive.
-**
-** Used for: general string comparions (various places)
-**
-***********************************************************************/
+//
+// Compare_String_Vals: C
+//
+// Compare two string values. Either can be byte or unicode wide.
+//
+// Uncase: compare is case-insensitive.
+//
+// Used for: general string comparions (various places)
+//
+REBINT Compare_String_Vals(const RELVAL *v1, const RELVAL *v2, REBOOL uncase)
{
- REBCNT l1 = VAL_LEN(v1);
- REBCNT l2 = VAL_LEN(v2);
- REBCNT len = MIN(l1, l2);
- REBINT n;
-
- if (IS_BINARY(v1) || IS_BINARY(v2)) uncase = FALSE;
-
- if (VAL_BYTE_SIZE(v1)) { // v1 is 8
- if (VAL_BYTE_SIZE(v2))
- n = Compare_Bytes(VAL_BIN_DATA(v1), VAL_BIN_DATA(v2), len, uncase);
- else
- n = -Compare_Uni_Byte(VAL_UNI_DATA(v2), VAL_BIN_DATA(v1), len, uncase);
- }
- else { // v1 is 16
- if (VAL_BYTE_SIZE(v2))
- n = Compare_Uni_Byte(VAL_UNI_DATA(v1), VAL_BIN_DATA(v2), len, uncase);
- else
- n = Compare_Uni_Str(VAL_UNI_DATA(v1), VAL_UNI_DATA(v2), len, uncase);
- }
-
- if (n != 0) return n;
- return l1 - l2;
+ REBCNT l1 = VAL_LEN_AT(v1);
+ REBCNT l2 = VAL_LEN_AT(v2);
+ REBCNT len = MIN(l1, l2);
+ REBINT n;
+
+ if (IS_BINARY(v1) || IS_BINARY(v2)) uncase = FALSE;
+
+ if (VAL_BYTE_SIZE(v1)) { // v1 is 8
+ if (VAL_BYTE_SIZE(v2))
+ n = Compare_Bytes(VAL_BIN_AT(v1), VAL_BIN_AT(v2), len, uncase);
+ else
+ n = -Compare_Uni_Byte(VAL_UNI_AT(v2), VAL_BIN_AT(v1), len, uncase);
+ }
+ else { // v1 is 16
+ if (VAL_BYTE_SIZE(v2))
+ n = Compare_Uni_Byte(VAL_UNI_AT(v1), VAL_BIN_AT(v2), len, uncase);
+ else
+ n = Compare_Uni_Str(VAL_UNI_AT(v1), VAL_UNI_AT(v2), len, uncase);
+ }
+
+ if (n != 0) return n;
+ return l1 - l2;
}
-/***********************************************************************
-**
-*/ REBINT Compare_UTF8(REBYTE *s1, REBYTE *s2, REBCNT l2)
-/*
-** Compare two UTF8 strings.
-**
-** It is necessary to decode the strings to check if the match
-** case-insensitively.
-**
-** Returns:
-** -3: no match, s2 > s1
-** -1: no match, s1 > s2
-** 0: exact match
-** 1: non-case match, s2 > s1
-** 3: non-case match, s1 > s2
-**
-** So, result + 2 for no-match gives proper sort order.
-** And, result - 2 for non-case match gives sort order.
-**
-** Used for: WORD comparison.
-**
-***********************************************************************/
+//
+// Compare_UTF8: C
+//
+// Compare two UTF8 strings.
+//
+// It is necessary to decode the strings to check if the match
+// case-insensitively.
+//
+// Returns:
+// -3: no match, s2 > s1
+// -1: no match, s1 > s2
+// 0: exact match
+// 1: non-case match, s2 > s1
+// 3: non-case match, s1 > s2
+//
+// So, result + 2 for no-match gives proper sort order.
+// And, result - 2 for non-case match gives sort order.
+//
+// Used for: WORD comparison.
+//
+REBINT Compare_UTF8(const REBYTE *s1, const REBYTE *s2, REBCNT l2)
{
- REBINT c1, c2;
- REBCNT l1 = LEN_BYTES(s1);
- REBINT result = 0;
-
- for (; l1 > 0 && l2 > 0; s1++, s2++, l1--, l2--) {
- c1 = (REBYTE)*s1;
- c2 = (REBYTE)*s2;
- if (c1 > 127) c1 = Decode_UTF8_Char(&s1, &l1); //!!! can return 0 on error!
- if (c2 > 127) c2 = Decode_UTF8_Char(&s2, &l2);
- if (c1 != c2) {
- if (c1 >= UNICODE_CASES || c2 >= UNICODE_CASES ||
- LO_CASE(c1) != LO_CASE(c2)) {
- return (c1 > c2) ? -1 : -3;
- }
- if (!result) result = (c1 > c2) ? 3 : 1;
- }
- }
- if (l1 != l2) result = (l1 > l2) ? -1 : -3;
-
- return result;
+ REBUNI c1, c2;
+ REBCNT l1 = LEN_BYTES(s1);
+ REBINT result = 0;
+
+ for (; l1 > 0 && l2 > 0; s1++, s2++, l1--, l2--) {
+ c1 = *s1;
+ c2 = *s2;
+ if (c1 > 127) {
+ s1 = Back_Scan_UTF8_Char(&c1, s1, &l1);
+ assert(s1); // UTF8 should have already been verified good
+ }
+ if (c2 > 127) {
+ s2 = Back_Scan_UTF8_Char(&c2, s2, &l2);
+ assert(s2); // UTF8 should have already been verified good
+ }
+ if (c1 != c2) {
+ if (c1 >= UNICODE_CASES || c2 >= UNICODE_CASES ||
+ LO_CASE(c1) != LO_CASE(c2)) {
+ return (c1 > c2) ? -1 : -3;
+ }
+ if (!result) result = (c1 > c2) ? 3 : 1;
+ }
+ }
+ if (l1 != l2) result = (l1 > l2) ? -1 : -3;
+
+ return result;
}
-/***********************************************************************
-**
-*/ REBCNT Find_Byte_Str(REBSER *series, REBCNT index, REBYTE *b2, REBCNT l2, REBFLG uncase, REBFLG match)
-/*
-** Find a byte string within a byte string. Optimized for speed.
-**
-** Returns starting position or NOT_FOUND.
-**
-** Uncase: compare is case-insensitive.
-** Match: compare to first position only.
-**
-** NOTE: Series tail must be > index.
-**
-***********************************************************************/
+//
+// Find_Byte_Str: C
+//
+// Find a byte string within a byte string. Optimized for speed.
+//
+// Returns starting position or NOT_FOUND.
+//
+// Uncase: compare is case-insensitive.
+// Match: compare to first position only.
+//
+// NOTE: Series tail must be > index.
+//
+REBCNT Find_Byte_Str(REBSER *series, REBCNT index, REBYTE *b2, REBCNT l2, REBOOL uncase, REBOOL match)
{
- REBYTE *b1;
- REBYTE *e1;
- REBCNT l1;
- REBYTE c;
- REBCNT n;
+ REBYTE *b1;
+ REBYTE *e1;
+ REBCNT l1;
+ REBYTE c;
+ REBCNT n;
- // The pattern empty or is longer than the target:
- if (l2 == 0 || (l2 + index) > SERIES_TAIL(series)) return NOT_FOUND;
+ // The pattern empty or is longer than the target:
+ if (l2 == 0 || (l2 + index) > SER_LEN(series)) return NOT_FOUND;
- b1 = BIN_SKIP(series, index);
- l1 = SERIES_TAIL(series) - index;
+ b1 = BIN_AT(series, index);
+ l1 = SER_LEN(series) - index;
- e1 = b1 + (match ? 1 : l1 - (l2 - 1));
+ e1 = b1 + (match ? 1 : l1 - (l2 - 1));
- c = *b2; // first char
+ c = *b2; // first char
- if (!uncase) {
+ if (!uncase) {
- while (b1 != e1) {
- if (*b1 == c) { // matched first char
- for (n = 1; n < l2; n++) {
- if (b1[n] != b2[n]) break;
- }
- if (n == l2) return (b1 - BIN_HEAD(series));
- }
- b1++;
- }
+ while (b1 != e1) {
+ if (*b1 == c) { // matched first char
+ for (n = 1; n < l2; n++) {
+ if (b1[n] != b2[n]) break;
+ }
+ if (n == l2) return (b1 - BIN_HEAD(series));
+ }
+ b1++;
+ }
- } else {
+ } else {
- c = (REBYTE)LO_CASE(c); // OK! (never > 255)
+ c = (REBYTE)LO_CASE(c); // OK! (never > 255)
- while (b1 != e1) {
- if (LO_CASE(*b1) == c) { // matched first char
- for (n = 1; n < l2; n++) {
- if (LO_CASE(b1[n]) != LO_CASE(b2[n])) break;
- }
- if (n == l2) return (b1 - BIN_HEAD(series));
- }
- b1++;
- }
+ while (b1 != e1) {
+ if (LO_CASE(*b1) == c) { // matched first char
+ for (n = 1; n < l2; n++) {
+ if (LO_CASE(b1[n]) != LO_CASE(b2[n])) break;
+ }
+ if (n == l2) return (b1 - BIN_HEAD(series));
+ }
+ b1++;
+ }
- }
+ }
- return NOT_FOUND;
+ return NOT_FOUND;
}
-/***********************************************************************
-**
-*/ REBCNT Find_Str_Str(REBSER *ser1, REBCNT head, REBCNT index, REBCNT tail, REBINT skip, REBSER *ser2, REBCNT index2, REBCNT len, REBCNT flags)
-/*
-** General purpose find a substring.
-**
-** Supports: forward/reverse with skip, cased/uncase, Unicode/byte.
-**
-** Skip can be set positive or negative (for reverse).
-**
-** Flags are set according to ALL_FIND_REFS
-**
-***********************************************************************/
+//
+// Find_Str_Str: C
+//
+// General purpose find a substring.
+//
+// Supports: forward/reverse with skip, cased/uncase, Unicode/byte.
+//
+// Skip can be set positive or negative (for reverse).
+//
+// Flags are set according to ALL_FIND_REFS
+//
+REBCNT Find_Str_Str(REBSER *ser1, REBCNT head, REBCNT index, REBCNT tail, REBINT skip, REBSER *ser2, REBCNT index2, REBCNT len, REBCNT flags)
{
- REBUNI c1;
- REBUNI c2;
- REBUNI c3;
- REBCNT n = 0;
- REBOOL uncase = !(flags & AM_FIND_CASE); // uncase = case insenstive
-
- c2 = GET_ANY_CHAR(ser2, index2); // starting char
- if (uncase && c2 < UNICODE_CASES) c2 = LO_CASE(c2);
-
- for (; index >= head && index < tail; index += skip) {
-
- c1 = GET_ANY_CHAR(ser1, index);
- if (uncase && c1 < UNICODE_CASES) c1 = LO_CASE(c1);
-
- if (c1 == c2) {
- for (n = 1; n < len; n++) {
- c1 = GET_ANY_CHAR(ser1, index+n);
- c3 = GET_ANY_CHAR(ser2, index2+n);
- if (uncase && c1 < UNICODE_CASES && c3 < UNICODE_CASES) {
- if (LO_CASE(c1) != LO_CASE(c3)) break;
- } else {
- if (c1 != c3) break;
- }
- }
- if (n == len) {
- if (flags & AM_FIND_TAIL) return index + len;
- return index;
- }
- }
- if (flags & AM_FIND_MATCH) break;
- }
-
- return NOT_FOUND;
+ REBUNI c1;
+ REBUNI c2;
+ REBUNI c3;
+ REBCNT n = 0;
+ REBOOL uncase = NOT(flags & AM_FIND_CASE); // case insenstive
+
+ c2 = GET_ANY_CHAR(ser2, index2); // starting char
+ if (uncase && c2 < UNICODE_CASES) c2 = LO_CASE(c2);
+
+ for (; index >= head && index < tail; index += skip) {
+
+ c1 = GET_ANY_CHAR(ser1, index);
+ if (uncase && c1 < UNICODE_CASES) c1 = LO_CASE(c1);
+
+ if (c1 == c2) {
+ for (n = 1; n < len; n++) {
+ c1 = GET_ANY_CHAR(ser1, index+n);
+ c3 = GET_ANY_CHAR(ser2, index2+n);
+ if (uncase && c1 < UNICODE_CASES && c3 < UNICODE_CASES) {
+ if (LO_CASE(c1) != LO_CASE(c3)) break;
+ } else {
+ if (c1 != c3) break;
+ }
+ }
+ if (n == len) {
+ if (flags & AM_FIND_TAIL) return index + len;
+ return index;
+ }
+ }
+ if (flags & AM_FIND_MATCH) break;
+ }
+
+ return NOT_FOUND;
}
-/***********************************************************************
-**
-*/ REBCNT Find_Str_Char(REBSER *ser, REBCNT head, REBCNT index, REBCNT tail, REBINT skip, REBUNI c2, REBCNT flags)
-/*
-** General purpose find a char in a string.
-**
-** Supports: forward/reverse with skip, cased/uncase, Unicode/byte.
-**
-** Skip can be set positive or negative (for reverse).
-**
-** Flags are set according to ALL_FIND_REFS
-**
-***********************************************************************/
-{
- REBUNI c1;
- REBOOL uncase = !GET_FLAG(flags, ARG_FIND_CASE-1); // uncase = case insenstive
-
- if (uncase && c2 < UNICODE_CASES) c2 = LO_CASE(c2);
-
- for (; index >= head && index < tail; index += skip) {
-
- c1 = GET_ANY_CHAR(ser, index);
- if (uncase && c1 < UNICODE_CASES) c1 = LO_CASE(c1);
-
- if (c1 == c2) return index;
-
- if GET_FLAG(flags, ARG_FIND_MATCH-1) break;
- }
-
- return NOT_FOUND;
+#if !defined(NDEBUG)
+
+//
+// Find_Str_Char_Old: C
+//
+// The Find_Str_Char routine turned out to be kind of a bottleneck in code
+// that was heavily reliant on PARSE, so it became slightly interesting to
+// try and optimize it a bit. The old routine is kept around for the
+// moment (and maybe indefinitely) as a debug check to make sure the
+// optimized routine gives back the same answer.
+//
+// Note: the old routine did not handle negative skips correctly, because
+// index is unsigned and it tries to use a comparison crossing zero. This
+// is handled by the new version, and will be vetted separately.
+//
+static REBCNT Find_Str_Char_Old(
+ REBSER *ser,
+ REBCNT head,
+ REBCNT index,
+ REBCNT tail,
+ REBINT skip,
+ REBUNI c2,
+ REBCNT flags
+) {
+ REBOOL uncase = NOT(flags & AM_FIND_CASE); // case insensitive
+
+ if (uncase && c2 < UNICODE_CASES) c2 = LO_CASE(c2);
+
+ for (; index >= head && index < tail; index += skip) {
+ REBUNI c1 = GET_ANY_CHAR(ser, index);
+ if (uncase && c1 < UNICODE_CASES)
+ c1 = LO_CASE(c1);
+
+ if (c1 == c2)
+ return index;
+
+ if (flags & AM_FIND_MATCH)
+ break;
+ }
+
+ return NOT_FOUND;
}
+#endif
-/***********************************************************************
-**
-*/ REBCNT Find_Str_Bitset(REBSER *ser, REBCNT head, REBCNT index, REBCNT tail, REBINT skip, REBSER *bset, REBCNT flags)
-/*
-** General purpose find a bitset char in a string.
-**
-** Supports: forward/reverse with skip, cased/uncase, Unicode/byte.
-**
-** Skip can be set positive or negative (for reverse).
-**
-** Flags are set according to ALL_FIND_REFS
-**
-***********************************************************************/
-{
- REBUNI c1;
- REBOOL uncase = !GET_FLAG(flags, ARG_FIND_CASE-1); // uncase = case insenstive
-
- for (; index >= head && index < tail; index += skip) {
-
- c1 = GET_ANY_CHAR(ser, index);
- //if (uncase && c1 < UNICODE_CASES) {
- // if (Check_Bit(bset, LO_CASE(c1)) || Check_Bit(bset, UP_CASE(c1)))
- // return index;
- //}
- //else
- if (Check_Bit(bset, c1, uncase)) return index;
+//
+// Find_Str_Char: C
+//
+// General purpose find a char in a string, which works with both unicode and
+// byte-sized strings. Supports AM_FIND_CASE for case-sensitivity (as
+// opposed to the case-insensitive default) and AM_FIND_MATCH to check only
+// the character at the current position and then stop.
+//
+// Skip can be set positive or negative (for reverse), and will be bounded
+// by the `start` and `end`.
+//
+// Note that features like "/LAST" are handled at a higher level and
+// translated into SKIP=(-1) and starting at (highest - 1).
+//
+// *This routine is called a lot*, especially in PARSE. So the seeming
+// micro-optimization of it was motivated by that. It's not all that
+// complicated, in truth. For the near-term, the old implementation of the
+// routine is run in parallel as a debug check to ensure the same result
+// is coming from the optimized code.
+//
+REBCNT Find_Str_Char(
+ REBUNI uni, // character to look for
+ REBSER *series, // series with width sizeof(REBYTE) or sizeof(REBUNI)
+ REBCNT lowest, // lowest return index
+ REBCNT index_orig, // first index to examine (if out of range, NOT_FOUND)
+ REBCNT highest, // *one past* highest return result (e.g. SER_LEN)
+ REBINT skip, // step amount while searching, can be negative!
+ REBFLGS flags // AM_FIND_CASE, AM_FIND_MATCH
+) {
+ // Because the skip may be negative, and we don't check before we step
+ // and may "cross zero", it's necessary to use a signed index to be
+ // able to notice that crossing.
+ //
+ REBINT index;
+
+ // We establish an array of two potential cases we are looking for.
+ // If there aren't actually two, this array sets both to be the same (vs.
+ // using something like a '\0' in one cell if they are) because FIND is
+ // able to seek NUL in strings.
+ //
+ REBUNI casings[2];
+
+ if (LOGICAL(flags & AM_FIND_CASE)) { // case-*sensitive*
+ casings[0] = uni;
+ casings[1] = uni;
+ }
+ else {
+ casings[0] = uni < UNICODE_CASES ? LO_CASE(uni) : uni;
+ casings[1] = uni < UNICODE_CASES ? UP_CASE(uni) : uni;
+ }
+
+ assert(lowest <= SER_LEN(series));
+ assert(index_orig <= SER_LEN(series));
+ assert(highest <= SER_LEN(series));
+
+ // !!! Would skip = 0 be a clearer expression of /MATCH, as in "there
+ // is no skip count"? Perhaps in the interface as /SKIP NONE and then
+ // translated to 0 for this internal call?
+ //
+ assert(skip != 0);
+
+ // Rest of routine assumes we are inside of the range to begin with.
+ //
+ if (index_orig < lowest || index_orig >= highest || lowest == highest)
+ goto return_not_found;
+
+ // Past this point we'll be using the signed index.
+ //
+ index = cast(REBINT, index_orig);
+
+ // /MATCH only does one check at the current position for the character
+ // and then returns. It basically subverts any optimization we might
+ // try that uses memory range functions/etc, and if "/skip 0" were the
+ // replacement for match it would have to be handled separately anyway.
+ //
+ if (LOGICAL(flags & AM_FIND_MATCH)) {
+ REBUNI single = GET_ANY_CHAR(series, index_orig);
+ if (single == casings[0] || single == casings[1])
+ goto return_index;
+ goto return_not_found;
+ }
+
+ // If searching a potentially much longer string, take opportunities to
+ // use optimized C library functions if possible.
+ //
+ if (BYTE_SIZE(series)) {
+ REBYTE *bp = BIN_HEAD(series);
+ REBYTE breakset[3];
+
+ // We need to cover when the lowercase or uppercase variant of a
+ // unicode character is <= 0xFF even though the character itself
+ // is not. Build our breakset while we're doing the test. Note
+ // that this handles the case-sensitive version fine because it
+ // will be noticed if breakset[0] and breakset[1] are the same.
+ //
+ if (casings[0] > 0xFF) {
+ if (casings[1] > 0xFF) goto return_not_found;
+
+ breakset[0] = cast(REBYTE, casings[1]);
+ breakset[1] = '\0';
+ }
+ else {
+ breakset[0] = cast(REBYTE, casings[0]);
+
+ if (casings[1] > 0xFF || casings[1] == casings[0]) {
+ breakset[1] = '\0';
+ }
+ else {
+ breakset[1] = cast(REBYTE, casings[1]);
+ breakset[2] = '\0';
+ }
+ }
+
+ // breakset[0] will be '\0' if we're literally searching for a '\0'.
+ // But it will also be '\0' if no candidate we were searching for
+ // would be byte-sized, and hence won't be found...so return NOT_FOUND
+ // if the latter is true.
+ //
+ if (breakset[0] == '\0' && uni != '\0')
+ goto return_not_found;
+
+ if (skip == 1 && breakset[1] == '\0') {
+ //
+ // For case-sensitive comparisons, or if the character has no
+ // distinction in upper and lower cases, or if only one of the
+ // two unicode casings is byte-sized...we can use use the
+ // optimized `memchr()` operation to find the single byte.
+ // This can only work if SKIP is 1.
+ //
+ void *v = memchr(bp + index, breakset[0], highest - index);
+ if (v) {
+ index = cast(REBYTE*, v) - bp;
+ goto return_index;
+ }
+ }
+ else {
+ // If the comparison is case-insensitive and the character has
+ // a distinct upper and lower case, there are two candidate
+ // characters we are looking for.
+ //
+ // We use a threshold to decide if it's worth it to use a library
+ // routine that can only search forward to null terminators vs.
+ // a for loop we can limit, run reverse, or skip by more than 1.
+ // ( routines also can't be used to hunt for a 0 byte.)
+ //
+ if (
+ skip == 1
+ && (SER_LEN(series) - highest) < ((highest - lowest) / 2)
+ && uni != '\0'
+ ) {
+ // The `strcspn()` optimized routine can be used to check for
+ // a set of characters, and returns the number of characters
+ // read before a match was found. It will be the length of
+ // the string if no match.
+ //
+ while (TRUE) {
+ index += strcspn(
+ cast(char*, bp + index), cast(char*, breakset)
+ );
+ if (index >= cast(REBINT, highest))
+ goto return_not_found;
+
+ goto return_index;
+ }
+ }
+ else {
+ // We're skipping by more than one, going in reverse, or
+ // looking for a NULL byte. Can't use any fancy tricks
+ // (besides the trick of precalculating the casings)
+ //
+ while (TRUE) {
+ if (bp[index] == breakset[0] || bp[index] == breakset[1])
+ goto return_index;
+
+ index += skip;
+ if (index < cast(REBINT, lowest)) break;
+ if (index >= cast(REBINT, highest)) break;
+ }
+ }
+ }
+ }
+ else {
+ REBUNI *up = UNI_HEAD(series);
+
+ // Can't actually use wchar_t routines in the general case, because
+ // REBUNI and wchar_t may not be the same size...though on Win32
+ // compilers must guarantee `sizeof(wchar_t) == 2`. But consider
+ // adapting `casings` for a similar optimization to what's being
+ // done for byte-sized strings at some later date, perhaps based
+ // on a check of `sizeof(wchar_t) == sizeof(REBUNI)`.
+ //
+ while (TRUE) {
+ if (up[index] == casings[0] || up[index] == casings[1])
+ goto return_index;
+
+ index += skip;
+ if (index < cast(REBINT, lowest)) break;
+ if (index >= cast(REBINT, highest)) break;
+ }
+ }
+
+return_not_found:
+
+#if !defined(NDEBUG)
+ assert(NOT_FOUND == Find_Str_Char_Old(
+ series, lowest, index_orig, highest, skip, uni, flags
+ ));
+#endif
+ return NOT_FOUND;
- if (flags & AM_FIND_MATCH) break;
- }
-
- return NOT_FOUND;
-}
+return_index:
+#if !defined(NDEBUG)
+ assert(cast(REBCNT, index) == Find_Str_Char_Old(
+ series, lowest, index_orig, highest, skip, uni, flags
+ ));
+#endif
-#ifdef old
-/***********************************************************************
-**
-x*/ REBCNT Match_2_String(REBSER *series, REBCNT index, REBYTE *str, REBCNT len, REBINT uncase)
-/*
-** (Evaluate if there is another function to use. ???!!!)
-**
-** Used for: PARSE function
-**
-***********************************************************************/
-{
- REBYTE *ser = STR_SKIP(series, index);
- REBCNT tail = series->tail;
-
- if (uncase) {
- for (;len > 0 && index < tail; index++, len--) {
- if (*ser++ != *str++) return 0;
- }
- } else {
- for (;len > 0 && index < tail; index++, len--) {
- if (LO_CASE(*ser++) != LO_CASE(*str++)) return 0;
- }
- }
- if (len == 0) return index;
- return 0;
+ assert(index >= 0);
+ return cast(REBCNT, index);
}
-/***********************************************************************
-**
-x*/ REBYTE *Match_Str_Part(REBYTE *str, REBYTE *pat, REBCNT len)
-/*
-** If the string matches the pattern for the given length
-** return the char string just past the match (in str).
-** Else, return 0. A case insensitive compare is made.
-**
-***********************************************************************/
-{
- REBYTE *pp = pat;
- REBYTE *cp = str;
- for (;len > 0 && *pp && *cp; pp++, cp++, len--) {
- if (UP_CASE(*pp) != UP_CASE(*cp)) return 0;
- }
- if (len == 0) return cp;
- return 0;
+//
+// Find_Str_Bitset: C
+//
+// General purpose find a bitset char in a string.
+//
+// Supports: forward/reverse with skip, cased/uncase, Unicode/byte.
+//
+// Skip can be set positive or negative (for reverse).
+//
+// Flags are set according to ALL_FIND_REFS
+//
+REBCNT Find_Str_Bitset(
+ REBSER *ser,
+ REBCNT head,
+ REBCNT index,
+ REBCNT tail,
+ REBINT skip,
+ REBSER *bset,
+ REBCNT flags
+) {
+ REBOOL uncase = NOT(flags & AM_FIND_CASE); // case insensitive
+
+ for (; index >= head && index < tail; index += skip) {
+ REBUNI c1 = GET_ANY_CHAR(ser, index);
+
+ if (Check_Bit(bset, c1, uncase))
+ return index;
+
+ if (flags & AM_FIND_MATCH)
+ break;
+ }
+
+ return NOT_FOUND;
}
-#endif
-/***********************************************************************
-**
-*/ REBCNT Count_Lines(REBYTE *bp, REBCNT len)
-/*
-** Count lines in a UTF-8 file.
-**
-***********************************************************************/
+//
+// Count_Lines: C
+//
+// Count lines in a UTF-8 file.
+//
+REBCNT Count_Lines(REBYTE *bp, REBCNT len)
{
- REBCNT count = 0;
-
- for (; len > 0; bp++, len--) {
- if (*bp == CR) {
- count++;
- if (len == 1) break;
- if (bp[1] == LF) bp++, len--;
- }
- else if (*bp == LF) count++;
- }
-
- return count;
+ REBCNT count = 0;
+
+ for (; len > 0; bp++, len--) {
+ if (*bp == CR) {
+ count++;
+ if (len == 1) break;
+ if (bp[1] == LF) bp++, len--;
+ }
+ else if (*bp == LF) count++;
+ }
+
+ return count;
}
-/***********************************************************************
-**
-*/ REBCNT Next_Line(REBYTE **bin)
-/*
-** Find next line termination. Advance the bp; return bin length.
-**
-***********************************************************************/
+//
+// Next_Line: C
+//
+// Find next line termination. Advance the bp; return bin length.
+//
+REBCNT Next_Line(REBYTE **bin)
{
- REBCNT count = 0;
- REBYTE *bp = *bin;
-
- for (; *bp; bp++) {
- if (*bp == CR) {
- bp++;
- if (*bp == LF) bp++;
- break;
- }
- else if (*bp == LF) {
- bp++;
- break;
- }
- else count++;
- }
-
- *bin = bp;
- return count;
+ REBCNT count = 0;
+ REBYTE *bp = *bin;
+
+ for (; *bp; bp++) {
+ if (*bp == CR) {
+ bp++;
+ if (*bp == LF) bp++;
+ break;
+ }
+ else if (*bp == LF) {
+ bp++;
+ break;
+ }
+ else count++;
+ }
+
+ *bin = bp;
+ return count;
}
diff --git a/src/core/s-make.c b/src/core/s-make.c
index 5368bf3269..1962c69fcf 100644
--- a/src/core/s-make.c
+++ b/src/core/s-make.c
@@ -1,669 +1,657 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: s-make.c
-** Summary: binary and unicode string support
-** Section: strings
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %s-make.c
+// Summary: "binary and unicode string support"
+// Section: strings
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#include "sys-scan.h"
-/***********************************************************************
-**
-*/ REBSER *Make_Binary(REBCNT length)
-/*
-** Make a binary string series. For byte, C, and UTF8 strings.
-** Add 1 extra for terminator.
-**
-***********************************************************************/
+//
+// Make_Binary: C
+//
+// Make a binary string series. For byte, C, and UTF8 strings.
+// Add 1 extra for terminator.
+//
+REBSER *Make_Binary(REBCNT length)
{
- REBSER *series = Make_Series(length + 1, sizeof(REBYTE), FALSE);
- LABEL_SERIES(series, "make binary");
- BIN_DATA(series)[length] = 0;
- return series;
+ REBSER *series = Make_Series(length + 1, sizeof(REBYTE));
+
+ // !!! Clients seem to have different expectations of if `length` is
+ // total capacity (and the binary should be empty) or actually is
+ // specifically being preallocated at a fixed length. Until this
+ // is straightened out, terminate for both possibilities.
+
+ BIN_HEAD(series)[length] = 0;
+ TERM_SEQUENCE(series);
+ return series;
}
-/***********************************************************************
-**
-*/ REBSER *Make_Unicode(REBCNT length)
-/*
-** Make a unicode string series. Used for internal strings.
-** Add 1 extra for terminator.
-**
-***********************************************************************/
+//
+// Make_Unicode: C
+//
+// Make a unicode string series. Used for internal strings.
+// Add 1 extra for terminator.
+//
+REBSER *Make_Unicode(REBCNT length)
{
- REBSER *series = Make_Series(length + 1, sizeof(REBUNI), FALSE);
- LABEL_SERIES(series, "make unicode");
- UNI_HEAD(series)[length] = 0;
- return series;
+ REBSER *series = Make_Series(length + 1, sizeof(REBUNI));
+
+ // !!! Clients seem to have different expectations of if `length` is
+ // total capacity (and the binary should be empty) or actually is
+ // specifically being preallocated at a fixed length. Until this
+ // is straightened out, terminate for both possibilities.
+
+ UNI_HEAD(series)[length] = 0;
+ TERM_SEQUENCE(series);
+ return series;
}
-/***********************************************************************
-**
-*/ REBSER *Copy_Bytes(REBYTE *src, REBINT len)
-/*
-** Create a string series from the given bytes.
-** Source is always latin-1 valid. Result is always 8bit.
-**
-***********************************************************************/
+//
+// Copy_Bytes: C
+//
+// Create a string series from the given bytes.
+// Source is always latin-1 valid. Result is always 8bit.
+//
+REBSER *Copy_Bytes(const REBYTE *src, REBINT len)
{
- REBSER *dst;
+ if (len < 0)
+ len = LEN_BYTES(src);
- if (len < 0) len = LEN_BYTES(src);
+ REBSER *dst = Make_Binary(len);
+ memcpy(BIN_HEAD(dst), src, len);
+ TERM_SEQUENCE_LEN(dst, len);
- dst = Make_Binary(len);
- memcpy(STR_DATA(dst), src, len);
- SERIES_TAIL(dst) = len;
- STR_TERM(dst);
-
- return dst;
+ return dst;
}
-/***********************************************************************
-**
-*/ REBSER *Copy_Bytes_To_Unicode(REBYTE *src, REBINT len)
-/*
-** Convert a byte string to a unicode string. This can
-** be used for ASCII or LATIN-8 strings.
-**
-***********************************************************************/
+//
+// Copy_Bytes_To_Unicode: C
+//
+// Convert a byte string to a unicode string. This can
+// be used for ASCII or LATIN-8 strings.
+//
+REBSER *Copy_Bytes_To_Unicode(REBYTE *src, REBINT len)
{
- REBSER *series;
- REBUNI *dst;
+ REBSER *series = Make_Unicode(len);
+ REBUNI *dst = UNI_HEAD(series);
- series = Make_Unicode(len);
- dst = UNI_HEAD(series);
- SERIES_TAIL(series) = len;
+ for (; len > 0; len--)
+ *dst++ = cast(REBUNI, *src++);
- for (; len > 0; len--) {
- *dst++ = (REBUNI)(*src++);
- }
+ TERM_UNI_LEN(series, len);
+ return series;
+}
- UNI_TERM(series);
- return series;
+//
+// Copy_Wide_Str: C
+//
+// Create a REBOL string series from a wide char string.
+// Minimize to bytes if possible
+//
+REBSER *Copy_Wide_Str(void *src, REBINT len)
+{
+ REBSER *dst;
+ REBUNI *str = (REBUNI*)src;
+ if (Is_Wide(str, len)) {
+ REBUNI *up;
+ dst = Make_Unicode(len);
+ SET_SERIES_LEN(dst, len);
+ up = UNI_HEAD(dst);
+ while (len-- > 0) *up++ = *str++;
+ *up = 0;
+ }
+ else {
+ REBYTE *bp;
+ dst = Make_Binary(len);
+ SET_SERIES_LEN(dst, len);
+ bp = BIN_HEAD(dst);
+ while (len-- > 0) *bp++ = (REBYTE)*str++;
+ *bp = 0;
+ }
+ ASSERT_SERIES_TERM(dst);
+ return dst;
}
-
-/***********************************************************************
-**
-*/ REBSER *Copy_OS_Str(void *src, REBINT len)
-/*
-** Create a REBOL string series from an OS native string.
-**
-** For example, in Win32 with the wide char interface, we must
-** convert wide char strings, minimizing to bytes if possible.
-**
-** For Linux the char string could be UTF-8, so that must be
-** converted to REBOL Unicode or Latin byte strings.
-**
-***********************************************************************/
+//
+// Copy_OS_Str: C
+//
+// Create a REBOL string series from an OS native string.
+//
+// For example, in Win32 with the wide char interface, we must
+// convert wide char strings, minimizing to bytes if possible.
+//
+// For Linux the char string could be UTF-8, so that must be
+// converted to REBOL Unicode or Latin byte strings.
+//
+REBSER *Copy_OS_Str(void *src, REBINT len)
{
#ifdef OS_WIDE_CHAR
- REBSER *dst;
- REBUNI *str = (REBUNI*)src;
- if (Is_Wide(str, len)) {
- REBUNI *up;
- dst = Make_Unicode(len);
- SERIES_TAIL(dst) = len;
- up = UNI_HEAD(dst);
- while (len-- > 0) *up++ = *str++;
- *up = 0;
- }
- else {
- REBYTE *bp;
- dst = Make_Binary(len);
- SERIES_TAIL(dst) = len;
- bp = BIN_HEAD(dst);
- while (len-- > 0) *bp++ = (REBYTE)*str++;
- *bp = 0;
- }
- return dst;
+ return Copy_Wide_Str(src, len);
#else
- return Decode_UTF_String((REBYTE*)src, len, 8);
+ return Decode_UTF_String((REBYTE*)src, len, 8);
#endif
}
-/***********************************************************************
-**
-*/ void Widen_String(REBSER *series)
-/*
-** Widen string from 1 byte to 2 bytes.
-**
-** NOTE: allocates new memory. Cached pointers are invalid.
-**
-***********************************************************************/
+//
+// Insert_Char: C
+//
+// Insert a Char (byte or unicode) into a string.
+//
+void Insert_Char(REBSER *dst, REBCNT index, REBCNT chr)
{
- REBSER *uni = Make_Unicode(STR_LEN(series));
- REBUNI *up;
- REBYTE *bp;
- REBCNT n;
- REBSER tmp;
-
- // !!! optimize the empty case by just modifying series header??
-
- bp = BIN_HEAD(series);
- up = UNI_HEAD(uni);
- for (n = 0; n < STR_LEN(series); n++) up[n] = bp[n];
- SERIES_TAIL(uni) = SERIES_TAIL(series);
-
- // Swap series headers: // !!?? is it valid for all?
- tmp = *series;
- *series = *uni;
- *uni = tmp;
+ if (index > SER_LEN(dst)) index = SER_LEN(dst);
+ if (chr > 0xFF && BYTE_SIZE(dst)) Widen_String(dst, TRUE);
+ Expand_Series(dst, index, 1);
+ SET_ANY_CHAR(dst, index, chr);
}
-/***********************************************************************
-**
-*/ void Insert_Char(REBSER *dst, REBCNT index, REBCNT chr)
-/*
-** Insert a Char (byte or unicode) into a string.
-**
-***********************************************************************/
-{
- if (index > dst->tail) index = dst->tail;
- if (chr > 0xFF && BYTE_SIZE(dst)) Widen_String(dst);
- Expand_Series(dst, index, 1);
- SET_ANY_CHAR(dst, index, chr);
+//
+// Insert_String: C
+//
+// Insert a non-encoded string into a series at given index.
+// Source and/or destination can be 1 or 2 bytes wide.
+// If destination is not wide enough, it will be widened.
+//
+void Insert_String(
+ REBSER *dst,
+ REBCNT idx,
+ REBSER *src,
+ REBCNT pos,
+ REBCNT len,
+ REBOOL no_expand
+) {
+ REBUNI *up;
+ REBYTE *bp;
+ REBCNT n;
+
+ assert(idx <= SER_LEN(dst));
+
+ if (!no_expand) Expand_Series(dst, idx, len); // tail changed too
+
+ // Src and dst have same width (8 or 16):
+ if (SER_WIDE(dst) == SER_WIDE(src)) {
+cp_same:
+ if (BYTE_SIZE(dst))
+ memcpy(BIN_AT(dst, idx), BIN_AT(src, pos), len);
+ else
+ memcpy(UNI_AT(dst, idx), UNI_AT(src, pos), sizeof(REBUNI) * len);
+ return;
+ }
+
+ // Src is 8 and dst is 16:
+ if (!BYTE_SIZE(dst)) {
+ bp = BIN_AT(src, pos);
+ up = UNI_AT(dst, idx);
+ for (n = 0; n < len; n++) up[n] = (REBUNI)bp[n];
+ return;
+ }
+
+ // Src is 16 and dst is 8:
+ bp = BIN_AT(dst, idx);
+ up = UNI_AT(src, pos);
+ for (n = 0; n < len; n++) {
+ if (up[n] > 0xFF) {
+ // Expand dst and restart:
+ idx += n;
+ pos += n;
+ len -= n;
+ Widen_String(dst, TRUE);
+ goto cp_same;
+ }
+ bp[n] = (REBYTE)up[n];
+ }
}
-/***********************************************************************
-**
-*/ void Insert_String(REBSER *dst, REBCNT idx, REBSER *src, REBCNT pos, REBCNT len, REBFLG no_expand)
-/*
-** Insert a non-encoded string into a series at given index.
-** Source and/or destination can be 1 or 2 bytes wide.
-** If destination is not wide enough, it will be widened.
-**
-***********************************************************************/
+//
+// Copy_String_Slimming: C
+//
+// Copies a portion of any string (byte or unicode). If the input is a
+// wide REBUNI string, the range of copied characters will be examined to
+// see if they could fit in a byte-size series. The string will be
+// "slimmed" if possible.
+//
+REBSER *Copy_String_Slimming(REBSER *src, REBCNT index, REBINT length)
{
- REBUNI *up;
- REBYTE *bp;
- REBCNT n;
+ REBYTE wide = 1;
- if (idx > dst->tail) idx = dst->tail;
- if (!no_expand) Expand_Series(dst, idx, len); // tail changed too
+ if (length < 0)
+ length = SER_LEN(src) - index;
- // Src and dst have same width (8 or 16):
- if (SERIES_WIDE(dst) == SERIES_WIDE(src)) {
-cp_same:
- if (BYTE_SIZE(dst))
- memcpy(BIN_SKIP(dst, idx), BIN_SKIP(src, pos), len);
- else
- memcpy(UNI_SKIP(dst, idx), UNI_SKIP(src, pos), sizeof(REBUNI) * len);
- return;
- }
-
- // Src is 8 and dst is 16:
- if (!BYTE_SIZE(dst)) {
- bp = BIN_SKIP(src, pos);
- up = UNI_SKIP(dst, idx);
- for (n = 0; n < len; n++) up[n] = (REBUNI)bp[n];
- return;
- }
-
- // Src is 16 and dst is 8:
- bp = BIN_SKIP(dst, idx);
- up = UNI_SKIP(src, pos);
- for (n = 0; n < len; n++) {
- if (up[n] > 0xFF) {
- //Debug_Num("##Widen-series because char value is:", up[n]);
- // Expand dst and restart:
- idx += n;
- pos += n;
- len -= n;
- Widen_String(dst);
- goto cp_same;
- }
- bp[n] = (REBYTE)up[n];
- }
-}
+ // Can it be slimmed down?
+ if (!BYTE_SIZE(src)) {
+ REBUNI *up = UNI_AT(src, index);
-#ifdef not_used
-/***********************************************************************
-**
-x*/ REBCNT Insert_Value(REBSER *series, REBCNT index, REBVAL *item, REBCNT type, REBFLG only)
-/*
-** A general method to insert a value into a block, string,
-** or binary.
-**
-** Returns: index past the insert.
-**
-***********************************************************************/
-{
- REBCNT len = 1;
-
- if (type >= REB_BLOCK) {
- if (only || !ANY_BLOCK(item))
- Insert_Series(series, index, (void*)item, len);
- else {
- len = VAL_LEN(item);
- Insert_Series(series, index, (void*)VAL_BLK_DATA(item), len);
- }
- }
- else if (type == REB_BINARY) {
- if (IS_BINARY(item)) {
- len = VAL_LEN(item);
- Insert_String(series, index, VAL_SERIES(item), VAL_INDEX(item), len, 0);
- }
- else if (IS_INTEGER(item)) {
- Insert_Char(series, index, (0xff & VAL_INT32(item)));
- }
- else if (IS_CHAR(item)) {
- Insert_Char(series, index, (0xff & VAL_CHAR(item)));
- }
- }
- else { // other strings
- if (ANY_STR(item)) {
- len = VAL_LEN(item);
- Insert_String(series, index, VAL_SERIES(item), VAL_INDEX(item), len, 0);
- }
- else if (IS_CHAR(item)) {
- Insert_Char(series, index, VAL_CHAR(item));
- }
- }
-
- return index + len;
-}
-#endif
+ REBINT n;
+ for (n = 0; n < length; n++)
+ if (up[n] > 0xff)
+ break;
+ if (n < length)
+ wide = sizeof(REBUNI);
+ }
-/***********************************************************************
-**
-*/ REBSER *Copy_String(REBSER *src, REBCNT index, REBINT length)
-/*
-** Copies a portion of any string (byte or unicode).
-** Will slim the string, if needed.
-**
-** The index + length must be in range unsigned int 32.
-**
-***********************************************************************/
-{
- REBUNI *up;
- REBINT wide = 1;
- REBSER *dst;
- REBINT n;
-
- if (length < 0) length = src->tail;
-
- // Can it be slimmed down?
- if (!BYTE_SIZE(src)) {
- up = UNI_SKIP(src, index);
- for (n = 0; n < length; n++)
- if (up[n] > 0xff) break;
- if (n < length) wide = sizeof(REBUNI);
- }
-
- dst = Make_Series(length + 1, wide, FALSE);
- Insert_String(dst, 0, src, index, length, TRUE);
- SERIES_TAIL(dst) = length;
- TERM_SERIES(dst);
-
- return dst;
+ REBSER *dst = Make_Series(length + 1, wide);
+ Insert_String(dst, 0, src, index, length, TRUE);
+ TERM_SEQUENCE_LEN(dst, length);
+
+ return dst;
}
-/***********************************************************************
-**
-*/ REBCHR *Val_Str_To_OS(REBVAL *val)
-/*
-** This is used to pass a REBOL value string to an OS API.
-**
-** The REBOL (input) string can be byte or wide sized.
-** The OS (output) string is in the native OS format.
-** On Windows, its a wide-char, but on Linux, its UTF-8.
-**
-** If we know that the string can be used directly as-is,
-** (because it's in the OS size format), we can used it
-** like that.
-**
-***********************************************************************/
+//
+// Val_Str_To_OS_Managed: C
+//
+// This is used to pass a REBOL value string to an OS API.
+//
+// The REBOL (input) string can be byte or wide sized.
+// The OS (output) string is in the native OS format.
+// On Windows, its a wide-char, but on Linux, its UTF-8.
+//
+// If we know that the string can be used directly as-is,
+// (because it's in the OS size format), we can used it
+// like that.
+//
+// !!! The series is created but just let up to the garbage
+// collector to free. This is a "leaky" approach. You may
+// optionally request to have the series returned if it is
+// important for you to protect it from GC, but you cannot
+// currently get a "freeable" series out of this.
+//
+REBCHR *Val_Str_To_OS_Managed(REBSER **out, REBVAL *val)
{
#ifdef OS_WIDE_CHAR
- if (VAL_BYTE_SIZE(val)) {
- // On windows, we need to convert byte to wide:
- REBINT n = VAL_LEN(val);
- REBSER *up = Make_Unicode(n); // will be GC'd ok
- n = Decode_UTF8(UNI_HEAD(up), VAL_BIN_DATA(val), n, FALSE);
- SERIES_TAIL(up) = abs(n);
- UNI_TERM(up);
- return UNI_HEAD(up);
- }
- else {
- // Already wide, we can use it as-is:
- // !Assumes the OS uses same wide format!
- return VAL_UNI_DATA(val);
- }
+ if (VAL_BYTE_SIZE(val)) {
+ // On windows, we need to convert byte to wide:
+ REBINT n = VAL_LEN_AT(val);
+ REBSER *up = Make_Unicode(n);
+
+ // !!!"Leaks" in the sense that the GC has to take care of this
+ MANAGE_SERIES(up);
+
+ n = Decode_UTF8_Negative_If_Latin1(
+ UNI_HEAD(up),
+ VAL_BIN_AT(val),
+ n,
+ FALSE
+ );
+ TERM_UNI_LEN(up, abs(n));
+
+ if (out) *out = up;
+
+ return cast(REBCHR*, UNI_HEAD(up));
+ }
+ else {
+ // Already wide, we can use it as-is:
+ // !Assumes the OS uses same wide format!
+
+ if (out) *out = VAL_SERIES(val);
+
+ return cast(REBCHR*, VAL_UNI_AT(val));
+ }
#else
- if (VAL_STR_IS_ASCII(val)) {
- // On Linux/Unix we can use ASCII directly (it is valid UTF-8):
- return VAL_BIN_DATA(val);
- }
- else {
- REBINT n = VAL_LEN(val);
- REBSER *ser = Prep_Bin_Str(val, 0, &n);
- // NOTE: may return a shared buffer!
- return BIN_HEAD(ser); // (actually, it's a byte pointer)
- }
+ if (
+ VAL_BYTE_SIZE(val)
+ && All_Bytes_ASCII(VAL_BIN_AT(val), VAL_LEN_AT(val))
+ ) {
+ if (out) *out = VAL_SERIES(val);
+
+ // On Linux/Unix we can use ASCII directly (it is valid UTF-8):
+ return cast(REBCHR*, VAL_BIN_AT(val));
+ }
+ else {
+ // !!! "Leaks" in the sense that the GC has to take care of this
+ REBSER *ser = Temp_Bin_Str_Managed(val, 0, NULL);
+
+ if (out) *out = ser;
+
+ // NOTE: may return a shared buffer!
+ return cast(REBCHR*, BIN_HEAD(ser));
+ }
#endif
}
-/***********************************************************************
-**
-*/ REBSER *Append_Bytes_Len(REBSER *dst, REBYTE *src, REBCNT len)
-/*
-** Optimized function to append a non-encoded byte string.
-**
-** If dst is null, it will be created and returned.
-** Such src strings normally come from C code or tables.
-** Destination can be 1 or 2 bytes wide.
-**
-***********************************************************************/
+//
+// Append_Unencoded_Len: C
+//
+// Optimized function to append a non-encoded byte string.
+//
+// If dst is null, it will be created and returned.
+// Such src strings normally come from C code or tables.
+// Destination can be 1 or 2 bytes wide.
+//
+REBSER *Append_Unencoded_Len(REBSER *dst, const char *src, REBCNT len)
{
- REBUNI *up;
- REBCNT tail;
-
- if (!dst) {
- dst = Make_Binary(len);
- tail = 0;
- } else {
- tail = SERIES_TAIL(dst);
- EXPAND_SERIES_TAIL(dst, len);
- }
-
- if (BYTE_SIZE(dst)) {
- memcpy(STR_SKIP(dst, tail), src, len);
- STR_TERM(dst);
- }
- else {
- up = UNI_SKIP(dst, tail);
- for (; len > 0; len--) *up++ = (REBUNI)*src++;
- *up = 0;
- }
-
- return dst;
+ REBUNI *up;
+ REBCNT tail;
+
+ if (!dst) {
+ dst = Make_Binary(len);
+ tail = 0;
+ } else {
+ tail = SER_LEN(dst);
+ EXPAND_SERIES_TAIL(dst, len);
+ }
+
+ if (BYTE_SIZE(dst)) {
+ memcpy(BIN_AT(dst, tail), src, len);
+ TERM_SEQUENCE(dst);
+ }
+ else {
+ up = UNI_AT(dst, tail);
+ for (; len > 0; len--) *up++ = (REBUNI)*src++;
+ *up = 0;
+ }
+
+ return dst;
}
-/***********************************************************************
-**
-*/ REBSER *Append_Bytes(REBSER *dst, REBYTE *src)
-/*
-** Optimized function to append a non-encoded byte string.
-** If dst is null, it will be created and returned.
-** Such src strings normally come from C code or tables.
-** Destination can be 1 or 2 bytes wide.
-**
-***********************************************************************/
+//
+// Append_Unencoded: C
+//
+// Optimized function to append a non-encoded byte string.
+// If dst is null, it will be created and returned.
+// Such src strings normally come from C code or tables.
+// Destination can be 1 or 2 bytes wide.
+//
+REBSER *Append_Unencoded(REBSER *dst, const char *src)
{
- return Append_Bytes_Len(dst, src, LEN_BYTES(src));
+ return Append_Unencoded_Len(dst, src, strlen(src));
}
-/***********************************************************************
-**
-*/ REBSER *Append_Byte(REBSER *dst, REBCNT chr)
-/*
-** Optimized function to append a non-encoded character.
-** If dst is null, it will be created and returned and the
-** chr will be used to determine the width.
-**
-** Destination can be 1 or 2 bytes wide, but DOES NOT WIDEN.
-**
-***********************************************************************/
+//
+// Append_Codepoint_Raw: C
+//
+// Optimized function to append a non-encoded character.
+// Destination can be 1 or 2 bytes wide, but DOES NOT WIDEN.
+//
+REBSER *Append_Codepoint_Raw(REBSER *dst, REBCNT codepoint)
{
- REBCNT tail;
-
- if (!dst) {
- dst = (chr > 255) ? Make_Unicode(3) : Make_Binary(3);
- tail = 0;
- SERIES_TAIL(dst) = 1;
- } else {
- tail = SERIES_TAIL(dst);
- EXPAND_SERIES_TAIL(dst, 1);
- }
-
- if (BYTE_SIZE(dst)) {
- *STR_SKIP(dst, tail) = (REBYTE)chr;
- STR_TERM(dst);
- }
- else {
- *UNI_SKIP(dst, tail) = (REBUNI)chr;
- UNI_TERM(dst);
- }
-
- return dst;
+ REBCNT tail = SER_LEN(dst);
+
+ EXPAND_SERIES_TAIL(dst, 1);
+
+ if (BYTE_SIZE(dst)) {
+ assert(codepoint < (1 << 8));
+ *BIN_AT(dst, tail) = cast(REBYTE, codepoint);
+ TERM_BIN(dst);
+ }
+ else {
+ assert(codepoint < (1 << 16));
+ *UNI_AT(dst, tail) = cast(REBUNI, codepoint);
+ TERM_UNI(dst);
+ }
+
+ return dst;
}
-/***********************************************************************
-**
-*/ void Append_Uni_Bytes(REBSER *dst, REBUNI *src, REBCNT len)
-/*
-** Append a unicode string to a byte string. OPTIMZED.
-**
-***********************************************************************/
+//
+// Make_Series_Codepoint: C
+//
+// Create a series that holds a single codepoint. If the
+// codepoint will fit into a byte, then it will be a byte
+// series. If two bytes, it will be a REBUNI series.
+//
+// (Codepoints greater than the size of REBUNI are not
+// currently supported in Rebol3.)
+//
+REBSER *Make_Series_Codepoint(REBCNT codepoint)
{
- REBYTE *bp;
- REBCNT tail = SERIES_TAIL(dst);
+ REBSER *out;
- EXPAND_SERIES_TAIL(dst, len);
+ assert(codepoint < (1 << 16));
- bp = BIN_SKIP(dst, tail);
+ out = (codepoint > 255) ? Make_Unicode(1) : Make_Binary(1);
+ TERM_SEQUENCE(out);
- for (; len > 0; len--)
- *bp++ = (REBYTE)*src++;
+ Append_Codepoint_Raw(out, codepoint);
- *bp = 0;
+ return out;
}
-/***********************************************************************
-**
-*/ void Append_Uni_Uni(REBSER *dst, REBUNI *src, REBCNT len)
-/*
-** Append a unicode string to a unicode string. OPTIMZED.
-**
-***********************************************************************/
+//
+// Append_Uni_Bytes: C
+//
+// Append a unicode string to a byte string. OPTIMZED.
+//
+void Append_Uni_Bytes(REBSER *dst, const REBUNI *src, REBCNT len)
{
- REBUNI *up;
- REBCNT tail = SERIES_TAIL(dst);
+ REBCNT old_len = SER_LEN(dst);
- EXPAND_SERIES_TAIL(dst, len);
+ EXPAND_SERIES_TAIL(dst, len);
+ SET_SERIES_LEN(dst, old_len + len);
- up = UNI_SKIP(dst, tail);
+ REBYTE *bp = BIN_AT(dst, old_len);
- for (; len > 0; len--)
- *up++ = *src++;
+ for (; len > 0; len--)
+ *bp++ = cast(REBYTE, *src++);
- *up = 0;
+ *bp = 0;
}
-/***********************************************************************
-**
-*/ void Append_String(REBSER *dst, REBSER *src, REBCNT i, REBCNT len)
-/*
-** Append a byte or unicode string to a unicode string.
-**
-***********************************************************************/
+//
+// Append_Uni_Uni: C
+//
+// Append a unicode string to a unicode string. OPTIMZED.
+//
+void Append_Uni_Uni(REBSER *dst, const REBUNI *src, REBCNT len)
{
- Insert_String(dst, SERIES_TAIL(dst), src, i, len, 0);
-}
+ REBCNT old_len = SER_LEN(dst);
+ EXPAND_SERIES_TAIL(dst, len);
+ SET_SERIES_LEN(dst, old_len + len);
-/***********************************************************************
-**
-*/ void Append_Boot_Str(REBSER *dst, REBINT num)
-/*
-***********************************************************************/
-{
- Append_Bytes(dst, PG_Boot_Strs[num]);
+ REBUNI *up = UNI_AT(dst, old_len);
+
+ for (; len > 0; len--)
+ *up++ = *src++;
+
+ *up = 0;
}
-/***********************************************************************
-**
-*/ void Append_Int(REBSER *dst, REBINT num)
-/*
-** Append an integer string.
-**
-***********************************************************************/
+//
+// Append_String: C
+//
+// Append a byte or unicode string to a unicode string.
+//
+void Append_String(REBSER *dst, REBSER *src, REBCNT i, REBCNT len)
{
- REBYTE buf[32];
-
- Form_Int(buf, num);
- Append_Bytes(dst, buf);
+ Insert_String(dst, SER_LEN(dst), src, i, len, FALSE);
}
-/***********************************************************************
-**
-*/ void Append_Int_Pad(REBSER *dst, REBINT num, REBINT digs)
-/*
-** Append an integer string.
-**
-***********************************************************************/
+//
+// Append_Int: C
+//
+// Append an integer string.
+//
+void Append_Int(REBSER *dst, REBINT num)
{
- REBYTE buf[32];
- if (digs > 0)
- Form_Int_Pad(buf, num, digs, -digs, '0');
- else
- Form_Int_Pad(buf, num, -digs, digs, '0');
+ REBYTE buf[32];
- Append_Bytes(dst, buf);
+ Form_Int(buf, num);
+ Append_Unencoded(dst, s_cast(buf));
}
-
-/***********************************************************************
-**
-*/ REBSER *Append_UTF8(REBSER *dst, REBYTE *src, REBINT len)
-/*
-** Append (or create) decoded UTF8 to a string. OPTIMIZED.
-**
-** Result can be 8 bits (latin-1 optimized) or 16 bits wide.
-**
-** dst = null means make a new string.
-**
-***********************************************************************/
+//
+// Append_Int_Pad: C
+//
+// Append an integer string.
+//
+void Append_Int_Pad(REBSER *dst, REBINT num, REBINT digs)
{
- REBSER *ser = BUF_UTF8; // buffer is Unicode width
-
- if (len < 0) len = LEN_BYTES(src);
+ REBYTE buf[32];
+ if (digs > 0)
+ Form_Int_Pad(buf, num, digs, -digs, '0');
+ else
+ Form_Int_Pad(buf, num, -digs, digs, '0');
- Resize_Series(ser, len+1); // needs at most this much
-
- len = Decode_UTF8(UNI_HEAD(ser), src, len, FALSE);
+ Append_Unencoded(dst, s_cast(buf));
+}
- if (len < 0) {
- len = -len;
- if (!dst) dst = Make_Binary(len);
- if (BYTE_SIZE(dst)) {
- Append_Uni_Bytes(dst, UNI_HEAD(ser), len);
- return dst;
- }
- } else {
- if (!dst) dst = Make_Unicode(len);
- }
- Append_Uni_Uni(dst, UNI_HEAD(ser), len);
- return dst;
+//
+// Append_UTF8_May_Fail: C
+//
+// Append (or create) decoded UTF8 to a string. OPTIMIZED.
+//
+// Result can be 8 bits (latin-1 optimized) or 16 bits wide.
+//
+// dst = null means make a new string.
+//
+REBSER *Append_UTF8_May_Fail(REBSER *dst, const REBYTE *src, REBCNT num_bytes)
+{
+ REBSER *ser = BUF_UTF8; // buffer is Unicode width
+
+ Resize_Series(ser, num_bytes + 1); // needs at most this many unicode chars
+
+ REBINT len = Decode_UTF8_Negative_If_Latin1(
+ UNI_HEAD(ser),
+ src,
+ num_bytes,
+ FALSE
+ );
+
+ if (len < 0) { // All characters being added are Latin1
+ len = -len;
+ if (dst == NULL)
+ dst = Make_Binary(len);
+ if (BYTE_SIZE(dst)) {
+ Append_Uni_Bytes(dst, UNI_HEAD(ser), len);
+ return dst;
+ }
+ }
+ else {
+ if (dst == NULL)
+ dst = Make_Unicode(len);
+ }
+
+ Append_Uni_Uni(dst, UNI_HEAD(ser), len);
+
+ return dst;
}
-/***********************************************************************
-**
-*/ REBSER *Join_Binary(REBVAL *blk)
-/*
-** Join a binary from component values for use in standard
-** actions like make, insert, or append.
-**
-** WARNING: returns BUF_FORM, not a copy!
-**
-***********************************************************************/
+//
+// Join_Binary: C
+//
+// Join a binary from component values for use in standard
+// actions like make, insert, or append.
+// limit: maximum number of values to process
+// limit < 0 means no limit
+//
+// WARNING: returns BYTE_BUF, not a copy!
+//
+REBSER *Join_Binary(const REBVAL *blk, REBINT limit)
{
- REBSER *series = BUF_FORM;
- REBVAL *val;
- REBCNT tail = 0;
- REBCNT len;
- void *bp;
-
- RESET_TAIL(series);
-
- for (val = VAL_BLK_DATA(blk); NOT_END(val); val++) {
- switch (VAL_TYPE(val)) {
-
- case REB_INTEGER:
- if (VAL_INT64(val) > (i64)255 || VAL_INT64(val) < 0) Trap_Range(val);
- EXPAND_SERIES_TAIL(series, 1);
- *BIN_SKIP(series, tail) = (REBYTE)VAL_INT32(val);
- break;
-
- case REB_BINARY:
- len = VAL_LEN(val);
- EXPAND_SERIES_TAIL(series, len);
- memcpy(BIN_SKIP(series, tail), VAL_BIN_DATA(val), len);
- break;
-
- case REB_STRING:
- case REB_FILE:
- case REB_EMAIL:
- case REB_URL:
- case REB_TAG:
- len = VAL_LEN(val);
- bp = VAL_BYTE_SIZE(val) ? VAL_BIN_DATA(val) : (REBYTE*)VAL_UNI_DATA(val);
- len = Length_As_UTF8(bp, len, (REBOOL)!VAL_BYTE_SIZE(val), 0);
- EXPAND_SERIES_TAIL(series, len);
- Encode_UTF8(BIN_SKIP(series, tail), len, bp, &len, !VAL_BYTE_SIZE(val), 0);
- series->tail = tail + len;
- break;
-
- case REB_CHAR:
- EXPAND_SERIES_TAIL(series, 6);
- len = Encode_UTF8_Char(BIN_SKIP(series, tail), VAL_CHAR(val));
- series->tail = tail + len;
- break;
-
- default:
- Trap_Arg(val);
- }
-
- tail = series->tail;
- }
-
- SET_STR_END(series, tail);
-
- return series; // SHARED FORM SERIES!
+ REBSER *series = BYTE_BUF;
+
+ REBCNT tail = 0;
+
+ if (limit < 0)
+ limit = VAL_LEN_AT(blk);
+
+ SET_SERIES_LEN(series, 0);
+
+ RELVAL *val;
+ for (val = VAL_ARRAY_AT(blk); limit > 0; val++, limit--) {
+ switch (VAL_TYPE(val)) {
+ case REB_INTEGER:
+ if (VAL_INT64(val) > cast(i64, 255) || VAL_INT64(val) < 0)
+ fail (Error_Out_Of_Range(KNOWN(val)));
+ EXPAND_SERIES_TAIL(series, 1);
+ *BIN_AT(series, tail) = (REBYTE)VAL_INT32(val);
+ break;
+
+ case REB_BINARY: {
+ REBCNT len = VAL_LEN_AT(val);
+ EXPAND_SERIES_TAIL(series, len);
+ memcpy(BIN_AT(series, tail), VAL_BIN_AT(val), len);
+ break; }
+
+ case REB_STRING:
+ case REB_FILE:
+ case REB_EMAIL:
+ case REB_URL:
+ case REB_TAG: {
+ REBCNT len = VAL_LEN_AT(val);
+
+ void *bp = VAL_BYTE_SIZE(val)
+ ? VAL_BIN_AT(val)
+ : (REBYTE*)VAL_UNI_AT(val);
+
+ REBCNT bl = Length_As_UTF8(
+ bp, len, VAL_BYTE_SIZE(val) ? 0 : OPT_ENC_UNISRC
+ );
+
+ EXPAND_SERIES_TAIL(series, bl);
+ SET_SERIES_LEN(
+ series,
+ tail + Encode_UTF8(
+ BIN_AT(series, tail),
+ bl,
+ bp,
+ &len,
+ VAL_BYTE_SIZE(val) ? 0 : OPT_ENC_UNISRC
+ )
+ );
+ break; }
+
+ case REB_CHAR: {
+ EXPAND_SERIES_TAIL(series, 6);
+ REBCNT len =
+ Encode_UTF8_Char(BIN_AT(series, tail), VAL_CHAR(val));
+ SET_SERIES_LEN(series, tail + len);
+ break; }
+
+ default:
+ fail (Error_Invalid_Arg_Core(val, VAL_SPECIFIER(blk)));
+ }
+
+ tail = SER_LEN(series);
+ }
+
+ *BIN_AT(series, tail) = 0;
+
+ return series; // SHARED FORM SERIES!
}
diff --git a/src/core/s-mold.c b/src/core/s-mold.c
old mode 100644
new mode 100755
index 4be4c60155..17a8685021
--- a/src/core/s-mold.c
+++ b/src/core/s-mold.c
@@ -1,40 +1,38 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: s-mold.c
-** Summary: value to string conversion
-** Section: strings
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-
-//#define INCLUDE_TYPE_NAMES // include the value names table
+//
+// File: %s-mold.c
+// Summary: "value to string conversion"
+// Section: strings
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+
+//#define INCLUDE_TYPE_NAMES // include the value names table
#include "sys-core.h"
-#include "sys-scan.h"
#include
-#define STOID static void
-
-#define MAX_QUOTED_STR 50 // max length of "string" before going to { }
+#define MAX_QUOTED_STR 50 // max length of "string" before going to { }
//typedef REBSER *(*MOLD_FUNC)(REBVAL *, REBSER *, REBCNT);
typedef void (*MOLD_FUNC)(REBVAL *, REB_MOLD *);
@@ -43,11 +41,11 @@ typedef void (*MOLD_FUNC)(REBVAL *, REB_MOLD *);
const REBYTE Punctuation[] = ".,-/";
enum REB_Punct {
- PUNCT_DOT = 0, // Must be 0
- PUNCT_COMMA, // Must be 1
- PUNCT_DASH,
- PUNCT_SLASH,
- PUNCT_MAX
+ PUNCT_DOT = 0, // Must be 0
+ PUNCT_COMMA, // Must be 1
+ PUNCT_DASH,
+ PUNCT_SLASH,
+ PUNCT_MAX
};
REBYTE *Char_Escapes;
@@ -60,1381 +58,1876 @@ REBYTE *URL_Escapes;
#define IS_FILE_ESC(c) ((c) <= MAX_URL_CHAR && (URL_Escapes[c] & ESC_FILE))
enum {
- ESC_URL = 1,
- ESC_FILE = 2,
- ESC_EMAIL = 4,
+ ESC_URL = 1,
+ ESC_FILE = 2,
+ ESC_EMAIL = 4
};
/***********************************************************************
************************************************************************
**
-** SECTION: Global Mold Utilities
+** SECTION: Global Mold Utilities
**
************************************************************************
***********************************************************************/
-/***********************************************************************
-**
-*/ REBSER *Emit(REB_MOLD *mold, REBYTE *fmt, ...)
-/*
-***********************************************************************/
+//
+// Emit: C
+//
+REBSER *Emit(REB_MOLD *mold, const char *fmt, ...)
{
- va_list args;
- REBYTE ender = 0;
- REBSER *series = mold->series;
-
- ASSERT2(SERIES_WIDE(series) ==2, 9997);
-
- va_start(args, fmt);
-
- for (; *fmt; fmt++) {
- switch (*fmt) {
- case 'W': // Word symbol
- Append_UTF8(series, Get_Word_Name(va_arg(args, REBVAL*)), -1);
- break;
- case 'V': // Value
- Mold_Value(mold, va_arg(args, REBVAL*), TRUE);
- break;
- case 'S': // String of bytes
- Append_Bytes(series, va_arg(args, REBYTE*));
- break;
- case 'C': // Char
- Append_Byte(series, va_arg(args, REBCNT));
- break;
- case 'E': // Series (byte or uni)
- {
- REBSER *src = va_arg(args, REBSER*);
- Insert_String(series, SERIES_TAIL(series), src, 0, SERIES_TAIL(src), 0);
- }
- break;
- case 'I': // Integer
- Append_Int(series, va_arg(args, REBINT));
- break;
- case 'i':
- Append_Int_Pad(series, va_arg(args, REBINT), -9);
- Trim_Tail(mold->series, '0');
- break;
- case '2': // 2 digit int (for time)
- Append_Int_Pad(series, va_arg(args, REBINT), 2);
- break;
- case 'T': // Type name
- Append_UTF8(series, Get_Type_Name(va_arg(args, REBVAL*)), -1);
- break;
- case 'N': // Symbol name
- Append_UTF8(series, Get_Sym_Name(va_arg(args, REBCNT)), -1);
- break;
- case '+': // Add #[ if mold/all
- if (GET_MOPT(mold, MOPT_MOLD_ALL)) {
- Append_Bytes(series, "#[");
- ender = ']';
- }
- break;
- case 'D': // Datatype symbol: #[type
- if (ender) {
- Append_UTF8(series, Get_Sym_Name(va_arg(args, REBCNT)), -1);
- Append_Byte(series, ' ');
- } else va_arg(args, REBCNT); // ignore it
- break;
- case 'B': // Boot string
- Append_Boot_Str(series, va_arg(args, REBINT));
- break;
- default:
- Append_Byte(series, *fmt);
- }
- }
- va_end(args);
-
- if (ender) Append_Byte(series, ender);
-
- return series;
+ va_list va;
+ REBYTE ender = 0;
+ REBSER *series = mold->series;
+
+ assert(SER_WIDE(series) == 2);
+
+ va_start(va, fmt);
+
+ for (; *fmt; fmt++) {
+ switch (*fmt) {
+ case 'W': { // Word symbol
+ const REBVAL *any_word = va_arg(va, const REBVAL*);
+ REBSTR *spelling = VAL_WORD_SPELLING(any_word);
+ Append_UTF8_May_Fail(
+ series, STR_HEAD(spelling), STR_NUM_BYTES(spelling)
+ );
+ break;
+ }
+
+ case 'V': // Value
+ Mold_Value(mold, va_arg(va, const REBVAL*), TRUE);
+ break;
+ case 'S': // String of bytes
+ Append_Unencoded(series, va_arg(va, const char *));
+ break;
+ case 'C': // Char
+ Append_Codepoint_Raw(series, va_arg(va, REBCNT));
+ break;
+ case 'E': { // Series (byte or uni)
+ REBSER *src = va_arg(va, REBSER*);
+ Insert_String(
+ series, SER_LEN(series), src, 0, SER_LEN(src), FALSE
+ );
+ break;
+ }
+ case 'I': // Integer
+ Append_Int(series, va_arg(va, REBINT));
+ break;
+ case 'i':
+ Append_Int_Pad(series, va_arg(va, REBINT), -9);
+ Trim_Tail(mold->series, '0');
+ break;
+ case '2': // 2 digit int (for time)
+ Append_Int_Pad(series, va_arg(va, REBINT), 2);
+ break;
+ case 'T': { // Type name
+ const REBYTE *bytes = Get_Type_Name(va_arg(va, REBVAL*));
+ Append_UTF8_May_Fail(series, bytes, LEN_BYTES(bytes));
+ break; }
+ case 'N': { // Symbol name
+ REBSTR *spelling = va_arg(va, REBSTR*);
+ Append_UTF8_May_Fail(
+ series, STR_HEAD(spelling), STR_NUM_BYTES(spelling)
+ );
+ break; }
+ case '+': // Add #[ if mold/all
+ if (GET_MOPT(mold, MOPT_MOLD_ALL)) {
+ Append_Unencoded(series, "#[");
+ ender = ']';
+ }
+ break;
+ case 'D': // Datatype symbol: #[type
+ if (ender) {
+ REBSTR *canon = Canon(cast(REBSYM, va_arg(va, int)));
+ Append_UTF8_May_Fail(
+ series, STR_HEAD(canon), STR_NUM_BYTES(canon)
+ );
+ Append_Codepoint_Raw(series, ' ');
+ }
+ else
+ va_arg(va, REBCNT); // ignore it
+ break;
+ default:
+ Append_Codepoint_Raw(series, *fmt);
+ }
+ }
+ va_end(va);
+
+ if (ender) Append_Codepoint_Raw(series, ender);
+
+ return series;
}
-/***********************************************************************
-**
-*/ REBSER *Prep_String(REBSER *series, REBYTE **str, REBCNT len)
-/*
-** Helper function for the string related Mold functions below.
-** Creates or expands the series and provides the location to
-** copy text into.
-**
-***********************************************************************/
+//
+// Prep_String: C
+//
+// Helper function for the string related Mold functions below.
+// Creates or expands the series and provides the location to
+// copy text into.
+//
+REBSER *Prep_String(REBSER *series, REBYTE **str, REBCNT len)
{
- REBCNT tail;
-
- if (!series) {
- series = Make_Binary(len);
- series->tail = len;
- *str = STR_HEAD(series);
- }
- else {
- tail = SERIES_TAIL(series);
- EXPAND_SERIES_TAIL(series, len);
- *str = STR_SKIP(series, tail);
- }
- return series;
+ REBCNT tail;
+
+ if (!series) {
+ series = Make_Binary(len);
+ SET_SERIES_LEN(series, len);
+ *str = BIN_HEAD(series);
+ }
+ else {
+ // This used "STR_AT" (obsolete) but didn't have an explicit case
+ // here that it was byte sized. Check it, because if you have
+ // unicode characters this would give the wrong pointer.
+ //
+ assert(BYTE_SIZE(series));
+
+ tail = SER_LEN(series);
+ EXPAND_SERIES_TAIL(series, len);
+ *str = BIN_AT(series, tail);
+ }
+ return series;
}
-/***********************************************************************
-**
-*/ REBUNI *Prep_Uni_Series(REB_MOLD *mold, REBCNT len)
-/*
-***********************************************************************/
+//
+// Prep_Uni_Series: C
+//
+REBUNI *Prep_Uni_Series(REB_MOLD *mold, REBCNT len)
{
- REBCNT tail = SERIES_TAIL(mold->series);
+ REBCNT tail = SER_LEN(mold->series);
- EXPAND_SERIES_TAIL(mold->series, len);
+ EXPAND_SERIES_TAIL(mold->series, len);
- return UNI_SKIP(mold->series, tail);
+ return UNI_AT(mold->series, tail);
}
/***********************************************************************
************************************************************************
**
-** SECTION: Local MOLD Utilities
+** SECTION: Local MOLD Utilities
**
************************************************************************
***********************************************************************/
-/***********************************************************************
-**
-*/ void Pre_Mold(REBVAL *value, REB_MOLD *mold)
-/*
-** Emit the initial datatype function, depending on /ALL option
-**
-***********************************************************************/
+//
+// Pre_Mold: C
+//
+// Emit the initial datatype function, depending on /ALL option
+//
+void Pre_Mold(const RELVAL *value, REB_MOLD *mold)
{
- Emit(mold, GET_MOPT(mold, MOPT_MOLD_ALL) ? "#[T " : "make T ", value);
+ Emit(mold, GET_MOPT(mold, MOPT_MOLD_ALL) ? "#[T " : "make T ", value);
}
-/***********************************************************************
-**
-*/ void End_Mold(REB_MOLD *mold)
-/*
-** Finish the mold, depending on /ALL with close block.
-**
-***********************************************************************/
+//
+// End_Mold: C
+//
+// Finish the mold, depending on /ALL with close block.
+//
+void End_Mold(REB_MOLD *mold)
{
- if (GET_MOPT(mold, MOPT_MOLD_ALL)) Append_Byte(mold->series, ']');
+ if (GET_MOPT(mold, MOPT_MOLD_ALL)) Append_Codepoint_Raw(mold->series, ']');
}
-/***********************************************************************
-**
-*/ void Post_Mold(REBVAL *value, REB_MOLD *mold)
-/*
-** For series that has an index, add the index for mold/all.
-** Add closing block.
-**
-***********************************************************************/
+//
+// Post_Mold: C
+//
+// For series that has an index, add the index for mold/all.
+// Add closing block.
+//
+void Post_Mold(const RELVAL *value, REB_MOLD *mold)
{
- if (VAL_INDEX(value)) {
- Append_Byte(mold->series, ' ');
- Append_Int(mold->series, VAL_INDEX(value)+1);
- }
- if (GET_MOPT(mold, MOPT_MOLD_ALL)) Append_Byte(mold->series, ']');
+ if (VAL_INDEX(value)) {
+ Append_Codepoint_Raw(mold->series, ' ');
+ Append_Int(mold->series, VAL_INDEX(value)+1);
+ }
+ if (GET_MOPT(mold, MOPT_MOLD_ALL)) Append_Codepoint_Raw(mold->series, ']');
}
-/***********************************************************************
-**
-*/ void New_Indented_Line(REB_MOLD *mold)
-/*
-** Create a newline with auto-indent on next line if needed.
-**
-***********************************************************************/
+//
+// New_Indented_Line: C
+//
+// Create a newline with auto-indent on next line if needed.
+//
+void New_Indented_Line(REB_MOLD *mold)
{
- REBINT n;
- REBUNI *cp = 0;
-
- // Check output string has content already but no terminator:
- if (mold->series->tail) {
- cp = UNI_LAST(mold->series);
- if (*cp == ' ' || *cp == '\t') *cp = '\n';
- else cp = 0;
- }
-
- // Add terminator:
- if (!cp) Append_Byte(mold->series, '\n');
-
- // Add proper indentation:
- if (!GET_MOPT(mold, MOPT_INDENT)) {
- for (n = 0; n < mold->indent; n++)
- Append_Bytes(mold->series, " ");
- }
+ REBINT n;
+ REBUNI *cp = 0;
+
+ // Check output string has content already but no terminator:
+ if (SER_LEN(mold->series)) {
+ cp = UNI_LAST(mold->series);
+ if (*cp == ' ' || *cp == '\t') *cp = '\n';
+ else cp = 0;
+ }
+
+ // Add terminator:
+ if (!cp) Append_Codepoint_Raw(mold->series, '\n');
+
+ // Add proper indentation:
+ if (!GET_MOPT(mold, MOPT_INDENT)) {
+ for (n = 0; n < mold->indent; n++)
+ Append_Unencoded(mold->series, " ");
+ }
}
/***********************************************************************
************************************************************************
**
-** SECTION: Char/String Datatypes
+** SECTION: Char/String Datatypes
**
************************************************************************
***********************************************************************/
typedef struct REB_Str_Flags {
- REBCNT escape; // escaped chars
- REBCNT brace_in; // {
- REBCNT brace_out; // }
- REBCNT newline; // lf
- REBCNT quote; // "
- REBCNT paren; // (1234)
- REBCNT chr1e;
- REBCNT malign;
+ REBCNT escape; // escaped chars
+ REBCNT brace_in; // {
+ REBCNT brace_out; // }
+ REBCNT newline; // lf
+ REBCNT quote; // "
+ REBCNT paren; // (1234)
+ REBCNT chr1e;
+ REBCNT malign;
} REB_STRF;
-STOID Sniff_String(REBSER *ser, REBCNT idx, REB_STRF *sf)
+static void Sniff_String(REBSER *ser, REBCNT idx, REB_STRF *sf)
{
- // Scan to find out what special chars the string contains?
- REBYTE *bp = STR_HEAD(ser);
- REBUNI *up = (REBUNI*)bp;
- REBUNI c;
- REBCNT n;
-
- for (n = idx; n < SERIES_TAIL(ser); n++) {
- c = (BYTE_SIZE(ser)) ? (REBUNI)(bp[n]) : up[n];
- switch (c) {
- case '{':
- sf->brace_in++;
- break;
- case '}':
- sf->brace_out++;
- if (sf->brace_out > sf->brace_in) sf->malign++;
- break;
- case '"':
- sf->quote++;
- break;
- case '\n':
- sf->newline++;
- break;
- default:
- if (c == 0x1e) sf->chr1e += 4; // special case of ^(1e)
- else if (IS_CHR_ESC(c)) sf->escape++;
- else if (c >= 0x1000) sf->paren += 6; // ^(1234)
- else if (c >= 0x100) sf->paren += 5; // ^(123)
- else if (c >= 0x80) sf->paren += 4; // ^(12)
- }
- }
- if (sf->brace_in != sf->brace_out) sf->malign++;
+ // Scan to find out what special chars the string contains?
+ REBYTE *bp = SER_DATA_RAW(ser);
+ REBUNI *up = cast(REBUNI*, bp);
+ REBUNI c;
+ REBCNT n;
+
+ for (n = idx; n < SER_LEN(ser); n++) {
+ c = BYTE_SIZE(ser) ? cast(REBUNI, bp[n]) : up[n];
+ switch (c) {
+ case '{':
+ sf->brace_in++;
+ break;
+ case '}':
+ sf->brace_out++;
+ if (sf->brace_out > sf->brace_in) sf->malign++;
+ break;
+ case '"':
+ sf->quote++;
+ break;
+ case '\n':
+ sf->newline++;
+ break;
+ default:
+ if (c == 0x1e) sf->chr1e += 4; // special case of ^(1e)
+ else if (IS_CHR_ESC(c)) sf->escape++;
+ else if (c >= 0x1000) sf->paren += 6; // ^(1234)
+ else if (c >= 0x100) sf->paren += 5; // ^(123)
+ else if (c >= 0x80) sf->paren += 4; // ^(12)
+ }
+ }
+ if (sf->brace_in != sf->brace_out) sf->malign++;
}
static REBUNI *Emit_Uni_Char(REBUNI *up, REBUNI chr, REBOOL parened)
{
- if (chr >= 0x7f || chr == 0x1e) { // non ASCII or ^ must be (00) escaped
- if (parened || chr == 0x1e) { // do not AND with above
- *up++ = '^';
- *up++ = '(';
- up = Form_Uni_Hex(up, chr);
- *up++ = ')';
- return up;
- }
- }
- else if (IS_CHR_ESC(chr)) {
- *up++ = '^';
- *up++ = Char_Escapes[chr];
- return up;
- }
-
- *up++ = chr;
- return up;
+ if (chr >= 0x7f || chr == 0x1e) { // non ASCII or ^ must be (00) escaped
+ if (parened || chr == 0x1e) { // do not AND with above
+ *up++ = '^';
+ *up++ = '(';
+ up = Form_Uni_Hex(up, chr);
+ *up++ = ')';
+ return up;
+ }
+ }
+ else if (IS_CHR_ESC(chr)) {
+ *up++ = '^';
+ *up++ = Char_Escapes[chr];
+ return up;
+ }
+
+ *up++ = chr;
+ return up;
}
-STOID Mold_Uni_Char(REBSER *dst, REBUNI chr, REBOOL molded, REBOOL parened)
+static void Mold_Uni_Char(REBSER *dst, REBUNI chr, REBOOL molded, REBOOL parened)
{
- REBCNT tail = SERIES_TAIL(dst);
- REBUNI *up;
-
- if (!molded) {
- EXPAND_SERIES_TAIL(dst, 1);
- *UNI_SKIP(dst, tail) = chr;
- }
- else {
- EXPAND_SERIES_TAIL(dst, 10); // worst case: #"^(1234)"
- up = UNI_SKIP(dst, tail);
- *up++ = '#';
- *up++ = '"';
- up = Emit_Uni_Char(up, chr, parened);
- *up++ = '"';
- dst->tail = up - UNI_HEAD(dst);
- }
- UNI_TERM(dst);
+ REBCNT tail = SER_LEN(dst);
+
+ if (!molded) {
+ EXPAND_SERIES_TAIL(dst, 1);
+ *UNI_AT(dst, tail) = chr;
+ }
+ else {
+ EXPAND_SERIES_TAIL(dst, 10); // worst case: #"^(1234)"
+
+ REBUNI *up = UNI_AT(dst, tail);
+ *up++ = '#';
+ *up++ = '"';
+ up = Emit_Uni_Char(up, chr, parened);
+ *up++ = '"';
+
+ SET_SERIES_LEN(dst, up - UNI_HEAD(dst));
+ }
+ TERM_UNI(dst);
}
-STOID Mold_String_Series(REBVAL *value, REB_MOLD *mold)
+static void Mold_String_Series(const REBVAL *value, REB_MOLD *mold)
{
- REBCNT len = VAL_LEN(value);
- REBSER *ser = VAL_SERIES(value);
- REBCNT idx = VAL_INDEX(value);
- REB_STRF sf = {0};
- REBYTE *bp;
- REBUNI *up;
- REBUNI *dp;
- REBOOL uni = !BYTE_SIZE(ser);
- REBCNT n;
- REBUNI c;
-
- // Empty string:
- if (idx >= VAL_TAIL(value)) {
- Append_Bytes(mold->series, "\"\""); //Trap0(RE_PAST_END);
- return;
- }
-
- Sniff_String(ser, idx, &sf);
- if (!GET_MOPT(mold, MOPT_ANSI_ONLY)) sf.paren = 0;
-
- // Source can be 8 or 16 bits:
- if (uni) up = UNI_HEAD(ser);
- else bp = STR_HEAD(ser);
-
- // If it is a short quoted string, emit it as "string":
- if (len <= MAX_QUOTED_STR && sf.quote == 0 && sf.newline < 3) {
-
- dp = Prep_Uni_Series(mold, len + sf.newline + sf.escape + sf.paren + sf.chr1e + 2);
-
- *dp++ = '"';
-
- for (n = idx; n < VAL_TAIL(value); n++) {
- c = uni ? up[n] : (REBUNI)(bp[n]);
- dp = Emit_Uni_Char(dp, c, (REBOOL)GET_MOPT(mold, MOPT_ANSI_ONLY)); // parened
- }
-
- *dp++ = '"';
- *dp = 0;
- return;
- }
-
- // It is a braced string, emit it as {string}:
- if (!sf.malign) sf.brace_in = sf.brace_out = 0;
-
- dp = Prep_Uni_Series(mold, len + sf.brace_in + sf.brace_out + sf.escape + sf.paren + sf.chr1e + 2);
-
- *dp++ = '{';
-
- for (n = idx; n < VAL_TAIL(value); n++) {
-
- c = uni ? up[n] : (REBUNI)(bp[n]);
- switch (c) {
- case '{':
- case '}':
- if (sf.malign) {
- *dp++ = '^';
- *dp++ = c;
- break;
- }
- case '\n':
- case '"':
- *dp++ = c;
- break;
- default:
- dp = Emit_Uni_Char(dp, c, (REBOOL)GET_MOPT(mold, MOPT_ANSI_ONLY)); // parened
- }
- }
-
- *dp++ = '}';
- *dp = 0;
+ REBCNT len = VAL_LEN_AT(value);
+ REBSER *ser = VAL_SERIES(value);
+ REBCNT idx = VAL_INDEX(value);
+ REBYTE *bp;
+ REBUNI *up;
+ REBUNI *dp;
+ REBOOL unicode = NOT(BYTE_SIZE(ser));
+ REBCNT n;
+ REBUNI c;
+
+ REB_STRF sf;
+ CLEARS(&sf);
+
+ // Empty string:
+ if (idx >= VAL_LEN_HEAD(value)) {
+ // !!! Comment said `fail (Error_Past_End_Raw());`
+ Append_Unencoded(mold->series, "\"\"");
+ return;
+ }
+
+ Sniff_String(ser, idx, &sf);
+ if (!GET_MOPT(mold, MOPT_NON_ANSI_PARENED)) sf.paren = 0;
+
+ // Source can be 8 or 16 bits:
+ if (unicode) {
+ up = UNI_HEAD(ser);
+ bp = NULL; // wasteful, but avoids may be used uninitialized warning
+ }
+ else {
+ up = NULL; // wasteful, but avoids may be used uninitialized warning
+ bp = BIN_HEAD(ser);
+ }
+
+ // If it is a short quoted string, emit it as "string":
+ if (len <= MAX_QUOTED_STR && sf.quote == 0 && sf.newline < 3) {
+
+ dp = Prep_Uni_Series(mold, len + sf.newline + sf.escape + sf.paren + sf.chr1e + 2);
+
+ *dp++ = '"';
+
+ for (n = idx; n < VAL_LEN_HEAD(value); n++) {
+ c = unicode ? up[n] : cast(REBUNI, bp[n]);
+ dp = Emit_Uni_Char(dp, c, GET_MOPT(mold, MOPT_NON_ANSI_PARENED));
+ }
+
+ *dp++ = '"';
+ *dp = 0;
+ return;
+ }
+
+ // It is a braced string, emit it as {string}:
+ if (!sf.malign) sf.brace_in = sf.brace_out = 0;
+
+ dp = Prep_Uni_Series(mold, len + sf.brace_in + sf.brace_out + sf.escape + sf.paren + sf.chr1e + 2);
+
+ *dp++ = '{';
+
+ for (n = idx; n < VAL_LEN_HEAD(value); n++) {
+
+ c = unicode ? up[n] : cast(REBUNI, bp[n]);
+
+ switch (c) {
+ case '{':
+ case '}':
+ if (sf.malign) {
+ *dp++ = '^';
+ *dp++ = c;
+ break;
+ }
+ // falls through
+ case '\n':
+ case '"':
+ *dp++ = c;
+ break;
+ default:
+ dp = Emit_Uni_Char(dp, c, GET_MOPT(mold, MOPT_NON_ANSI_PARENED));
+ }
+ }
+
+ *dp++ = '}';
+ *dp = 0;
}
-#ifdef not_used
-STOID Mold_Issue(REBVAL *value, REB_MOLD *mold)
-{
- REBUNI *dp;
- REBCNT n;
- REBUNI c;
- REBSER *ser = VAL_SERIES(value);
-
- dp = Prep_Uni_Series(mold, VAL_LEN(value)+1); // '#' extra
-
- *dp++ = '#';
-
- for (n = VAL_INDEX(value); n < VAL_TAIL(value); n++) {
- c = GET_ANY_CHAR(ser, n);
- if (IS_LEX_DELIMIT(c)) c = '?';
- *dp++ = c;
- }
-
- *dp = 0;
-}
-#endif
/*
- http://www.blooberry.com/indexdot/html/topics/urlencoding.htm
+ http://www.blooberry.com/indexdot/html/topics/urlencoding.htm
- Only alphanumerics [0-9a-zA-Z], the special characters $-_.+!*'(),
- and reserved characters used for their reserved purposes may be used
- unencoded within a URL.
+ Only alphanumerics [0-9a-zA-Z], the special characters $-_.+!*'(),
+ and reserved characters used for their reserved purposes may be used
+ unencoded within a URL.
*/
-STOID Mold_Url(REBVAL *value, REB_MOLD *mold)
+static void Mold_Url(const REBVAL *value, REB_MOLD *mold)
{
- REBUNI *dp;
- REBCNT n;
- REBUNI c;
- REBCNT len = VAL_LEN(value);
- REBSER *ser = VAL_SERIES(value);
-
- // Compute extra space needed for hex encoded characters:
- for (n = VAL_INDEX(value); n < VAL_TAIL(value); n++) {
- c = GET_ANY_CHAR(ser, n);
- if (IS_URL_ESC(c)) len += 2;
- }
-
- dp = Prep_Uni_Series(mold, len);
-
- for (n = VAL_INDEX(value); n < VAL_TAIL(value); n++) {
- c = GET_ANY_CHAR(ser, n);
- if (IS_URL_ESC(c)) dp = Form_Hex_Esc_Uni(dp, c); // c => %xx
- else *dp++ = c;
- }
-
- *dp = 0;
+ REBUNI *dp;
+ REBCNT n;
+ REBUNI c;
+ REBCNT len = VAL_LEN_AT(value);
+ REBSER *ser = VAL_SERIES(value);
+
+ // Compute extra space needed for hex encoded characters:
+ for (n = VAL_INDEX(value); n < VAL_LEN_HEAD(value); n++) {
+ c = GET_ANY_CHAR(ser, n);
+ if (IS_URL_ESC(c)) len += 2;
+ }
+
+ dp = Prep_Uni_Series(mold, len);
+
+ for (n = VAL_INDEX(value); n < VAL_LEN_HEAD(value); n++) {
+ c = GET_ANY_CHAR(ser, n);
+ if (IS_URL_ESC(c)) dp = Form_Hex_Esc_Uni(dp, c); // c => %xx
+ else *dp++ = c;
+ }
+
+ *dp = 0;
}
-STOID Mold_File(REBVAL *value, REB_MOLD *mold)
+static void Mold_File(const REBVAL *value, REB_MOLD *mold)
{
- REBUNI *dp;
- REBCNT n;
- REBUNI c;
- REBCNT len = VAL_LEN(value);
- REBSER *ser = VAL_SERIES(value);
+ REBUNI *dp;
+ REBCNT n;
+ REBUNI c;
+ REBCNT len = VAL_LEN_AT(value);
+ REBSER *ser = VAL_SERIES(value);
- // Compute extra space needed for hex encoded characters:
- for (n = VAL_INDEX(value); n < VAL_TAIL(value); n++) {
- c = GET_ANY_CHAR(ser, n);
- if (IS_FILE_ESC(c)) len += 2;
- }
+ // Compute extra space needed for hex encoded characters:
+ for (n = VAL_INDEX(value); n < VAL_LEN_HEAD(value); n++) {
+ c = GET_ANY_CHAR(ser, n);
+ if (IS_FILE_ESC(c)) len += 2;
+ }
- len++; // room for % at start
+ len++; // room for % at start
- dp = Prep_Uni_Series(mold, len);
+ dp = Prep_Uni_Series(mold, len);
- *dp++ = '%';
+ *dp++ = '%';
- for (n = VAL_INDEX(value); n < VAL_TAIL(value); n++) {
- c = GET_ANY_CHAR(ser, n);
- if (IS_FILE_ESC(c)) dp = Form_Hex_Esc_Uni(dp, c); // c => %xx
- else *dp++ = c;
- }
+ for (n = VAL_INDEX(value); n < VAL_LEN_HEAD(value); n++) {
+ c = GET_ANY_CHAR(ser, n);
+ if (IS_FILE_ESC(c)) dp = Form_Hex_Esc_Uni(dp, c); // c => %xx
+ else *dp++ = c;
+ }
- *dp = 0;
+ *dp = 0;
}
-STOID Mold_Tag(REBVAL *value, REB_MOLD *mold)
+static void Mold_Tag(const REBVAL *value, REB_MOLD *mold)
{
- Append_Byte(mold->series, '<');
- Insert_String(mold->series, AT_TAIL, VAL_SERIES(value), VAL_INDEX(value), VAL_LEN(value), 0);
- Append_Byte(mold->series, '>');
+ Append_Codepoint_Raw(mold->series, '<');
+ Insert_String(
+ mold->series,
+ SER_LEN(mold->series), // "insert" at tail (append)
+ VAL_SERIES(value),
+ VAL_INDEX(value),
+ VAL_LEN_AT(value),
+ FALSE
+ );
+ Append_Codepoint_Raw(mold->series, '>');
}
-/***********************************************************************
-**
-*/ void Mold_Binary(REBVAL *value, REB_MOLD *mold)
-/*
-***********************************************************************/
+//
+// Mold_Binary: C
+//
+void Mold_Binary(const REBVAL *value, REB_MOLD *mold)
{
- REBCNT len = VAL_LEN(value);
- REBSER *out;
-
- switch (Get_System_Int(SYS_OPTIONS, OPTIONS_BINARY_BASE, 16)) {
- default:
- case 16:
- out = Encode_Base16(value, 0, len > 32);
- break;
- case 64:
- Append_Bytes(mold->series, "64");
- out = Encode_Base64(value, 0, len > 64);
- break;
- case 2:
- Append_Byte(mold->series, '2');
- out = Encode_Base2(value, 0, len > 8);
- break;
- }
-
- Emit(mold, "#{E}", out);
+ REBCNT len = VAL_LEN_AT(value);
+ REBSER *out;
+
+ switch (Get_System_Int(SYS_OPTIONS, OPTIONS_BINARY_BASE, 16)) {
+ default:
+ case 16:
+ out = Encode_Base16(value, 0, LOGICAL(len > 32));
+ break;
+ case 64:
+ Append_Unencoded(mold->series, "64");
+ out = Encode_Base64(value, 0, LOGICAL(len > 64));
+ break;
+ case 2:
+ Append_Codepoint_Raw(mold->series, '2');
+ out = Encode_Base2(value, 0, LOGICAL(len > 8));
+ break;
+ }
+
+ Emit(mold, "#{E}", out);
+ Free_Series(out);
}
-STOID Mold_All_String(REBVAL *value, REB_MOLD *mold)
+static void Mold_All_String(const REBVAL *value, REB_MOLD *mold)
{
- // The string that is molded for /all option:
- REBVAL val;
-
- //// ???? move to above Mold_String_Series function????
-
- Pre_Mold(value, mold); // #[file! part
- val = *value;
- VAL_INDEX(&val) = 0;
- if (IS_BINARY(value)) Mold_Binary(&val, mold);
- else {
- VAL_SET(&val, REB_STRING);
- Mold_String_Series(&val, mold);
- }
- Post_Mold(value, mold);
+ //// ???? move to above Mold_String_Series function????
+
+ Pre_Mold(value, mold); // e.g. #[file! part
+
+ DECLARE_LOCAL (head);
+ Move_Value(head, value);
+ VAL_INDEX(head) = 0;
+
+ if (IS_BINARY(value))
+ Mold_Binary(head, mold);
+ else {
+ VAL_RESET_HEADER(head, REB_STRING);
+ Mold_String_Series(head, mold);
+ }
+
+ Post_Mold(value, mold);
}
/***********************************************************************
************************************************************************
**
-** SECTION: Block Series Datatypes
+** SECTION: Block Series Datatypes
**
************************************************************************
***********************************************************************/
-STOID Mold_Block_Series(REB_MOLD *mold, REBSER *series, REBCNT index, REBYTE *sep)
-{
- REBSER *out = mold->series;
- REBOOL line_flag = FALSE; // newline was part of block
- REBOOL had_lines = FALSE;
- REBVAL *value = BLK_SKIP(series, index);
-
- if (!sep) sep = "[]";
-
- if (IS_END(value)) {
- Append_Bytes(out, sep);
- return;
- }
-
- // Recursion check: (variation of: Find_Same_Block(MOLD_LOOP, value))
- for (value = BLK_HEAD(MOLD_LOOP); NOT_END(value); value++) {
- if (VAL_SERIES(value) == series) {
- Emit(mold, "C...C", sep[0], sep[1]);
- return;
- }
- }
- value = Append_Value(MOLD_LOOP);
- Set_Block(value, series);
-
- if (sep[1]) {
- Append_Byte(out, sep[0]);
- mold->indent++;
- }
-// else out->tail--; // why?????
-
- value = BLK_SKIP(series, index);
- while (NOT_END(value)) {
- if (VAL_GET_LINE(value)) {
- if (sep[1] || line_flag) New_Indented_Line(mold);
- had_lines = TRUE;
- }
- line_flag = TRUE;
- Mold_Value(mold, value, TRUE);
- value++;
- if (NOT_END(value))
- Append_Byte(out, (sep[0] == '/') ? '/' : ' ');
- }
-
- if (sep[1]) {
- mold->indent--;
- if (VAL_GET_LINE(value) || had_lines) New_Indented_Line(mold);
- Append_Byte(out, sep[1]);
- }
-
- Remove_Last(MOLD_LOOP);
+//
+// Mold_Array_At: C
+//
+void Mold_Array_At(
+ REB_MOLD *mold,
+ REBARR *array,
+ REBCNT index,
+ const char *sep
+) {
+ REBSER *out = mold->series;
+ REBOOL line_flag = FALSE; // newline was part of block
+ REBOOL had_lines = FALSE;
+ RELVAL *value = ARR_AT(array, index);
+
+ if (!sep) sep = "[]";
+
+ if (IS_END(value)) {
+ Append_Unencoded(out, sep);
+ return;
+ }
+
+ // Recursion check:
+ if (Find_Same_Array(MOLD_STACK, value) != NOT_FOUND) {
+ Emit(mold, "C...C", sep[0], sep[1]);
+ return;
+ }
+
+ // We don't want to use Init_Block because it will create an implicit
+ // managed value, and the incoming series may be from an unmanaged source
+ // !!! Review how to avoid needing to put the series into a value
+ {
+ REBVAL *temp = Alloc_Tail_Array(MOLD_STACK);
+ VAL_RESET_HEADER(temp, REB_BLOCK);
+ INIT_VAL_ARRAY(temp, array); // copies args
+ VAL_INDEX(temp) = 0;
+ }
+
+ if (sep[1]) {
+ Append_Codepoint_Raw(out, sep[0]);
+ mold->indent++;
+ }
+// else out->tail--; // why?????
+
+ value = ARR_AT(array, index);
+ while (NOT_END(value)) {
+ if (GET_VAL_FLAG(value, VALUE_FLAG_LINE)) {
+ if (sep[1] || line_flag) New_Indented_Line(mold);
+ had_lines = TRUE;
+ }
+ line_flag = TRUE;
+ Mold_Value(mold, value, TRUE);
+ value++;
+ if (NOT_END(value))
+ Append_Codepoint_Raw(out, (sep[0] == '/') ? '/' : ' ');
+ }
+
+ if (sep[1]) {
+ mold->indent--;
+ if (had_lines)
+ New_Indented_Line(mold);
+ Append_Codepoint_Raw(out, sep[1]);
+ }
+
+ TERM_ARRAY_LEN(MOLD_STACK, ARR_LEN(MOLD_STACK) - 1);
}
-STOID Mold_Block(REBVAL *value, REB_MOLD *mold)
+
+static void Mold_Block(const RELVAL *value, REB_MOLD *mold)
{
- REBYTE *sep;
- REBOOL all = GET_MOPT(mold, MOPT_MOLD_ALL);
- REBSER *series = mold->series;
- REBFLG over = FALSE;
-
- if (SERIES_WIDE(VAL_SERIES(value)) == 0)
- Crash(RP_BAD_WIDTH, sizeof(REBVAL), 0, VAL_TYPE(value));
-
- // Optimize when no index needed:
- if (VAL_INDEX(value) == 0 && !IS_MAP(value)) // && (VAL_TYPE(value) <= REB_LIT_PATH))
- all = FALSE;
-
- // If out of range, do not cause error to avoid error looping.
- if (VAL_INDEX(value) >= VAL_TAIL(value)) over = TRUE; // Force it into []
-
- if (all || (over && !IS_BLOCK(value) && !IS_PAREN(value))) {
- SET_FLAG(mold->opts, MOPT_MOLD_ALL);
- Pre_Mold(value, mold); // #[block! part
- //if (over) Append_Bytes(mold->series, "[]");
- //else
- Mold_Block_Series(mold, VAL_SERIES(value), 0, 0);
- Post_Mold(value, mold);
- }
- else
- {
- switch(VAL_TYPE(value)) {
-
- case REB_MAP:
- Pre_Mold(value, mold);
- sep = 0;
-
- case REB_BLOCK:
- if (GET_MOPT(mold, MOPT_ONLY)) {
- CLR_FLAG(mold->opts, MOPT_ONLY); // only top level
- sep = "\000\000";
- }
- else sep = 0;
- break;
-
- case REB_PAREN:
- sep = "()";
- break;
-
- case REB_GET_PATH:
- series = Append_Byte(series, ':');
- sep = "/";
- break;
-
- case REB_LIT_PATH:
- series = Append_Byte(series, '\'');
- /* fall through */
- case REB_PATH:
- case REB_SET_PATH:
- sep = "/";
- break;
- }
-
- if (over) Append_Bytes(mold->series, sep ? sep : (REBYTE*)("[]"));
- else Mold_Block_Series(mold, VAL_SERIES(value), VAL_INDEX(value), sep);
-
- if (VAL_TYPE(value) == REB_SET_PATH)
- Append_Byte(series, ':');
- }
+ const char *sep;
+ REBOOL all = GET_MOPT(mold, MOPT_MOLD_ALL);
+ REBSER *series = mold->series;
+ REBOOL over = FALSE;
+
+ // Optimize when no index needed:
+ if (VAL_INDEX(value) == 0 && !IS_MAP(value)) // && (VAL_TYPE(value) <= REB_LIT_PATH))
+ all = FALSE;
+
+ // If out of range, do not cause error to avoid error looping.
+ if (VAL_INDEX(value) >= VAL_LEN_HEAD(value)) over = TRUE; // Force it into []
+
+ if (all || (over && !IS_BLOCK(value) && !IS_GROUP(value))) {
+ SET_FLAG(mold->opts, MOPT_MOLD_ALL);
+ Pre_Mold(value, mold); // #[block! part
+ //if (over) Append_Unencoded(mold->series, "[]");
+ //else
+ Append_Codepoint_Raw(mold->series, '[');
+ Mold_Array_At(mold, VAL_ARRAY(value), 0, 0);
+ Post_Mold(value, mold);
+ Append_Codepoint_Raw(mold->series, ']');
+ }
+ else
+ {
+ switch(VAL_TYPE(value)) {
+
+ case REB_MAP:
+ Pre_Mold(value, mold);
+ sep = 0;
+
+ // falls through
+ case REB_BLOCK:
+ if (GET_MOPT(mold, MOPT_ONLY)) {
+ CLR_FLAG(mold->opts, MOPT_ONLY); // only top level
+ sep = "\000\000";
+ }
+ else sep = 0;
+ break;
+
+ case REB_GROUP:
+ sep = "()";
+ break;
+
+ case REB_GET_PATH:
+ series = Append_Codepoint_Raw(series, ':');
+ sep = "/";
+ break;
+
+ case REB_LIT_PATH:
+ series = Append_Codepoint_Raw(series, '\'');
+ /* fall through */
+ case REB_PATH:
+ case REB_SET_PATH:
+ sep = "/";
+ break;
+ default:
+ sep = NULL;
+ }
+
+ if (over) Append_Unencoded(mold->series, sep ? sep : "[]");
+ else Mold_Array_At(mold, VAL_ARRAY(value), VAL_INDEX(value), sep);
+
+ if (VAL_TYPE(value) == REB_SET_PATH)
+ Append_Codepoint_Raw(series, ':');
+ }
}
-STOID Mold_Simple_Block(REB_MOLD *mold, REBVAL *block, REBCNT len)
+static void Mold_Simple_Block(REB_MOLD *mold, RELVAL *block, REBCNT len)
{
- // Simple molder for error locations. Series must be valid.
- // Max length in chars must be provided.
- REBCNT start = SERIES_TAIL(mold->series);
-
- while (NOT_END(block)) {
- if ((SERIES_TAIL(mold->series) - start) > len) break;
- Mold_Value(mold, block, TRUE);
- block++;
- if (NOT_END(block)) Append_Byte(mold->series, ' ');
- }
-
- // If it's too large, truncate it:
- if ((SERIES_TAIL(mold->series) - start) > len) {
- SERIES_TAIL(mold->series) = start + len;
- Append_Bytes(mold->series, "...");
- }
+ // Simple molder for error locations. Series must be valid.
+ // Max length in chars must be provided.
+ REBCNT start = SER_LEN(mold->series);
+
+ while (NOT_END(block)) {
+ if ((SER_LEN(mold->series) - start) > len) break;
+ Mold_Value(mold, block, TRUE);
+ block++;
+ if (NOT_END(block)) Append_Codepoint_Raw(mold->series, ' ');
+ }
+
+ // If it's too large, truncate it:
+ if ((SER_LEN(mold->series) - start) > len) {
+ SET_SERIES_LEN(mold->series, start + len);
+ Append_Unencoded(mold->series, "...");
+ }
}
-STOID Form_Block_Series(REBSER *blk, REBCNT index, REB_MOLD *mold, REBSER *frame)
-{
- // Form a series (part_mold means mold non-string values):
- REBINT n;
- REBINT len = SERIES_TAIL(blk) - index;
- REBVAL *val;
- REBVAL *wval;
-
- if (len < 0) len = 0;
-
- for (n = 0; n < len;) {
- val = BLK_SKIP(blk, index+n);
- wval = 0;
- if (frame && (IS_WORD(val) || IS_GET_WORD(val))) {
- wval = Find_Word_Value(frame, VAL_WORD_SYM(val));
- if (wval) val = wval;
- }
- Mold_Value(mold, val, wval != 0);
- n++;
- if (GET_MOPT(mold, MOPT_LINES)) {
- Append_Byte(mold->series, LF);
- }
- else {
- // Add a space if needed:
- if (n < len && mold->series->tail
- && *UNI_LAST(mold->series) != LF
- && !GET_MOPT(mold, MOPT_TIGHT)
- )
- Append_Byte(mold->series, ' ');
- }
- }
+
+static void Form_Array_At(
+ REBARR *array,
+ REBCNT index,
+ REB_MOLD *mold,
+ REBCTX *context
+) {
+ // Form a series (part_mold means mold non-string values):
+ REBINT n;
+ REBINT len = ARR_LEN(array) - index;
+
+ if (len < 0) len = 0;
+
+ for (n = 0; n < len;) {
+ RELVAL *val = ARR_AT(array, index + n);
+ REBVAL *wval = NULL;
+ if (context && (IS_WORD(val) || IS_GET_WORD(val))) {
+ wval = Select_Canon_In_Context(context, VAL_WORD_CANON(val));
+ if (wval) val = wval;
+ }
+ Mold_Value(mold, val, LOGICAL(wval != NULL));
+ n++;
+ if (GET_MOPT(mold, MOPT_LINES)) {
+ Append_Codepoint_Raw(mold->series, LF);
+ }
+ else {
+ // Add a space if needed:
+ if (n < len && SER_LEN(mold->series)
+ && *UNI_LAST(mold->series) != LF
+ && !GET_MOPT(mold, MOPT_TIGHT)
+ ){
+ Append_Codepoint_Raw(mold->series, ' ');
+ }
+ }
+ }
}
/***********************************************************************
************************************************************************
**
-** SECTION: Special Datatypes
+** SECTION: Special Datatypes
**
************************************************************************
***********************************************************************/
-#ifdef removed
-STOID Mold_Logic(REB_MOLD *mold, REBVAL *value)
-{
- REBYTE buf[20];
- Pre_Mold(value, mold);
-
- INT_TO_STR(VAL_LOGIC(value), buf);
- Append_Bytes(mold->series, buf);
- Append_Byte(mold->series, ' ');
- old_Block_Series(mold, BLK_HEAD(VAL_LOGIC_WORDS(value)), 0);
+static void Mold_Typeset(const REBVAL *value, REB_MOLD *mold, REBOOL molded)
+{
+ REBINT n;
+
+ if (molded) {
+ Pre_Mold(value, mold); // #[typeset! or make typeset!
+ Append_Codepoint_Raw(mold->series, '[');
+ }
+
+#if !defined(NDEBUG)
+ if (VAL_KEY_SPELLING(value) != NULL) {
+ //
+ // In debug builds we're probably more interested in the symbol than
+ // the typesets, if we are looking at a PARAMLIST or KEYLIST.
+ //
+ Append_Unencoded(mold->series, "(");
+
+ REBSTR *spelling = VAL_KEY_SPELLING(value);
+ Append_UTF8_May_Fail(
+ mold->series, STR_HEAD(spelling), STR_NUM_BYTES(spelling)
+ );
+ Append_Unencoded(mold->series, ") ");
+
+ // REVIEW: should detect when a lot of types are active and condense
+ // only if the number of types is unreasonable (often for keys/params)
+ //
+ if (TRUE) {
+ Append_Unencoded(mold->series, "...");
+ goto skip_types;
+ }
+ }
+#endif
- End_Mold(mold);
-}
+ assert(!TYPE_CHECK(value, REB_0)); // REB_0 is used for internal purposes
+
+ // Note that although REB_MAX_VOID is used as an implementation detail for
+ // special typesets in function paramlists or context keys to indicate
+ // -style optionality, the "absence of a type" is not generally legal
+ // in user typesets. Only legal "key" typesets (that have symbols).
+ //
+ assert(
+ !TYPE_CHECK(value, REB_MAX_VOID) || VAL_KEY_SPELLING(value) != NULL
+ );
+
+ // Convert bits to types.
+ //
+ for (n = REB_0 + 1; n < REB_MAX; n++) {
+ if (TYPE_CHECK(value, cast(enum Reb_Kind, n))) {
+ Emit(mold, "+DN ", SYM_DATATYPE_X, Canon(cast(REBSYM, n)));
+ }
+ }
+ Trim_Tail(mold->series, ' ');
+
+#if !defined(NDEBUG)
+skip_types:
#endif
-STOID Mold_Typeset(REBVAL *value, REB_MOLD *mold, REBFLG molded)
-{
- REBINT n;
-
- if (molded) {
- Pre_Mold(value, mold); // #[typeset! or make typeset!
- Append_Byte(mold->series, '[');
- }
-
- // Convert bits to types (we can make this more efficient !!)
- for (n = 0; n < REB_MAX; n++) {
- if (TYPE_CHECK(value, n)) {
- Emit(mold, "+DN ", SYM_DATATYPE_TYPE, n + 1);
- }
- }
- Trim_Tail(mold->series, ' ');
-
- if (molded) {
- //Form_Typeset(value, mold & ~(1<series, ']');
- End_Mold(mold);
- }
+ if (molded) {
+ //Form_Typeset(value, mold & ~(1<series, ']');
+ End_Mold(mold);
+ }
}
-STOID Mold_Function(REBVAL *value, REB_MOLD *mold)
+static void Mold_Function(const REBVAL *value, REB_MOLD *mold)
{
- Pre_Mold(value, mold);
-
- Append_Byte(mold->series, '[');
-
- Mold_Block_Series(mold, VAL_FUNC_SPEC(value), 0, 0); //// & ~(1<series, ']');
- End_Mold(mold);
+ Pre_Mold(value, mold);
+
+ Append_Codepoint_Raw(mold->series, '[');
+
+ // !!! The system is no longer keeping the spec of functions, in order
+ // to focus on a generalized "meta info object" service. MOLD of
+ // functions temporarily uses the word list as a substitute (which
+ // drops types)
+ //
+ REBARR *words_list = List_Func_Words(value, TRUE); // show pure locals
+ Mold_Array_At(mold, words_list, 0, 0);
+ Free_Array(words_list);
+
+ if (IS_FUNCTION_INTERPRETED(value)) {
+ //
+ // MOLD is an example of user-facing code that needs to be complicit
+ // in the "lie" about the effective bodies of the functions made
+ // by the optimized generators FUNC and CLOS...
+
+ REBOOL is_fake;
+ REBARR *body = Get_Maybe_Fake_Func_Body(&is_fake, value);
+
+ Mold_Array_At(mold, body, 0, 0);
+
+ if (is_fake) Free_Array(body); // was shallow copy
+ }
+ else if (IS_FUNCTION_SPECIALIZER(value)) {
+ //
+ // !!! Interim form of looking at specialized functions... show
+ // the frame
+ //
+ // >> source first
+ // first: make function! [[aggregate index] [
+ // aggregate: $void
+ // index: 1
+ // ]]
+ //
+ REBVAL *exemplar = KNOWN(VAL_FUNC_BODY(value));
+ Mold_Value(mold, exemplar, TRUE);
+ }
+
+ Append_Codepoint_Raw(mold->series, ']');
+ End_Mold(mold);
}
-STOID Mold_Map(REBVAL *value, REB_MOLD *mold, REBFLG molded)
+
+static void Mold_Map(const REBVAL *value, REB_MOLD *mold, REBOOL molded)
{
- REBSER *mapser = VAL_SERIES(value);
- REBVAL *val;
-
- // Prevent endless mold loop:
- if (Find_Same_Block(MOLD_LOOP, value) > 0) {
- Append_Bytes(mold->series, "...]");
- return;
- }
- Append_Val(MOLD_LOOP, value);
-
- if (molded) {
- Pre_Mold(value, mold);
- Append_Byte(mold->series, '[');
- }
-
- // Mold all non-none entries
- mold->indent++;
- for (val = BLK_HEAD(mapser); NOT_END(val) && NOT_END(val+1); val += 2) {
- if (!IS_NONE(val+1)) {
- if (molded) New_Indented_Line(mold);
- Emit(mold, "V V", val, val+1);
- if (!molded) Append_Byte(mold->series, '\n');
- }
- }
- mold->indent--;
-
- if (molded) {
- New_Indented_Line(mold);
- Append_Byte(mold->series, ']');
- }
-
- End_Mold(mold);
- Remove_Last(MOLD_LOOP);
+ REBARR *mapser = MAP_PAIRLIST(VAL_MAP(value));
+ RELVAL *val;
+
+ // Prevent endless mold loop:
+ if (Find_Same_Array(MOLD_STACK, value) != NOT_FOUND) {
+ Append_Unencoded(mold->series, "...]");
+ return;
+ }
+ Append_Value(MOLD_STACK, value);
+
+ if (molded) {
+ Pre_Mold(value, mold);
+ Append_Codepoint_Raw(mold->series, '[');
+ }
+
+ // Mold all entries that are set. As with contexts, void values are not
+ // valid entries but indicate the absence of a value.
+ //
+ mold->indent++;
+ for (val = ARR_HEAD(mapser); NOT_END(val) && NOT_END(val+1); val += 2) {
+ if (!IS_VOID(val + 1)) {
+ if (molded) New_Indented_Line(mold);
+ Emit(mold, "V V", val, val+1);
+ if (!molded) Append_Codepoint_Raw(mold->series, '\n');
+ }
+ }
+ mold->indent--;
+
+ if (molded) {
+ New_Indented_Line(mold);
+ Append_Codepoint_Raw(mold->series, ']');
+ }
+
+ End_Mold(mold);
+ TERM_ARRAY_LEN(MOLD_STACK, ARR_LEN(MOLD_STACK) - 1);
}
-STOID Form_Object(REBVAL *value, REB_MOLD *mold)
+
+static void Form_Object(const REBVAL *value, REB_MOLD *mold)
{
- REBSER *wser = VAL_OBJ_WORDS(value);
- REBVAL *words = BLK_HEAD(wser);
- REBVAL *vals = VAL_OBJ_VALUES(value); // first value is context
- REBCNT n;
-
- // Prevent endless mold loop:
- if (Find_Same_Block(MOLD_LOOP, value) > 0) {
- Append_Bytes(mold->series, "...]");
- return;
- }
- Append_Val(MOLD_LOOP, value);
-
- // Mold all words and their values:
- for (n = 1; n < SERIES_TAIL(wser); n++) {
- if (!VAL_GET_OPT(words+n, OPTS_HIDE))
- Emit(mold, "N: V\n", VAL_WORD_SYM(words+n), vals+n);
- }
- Remove_Last(mold->series);
- Remove_Last(MOLD_LOOP);
+ REBVAL *key = CTX_KEYS_HEAD(VAL_CONTEXT(value));
+ REBVAL *var = CTX_VARS_HEAD(VAL_CONTEXT(value));
+ REBOOL had_output = FALSE;
+
+ // Prevent endless mold loop:
+ if (Find_Same_Array(MOLD_STACK, value) != NOT_FOUND) {
+ Append_Unencoded(mold->series, "...]");
+ return;
+ }
+
+ Append_Value(MOLD_STACK, value);
+
+ // Mold all words and their values:
+ for (; NOT_END(key); key++, var++) {
+ if (NOT_VAL_FLAG(key, TYPESET_FLAG_HIDDEN)) {
+ had_output = TRUE;
+ Emit(mold, "N: V\n", VAL_KEY_SPELLING(key), var);
+ }
+ }
+
+ // Remove the final newline...but only if WE added something to the buffer
+ if (had_output) {
+ SET_SERIES_LEN(mold->series, SER_LEN(mold->series) - 1);
+ TERM_SEQUENCE(mold->series);
+ }
+
+ TERM_ARRAY_LEN(MOLD_STACK, ARR_LEN(MOLD_STACK) - 1);
}
-STOID Mold_Object(REBVAL *value, REB_MOLD *mold)
+
+static void Mold_Object(const REBVAL *value, REB_MOLD *mold)
{
- REBSER *wser;
- REBVAL *words;
- REBVAL *vals; // first value is context
- REBCNT n;
-
- ASSERT(VAL_OBJ_FRAME(value), RP_NO_OBJECT_FRAME);
-
- wser = VAL_OBJ_WORDS(value);
-// if (wser < 1000)
-// Dump_Block_Raw(VAL_OBJ_FRAME(value), 0, 1);
- words = BLK_HEAD(wser);
-
- vals = VAL_OBJ_VALUES(value); // first value is context
-
- Pre_Mold(value, mold);
-
- Append_Byte(mold->series, '[');
-
- // Prevent infinite looping:
- if (Find_Same_Block(MOLD_LOOP, value) > 0) {
- Append_Bytes(mold->series, "...]");
- return;
- }
- Append_Val(MOLD_LOOP, value);
-
- mold->indent++;
- for (n = 1; n < SERIES_TAIL(wser); n++) {
- if (
- !VAL_GET_OPT(words+n, OPTS_HIDE) &&
- ((VAL_TYPE(vals+n) > REB_NONE) || !GET_MOPT(mold, MOPT_NO_NONE))
- ){
- New_Indented_Line(mold);
- Append_UTF8(mold->series, Get_Sym_Name(VAL_WORD_SYM(words+n)), -1);
- //Print("Slot: %s", Get_Sym_Name(VAL_WORD_SYM(words+n)));
- Append_Bytes(mold->series, ": ");
- if (IS_WORD(vals+n) && !GET_MOPT(mold, MOPT_MOLD_ALL)) Append_Byte(mold->series, '\'');
- Mold_Value(mold, vals+n, TRUE);
- }
- }
- mold->indent--;
- New_Indented_Line(mold);
- Append_Byte(mold->series, ']');
-
- End_Mold(mold);
- Remove_Last(MOLD_LOOP);
+ REBVAL *keys_head = CTX_KEYS_HEAD(VAL_CONTEXT(value));
+
+ REBVAL *vars_head;
+ if (CTX_VARS_UNAVAILABLE(VAL_CONTEXT(value))) {
+ //
+ // If something like a function call has gone of the stack, the data
+ // for the vars will no longer be available. The keys should still
+ // be good, however.
+ //
+ vars_head = NULL;
+ }
+ else
+ vars_head = CTX_VARS_HEAD(VAL_CONTEXT(value));
+
+ Pre_Mold(value, mold);
+
+ Append_Codepoint_Raw(mold->series, '[');
+
+ // Prevent infinite looping:
+ if (Find_Same_Array(MOLD_STACK, value) != NOT_FOUND) {
+ Append_Unencoded(mold->series, "...]");
+ return;
+ }
+
+ Append_Value(MOLD_STACK, value);
+ mold->indent++;
+
+ // !!! New experimental Ren-C code for the [[spec][body]] format of the
+ // non-evaluative MAKE OBJECT!.
+
+ // First loop: spec block. This is difficult because unlike functions,
+ // objects are dynamically modified with new members added. If the spec
+ // were captured with strings and other data in it as separate from the
+ // "keylist" information, it would have to be updated to reflect newly
+ // added fields in order to be able to run a corresponding MAKE OBJECT!.
+ //
+ // To get things started, we aren't saving the original spec that made
+ // the object...but regenerate one from the keylist. If this were done
+ // with functions, they would "forget" their help strings in MOLDing.
+
+ New_Indented_Line(mold);
+ Append_Codepoint_Raw(mold->series, '[');
+
+ REBVAL *key = keys_head;
+
+ for (; NOT_END(key); ++key) {
+ if (key != keys_head)
+ Append_Codepoint_Raw(mold->series, ' ');
+
+ // !!! Feature of hidden words in object specs not yet implemented,
+ // but if it paralleled how function specs work it would be SET-WORD!
+ //
+ DECLARE_LOCAL (any_word);
+ Init_Any_Word(
+ any_word,
+ GET_VAL_FLAG(key, TYPESET_FLAG_HIDDEN) ? REB_SET_WORD : REB_WORD,
+ VAL_KEY_SPELLING(key)
+ );
+ Mold_Value(mold, any_word, TRUE);
+ }
+
+ Append_Codepoint_Raw(mold->series, ']');
+ New_Indented_Line(mold);
+ Append_Codepoint_Raw(mold->series, '[');
+
+ mold->indent++;
+
+ key = keys_head;
+
+ REBVAL *var = vars_head;
+
+ for (; NOT_END(key); var ? (++key, ++var) : ++key) {
+ if (GET_VAL_FLAG(key, TYPESET_FLAG_HIDDEN))
+ continue; // !!! Should hidden fields be in molded view?
+
+ // Having the key mentioned in the spec and then not being assigned
+ // a value in the body is how voids are denoted.
+ //
+ if (var && IS_VOID(var))
+ continue;
+
+ New_Indented_Line(mold);
+
+ REBSTR *spelling = VAL_KEY_SPELLING(key);
+ Append_UTF8_May_Fail(
+ mold->series, STR_HEAD(spelling), STR_NUM_BYTES(spelling)
+ );
+
+ Append_Unencoded(mold->series, ": ");
+
+ if (var)
+ Mold_Value(mold, var, TRUE);
+ else
+ Append_Unencoded(mold->series, ": --optimized out--");
+ }
+
+ mold->indent--;
+ New_Indented_Line(mold);
+ Append_Codepoint_Raw(mold->series, ']');
+ mold->indent--;
+ New_Indented_Line(mold);
+ Append_Codepoint_Raw(mold->series, ']');
+
+ End_Mold(mold);
+ TERM_ARRAY_LEN(MOLD_STACK, ARR_LEN(MOLD_STACK) - 1);
}
-STOID Mold_Error(REBVAL *value, REB_MOLD *mold, REBFLG molded)
+
+static void Mold_Error(const REBVAL *value, REB_MOLD *mold, REBOOL molded)
{
- ERROR_OBJ *err;
- REBVAL *msg; // Error message block
-
- // Protect against recursion. !!!!
-
- if (molded) {
- if (VAL_OBJ_FRAME(value) && VAL_ERR_NUM(value) >= RE_NOTE && VAL_ERR_OBJECT(value))
- Mold_Object(value, mold);
- else {
- // Happens if throw or return is molded.
- // make error! 0-3
- Pre_Mold(value, mold);
- Append_Int(mold->series, VAL_ERR_NUM(value));
- End_Mold(mold);
- }
- return;
- }
-
- // If it is an unprocessed BREAK, THROW, CONTINUE, RETURN:
- if (VAL_ERR_NUM(value) < RE_NOTE || !VAL_ERR_OBJECT(value)) {
- VAL_ERR_OBJECT(value) = Make_Error(VAL_ERR_NUM(value), value, 0, 0); // spoofs field
- }
- err = VAL_ERR_VALUES(value);
-
- // Form: ** Error:
- Emit(mold, "** WB", &err->type, RS_ERRS+0);
-
- // Append: error message ARG1, ARG2, etc.
- msg = Find_Error_Info(err, 0);
- if (msg) {
- if (!IS_BLOCK(msg)) Mold_Value(mold, msg, 0);
- else {
- //start = DSP + 1;
- //Reduce_In_Frame(VAL_ERR_OBJECT(value), VAL_BLK_DATA(msg));
- //SERIES_TAIL(DS_Series) = DSP + 1;
- //Form_Block_Series(DS_Series, start, mold, 0);
- Form_Block_Series(VAL_SERIES(msg), 0, mold, VAL_ERR_OBJECT(value));
- }
- } else
- Append_Boot_Str(mold->series, RS_ERRS+1);
-
- Append_Byte(mold->series, '\n');
-
- // Form: ** Where: function
- value = &err->where;
- if (VAL_TYPE(value) > REB_NONE) {
- Append_Boot_Str(mold->series, RS_ERRS+2);
- Mold_Value(mold, value, 0);
- Append_Byte(mold->series, '\n');
- }
-
- // Form: ** Near: location
- value = &err->nearest;
- if (VAL_TYPE(value) > REB_NONE) {
- Append_Boot_Str(mold->series, RS_ERRS+3);
- if (IS_STRING(value)) // special case: source file line number
- Append_String(mold->series, VAL_SERIES(value), 0, VAL_TAIL(value));
- else if (IS_BLOCK(value))
- Mold_Simple_Block(mold, VAL_BLK_DATA(value), 60);
- Append_Byte(mold->series, '\n');
- }
+ ERROR_VARS *vars;
+ REBCTX *context;
+
+ // Protect against recursion. !!!!
+
+ if (molded) {
+ Mold_Object(value, mold);
+ return;
+ }
+
+ context = VAL_CONTEXT(value);
+ vars = VAL_ERR_VARS(value);
+
+ // Form: ** Error:
+ if (IS_BLANK(&vars->type))
+ Emit(mold, "** S", RM_ERROR_LABEL);
+ else {
+ assert(IS_WORD(&vars->type));
+ Emit(mold, "** W S", &vars->type, RM_ERROR_LABEL);
+ }
+
+ // Append: error message ARG1, ARG2, etc.
+ if (IS_BLOCK(&vars->message))
+ Form_Array_At(VAL_ARRAY(&vars->message), 0, mold, context);
+ else if (IS_STRING(&vars->message))
+ Mold_Value(mold, &vars->message, FALSE);
+ else
+ Append_Unencoded(mold->series, RM_BAD_ERROR_FORMAT);
+
+ // Form: ** Where: function
+ REBVAL *where = &vars->where;
+ if (NOT(IS_BLANK(where))) {
+ Append_Codepoint_Raw(mold->series, '\n');
+ Append_Unencoded(mold->series, RM_ERROR_WHERE);
+ Mold_Value(mold, where, FALSE);
+ }
+
+ // Form: ** Near: location
+ REBVAL *nearest = &vars->nearest;
+ if (NOT(IS_BLANK(nearest))) {
+ Append_Codepoint_Raw(mold->series, '\n');
+ Append_Unencoded(mold->series, RM_ERROR_NEAR);
+
+ if (IS_STRING(nearest)) {
+ //
+ // !!! The scanner puts strings into the near information in order
+ // to say where the file and line of the scan problem was. This
+ // seems better expressed as an explicit argument to the scanner
+ // error, because otherwise it obscures the LOAD call where the
+ // scanner was invoked. Review.
+ //
+ Append_String(
+ mold->series, VAL_SERIES(nearest), 0, VAL_LEN_HEAD(nearest)
+ );
+ }
+ else if (IS_BLOCK(nearest))
+ Mold_Simple_Block(mold, VAL_ARRAY_AT(nearest), 60);
+ else
+ Append_Unencoded(mold->series, RM_BAD_ERROR_FORMAT);
+ }
+
+ // Form: ** File: filename
+ //
+ // !!! In order to conserve space in the system, filenames are interned.
+ // Although interned strings are GC'd when no longer referenced, they can
+ // only be used in ANY-WORD! values at the moment, so the filename is
+ // not a FILE!.
+ //
+ REBVAL *file = &vars->file;
+ if (NOT(IS_BLANK(file))) {
+ Append_Codepoint_Raw(mold->series, '\n');
+ Append_Unencoded(mold->series, RM_ERROR_FILE);
+ if (IS_WORD(file))
+ Mold_Value(mold, file, FALSE);
+ else
+ Append_Unencoded(mold->series, RM_BAD_ERROR_FORMAT);
+ }
+
+ // Form: ** Line: line-number
+ REBVAL *line = &vars->line;
+ if (NOT(IS_BLANK(line))) {
+ Append_Codepoint_Raw(mold->series, '\n');
+ Append_Unencoded(mold->series, RM_ERROR_LINE);
+ if (IS_INTEGER(line))
+ Mold_Value(mold, line, FALSE);
+ else
+ Append_Unencoded(mold->series, RM_BAD_ERROR_FORMAT);
+ }
}
/***********************************************************************
************************************************************************
**
-** SECTION: Global Mold Functions
+** SECTION: Global Mold Functions
**
************************************************************************
***********************************************************************/
-/***********************************************************************
-**
-*/ void Mold_Value(REB_MOLD *mold, REBVAL *value, REBFLG molded)
-/*
-** Mold or form any value to string series tail.
-**
-***********************************************************************/
+//
+// Mold_Value: C
+//
+// Mold or form any value to string series tail.
+//
+void Mold_Value(REB_MOLD *mold, const RELVAL *value, REBOOL molded)
{
- REBYTE buf[60];
- REBINT len;
- REBSER *ser = mold->series;
-
- CHECK_STACK(&len);
-
- ASSERT2(SERIES_WIDE(mold->series) == sizeof(REBUNI), RP_BAD_SIZE);
- ASSERT2(ser, RP_NO_BUFFER);
-
- // Special handling of string series: {
- if (ANY_STR(value) && !IS_TAG(value)) {
-
- // Forming a string:
- if (!molded) {
- Insert_String(ser, -1, VAL_SERIES(value), VAL_INDEX(value), VAL_LEN(value), 0);
- return;
- }
-
- // Special format for ALL string series when not at head:
- if (GET_MOPT(mold, MOPT_MOLD_ALL) && VAL_INDEX(value) != 0) {
- Mold_All_String(value, mold);
- return;
- }
- }
-
- switch (VAL_TYPE(value)) {
- case REB_NONE:
- Emit(mold, "+N", SYM_NONE);
- break;
-
- case REB_LOGIC:
-// if (!molded || !VAL_LOGIC_WORDS(value) || !GET_MOPT(mold, MOPT_MOLD_ALL))
- Emit(mold, "+N", VAL_LOGIC(value) ? SYM_TRUE : SYM_FALSE);
-// else
-// Mold_Logic(mold, value);
- break;
-
- case REB_INTEGER:
- len = Emit_Integer(buf, VAL_INT64(value));
- goto append;
-
- case REB_DECIMAL:
- case REB_PERCENT:
- len = Emit_Decimal(buf, VAL_DECIMAL(value), IS_PERCENT(value)?DEC_MOLD_PERCENT:0,
- Punctuation[GET_MOPT(mold, MOPT_COMMA_PT) ? PUNCT_COMMA : PUNCT_DOT], mold->digits);
- goto append;
-
- case REB_MONEY:
- len = Emit_Money(value, buf, mold->opts);
- goto append;
-
- case REB_CHAR:
- Mold_Uni_Char(ser, VAL_CHAR(value), (REBOOL)molded, (REBOOL)GET_MOPT(mold, MOPT_MOLD_ALL));
- break;
-
- case REB_PAIR:
- len = Emit_Decimal(buf, VAL_PAIR_X(value), DEC_MOLD_MINIMAL, Punctuation[PUNCT_DOT], mold->digits/2);
- Append_Bytes_Len(ser, buf, len);
- Append_Byte(ser, 'x');
- len = Emit_Decimal(buf, VAL_PAIR_Y(value), DEC_MOLD_MINIMAL, Punctuation[PUNCT_DOT], mold->digits/2);
- Append_Bytes_Len(ser, buf, len);
- //Emit(mold, "IxI", VAL_PAIR_X(value), VAL_PAIR_Y(value));
- break;
-
- case REB_TUPLE:
- len = Emit_Tuple(value, buf);
- goto append;
-
- case REB_TIME:
- //len = Emit_Time(value, buf, Punctuation[GET_MOPT(mold, MOPT_COMMA_PT) ? PUNCT_COMMA : PUNCT_DOT]);
- Emit_Time(mold, value);
- break;
-
- case REB_DATE:
- Emit_Date(mold, value);
- break;
-
- case REB_STRING:
- // FORM happens in top section.
- Mold_String_Series(value, mold);
- break;
-
- case REB_BINARY:
- if (GET_MOPT(mold, MOPT_MOLD_ALL) && VAL_INDEX(value) != 0) {
- Mold_All_String(value, mold);
- return;
- }
- Mold_Binary(value, mold);
- break;
-
- case REB_FILE:
- if (VAL_LEN(value) == 0) {
- Append_Bytes(ser, "%\"\"");
- break;
- }
- Mold_File(value, mold);
- break;
-
- case REB_EMAIL:
- case REB_URL:
- Mold_Url(value, mold);
- break;
-
- case REB_TAG:
- if (GET_MOPT(mold, MOPT_MOLD_ALL) && VAL_INDEX(value) != 0) {
- Mold_All_String(value, mold);
- return;
- }
- Mold_Tag(value, mold);
- break;
-
-// Mold_Issue(value, mold);
-// break;
-
- case REB_BITSET:
- Pre_Mold(value, mold); // #[bitset! or make bitset!
- Mold_Bitset(value, mold);
- End_Mold(mold);
- break;
-
- case REB_IMAGE:
- Pre_Mold(value, mold);
- if (!GET_MOPT(mold, MOPT_MOLD_ALL)) {
- Append_Byte(ser, '[');
- Mold_Image_Data(value, mold);
- Append_Byte(ser, ']');
- End_Mold(mold);
- }
- else {
- REBVAL val = *value;
- VAL_INDEX(&val) = 0; // mold all of it
- Mold_Image_Data(&val, mold);
- Post_Mold(value, mold);
- }
- break;
-
- case REB_BLOCK:
- case REB_PAREN:
- if (!molded)
- Form_Block_Series(VAL_SERIES(value), VAL_INDEX(value), mold, 0);
- else
- Mold_Block(value, mold);
- break;
-
- case REB_PATH:
- case REB_SET_PATH:
- case REB_GET_PATH:
- case REB_LIT_PATH:
- Mold_Block(value, mold);
- break;
-
- case REB_VECTOR:
- Mold_Vector(value, mold, molded);
- break;
-
- case REB_DATATYPE:
- if (!molded)
- Emit(mold, "N", VAL_DATATYPE(value) + 1);
- else
- Emit(mold, "+DN", SYM_DATATYPE_TYPE, VAL_DATATYPE(value) + 1);
- break;
-
- case REB_TYPESET:
- Mold_Typeset(value, mold, molded);
- break;
-
- case REB_WORD:
- // This is a high frequency function, so it is optimized.
- Append_UTF8(ser, Get_Sym_Name(VAL_WORD_SYM(value)), -1);
- break;
-
- case REB_SET_WORD:
- Emit(mold, "W:", value);
- break;
-
- case REB_GET_WORD:
- Emit(mold, ":W", value);
- break;
-
- case REB_LIT_WORD:
- Emit(mold, "\'W", value);
- break;
-
- case REB_REFINEMENT:
- Emit(mold, "/W", value);
- break;
-
- case REB_ISSUE:
- Emit(mold, "#W", value);
- break;
-
- case REB_CLOSURE:
- case REB_FUNCTION:
- case REB_NATIVE:
- case REB_ACTION:
- case REB_COMMAND:
- Mold_Function(value, mold);
- break;
-
- case REB_OBJECT:
- case REB_MODULE:
- case REB_PORT:
- if (!molded) Form_Object(value, mold);
- else Mold_Object(value, mold);
- break;
-
- case REB_TASK:
- Mold_Object(value, mold); //// | (1<series;
+
+ if (C_STACK_OVERFLOWING(&len)) Trap_Stack_Overflow();
+
+ assert(SER_WIDE(ser) == sizeof(REBUNI));
+ ASSERT_SERIES_TERM(ser);
+
+ if (GET_MOPT(mold, MOPT_LIMIT)) {
+ //
+ // It's hard to detect the exact moment of tripping over the length
+ // limit unless all code paths that add to the mold buffer (e.g.
+ // tacking on delimiters etc.) check the limit. The easier thing
+ // to do is check at the end and truncate. This adds a lot of data
+ // wastefully, so short circuit here in the release build. (Have
+ // the debug build keep going to exercise mold on the data.)
+ //
+ #ifdef NDEBUG
+ if (SER_LEN(mold->series) >= mold->limit)
+ return;
+ #endif
+ }
+
+ if (THROWN(value)) {
+ // !!! You do not want to see THROWN values leak into user awareness,
+ // as they are an implementation detail. So unless this is debug
+ // output, it should be an assert. Thus REB_MOLD probably needs a
+ // "for debug output purposes" switch.
+ Emit(mold, "S", "!!! THROWN() -> ");
+ }
+
+ // Special handling of string series: {
+ if (ANY_STRING(value) && !IS_TAG(value)) {
+
+ // Forming a string:
+ if (!molded) {
+ Insert_String(
+ ser,
+ SER_LEN(ser), // "insert" at tail (append)
+ VAL_SERIES(value),
+ VAL_INDEX(value),
+ VAL_LEN_AT(value),
+ FALSE
+ );
+ return;
+ }
+
+ // Special format for ALL string series when not at head:
+ if (GET_MOPT(mold, MOPT_MOLD_ALL) && VAL_INDEX(value) != 0) {
+ Mold_All_String(const_KNOWN(value), mold);
+ return;
+ }
+ }
+
+ switch (VAL_TYPE(value)) {
+ case REB_MAX_VOID:
+ // Voids should only be molded in debug scenarios
+ Append_Unencoded(ser, "&void");
+ break;
+
+ case REB_BAR:
+ Append_Unencoded(ser, "|");
+ break;
+
+ case REB_LIT_BAR:
+ Append_Unencoded(ser, "'|");
+ break;
+
+ case REB_BLANK:
+ Append_Unencoded(ser, "_");
+ break;
+
+ case REB_LOGIC:
+ Emit(mold, "+N", VAL_LOGIC(value) ? Canon(SYM_TRUE) : Canon(SYM_FALSE));
+ break;
+
+ case REB_INTEGER:
+ len = Emit_Integer(buf, VAL_INT64(value));
+ goto append;
+
+ case REB_DECIMAL:
+ case REB_PERCENT:
+ len = Emit_Decimal(buf, VAL_DECIMAL(value), IS_PERCENT(value)?DEC_MOLD_PERCENT:0,
+ Punctuation[GET_MOPT(mold, MOPT_COMMA_PT) ? PUNCT_COMMA : PUNCT_DOT], mold->digits);
+ goto append;
+
+ case REB_MONEY:
+ len = Emit_Money(const_KNOWN(value), buf, mold->opts);
+ goto append;
+
+ case REB_CHAR:
+ Mold_Uni_Char(
+ ser, VAL_CHAR(value), molded, GET_MOPT(mold, MOPT_MOLD_ALL)
+ );
+ break;
+
+ case REB_PAIR:
+ len = Emit_Decimal(buf, VAL_PAIR_X(value), DEC_MOLD_MINIMAL, Punctuation[PUNCT_DOT], mold->digits/2);
+ Append_Unencoded_Len(ser, s_cast(buf), len);
+ Append_Codepoint_Raw(ser, 'x');
+ len = Emit_Decimal(buf, VAL_PAIR_Y(value), DEC_MOLD_MINIMAL, Punctuation[PUNCT_DOT], mold->digits/2);
+ Append_Unencoded_Len(ser, s_cast(buf), len);
+ //Emit(mold, "IxI", VAL_PAIR_X(value), VAL_PAIR_Y(value));
+ break;
+
+ case REB_TUPLE:
+ len = Emit_Tuple(const_KNOWN(value), buf);
+ goto append;
+
+ case REB_TIME:
+ //len = Emit_Time(value, buf, Punctuation[GET_MOPT(mold, MOPT_COMMA_PT) ? PUNCT_COMMA : PUNCT_DOT]);
+ Emit_Time(mold, const_KNOWN(value));
+ break;
+
+ case REB_DATE:
+ Emit_Date(mold, const_KNOWN(value));
+ break;
+
+ case REB_STRING:
+ // FORM happens in top section.
+ Mold_String_Series(const_KNOWN(value), mold);
+ break;
+
+ case REB_BINARY:
+ if (GET_MOPT(mold, MOPT_MOLD_ALL) && VAL_INDEX(value) != 0) {
+ Mold_All_String(const_KNOWN(value), mold);
+ return;
+ }
+ Mold_Binary(const_KNOWN(value), mold);
+ break;
+
+ case REB_FILE:
+ if (VAL_LEN_AT(value) == 0) {
+ Append_Unencoded(ser, "%\"\"");
+ break;
+ }
+ Mold_File(const_KNOWN(value), mold);
+ break;
+
+ case REB_EMAIL:
+ case REB_URL:
+ Mold_Url(const_KNOWN(value), mold);
+ break;
+
+ case REB_TAG:
+ if (GET_MOPT(mold, MOPT_MOLD_ALL) && VAL_INDEX(value) != 0) {
+ Mold_All_String(const_KNOWN(value), mold);
+ return;
+ }
+ Mold_Tag(const_KNOWN(value), mold);
+ break;
+
+// Mold_Issue(value, mold);
+// break;
+
+ case REB_BITSET:
+ Pre_Mold(value, mold); // #[bitset! or make bitset!
+ Mold_Bitset(const_KNOWN(value), mold);
+ End_Mold(mold);
+ break;
+
+ case REB_IMAGE:
+ Pre_Mold(value, mold);
+ if (!GET_MOPT(mold, MOPT_MOLD_ALL)) {
+ Append_Codepoint_Raw(ser, '[');
+ Mold_Image_Data(const_KNOWN(value), mold);
+ Append_Codepoint_Raw(ser, ']');
+ End_Mold(mold);
+ }
+ else {
+ DECLARE_LOCAL (head);
+ Move_Value(head, const_KNOWN(value));
+ VAL_INDEX(head) = 0; // mold all of it
+ Mold_Image_Data(head, mold);
+ Post_Mold(value, mold);
+ }
+ break;
+
+ case REB_BLOCK:
+ case REB_GROUP:
+ if (!molded)
+ Form_Array_At(VAL_ARRAY(value), VAL_INDEX(value), mold, 0);
+ else
+ Mold_Block(value, mold);
+ break;
+
+ case REB_PATH:
+ case REB_SET_PATH:
+ case REB_GET_PATH:
+ case REB_LIT_PATH:
+ Mold_Block(value, mold);
+ break;
+
+ case REB_VECTOR:
+ Mold_Vector(const_KNOWN(value), mold, molded);
+ break;
+
+ case REB_DATATYPE: {
+ REBSTR *name = Canon(VAL_TYPE_SYM(value));
+ #if !defined(NDEBUG)
+ if (LEGACY(OPTIONS_PAREN_INSTEAD_OF_GROUP)) {
+ if (VAL_TYPE_KIND(value) == REB_GROUP)
+ name = Canon(SYM_PAREN_X); // e_Xclamation point (GROUP!)
+ }
+ #endif
+ if (!molded)
+ Emit(mold, "N", name);
+ else
+ Emit(mold, "+DN", SYM_DATATYPE_X, name);
+ break; }
+
+ case REB_TYPESET:
+ Mold_Typeset(const_KNOWN(value), mold, molded);
+ break;
+
+ case REB_WORD: { // Note: called often
+ REBSTR *spelling = VAL_WORD_SPELLING(value);
+ Append_UTF8_May_Fail(ser, STR_HEAD(spelling), STR_NUM_BYTES(spelling));
+ break;
+ }
+
+ case REB_SET_WORD:
+ Emit(mold, "W:", value);
+ break;
+
+ case REB_GET_WORD:
+ Emit(mold, ":W", value);
+ break;
+
+ case REB_LIT_WORD:
+ Emit(mold, "\'W", value);
+ break;
+
+ case REB_REFINEMENT:
+ Emit(mold, "/W", value);
+ break;
+
+ case REB_ISSUE:
+ Emit(mold, "#W", value);
+ break;
+
+ case REB_FUNCTION:
+ Mold_Function(const_KNOWN(value), mold);
+ break;
+
+ case REB_VARARGS:
+ Mold_Varargs(const_KNOWN(value), mold);
+ break;
+
+ case REB_OBJECT:
+ case REB_MODULE:
+ case REB_PORT:
+ case REB_FRAME:
+ if (!molded) Form_Object(const_KNOWN(value), mold);
+ else Mold_Object(const_KNOWN(value), mold);
+ break;
+
+ case REB_ERROR:
+ Mold_Error(const_KNOWN(value), mold, molded);
+ break;
+
+ case REB_MAP:
+ Mold_Map(const_KNOWN(value), mold, molded);
+ break;
+
+ case REB_GOB:
+ {
+ REBARR *array;
+ Pre_Mold(value, mold);
+ array = Gob_To_Array(VAL_GOB(value));
+ Mold_Array_At(mold, array, 0, 0);
+ End_Mold(mold);
+ Free_Array(array);
+ }
+ break;
+
+ case REB_EVENT:
+ Mold_Event(const_KNOWN(value), mold);
+ break;
+
+ case REB_STRUCT: {
+ Pre_Mold(value, mold);
+
+ REBARR *array = Struct_To_Array(VAL_STRUCT(value));
+ Mold_Array_At(mold, array, 0, 0);
+ Free_Array(array);
+
+ End_Mold(mold);
+ break; }
+
+ case REB_LIBRARY: {
+ Pre_Mold(value, mold);
+
+ REBCTX *meta = VAL_LIBRARY_META(value);
+ if (meta)
+ Mold_Object(CTX_VALUE(meta), mold);
+
+ End_Mold(mold);
+ break; }
+
+ case REB_HANDLE:
+ // Value has no printable form, so just print its name.
+ if (!molded) Emit(mold, "?T?", value);
+ else Emit(mold, "+T", value);
+ break;
+
+ default:
+ panic (value);
+ }
+ goto check_and_return;
append:
- Append_Bytes_Len(ser, buf, len);
+ Append_Unencoded_Len(ser, s_cast(buf), len);
+check_and_return:
+ ASSERT_SERIES_TERM(ser);
}
-/***********************************************************************
-**
-*/ REBSER *Copy_Form_Value(REBVAL *value, REBCNT opts)
-/*
-** Form a value based on the mold opts provided.
-**
-***********************************************************************/
+//
+// Copy_Form_Value: C
+//
+// Form a value based on the mold opts provided.
+//
+REBSER *Copy_Form_Value(const RELVAL *value, REBFLGS opts)
{
- REB_MOLD mo = {0};
+ REB_MOLD mo;
+ CLEARS(&mo);
+ mo.opts = opts;
- mo.opts = opts;
- Reset_Mold(&mo);
- Mold_Value(&mo, value, 0);
- return Copy_String(mo.series, 0, -1);
+ Push_Mold(&mo);
+ Mold_Value(&mo, value, FALSE);
+ return Pop_Molded_String(&mo);
}
-/***********************************************************************
-**
-*/ REBSER *Copy_Mold_Value(REBVAL *value, REBCNT opts)
-/*
-** Form a value based on the mold opts provided.
-**
-***********************************************************************/
+//
+// Copy_Mold_Value: C
+//
+// Form a value based on the mold opts provided.
+//
+REBSER *Copy_Mold_Value(const REBVAL *value, REBFLGS opts)
{
- REB_MOLD mo = {0};
+ REB_MOLD mo;
+ CLEARS(&mo);
+ mo.opts = opts;
- mo.opts = opts;
- Reset_Mold(&mo);
- Mold_Value(&mo, value, TRUE);
- return Copy_String(mo.series, 0, -1);
+ Push_Mold(&mo);
+ Mold_Value(&mo, value, TRUE);
+ return Pop_Molded_String(&mo);
}
-/***********************************************************************
-**
-*/ REBSER *Form_Reduce(REBSER *block, REBCNT index)
-/*
-** Reduce a block and then form each value into a string. Return the
-** string or NULL if an unwind triggered while reducing.
-**
-***********************************************************************/
-{
- REBINT start = DSP + 1;
- REBINT n;
- REB_MOLD mo = {0};
+//
+// Form_Reduce_Throws: C
+//
+// Evaluates each item in a block and forms it, with an optional delimiter.
+//
+// The special treatment of BLANK! in the source block is to act as an
+// opt-out, and the special treatment of BAR! is to act as a line break.
+// There's no such thing as a void literal in the incoming block, but if
+// an element evaluated to void it is also considered an opt-out, equivalent
+// to a BLANK!.
+//
+// BAR!, BLANK!/void, and CHAR! suppress the delimiter logic. Hence if you
+// are to form `["a" space "b" | () (blank) "c" newline "d" "e"]` with a
+// delimiter of ":", you will get back `"a b^/c^/d:e"... where only the
+// last interstitial is considered a valid candidate for delimiting.
+//
+REBOOL Form_Reduce_Throws(
+ REBVAL *out,
+ REBARR *array,
+ REBCNT index,
+ REBSPC *specifier,
+ const REBVAL *delimiter
+) {
+ assert(!IS_VOID(delimiter)); // use BLANK! to indicate no delimiting
+ if (IS_BAR(delimiter))
+ delimiter = ROOT_NEWLINE_CHAR; // BAR! is synonymous to newline here
+
+ REB_MOLD mo;
+ CLEARS(&mo);
+
+ Push_Mold(&mo);
+
+ DECLARE_FRAME (f);
+ Push_Frame_At(f, array, index, specifier, DO_FLAG_NORMAL);
+
+ REBOOL pending = FALSE;
+
+ while (NOT_END(f->value)) {
+ if (IS_BLANK(f->value)) { // opt-out
+ Fetch_Next_In_Frame(f);
+ continue;
+ }
+
+ if (IS_BAR(f->value)) { // newline
+ Append_Codepoint_Raw(mo.series, '\n');
+ pending = FALSE;
+ Fetch_Next_In_Frame(f);
+ continue;
+ }
+
+ if (Do_Next_In_Frame_Throws(out, f)) {
+ Drop_Frame(f);
+ return TRUE;
+ }
+
+ if (IS_VOID(out) || IS_BLANK(out)) // opt-out
+ continue;
+
+ if (IS_BAR(out)) { // newline
+ Append_Codepoint_Raw(mo.series, '\n');
+ pending = FALSE;
+ continue;
+ }
+
+ if (IS_CHAR(out)) {
+ Append_Codepoint_Raw(mo.series, VAL_CHAR(out));
+ pending = FALSE;
+ }
+ else if (IS_BLANK(delimiter)) // no delimiter
+ Mold_Value(&mo, out, FALSE);
+ else {
+ if (pending)
+ Mold_Value(&mo, delimiter, FALSE);
+
+ Mold_Value(&mo, out, FALSE);
+ pending = TRUE;
+ }
+ }
+
+ Drop_Frame(f);
+
+ Init_String(out, Pop_Molded_String(&mo));
+
+ return FALSE;
+}
- while (index < BLK_LEN(block)) {
- index = Do_Next(block, index, 0);
- if (THROWN(DS_TOP)) {
- *DS_VALUE(start) = *DS_TOP;
- DSP = start;
- return NULL;
- }
- }
- Reset_Mold(&mo);
+//
+// Form_Tight_Block: C
+//
+REBSER *Form_Tight_Block(const REBVAL *blk)
+{
+ RELVAL *val;
- for (n = start; n <= DSP; n++)
- Mold_Value(&mo, &DS_Base[n], 0);
+ REB_MOLD mo;
+ CLEARS(&mo);
- DSP = start;
+ Push_Mold(&mo);
+ for (val = VAL_ARRAY_AT(blk); NOT_END(val); val++)
+ Mold_Value(&mo, val, FALSE);
- return Copy_String(mo.series, 0, -1);
+ return Pop_Molded_String(&mo);
}
-/***********************************************************************
-**
-*/ REBSER *Form_Tight_Block(REBVAL *blk)
-/*
-***********************************************************************/
+//
+// Push_Mold: C
+//
+void Push_Mold(REB_MOLD *mold)
{
- REB_MOLD mo = {0};
- REBVAL *val;
+#if !defined(NDEBUG)
+ //
+ // If some kind of Debug_Fmt() happens while this Push_Mold is happening,
+ // it will lead to a recursion. It's necessary to look at the stack in
+ // the debugger and figure it out manually. (e.g. any failures in this
+ // function will break the very mechanism by which failure messages
+ // are reported.)
+ //
+ // !!! This isn't ideal. So if all the routines below guaranteed to
+ // use some kind of assert reporting mechanism "lower than mold"
+ // (hence "lower than Debug_Fmt") that would be an improvement.
+ //
+ assert(!TG_Pushing_Mold);
+ TG_Pushing_Mold = TRUE;
+#endif
+
+ // Series is nulled out on Pop in debug builds to make sure you don't
+ // Push the same mold tracker twice (without a Pop)
+ //
+ assert(!mold->series);
+
+#if !defined(NDEBUG)
+ // Sanity check that if they set a limit it wasn't 0. (Perhaps over the
+ // long term it would be okay, but for now we'll consider it a mistake.)
+ //
+ if (GET_MOPT(mold, MOPT_LIMIT))
+ assert(mold->limit != 0);
+#endif
- Reset_Mold(&mo);
- for (val = VAL_BLK_DATA(blk); NOT_END(val); val++)
- Mold_Value(&mo, val, 0);
- return Copy_String(mo.series, 0, -1);
+ mold->series = UNI_BUF;
+ mold->start = SER_LEN(mold->series);
+
+ ASSERT_SERIES_TERM(mold->series);
+
+ if (
+ GET_MOPT(mold, MOPT_RESERVE)
+ && SER_REST(mold->series) < mold->reserve
+ ) {
+ // Expand will add to the series length, so we set it back.
+ //
+ // !!! Should reserve actually leave the length expanded? Some cases
+ // definitely don't want this, others do. The protocol most
+ // compatible with the appending mold is to come back with an
+ // empty buffer after a push.
+ //
+ Expand_Series(mold->series, mold->start, mold->reserve);
+ SET_SERIES_LEN(mold->series, mold->start);
+ }
+ else if (SER_REST(mold->series) - SER_LEN(mold->series) > MAX_COMMON) {
+ //
+ // If the "extra" space in the series has gotten to be excessive (due
+ // to some particularly large mold), back off the space. But preserve
+ // the contents, as there may be important mold data behind the
+ // ->start index in the stack!
+ //
+ Remake_Series(
+ mold->series,
+ SER_LEN(mold->series) + MIN_COMMON,
+ SER_WIDE(mold->series),
+ NODE_FLAG_NODE // NODE_FLAG_NODE means preserve the data
+ );
+ }
+
+ if (GET_MOPT(mold, MOPT_MOLD_ALL))
+ mold->digits = MAX_DIGITS;
+ else {
+ // If there is no notification when the option is changed, this
+ // must be retrieved each time.
+ //
+ // !!! It may be necessary to mold out values before the options
+ // block is loaded, and this 'Get_System_Int' is a bottleneck which
+ // crashes that in early debugging. BOOT_ERRORS is sufficient.
+ //
+ if (PG_Boot_Phase >= BOOT_ERRORS) {
+ REBINT idigits = Get_System_Int(
+ SYS_OPTIONS, OPTIONS_DECIMAL_DIGITS, MAX_DIGITS
+ );
+ if (idigits < 0)
+ mold->digits = 0;
+ else if (idigits > MAX_DIGITS)
+ mold->digits = cast(REBCNT, idigits);
+ else
+ mold->digits = MAX_DIGITS;
+ }
+ else
+ mold->digits = MAX_DIGITS;
+ }
+
+#if !defined(NDEBUG)
+ TG_Pushing_Mold = FALSE;
+#endif
}
-/***********************************************************************
-**
-*/ void Reset_Mold(REB_MOLD *mold)
-/*
-***********************************************************************/
+//
+// Throttle_Mold: C
+//
+// Contain a mold's series to its limit (if it has one).
+//
+void Throttle_Mold(REB_MOLD *mold) {
+ if (GET_MOPT(mold, MOPT_LIMIT) && SER_LEN(mold->series) > mold->limit) {
+ SET_SERIES_LEN(mold->series, mold->limit - 3); // account for ellipsis
+ Append_Unencoded(mold->series, "..."); // adds a null at the tail
+ }
+}
+
+
+//
+// Pop_Molded_String_Core: C
+//
+// When a Push_Mold is started, then string data for the mold is accumulated
+// at the tail of the task-global unicode buffer. Once the molding is done,
+// this allows extraction of the string, and resets the buffer to its length
+// at the time when the last push began.
+//
+// Can limit string output to a specified size to prevent long console
+// garbage output if MOPT_LIMIT was set in Push_Mold().
+//
+// If len is END_FLAG then all the string content will be copied, otherwise
+// it will be copied up to `len`. If there are not enough characters then
+// the debug build will assert.
+//
+REBSER *Pop_Molded_String_Core(REB_MOLD *mold, REBCNT len)
{
- REBSER *buf = BUF_MOLD;
- REBINT len;
-
- if (!buf) Crash(RP_NO_BUFFER);
-
- if (SERIES_REST(buf) > MAX_COMMON)
- Shrink_Series(buf, MIN_COMMON);
-
- BLK_RESET(MOLD_LOOP);
- RESET_SERIES(buf);
- mold->series = buf;
-
- // This is not needed every time, but w/o a functional way to set the option,
- // it must be done like this and each time.
- if (GET_MOPT(mold, MOPT_MOLD_ALL)) len = MAX_DIGITS;
- else {
- len = Get_System_Int(SYS_OPTIONS, OPTIONS_DECIMAL_DIGITS, MAX_DIGITS);
- if (len > MAX_DIGITS) len = MAX_DIGITS;
- else if (len < 0) len = 0;
- }
- mold->digits = len;
+ REBSER *string;
+
+ assert(mold->series); // if NULL there was no Push_Mold()
+
+ ASSERT_SERIES_TERM(mold->series);
+ Throttle_Mold(mold);
+
+ assert(
+ (len == UNKNOWN) || (len <= SER_LEN(mold->series) - mold->start)
+ );
+
+ // The copy process looks at the characters in range and will make a
+ // BYTE_SIZE() target string out of the REBUNIs if possible...
+ //
+ string = Copy_String_Slimming(
+ mold->series,
+ mold->start,
+ (len == UNKNOWN)
+ ? SER_LEN(mold->series) - mold->start
+ : len
+ );
+
+ // Though the protocol of Mold_Value does terminate, it only does so if
+ // it adds content to the buffer. If we did not terminate when we
+ // reset the size, then these no-op molds (e.g. mold of "") would leave
+ // whatever value in the terminator spot was there. This could be
+ // addressed by making no-op molds terminate.
+ //
+ TERM_UNI_LEN(mold->series, mold->start);
+
+ mold->series = NULL;
+
+ return string;
}
-/***********************************************************************
-**
-*/ REBSER *Mold_Print_Value(REBVAL *value, REBCNT limit, REBFLG mold)
-/*
-** Basis function for print. Can do a form or a mold based
-** on the mold flag setting. Can limit string output to a
-** specified size to prevent long console garbage output.
-**
-***********************************************************************/
+//
+// Pop_Molded_UTF8: C
+//
+// Same as Pop_Molded_String() except gives back the data in UTF8 byte-size
+// series form.
+//
+REBSER *Pop_Molded_UTF8(REB_MOLD *mold)
{
- REB_MOLD mo = {0};
+ assert(SER_LEN(mold->series) >= mold->start);
- Reset_Mold(&mo);
+ ASSERT_SERIES_TERM(mold->series);
+ Throttle_Mold(mold);
- Mold_Value(&mo, value, mold);
+ REBSER *bytes = Make_UTF8_Binary(
+ UNI_AT(mold->series, mold->start),
+ SER_LEN(mold->series) - mold->start,
+ 0,
+ OPT_ENC_UNISRC
+ );
+ assert(BYTE_SIZE(bytes));
- if (limit != 0 && STR_LEN(mo.series) > limit) {
- SERIES_TAIL(mo.series) = limit;
- Append_Bytes(mo.series, "..."); // adds a null at the tail
- }
+ TERM_UNI_LEN(mold->series, mold->start);
- return mo.series;
+ mold->series = NULL;
+ return bytes;
}
-/***********************************************************************
-**
-*/ void Init_Mold(REBCNT size)
-/*
-***********************************************************************/
+//
+// Drop_Mold_Core: C
+//
+// When generating a molded string, sometimes it's enough to have access to
+// the molded data without actually creating a new series out of it. If the
+// information in the mold has done its job and Pop_Molded_String() is not
+// required, just call this to drop back to the state of the last push.
+//
+void Drop_Mold_Core(REB_MOLD *mold, REBOOL not_pushed_ok)
+{
+ // The tokenizer can often identify tokens to load by their start and end
+ // pointers in the UTF8 data it is loading alone. However, scanning
+ // string escapes is a process that requires converting the actual
+ // characters to unicode. To avoid redoing this work later in the scan,
+ // it uses the unicode buffer as a storage space from the tokenization
+ // that did UTF-8 decoding of string contents to reuse.
+ //
+ // Despite this usage, it's desirable to be able to do things like output
+ // debug strings or do basic molding in that code. So to reuse the
+ // allocated unicode buffer, it has to properly participate in the mold
+ // stack protocol.
+ //
+ // However, only a few token types use the buffer. Rather than burden
+ // the tokenizer with an additional flag, having a modality to be willing
+ // to "drop" a mold that hasn't ever been pushed is the easiest way to
+ // avoid intervening. Drop_Mold_If_Pushed(&mo) macro makes this clearer.
+ //
+ if (not_pushed_ok && mold->series == NULL)
+ return;
+
+ assert(mold->series != NULL); // if NULL there was no Push_Mold
+
+ // When pushed data are to be discarded, mold->series may be unterminated.
+ // (Indeed that happens when Scan_Item_Push_Mold returns NULL/0.)
+ //
+ NOTE_SERIES_MAYBE_TERM(mold->series);
+
+ TERM_UNI_LEN(mold->series, mold->start); // see Pop_Molded_String() notes
+
+ mold->series = NULL;
+}
+
+
+//
+// Startup_Mold: C
+//
+void Startup_Mold(REBCNT size)
+{
+ REBYTE *cp;
+ REBYTE c;
+ const REBYTE *dc;
+
+ Init_Block(TASK_MOLD_STACK, Make_Array(size/10));
+ Init_String(TASK_UNI_BUF, Make_Unicode(size));
+
+ // Create quoted char escape table:
+ Char_Escapes = cp = ALLOC_N_ZEROFILL(REBYTE, MAX_ESC_CHAR + 1);
+ for (c = '@'; c <= '_'; c++) *cp++ = c;
+ Char_Escapes[cast(REBYTE, '\t')] = '-'; // tab
+ Char_Escapes[cast(REBYTE, '\n')] = '/'; // line feed
+ Char_Escapes[cast(REBYTE, '"')] = '"';
+ Char_Escapes[cast(REBYTE, '^')] = '^';
+
+ URL_Escapes = cp = ALLOC_N_ZEROFILL(REBYTE, MAX_URL_CHAR + 1);
+ //for (c = 0; c <= MAX_URL_CHAR; c++) if (IS_LEX_DELIMIT(c)) cp[c] = ESC_URL;
+ for (c = 0; c <= ' '; c++) cp[c] = ESC_URL | ESC_FILE;
+ dc = cb_cast(";%\"()[]{}<>");
+ for (c = LEN_BYTES(dc); c > 0; c--) URL_Escapes[*dc++] = ESC_URL | ESC_FILE;
+}
+
+
+//
+// Shutdown_Mold: C
+//
+void Shutdown_Mold(void)
{
- REBYTE *cp;
- REBYTE c;
- REBYTE *dc;
-
- Set_Root_Series(TASK_MOLD_LOOP, Make_Block(size/10), "mold loop");
- Set_Root_Series(TASK_BUF_MOLD, Make_Unicode(size), "mold buffer");
-
- // Create quoted char escape table:
- Char_Escapes = cp = Make_Mem(MAX_ESC_CHAR+1); // cleared
- for (c = '@'; c <= '_'; c++) *cp++ = c;
- Char_Escapes[TAB] = '-';
- Char_Escapes[LF] = '/';
- Char_Escapes['"'] = '"';
- Char_Escapes['^'] = '^';
-
- URL_Escapes = cp = Make_Mem(MAX_URL_CHAR+1); // cleared
- //for (c = 0; c <= MAX_URL_CHAR; c++) if (IS_LEX_DELIMIT(c)) cp[c] = ESC_URL;
- for (c = 0; c <= ' '; c++) cp[c] = ESC_URL | ESC_FILE;
- dc = ";%\"()[]{}<>";
- for (c = LEN_BYTES(dc); c > 0; c--) URL_Escapes[*dc++] = ESC_URL | ESC_FILE;
+ FREE_N(REBYTE, MAX_ESC_CHAR + 1, Char_Escapes);
+ FREE_N(REBYTE, MAX_URL_CHAR + 1, URL_Escapes);
}
diff --git a/src/core/s-ops.c b/src/core/s-ops.c
old mode 100644
new mode 100755
index 7c755caa09..767e439d59
--- a/src/core/s-ops.c
+++ b/src/core/s-ops.c
@@ -1,776 +1,798 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: s-ops.c
-** Summary: string handling utilities
-** Section: strings
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %s-ops.c
+// Summary: "string handling utilities"
+// Section: strings
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#include "sys-scan.h"
-/*********************************************************************
-**
-*/ REBOOL Is_Not_ASCII(REBYTE *bp, REBCNT len)
-/*
-** Returns TRUE if byte string uses upper code page.
-**
-***********************************************************************/
+//
+// All_Bytes_ASCII: C
+//
+// Returns TRUE if byte string does not use upper code page
+// (e.g. no 128-255 characters)
+//
+REBOOL All_Bytes_ASCII(REBYTE *bp, REBCNT len)
{
- for (; len > 0; len--, bp++)
- if (*bp >= 0x80) return TRUE;
+ for (; len > 0; len--, bp++)
+ if (*bp >= 0x80) return FALSE;
- return FALSE;
+ return TRUE;
}
-/*********************************************************************
-**
-*/ REBOOL Is_Wide(REBUNI *up, REBCNT len)
-/*
-** Returns TRUE if uni string needs 16 bits.
-**
-***********************************************************************/
+//
+// Is_Wide: C
+//
+// Returns TRUE if uni string needs 16 bits.
+//
+REBOOL Is_Wide(const REBUNI *up, REBCNT len)
{
- for (; len > 0; len--, up++)
- if (*up >= 0x100) return TRUE;
+ for (; len > 0; len--, up++)
+ if (*up >= 0x100) return TRUE;
- return FALSE;
+ return FALSE;
}
-/*********************************************************************
-**
-*/ REBYTE *Qualify_String(REBVAL *val, REBINT max_len, REBCNT *length, REBINT opts)
-/*
-** Prequalifies a string before using it with a function that
-** expects it to be 8-bits.
-**
-** Returns a temporary string and sets the length field.
-**
-** Opts can be:
-** 0 - no special options
-** 1 - allow UTF8 (val is converted to UTF8 during qualification)
-** 2 - allow binary
-**
-** Checks or converts it:
-**
-** 1. it is byte string (not unicode)
-** 2. if unicode, copy and return as temp byte string
-** 3. it's actual content (less space, newlines) <= max len
-** 4. it does not contain other values ("123 456")
-** 5. it's not empty or only whitespace
-**
-** Notes:
-*
-** 1. This function will TRAP on errors.
-** 2. Do not recursively use it (internal buffer)
-**
-***********************************************************************/
-{
- REBCNT tail = VAL_TAIL(val);
- REBCNT index = VAL_INDEX(val);
- REBCNT len;
- REBUNI c;
- REBYTE *bp;
- REBSER *src = VAL_SERIES(val);
-
- if (index > tail) Trap0(RE_PAST_END);
-
- Resize_Series(BUF_FORM, max_len+1);
- bp = BIN_HEAD(BUF_FORM);
-
- // Skip leading whitespace:
- for (; index < tail; index++) {
- c = GET_ANY_CHAR(src, index);
- if (!IS_SPACE(c)) break;
- }
-
- // Copy chars that are valid:
- for (; index < tail; index++) {
- c = GET_ANY_CHAR(src, index);
- if (opts < 2 && c >= 0x80) {
- if (opts == 0) Trap0(RE_INVALID_CHARS);
- len = Encode_UTF8_Char(bp, c);
- max_len -= len;
- bp += len;
- }
- else if (!IS_SPACE(c)) {
- *bp++ = (REBYTE)c;
- max_len--;
- }
- else break;
- if (max_len < 0)
- Trap0(RE_TOO_LONG);
- }
-
- // Rest better be just spaces:
- for (; index < tail; index++) {
- c = GET_ANY_CHAR(src, index);
- if (!IS_SPACE(c)) Trap0(RE_INVALID_CHARS);
- }
-
- *bp= 0;
-
- len = bp - BIN_HEAD(BUF_FORM);
- if (len == 0) Trap0(RE_TOO_SHORT);
-
- if (length) *length = len;
-
- return BIN_HEAD(BUF_FORM);
+//
+// Temp_Byte_Chars_May_Fail: C
+//
+// NOTE: This function returns a temporary result, and uses an internal
+// buffer. Do not use it recursively. Also, it will Trap on errors.
+//
+// Prequalifies a string before using it with a function that
+// expects it to be 8-bits. It would be used for instance to convert
+// a string that is potentially REBUNI-wide into a form that can be used
+// with a Scan_XXX routine, that is expecting ASCII or UTF-8 source.
+// (Many TO-XXX conversions from STRING re-use that scanner logic.)
+//
+// Returns a temporary string and sets the length field.
+//
+// If `allow_utf8`, the constructed result is converted to UTF8.
+//
+// Checks or converts it:
+//
+// 1. it is byte string (not unicode)
+// 2. if unicode, copy and return as temp byte string
+// 3. it's actual content (less space, newlines) <= max len
+// 4. it does not contain other values ("123 456")
+// 5. it's not empty or only whitespace
+//
+REBYTE *Temp_Byte_Chars_May_Fail(
+ const REBVAL *val,
+ REBINT max_len,
+ REBCNT *length,
+ REBOOL allow_utf8
+) {
+ REBCNT tail = VAL_LEN_HEAD(val);
+ REBCNT index = VAL_INDEX(val);
+ REBCNT len;
+ REBUNI c;
+ REBYTE *bp;
+ REBSER *src = VAL_SERIES(val);
+
+ if (index > tail) fail (Error_Past_End_Raw());
+
+ Resize_Series(BYTE_BUF, max_len+1);
+ bp = BIN_HEAD(BYTE_BUF);
+
+ // Skip leading whitespace:
+ for (; index < tail; index++) {
+ c = GET_ANY_CHAR(src, index);
+ if (!IS_SPACE(c)) break;
+ }
+
+ // Copy chars that are valid:
+ for (; index < tail; index++) {
+ c = GET_ANY_CHAR(src, index);
+ if (c >= 0x80) {
+ if (!allow_utf8) fail (Error_Invalid_Chars_Raw());
+
+ len = Encode_UTF8_Char(bp, c);
+ max_len -= len;
+ bp += len;
+ }
+ else if (!IS_SPACE(c)) {
+ *bp++ = (REBYTE)c;
+ max_len--;
+ }
+ else break;
+ if (max_len < 0)
+ fail (Error_Too_Long_Raw());
+ }
+
+ // Rest better be just spaces:
+ for (; index < tail; index++) {
+ c = GET_ANY_CHAR(src, index);
+ if (!IS_SPACE(c)) fail (Error_Invalid_Chars_Raw());
+ }
+
+ *bp = '\0';
+
+ len = bp - BIN_HEAD(BYTE_BUF);
+ if (len == 0) fail (Error_Too_Short_Raw());
+
+ if (length) *length = len;
+
+ return BIN_HEAD(BYTE_BUF);
}
-/*********************************************************************
-**
-*/ REBSER *Prep_Bin_Str(REBVAL *val, REBCNT *index, REBCNT *length)
-/*
-** Determines if UTF8 conversion is needed for a series before it
-** is used with a byte-oriented function.
-**
-** If conversion is needed, a temp series is returned with the UTF8.
-** Otherwise, the source series is returned as-is.
-**
-** The UTF8 flags that val is converted to UTF8 during qualification.
-**
-** Do not recursively use it (because of internal buffer).
-**
-***********************************************************************/
+//
+// Temp_Bin_Str_Managed: C
+//
+// Determines if UTF8 conversion is needed for a series before it
+// is used with a byte-oriented function.
+//
+// If conversion is needed, a UTF8 series will be created. Otherwise,
+// the source series is returned as-is.
+//
+// Note: This routine should only be used to generate a value used
+// for temporary purposes, because it has a "surprising variance"
+// regarding its input. If the value's series can be reused, it is--
+// and this depends on an implementation detail of internal encoding
+// that the user should not be aware of (they need not know if the
+// internal representation of an ASCII string uses 1, 2, or however
+// many bytes). But copying vs. non-copying means the resulting
+// data might or might not have previous values available to step
+// back into from the originating series!
+//
+// !!! Should performance dictate it, the callsites could be
+// adapted to know whether this produced a new series or not, and
+// instead of managing a created result they could be responsible
+// for freeing it if so.
+//
+REBSER *Temp_Bin_Str_Managed(const RELVAL *val, REBCNT *index, REBCNT *length)
{
- REBCNT idx = VAL_INDEX(val);
- REBCNT len;
- REBSER *ser = 0;
-
- len = (length && *length) ? *length : VAL_LEN(val);
-
- // Is it binary? If so, then no conversion needed.
- if (IS_BINARY(val) || len == 0)
- ser = VAL_SERIES(val);
- else // Convert it if 16-bit or has latin-1 upper chars.
- if (NZ(ser = Encode_UTF8_Value(val, len, ENCF_NO_COPY))) {
- idx = 0;
- len = SERIES_TAIL(ser);
- }
- else ser = VAL_SERIES(val);
-
- if (index) *index = idx;
- if (length) *length = len;
- return ser;
+ REBCNT len = (length && *length) ? *length : VAL_LEN_AT(val);
+ REBSER *series;
+
+ assert(IS_BINARY(val) || ANY_STRING(val));
+
+ // !!! This used to check `len == 0` and reuse a zero length string.
+ // However, the zero length string could have the wrong width. We are
+ // expected to be returning a BYTE_SIZE() string, and that confused
+ // things. It's not a good idea to mutate the source string (e.g.
+ // reallocate under a new width) so consider having an EMPTY_BYTE_STRING
+ // like EMPTY_ARRAY which is protected to hand back.
+ //
+ if (
+ IS_BINARY(val)
+ || (
+ VAL_BYTE_SIZE(val)
+ && All_Bytes_ASCII(VAL_BIN_AT(val), VAL_LEN_AT(val))
+ )
+ ){
+ //
+ // It's BINARY!, or an ANY-STRING! whose codepoints are all values in
+ // ASCII (0x00 => 0x7F), hence not needing any UTF-8 encoding.
+ //
+ series = VAL_SERIES(val);
+ ASSERT_SERIES_MANAGED(series);
+
+ if (index)
+ *index = VAL_INDEX(val);
+ if (length)
+ *length = len;
+ }
+ else {
+ // UTF-8 conversion is required, and we manage the result.
+
+ series = Make_UTF8_From_Any_String(val, len, OPT_ENC_CRLF_MAYBE);
+ MANAGE_SERIES(series);
+
+ #if !defined(NDEBUG)
+ //
+ // Also, PROTECT the result in the debug build...because since the
+ // caller doesn't know if a new series was created or if the initial
+ // data is being used, they should not be modifying it! (We don't
+ // want to protect the original data, because we wouldn't know when
+ // we were allowed to unlock it...there's no later call in this
+ // model to clean up the series.)
+ {
+ DECLARE_LOCAL (protect);
+ Init_String(protect, series);
+
+ Protect_Value(protect, FLAGIT(PROT_SET));
+
+ // just a string...not /DEEP...shouldn't need to Uncolor()
+ }
+ #endif
+
+ if (index)
+ *index = 0;
+ if (length)
+ *length = SER_LEN(series);
+ }
+
+ assert(BYTE_SIZE(series));
+ return series;
}
-/***********************************************************************
-**
-*/ REBSER *Xandor_Binary(REBCNT action, REBVAL *value, REBVAL *arg)
-/*
-** Only valid for BINARY data.
-**
-***********************************************************************/
+//
+// Xandor_Binary: C
+//
+// Only valid for BINARY data.
+//
+REBSER *Xandor_Binary(REBCNT action, REBVAL *value, REBVAL *arg)
{
- REBSER *series;
- REBYTE *p0 = VAL_BIN_DATA(value);
- REBYTE *p1 = VAL_BIN_DATA(arg);
- REBYTE *p2;
- REBCNT i;
- REBCNT mt, t1, t0, t2;
-
- t0 = VAL_LEN(value);
- t1 = VAL_LEN(arg);
-
- mt = MIN(t0, t1); // smaller array size
- // For AND - result is size of shortest input:
-// if (action == A_AND || (action == 0 && t1 >= t0))
-// t2 = mt;
-// else
- t2 = MAX(t0, t1);
-
- series = Make_Binary(t2);
- SERIES_TAIL(series) = t2;
- p2 = BIN_HEAD(series);
-
- switch (action) {
- case A_AND:
- for (i = 0; i < mt; i++) *p2++ = *p0++ & *p1++;
- CLEAR(p2, t2 - mt);
- return series;
- case A_OR:
- for (i = 0; i < mt; i++) *p2++ = *p0++ | *p1++;
- break;
- case A_XOR:
- for (i = 0; i < mt; i++) *p2++ = *p0++ ^ *p1++;
- break;
- default:
- // special bit set case EXCLUDE:
- for (i = 0; i < mt; i++) *p2++ = *p0++ & ~*p1++;
- if (t0 > t1) memcpy(p2, p0, t0 - t1); // residual from first only
- return series;
- }
-
- // Copy the residual:
- memcpy(p2, ((t0 > t1) ? p0 : p1), t2 - mt);
- return series;
+ REBSER *series;
+ REBYTE *p0 = VAL_BIN_AT(value);
+ REBYTE *p1 = VAL_BIN_AT(arg);
+ REBYTE *p2;
+ REBCNT i;
+ REBCNT mt, t1, t0, t2;
+
+ t0 = VAL_LEN_AT(value);
+ t1 = VAL_LEN_AT(arg);
+
+ mt = MIN(t0, t1); // smaller array size
+ // For AND - result is size of shortest input:
+// if (action == A_AND || (action == 0 && t1 >= t0))
+// t2 = mt;
+// else
+ t2 = MAX(t0, t1);
+
+ if (IS_BITSET(value)) {
+ //
+ // Although bitsets and binaries share some implementation here,
+ // they have distinct allocation functions...and bitsets need
+ // to set the REBSER.misc.negated union field (BITS_NOT) as
+ // it would be illegal to read it if it were cleared via another
+ // element of the union.
+ //
+ assert(IS_BITSET(arg));
+ series = Make_Bitset(t2 * 8);
+ }
+ else {
+ // Ordinary binary
+ //
+ series = Make_Binary(t2);
+ SET_SERIES_LEN(series, t2);
+ }
+
+ p2 = BIN_HEAD(series);
+
+ switch (action) {
+ case SYM_AND_T: // and~
+ for (i = 0; i < mt; i++) *p2++ = *p0++ & *p1++;
+ CLEAR(p2, t2 - mt);
+ return series;
+
+ case SYM_OR_T: // or~
+ for (i = 0; i < mt; i++) *p2++ = *p0++ | *p1++;
+ break;
+
+ case SYM_XOR_T: // xor~
+ for (i = 0; i < mt; i++) *p2++ = *p0++ ^ *p1++;
+ break;
+
+ default:
+ // special bit set case EXCLUDE:
+ for (i = 0; i < mt; i++) *p2++ = *p0++ & ~*p1++;
+ if (t0 > t1) memcpy(p2, p0, t0 - t1); // residual from first only
+ return series;
+ }
+
+ // Copy the residual:
+ memcpy(p2, ((t0 > t1) ? p0 : p1), t2 - mt);
+ return series;
}
-/***********************************************************************
-**
-*/ REBSER *Complement_Binary(REBVAL *value)
-/*
-** Only valid for BINARY data.
-**
-***********************************************************************/
+//
+// Complement_Binary: C
+//
+// Only valid for BINARY data.
+//
+REBSER *Complement_Binary(REBVAL *value)
{
- REBSER *series;
- REBYTE *str = VAL_BIN_DATA(value);
- REBINT len = VAL_LEN(value);
- REBYTE *out;
-
- series = Make_Binary(len);
- SERIES_TAIL(series) = len;
- out = BIN_HEAD(series);
- for (; len > 0; len--)
- *out++ = ~ *str++;
-
- return series;
+ REBSER *series;
+ REBYTE *str = VAL_BIN_AT(value);
+ REBINT len = VAL_LEN_AT(value);
+ REBYTE *out;
+
+ series = Make_Binary(len);
+ SET_SERIES_LEN(series, len);
+ out = BIN_HEAD(series);
+ for (; len > 0; len--) {
+ *out++ = ~(*str);
+ ++str;
+ }
+
+ return series;
}
-/***********************************************************************
-**
-*/ void Shuffle_String(REBVAL *value, REBFLG secure)
-/*
-** Randomize a string. Return a new string series.
-** Handles both BYTE and UNICODE strings.
-**
-***********************************************************************/
+//
+// Shuffle_String: C
+//
+// Randomize a string. Return a new string series.
+// Handles both BYTE and UNICODE strings.
+//
+void Shuffle_String(REBVAL *value, REBOOL secure)
{
- REBCNT n;
- REBCNT k;
- REBSER *series = VAL_SERIES(value);
- REBCNT idx = VAL_INDEX(value);
- REBUNI swap;
-
- for (n = VAL_LEN(value); n > 1;) {
- k = idx + (REBCNT)Random_Int(secure) % n;
- n--;
- swap = GET_ANY_CHAR(series, k);
- SET_ANY_CHAR(series, k, GET_ANY_CHAR(series, n + idx));
- SET_ANY_CHAR(series, n + idx, swap);
- }
+ REBCNT n;
+ REBCNT k;
+ REBSER *series = VAL_SERIES(value);
+ REBCNT idx = VAL_INDEX(value);
+ REBUNI swap;
+
+ for (n = VAL_LEN_AT(value); n > 1;) {
+ k = idx + (REBCNT)Random_Int(secure) % n;
+ n--;
+ swap = GET_ANY_CHAR(series, k);
+ SET_ANY_CHAR(series, k, GET_ANY_CHAR(series, n + idx));
+ SET_ANY_CHAR(series, n + idx, swap);
+ }
}
-/*
-#define SEED_LEN 10
-static REBYTE seed_str[SEED_LEN] = {
- 249, 52, 217, 38, 207, 59, 216, 52, 222, 61 // xor "Sassenrath" #{AA55..}
-};
-// kp = seed_str; // Any seed constant.
-// klen = SEED_LEN;
-*/
-
-/***********************************************************************
-**
-*/ REBOOL Cloak(REBOOL decode, REBYTE *cp, REBCNT dlen, REBYTE *kp, REBCNT klen, REBFLG as_is)
-/*
-** Simple data scrambler. Quality depends on the key length.
-** Result is made in place (data string).
-**
-** The key (kp) is passed as a REBVAL or REBYTE (when klen is !0).
-**
-***********************************************************************/
+//
+// Trim_Tail: C
+//
+// Used to trim off hanging spaces during FORM and MOLD.
+//
+void Trim_Tail(REBSER *src, REBYTE chr)
{
- REBCNT i, n;
- REBYTE src[20];
- REBYTE dst[20];
-
- if (dlen == 0) return TRUE;
-
- // Decode KEY as VALUE field (binary, string, or integer)
- if (klen == 0) {
- REBVAL *val = (REBVAL*)kp;
- REBSER *ser;
-
- switch (VAL_TYPE(val)) {
- case REB_BINARY:
- kp = (void*)VAL_BIN_DATA(val);
- klen = VAL_LEN(val);
- break;
- case REB_STRING:
- ser = Prep_Bin_Str(val, &i, &klen); // result may be a SHARED BUFFER!
- kp = BIN_SKIP(ser, i);
- break;
- case REB_INTEGER:
- INT_TO_STR(VAL_INT64(val), dst);
- klen = LEN_BYTES(dst);
- as_is = FALSE;
- break;
- }
-
- if (klen == 0) return FALSE;
- }
-
- if (!as_is) {
- for (i = 0; i < 20; i++) src[i] = kp[i % klen];
- SHA1(src, 20, dst);
- klen = 20;
- kp = dst;
- }
-
- if (decode)
- for (i = dlen-1; i > 0; i--) cp[i] ^= cp[i-1] ^ kp[i % klen];
-
- // Change starting byte based all other bytes.
- n = 0xa5;
- for (i = 1; i < dlen; i++) n += cp[i];
- cp[0] ^= (REBYTE)n;
-
- if (!decode)
- for (i = 1; i < dlen; i++) cp[i] ^= cp[i-1] ^ kp[i % klen];
-
- return TRUE;
+ assert(NOT_SER_FLAG(src, SERIES_FLAG_ARRAY));
+
+ REBOOL unicode = NOT(BYTE_SIZE(src));
+ REBCNT tail;
+ REBUNI c;
+
+ for (tail = SER_LEN(src); tail > 0; tail--) {
+ c = unicode ? *UNI_AT(src, tail - 1) : *BIN_AT(src, tail - 1);
+ if (c != chr) break;
+ }
+ SET_SERIES_LEN(src, tail);
+ TERM_SEQUENCE(src);
}
-/***********************************************************************
-**
-*/ void Trim_Tail(REBSER *src, REBYTE chr)
-/*
-** Used to trim off hanging spaces during FORM and MOLD.
-**
-***********************************************************************/
+//
+// Deline_Bytes: C
+//
+// This function converts any combination of CR and
+// LF line endings to the internal REBOL line ending.
+// The new length of the buffer is returned.
+//
+REBCNT Deline_Bytes(REBYTE *buf, REBCNT len)
{
- REBOOL wide = !BYTE_SIZE(src);
- REBCNT tail;
- REBUNI c;
-
- for (tail = SERIES_TAIL(src); tail > 0; tail--) {
- c = wide ? *UNI_SKIP(src, tail-1) : (REBUNI)*BIN_SKIP(src, tail-1);
- if (c != (REBUNI)chr) break;
- }
- SERIES_TAIL(src) = tail;
- TERM_SERIES(src);
+ REBYTE c, *cp, *tp;
+
+ cp = tp = buf;
+ while (cp < buf + len) {
+ if ((c = *cp++) == LF) {
+ if (*cp == CR) cp++;
+ }
+ else if (c == CR) {
+ c = LF;
+ if (*cp == LF) cp++;
+ }
+ *tp++ = c;
+ }
+ *tp = 0;
+
+ return (REBCNT)(tp - buf);
}
-/***********************************************************************
-**
-*/ REBCNT Deline_Bytes(REBYTE *buf, REBCNT len)
-/*
-** This function converts any combination of CR and
-** LF line endings to the internal REBOL line ending.
-** The new length of the buffer is returned.
-**
-***********************************************************************/
+//
+// Deline_Uni: C
+//
+REBCNT Deline_Uni(REBUNI *buf, REBCNT len)
{
- REBYTE c, *cp, *tp;
-
- cp = tp = buf;
- while (cp < buf + len) {
- if ((c = *cp++) == LF) {
- if (*cp == CR) cp++;
- }
- else if (c == CR) {
- c = LF;
- if (*cp == LF) cp++;
- }
- *tp++ = c;
- }
- *tp = 0;
-
- return (REBCNT)(tp - buf);
+ REBUNI c, *cp, *tp;
+
+ cp = tp = buf;
+ while (cp < buf + len) {
+ if ((c = *cp++) == LF) {
+ if (*cp == CR) cp++;
+ }
+ else if (c == CR) {
+ c = LF;
+ if (*cp == LF) cp++;
+ }
+ *tp++ = c;
+ }
+ *tp = 0;
+
+ return (REBCNT)(tp - buf);
}
-/***********************************************************************
-**
-*/ REBCNT Deline_Uni(REBUNI *buf, REBCNT len)
-/*
-***********************************************************************/
+//
+// Enline_Bytes: C
+//
+void Enline_Bytes(REBSER *ser, REBCNT idx, REBCNT len)
{
- REBUNI c, *cp, *tp;
-
- cp = tp = buf;
- while (cp < buf + len) {
- if ((c = *cp++) == LF) {
- if (*cp == CR) cp++;
- }
- else if (c == CR) {
- c = LF;
- if (*cp == LF) cp++;
- }
- *tp++ = c;
- }
- *tp = 0;
-
- return (REBCNT)(tp - buf);
+ REBCNT cnt = 0;
+ REBYTE *bp;
+ REBYTE c = 0;
+ REBCNT tail;
+
+ // Calculate the size difference by counting the number of LF's
+ // that have no CR's in front of them.
+ bp = BIN_AT(ser, idx);
+ for (; len > 0; len--) {
+ if (*bp == LF && c != CR) cnt++;
+ c = *bp++;
+ }
+ if (cnt == 0) return;
+
+ // Extend series:
+ len = SER_LEN(ser); // before expansion
+ EXPAND_SERIES_TAIL(ser, cnt);
+ tail = SER_LEN(ser); // after expansion
+ bp = BIN_HEAD(ser); // expand may change it
+
+ // Add missing CRs:
+ while (cnt > 0) {
+ bp[tail--] = bp[len]; // Copy src to dst.
+ if (bp[len] == LF && (len == 0 || bp[len - 1] != CR)) {
+ bp[tail--] = CR;
+ cnt--;
+ }
+ len--;
+ }
}
-/***********************************************************************
-**
-*/ void Enline_Bytes(REBSER *ser, REBCNT idx, REBCNT len)
-/*
-***********************************************************************/
+//
+// Enline_Uni: C
+//
+void Enline_Uni(REBSER *ser, REBCNT idx, REBCNT len)
{
- REBCNT cnt = 0;
- REBYTE *bp;
- REBYTE c = 0;
- REBCNT tail;
-
- // Calculate the size difference by counting the number of LF's
- // that have no CR's in front of them.
- bp = BIN_SKIP(ser, idx);
- for (; len > 0; len--) {
- if (*bp == LF && c != CR) cnt++;
- c = *bp++;
- }
- if (cnt == 0) return;
-
- // Extend series:
- len = SERIES_TAIL(ser); // before expansion
- EXPAND_SERIES_TAIL(ser, cnt);
- tail = SERIES_TAIL(ser); // after expansion
- bp = BIN_HEAD(ser); // expand may change it
-
- // Add missing CRs:
- while (cnt > 0) {
- bp[tail--] = bp[len]; // Copy src to dst.
- if (bp[len--] == LF && bp[len] != CR) {
- bp[tail--] = CR;
- cnt--;
- }
- }
+ REBCNT cnt = 0;
+ REBUNI *bp;
+ REBUNI c = 0;
+ REBCNT tail;
+
+ // Calculate the size difference by counting the number of LF's
+ // that have no CR's in front of them.
+ bp = UNI_AT(ser, idx);
+ for (; len > 0; len--) {
+ if (*bp == LF && c != CR) cnt++;
+ c = *bp++;
+ }
+ if (cnt == 0) return;
+
+ // Extend series:
+ len = SER_LEN(ser); // before expansion
+ EXPAND_SERIES_TAIL(ser, cnt);
+ tail = SER_LEN(ser); // after expansion
+ bp = UNI_HEAD(ser); // expand may change it
+
+ // Add missing CRs:
+ while (cnt > 0) {
+ bp[tail--] = bp[len]; // Copy src to dst.
+ if (bp[len] == LF && (len == 0 || bp[len - 1] != CR)) {
+ bp[tail--] = CR;
+ cnt--;
+ }
+ len--;
+ }
}
-/***********************************************************************
-**
-*/ void Enline_Uni(REBSER *ser, REBCNT idx, REBCNT len)
-/*
-***********************************************************************/
+//
+// Entab_Bytes: C
+//
+// Entab a string and return a new series.
+//
+REBSER *Entab_Bytes(REBYTE *bp, REBCNT index, REBCNT len, REBINT tabsize)
{
- REBCNT cnt = 0;
- REBUNI *bp;
- REBUNI c = 0;
- REBCNT tail;
-
- // Calculate the size difference by counting the number of LF's
- // that have no CR's in front of them.
- bp = UNI_SKIP(ser, idx);
- for (; len > 0; len--) {
- if (*bp == LF && c != CR) cnt++;
- c = *bp++;
- }
- if (cnt == 0) return;
-
- // Extend series:
- len = SERIES_TAIL(ser); // before expansion
- EXPAND_SERIES_TAIL(ser, cnt);
- tail = SERIES_TAIL(ser); // after expansion
- bp = UNI_HEAD(ser); // expand may change it
-
- // Add missing CRs:
- while (cnt > 0) {
- bp[tail--] = bp[len]; // Copy src to dst.
- if (bp[len--] == LF && bp[len] != CR) {
- bp[tail--] = CR;
- cnt--;
- }
- }
+ REBINT n = 0;
+ REBYTE *dp;
+ REBYTE c;
+
+ dp = Reset_Buffer(BYTE_BUF, len);
+
+ for (; index < len; index++) {
+
+ c = bp[index];
+
+ // Count leading spaces, insert TAB for each tabsize:
+ if (c == ' ') {
+ if (++n >= tabsize) {
+ *dp++ = '\t';
+ n = 0;
+ }
+ continue;
+ }
+
+ // Hitting a leading TAB resets space counter:
+ if (c == '\t') {
+ *dp++ = (REBYTE)c;
+ n = 0;
+ }
+ else {
+ // Incomplete tab space, pad with spaces:
+ for (; n > 0; n--) *dp++ = ' ';
+
+ // Copy chars thru end-of-line (or end of buffer):
+ while (index < len) {
+ if ((*dp++ = bp[index++]) == '\n') break;
+ }
+ }
+ }
+
+ return Copy_Buffer(BYTE_BUF, 0, dp);
}
-/***********************************************************************
-**
-*/ REBSER *Entab_Bytes(REBYTE *bp, REBCNT index, REBCNT len, REBINT tabsize)
-/*
-** Entab a string and return a new series.
-**
-***********************************************************************/
+//
+// Entab_Unicode: C
+//
+// Entab a string and return a new series.
+//
+REBSER *Entab_Unicode(REBUNI *bp, REBCNT index, REBCNT len, REBINT tabsize)
{
- REBINT n = 0;
- REBYTE *dp;
- REBYTE c;
-
- dp = Reset_Buffer(BUF_FORM, len);
-
- for (; index < len; index++) {
-
- c = bp[index];
-
- // Count leading spaces, insert TAB for each tabsize:
- if (c == ' ') {
- if (++n >= tabsize) {
- *dp++ = '\t';
- n = 0;
- }
- continue;
- }
-
- // Hitting a leading TAB resets space counter:
- if (c == '\t') {
- *dp++ = (REBYTE)c;
- n = 0;
- }
- else {
- // Incomplete tab space, pad with spaces:
- for (; n > 0; n--) *dp++ = ' ';
-
- // Copy chars thru end-of-line (or end of buffer):
- while (index < len) {
- if ((*dp++ = bp[index++]) == '\n') break;
- }
- }
- }
-
- return Copy_Buffer(BUF_FORM, dp);
+ REBINT n = 0;
+ REBUNI *dp;
+ REBUNI c;
+
+ REB_MOLD mo;
+ CLEARS(&mo);
+ mo.opts = MOPT_RESERVE;
+ mo.reserve = len;
+
+ Push_Mold(&mo);
+ dp = UNI_AT(mo.series, mo.start);
+
+ for (; index < len; index++) {
+
+ c = bp[index];
+
+ // Count leading spaces, insert TAB for each tabsize:
+ if (c == ' ') {
+ if (++n >= tabsize) {
+ *dp++ = '\t';
+ n = 0;
+ }
+ continue;
+ }
+
+ // Hitting a leading TAB resets space counter:
+ if (c == '\t') {
+ *dp++ = (REBYTE)c;
+ n = 0;
+ }
+ else {
+ // Incomplete tab space, pad with spaces:
+ for (; n > 0; n--) *dp++ = ' ';
+
+ // Copy chars thru end-of-line (or end of buffer):
+ while (index < len) {
+ if ((*dp++ = bp[index++]) == '\n') break;
+ }
+ }
+ }
+
+ TERM_UNI_LEN(
+ mo.series,
+ mo.start + cast(REBCNT, dp - UNI_AT(mo.series, mo.start))
+ );
+
+ return Pop_Molded_String(&mo);
}
-/***********************************************************************
-**
-*/ REBSER *Entab_Unicode(REBUNI *bp, REBCNT index, REBCNT len, REBINT tabsize)
-/*
-** Entab a string and return a new series.
-**
-***********************************************************************/
+//
+// Detab_Bytes: C
+//
+// Detab a string and return a new series.
+//
+REBSER *Detab_Bytes(REBYTE *bp, REBCNT index, REBCNT len, REBINT tabsize)
{
- REBINT n = 0;
- REBUNI *dp;
- REBUNI c;
-
- dp = (REBUNI *)Reset_Buffer(BUF_MOLD, len);
-
- for (; index < len; index++) {
-
- c = bp[index];
-
- // Count leading spaces, insert TAB for each tabsize:
- if (c == ' ') {
- if (++n >= tabsize) {
- *dp++ = '\t';
- n = 0;
- }
- continue;
- }
-
- // Hitting a leading TAB resets space counter:
- if (c == '\t') {
- *dp++ = (REBYTE)c;
- n = 0;
- }
- else {
- // Incomplete tab space, pad with spaces:
- for (; n > 0; n--) *dp++ = ' ';
-
- // Copy chars thru end-of-line (or end of buffer):
- while (index < len) {
- if ((*dp++ = bp[index++]) == '\n') break;
- }
- }
- }
-
- return Copy_Buffer(BUF_MOLD, dp);
-}
+ REBCNT cnt = 0;
+ REBCNT n;
+ REBYTE *dp;
+ REBYTE c;
+ // Estimate new length based on tab expansion:
+ for (n = index; n < len; n++)
+ if (bp[n] == '\t') // tab character
+ ++cnt;
-/***********************************************************************
-**
-*/ REBSER *Detab_Bytes(REBYTE *bp, REBCNT index, REBCNT len, REBINT tabsize)
-/*
-** Detab a string and return a new series.
-**
-***********************************************************************/
-{
- REBCNT cnt = 0;
- REBCNT n;
- REBYTE *dp;
- REBYTE c;
-
- // Estimate new length based on tab expansion:
- for (n = index; n < len; n++)
- if (bp[n] == TAB) cnt++;
+ dp = Reset_Buffer(BYTE_BUF, len + (cnt * (tabsize-1)));
- dp = Reset_Buffer(BUF_FORM, len + (cnt * (tabsize-1)));
+ n = 0;
+ while (index < len) {
- n = 0;
- while (index < len) {
+ c = bp[index++];
- c = bp[index++];
+ if (c == '\t') {
+ *dp++ = ' ';
+ n++;
+ for (; n % tabsize != 0; n++) *dp++ = ' ';
+ continue;
+ }
- if (c == '\t') {
- *dp++ = ' ';
- n++;
- for (; n % tabsize != 0; n++) *dp++ = ' ';
- continue;
- }
+ if (c == '\n') n = 0;
+ else n++;
- if (c == '\n') n = 0;
- else n++;
+ *dp++ = c;
+ }
- *dp++ = c;
- }
-
- return Copy_Buffer(BUF_FORM, dp);
+ return Copy_Buffer(BYTE_BUF, 0, dp);
}
-/***********************************************************************
-**
-*/ REBSER *Detab_Unicode(REBUNI *bp, REBCNT index, REBCNT len, REBINT tabsize)
-/*
-** Detab a unicode string and return a new series.
-**
-***********************************************************************/
+//
+// Detab_Unicode: C
+//
+// Detab a unicode string and return a new series.
+//
+REBSER *Detab_Unicode(REBUNI *bp, REBCNT index, REBCNT len, REBINT tabsize)
{
- REBCNT cnt = 0;
- REBCNT n;
- REBUNI *dp;
- REBUNI c;
+ REBCNT cnt = 0;
+ REBCNT n;
+ REBUNI *dp;
+ REBUNI c;
+
+ REB_MOLD mo;
+ CLEARS(&mo);
+
+ // Estimate new length based on tab expansion:
+ for (n = index; n < len; n++)
+ if (bp[n] == '\t') // tab character
+ ++cnt;
- // Estimate new length based on tab expansion:
- for (n = index; n < len; n++)
- if (bp[n] == TAB) cnt++;
+ mo.opts = MOPT_RESERVE;
+ mo.reserve = len + (cnt * (tabsize - 1));
- dp = (REBUNI *)Reset_Buffer(BUF_MOLD, len + (cnt * (tabsize-1)));
+ Push_Mold(&mo);
+ dp = UNI_AT(mo.series, mo.start);
+ n = 0;
+ while (index < len) {
- n = 0;
- while (index < len) {
+ c = bp[index++];
- c = bp[index++];
+ if (c == '\t') {
+ *dp++ = ' ';
+ n++;
+ for (; n % tabsize != 0; n++) *dp++ = ' ';
+ continue;
+ }
- if (c == '\t') {
- *dp++ = ' ';
- n++;
- for (; n % tabsize != 0; n++) *dp++ = ' ';
- continue;
- }
+ if (c == '\n') n = 0;
+ else n++;
- if (c == '\n') n = 0;
- else n++;
+ *dp++ = c;
+ }
- *dp++ = c;
- }
+ TERM_UNI_LEN(
+ mo.series,
+ mo.start + cast(REBCNT, dp - UNI_AT(mo.series, mo.start))
+ );
- return Copy_Buffer(BUF_MOLD, dp);
+ return Pop_Molded_String(&mo);
}
-/***********************************************************************
-**
-*/ void Change_Case(REBVAL *ds, REBVAL *val, REBVAL *part, REBOOL upper)
-/*
-** Common code for string case handling.
-**
-***********************************************************************/
+//
+// Change_Case: C
+//
+// Common code for string case handling.
+//
+void Change_Case(REBVAL *out, REBVAL *val, REBVAL *part, REBOOL upper)
{
- REBCNT len;
- REBCNT n;
-
- *D_RET = *val;
-
- if (IS_CHAR(val)) {
- REBUNI c = VAL_CHAR(val);
- if (c < UNICODE_CASES) {
- c = upper ? UP_CASE(c) : LO_CASE(c);
- }
- VAL_CHAR(D_RET) = c;
- return;
- }
-
- // String series:
-
- if (IS_PROTECT_SERIES(VAL_SERIES(val))) Trap0(RE_PROTECTED);
-
- len = Partial(val, 0, part, 0);
- n = VAL_INDEX(val);
- len += n;
-
- if (VAL_BYTE_SIZE(val)) {
- REBYTE *bp = VAL_BIN(val);
- if (upper)
- for (; n < len; n++) bp[n] = (REBYTE)UP_CASE(bp[n]);
- else {
- for (; n < len; n++) bp[n] = (REBYTE)LO_CASE(bp[n]);
- }
- } else {
- REBUNI *up = VAL_UNI(val);
- if (upper) {
- for (; n < len; n++) {
- if (up[n] < UNICODE_CASES) up[n] = UP_CASE(up[n]);
- }
- }
- else {
- for (; n < len; n++) {
- if (up[n] < UNICODE_CASES) up[n] = LO_CASE(up[n]);
- }
- }
- }
+ REBCNT len;
+ REBCNT n;
+
+ Move_Value(out, val);
+
+ if (IS_CHAR(val)) {
+ REBUNI c = VAL_CHAR(val);
+ if (c < UNICODE_CASES) {
+ c = upper ? UP_CASE(c) : LO_CASE(c);
+ }
+ VAL_CHAR(out) = c;
+ return;
+ }
+
+ // String series:
+
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(val));
+
+ len = Partial(val, 0, part);
+ n = VAL_INDEX(val);
+ len += n;
+
+ if (VAL_BYTE_SIZE(val)) {
+ REBYTE *bp = VAL_BIN(val);
+ if (upper)
+ for (; n < len; n++) bp[n] = (REBYTE)UP_CASE(bp[n]);
+ else {
+ for (; n < len; n++) bp[n] = (REBYTE)LO_CASE(bp[n]);
+ }
+ } else {
+ REBUNI *up = VAL_UNI(val);
+ if (upper) {
+ for (; n < len; n++) {
+ if (up[n] < UNICODE_CASES) up[n] = UP_CASE(up[n]);
+ }
+ }
+ else {
+ for (; n < len; n++) {
+ if (up[n] < UNICODE_CASES) up[n] = LO_CASE(up[n]);
+ }
+ }
+ }
}
-/***********************************************************************
-**
-*/ REBSER *Split_Lines(REBVAL *val)
-/*
-** Given a string series, split lines on CR-LF.
-** Series can be bytes or Unicode.
-**
-***********************************************************************/
+//
+// Split_Lines: C
+//
+// Given a string series, split lines on CR-LF.
+// Series can be bytes or Unicode.
+//
+REBARR *Split_Lines(REBVAL *str)
{
- REBSER *ser = BUF_EMIT; // GC protected (because it is emit buffer)
- REBSER *str = VAL_SERIES(val);
- REBCNT len = VAL_LEN(val);
- REBCNT idx = VAL_INDEX(val);
- REBCNT start = idx;
- REBSER *out;
- REBCHR c;
-
- BLK_RESET(ser);
-
- while (idx < len) {
- c = GET_ANY_CHAR(str, idx);
- if (c == LF || c == CR) {
- out = Copy_String(str, start, idx - start);
- val = Append_Value(ser);
- SET_STRING(val, out);
- VAL_SET_LINE(val);
- idx++;
- if (c == CR && GET_ANY_CHAR(str, idx) == LF) idx++;
- start = idx;
- }
- else idx++;
- }
- // Possible remainder (no terminator)
- if (idx > start) {
- out = Copy_String(str, start, idx - start);
- val = Append_Value(ser);
- SET_STRING(val, out);
- VAL_SET_LINE(val);
- }
-
- return Copy_Block(ser, 0);
+ REBDSP dsp_orig = DSP;
+
+ REBSER *s = VAL_SERIES(str);
+ REBCNT len = VAL_LEN_AT(str);
+ REBCNT i = VAL_INDEX(str);
+
+ REBCNT start = i;
+
+ while (i < len) {
+ REBUNI c = GET_ANY_CHAR(s, i);
+ if (c == LF || c == CR) {
+ DS_PUSH_TRASH;
+ Init_String(
+ DS_TOP,
+ Copy_String_Slimming(s, start, i - start)
+ );
+ SET_VAL_FLAG(DS_TOP, VALUE_FLAG_LINE);
+ ++i;
+ if (c == CR && GET_ANY_CHAR(s, i) == LF)
+ ++i;
+ start = i;
+ }
+ else
+ ++i;
+ }
+ // Possible remainder (no terminator)
+ if (i > start) {
+ DS_PUSH_TRASH;
+ Init_String(
+ DS_TOP,
+ Copy_String_Slimming(s, start, i - start)
+ );
+ SET_VAL_FLAG(DS_TOP, VALUE_FLAG_LINE);
+ }
+
+ return Pop_Stack_Values(dsp_orig);
}
diff --git a/src/core/s-trim.c b/src/core/s-trim.c
index 4ee6e0ca66..96aaac4636 100644
--- a/src/core/s-trim.c
+++ b/src/core/s-trim.c
@@ -1,295 +1,279 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: s-trim.c
-** Summary: string trimming
-** Section: strings
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %s-trim.c
+// Summary: "string trimming"
+// Section: strings
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-static REBFLG find_in_uni(REBUNI *up, REBINT len, REBUNI c)
+static REBOOL find_in_uni(REBUNI *up, REBINT len, REBUNI c)
{
- while (len-- > 0) if (*up++ == c) return TRUE;
- return FALSE;
+ while (len-- > 0) if (*up++ == c) return TRUE;
+ return FALSE;
}
-/***********************************************************************
-**
-*/ static void replace_with(REBSER *ser, REBCNT index, REBCNT tail, REBVAL *with)
-/*
-** Replace whitespace chars that match WITH string.
-**
-** Resulting string is always smaller than it was to start.
-**
-***********************************************************************/
-{
- #define MAX_WITH 32
- REBCNT wlen;
- REBUNI with_chars[MAX_WITH]; // chars to be trimmed
- REBUNI *up = with_chars;
- REBYTE *bp;
- REBCNT n;
- REBUNI uc;
-
- // Setup WITH array from arg or the default:
- n = 0;
- if (IS_NONE(with)) {
- bp = "\n \r\t";
- wlen = n = 4;
- }
- else if (IS_CHAR(with)) {
- wlen = 1;
- *up++ = VAL_CHAR(with);
- }
- else if (IS_INTEGER(with)) {
- wlen = 1;
- *up++ = Int32s(with, 0);
- }
- else if (ANY_BINSTR(with)) {
- n = VAL_LEN(with);
- if (n >= MAX_WITH) n = MAX_WITH-1;
- wlen = n;
- if (VAL_BYTE_SIZE(with)) {
- bp = VAL_BIN_DATA(with);
- } else {
- memcpy(up, VAL_UNI_DATA(with), n * sizeof(REBUNI));
- n = 0;
- }
- }
- for (; n > 0; n--) *up++ = (REBUNI)*bp++;
-
- // Remove all occurances of chars found in WITH string:
- for (n = index; index < tail; index++) {
- uc = GET_ANY_CHAR(ser, index);
- if (!find_in_uni(with_chars, wlen, uc)) {
- SET_ANY_CHAR(ser, n, uc);
- n++;
- }
- }
-
- SET_ANY_CHAR(ser, n, 0);
- SERIES_TAIL(ser) = n;
-}
-
-
-/***********************************************************************
-**
-*/ static void trim_auto(REBSER *ser, REBCNT index, REBCNT tail)
-/*
-** Skip any blank lines and then determine indent of
-** first line and make the rest align with it.
-**
-** BUG!!! If the indentation uses TABS, then it could
-** fill past the source pointer!
-**
-***********************************************************************/
-{
- REBCNT out = index;
- REBCNT line;
- REBCNT len;
- REBCNT indent;
- REBUNI uc = 0;
-
- // Skip whitespace, remember start of last line:
- for (line = index; index < tail; index++) {
- uc = GET_ANY_CHAR(ser, index);
- if (!IS_WHITE(uc)) break;
- if (uc == LF) line = index+1;
- }
-
- // Count the indentation used:
- for (indent = 0; line < index; line++) {
- if (GET_ANY_CHAR(ser, line) == ' ') indent++;
- else indent = (indent + TAB_SIZE) & ~3;
- }
-
- // For each line, pad with necessary indentation:
- while (index < tail) {
- // Skip to next content, track indentation:
- for (len = 0; index < tail; index++) {
- uc = GET_ANY_CHAR(ser, index);
- if (!IS_SPACE(uc) || len >= indent) break;
- if (uc == ' ') len++;
- else len = (len + TAB_SIZE) & ~3;
- }
-
- // Indent the line:
- for (; len > indent; len--) {
- SET_ANY_CHAR(ser, out, ' ');
- out++;
- }
-
- // Copy line contents:
- while (index < tail) {
- uc = GET_ANY_CHAR(ser, index);
- SET_ANY_CHAR(ser, out, uc);
- out++;
- index++;
- if (uc == LF) break;
- }
- }
-
- SET_ANY_CHAR(ser, out, 0);
- SERIES_TAIL(ser) = out;
+//
+// Whitespace_Replace_With: C
+//
+// Replace whitespace chars that match WITH string.
+//
+// Resulting string is always smaller than it was to start.
+//
+void Whitespace_Replace_With(
+ REBSER *ser,
+ REBCNT index,
+ REBCNT tail,
+ const REBVAL *with
+) {
+ #define MAX_WITH 32
+ REBCNT wlen;
+ REBUNI with_chars[MAX_WITH]; // chars to be trimmed
+ REBUNI *up = with_chars;
+ const REBYTE *bp;
+ REBCNT n;
+ REBUNI uc;
+
+ // Setup WITH array from arg or the default:
+ n = 0;
+ if (IS_VOID(with)) {
+ bp = cb_cast("\n \r\t");
+ wlen = n = 4;
+ }
+ else if (IS_CHAR(with)) {
+ wlen = 1;
+ *up++ = VAL_CHAR(with);
+ }
+ else if (IS_INTEGER(with)) {
+ wlen = 1;
+ *up++ = Int32s(with, 0);
+ }
+ else {
+ assert(ANY_BINSTR(with));
+ n = VAL_LEN_AT(with);
+ if (n >= MAX_WITH) n = MAX_WITH-1;
+ wlen = n;
+ if (VAL_BYTE_SIZE(with)) {
+ bp = VAL_BIN_AT(with);
+ } else {
+ memcpy(up, VAL_UNI_AT(with), n * sizeof(REBUNI));
+ n = 0;
+ }
+ }
+
+ for (; n > 0; n--) *up++ = (REBUNI)*bp++;
+
+ // Remove all occurances of chars found in WITH string:
+ for (n = index; index < tail; index++) {
+ uc = GET_ANY_CHAR(ser, index);
+ if (!find_in_uni(with_chars, wlen, uc)) {
+ SET_ANY_CHAR(ser, n, uc);
+ n++;
+ }
+ }
+
+ SET_ANY_CHAR(ser, n, 0);
+ SET_SERIES_LEN(ser, n);
}
-/***********************************************************************
-**
-*/ static void trim_lines(REBSER *ser, REBCNT index, REBCNT tail)
-/*
-** Remove all newlines and extra space.
-**
-***********************************************************************/
+//
+// Trim_String_Auto: C
+//
+// Skip any blank lines and then determine indent of
+// first line and make the rest align with it.
+//
+// BUG!!! If the indentation uses TABS, then it could
+// fill past the source pointer!
+//
+void Trim_String_Auto(REBSER *ser, REBCNT index, REBCNT tail)
{
- REBINT pad = 1; // used to allow a single space
- REBUNI uc;
- REBCNT out = index;
-
- for (; index < tail; index++) {
- uc = GET_ANY_CHAR(ser, index);
- if (IS_WHITE(uc)) {
- uc = ' ';
- if (!pad) {
- SET_ANY_CHAR(ser, out, uc);
- out++;
- pad = 2;
- }
- }
- else {
- SET_ANY_CHAR(ser, out, uc);
- out++;
- pad = 0;
- }
- }
-
- // Remove extra end pad if found:
- if (pad == 2) out--;
-
- SET_ANY_CHAR(ser, out, 0);
- SERIES_TAIL(ser) = out;
+ REBCNT out = index;
+ REBCNT line;
+ REBCNT len;
+ REBCNT indent;
+ REBUNI uc = 0;
+
+ // Skip whitespace, remember start of last line:
+ for (line = index; index < tail; index++) {
+ uc = GET_ANY_CHAR(ser, index);
+ if (!IS_WHITE(uc)) break;
+ if (uc == LF) line = index+1;
+ }
+
+ // Count the indentation used:
+ for (indent = 0; line < index; line++) {
+ if (GET_ANY_CHAR(ser, line) == ' ') indent++;
+ else indent = (indent + TAB_SIZE) & ~3;
+ }
+
+ // For each line, pad with necessary indentation:
+ while (index < tail) {
+ // Skip to next content, track indentation:
+ for (len = 0; index < tail; index++) {
+ uc = GET_ANY_CHAR(ser, index);
+ if (!IS_SPACE(uc) || len >= indent) break;
+ if (uc == ' ') len++;
+ else len = (len + TAB_SIZE) & ~3;
+ }
+
+ // Indent the line:
+ for (; len > indent; len--) {
+ SET_ANY_CHAR(ser, out, ' ');
+ out++;
+ }
+
+ // Copy line contents:
+ while (index < tail) {
+ uc = GET_ANY_CHAR(ser, index);
+ SET_ANY_CHAR(ser, out, uc);
+ out++;
+ index++;
+ if (uc == LF) break;
+ }
+ }
+
+ SET_ANY_CHAR(ser, out, 0);
+ SET_SERIES_LEN(ser, out);
}
-/***********************************************************************
-**
-*/ static void trim_head_tail(REBSER *ser, REBCNT index, REBCNT tail, REBFLG h, REBFLG t)
-/*
-** Trim from head and tail of each line, trim any leading or
-** trailing lines as well, leaving one at the end if present
-**
-***********************************************************************/
+//
+// Trim_String_Lines: C
+//
+// Remove all newlines and extra space.
+//
+void Trim_String_Lines(REBSER *ser, REBCNT index, REBCNT tail)
{
- REBCNT out = index;
- REBOOL append_line_feed = FALSE;
- REBUNI uc;
-
- // Skip head lines if required:
- if (h || !t) {
- for (; index < tail; index++) {
- uc = GET_ANY_CHAR(ser, index);
- if (!IS_WHITE(uc)) break;
- }
- }
-
- // Skip tail lines if required:
- if (t || !h) {
- for (; index < tail; tail--) {
- uc = GET_ANY_CHAR(ser, tail -1);
- if (uc == LF) append_line_feed = TRUE;
- if (!IS_WHITE(uc)) break;
- }
- }
-
- // Trim head and tail of innner lines if required:
- if (!h && !t) {
- REBOOL outside = FALSE; // inside an inner line
- REBCNT left = 0; // index of leftmost space (in output)
-
- for (; index < tail; index++) {
-
- uc = GET_ANY_CHAR(ser, index);
-
- if (IS_SPACE(uc)) {
- if (outside) continue;
- if (!left) left = out;
- }
- else if (uc == LF) {
- outside = TRUE;
- if (left) out = left, left = 0;
- }
- else {
- outside = FALSE;
- left = 0;
- }
-
- SET_ANY_CHAR(ser, out, uc);
- out++;
- }
- }
- else {
- for (; index < tail; index++) {
- uc = GET_ANY_CHAR(ser, index);
- SET_ANY_CHAR(ser, out, uc);
- out++;
- }
- }
-
- // Append line feed if necessary
- if (append_line_feed && !t) {
- SET_ANY_CHAR(ser, out, LF);
- out++;
- }
-
- SET_ANY_CHAR(ser, out, 0);
- SERIES_TAIL(ser) = out;
+ REBINT pad = 1; // used to allow a single space
+ REBUNI uc;
+ REBCNT out = index;
+
+ for (; index < tail; index++) {
+ uc = GET_ANY_CHAR(ser, index);
+ if (IS_WHITE(uc)) {
+ uc = ' ';
+ if (!pad) {
+ SET_ANY_CHAR(ser, out, uc);
+ out++;
+ pad = 2;
+ }
+ }
+ else {
+ SET_ANY_CHAR(ser, out, uc);
+ out++;
+ pad = 0;
+ }
+ }
+
+ // Remove extra end pad if found:
+ if (pad == 2) out--;
+
+ SET_ANY_CHAR(ser, out, 0);
+ SET_SERIES_LEN(ser, out);
}
-/***********************************************************************
-**
-*/ void Trim_String(REBSER *ser, REBCNT index, REBCNT len, REBCNT flags, REBVAL *with)
-/*
-***********************************************************************/
-{
- REBCNT tail = index + len;
-
- // /all or /with
- if (flags & (AM_TRIM_ALL | AM_TRIM_WITH)) {
- replace_with(ser, index, tail, with);
- }
- // /auto option
- else if (flags & AM_TRIM_AUTO) {
- trim_auto(ser, index, tail);
- }
- // /lines option
- else if (flags & AM_TRIM_LINES) {
- trim_lines(ser, index, tail);
- }
- else {
- trim_head_tail(ser, index, tail, flags & AM_TRIM_HEAD, flags & AM_TRIM_TAIL);
- }
+//
+// Trim_String_Head_Tail: C
+//
+// Trim from head and tail of each line, trim any leading or
+// trailing lines as well, leaving one at the end if present
+//
+void Trim_String_Head_Tail(
+ REBSER *ser,
+ REBCNT index,
+ REBCNT tail,
+ REBOOL h,
+ REBOOL t
+) {
+ REBCNT out = index;
+ REBOOL append_line_feed = FALSE;
+ REBUNI uc;
+ if (tail == index){
+ return;
+ }
+ // Skip head lines if required:
+ if (h || !t) {
+ for (; index < tail; index++) {
+ uc = GET_ANY_CHAR(ser, index);
+ if (!IS_WHITE(uc)) break;
+ }
+ }
+
+ // Skip tail lines if required:
+ if (t || !h) {
+ for (; index < tail; tail--) {
+ uc = GET_ANY_CHAR(ser, tail -1);
+ if (uc == LF) append_line_feed = TRUE;
+ if (!IS_WHITE(uc)) break;
+ }
+ }
+
+ // Trim head and tail of innner lines if required:
+ if (!h && !t) {
+ REBOOL outside = FALSE; // inside an inner line
+ REBCNT left = 0; // index of leftmost space (in output)
+
+ for (; index < tail; index++) {
+
+ uc = GET_ANY_CHAR(ser, index);
+
+ if (IS_SPACE(uc)) {
+ if (outside) continue;
+ if (!left) left = out;
+ }
+ else if (uc == LF) {
+ outside = TRUE;
+ if (left) out = left, left = 0;
+ }
+ else {
+ outside = FALSE;
+ left = 0;
+ }
+
+ SET_ANY_CHAR(ser, out, uc);
+ out++;
+ }
+ }
+ else {
+ for (; index < tail; index++) {
+ uc = GET_ANY_CHAR(ser, index);
+ SET_ANY_CHAR(ser, out, uc);
+ out++;
+ }
+ }
+
+ // Append line feed if necessary
+ if (append_line_feed && !t) {
+ SET_ANY_CHAR(ser, out, LF);
+ out++;
+ }
+
+ SET_ANY_CHAR(ser, out, 0);
+ SET_SERIES_LEN(ser, out);
}
diff --git a/src/core/s-unicode.c b/src/core/s-unicode.c
index c6383ae9db..0e97249520 100644
--- a/src/core/s-unicode.c
+++ b/src/core/s-unicode.c
@@ -1,39 +1,40 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: s-unicode.c
-** Summary: unicode support functions
-** Section: strings
-** Author: Carl Sassenrath
-** Notes:
-** The top part of this code is from Unicode Inc. The second
-** part was added by REBOL Technologies.
-**
-***********************************************************************/
+//
+// Rebol 3 Language Interpreter and Run-time Environment
+// "Ren-C" branch @ https://github.com/metaeducation/ren-c
+// REBOL is a trademark of REBOL Technologies
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Project: Rebol 3 Interpreter and Run-time (Ren-C branch)
+// Homepage: https://github.com/metaeducation/ren-c/
+// File: %s-unicode.c
+// Summary: unicode support functions
+// Section: strings
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// The top part of this code is from Unicode Inc. The second
+// part was added by REBOL Technologies.
+//
/*
* Copyright 2001-2004 Unicode, Inc.
- *
+ *
* Disclaimer
- *
+ *
* This source code is provided as is by Unicode, Inc. No claims are
* made as to fitness for any particular purpose. No warranties of any
* kind are expressed or implied. The recipient agrees to determine
@@ -41,9 +42,9 @@
* purchased on magnetic or optical media from Unicode, Inc., the
* sole remedy for any claim will be exchange of defective media
* within 90 days of receipt.
- *
+ *
* Limitations on Rights to Redistribute This Code
- *
+ *
* Unicode, Inc. hereby grants the right to freely use the information
* supplied in this file in the creation of products supporting the
* Unicode Standard, and to make copies of this file in any form
@@ -53,60 +54,60 @@
/* ---------------------------------------------------------------------
- Conversions between UTF32, UTF-16, and UTF-8. Header file.
-
- Several funtions are included here, forming a complete set of
- conversions between the three formats. UTF-7 is not included
- here, but is handled in a separate source file.
-
- Each of these routines takes pointers to input buffers and output
- buffers. The input buffers are const.
-
- Each routine converts the text between *sourceStart and sourceEnd,
- putting the result into the buffer between *targetStart and
- targetEnd. Note: the end pointers are *after* the last item: e.g.
- *(sourceEnd - 1) is the last item.
-
- The return result indicates whether the conversion was successful,
- and if not, whether the problem was in the source or target buffers.
- (Only the first encountered problem is indicated.)
-
- After the conversion, *sourceStart and *targetStart are both
- updated to point to the end of last text successfully converted in
- the respective buffers.
-
- Input parameters:
- sourceStart - pointer to a pointer to the source buffer.
- The contents of this are modified on return so that
- it points at the next thing to be converted.
- targetStart - similarly, pointer to pointer to the target buffer.
- sourceEnd, targetEnd - respectively pointers to the ends of the
- two buffers, for overflow checking only.
-
- These conversion functions take a ConversionFlags argument. When this
- flag is set to strict, both irregular sequences and isolated surrogates
- will cause an error. When the flag is set to lenient, both irregular
- sequences and isolated surrogates are converted.
-
- Whether the flag is strict or lenient, all illegal sequences will cause
- an error return. This includes sequences such as: , ,
- or in UTF-8, and values above 0x10FFFF in UTF-32. Conformant code
- must check for illegal sequences.
-
- When the flag is set to lenient, characters over 0x10FFFF are converted
- to the replacement character; otherwise (when the flag is set to strict)
- they constitute an error.
-
- Output parameters:
- The value "sourceIllegal" is returned from some routines if the input
- sequence is malformed. When "sourceIllegal" is returned, the source
- value will point to the illegal value that caused the problem. E.g.,
- in UTF-8 when a sequence is malformed, it points to the start of the
- malformed sequence.
-
- Author: Mark E. Davis, 1994.
- Rev History: Rick McGowan, fixes & updates May 2001.
- Fixes & updates, Sept 2001.
+ Conversions between UTF32, UTF-16, and UTF-8. Header file.
+
+ Several funtions are included here, forming a complete set of
+ conversions between the three formats. UTF-7 is not included
+ here, but is handled in a separate source file.
+
+ Each of these routines takes pointers to input buffers and output
+ buffers. The input buffers are const.
+
+ Each routine converts the text between *sourceStart and sourceEnd,
+ putting the result into the buffer between *targetStart and
+ targetEnd. Note: the end pointers are *after* the last item: e.g.
+ *(sourceEnd - 1) is the last item.
+
+ The return result indicates whether the conversion was successful,
+ and if not, whether the problem was in the source or target buffers.
+ (Only the first encountered problem is indicated.)
+
+ After the conversion, *sourceStart and *targetStart are both
+ updated to point to the end of last text successfully converted in
+ the respective buffers.
+
+ Input parameters:
+ sourceStart - pointer to a pointer to the source buffer.
+ The contents of this are modified on return so that
+ it points at the next thing to be converted.
+ targetStart - similarly, pointer to pointer to the target buffer.
+ sourceEnd, targetEnd - respectively pointers to the ends of the
+ two buffers, for overflow checking only.
+
+ These conversion functions take a ConversionFlags argument. When this
+ flag is set to strict, both irregular sequences and isolated surrogates
+ will cause an error. When the flag is set to lenient, both irregular
+ sequences and isolated surrogates are converted.
+
+ Whether the flag is strict or lenient, all illegal sequences will cause
+ an error return. This includes sequences such as: , ,
+ or in UTF-8, and values above 0x10FFFF in UTF-32. Conformant code
+ must check for illegal sequences.
+
+ When the flag is set to lenient, characters over 0x10FFFF are converted
+ to the replacement character; otherwise (when the flag is set to strict)
+ they constitute an error.
+
+ Output parameters:
+ The value "sourceIllegal" is returned from some routines if the input
+ sequence is malformed. When "sourceIllegal" is returned, the source
+ value will point to the illegal value that caused the problem. E.g.,
+ in UTF-8 when a sequence is malformed, it points to the start of the
+ malformed sequence.
+
+ Author: Mark E. Davis, 1994.
+ Rev History: Rick McGowan, fixes & updates May 2001.
+ Fixes & updates, Sept 2001.
------------------------------------------------------------------------ */
@@ -114,17 +115,17 @@
/* ---------------------------------------------------------------------
- The following 4 definitions are compiler-specific.
- The C standard does not guarantee that wchar_t has at least
- 16 bits, so wchar_t is no less portable than unsigned short!
- All should be unsigned values to avoid sign extension during
- bit mask & shift operations.
+ The following 4 definitions are compiler-specific.
+ The C standard does not guarantee that wchar_t has at least
+ 16 bits, so wchar_t is no less portable than unsigned short!
+ All should be unsigned values to avoid sign extension during
+ bit mask & shift operations.
------------------------------------------------------------------------ */
-typedef unsigned long UTF32; /* at least 32 bits */
-typedef unsigned short UTF16; /* at least 16 bits */
-typedef unsigned char UTF8; /* typically 8 bits */
-typedef unsigned char Boolean; /* 0 or 1 */
+typedef unsigned long UTF32; /* at least 32 bits */
+typedef unsigned short UTF16; /* at least 16 bits */
+typedef unsigned char UTF8; /* typically 8 bits */
+typedef unsigned char Boolean; /* 0 or 1 */
/* Some fundamental constants */
#define UNI_REPLACEMENT_CHAR (UTF32)0x0000FFFD
@@ -134,77 +135,73 @@ typedef unsigned char Boolean; /* 0 or 1 */
#define UNI_MAX_LEGAL_UTF32 (UTF32)0x0010FFFF
typedef enum {
- conversionOK, /* conversion successful */
- sourceExhausted, /* partial character in source, but hit end */
- targetExhausted, /* insuff. room in target for conversion */
- sourceIllegal /* source sequence is illegal/malformed */
+ conversionOK, /* conversion successful */
+ sourceExhausted, /* partial character in source, but hit end */
+ targetExhausted, /* insuff. room in target for conversion */
+ sourceIllegal /* source sequence is illegal/malformed */
} ConversionResult;
typedef enum {
- strictConversion = 0,
- lenientConversion
+ strictConversion = 0,
+ lenientConversion
} ConversionFlags;
ConversionResult ConvertUTF8toUTF16 (
- const UTF8** sourceStart, const UTF8* sourceEnd,
- UTF16** targetStart, UTF16* targetEnd, ConversionFlags flags);
+ const UTF8** sourceStart, const UTF8* sourceEnd,
+ UTF16** targetStart, UTF16* targetEnd, ConversionFlags flags);
ConversionResult ConvertUTF16toUTF8 (
- const UTF16** sourceStart, const UTF16* sourceEnd,
- UTF8** targetStart, UTF8* targetEnd, ConversionFlags flags);
-
+ const UTF16** sourceStart, const UTF16* sourceEnd,
+ UTF8** targetStart, UTF8* targetEnd, ConversionFlags flags);
+
ConversionResult ConvertUTF8toUTF32 (
- const UTF8** sourceStart, const UTF8* sourceEnd,
- UTF32** targetStart, UTF32* targetEnd, ConversionFlags flags);
+ const UTF8** sourceStart, const UTF8* sourceEnd,
+ UTF32** targetStart, UTF32* targetEnd, ConversionFlags flags);
ConversionResult ConvertUTF32toUTF8 (
- const UTF32** sourceStart, const UTF32* sourceEnd,
- UTF8** targetStart, UTF8* targetEnd, ConversionFlags flags);
-
+ const UTF32** sourceStart, const UTF32* sourceEnd,
+ UTF8** targetStart, UTF8* targetEnd, ConversionFlags flags);
+
ConversionResult ConvertUTF16toUTF32 (
- const UTF16** sourceStart, const UTF16* sourceEnd,
- UTF32** targetStart, UTF32* targetEnd, ConversionFlags flags);
+ const UTF16** sourceStart, const UTF16* sourceEnd,
+ UTF32** targetStart, UTF32* targetEnd, ConversionFlags flags);
ConversionResult ConvertUTF32toUTF16 (
- const UTF32** sourceStart, const UTF32* sourceEnd,
- UTF16** targetStart, UTF16* targetEnd, ConversionFlags flags);
+ const UTF32** sourceStart, const UTF32* sourceEnd,
+ UTF16** targetStart, UTF16* targetEnd, ConversionFlags flags);
Boolean isLegalUTF8Sequence(const UTF8 *source, const UTF8 *sourceEnd);
/* ---------------------------------------------------------------------
- Conversions between UTF32, UTF-16, and UTF-8. Source code file.
- Author: Mark E. Davis, 1994.
- Rev History: Rick McGowan, fixes & updates May 2001.
- Sept 2001: fixed const & error conditions per
- mods suggested by S. Parent & A. Lillich.
- June 2002: Tim Dodd added detection and handling of incomplete
- source sequences, enhanced error detection, added casts
- to eliminate compiler warnings.
- July 2003: slight mods to back out aggressive FFFE detection.
- Jan 2004: updated switches in from-UTF8 conversions.
- Oct 2004: updated to use UNI_MAX_LEGAL_UTF32 in UTF-32 conversions.
+ Conversions between UTF32, UTF-16, and UTF-8. Source code file.
+ Author: Mark E. Davis, 1994.
+ Rev History: Rick McGowan, fixes & updates May 2001.
+ Sept 2001: fixed const & error conditions per
+ mods suggested by S. Parent & A. Lillich.
+ June 2002: Tim Dodd added detection and handling of incomplete
+ source sequences, enhanced error detection, added casts
+ to eliminate compiler warnings.
+ July 2003: slight mods to back out aggressive FFFE detection.
+ Jan 2004: updated switches in from-UTF8 conversions.
+ Oct 2004: updated to use UNI_MAX_LEGAL_UTF32 in UTF-32 conversions.
- See the header file "ConvertUTF.h" for complete documentation.
+ See the header file "ConvertUTF.h" for complete documentation.
------------------------------------------------------------------------ */
#ifdef CVTUTF_DEBUG
-#include
+// #include // !!! No in Ren-C release builds
#endif
-static const int halfShift = 10; /* used for shifting by 10 bits */
-
-static const UTF32 halfBase = 0x0010000UL;
-static const UTF32 halfMask = 0x3FFUL;
#define UNI_SUR_HIGH_START (UTF32)0xD800
#define UNI_SUR_HIGH_END (UTF32)0xDBFF
#define UNI_SUR_LOW_START (UTF32)0xDC00
#define UNI_SUR_LOW_END (UTF32)0xDFFF
-#define false 0
-#define true 1
+#define false 0
+#define true 1
/* --------------------------------------------------------------------- */
@@ -216,14 +213,14 @@ static const UTF32 halfMask = 0x3FFUL;
* allowed in earlier algorithms.
*/
static const char trailingBytesForUTF8[256] = {
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
- 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
- 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
+ 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5
};
/*
@@ -231,8 +228,8 @@ static const char trailingBytesForUTF8[256] = {
* This table contains as many values as there might be trailing bytes
* in a UTF-8 sequence.
*/
-static const UTF32 offsetsFromUTF8[6] = { 0x00000000UL, 0x00003080UL, 0x000E2080UL,
- 0x03C82080UL, 0xFA082080UL, 0x82082080UL };
+static const UTF32 offsetsFromUTF8[6] = { 0x00000000UL, 0x00003080UL, 0x000E2080UL,
+ 0x03C82080UL, 0xFA082080UL, 0x82082080UL };
/*
* Once the bits are split out into bytes of UTF-8, this is a mask OR-ed
@@ -245,110 +242,115 @@ static const UTF8 firstByteMark[7] = { 0x00, 0x00, 0xC0, 0xE0, 0xF0, 0xF8, 0xFC
/* --------------------------------------------------------------------- */
-#ifdef unused
+#ifdef USE_ARCHIVED_UTF8_SOURCE
+
+static const int halfShift = 10; /* used for shifting by 10 bits */
+
+static const UTF32 halfBase = 0x0010000UL;
+static const UTF32 halfMask = 0x3FFUL;
ConversionResult ConvertUTF32toUTF16 (
- const UTF32** sourceStart, const UTF32* sourceEnd,
- UTF16** targetStart, UTF16* targetEnd, ConversionFlags flags) {
- ConversionResult result = conversionOK;
- const UTF32* source = *sourceStart;
- UTF16* target = *targetStart;
- while (source < sourceEnd) {
- UTF32 ch;
- if (target >= targetEnd) {
- result = targetExhausted; break;
- }
- ch = *source++;
- if (ch <= UNI_MAX_BMP) { /* Target is a character <= 0xFFFF */
- /* UTF-16 surrogate values are illegal in UTF-32; 0xffff or 0xfffe are both reserved values */
- if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_LOW_END) {
- if (flags == strictConversion) {
- --source; /* return to the illegal value itself */
- result = sourceIllegal;
- break;
- } else {
- *target++ = UNI_REPLACEMENT_CHAR;
- }
- } else {
- *target++ = (UTF16)ch; /* normal case */
- }
- } else if (ch > UNI_MAX_LEGAL_UTF32) {
- if (flags == strictConversion) {
- result = sourceIllegal;
- } else {
- *target++ = UNI_REPLACEMENT_CHAR;
- }
- } else {
- /* target is a character in range 0xFFFF - 0x10FFFF. */
- if (target + 1 >= targetEnd) {
- --source; /* Back up source pointer! */
- result = targetExhausted; break;
- }
- ch -= halfBase;
- *target++ = (UTF16)((ch >> halfShift) + UNI_SUR_HIGH_START);
- *target++ = (UTF16)((ch & halfMask) + UNI_SUR_LOW_START);
- }
- }
- *sourceStart = source;
- *targetStart = target;
- return result;
+ const UTF32** sourceStart, const UTF32* sourceEnd,
+ UTF16** targetStart, UTF16* targetEnd, ConversionFlags flags) {
+ ConversionResult result = conversionOK;
+ const UTF32* source = *sourceStart;
+ UTF16* target = *targetStart;
+ while (source < sourceEnd) {
+ UTF32 ch;
+ if (target >= targetEnd) {
+ result = targetExhausted; break;
+ }
+ ch = *source++;
+ if (ch <= UNI_MAX_BMP) { /* Target is a character <= 0xFFFF */
+ /* UTF-16 surrogate values are illegal in UTF-32; 0xffff or 0xfffe are both reserved values */
+ if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_LOW_END) {
+ if (flags == strictConversion) {
+ --source; /* return to the illegal value itself */
+ result = sourceIllegal;
+ break;
+ } else {
+ *target++ = UNI_REPLACEMENT_CHAR;
+ }
+ } else {
+ *target++ = (UTF16)ch; /* normal case */
+ }
+ } else if (ch > UNI_MAX_LEGAL_UTF32) {
+ if (flags == strictConversion) {
+ result = sourceIllegal;
+ } else {
+ *target++ = UNI_REPLACEMENT_CHAR;
+ }
+ } else {
+ /* target is a character in range 0xFFFF - 0x10FFFF. */
+ if (target + 1 >= targetEnd) {
+ --source; /* Back up source pointer! */
+ result = targetExhausted; break;
+ }
+ ch -= halfBase;
+ *target++ = (UTF16)((ch >> halfShift) + UNI_SUR_HIGH_START);
+ *target++ = (UTF16)((ch & halfMask) + UNI_SUR_LOW_START);
+ }
+ }
+ *sourceStart = source;
+ *targetStart = target;
+ return result;
}
/* --------------------------------------------------------------------- */
ConversionResult ConvertUTF16toUTF32 (
- const UTF16** sourceStart, const UTF16* sourceEnd,
- UTF32** targetStart, UTF32* targetEnd, ConversionFlags flags) {
- ConversionResult result = conversionOK;
- const UTF16* source = *sourceStart;
- UTF32* target = *targetStart;
- UTF32 ch, ch2;
- while (source < sourceEnd) {
- const UTF16* oldSource = source; /* In case we have to back up because of target overflow. */
- ch = *source++;
- /* If we have a surrogate pair, convert to UTF32 first. */
- if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_HIGH_END) {
- /* If the 16 bits following the high surrogate are in the source buffer... */
- if (source < sourceEnd) {
- ch2 = *source;
- /* If it's a low surrogate, convert to UTF32. */
- if (ch2 >= UNI_SUR_LOW_START && ch2 <= UNI_SUR_LOW_END) {
- ch = ((ch - UNI_SUR_HIGH_START) << halfShift)
- + (ch2 - UNI_SUR_LOW_START) + halfBase;
- ++source;
- } else if (flags == strictConversion) { /* it's an unpaired high surrogate */
- --source; /* return to the illegal value itself */
- result = sourceIllegal;
- break;
- }
- } else { /* We don't have the 16 bits following the high surrogate. */
- --source; /* return to the high surrogate */
- result = sourceExhausted;
- break;
- }
- } else if (flags == strictConversion) {
- /* UTF-16 surrogate values are illegal in UTF-32 */
- if (ch >= UNI_SUR_LOW_START && ch <= UNI_SUR_LOW_END) {
- --source; /* return to the illegal value itself */
- result = sourceIllegal;
- break;
- }
- }
- if (target >= targetEnd) {
- source = oldSource; /* Back up source pointer! */
- result = targetExhausted; break;
- }
- *target++ = ch;
- }
- *sourceStart = source;
- *targetStart = target;
+ const UTF16** sourceStart, const UTF16* sourceEnd,
+ UTF32** targetStart, UTF32* targetEnd, ConversionFlags flags) {
+ ConversionResult result = conversionOK;
+ const UTF16* source = *sourceStart;
+ UTF32* target = *targetStart;
+ UTF32 ch, ch2;
+ while (source < sourceEnd) {
+ const UTF16* oldSource = source; /* In case we have to back up because of target overflow. */
+ ch = *source++;
+ /* If we have a surrogate pair, convert to UTF32 first. */
+ if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_HIGH_END) {
+ /* If the 16 bits following the high surrogate are in the source buffer... */
+ if (source < sourceEnd) {
+ ch2 = *source;
+ /* If it's a low surrogate, convert to UTF32. */
+ if (ch2 >= UNI_SUR_LOW_START && ch2 <= UNI_SUR_LOW_END) {
+ ch = ((ch - UNI_SUR_HIGH_START) << halfShift)
+ + (ch2 - UNI_SUR_LOW_START) + halfBase;
+ ++source;
+ } else if (flags == strictConversion) { /* it's an unpaired high surrogate */
+ --source; /* return to the illegal value itself */
+ result = sourceIllegal;
+ break;
+ }
+ } else { /* We don't have the 16 bits following the high surrogate. */
+ --source; /* return to the high surrogate */
+ result = sourceExhausted;
+ break;
+ }
+ } else if (flags == strictConversion) {
+ /* UTF-16 surrogate values are illegal in UTF-32 */
+ if (ch >= UNI_SUR_LOW_START && ch <= UNI_SUR_LOW_END) {
+ --source; /* return to the illegal value itself */
+ result = sourceIllegal;
+ break;
+ }
+ }
+ if (target >= targetEnd) {
+ source = oldSource; /* Back up source pointer! */
+ result = targetExhausted; break;
+ }
+ *target++ = ch;
+ }
+ *sourceStart = source;
+ *targetStart = target;
#ifdef CVTUTF_DEBUG
if (result == sourceIllegal) {
- fprintf(stderr, "ConvertUTF16toUTF32 illegal seq 0x%04x,%04x\n", ch, ch2);
- fflush(stderr);
+ fprintf(stderr, "ConvertUTF16toUTF32 illegal seq 0x%04x,%04x\n", ch, ch2);
+ fflush(stderr);
}
#endif
- return result;
+ return result;
}
/* --------------------------------------------------------------------- */
@@ -364,73 +366,73 @@ if (result == sourceIllegal) {
/* --------------------------------------------------------------------- */
ConversionResult ConvertUTF16toUTF8 (
- const UTF16** sourceStart, const UTF16* sourceEnd,
- UTF8** targetStart, UTF8* targetEnd, ConversionFlags flags) {
- ConversionResult result = conversionOK;
- const UTF16* source = *sourceStart;
- UTF8* target = *targetStart;
- while (source < sourceEnd) {
- UTF32 ch;
- unsigned short bytesToWrite = 0;
- const UTF32 byteMask = 0xBF;
- const UTF32 byteMark = 0x80;
- const UTF16* oldSource = source; /* In case we have to back up because of target overflow. */
- ch = *source++;
- /* If we have a surrogate pair, convert to UTF32 first. */
- if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_HIGH_END) {
- /* If the 16 bits following the high surrogate are in the source buffer... */
- if (source < sourceEnd) {
- UTF32 ch2 = *source;
- /* If it's a low surrogate, convert to UTF32. */
- if (ch2 >= UNI_SUR_LOW_START && ch2 <= UNI_SUR_LOW_END) {
- ch = ((ch - UNI_SUR_HIGH_START) << halfShift)
- + (ch2 - UNI_SUR_LOW_START) + halfBase;
- ++source;
- } else if (flags == strictConversion) { /* it's an unpaired high surrogate */
- --source; /* return to the illegal value itself */
- result = sourceIllegal;
- break;
- }
- } else { /* We don't have the 16 bits following the high surrogate. */
- --source; /* return to the high surrogate */
- result = sourceExhausted;
- break;
- }
- } else if (flags == strictConversion) {
- /* UTF-16 surrogate values are illegal in UTF-32 */
- if (ch >= UNI_SUR_LOW_START && ch <= UNI_SUR_LOW_END) {
- --source; /* return to the illegal value itself */
- result = sourceIllegal;
- break;
- }
- }
- /* Figure out how many bytes the result will require */
- if (ch < (UTF32)0x80) { bytesToWrite = 1;
- } else if (ch < (UTF32)0x800) { bytesToWrite = 2;
- } else if (ch < (UTF32)0x10000) { bytesToWrite = 3;
- } else if (ch < (UTF32)0x110000) { bytesToWrite = 4;
- } else { bytesToWrite = 3;
- ch = UNI_REPLACEMENT_CHAR;
- }
-
- target += bytesToWrite;
- if (target > targetEnd) {
- source = oldSource; /* Back up source pointer! */
- target -= bytesToWrite; result = targetExhausted; break;
- }
- switch (bytesToWrite) { /* note: everything falls through. */
- case 4: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
- case 3: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
- case 2: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
- case 1: *--target = (UTF8)(ch | firstByteMark[bytesToWrite]);
- }
- target += bytesToWrite;
- }
- *sourceStart = source;
- *targetStart = target;
- return result;
+ const UTF16** sourceStart, const UTF16* sourceEnd,
+ UTF8** targetStart, UTF8* targetEnd, ConversionFlags flags) {
+ ConversionResult result = conversionOK;
+ const UTF16* source = *sourceStart;
+ UTF8* target = *targetStart;
+ while (source < sourceEnd) {
+ UTF32 ch;
+ unsigned short bytesToWrite = 0;
+ const UTF32 byteMask = 0xBF;
+ const UTF32 byteMark = 0x80;
+ const UTF16* oldSource = source; /* In case we have to back up because of target overflow. */
+ ch = *source++;
+ /* If we have a surrogate pair, convert to UTF32 first. */
+ if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_HIGH_END) {
+ /* If the 16 bits following the high surrogate are in the source buffer... */
+ if (source < sourceEnd) {
+ UTF32 ch2 = *source;
+ /* If it's a low surrogate, convert to UTF32. */
+ if (ch2 >= UNI_SUR_LOW_START && ch2 <= UNI_SUR_LOW_END) {
+ ch = ((ch - UNI_SUR_HIGH_START) << halfShift)
+ + (ch2 - UNI_SUR_LOW_START) + halfBase;
+ ++source;
+ } else if (flags == strictConversion) { /* it's an unpaired high surrogate */
+ --source; /* return to the illegal value itself */
+ result = sourceIllegal;
+ break;
+ }
+ } else { /* We don't have the 16 bits following the high surrogate. */
+ --source; /* return to the high surrogate */
+ result = sourceExhausted;
+ break;
+ }
+ } else if (flags == strictConversion) {
+ /* UTF-16 surrogate values are illegal in UTF-32 */
+ if (ch >= UNI_SUR_LOW_START && ch <= UNI_SUR_LOW_END) {
+ --source; /* return to the illegal value itself */
+ result = sourceIllegal;
+ break;
+ }
+ }
+ /* Figure out how many bytes the result will require */
+ if (ch < (UTF32)0x80) { bytesToWrite = 1;
+ } else if (ch < (UTF32)0x800) { bytesToWrite = 2;
+ } else if (ch < (UTF32)0x10000) { bytesToWrite = 3;
+ } else if (ch < (UTF32)0x110000) { bytesToWrite = 4;
+ } else { bytesToWrite = 3;
+ ch = UNI_REPLACEMENT_CHAR;
+ }
+
+ target += bytesToWrite;
+ if (target > targetEnd) {
+ source = oldSource; /* Back up source pointer! */
+ target -= bytesToWrite; result = targetExhausted; break;
+ }
+ switch (bytesToWrite) { /* note: everything falls through. */
+ case 4: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
+ case 3: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
+ case 2: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
+ case 1: *--target = (UTF8)(ch | firstByteMark[bytesToWrite]);
+ }
+ target += bytesToWrite;
+ }
+ *sourceStart = source;
+ *targetStart = target;
+ return result;
}
-#endif //unused
+#endif // USE_ARCHIVED_UTF8_SOURCE
/* --------------------------------------------------------------------- */
@@ -446,31 +448,32 @@ ConversionResult ConvertUTF16toUTF8 (
*/
static Boolean isLegalUTF8(const UTF8 *source, int length) {
- UTF8 a;
- const UTF8 *srcptr = source+length;
-
- switch (length) {
- default: return false;
- /* Everything else falls through when "true"... */
- case 4: if ((a = (*--srcptr)) < 0x80 || a > 0xBF) return false;
- case 3: if ((a = (*--srcptr)) < 0x80 || a > 0xBF) return false;
- case 2: if ((a = (*--srcptr)) > 0xBF) return false;
-
- switch (*source) {
- /* no fall-through in this inner switch */
- case 0xE0: if (a < 0xA0) return false; break;
- case 0xED: if (a > 0x9F) return false; break;
- case 0xF0: if (a < 0x90) return false; break;
- case 0xF4: if (a > 0x8F) return false; break;
- default: if (a < 0x80) return false;
- }
-
- case 1: if (*source >= 0x80 && *source < 0xC2) return false;
- }
-
- if (*source > 0xF4) return false;
-
- return true;
+ UTF8 a;
+ const UTF8 *srcptr = source+length;
+
+ switch (length) {
+ default: return false;
+ /* Everything else falls through when "true"... */
+ case 4: if ((a = (*--srcptr)) < 0x80 || a > 0xBF) return false; // falls through
+ case 3: if ((a = (*--srcptr)) < 0x80 || a > 0xBF) return false; // falls through
+ case 2: if ((a = (*--srcptr)) > 0xBF) return false; // falls through
+
+ switch (*source) {
+ /* no fall-through in this inner switch */
+ case 0xE0: if (a < 0xA0) return false; break;
+ case 0xED: if (a > 0x9F) return false; break;
+ case 0xF0: if (a < 0x90) return false; break;
+ case 0xF4: if (a > 0x8F) return false; break;
+ default: if (a < 0x80) return false; break;
+ }
+
+ // falls through
+ case 1: if (*source >= 0x80 && *source < 0xC2) return false;
+ }
+
+ if (*source > 0xF4) return false;
+
+ return true;
}
/* --------------------------------------------------------------------- */
@@ -480,215 +483,215 @@ static Boolean isLegalUTF8(const UTF8 *source, int length) {
* This is not used here; it's just exported.
*/
Boolean isLegalUTF8Sequence(const UTF8 *source, const UTF8 *sourceEnd) {
- int length = trailingBytesForUTF8[*source]+1;
- if (source+length > sourceEnd) return false;
- return isLegalUTF8(source, length);
+ int length = trailingBytesForUTF8[*source]+1;
+ if (source+length > sourceEnd) return false;
+ return isLegalUTF8(source, length);
}
/* --------------------------------------------------------------------- */
-#ifdef unused
+#ifdef USE_ARCHIVED_UTF16_CODE
ConversionResult ConvertUTF8toUTF16 (
- const UTF8** sourceStart, const UTF8* sourceEnd,
- UTF16** targetStart, UTF16* targetEnd, ConversionFlags flags) {
- ConversionResult result = conversionOK;
- const UTF8* source = *sourceStart;
- UTF16* target = *targetStart;
- while (source < sourceEnd) {
- UTF32 ch = 0;
- unsigned short extraBytesToRead = trailingBytesForUTF8[*source];
- if (source + extraBytesToRead >= sourceEnd) {
- result = sourceExhausted; break;
- }
- /* Do this check whether lenient or strict */
- if (! isLegalUTF8(source, extraBytesToRead+1)) {
- result = sourceIllegal;
- break;
- }
- /*
- * The cases all fall through. See "Note A" below.
- */
- switch (extraBytesToRead) {
- case 5: ch += *source++; ch <<= 6; /* remember, illegal UTF-8 */
- case 4: ch += *source++; ch <<= 6; /* remember, illegal UTF-8 */
- case 3: ch += *source++; ch <<= 6;
- case 2: ch += *source++; ch <<= 6;
- case 1: ch += *source++; ch <<= 6;
- case 0: ch += *source++;
- }
- ch -= offsetsFromUTF8[extraBytesToRead];
-
- if (target >= targetEnd) {
- source -= (extraBytesToRead+1); /* Back up source pointer! */
- result = targetExhausted; break;
- }
- if (ch <= UNI_MAX_BMP) { /* Target is a character <= 0xFFFF */
- /* UTF-16 surrogate values are illegal in UTF-32 */
- if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_LOW_END) {
- if (flags == strictConversion) {
- source -= (extraBytesToRead+1); /* return to the illegal value itself */
- result = sourceIllegal;
- break;
- } else {
- *target++ = UNI_REPLACEMENT_CHAR;
- }
- } else {
- *target++ = (UTF16)ch; /* normal case */
- }
- } else if (ch > UNI_MAX_UTF16) {
- if (flags == strictConversion) {
- result = sourceIllegal;
- source -= (extraBytesToRead+1); /* return to the start */
- break; /* Bail out; shouldn't continue */
- } else {
- *target++ = UNI_REPLACEMENT_CHAR;
- }
- } else {
- /* target is a character in range 0xFFFF - 0x10FFFF. */
- if (target + 1 >= targetEnd) {
- source -= (extraBytesToRead+1); /* Back up source pointer! */
- result = targetExhausted; break;
- }
- ch -= halfBase;
- *target++ = (UTF16)((ch >> halfShift) + UNI_SUR_HIGH_START);
- *target++ = (UTF16)((ch & halfMask) + UNI_SUR_LOW_START);
- }
- }
- *sourceStart = source;
- *targetStart = target;
- return result;
+ const UTF8** sourceStart, const UTF8* sourceEnd,
+ UTF16** targetStart, UTF16* targetEnd, ConversionFlags flags) {
+ ConversionResult result = conversionOK;
+ const UTF8* source = *sourceStart;
+ UTF16* target = *targetStart;
+ while (source < sourceEnd) {
+ UTF32 ch = 0;
+ unsigned short extraBytesToRead = trailingBytesForUTF8[*source];
+ if (source + extraBytesToRead >= sourceEnd) {
+ result = sourceExhausted; break;
+ }
+ /* Do this check whether lenient or strict */
+ if (! isLegalUTF8(source, extraBytesToRead+1)) {
+ result = sourceIllegal;
+ break;
+ }
+ /*
+ * The cases all fall through. See "Note A" below.
+ */
+ switch (extraBytesToRead) {
+ case 5: ch += *source++; ch <<= 6; /* remember, illegal UTF-8 */
+ case 4: ch += *source++; ch <<= 6; /* remember, illegal UTF-8 */
+ case 3: ch += *source++; ch <<= 6;
+ case 2: ch += *source++; ch <<= 6;
+ case 1: ch += *source++; ch <<= 6;
+ case 0: ch += *source++;
+ }
+ ch -= offsetsFromUTF8[extraBytesToRead];
+
+ if (target >= targetEnd) {
+ source -= (extraBytesToRead+1); /* Back up source pointer! */
+ result = targetExhausted; break;
+ }
+ if (ch <= UNI_MAX_BMP) { /* Target is a character <= 0xFFFF */
+ /* UTF-16 surrogate values are illegal in UTF-32 */
+ if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_LOW_END) {
+ if (flags == strictConversion) {
+ source -= (extraBytesToRead+1); /* return to the illegal value itself */
+ result = sourceIllegal;
+ break;
+ } else {
+ *target++ = UNI_REPLACEMENT_CHAR;
+ }
+ } else {
+ *target++ = (UTF16)ch; /* normal case */
+ }
+ } else if (ch > UNI_MAX_UTF16) {
+ if (flags == strictConversion) {
+ result = sourceIllegal;
+ source -= (extraBytesToRead+1); /* return to the start */
+ break; /* Bail out; shouldn't continue */
+ } else {
+ *target++ = UNI_REPLACEMENT_CHAR;
+ }
+ } else {
+ /* target is a character in range 0xFFFF - 0x10FFFF. */
+ if (target + 1 >= targetEnd) {
+ source -= (extraBytesToRead+1); /* Back up source pointer! */
+ result = targetExhausted; break;
+ }
+ ch -= halfBase;
+ *target++ = (UTF16)((ch >> halfShift) + UNI_SUR_HIGH_START);
+ *target++ = (UTF16)((ch & halfMask) + UNI_SUR_LOW_START);
+ }
+ }
+ *sourceStart = source;
+ *targetStart = target;
+ return result;
}
/* --------------------------------------------------------------------- */
ConversionResult ConvertUTF32toUTF8 (
- const UTF32** sourceStart, const UTF32* sourceEnd,
- UTF8** targetStart, UTF8* targetEnd, ConversionFlags flags) {
- ConversionResult result = conversionOK;
- const UTF32* source = *sourceStart;
- UTF8* target = *targetStart;
- while (source < sourceEnd) {
- UTF32 ch;
- unsigned short bytesToWrite = 0;
- const UTF32 byteMask = 0xBF;
- const UTF32 byteMark = 0x80;
- ch = *source++;
- if (flags == strictConversion ) {
- /* UTF-16 surrogate values are illegal in UTF-32 */
- if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_LOW_END) {
- --source; /* return to the illegal value itself */
- result = sourceIllegal;
- break;
- }
- }
- /*
- * Figure out how many bytes the result will require. Turn any
- * illegally large UTF32 things (> Plane 17) into replacement chars.
- */
- if (ch < (UTF32)0x80) { bytesToWrite = 1;
- } else if (ch < (UTF32)0x800) { bytesToWrite = 2;
- } else if (ch < (UTF32)0x10000) { bytesToWrite = 3;
- } else if (ch <= UNI_MAX_LEGAL_UTF32) { bytesToWrite = 4;
- } else { bytesToWrite = 3;
- ch = UNI_REPLACEMENT_CHAR;
- result = sourceIllegal;
- }
-
- target += bytesToWrite;
- if (target > targetEnd) {
- --source; /* Back up source pointer! */
- target -= bytesToWrite; result = targetExhausted; break;
- }
- switch (bytesToWrite) { /* note: everything falls through. */
- case 4: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
- case 3: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
- case 2: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
- case 1: *--target = (UTF8) (ch | firstByteMark[bytesToWrite]);
- }
- target += bytesToWrite;
- }
- *sourceStart = source;
- *targetStart = target;
- return result;
+ const UTF32** sourceStart, const UTF32* sourceEnd,
+ UTF8** targetStart, UTF8* targetEnd, ConversionFlags flags) {
+ ConversionResult result = conversionOK;
+ const UTF32* source = *sourceStart;
+ UTF8* target = *targetStart;
+ while (source < sourceEnd) {
+ UTF32 ch;
+ unsigned short bytesToWrite = 0;
+ const UTF32 byteMask = 0xBF;
+ const UTF32 byteMark = 0x80;
+ ch = *source++;
+ if (flags == strictConversion ) {
+ /* UTF-16 surrogate values are illegal in UTF-32 */
+ if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_LOW_END) {
+ --source; /* return to the illegal value itself */
+ result = sourceIllegal;
+ break;
+ }
+ }
+ /*
+ * Figure out how many bytes the result will require. Turn any
+ * illegally large UTF32 things (> Plane 17) into replacement chars.
+ */
+ if (ch < (UTF32)0x80) { bytesToWrite = 1;
+ } else if (ch < (UTF32)0x800) { bytesToWrite = 2;
+ } else if (ch < (UTF32)0x10000) { bytesToWrite = 3;
+ } else if (ch <= UNI_MAX_LEGAL_UTF32) { bytesToWrite = 4;
+ } else { bytesToWrite = 3;
+ ch = UNI_REPLACEMENT_CHAR;
+ result = sourceIllegal;
+ }
+
+ target += bytesToWrite;
+ if (target > targetEnd) {
+ --source; /* Back up source pointer! */
+ target -= bytesToWrite; result = targetExhausted; break;
+ }
+ switch (bytesToWrite) { /* note: everything falls through. */
+ case 4: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
+ case 3: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
+ case 2: *--target = (UTF8)((ch | byteMark) & byteMask); ch >>= 6;
+ case 1: *--target = (UTF8) (ch | firstByteMark[bytesToWrite]);
+ }
+ target += bytesToWrite;
+ }
+ *sourceStart = source;
+ *targetStart = target;
+ return result;
}
/* --------------------------------------------------------------------- */
ConversionResult ConvertUTF8toUTF32 (
- const UTF8** sourceStart, const UTF8* sourceEnd,
- UTF32** targetStart, UTF32* targetEnd, ConversionFlags flags) {
- ConversionResult result = conversionOK;
- const UTF8* source = *sourceStart;
- UTF32* target = *targetStart;
- while (source < sourceEnd) {
- UTF32 ch = 0;
- unsigned short extraBytesToRead = trailingBytesForUTF8[*source];
- if (source + extraBytesToRead >= sourceEnd) {
- result = sourceExhausted; break;
- }
- /* Do this check whether lenient or strict */
- if (! isLegalUTF8(source, extraBytesToRead+1)) {
- result = sourceIllegal;
- break;
- }
- /*
- * The cases all fall through. See "Note A" below.
- */
- switch (extraBytesToRead) {
- case 5: ch += *source++; ch <<= 6;
- case 4: ch += *source++; ch <<= 6;
- case 3: ch += *source++; ch <<= 6;
- case 2: ch += *source++; ch <<= 6;
- case 1: ch += *source++; ch <<= 6;
- case 0: ch += *source++;
- }
- ch -= offsetsFromUTF8[extraBytesToRead];
-
- if (target >= targetEnd) {
- source -= (extraBytesToRead+1); /* Back up the source pointer! */
- result = targetExhausted; break;
- }
- if (ch <= UNI_MAX_LEGAL_UTF32) {
- /*
- * UTF-16 surrogate values are illegal in UTF-32, and anything
- * over Plane 17 (> 0x10FFFF) is illegal.
- */
- if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_LOW_END) {
- if (flags == strictConversion) {
- source -= (extraBytesToRead+1); /* return to the illegal value itself */
- result = sourceIllegal;
- break;
- } else {
- *target++ = UNI_REPLACEMENT_CHAR;
- }
- } else {
- *target++ = ch;
- }
- } else { /* i.e., ch > UNI_MAX_LEGAL_UTF32 */
- result = sourceIllegal;
- *target++ = UNI_REPLACEMENT_CHAR;
- }
- }
- *sourceStart = source;
- *targetStart = target;
- return result;
+ const UTF8** sourceStart, const UTF8* sourceEnd,
+ UTF32** targetStart, UTF32* targetEnd, ConversionFlags flags) {
+ ConversionResult result = conversionOK;
+ const UTF8* source = *sourceStart;
+ UTF32* target = *targetStart;
+ while (source < sourceEnd) {
+ UTF32 ch = 0;
+ unsigned short extraBytesToRead = trailingBytesForUTF8[*source];
+ if (source + extraBytesToRead >= sourceEnd) {
+ result = sourceExhausted; break;
+ }
+ /* Do this check whether lenient or strict */
+ if (! isLegalUTF8(source, extraBytesToRead+1)) {
+ result = sourceIllegal;
+ break;
+ }
+ /*
+ * The cases all fall through. See "Note A" below.
+ */
+ switch (extraBytesToRead) {
+ case 5: ch += *source++; ch <<= 6;
+ case 4: ch += *source++; ch <<= 6;
+ case 3: ch += *source++; ch <<= 6;
+ case 2: ch += *source++; ch <<= 6;
+ case 1: ch += *source++; ch <<= 6;
+ case 0: ch += *source++;
+ }
+ ch -= offsetsFromUTF8[extraBytesToRead];
+
+ if (target >= targetEnd) {
+ source -= (extraBytesToRead+1); /* Back up the source pointer! */
+ result = targetExhausted; break;
+ }
+ if (ch <= UNI_MAX_LEGAL_UTF32) {
+ /*
+ * UTF-16 surrogate values are illegal in UTF-32, and anything
+ * over Plane 17 (> 0x10FFFF) is illegal.
+ */
+ if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_LOW_END) {
+ if (flags == strictConversion) {
+ source -= (extraBytesToRead+1); /* return to the illegal value itself */
+ result = sourceIllegal;
+ break;
+ } else {
+ *target++ = UNI_REPLACEMENT_CHAR;
+ }
+ } else {
+ *target++ = ch;
+ }
+ } else { /* i.e., ch > UNI_MAX_LEGAL_UTF32 */
+ result = sourceIllegal;
+ *target++ = UNI_REPLACEMENT_CHAR;
+ }
+ }
+ *sourceStart = source;
+ *targetStart = target;
+ return result;
}
/* ---------------------------------------------------------------------
- Note A.
- The fall-through switches in UTF-8 reading code save a
- temp variable, some decrements & conditionals. The switches
- are equivalent to the following loop:
- {
- int tmpBytesToRead = extraBytesToRead+1;
- do {
- ch += *source++;
- --tmpBytesToRead;
- if (tmpBytesToRead) ch <<= 6;
- } while (tmpBytesToRead > 0);
- }
- In UTF-8 writing code, the switches on "bytesToWrite" are
- similarly unrolled loops.
+ Note A.
+ The fall-through switches in UTF-8 reading code save a
+ temp variable, some decrements & conditionals. The switches
+ are equivalent to the following loop:
+ {
+ int tmpBytesToRead = extraBytesToRead+1;
+ do {
+ ch += *source++;
+ --tmpBytesToRead;
+ if (tmpBytesToRead) ch <<= 6;
+ } while (tmpBytesToRead > 0);
+ }
+ In UTF-8 writing code, the switches on "bytesToWrite" are
+ similarly unrolled loops.
--------------------------------------------------------------------- */
@@ -698,497 +701,680 @@ ConversionResult ConvertUTF8toUTF32 (
/***********************************************************************
************************************************************************
**
-** Code below added by REBOL Technologies 2008
+** Code below added by REBOL Technologies 2008
**
************************************************************************
***********************************************************************/
-/***********************************************************************
-**
-*/ REBINT What_UTF(REBYTE *bp, REBCNT len)
-/*
-** Tell us what UTF encoding the string has. Negative for LE.
-**
-***********************************************************************/
+//
+// What_UTF: C
+//
+// Tell us what UTF encoding the byte stream has, as integer # of bits.
+// 0 is unknown, negative for Little Endian.
+//
+// !!! Currently only uses the Byte-Order-Mark for detection (which is not
+// necessarily present)
+//
+// !!! Note that UTF8 is not prescribed to have a byte order mark by the
+// standard. Writing routines will not add it by default, hence if it is
+// present it is to be considered part of the in-band data stream...so that
+// reading and writing back out will preserve the input.
+//
+REBINT What_UTF(REBYTE *bp, REBCNT len)
{
- // UTF8:
- if (len >= 3 && bp[0] == 0xef && bp[1] == 0xbb && bp[2] == 0xbf) return 8;
-
- if (len >= 2) {
-
- // UTF16:
- if (bp[0] == 0xfe && bp[1] == 0xff) return 16;
-
- // Either UTF16 or 32:
- if (bp[0] == 0xff && bp[1] == 0xfe) {
- if (len >= 4 && bp[2] == 0 && bp[3] == 0) return -32;
- return -16;
- }
-
- // UTF32
- if (len >= 4 && bp[0] == 0 && bp[1] == 0 && bp[2] == 0xfe && bp[3] == 0xff)
- return 32;
- }
-
- // Unknown:
- return 0;
+ if (len >= 3 && bp[0] == 0xef && bp[1] == 0xbb && bp[2] == 0xbf)
+ return 8; // UTF8 (endian agnostic)
+
+ if (len >= 2) {
+ if (bp[0] == 0xfe && bp[1] == 0xff)
+ return 16; // UTF16 big endian
+
+ if (bp[0] == 0xff && bp[1] == 0xfe) {
+ if (len >= 4 && bp[2] == 0 && bp[3] == 0)
+ return -32; // UTF32 little endian
+ return -16; // UTF16 little endian
+ }
+
+ if (
+ len >= 4
+ && bp[0] == 0 && bp[1] == 0 && bp[2] == 0xfe && bp[3] == 0xff
+ ){
+ return 32; // UTF32 big endian
+ }
+ }
+
+ return 0; // unknown
}
-/***********************************************************************
-**
-*/ REBFLG Legal_UTF8_Char(REBYTE *str, REBCNT len)
-/*
-** Returns TRUE if char is legal.
-**
-***********************************************************************/
+
+//
+// Legal_UTF8_Char: C
+//
+// Returns TRUE if char is legal.
+//
+REBOOL Legal_UTF8_Char(const REBYTE *str, REBCNT len)
{
- return isLegalUTF8Sequence(str, str + len);
+ return LOGICAL(isLegalUTF8Sequence(str, str + len));
}
-/***********************************************************************
-**
-*/ REBYTE *Check_UTF8(REBYTE *str, REBCNT len)
-/*
-** Returns 0 for success, else str where error occurred.
-**
-***********************************************************************/
+//
+// Check_UTF8: C
+//
+// Returns 0 for success, else str where error occurred.
+//
+REBYTE *Check_UTF8(REBYTE *str, REBCNT len)
{
- REBINT n;
- REBYTE *end = str + len;
+ REBINT n;
+ REBYTE *end = str + len;
- for (;str < end; str += n) {
- n = trailingBytesForUTF8[*str] + 1;
- if (str + n > end || !isLegalUTF8(str, n)) return str;
- }
+ for (;str < end; str += n) {
+ n = trailingBytesForUTF8[*str] + 1;
+ if (str + n > end || !isLegalUTF8(str, n)) return str;
+ }
- return 0;
+ return 0;
}
-/***********************************************************************
-**
-*/ REBCNT Decode_UTF8_Char(REBYTE **str, REBCNT *len)
-/*
-** Converts a single UTF8 code-point (to 32 bit).
-** Errors are returned as zero. (So prescan source for null.)
-** Increments str by extra chars needed.
-** Decrements len by extra chars needed.
-**
-***********************************************************************/
-{
- UTF8 *source = *str;
- UTF32 ch = 0;
- int slen = trailingBytesForUTF8[*source];
-
- // Check that we have enough valid source bytes:
- if (len) {
- if (slen+1 > *len) return 0;
- }
- else {
- for (; slen >= 0; slen--)
- if (source[slen] < 0x80) return 0;
- slen = trailingBytesForUTF8[*source];
- }
-
- // Do this check whether lenient or strict:
- // if (!isLegalUTF8(source, slen+1)) return 0;
-
- switch (slen) {
- case 5: ch += *source++; ch <<= 6;
- case 4: ch += *source++; ch <<= 6;
- case 3: ch += *source++; ch <<= 6;
- case 2: ch += *source++; ch <<= 6;
- case 1: ch += *source++; ch <<= 6;
- case 0: ch += *source++;
- }
- ch -= offsetsFromUTF8[slen];
-
- // UTF-16 surrogate values are illegal in UTF-32, and anything
- // over Plane 17 (> 0x10FFFF) is illegal.
- if (ch > UNI_MAX_LEGAL_UTF32) return 0;
- if (ch >= UNI_SUR_HIGH_START && ch <= UNI_SUR_LOW_END) return 0;
-
- if (len) *len -= slen;
- *str += slen;
- return ch;
+//
+// Back_Scan_UTF8_Char_Core: C
+//
+// Converts a single UTF8 code-point and returns the position *at the
+// the last byte of the character's data*. (This differs from the usual
+// `Scan_XXX` interface of returning the position after the scanned
+// element, ready to read the next one.)
+//
+// The peculiar interface is useful in loops that are processing
+// ordinary ASCII chars directly -as well- as UTF8 ones. The loop can
+// do a single byte pointer increment after both kinds of
+// elements, avoiding the need to call any kind of `Scan_Ascii()`:
+//
+// for (; len > 0; bp++, len--) {
+// if (*bp < 0x80) {
+// // do ASCII stuff...
+// }
+// else {
+// REBUNI uni;
+// bp = Back_Scan_UTF8_Char(&uni, bp, &len);
+// // do UNICODE stuff...
+// }
+// }
+//
+// The third parameter is an optional length that will be decremented by
+// the number of "extra" bytes the UTF8 has beyond a single byte character.
+// This allows for decrement-style loops such as the above.
+//
+// Prescans source for null, and will not return code point 0.
+//
+// If failure due to insufficient data or malformed bytes, then NULL is
+// returned (len is not advanced).
+//
+const REBYTE *Back_Scan_UTF8_Char_Core(
+ unsigned long *out, // "UTF32" is defined as unsigned long above
+ const REBYTE *bp,
+ REBCNT *len
+) {
+ *out = 0;
+
+ const UTF8 *source = bp;
+ REBCNT trail = trailingBytesForUTF8[*source];
+
+ // Check that we have enough valid source bytes:
+ if (len) {
+ if (trail + 1 > *len)
+ return NULL;
+ }
+ else if (trail != 0) {
+ do {
+ if (source[trail] < 0x80)
+ return NULL;
+ } while (--trail != 0);
+
+ trail = trailingBytesForUTF8[*source];
+ }
+
+ // Do this check whether lenient or strict:
+ // if (!isLegalUTF8(source, slen+1)) return 0;
+
+ switch (trail) {
+ case 5: *out += *source++; *out <<= 6; // falls through
+ case 4: *out += *source++; *out <<= 6; // falls through
+ case 3: *out += *source++; *out <<= 6; // falls through
+ case 2: *out += *source++; *out <<= 6; // falls through
+ case 1: *out += *source++; *out <<= 6; // falls through
+ case 0: *out += *source++;
+ }
+ *out -= offsetsFromUTF8[trail];
+
+ // UTF-16 surrogate values are illegal in UTF-32, and anything
+ // over Plane 17 (> 0x10FFFF) is illegal.
+ //
+ // !!! Is this still relevant, in a system that is fully UTF8 based?
+ //
+ if (*out > UNI_MAX_LEGAL_UTF32)
+ return NULL;
+ if (*out >= UNI_SUR_HIGH_START && *out <= UNI_SUR_LOW_END)
+ return NULL;
+
+ if (len)
+ *len -= trail;
+
+ // !!! Original implementation used 0 as a return value to indicate a
+ // decoding failure. However, 0 is a legal UTF8 codepoint, and also
+ // Rebol strings are able to store NUL characters (they track a length
+ // and are not zero-terminated.) Should this be legal?
+ //
+ assert(*out != 0);
+ if (*out == 0)
+ return NULL;
+
+ return bp + trail;
}
-/***********************************************************************
-**
-*/ int Decode_UTF8(REBUNI *dst, REBYTE *src, REBCNT len, REBFLG ccr)
-/*
-** Decode UTF8 byte string into a 16 bit preallocated array.
-**
-** dst: the desination array, must always be large enough!
-** src: source binary data
-** len: byte-length of source (not number of chars)
-** ccr: convert CRLF/CR to LF
-**
-** Returns length in chars (negative if all chars are latin-1).
-** No terminator is added.
-**
-***********************************************************************/
-{
- int flag = -1;
- UTF32 ch;
- REBUNI *start = dst;
-
- for (; len > 0; len--, src++) {
- if ((ch = *src) >= 0x80) {
- ch = Decode_UTF8_Char(&src, &len);
- if (ch == 0) ch = UNI_REPLACEMENT_CHAR; // temporary!
- if (ch > 0xff) flag = 1;
- } if (ch == CR && ccr) {
- if (src[1] == LF) continue;
- ch = LF;
- }
- *dst++ = (REBUNI)ch;
- }
-
- return (dst - start) * flag;
+//
+// Decode_UTF8_Negative_If_Latin1: C
+//
+// Decode UTF8 byte string into a 16 bit preallocated array.
+//
+// dst: the desination array, must always be large enough!
+// src: source binary data
+// len: byte-length of source (not number of chars)
+// crlf_to_lf: convert CRLF/CR to LF
+//
+// Returns length in chars (negative if all chars are latin-1).
+// No terminator is added.
+//
+int Decode_UTF8_Negative_If_Latin1(
+ REBUNI *dst,
+ const REBYTE *src,
+ REBCNT len,
+ REBOOL crlf_to_lf
+) {
+ int flag = -1;
+ REBUNI ch;
+ REBUNI *start = dst;
+
+ for (; len > 0; len--, src++) {
+ if ((ch = *src) >= 0x80) {
+ if (!(src = Back_Scan_UTF8_Char(&ch, src, &len)))
+ fail (Error_Bad_Utf8_Raw());
+
+ if (ch > 0xff) flag = 1;
+ }
+ else if (ch == CR && crlf_to_lf) {
+ if (src[1] == LF) continue;
+ ch = LF;
+ }
+ *dst++ = ch;
+ }
+
+ return (dst - start) * flag;
}
-/***********************************************************************
-**
-*/ int Decode_UTF16(REBUNI *dst, REBYTE *src, REBCNT len, REBFLG lee, REBFLG ccr)
-/*
-** dst: the desination array, must always be large enough!
-** src: source binary data
-** len: byte-length of source (not number of chars)
-** lee: little endian encoded
-** ccr: convert CRLF/CR to LF
-**
-** Returns length in chars (negative if all chars are latin-1).
-** No terminator is added.
-**
-***********************************************************************/
-{
- int flag = -1;
- UTF32 ch;
- REBUNI *start = dst;
-
- if (ccr) ccr = 1;
-
- for (; len > 0; len--, src++) {
-
- // Combine bytes in big or little endian format:
- ch = *src;
- if (!lee) ch <<= 8;
- if (--len <= 0) break;
- src++;
- ch |= lee ? (UTF32)(*src) << 8 : *src;
-
- // Skip CR, but add LF (even if missing)
- if (ccr) {
- if (ccr < 0 && ch != LF) {
- ccr = 1;
- *dst++ = LF;
- }
- if (ch == CR) {
- ccr = -1;
- continue;
- }
- }
-
- // check for surrogate pair ??
-
- if (ch > 0xff) flag = 1;
-
- *dst++ = (REBUNI)ch;
- }
-
- return (dst - start) * flag;
+//
+// Decode_UTF8_Maybe_Astral_Throws: C
+//
+// Prior to formal support for unicode codepoints higher than 0xFFFF, this
+// routine allows a handler to be called for high codepoints that can return
+// something to substitute into the string instead. Whereas typical UTF8
+// decoding knows an upper bound on the total string length, this does not...
+// so the interface must allow for resizing the buffer.
+//
+REBOOL Decode_UTF8_Maybe_Astral_Throws(
+ REBVAL *out_if_thrown,
+ REBSER *dst,
+ const REBYTE *src,
+ REBCNT len,
+ REBOOL crlf_to_lf,
+ const REBVAL *handler
+) {
+ TRASH_CELL_IF_DEBUG(out_if_thrown);
+
+ assert(SER_WIDE(dst) == sizeof(REBUNI)); // Append_Codepoint_Raw is used
+
+ UTF32 ch;
+
+ DECLARE_LOCAL (item);
+ DECLARE_LOCAL (astral);
+
+ for (; len > 0; len--, src++) {
+ if ((ch = *src) >= 0x80) {
+ if (!(src = Back_Scan_UTF8_Char_Core(&ch, src, &len)))
+ fail (Error_Bad_Utf8_Raw());
+
+ if (ch > 0xFFFF) { // too big to fit in today's REBUNI
+ if (IS_FUNCTION(handler)) {
+ Init_Integer(astral, ch); // CHAR! only 16-bit for now
+
+ // Try passing the handler the codepoint value. Passing
+ // FALSE for `fully` means it will not raise an error if
+ // the handler happens to be arity 0.
+
+ const REBOOL fully = FALSE;
+ if (Apply_Only_Throws(item, fully, handler, astral, END)) {
+ Move_Value(out_if_thrown, item);
+ return TRUE;
+ }
+ }
+ else
+ Move_Value(item, handler);
+
+ switch (VAL_TYPE(item)) {
+ case REB_MAX_VOID:
+ case REB_BLANK:
+ break; // tolerate void or blank as meaning nothing
+
+ case REB_CHAR:
+ Append_Codepoint_Raw(dst, VAL_CHAR(item));
+ break;
+
+ case REB_STRING:
+ Append_String(
+ dst,
+ VAL_SERIES(item),
+ VAL_INDEX(item),
+ VAL_LEN_AT(item)
+ );
+ break;
+
+ default:
+ fail (item);
+ }
+
+ continue;
+ }
+ }
+ else if (ch == CR && crlf_to_lf) {
+ if (src[1] == LF) continue;
+ ch = LF;
+ }
+ Append_Codepoint_Raw(dst, ch);
+ }
+
+ return FALSE; // no throw
}
-/***********************************************************************
-**
-*/ int Decode_UTF32(REBUNI *dst, REBYTE *src, REBINT len, REBFLG lee, REBFLG ccr)
-/*
-***********************************************************************/
-{
- return 0;
+//
+// Decode_UTF16: C
+//
+// dst: the desination array, must always be large enough!
+// src: source binary data
+// len: byte-length of source (not number of chars)
+// little_endian: little endian encoded
+// crlf_to_lf: convert CRLF/CR to LF
+//
+// Returns length in chars (negative if all chars are latin-1).
+// No terminator is added.
+//
+int Decode_UTF16(
+ REBUNI *dst,
+ const REBYTE *src,
+ REBCNT len,
+ REBOOL little_endian,
+ REBOOL crlf_to_lf
+) {
+ REBOOL expect_lf = FALSE;
+ REBOOL latin1 = TRUE;
+ UTF32 ch;
+ REBUNI *start = dst;
+
+ for (; len > 0; len--, src++) {
+ //
+ // Combine bytes in big or little endian format
+ //
+ ch = *src;
+ if (!little_endian) ch <<= 8;
+ if (--len <= 0) break;
+ src++;
+ ch |= little_endian ? (cast(UTF32, *src) << 8) : *src;
+
+ if (crlf_to_lf) {
+ //
+ // Skip CR, but add LF (even if missing)
+ //
+ if (expect_lf && ch != LF) {
+ expect_lf = FALSE;
+ *dst++ = LF;
+ }
+ if (ch == CR) {
+ expect_lf = TRUE;
+ continue;
+ }
+ }
+
+ // !!! "check for surrogate pair" ??
+
+ if (ch > 0xff) latin1 = FALSE;
+
+ *dst++ = cast(REBUNI, ch);
+ }
+
+ return latin1 ? -(dst - start) : (dst - start);
}
-/***********************************************************************
-**
-*/ REBSER *Decode_UTF_String(REBYTE *bp, REBCNT len, REBINT utf)
-/*
-** Do all the details to decode a string.
-** Input is a byte series. Len is len of input.
-** The utf is 0, 8, +/-16, +/-32.
-** A special -1 means use the BOM.
-**
-***********************************************************************/
+//
+// Decode_UTF_String: C
+//
+// Do all the details to decode a string.
+// Input is a byte series. Len is len of input.
+// The utf is 0, 8, +/-16
+// A special -1 means use the BOM, if present, or UTF-8 otherwise.
+//
+// Returns the decoded string or NULL for unsupported encodings.
+//
+REBSER *Decode_UTF_String(REBYTE *bp, REBCNT len, REBINT utf)
{
- REBSER *ser = BUF_UTF8; // buffer is Unicode width
- REBSER *dst;
- REBINT size;
-
- if (utf == -1) {
- utf = What_UTF(bp, len);
- if (utf) {
- if (utf == 8) bp += 3, len -= 3;
- else if (utf == -16 || utf == 16) bp += 2, len -= 2;
- else if (utf == -32 || utf == 32) bp += 4, len -= 4;
- }
- }
-
- if (utf == 0 || utf == 8) {
- size = Decode_UTF8((REBUNI*)Reset_Buffer(ser, len), bp, len, TRUE);
- }
- else if (utf == -16 || utf == 16) {
- size = Decode_UTF16((REBUNI*)Reset_Buffer(ser, len/2 + 1), bp, len, utf < 0, TRUE);
- }
-// else if (utf == -32 || utf == 32) {
-// size = Decode_UTF32((REBUNI*)Reset_Buffer(ser, len/4 + 1), bp, len, utf < 0, TRUE);
-// }
-
- if (size < 0) {
- size = -size;
- dst = Make_Binary(size);
- Append_Uni_Bytes(dst, UNI_HEAD(ser), size);
- }
- else {
- dst = Make_Unicode(size);
- Append_Uni_Uni(dst, UNI_HEAD(ser), size);
- }
-
- return dst;
+ REBSER *ser = BUF_UTF8; // buffer is Unicode width
+ REBSER *dst;
+ REBINT size;
+
+ if (utf == -1) {
+ // Try to detect UTF encoding from a BOM. Returns 0 if no BOM present.
+ utf = What_UTF(bp, len);
+ if (utf != 0) {
+ if (utf == 8) bp += 3, len -= 3;
+ else if (utf == -16 || utf == 16) bp += 2, len -= 2;
+ else return NULL;
+ }
+ }
+
+ if (utf == 0 || utf == 8) {
+ size = Decode_UTF8_Negative_If_Latin1(
+ cast(REBUNI*, Reset_Buffer(ser, len)), bp, len, TRUE
+ );
+ }
+ else if (utf == -16 || utf == 16) {
+ size = Decode_UTF16(
+ cast(REBUNI*, Reset_Buffer(ser, (len / 2) + 1)),
+ bp,
+ len,
+ LOGICAL(utf < 0),
+ TRUE
+ );
+ }
+ else {
+ // Encoding is unsupported or not yet implemented.
+ return NULL;
+ }
+
+ if (size < 0) {
+ size = -size;
+ dst = Make_Binary(size);
+ Append_Uni_Bytes(dst, UNI_HEAD(ser), size);
+ }
+ else {
+ dst = Make_Unicode(size);
+ Append_Uni_Uni(dst, UNI_HEAD(ser), size);
+ }
+
+ return dst;
}
-/***********************************************************************
-**
-*/ REBCNT Length_As_UTF8(REBUNI *src, REBCNT len, REBOOL uni, REBOOL ccr)
-/*
-** Returns how long the UTF8 encoded string would be.
-**
-***********************************************************************/
+//
+// Length_As_UTF8: C
+//
+// Returns how long the UTF8 encoded string would be.
+//
+REBCNT Length_As_UTF8(const void *p, REBCNT len, REBFLGS opts)
{
- REBCNT size = 0;
- REBCNT c;
- REBYTE *bp = (REBYTE*)src;
-
- for (; len > 0; len--) {
- c = uni ? *src++ : *bp++;
- if (c < (UTF32)0x80) {
-#ifdef TO_WIN32
- if (ccr && c == LF) size++; // because we will add a CR to it
+ REBCNT size = 0;
+ REBCNT c;
+ REBOOL unicode = LOGICAL(opts & OPT_ENC_UNISRC);
+
+ const REBYTE *bp = unicode ? NULL : cast(const REBYTE *, p);
+ const REBUNI *up = unicode ? cast(const REBUNI *, p) : NULL;
+
+ for (; len > 0; len--) {
+ c = unicode ? *up++ : *bp++;
+ if (c < (UTF32)0x80) {
+#ifdef TO_WINDOWS
+ if (LOGICAL(opts & OPT_ENC_CRLF) && c == LF)
+ size++; // since we will add a CR to it
#endif
- size++;
- }
- else if (c < (UTF32)0x800) size += 2;
- else if (c < (UTF32)0x10000) size += 3;
- else if (c <= UNI_MAX_LEGAL_UTF32) size += 4;
- else size += 3;
- }
-
- return size;
+ size++;
+ }
+ else if (c < (UTF32)0x800) size += 2;
+ else if (c < (UTF32)0x10000) size += 3;
+ else if (c <= UNI_MAX_LEGAL_UTF32) size += 4;
+ else size += 3;
+ }
+
+ return size;
}
-/***********************************************************************
-**
-*/ REBCNT Encode_UTF8_Char(REBYTE *dst, REBCNT src)
-/*
-** Converts a single char to UTF8 code-point.
-** Returns length of char stored in dst.
-** Be sure dst has at least 4 bytes available.
-**
-***********************************************************************/
+//
+// Encode_UTF8_Char: C
+//
+// Converts a single char to UTF8 code-point.
+// Returns length of char stored in dst.
+// Be sure dst has at least 4 bytes available.
+//
+REBCNT Encode_UTF8_Char(REBYTE *dst, REBCNT src)
{
- int len = 0;
- const UTF32 mask = 0xBF;
- const UTF32 mark = 0x80;
-
- if (src < (UTF32)0x80) len = 1;
- else if (src < (UTF32)0x800) len = 2;
- else if (src < (UTF32)0x10000) len = 3;
- else if (src <= UNI_MAX_LEGAL_UTF32) len = 4;
- else {
- len = 3;
- src = UNI_REPLACEMENT_CHAR;
- }
-
- dst += len;
-
- switch (len) {
- case 4: *--dst = (UTF8)((src | mark) & mask); src >>= 6;
- case 3: *--dst = (UTF8)((src | mark) & mask); src >>= 6;
- case 2: *--dst = (UTF8)((src | mark) & mask); src >>= 6;
- case 1: *--dst = (UTF8) (src | firstByteMark[len]);
- }
-
- return len;
+ int len = 0;
+ const UTF32 mask = 0xBF;
+ const UTF32 mark = 0x80;
+
+ if (src < (UTF32)0x80) len = 1;
+ else if (src < (UTF32)0x800) len = 2;
+ else if (src < (UTF32)0x10000) len = 3;
+ else if (src <= UNI_MAX_LEGAL_UTF32) len = 4;
+ else {
+ len = 3;
+ src = UNI_REPLACEMENT_CHAR;
+ }
+
+ dst += len;
+
+ switch (len) {
+ case 4: *--dst = (UTF8)((src | mark) & mask); src >>= 6; // falls through
+ case 3: *--dst = (UTF8)((src | mark) & mask); src >>= 6; // falls through
+ case 2: *--dst = (UTF8)((src | mark) & mask); src >>= 6; // falls through
+ case 1: *--dst = (UTF8) (src | firstByteMark[len]);
+ }
+
+ return len;
}
-/***********************************************************************
-**
-*/ REBCNT Encode_UTF8(REBYTE *dst, REBINT max, void *src, REBCNT *len, REBFLG uni, REBFLG ccr)
-/*
-** Encode the unicode into UTF8 byte string.
-**
-** Source string can be byte or unichar sized (uni = TRUE);
-** Max is the maximum size of the result (UTF8).
-** Returns number of source chars used.
-** Updates len for dst bytes used.
-** Does not add a terminator.
-**
-***********************************************************************/
-{
- REBUNI c;
- REBINT n;
- REBYTE buf[8];
- REBYTE *bs = dst; // save start
- REBYTE *bp = (REBYTE*)src;
- REBUNI *up = (REBUNI*)src;
- REBCNT cnt;
-
- if (len) cnt = *len;
- else {
- cnt = uni ? wcslen((REBUNI*)bp) : LEN_BYTES((REBYTE*)bp);
- }
-
- for (; max > 0 && cnt > 0; cnt--) {
- c = uni ? *up++ : *bp++;
- if (c < 0x80) {
-#if defined(TO_WIN32)
- if (ccr && c == LF) {
- // If there's not room, don't try to output CRLF
- if (2 > max) {up--; break;}
- *dst++ = CR;
- max--;
- c = LF;
- }
+//
+// Encode_UTF8: C
+//
+// Encode the unicode into UTF8 byte string.
+//
+// Source string can be byte or unichar sized (OPT_ENC_UNISRC);
+// Max is the maximum size of the result (UTF8).
+// Returns number of dst bytes used.
+// Updates len for source chars used.
+// Does not add a terminator.
+//
+REBCNT Encode_UTF8(
+ REBYTE *dst,
+ REBCNT max,
+ const void *src,
+ REBCNT *len,
+ REBFLGS opts
+) {
+ REBUNI c;
+ REBINT n;
+ REBYTE buf[8];
+ REBYTE *bs = dst; // save start
+ const REBYTE *bp = cast(const REBYTE*, src);
+ const REBUNI *up = cast(const REBUNI*, src);
+ REBCNT cnt;
+ REBOOL unicode = LOGICAL(opts & OPT_ENC_UNISRC);
+
+ if (len) cnt = *len;
+ else cnt = unicode ? Strlen_Uni(up) : LEN_BYTES(bp);
+
+ for (; max > 0 && cnt > 0; cnt--) {
+ c = unicode ? *up++ : *bp++;
+ if (c < 0x80) {
+#if defined(TO_WINDOWS)
+ if (LOGICAL(opts & OPT_ENC_CRLF) && c == LF) {
+ // If there's not room, don't try to output CRLF
+ if (2 > max) {bp--; up--; break;}
+ *dst++ = CR;
+ max--;
+ c = LF;
+ }
#endif
- *dst++ = (REBYTE)c;
- max--;
- }
- else {
- n = Encode_UTF8_Char(buf, c);
- if (n > max) {up--; break;}
- memcpy(dst, buf, n);
- dst += n;
- max -= n;
- }
- }
-
- if (len) *len = dst - bs;
-
- return uni ? up - (REBUNI*)src : bp - (REBYTE*)src;
+ *dst++ = cast(REBYTE, c);
+ max--;
+ }
+ else {
+ n = Encode_UTF8_Char(buf, c);
+ if (n > cast(REBINT, max)) {bp--; up--; break;}
+ memcpy(dst, buf, n);
+ dst += n;
+ max -= n;
+ }
+ }
+
+ if (len)
+ *len = unicode
+ ? up - cast(const REBUNI*, src)
+ : bp - cast(const REBYTE*, src);
+
+ return dst - bs;
}
-/***********************************************************************
-**
-*/ int Encode_UTF8_Line(REBSER *dst, REBSER *src, REBCNT idx)
-/*
-** Encode a unicode source buffer into a binary line of UTF8.
-** Include the LF terminator in the result.
-** Return the length of the line buffer.
-**
-***********************************************************************/
+//
+// Encode_UTF8_Line: C
+//
+// Encode a unicode source buffer into a binary line of UTF8.
+// Include the LF terminator in the result.
+// Return the length of the line buffer.
+//
+int Encode_UTF8_Line(REBSER *dst, REBSER *src, REBCNT idx)
{
- REBUNI *up = UNI_HEAD(src);
- REBCNT len = SERIES_TAIL(src);
- REBCNT tail;
- REBUNI c;
- REBINT n;
- REBYTE buf[8];
-
- tail = RESET_TAIL(dst);
-
- while (idx < len) {
- if ((c = up[idx]) < 0x80) {
- EXPAND_SERIES_TAIL(dst, 1);
- BIN_HEAD(dst)[tail++] = (REBYTE)c;
- }
- else {
- n = Encode_UTF8_Char(buf, c);
- EXPAND_SERIES_TAIL(dst, n);
- memcpy(BIN_SKIP(dst, tail), buf, n);
- tail += n;
- }
- idx++;
- if (c == LF) break;
- }
-
- BIN_HEAD(dst)[tail] = 0;
- SERIES_TAIL(dst) = tail;
- return idx;
+ REBUNI *up = UNI_HEAD(src);
+ REBCNT len = SER_LEN(src);
+ REBCNT tail;
+ REBUNI c;
+ REBINT n;
+ REBYTE buf[8];
+
+ SET_SERIES_LEN(dst, 0);
+ tail = 0;
+
+ while (idx < len) {
+ if ((c = up[idx]) < 0x80) {
+ EXPAND_SERIES_TAIL(dst, 1);
+ BIN_HEAD(dst)[tail++] = (REBYTE)c;
+ }
+ else {
+ n = Encode_UTF8_Char(buf, c);
+ EXPAND_SERIES_TAIL(dst, n);
+ memcpy(BIN_AT(dst, tail), buf, n);
+ tail += n;
+ }
+ idx++;
+ if (c == LF) break;
+ }
+
+ BIN_HEAD(dst)[tail] = 0;
+ SET_SERIES_LEN(dst, tail);
+ return idx;
}
-/***********************************************************************
-**
-*/ REBSER *Encode_UTF8_Value(REBVAL *arg, REBCNT len, REBFLG opts)
-/*
-** Do all the details to encode a string as UTF8.
-** No_copy means do not make a copy.
-** Result can be a shared buffer!
-**
-***********************************************************************/
-{
- REBSER *ser = BUF_FORM; // a shared buffer
- REBCNT size;
- REBYTE *cp;
- REBFLG ccr = GET_FLAG(opts, ENC_OPT_CRLF);
-
- if (VAL_BYTE_SIZE(arg)) {
- REBYTE *bp = VAL_BIN_DATA(arg);
-
- if (Is_Not_ASCII(bp, len)) {
- size = Length_As_UTF8((REBUNI*)bp, len, FALSE, (REBOOL)ccr);
- cp = Reset_Buffer(ser, size + (GET_FLAG(opts, ENC_OPT_BOM) ? 3 : 0));
- Encode_UTF8(cp, size, bp, &len, FALSE, ccr);
- }
- else if (GET_FLAG(opts, ENC_OPT_NO_COPY)) return 0;
- else return Copy_Bytes(bp, len);
-
- } else {
- REBUNI *up = VAL_UNI_DATA(arg);
-
- size = Length_As_UTF8(up, len, TRUE, (REBOOL)ccr);
- cp = Reset_Buffer(ser, size + (GET_FLAG(opts, ENC_OPT_BOM) ? 3 : 0));
- Encode_UTF8(Reset_Buffer(ser, size), size, up, &len, TRUE, ccr);
- }
-
- SERIES_TAIL(ser) = len;
- STR_TERM(ser);
-
- return Copy_Bytes(BIN_HEAD(ser), len);
+//
+// Make_UTF8_Binary: C
+//
+// Convert byte- or REBUNI-sized data to UTF8-encoded
+// null-terminated series. Can reserve extra bytes of space.
+// Resulting series must be either freed or handed to the GC.
+//
+REBSER *Make_UTF8_Binary(
+ const void *data,
+ REBCNT len,
+ REBCNT extra,
+ REBFLGS opts
+) {
+ REBCNT size = Length_As_UTF8(data, len, opts);
+ REBSER *series = Make_Binary(size + extra);
+ SET_SERIES_LEN(series, Encode_UTF8(
+ BIN_HEAD(series), size, data, &len, opts
+ ));
+ assert(SER_LEN(series) == size);
+ TERM_SEQUENCE(series);
+ return series;
}
-/***********************************************************************
-**
-*/ REBSER *Encode_String(void *str, REBCNT len, REBCNT opts)
-/*
-** str: byte or unicode string
-** len: length in chars
-** opt: special options (UTF, LE/BE, CR/LF, BOM)
-**
-***********************************************************************/
-{
- REBSER *ser = 0;
+//
+// Make_UTF8_From_Any_String: C
+//
+// Do all the details to encode either a byte-sized or REBUNI
+// size ANY-STRING! value to a UTF8-encoded series. Resulting
+// series must be either freed or handed to the GC.
+//
+REBSER *Make_UTF8_From_Any_String(
+ const RELVAL *value,
+ REBCNT len,
+ REBFLGS opts
+) {
+ assert(ANY_STRING(value));
+
+ if (
+ NOT(opts & OPT_ENC_CRLF)
+ && (
+ VAL_BYTE_SIZE(value)
+ && All_Bytes_ASCII(VAL_BIN_AT(value), VAL_LEN_AT(value))
+ )
+ ){
+ // We can copy a one-byte-per-character series if it doesn't contain
+ // codepoints like 128 - 255 (pure ASCII is valid UTF-8)
+ //
+ return Copy_Bytes(VAL_BIN_AT(value), len);
+ }
+ else {
+ const void *data;
+ if (VAL_BYTE_SIZE(value)) {
+ opts &= ~OPT_ENC_UNISRC; // remove flag
+ data = VAL_BIN_AT(value);
+ }
+ else {
+ opts |= OPT_ENC_UNISRC; // add flag
+ data = VAL_UNI_AT(value);
+ }
+ return Make_UTF8_Binary(data, len, 0, opts);
+ }
+}
- if (GET_FLAG(opts, ENC_OPT_UTF8)) {
- //ser = Encode_UTF8_Value(arg, len, opts);
- }
- if (GET_FLAG(opts, ENC_OPT_UTF16)) {
- // ser = Encode_UTF16_Value(arg, len, FALSE, ccr);
- }
+//
+// Strlen_Uni: C
+//
+// Rebol's current choice is to use UCS-2 internally, such that
+// a REBUNI is an unsigned 16-bit number. This means that you
+// cannot use wcslen() to determine a REBUNI* string size, as
+// wchar_t is not guaranteed to be 2 bytes on every platform.
+//
+// Note: ideally this would use a routine like memmem() to look
+// for two sequential zero bytes and then match only those aligned
+// on an even byte boundary (to prevent spanning characters). But
+// memmem() is not POSIX and only on GNU. So this uses a simple
+// byte-by-byte search.
+//
+REBCNT Strlen_Uni(const REBUNI *up)
+{
+ const char *cp = cast(const char *, up) + 1; // "C"har vs. "U"nicode
+ assert(sizeof(REBUNI) == 2);
+ assert(cast(REBUPT, up) % 2 == 0);
-// if (utf == 0 || ser == 0) {
- // Enline_Bytes();
-// }
+ while (*cp || *(cp - 1)) cp += 2;
- return ser;
+ assert(cast(REBUPT, cp - 1) % 2 == 0);
+ return cast(const REBUNI*, cp - 1) - up;
}
+
diff --git a/src/core/t-bitset.c b/src/core/t-bitset.c
index 8d8e769ea0..0d6111ddf3 100644
--- a/src/core/t-bitset.c
+++ b/src/core/t-bitset.c
@@ -1,620 +1,693 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-bitset.c
-** Summary: bitset datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-bitset.c
+// Summary: "bitset datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
#define MAX_BITSET 0x7fffffff
-#define BITS_NOT(s) ((s)->size)
+static inline REBOOL BITS_NOT(REBSER *s) {
+ assert(s->misc.negated == TRUE || s->misc.negated == FALSE);
+ return s->misc.negated;
+}
+
+static inline void INIT_BITS_NOT(REBSER *s, REBOOL negated) {
+ s->misc.negated = negated;
+}
+
-/***********************************************************************
-**
-*/ REBINT CT_Bitset(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Bitset: C
+//
+REBINT CT_Bitset(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- if (mode == 3) return VAL_SERIES(a) == VAL_SERIES(b);
- if (mode >= 0) return (
- BITS_NOT(VAL_SERIES(a)) == BITS_NOT(VAL_SERIES(b))
- &&
- Compare_Binary_Vals(a, b) == 0
- );
- return -1;
+ if (mode >= 0) return (
+ BITS_NOT(VAL_SERIES(a)) == BITS_NOT(VAL_SERIES(b))
+ &&
+ Compare_Binary_Vals(a, b) == 0
+ );
+ return -1;
}
-/***********************************************************************
-**
-*/ REBSER *Make_Bitset(REBCNT len)
-/*
-** Return a bitset series (binary.
-**
-** len: the # of bits in the bitset.
-**
-***********************************************************************/
+//
+// Make_Bitset: C
+//
+// Return a bitset series (binary.
+//
+// len: the # of bits in the bitset.
+//
+REBSER *Make_Bitset(REBCNT len)
{
- REBSER *ser;
+ REBSER *ser;
- len = (len + 7) / 8;
- ser = Make_Binary(len);
- Clear_Series(ser);
- SERIES_TAIL(ser) = len;
- BITS_NOT(ser) = 0;
+ len = (len + 7) / 8;
+ ser = Make_Binary(len);
+ Clear_Series(ser);
+ SET_SERIES_LEN(ser, len);
+ INIT_BITS_NOT(ser, FALSE);
- return ser;
+ return ser;
}
-/***********************************************************************
-**
-*/ void Mold_Bitset(REBVAL *value, REB_MOLD *mold)
-/*
-***********************************************************************/
+//
+// Mold_Bitset: C
+//
+void Mold_Bitset(const REBVAL *value, REB_MOLD *mold)
{
- REBSER *ser = VAL_SERIES(value);
+ REBSER *ser = VAL_SERIES(value);
- if (BITS_NOT(ser)) Append_Bytes(mold->series, "[not bits ");
- Mold_Binary(value, mold);
- if (BITS_NOT(ser)) Append_Byte(mold->series, ']');
+ if (BITS_NOT(ser)) Append_Unencoded(mold->series, "[not bits ");
+ Mold_Binary(value, mold);
+ if (BITS_NOT(ser)) Append_Codepoint_Raw(mold->series, ']');
}
-/***********************************************************************
-**
-*/ REBFLG MT_Bitset(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
-{
- REBFLG is_not = 0;
-
- if (IS_BLOCK(data)) {
- REBINT len = Find_Max_Bit(data);
- REBSER *ser;
- if (len < 0 || len > 0xFFFFFF) Trap_Arg(data);
- ser = Make_Bitset(len);
- Set_Bits(ser, data, TRUE);
- Set_Series(REB_BITSET, out, ser);
- return TRUE;
- }
-
- if (!IS_BINARY(data)) return FALSE;
- Set_Series(REB_BITSET, out, Copy_Series_Value(data));
- BITS_NOT(VAL_SERIES(out)) = 0;
- return TRUE;
+//
+// MAKE_Bitset: C
+//
+void MAKE_Bitset(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+#ifdef NDEBUG
+ UNUSED(kind);
+#else
+ assert(kind == REB_BITSET);
+#endif
+
+ REBINT len = Find_Max_Bit(arg);
+
+ // Determine size of bitset. Returns -1 for errors.
+ //
+ // !!! R3-alpha construction syntax said 0xFFFFFF while the A_MAKE
+ // path used 0x0FFFFFFF. Assume A_MAKE was more likely right.
+ //
+ if (len < 0 || len > 0x0FFFFFFF)
+ fail (arg);
+
+ REBSER *ser = Make_Bitset(len);
+ Init_Bitset(out, ser);
+
+ if (IS_INTEGER(arg)) return; // allocated at a size, no contents.
+
+ if (IS_BINARY(arg)) {
+ memcpy(BIN_HEAD(ser), VAL_BIN_AT(arg), len/8 + 1);
+ return;
+ }
+
+ Set_Bits(ser, arg, TRUE);
+ INIT_BITS_NOT(VAL_SERIES(out), FALSE);
+}
+
+
+//
+// TO_Bitset: C
+//
+void TO_Bitset(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+ MAKE_Bitset(out, kind, arg);
}
-/***********************************************************************
-**
-*/ REBINT Find_Max_Bit(REBVAL *val)
-/*
-** Return integer number for the maximum bit number defined by
-** the value. Used to determine how much space to allocate.
-**
-***********************************************************************/
+//
+// Find_Max_Bit: C
+//
+// Return integer number for the maximum bit number defined by
+// the value. Used to determine how much space to allocate.
+//
+REBINT Find_Max_Bit(const RELVAL *val)
{
- REBINT maxi = 0;
- REBINT n;
-
- switch (VAL_TYPE(val)) {
-
- case REB_CHAR:
- maxi = VAL_CHAR(val)+1;
- break;
-
- case REB_INTEGER:
- maxi = Int32s(val, 0);
- break;
-
- case REB_STRING:
- case REB_FILE:
- case REB_EMAIL:
- case REB_URL:
- case REB_TAG:
-// case REB_ISSUE:
- n = VAL_INDEX(val);
- if (VAL_BYTE_SIZE(val)) {
- REBYTE *bp = VAL_BIN(val);
- for (; n < (REBINT)VAL_TAIL(val); n++)
- if (bp[n] > maxi) maxi = bp[n];
- }
- else {
- REBUNI *up = VAL_UNI(val);
- for (; n < (REBINT)VAL_TAIL(val); n++)
- if (up[n] > maxi) maxi = up[n];
- }
- maxi++;
- break;
-
- case REB_BINARY:
- maxi = VAL_LEN(val) * 8 - 1;
- if (maxi < 0) maxi = 0;
- break;
-
- case REB_BLOCK:
- for (val = VAL_BLK_DATA(val); NOT_END(val); val++) {
- n = Find_Max_Bit(val);
- if (n > maxi) maxi = n;
- }
- //maxi++;
- break;
-
- case REB_NONE:
- maxi = 0;
- break;
-
- default:
- return -1;
- }
-
- return maxi;
+ REBINT maxi = 0;
+ REBINT n;
+
+ switch (VAL_TYPE(val)) {
+
+ case REB_CHAR:
+ maxi = VAL_CHAR(val) + 1;
+ break;
+
+ case REB_INTEGER:
+ maxi = Int32s(val, 0);
+ break;
+
+ case REB_STRING:
+ case REB_FILE:
+ case REB_EMAIL:
+ case REB_URL:
+ case REB_TAG:
+// case REB_ISSUE:
+ n = VAL_INDEX(val);
+ if (VAL_BYTE_SIZE(val)) {
+ REBYTE *bp = VAL_BIN(val);
+ for (; n < cast(REBINT, VAL_LEN_HEAD(val)); n++)
+ if (bp[n] > maxi) maxi = bp[n];
+ }
+ else {
+ REBUNI *up = VAL_UNI(val);
+ for (; n < cast(REBINT, VAL_LEN_HEAD(val)); n++)
+ if (up[n] > maxi) maxi = up[n];
+ }
+ maxi++;
+ break;
+
+ case REB_BINARY:
+ maxi = VAL_LEN_AT(val) * 8 - 1;
+ if (maxi < 0) maxi = 0;
+ break;
+
+ case REB_BLOCK:
+ for (val = VAL_ARRAY_AT(val); NOT_END(val); val++) {
+ n = Find_Max_Bit(val);
+ if (n > maxi) maxi = n;
+ }
+ //maxi++;
+ break;
+
+ case REB_BLANK:
+ maxi = 0;
+ break;
+
+ default:
+ return -1;
+ }
+
+ return maxi;
}
-/***********************************************************************
-**
-*/ REBFLG Check_Bit(REBSER *bset, REBCNT c, REBFLG uncased)
-/*
-** Check bit indicated. Returns TRUE if set.
-** If uncased is TRUE, try to match either upper or lower case.
-**
-***********************************************************************/
+//
+// Check_Bit: C
+//
+// Check bit indicated. Returns TRUE if set.
+// If uncased is TRUE, try to match either upper or lower case.
+//
+REBOOL Check_Bit(REBSER *bset, REBCNT c, REBOOL uncased)
{
- REBCNT i, n = c;
- REBCNT tail = SERIES_TAIL(bset);
- REBFLG flag = 0;
+ REBCNT i, n = c;
+ REBCNT tail = SER_LEN(bset);
+ REBOOL flag = FALSE;
- if (uncased) {
- if (n >= UNICODE_CASES) uncased = FALSE; // no need to check
- else n = LO_CASE(c);
- }
+ if (uncased) {
+ if (n >= UNICODE_CASES) uncased = FALSE; // no need to check
+ else n = LO_CASE(c);
+ }
- // Check lowercase char:
+ // Check lowercase char:
retry:
- i = n >> 3;
- if (i < tail)
- flag = (0 != (BIN_HEAD(bset)[i] & (1 << (7 - ((n) & 7)))));
-
- // Check uppercase if needed:
- if (uncased && !flag) {
- n = UP_CASE(c);
- uncased = FALSE;
- goto retry;
- }
-
- return (BITS_NOT(bset)) ? !flag : flag;
+ i = n >> 3;
+ if (i < tail)
+ flag = LOGICAL(BIN_HEAD(bset)[i] & (1 << (7 - ((n) & 7))));
+
+ // Check uppercase if needed:
+ if (uncased && !flag) {
+ n = UP_CASE(c);
+ uncased = FALSE;
+ goto retry;
+ }
+
+ return BITS_NOT(bset) ? NOT(flag) : flag;
}
-/***********************************************************************
-**
-*/ REBFLG Check_Bit_Str(REBSER *bset, REBVAL *val, REBFLG uncased)
-/*
-** If uncased is TRUE, try to match either upper or lower case.
-**
-***********************************************************************/
+//
+// Check_Bit_Str: C
+//
+// If uncased is TRUE, try to match either upper or lower case.
+//
+REBOOL Check_Bit_Str(REBSER *bset, const REBVAL *val, REBOOL uncased)
{
- REBCNT n = VAL_INDEX(val);
-
- if (VAL_BYTE_SIZE(val)) {
- REBYTE *bp = VAL_BIN(val);
- for (; n < VAL_TAIL(val); n++)
- if (Check_Bit(bset, bp[n], uncased)) return TRUE;
- }
- else {
- REBUNI *up = VAL_UNI(val);
- for (; n < VAL_TAIL(val); n++)
- if (Check_Bit(bset, up[n], uncased)) return TRUE;
- }
- return FALSE;
+ REBCNT n = VAL_INDEX(val);
+
+ if (VAL_BYTE_SIZE(val)) {
+ REBYTE *bp = VAL_BIN(val);
+ for (; n < VAL_LEN_HEAD(val); n++)
+ if (Check_Bit(bset, bp[n], uncased)) return TRUE;
+ }
+ else {
+ REBUNI *up = VAL_UNI(val);
+ for (; n < VAL_LEN_HEAD(val); n++)
+ if (Check_Bit(bset, up[n], uncased)) return TRUE;
+ }
+ return FALSE;
}
-/***********************************************************************
-**
-*/ void Set_Bit(REBSER *bset, REBCNT n, REBOOL set)
-/*
-** Set/clear a single bit. Expand if needed.
-**
-***********************************************************************/
+//
+// Set_Bit: C
+//
+// Set/clear a single bit. Expand if needed.
+//
+void Set_Bit(REBSER *bset, REBCNT n, REBOOL set)
{
- REBCNT i = n >> 3;
- REBCNT tail = SERIES_TAIL(bset);
- REBYTE bit;
-
- // Expand if not enough room:
- if (i >= tail) {
- if (!set) return; // no need to expand
- Expand_Series(bset, tail, (i - tail) + 1);
- CLEAR(BIN_SKIP(bset, tail), (i - tail) + 1);
- }
-
- bit = 1 << (7 - ((n) & 7));
- if (set)
- BIN_HEAD(bset)[i] |= bit;
- else
- BIN_HEAD(bset)[i] &= ~bit;
+ REBCNT i = n >> 3;
+ REBCNT tail = SER_LEN(bset);
+ REBYTE bit;
+
+ // Expand if not enough room:
+ if (i >= tail) {
+ if (!set) return; // no need to expand
+ Expand_Series(bset, tail, (i - tail) + 1);
+ CLEAR(BIN_AT(bset, tail), (i - tail) + 1);
+ }
+
+ bit = 1 << (7 - ((n) & 7));
+ if (set)
+ BIN_HEAD(bset)[i] |= bit;
+ else
+ BIN_HEAD(bset)[i] &= ~bit;
}
-/***********************************************************************
-**
-*/ void Set_Bit_Str(REBSER *bset, REBVAL *val, REBOOL set)
-/*
-***********************************************************************/
+//
+// Set_Bit_Str: C
+//
+void Set_Bit_Str(REBSER *bset, const REBVAL *val, REBOOL set)
{
- REBCNT n = VAL_INDEX(val);
-
- if (VAL_BYTE_SIZE(val)) {
- REBYTE *bp = VAL_BIN(val);
- for (; n < VAL_TAIL(val); n++)
- Set_Bit(bset, bp[n], set);
- }
- else {
- REBUNI *up = VAL_UNI(val);
- for (; n < VAL_TAIL(val); n++)
- Set_Bit(bset, up[n], set);
- }
+ REBCNT n = VAL_INDEX(val);
+
+ if (VAL_BYTE_SIZE(val)) {
+ REBYTE *bp = VAL_BIN(val);
+ for (; n < VAL_LEN_HEAD(val); n++)
+ Set_Bit(bset, bp[n], set);
+ }
+ else {
+ REBUNI *up = VAL_UNI(val);
+ for (; n < VAL_LEN_HEAD(val); n++)
+ Set_Bit(bset, up[n], set);
+ }
}
-/***********************************************************************
-**
-*/ REBFLG Set_Bits(REBSER *bset, REBVAL *val, REBOOL set)
-/*
-** Set/clear bits indicated by strings and chars and ranges.
-**
-***********************************************************************/
+//
+// Set_Bits: C
+//
+// Set/clear bits indicated by strings and chars and ranges.
+//
+REBOOL Set_Bits(REBSER *bset, const REBVAL *val, REBOOL set)
{
- REBCNT n;
- REBCNT c;
-
- if (IS_CHAR(val)) {
- Set_Bit(bset, VAL_CHAR(val), set);
- return TRUE;
- }
-
- if (IS_INTEGER(val)) {
- n = Int32s(val, 0);
- if (n > MAX_BITSET) return 0;
- Set_Bit(bset, n, set);
- return TRUE;
- }
-
- if (ANY_BINSTR(val)) {
- Set_Bit_Str(bset, val, set);
- return TRUE;
- }
-
- if (!ANY_BLOCK(val)) Trap_Type(val);
-
- val = VAL_BLK_DATA(val);
- if (IS_SAME_WORD(val, SYM_NOT)) {
- BITS_NOT(bset) = TRUE;
- val++;
- }
-
- // Loop through block of bit specs:
- for (; NOT_END(val); val++) {
-
- switch (VAL_TYPE(val)) {
-
- case REB_CHAR:
- c = VAL_CHAR(val);
- if (IS_SAME_WORD(val + 1, SYM__)) {
- val += 2;
- if (IS_CHAR(val)) {
- n = VAL_CHAR(val);
+ FAIL_IF_READ_ONLY_SERIES(bset);
+
+ REBCNT n;
+ REBCNT c;
+
+ if (IS_CHAR(val)) {
+ Set_Bit(bset, VAL_CHAR(val), set);
+ return TRUE;
+ }
+
+ if (IS_INTEGER(val)) {
+ n = Int32s(val, 0);
+ if (n > MAX_BITSET) return FALSE;
+ Set_Bit(bset, n, set);
+ return TRUE;
+ }
+
+ if (ANY_BINSTR(val)) {
+ Set_Bit_Str(bset, val, set);
+ return TRUE;
+ }
+
+ if (!ANY_ARRAY(val))
+ fail (Error_Invalid_Type(VAL_TYPE(val)));
+
+ RELVAL *item = VAL_ARRAY_AT(val);
+
+ if (
+ NOT_END(item)
+ && IS_WORD(item)
+ && VAL_WORD_SYM(item) == SYM_NOT
+ ){
+ INIT_BITS_NOT(bset, TRUE);
+ item++;
+ }
+
+ // Loop through block of bit specs:
+ for (; NOT_END(item); item++) {
+
+ switch (VAL_TYPE(item)) {
+ case REB_CHAR:
+ c = VAL_CHAR(item);
+ if (
+ NOT_END(item + 1)
+ && IS_WORD(item + 1)
+ && VAL_WORD_SYM(item + 1) == SYM_HYPHEN
+ ){
+ item += 2;
+ if (IS_CHAR(item)) {
+ n = VAL_CHAR(item);
span_bits:
- if (n < c) Trap1(RE_PAST_END, val);
- for (; c <= n; c++) Set_Bit(bset, c, set);
- } else Trap_Arg(val);
- }
- else Set_Bit(bset, c, set);
- break;
-
- case REB_INTEGER:
- n = Int32s(val, 0);
- if (n > MAX_BITSET) return 0;
- if (IS_SAME_WORD(val + 1, SYM__)) {
- c = n;
- val += 2;
- if (IS_INTEGER(val)) {
- n = Int32s(val, 0);
- goto span_bits;
- } else Trap_Arg(val);
- }
- else Set_Bit(bset, n, set);
- break;
-
- case REB_BINARY:
- case REB_STRING:
- case REB_FILE:
- case REB_EMAIL:
- case REB_URL:
- case REB_TAG:
-// case REB_ISSUE:
- Set_Bit_Str(bset, val, set);
- break;
-
- case REB_WORD:
- // Special: BITS #{000...}
- if (!IS_SAME_WORD(val, SYM_BITS)) return 0;
- val++;
- if (!IS_BINARY(val)) return 0;
- n = VAL_LEN(val);
- c = bset->tail;
- if (n >= c) {
- Expand_Series(bset, c, (n - c));
- CLEAR(BIN_SKIP(bset, c), (n - c));
- }
- memcpy(BIN_HEAD(bset), VAL_BIN_DATA(val), n);
- break;
-
- default:
- return 0;
- }
- }
-
- return TRUE;
+ if (n < c) fail (Error_Past_End_Raw());
+ for (; c <= n; c++) Set_Bit(bset, c, set);
+ }
+ else
+ fail (Error_Invalid_Arg_Core(item, VAL_SPECIFIER(val)));
+ }
+ else Set_Bit(bset, c, set);
+ break;
+
+ case REB_INTEGER:
+ n = Int32s(KNOWN(item), 0);
+ if (n > MAX_BITSET) return FALSE;
+ if (IS_WORD(item + 1) && VAL_WORD_SYM(item + 1) == SYM_HYPHEN) {
+ c = n;
+ item += 2;
+ if (IS_INTEGER(item)) {
+ n = Int32s(KNOWN(item), 0);
+ goto span_bits;
+ }
+ else
+ fail (Error_Invalid_Arg_Core(item, VAL_SPECIFIER(val)));
+ }
+ else Set_Bit(bset, n, set);
+ break;
+
+ case REB_BINARY:
+ case REB_STRING:
+ case REB_FILE:
+ case REB_EMAIL:
+ case REB_URL:
+ case REB_TAG:
+// case REB_ISSUE:
+ Set_Bit_Str(bset, KNOWN(item), set);
+ break;
+
+ case REB_WORD:
+ // Special: BITS #{000...}
+ if (!IS_WORD(item) || VAL_WORD_SYM(item) != SYM_BITS)
+ return FALSE;
+ item++;
+ if (!IS_BINARY(item)) return FALSE;
+ n = VAL_LEN_AT(item);
+ c = SER_LEN(bset);
+ if (n >= c) {
+ Expand_Series(bset, c, (n - c));
+ CLEAR(BIN_AT(bset, c), (n - c));
+ }
+ memcpy(BIN_HEAD(bset), VAL_BIN_AT(item), n);
+ break;
+
+ default:
+ return FALSE;
+ }
+ }
+
+ return TRUE;
}
-
-/***********************************************************************
-**
-*/ REBFLG Check_Bits(REBSER *bset, REBVAL *val, REBFLG uncased)
-/*
-** Check bits indicated by strings and chars and ranges.
-** If uncased is TRUE, try to match either upper or lower case.
-**
-***********************************************************************/
+
+//
+// Check_Bits: C
+//
+// Check bits indicated by strings and chars and ranges.
+// If uncased is TRUE, try to match either upper or lower case.
+//
+REBOOL Check_Bits(REBSER *bset, const REBVAL *val, REBOOL uncased)
{
- REBCNT n;
- REBUNI c;
+ REBCNT n;
+ REBUNI c;
+ RELVAL *item;
- if (IS_CHAR(val))
- return Check_Bit(bset, VAL_CHAR(val), uncased);
+ if (IS_CHAR(val))
+ return Check_Bit(bset, VAL_CHAR(val), uncased);
- if (IS_INTEGER(val))
- return Check_Bit(bset, Int32s(val, 0), uncased);
+ if (IS_INTEGER(val))
+ return Check_Bit(bset, Int32s(val, 0), uncased);
- if (ANY_BINSTR(val))
- return Check_Bit_Str(bset, val, uncased);
+ if (ANY_BINSTR(val))
+ return Check_Bit_Str(bset, val, uncased);
- if (!ANY_BLOCK(val)) Trap_Type(val);
+ if (!ANY_ARRAY(val))
+ fail (Error_Invalid_Type(VAL_TYPE(val)));
- // Loop through block of bit specs:
- for (val = VAL_BLK_DATA(val); NOT_END(val); val++) {
+ // Loop through block of bit specs:
+ for (item = VAL_ARRAY_AT(val); NOT_END(item); item++) {
- switch (VAL_TYPE(val)) {
+ switch (VAL_TYPE(item)) {
- case REB_CHAR:
- c = VAL_CHAR(val);
- if (IS_SAME_WORD(val + 1, SYM__)) {
- val += 2;
- if (IS_CHAR(val)) {
- n = VAL_CHAR(val);
+ case REB_CHAR:
+ c = VAL_CHAR(item);
+ if (IS_WORD(item + 1) && VAL_WORD_SYM(item + 1) == SYM_HYPHEN) {
+ item += 2;
+ if (IS_CHAR(item)) {
+ n = VAL_CHAR(item);
scan_bits:
- if (n < c) Trap1(RE_PAST_END, val);
- for (; c <= n; c++)
- if (Check_Bit(bset, c, uncased)) goto found;
- } else Trap_Arg(val);
- }
- else
- if (Check_Bit(bset, c, uncased)) goto found;
- break;
-
- case REB_INTEGER:
- n = Int32s(val, 0);
- if (n > 0xffff) return 0;
- if (IS_SAME_WORD(val + 1, SYM__)) {
- c = n;
- val += 2;
- if (IS_INTEGER(val)) {
- n = Int32s(val, 0);
- goto scan_bits;
- } else Trap_Arg(val);
- }
- else
- if (Check_Bit(bset, n, uncased)) goto found;
- break;
-
- case REB_BINARY:
- case REB_STRING:
- case REB_FILE:
- case REB_EMAIL:
- case REB_URL:
- case REB_TAG:
-// case REB_ISSUE:
- if (Check_Bit_Str(bset, val, uncased)) goto found;
- break;
-
- default:
- Trap_Type(val);
- }
- }
- return FALSE;
+ if (n < c) fail (Error_Past_End_Raw());
+ for (; c <= n; c++)
+ if (Check_Bit(bset, c, uncased)) goto found;
+ }
+ else
+ fail (Error_Invalid_Arg_Core(item, VAL_SPECIFIER(val)));
+ }
+ else
+ if (Check_Bit(bset, c, uncased)) goto found;
+ break;
+
+ case REB_INTEGER:
+ n = Int32s(KNOWN(item), 0);
+ if (n > 0xffff) return FALSE;
+ if (IS_WORD(item + 1) && VAL_WORD_SYM(item + 1) == SYM_HYPHEN) {
+ c = n;
+ item += 2;
+ if (IS_INTEGER(item)) {
+ n = Int32s(KNOWN(item), 0);
+ goto scan_bits;
+ }
+ else
+ fail (Error_Invalid_Arg_Core(item, VAL_SPECIFIER(val)));
+ }
+ else
+ if (Check_Bit(bset, n, uncased)) goto found;
+ break;
+
+ case REB_BINARY:
+ case REB_STRING:
+ case REB_FILE:
+ case REB_EMAIL:
+ case REB_URL:
+ case REB_TAG:
+// case REB_ISSUE:
+ if (Check_Bit_Str(bset, KNOWN(item), uncased)) goto found;
+ break;
+
+ default:
+ fail (Error_Invalid_Type(VAL_TYPE(item)));
+ }
+ }
+ return FALSE;
found:
- return TRUE;
+ return TRUE;
}
-/***********************************************************************
-**
-*/ REBINT PD_Bitset(REBPVS *pvs)
-/*
-***********************************************************************/
+//
+// PD_Bitset: C
+//
+REBINT PD_Bitset(REBPVS *pvs)
{
- REBVAL *data = pvs->value;
- REBVAL *val = pvs->setval;
- REBSER *ser = VAL_SERIES(data);
- REBFLG t;
-
- if (val == 0) {
- if (Check_Bits(ser, pvs->select, 0)) {
- SET_TRUE(pvs->store);
- return PE_USE;
- }
- return PE_NONE;
- }
-
- t = IS_TRUE(val);
- if (BITS_NOT(ser)) t = !t;
- if (Set_Bits(ser, pvs->select, (REBOOL)t))
- return PE_OK;
-
- return PE_BAD_SET;
+ REBSER *ser = VAL_SERIES(pvs->value);
+
+ if (!pvs->opt_setval) {
+ if (Check_Bits(ser, pvs->picker, FALSE)) {
+ Init_Logic(pvs->store, TRUE);
+ return PE_USE_STORE;
+ }
+ return PE_NONE;
+ }
+
+ if (Set_Bits(
+ ser,
+ pvs->picker,
+ BITS_NOT(ser)
+ ? IS_CONDITIONAL_FALSE(pvs->opt_setval)
+ : IS_CONDITIONAL_TRUE(pvs->opt_setval)
+ )) {
+ return PE_OK;
+ }
+
+ fail (Error_Bad_Path_Set(pvs));
}
-/***********************************************************************
-**
-*/ void Trim_Tail_Zeros(REBSER *ser)
-/*
-** Remove extra zero bytes from end of byte string.
-**
-***********************************************************************/
+//
+// Trim_Tail_Zeros: C
+//
+// Remove extra zero bytes from end of byte string.
+//
+void Trim_Tail_Zeros(REBSER *ser)
{
- REBCNT tail = SERIES_TAIL(ser);
- REBYTE *bp = BIN_HEAD(ser);
+ REBCNT len = SER_LEN(ser);
+ REBYTE *bp = BIN_HEAD(ser);
+
+ while (len > 0 && bp[len] == 0)
+ len--;
- for (; tail > 0 && !bp[tail]; tail--);
+ if (bp[len] != 0)
+ len++;
- if (bp[tail]) tail++;
- SERIES_TAIL(ser) = tail;
+ SET_SERIES_LEN(ser, len);
}
-/***********************************************************************
-**
-*/ REBTYPE(Bitset)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+REBTYPE(Bitset)
{
- REBYTE *data = 0;
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBSER *ser;
- REBINT len;
- REBINT diff;
-
- if (action != A_MAKE && action != A_TO)
- data = VAL_BIT_DATA(value);
-
- // Check must be in this order (to avoid checking a non-series value);
- if (action >= A_TAKE && action <= A_SORT && IS_PROTECT_SERIES(VAL_SERIES(value)))
- Trap0(RE_PROTECTED);
-
- switch (action) {
-
- // Define PICK for BITSETS? PICK's set bits and returns #?
- // Add AND, OR, XOR
-
- case A_PICK:
- case A_FIND:
- if (!Check_Bits(VAL_SERIES(value), arg, D_REF(ARG_FIND_CASE))) return R_NONE;
- return R_TRUE;
-
- case A_COMPLEMENT:
- case A_NEGATE:
- ser = Copy_Series(VAL_SERIES(value));
- BITS_NOT(ser) = !BITS_NOT(VAL_SERIES(value));
- Set_Series(REB_BITSET, value, ser);
- break;
-
- case A_MAKE:
- case A_TO:
- // Determine size of bitset. Returns -1 for errors.
- len = Find_Max_Bit(arg);
- if (len < 0 || len > 0x0FFFFFFF) Trap_Arg(arg);
-
- ser = Make_Bitset(len);
- Set_Series(REB_BITSET, value, ser);
-
- // Nothing more to do.
- if (IS_INTEGER(arg)) break;
-
- if (IS_BINARY(arg)) {
- memcpy(BIN_HEAD(ser), VAL_BIN_DATA(arg), len/8 + 1);
- break;
- }
- // FALL THRU...
-
- case A_APPEND: // Accepts: #"a" "abc" [1 - 10] [#"a" - #"z"] etc.
- case A_INSERT:
- diff = TRUE;
- goto set_bits;
-
- case A_POKE:
- diff = Get_Logic_Arg(D_ARG(3));
-set_bits:
- if (BITS_NOT(VAL_SERIES(value))) diff = !diff;
- if (Set_Bits(VAL_SERIES(value), arg, (REBOOL)diff)) break;
- Trap_Arg(arg);
-
- case A_REMOVE: // #"a" "abc" remove/part bs "abcd" yuk: /part ?
- if (!D_REF(2)) Trap0(RE_MISSING_ARG); // /part required
- if (Set_Bits(VAL_SERIES(value), D_ARG(3), FALSE)) break;
- Trap_Arg(D_ARG(3));
-
- case A_COPY:
- VAL_SERIES(value) = Copy_Series_Value(value);
- break;
-
- case A_LENGTHQ:
- len = VAL_TAIL(value) * 8;
- SET_INTEGER(value, len);
- break;
-
- case A_TAILQ:
- // Necessary to make EMPTY? work:
- return (VAL_TAIL(value) == 0) ? R_TRUE : R_FALSE;
-
- case A_CLEAR:
- Clear_Series(VAL_SERIES(value));
- break;
-
- case A_AND:
- case A_OR:
- case A_XOR:
- if (!IS_BITSET(arg) && !IS_BINARY(arg))
- Trap_Math_Args(VAL_TYPE(arg), action);
- VAL_SERIES(value) = ser = Xandor_Binary(action, value, arg);
- Trim_Tail_Zeros(ser);
- break;
-
- default:
- Trap_Action(REB_BITSET, action);
- }
-
- DS_RET_VALUE(value);
- return R_RET;
+ REBVAL *value = D_ARG(1);
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+ REBSER *ser;
+ REBINT len;
+ REBOOL diff;
+
+ // !!! Set_Bits does locked series check--what should the more general
+ // responsibility be for checking?
+
+ switch (action) {
+
+ // Add AND, OR, XOR
+
+ case SYM_FIND: {
+ INCLUDE_PARAMS_OF_FIND;
+
+ UNUSED(PAR(series));
+ UNUSED(PAR(value));
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(skip)) {
+ UNUSED(ARG(size));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(last))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(reverse))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(tail))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(match))
+ fail (Error_Bad_Refines_Raw());
+
+ if (!Check_Bits(VAL_SERIES(value), arg, REF(case)))
+ return R_BLANK;
+ return R_TRUE;
+ }
+
+ case SYM_COMPLEMENT:
+ case SYM_NEGATE:
+ ser = Copy_Sequence(VAL_SERIES(value));
+ INIT_BITS_NOT(ser, NOT(BITS_NOT(VAL_SERIES(value))));
+ Init_Bitset(value, ser);
+ break;
+
+ case SYM_APPEND: // Accepts: #"a" "abc" [1 - 10] [#"a" - #"z"] etc.
+ case SYM_INSERT:
+ if (BITS_NOT(VAL_SERIES(value)))
+ diff = FALSE;
+ else
+ diff = TRUE;
+
+ if (NOT(Set_Bits(VAL_SERIES(value), arg, diff)))
+ fail (arg);
+ break;
+
+ case SYM_REMOVE: {
+ INCLUDE_PARAMS_OF_REMOVE;
+
+ UNUSED(PAR(series));
+ if (REF(map)) {
+ UNUSED(ARG(key));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ if (NOT(REF(part)))
+ fail (Error_Missing_Arg_Raw());
+
+ if (Set_Bits(VAL_SERIES(value), ARG(limit), FALSE))
+ break;
+
+ fail (ARG(limit)); }
+
+ case SYM_COPY: {
+ INCLUDE_PARAMS_OF_COPY;
+
+ UNUSED(PAR(value));
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(deep))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(types)) {
+ UNUSED(ARG(kinds));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ Init_Any_Series_At(
+ D_OUT,
+ REB_BITSET,
+ Copy_Sequence_At_Position(value),
+ VAL_INDEX(value) // !!! can bitset ever not be at 0?
+ );
+ INIT_BITS_NOT(VAL_SERIES(D_OUT), BITS_NOT(VAL_SERIES(value)));
+ return R_OUT; }
+
+ case SYM_LENGTH_OF:
+ len = VAL_LEN_HEAD(value) * 8;
+ Init_Integer(value, len);
+ break;
+
+ case SYM_TAIL_Q:
+ // Necessary to make EMPTY? work:
+ return (VAL_LEN_HEAD(value) == 0) ? R_TRUE : R_FALSE;
+
+ case SYM_CLEAR:
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(value));
+ Clear_Series(VAL_SERIES(value));
+ break;
+
+ case SYM_AND_T:
+ case SYM_OR_T:
+ case SYM_XOR_T:
+ if (!IS_BITSET(arg) && !IS_BINARY(arg))
+ fail (Error_Math_Args(VAL_TYPE(arg), action));
+ ser = Xandor_Binary(action, value, arg);
+ Trim_Tail_Zeros(ser);
+ Init_Any_Series(D_OUT, VAL_TYPE(value), ser);
+ return R_OUT;
+
+ default:
+ fail (Error_Illegal_Action(REB_BITSET, action));
+ }
+
+ Move_Value(D_OUT, value);
+ return R_OUT;
}
diff --git a/src/core/t-blank.c b/src/core/t-blank.c
new file mode 100644
index 0000000000..13144d0874
--- /dev/null
+++ b/src/core/t-blank.c
@@ -0,0 +1,119 @@
+//
+// File: %t-blank.c
+// Summary: "Blank datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+
+#include "sys-core.h"
+
+//
+// CT_Unit: C
+//
+REBINT CT_Unit(const RELVAL *a, const RELVAL *b, REBINT mode)
+{
+ if (mode >= 0) return (VAL_TYPE(a) == VAL_TYPE(b));
+ return -1;
+}
+
+
+//
+// MAKE_Unit: C
+//
+void MAKE_Unit(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+ UNUSED(arg);
+ VAL_RESET_HEADER(out, kind);
+}
+
+
+//
+// TO_Unit: C
+//
+void TO_Unit(REBVAL *out, enum Reb_Kind kind, const REBVAL *data) {
+ UNUSED(data);
+ VAL_RESET_HEADER(out, kind);
+}
+
+
+//
+// REBTYPE: C
+//
+REBTYPE(Unit)
+{
+ REBVAL *val = D_ARG(1);
+ assert(!IS_VOID(val));
+
+ switch (action) {
+ case SYM_TAIL_Q:
+ return R_TRUE;
+
+ case SYM_INDEX_OF:
+ case SYM_LENGTH_OF:
+ case SYM_SELECT_P:
+ case SYM_FIND:
+ case SYM_REMOVE:
+ case SYM_CLEAR:
+ case SYM_TAKE_P:
+ return R_BLANK;
+
+ case SYM_COPY: {
+ if (IS_BLANK(val))
+ return R_BLANK; // perhaps allow COPY on any type, as well.
+ break; }
+
+ default:
+ break;
+ }
+
+ fail (Error_Illegal_Action(VAL_TYPE(val), action));
+}
+
+
+//
+// CT_Handle: C
+//
+REBINT CT_Handle(const RELVAL *a, const RELVAL *b, REBINT mode)
+{
+ // Would it be meaningful to allow user code to compare HANDLE!?
+ //
+ UNUSED(a);
+ UNUSED(b);
+ UNUSED(mode);
+
+ fail ("Currently comparing HANDLE! types is not allowed.");
+}
+
+
+
+//
+// REBTYPE: C
+//
+REBTYPE(Handle)
+{
+ UNUSED(frame_);
+
+ fail (Error_Illegal_Action(REB_HANDLE, action));
+}
diff --git a/src/core/t-block.c b/src/core/t-block.c
old mode 100644
new mode 100755
index 8e5664417d..49a4f6031f
--- a/src/core/t-block.c
+++ b/src/core/t-block.c
@@ -1,855 +1,1069 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-block.c
-** Summary: block related datatypes
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-block.c
+// Summary: "block related datatypes"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ REBINT CT_Block(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Array: C
+//
+// "Compare Type" dispatcher for the following types: (list here to help
+// text searches)
+//
+// CT_Block()
+// CT_Group()
+// CT_Path()
+// CT_Set_Path()
+// CT_Get_Path()
+// CT_Lit_Path()
+//
+REBINT CT_Array(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBINT num;
+ REBINT num;
- if (mode == 3)
- return VAL_SERIES(a) == VAL_SERIES(b) && VAL_INDEX(a) == VAL_INDEX(b);
-
- num = Cmp_Block(a, b, mode > 1);
- if (mode >= 0) return (num == 0);
- if (mode == -1) return (num >= 0);
- return (num > 0);
+ num = Cmp_Array(a, b, LOGICAL(mode == 1));
+ if (mode >= 0) return (num == 0);
+ if (mode == -1) return (num >= 0);
+ return (num > 0);
}
-static void No_Nones(REBVAL *arg) {
- arg = VAL_BLK_DATA(arg);
- for (; NOT_END(arg); arg++) {
- if (IS_NONE(arg)) Trap_Arg(arg);
- }
-}
-/***********************************************************************
-**
-*/ REBFLG MT_Block(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
-{
- REBCNT i;
-
- if (!ANY_BLOCK(data)) return FALSE;
- if (type >= REB_PATH && type <= REB_LIT_PATH)
- if (!ANY_WORD(VAL_BLK(data))) return FALSE;
-
- *out = *data++;
- VAL_SET(out, type);
- i = IS_INTEGER(data) ? Int32(data) - 1 : 0;
- if (i > VAL_TAIL(out)) i = VAL_TAIL(out); // clip it
- VAL_INDEX(out) = i;
- return TRUE;
+//
+// MAKE_Array: C
+//
+// "Make Type" dispatcher for the following subtypes:
+//
+// MAKE_Block
+// MAKE_Group
+// MAKE_Path
+// MAKE_Set_Path
+// MAKE_Get_Path
+// MAKE_Lit_Path
+//
+void MAKE_Array(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+ //
+ // `make block! 10` => creates array with certain initial capacity
+ //
+ if (IS_INTEGER(arg) || IS_DECIMAL(arg)) {
+ Init_Any_Array(out, kind, Make_Array(Int32s(arg, 0)));
+ return;
+ }
+
+ // !!! See #2263 -- Ren-C has unified MAKE and construction syntax. A
+ // block parameter to MAKE should be arity 2...the existing array for
+ // the data source, and an offset from that array value's index:
+ //
+ // >> p1: #[path! [[a b c] 2]]
+ // == b/c
+ //
+ // >> head p1
+ // == a/b/c
+ //
+ // >> block: [a b c]
+ // >> p2: make path! compose [(block) 2]
+ // == b/c
+ //
+ // >> append block 'd
+ // == [a b c d]
+ //
+ // >> p2
+ // == b/c/d
+ //
+ // !!! This could be eased to not require the index, but without it then
+ // it can be somewhat confusing as to why [[a b c]] is needed instead of
+ // just [a b c] as the construction spec.
+ //
+ if (ANY_ARRAY(arg)) {
+ if (
+ VAL_ARRAY_LEN_AT(arg) != 2
+ || !ANY_ARRAY(VAL_ARRAY_AT(arg))
+ || !IS_INTEGER(VAL_ARRAY_AT(arg) + 1)
+ ) {
+ goto bad_make;
+ }
+
+ RELVAL *any_array = VAL_ARRAY_AT(arg);
+ REBINT index = VAL_INDEX(any_array) + Int32(VAL_ARRAY_AT(arg) + 1) - 1;
+
+ if (index < 0 || index > cast(REBINT, VAL_LEN_HEAD(any_array)))
+ goto bad_make;
+
+ REBSPC *derived = Derive_Specifier(VAL_SPECIFIER(arg), any_array);
+ Init_Any_Series_At_Core(
+ out,
+ kind,
+ SER(VAL_ARRAY(any_array)),
+ index,
+ derived
+ );
+
+ // !!! Previously this code would clear line break options on path
+ // elements, using `CLEAR_VAL_FLAG(..., VALUE_FLAG_LINE)`. But if
+ // arrays are allowed to alias each others contents, the aliasing
+ // via MAKE shouldn't modify the store. Line marker filtering out of
+ // paths should be part of the MOLDing logic -or- a path with embedded
+ // line markers should use construction syntax to preserve them.
+
+ return;
+ }
+
+ // !!! In R3-Alpha, MAKE and TO handled all cases except INTEGER!
+ // and TYPESET! in the same way. Ren-C switches MAKE of ANY-ARRAY!
+ // to be special (in order to compatible with construction syntax),
+ // continues the special treatment of INTEGER! by MAKE to mean
+ // a size, and disallows MAKE TYPESET!. This is a practical matter
+ // of addressing changes in #2263 and keeping legacy working, as
+ // opposed to endorsing any rationale in R3-Alpha's choices.
+ //
+ if (IS_TYPESET(arg))
+ goto bad_make;
+
+ TO_Array(out, kind, arg);
+ return;
+
+bad_make:
+ fail (Error_Bad_Make(kind, arg));
}
-/***********************************************************************
-**
-*/ REBCNT Find_Block(REBSER *series, REBCNT index, REBCNT end, REBVAL *target, REBCNT len, REBCNT flags, REBINT skip)
-/*
-** Flags are set according to: ALL_FIND_REFS
-**
-** Main Parameters:
-** start - index to start search
-** end - ending position
-** len - length of target
-** skip - skip factor
-** dir - direction
-**
-** Comparison Parameters:
-** case - case sensitivity
-** wild - wild cards/keys
-**
-** Final Parmameters:
-** tail - tail position
-** match - sequence
-** SELECT - (value that follows)
-**
-***********************************************************************/
-{
- REBVAL *value;
- REBVAL *val;
- REBCNT cnt;
- REBCNT start = index;
-
- if (flags & (AM_FIND_REVERSE | AM_FIND_LAST)) {
- skip = -1;
- start = 0;
- if (flags & AM_FIND_LAST) index = end - len;
- else index--;
- }
-
- // Optimized find word in block:
- if (ANY_WORD(target)) {
- for (; index >= start && index < end; index += skip) {
- value = BLK_SKIP(series, index);
- if (ANY_WORD(value)) {
- cnt = (VAL_WORD_SYM(value) == VAL_WORD_SYM(target));
- if (flags & AM_FIND_CASE) {
- // Must be same type and spelling:
- if (cnt && VAL_TYPE(value) == VAL_TYPE(target)) return index;
- }
- else {
- // Can be different type or alias:
- if (cnt || VAL_WORD_CANON(value) == VAL_WORD_CANON(target)) return index;
- }
- }
- if (flags & AM_FIND_MATCH) break;
- }
- return NOT_FOUND;
- }
- // Match a block against a block:
- else if (ANY_BLOCK(target) && !(flags & AM_FIND_ONLY)) {
- for (; index >= start && index < end; index += skip) {
- cnt = 0;
- value = BLK_SKIP(series, index);
- for (val = VAL_BLK_DATA(target); NOT_END(val); val++, value++) {
- if (0 != Cmp_Value(value, val, (REBOOL)(flags & AM_FIND_CASE))) break;
- if (++cnt >= len) {
- return index;
- }
- }
- if (flags & AM_FIND_MATCH) break;
- }
- return NOT_FOUND;
- }
- // Find a datatype in block:
- else if (IS_DATATYPE(target) || IS_TYPESET(target)) {
- for (; index >= start && index < end; index += skip) {
- value = BLK_SKIP(series, index);
- // Used if's so we can trace it...
- if (IS_DATATYPE(target)) {
- if ((REBINT)VAL_TYPE(value) == VAL_DATATYPE(target)) return index;
- if (IS_DATATYPE(value) && VAL_DATATYPE(value) == VAL_DATATYPE(target)) return index;
- }
- if (IS_TYPESET(target)) {
- if (TYPE_CHECK(target, VAL_TYPE(value))) return index;
- if (IS_DATATYPE(value) && TYPE_CHECK(target, VAL_DATATYPE(value))) return index;
- if (IS_TYPESET(value) && EQUAL_TYPESET(value, target)) return index;
- }
- if (flags & AM_FIND_MATCH) break;
- }
- return NOT_FOUND;
- }
- // All other cases:
- else {
- for (; index >= start && index < end; index += skip) {
- value = BLK_SKIP(series, index);
- if (0 == Cmp_Value(value, target, (REBOOL)(flags & AM_FIND_CASE))) return index;
- if (flags & AM_FIND_MATCH) break;
- }
- return NOT_FOUND;
- }
+//
+// TO_Array: C
+//
+void TO_Array(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+ if (IS_TYPESET(arg)) {
+ //
+ // This makes a block of types out of a typeset. Previously it was
+ // restricted to only BLOCK!, now it lets you turn a typeset into
+ // a GROUP! or a PATH!, etc.
+ //
+ Init_Any_Array(out, kind, Typeset_To_Array(arg));
+ }
+ else if (ANY_ARRAY(arg)) {
+ //
+ // `to group! [1 2 3]` etc. -- copy the array data at the index
+ // position and change the type. (Note: MAKE does not copy the
+ // data, but aliases it under a new kind.)
+ //
+ Init_Any_Array(
+ out,
+ kind,
+ Copy_Values_Len_Shallow(
+ VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg), VAL_ARRAY_LEN_AT(arg)
+ )
+ );
+ }
+ else if (IS_STRING(arg)) {
+ //
+ // `to block! "some string"` historically scans the source, so you
+ // get an unbound code array. Because the string may contain REBUNI
+ // characters, it may have to be converted to UTF8 before being
+ // used with the scanner.
+ //
+ REBCNT index;
+ REBSER *utf8 = Temp_Bin_Str_Managed(arg, &index, NULL);
+ PUSH_GUARD_SERIES(utf8);
+ REBSTR * const filename = Canon(SYM___ANONYMOUS__);
+ Init_Any_Array(
+ out,
+ kind,
+ Scan_UTF8_Managed(BIN_HEAD(utf8), BIN_LEN(utf8), filename)
+ );
+ DROP_GUARD_SERIES(utf8);
+ }
+ else if (IS_BINARY(arg)) {
+ //
+ // `to block! #{00BDAE....}` assumes the binary data is UTF8, and
+ // goes directly to the scanner to make an unbound code array.
+ //
+ REBSTR * const filename = Canon(SYM___ANONYMOUS__);
+ Init_Any_Array(
+ out,
+ kind,
+ Scan_UTF8_Managed(VAL_BIN_AT(arg), VAL_LEN_AT(arg), filename)
+ );
+ }
+ else if (IS_MAP(arg)) {
+ Init_Any_Array(out, kind, Map_To_Array(VAL_MAP(arg), 0));
+ }
+ else if (ANY_CONTEXT(arg)) {
+ Init_Any_Array(out, kind, Context_To_Array(VAL_CONTEXT(arg), 3));
+ }
+ else if (IS_VECTOR(arg)) {
+ Init_Any_Array(out, kind, Vector_To_Array(arg));
+ }
+ else {
+ // !!! The general case of not having any special conversion behavior
+ // in R3-Alpha is just to fall through to making a 1-element block
+ // containing the value. This may seem somewhat random, and an
+ // error may be preferable.
+ //
+ Init_Any_Array(out, kind, Copy_Values_Len_Shallow(arg, SPECIFIED, 1));
+ }
}
-/***********************************************************************
-**
-*/ void Modify_Blockx(REBCNT action, REBVAL *block, REBVAL *arg)
-/*
-** Actions: INSERT, APPEND, CHANGE
-**
-** block [block!] {Series at point to insert}
-** value [any-type!] {The value to insert}
-** /part {Limits to a given length or position.}
-** length [number! series! pair!]
-** /only {Inserts a series as a series.}
-** /dup {Duplicates the insert a specified number of times.}
-** count [number! pair!]
-**
-** Add:
-** Handle insert [] () case
-** What does insert () [] do?
-** /deep option for cloning subcontents?
-**
-***********************************************************************/
-{
- REBSER *series = VAL_SERIES(block);
- REBCNT index = VAL_INDEX(block);
- REBCNT tail = VAL_TAIL(block);
- REBFLG only = DS_REF(AN_ONLY);
- REBINT rlen; // length to be removed
- REBINT ilen = 1; // length to be inserted
- REBINT cnt = 1; // DUP count
- REBINT size;
- REBFLG is_blk = FALSE; // arg is a block not a value
-
- // Length of target (may modify index): (arg can be anything)
- rlen = Partial1((action == A_CHANGE) ? block : arg, DS_ARG(AN_LENGTH));
-
- index = VAL_INDEX(block);
- if (action == A_APPEND || index > tail) index = tail;
-
- // Check /PART, compute LEN:
- if (!only && ANY_BLOCK(arg)) {
- is_blk = TRUE; // arg is a block
- // Are we modifying ourselves? If so, copy arg block first:
- if (series == VAL_SERIES(arg)) {
- VAL_SERIES(arg) = Copy_Block(VAL_SERIES(arg), VAL_INDEX(arg));
- VAL_INDEX(arg) = 0;
- }
- // Length of insertion:
- ilen = (action != A_CHANGE && DS_REF(AN_PART)) ? rlen : VAL_LEN(arg);
- }
-
- // Get /DUP count:
- if (DS_REF(AN_DUP)) {
- cnt = Int32(DS_ARG(AN_COUNT));
- if (cnt <= 0) return; // no changes
- }
-
- // Total to insert:
- size = cnt * ilen;
-
- if (action != A_CHANGE) {
- // Always expand series for INSERT and APPEND actions:
- Expand_Series(series, index, size);
- } else {
- if (size > rlen)
- Expand_Series(series, index, size-rlen);
- else if (size < rlen && DS_REF(AN_PART))
- Remove_Series(series, index, rlen-size);
- else if (size + index > tail) {
- EXPAND_SERIES_TAIL(series, size - (tail - index));
- }
- }
-
- if (is_blk) arg = VAL_BLK_DATA(arg);
-
- // For dup count:
- VAL_INDEX(block) = (action == A_APPEND) ? 0 : size + index;
-
- index *= SERIES_WIDE(series); // loop invariant
- ilen *= SERIES_WIDE(series); // loop invariant
- for (; cnt > 0; cnt--) {
- memcpy(series->data + index, (REBYTE *)arg, ilen);
- index += ilen;
- }
- BLK_TERM(series);
+//
+// Find_In_Array: C
+//
+// Flags are set according to: ALL_FIND_REFS
+//
+// Main Parameters:
+// start - index to start search
+// end - ending position
+// len - length of target
+// skip - skip factor
+// dir - direction
+//
+// Comparison Parameters:
+// case - case sensitivity
+// wild - wild cards/keys
+//
+// Final Parmameters:
+// tail - tail position
+// match - sequence
+// SELECT - (value that follows)
+//
+REBCNT Find_In_Array(
+ REBARR *array,
+ REBCNT index,
+ REBCNT end,
+ const RELVAL *target,
+ REBCNT len,
+ REBFLGS flags,
+ REBINT skip
+) {
+ RELVAL *value;
+ RELVAL *val;
+ REBCNT cnt;
+ REBCNT start = index;
+
+ if (flags & (AM_FIND_REVERSE | AM_FIND_LAST)) {
+ skip = -1;
+ start = 0;
+ if (flags & AM_FIND_LAST) index = end - len;
+ else index--;
+ }
+
+ // Optimized find word in block:
+ if (ANY_WORD(target)) {
+ for (; index >= start && index < end; index += skip) {
+ value = ARR_AT(array, index);
+ if (ANY_WORD(value)) {
+ cnt = (VAL_WORD_SPELLING(value) == VAL_WORD_SPELLING(target));
+ if (flags & AM_FIND_CASE) {
+ // Must be same type and spelling:
+ if (cnt && VAL_TYPE(value) == VAL_TYPE(target)) return index;
+ }
+ else {
+ // Can be different type or alias:
+ if (cnt || VAL_WORD_CANON(value) == VAL_WORD_CANON(target)) return index;
+ }
+ }
+ if (flags & AM_FIND_MATCH) break;
+ }
+ return NOT_FOUND;
+ }
+ // Match a block against a block:
+ else if (ANY_ARRAY(target) && !(flags & AM_FIND_ONLY)) {
+ for (; index >= start && index < end; index += skip) {
+ cnt = 0;
+ value = ARR_AT(array, index);
+ for (val = VAL_ARRAY_AT(target); NOT_END(val); val++, value++) {
+ if (0 != Cmp_Value(value, val, LOGICAL(flags & AM_FIND_CASE)))
+ break;
+ if (++cnt >= len) {
+ return index;
+ }
+ }
+ if (flags & AM_FIND_MATCH) break;
+ }
+ return NOT_FOUND;
+ }
+ // Find a datatype in block:
+ else if (IS_DATATYPE(target) || IS_TYPESET(target)) {
+ for (; index >= start && index < end; index += skip) {
+ value = ARR_AT(array, index);
+ // Used if's so we can trace it...
+ if (IS_DATATYPE(target)) {
+ if (VAL_TYPE(value) == VAL_TYPE_KIND(target)) return index;
+ if (IS_DATATYPE(value) && VAL_TYPE_KIND(value) == VAL_TYPE_KIND(target)) return index;
+ }
+ if (IS_TYPESET(target)) {
+ if (TYPE_CHECK(target, VAL_TYPE(value))) return index;
+ if (IS_DATATYPE(value) && TYPE_CHECK(target, VAL_TYPE_KIND(value))) return index;
+ if (IS_TYPESET(value) && EQUAL_TYPESET(value, target)) return index;
+ }
+ if (flags & AM_FIND_MATCH) break;
+ }
+ return NOT_FOUND;
+ }
+ // All other cases:
+ else {
+ for (; index >= start && index < end; index += skip) {
+ value = ARR_AT(array, index);
+ if (
+ 0 == Cmp_Value(
+ value, target, LOGICAL(flags & AM_FIND_CASE)
+ )
+ ) {
+ return index;
+ }
+
+ if (flags & AM_FIND_MATCH) break;
+ }
+ return NOT_FOUND;
+ }
}
-/***********************************************************************
-**
-*/ void Make_Block_Type(REBFLG make, REBVAL *value, REBVAL *arg)
-/*
-** Value can be:
-** 1. a datatype (e.g. BLOCK!)
-** 2. a value (e.g. [...])
-**
-** Arg can be:
-** 1. integer (length of block)
-** 2. block (copy it)
-** 3. value (convert to a block)
-**
-***********************************************************************/
-{
- REBCNT type;
- REBCNT len;
- REBSER *ser;
-
- // make block! ...
- if (IS_DATATYPE(value))
- type = VAL_DATATYPE(value);
- else // make [...] ....
- type = VAL_TYPE(value);
-
- // make block! [1 2 3]
- if (ANY_BLOCK(arg)) {
- len = VAL_BLK_LEN(arg);
- if (len > 0 && type >= REB_PATH && type <= REB_LIT_PATH)
- No_Nones(arg);
- ser = Copy_Values(VAL_BLK_DATA(arg), len);
- goto done;
- }
-
- if (IS_STRING(arg)) {
- REBCNT index, len = 0;
- VAL_SERIES(arg) = Prep_Bin_Str(arg, &index, &len); // (keeps safe)
- ser = Scan_Source(VAL_BIN(arg), VAL_LEN(arg));
- goto done;
- }
-
- if (IS_BINARY(arg)) {
- ser = Scan_Source(VAL_BIN_DATA(arg), VAL_LEN(arg));
- goto done;
- }
-
- if (IS_MAP(arg)) {
- ser = Map_To_Block(VAL_SERIES(arg), 0);
- goto done;
- }
-
- if (ANY_OBJECT(arg)) {
- ser = Make_Object_Block(VAL_OBJ_FRAME(arg), 3);
- goto done;
- }
-
- if (IS_VECTOR(arg)) {
- ser = Make_Vector_Block(arg);
- goto done;
- }
-
-// if (make && IS_NONE(arg)) {
-// ser = Make_Block(0);
-// goto done;
-// }
-
- // to block! typset
- if (!make && IS_TYPESET(arg) && type == REB_BLOCK) {
- Set_Block(value, Typeset_To_Block(arg));
- return;
- }
-
- if (make) {
- // make block! 10
- if (IS_INTEGER(arg) || IS_DECIMAL(arg)) {
- len = Int32s(arg, 0);
- Set_Series(type, value, Make_Block(len));
- return;
- }
- Trap_Arg(arg);
- }
-
- ser = Copy_Values(arg, 1);
-
-done:
- Set_Series(type, value, ser);
- return;
-}
+struct sort_flags {
+ REBOOL cased;
+ REBOOL reverse;
+ REBCNT offset;
+ REBVAL *comparator;
+ REBOOL all; // !!! not used?
+};
+
-// WARNING! Not re-entrant. !!! Must find a way to push it on stack?
-static struct {
- REBFLG cased;
- REBFLG reverse;
- REBCNT offset;
- REBVAL *compare;
-} sort_flags = {0};
-
-/***********************************************************************
-**
-*/ static int Compare_Val(const void *v1, const void *v2)
-/*
-***********************************************************************/
+//
+// Compare_Val: C
+//
+static int Compare_Val(void *arg, const void *v1, const void *v2)
{
- // !!!! BE SURE that 64 bit large difference comparisons work
-
- if (sort_flags.reverse)
- return Cmp_Value((REBVAL*)v2+sort_flags.offset, (REBVAL*)v1+sort_flags.offset, sort_flags.cased);
- else
- return Cmp_Value((REBVAL*)v1+sort_flags.offset, (REBVAL*)v2+sort_flags.offset, sort_flags.cased);
-
-/*
- REBI64 n = VAL_INT64((REBVAL*)v1) - VAL_INT64((REBVAL*)v2);
- if (n > 0) return 1;
- if (n < 0) return -1;
- return 0;
-*/
+ struct sort_flags *flags = cast(struct sort_flags*, arg);
+
+ // !!!! BE SURE that 64 bit large difference comparisons work
+
+ if (flags->reverse)
+ return Cmp_Value(
+ cast(const RELVAL*, v2) + flags->offset,
+ cast(const RELVAL*, v1) + flags->offset,
+ flags->cased
+ );
+ else
+ return Cmp_Value(
+ cast(const RELVAL*, v1) + flags->offset,
+ cast(const RELVAL*, v2) + flags->offset,
+ flags->cased
+ );
}
-/***********************************************************************
-**
-*/ static int Compare_Call(const void *v1, const void *v2)
-/*
-***********************************************************************/
+//
+// Compare_Val_Custom: C
+//
+static int Compare_Val_Custom(void *arg, const void *v1, const void *v2)
{
- REBVAL *val;
-
- if (sort_flags.reverse)
- val = Apply_Func(0, sort_flags.compare, v1, v2, 0);
- else
- val = Apply_Func(0, sort_flags.compare, v2, v1, 0);
-
- if (IS_LOGIC(val)) {
- if (IS_TRUE(val)) return 1;
- return -1;
- }
- if (IS_INTEGER(val)) {
- if (VAL_INT64(val) > 0) return 1;
- if (VAL_INT64(val) == 0) return 0;
- return -1;
- }
- if (IS_DECIMAL(val)) {
- if (VAL_DECIMAL(val) > 0) return 1;
- if (VAL_DECIMAL(val) == 0) return 0;
- return -1;
- }
- if (IS_TRUE(val)) return 1;
- return -1;
+ struct sort_flags *flags = cast(struct sort_flags*, arg);
+
+ const REBOOL fully = TRUE; // error if not all arguments consumed
+
+ DECLARE_LOCAL (result);
+ if (Apply_Only_Throws(
+ result,
+ fully,
+ flags->comparator,
+ flags->reverse ? v1 : v2,
+ flags->reverse ? v2 : v1,
+ END
+ )) {
+ fail (Error_No_Catch_For_Throw(result));
+ }
+
+ REBINT tristate = -1;
+
+ if (IS_LOGIC(result)) {
+ if (VAL_LOGIC(result))
+ tristate = 1;
+ }
+ else if (IS_INTEGER(result)) {
+ if (VAL_INT64(result) > 0)
+ tristate = 1;
+ else if (VAL_INT64(result) == 0)
+ tristate = 0;
+ }
+ else if (IS_DECIMAL(result)) {
+ if (VAL_DECIMAL(result) > 0)
+ tristate = 1;
+ else if (VAL_DECIMAL(result) == 0)
+ tristate = 0;
+ }
+ else if (IS_CONDITIONAL_TRUE(result))
+ tristate = 1;
+
+ return tristate;
}
-/***********************************************************************
-**
-*/ static void Sort_Block(REBVAL *block, REBFLG ccase, REBVAL *skipv, REBVAL *compv, REBVAL *part, REBFLG all, REBFLG rev)
-/*
-** series [series!]
-** /case {Case sensitive sort}
-** /skip {Treat the series as records of fixed size}
-** size [integer!] {Size of each record}
-** /compare {Comparator offset, block or function}
-** comparator [integer! block! function!]
-** /part {Sort only part of a series}
-** length [number! series!] {Length of series to sort}
-** /all {Compare all fields}
-** /reverse {Reverse sort order}
-**
-***********************************************************************/
-{
- REBCNT len;
- REBCNT skip = 1;
- REBCNT size = sizeof(REBVAL);
-// int (*sfunc)(const void *v1, const void *v2);
-
- sort_flags.cased = ccase;
- sort_flags.reverse = rev;
- sort_flags.compare = 0;
- sort_flags.offset = 0;
-
- if (IS_INTEGER(compv)) sort_flags.offset = Int32(compv)-1;
- if (ANY_FUNC(compv)) sort_flags.compare = compv;
-
- // Determine length of sort:
- len = Partial1(block, part);
- if (len <= 1) return;
-
- // Skip factor:
- if (!IS_NONE(skipv)) {
- skip = Get_Num_Arg(skipv);
- if (skip <= 0 || len % skip != 0 || skip > len)
- Trap_Range(skipv);
- }
-
- // Use fast quicksort library function:
- if (skip > 1) len /= skip, size *= skip;
-
- if (sort_flags.compare)
- qsort((void *)VAL_BLK_DATA(block), len, size, Compare_Call);
- else
- qsort((void *)VAL_BLK_DATA(block), len, size, Compare_Val);
-
+//
+// Sort_Block: C
+//
+// series [any-series!]
+// /case {Case sensitive sort}
+// /skip {Treat the series as records of fixed size}
+// size [integer!] {Size of each record}
+// /compare {Comparator offset, block or function}
+// comparator [integer! block! function!]
+// /part {Sort only part of a series}
+// limit [any-number! any-series!] {Length of series to sort}
+// /all {Compare all fields}
+// /reverse {Reverse sort order}
+//
+static void Sort_Block(
+ REBVAL *block,
+ REBOOL ccase,
+ REBVAL *skipv,
+ REBVAL *compv,
+ REBVAL *part,
+ REBOOL all,
+ REBOOL rev
+) {
+ struct sort_flags flags;
+ flags.cased = ccase;
+ flags.reverse = rev;
+ flags.all = all; // !!! not used?
+
+ if (IS_FUNCTION(compv)) {
+ flags.comparator = compv;
+ flags.offset = 0;
+ }
+ else if (IS_INTEGER(compv)) {
+ flags.comparator = NULL;
+ flags.offset = Int32(compv) - 1;
+ }
+ else {
+ assert(IS_VOID(compv));
+ flags.comparator = NULL;
+ flags.offset = 0;
+ }
+
+ // Determine length of sort:
+ REBCNT len;
+ Partial1(block, part, &len);
+ if (len <= 1)
+ return;
+
+ // Skip factor:
+ REBCNT skip;
+ if (!IS_VOID(skipv)) {
+ skip = Get_Num_From_Arg(skipv);
+ if (skip <= 0 || len % skip != 0 || skip > len)
+ fail (Error_Out_Of_Range(skipv));
+ }
+ else
+ skip = 1;
+
+ reb_qsort_r(
+ VAL_ARRAY_AT(block),
+ len / skip,
+ sizeof(REBVAL) * skip,
+ &flags,
+ flags.comparator != NULL ? &Compare_Val_Custom : &Compare_Val
+ );
}
-/***********************************************************************
-**
-*/ static void Trim_Block(REBSER *ser, REBCNT index, REBCNT flags)
-/*
-** See Trim_String().
-**
-***********************************************************************/
+//
+// Shuffle_Block: C
+//
+void Shuffle_Block(REBVAL *value, REBOOL secure)
{
- REBVAL *blk = BLK_HEAD(ser);
- REBCNT out = index;
- REBCNT end = ser->tail;
-
- if (flags & AM_TRIM_TAIL) {
- for (; end >= (index+1); end--) {
- if (VAL_TYPE(blk+end-1) > REB_NONE) break;
- }
- Remove_Series(ser, end, ser->tail - end);
- if (!(flags & AM_TRIM_HEAD) || index >= end) return;
- }
-
- if (flags & AM_TRIM_HEAD) {
- for (; index < end; index++) {
- if (VAL_TYPE(blk+index) > REB_NONE) break;
- }
- Remove_Series(ser, out, index - out);
- }
-
- if (flags == 0) {
- for (; index < end; index++) {
- if (VAL_TYPE(blk+index) > REB_NONE) {
- *BLK_SKIP(ser, out) = blk[index];
- out++;
- }
- }
- Remove_Series(ser, out, end - out);
- }
+ REBCNT n;
+ REBCNT k;
+ REBCNT idx = VAL_INDEX(value);
+ RELVAL *data = VAL_ARRAY_HEAD(value);
+
+ // Rare case where RELVAL bit copying is okay...between spots in the
+ // same array.
+ //
+ RELVAL swap;
+
+ for (n = VAL_LEN_AT(value); n > 1;) {
+ k = idx + (REBCNT)Random_Int(secure) % n;
+ n--;
+ swap = data[k];
+ data[k] = data[n + idx];
+ data[n + idx] = swap;
+ }
}
-/***********************************************************************
-**
-*/ void Shuffle_Block(REBVAL *value, REBFLG secure)
-/*
-***********************************************************************/
+//
+// PD_Array: C
+//
+// Path dispatch for the following types:
+//
+// PD_Block
+// PD_Group
+// PD_Path
+// PD_Get_Path
+// PD_Set_Path
+// PD_Lit_Path
+//
+REBINT PD_Array(REBPVS *pvs)
{
- REBCNT n;
- REBCNT k;
- REBCNT idx = VAL_INDEX(value);
- REBVAL *data = VAL_BLK(value);
- REBVAL swap;
-
- for (n = VAL_LEN(value); n > 1;) {
- k = idx + (REBCNT)Random_Int(secure) % n;
- n--;
- swap = data[k];
- data[k] = data[n + idx];
- data[n + idx] = swap;
- }
+ REBINT n = 0;
+
+ /* Issues!!!
+ a/1.3
+ a/not-found: 10 error or append?
+ a/not-followed: 10 error or append?
+ */
+
+ if (IS_INTEGER(pvs->picker)) {
+ n = Int32(pvs->picker) + VAL_INDEX(pvs->value) - 1;
+ }
+ else if (IS_WORD(pvs->picker)) {
+ n = Find_Word_In_Array(
+ VAL_ARRAY(pvs->value),
+ VAL_INDEX(pvs->value),
+ VAL_WORD_CANON(pvs->picker)
+ );
+ if (cast(REBCNT, n) != NOT_FOUND) n++;
+ }
+ else if (IS_LOGIC(pvs->picker)) {
+ //
+ // !!! PICK in R3-Alpha historically would use a logic TRUE to get
+ // the first element in an array, and a logic FALSE to get the second.
+ // It did this regardless of how many elements were in the array.
+ // (For safety, it has been suggested non-binary arrays should fail).
+ // But path picking would act like you had written SELECT and looked
+ // for the item to come after a TRUE. With the merging of path
+ // picking and PICK, this changes the behavior.
+ //
+ if (VAL_LOGIC(pvs->picker))
+ n = VAL_INDEX(pvs->value);
+ else
+ n = VAL_INDEX(pvs->value) + 1;
+ }
+ else {
+ // other values:
+ n = 1 + Find_In_Array_Simple(
+ VAL_ARRAY(pvs->value),
+ VAL_INDEX(pvs->value),
+ pvs->picker
+ );
+ }
+
+ if (n < 0 || cast(REBCNT, n) >= VAL_LEN_HEAD(pvs->value)) {
+ if (pvs->opt_setval)
+ fail (Error_Bad_Path_Select(pvs));
+
+ Init_Void(pvs->store);
+ return PE_USE_STORE;
+ }
+
+ if (pvs->opt_setval)
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(pvs->value));
+
+ pvs->value_specifier = Derive_Specifier(pvs->value_specifier, pvs->value);
+ pvs->value = VAL_ARRAY_AT_HEAD(pvs->value, n);
+
+#if !defined(NDEBUG)
+ if (pvs->value_specifier == SPECIFIED && IS_RELATIVE(pvs->value)) {
+ printf("Relative value found in PD_Array with no specifier\n");
+ panic (pvs->value);
+ }
+#endif
+
+ return PE_SET_IF_END;
}
-/***********************************************************************
-**
-*/ REBINT PD_Block(REBPVS *pvs)
-/*
-***********************************************************************/
+//
+// Pick_Block: C
+//
+// Fills out with void if no pick.
+//
+RELVAL *Pick_Block(REBVAL *out, const REBVAL *block, const REBVAL *picker)
{
- REBINT n = 0;
-
- /* Issues!!!
- a/1.3
- a/not-found: 10 error or append?
- a/not-followed: 10 error or append?
- */
-
- if (IS_INTEGER(pvs->select)) {
- n = Int32(pvs->select) + VAL_INDEX(pvs->value) - 1;
- }
- else if (IS_WORD(pvs->select)) {
- n = Find_Word(VAL_SERIES(pvs->value), VAL_INDEX(pvs->value), VAL_WORD_CANON(pvs->select));
- if (n != NOT_FOUND) n++;
- }
- else {
- // other values:
- n = Find_Block_Simple(VAL_SERIES(pvs->value), VAL_INDEX(pvs->value), pvs->select) + 1;
- }
-
- if (n < 0 || (REBCNT)n >= VAL_TAIL(pvs->value)) {
- if (pvs->setval) return PE_BAD_SELECT;
- return PE_NONE;
- }
-
- if (pvs->setval) TRAP_PROTECT(VAL_SERIES(pvs->value));
- pvs->value = VAL_BLK_SKIP(pvs->value, n);
- // if valset - check PROTECT on block
- //if (NOT_END(pvs->path+1)) Next_Path(pvs); return PE_OK;
- return PE_SET;
+ REBINT n = Get_Num_From_Arg(picker);
+ n += VAL_INDEX(block) - 1;
+ if (n < 0 || cast(REBCNT, n) >= VAL_LEN_HEAD(block)) {
+ Init_Void(out);
+ return NULL;
+ }
+
+ RELVAL *slot = VAL_ARRAY_AT_HEAD(block, n);
+ Derelativize(out, slot, VAL_SPECIFIER(block));
+ return slot;
}
-/***********************************************************************
-**
-*/ REBVAL *Pick_Block(REBVAL *block, REBVAL *selector)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+// Implementation of type dispatch of the following:
+//
+// REBTYPE(Block)
+// REBTYPE(Group)
+// REBTYPE(Path)
+// REBTYPE(Get_Path)
+// REBTYPE(Set_Path)
+// REBTYPE(Lit_Path)
+//
+REBTYPE(Array)
{
- REBINT n = 0;
+ REBVAL *value = D_ARG(1);
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
- n = Get_Num_Arg(selector);
- n += VAL_INDEX(block) - 1;
- if (n < 0 || (REBCNT)n >= VAL_TAIL(block)) return 0;
- return VAL_BLK_SKIP(block, n);
+ // Common operations for any series type (length, head, etc.)
+ {
+ REB_R r = Series_Common_Action_Maybe_Unhandled(frame_, action);
+ if (r != R_UNHANDLED)
+ return r;
+ }
+
+ // NOTE: Partial1() used below can mutate VAL_INDEX(value), be aware :-/
+ //
+ REBARR *array = VAL_ARRAY(value);
+ REBCNT index = VAL_INDEX(value);
+ REBSPC *specifier = VAL_SPECIFIER(value);
+
+ switch (action) {
+
+ case SYM_TAKE_P: {
+ INCLUDE_PARAMS_OF_TAKE_P;
+
+ UNUSED(PAR(series));
+ if (REF(deep))
+ fail (Error_Bad_Refines_Raw());
+
+ REBCNT len;
+
+ FAIL_IF_READ_ONLY_ARRAY(array);
+
+ if (REF(part)) {
+ Partial1(value, ARG(limit), &len);
+ if (len == 0)
+ goto return_empty_block;
+
+ assert(VAL_LEN_HEAD(value) >= len);
+ }
+ else
+ len = 1;
+
+ index = VAL_INDEX(value); // /part can change index
+
+ if (REF(last))
+ index = VAL_LEN_HEAD(value) - len;
+
+ if (index >= VAL_LEN_HEAD(value)) {
+ if (NOT(REF(part)))
+ return R_VOID;
+
+ goto return_empty_block;
+ }
+
+ if (REF(part))
+ Init_Block(
+ D_OUT, Copy_Array_At_Max_Shallow(array, index, specifier, len)
+ );
+ else
+ Derelativize(D_OUT, &ARR_HEAD(array)[index], specifier);
+
+ Remove_Series(SER(array), index, len);
+ return R_OUT;
+ }
+
+ //-- Search:
+
+ case SYM_FIND:
+ case SYM_SELECT_P: {
+ INCLUDE_PARAMS_OF_FIND;
+
+ UNUSED(PAR(series));
+ UNUSED(PAR(value)); // aliased as arg
+
+ REBINT len = ANY_ARRAY(arg) ? VAL_ARRAY_LEN_AT(arg) : 1;
+
+ REBCNT limit;
+ if (REF(part))
+ Partial1(value, ARG(limit), &limit);
+ else
+ limit = VAL_LEN_HEAD(value);
+
+ REBFLGS flags = (
+ (REF(only) ? AM_FIND_ONLY : 0)
+ | (REF(match) ? AM_FIND_MATCH : 0)
+ | (REF(reverse) ? AM_FIND_REVERSE : 0)
+ | (REF(case) ? AM_FIND_CASE : 0)
+ | (REF(last) ? AM_FIND_LAST : 0)
+ );
+
+ REBCNT skip = REF(skip) ? Int32s(ARG(size), 1) : 1;
+
+ REBCNT ret = Find_In_Array(
+ array, index, limit, arg, len, flags, skip
+ );
+
+ if (ret >= limit) {
+ if (action == SYM_FIND)
+ return R_BLANK;
+ return R_VOID;
+ }
+
+ if (REF(only))
+ len = 1;
+
+ if (action == SYM_FIND) {
+ if (REF(tail) || REF(match))
+ ret += len;
+ VAL_INDEX(value) = ret;
+ Move_Value(D_OUT, value);
+ }
+ else {
+ ret += len;
+ if (ret >= limit) {
+ if (action == SYM_FIND)
+ return R_BLANK;
+ return R_VOID;
+ }
+ Derelativize(D_OUT, ARR_AT(array, ret), specifier);
+ }
+ return R_OUT;
+ }
+
+ //-- Modification:
+ case SYM_APPEND:
+ case SYM_INSERT:
+ case SYM_CHANGE: {
+ INCLUDE_PARAMS_OF_INSERT;
+
+ UNUSED(PAR(series));
+ UNUSED(PAR(value));
+
+ // Length of target (may modify index): (arg can be anything)
+ //
+ REBCNT len;
+ Partial1(
+ (action == SYM_CHANGE)
+ ? value
+ : arg,
+ ARG(limit),
+ &len
+ );
+
+ FAIL_IF_READ_ONLY_ARRAY(array);
+ index = VAL_INDEX(value);
+
+ REBFLGS flags = 0;
+ if (REF(only))
+ flags |= AM_ONLY;
+ if (REF(part))
+ flags |= AM_PART;
+
+ index = Modify_Array(
+ action,
+ array,
+ index,
+ arg,
+ flags,
+ len,
+ REF(dup) ? Int32(ARG(count)) : 1
+ );
+ VAL_INDEX(value) = index;
+ Move_Value(D_OUT, value);
+ return R_OUT;
+ }
+
+ case SYM_CLEAR: {
+ FAIL_IF_READ_ONLY_ARRAY(array);
+ if (index < VAL_LEN_HEAD(value)) {
+ if (index == 0) Reset_Array(array);
+ else {
+ SET_END(ARR_AT(array, index));
+ SET_SERIES_LEN(VAL_SERIES(value), cast(REBCNT, index));
+ }
+ }
+ Move_Value(D_OUT, value);
+ return R_OUT;
+ }
+
+ //-- Creation:
+
+ case SYM_COPY: {
+ INCLUDE_PARAMS_OF_COPY;
+
+ UNUSED(PAR(value));
+
+ REBU64 types = 0;
+ REBCNT tail = 0;
+
+ UNUSED(REF(part));
+ Partial1(value, ARG(limit), &tail); // may change VAL_INDEX
+ tail += VAL_INDEX(value);
+
+ if (REF(deep))
+ types |= REF(types) ? 0 : TS_STD_SERIES;
+
+ if (REF(types)) {
+ if (IS_DATATYPE(ARG(kinds)))
+ types |= FLAGIT_KIND(VAL_TYPE(ARG(kinds)));
+ else
+ types |= VAL_TYPESET_BITS(ARG(kinds));
+ }
+
+ REBARR *copy = Copy_Array_Core_Managed(
+ array,
+ VAL_INDEX(value), // at
+ specifier,
+ tail, // tail
+ 0, // extra
+ REF(deep), // deep
+ types // types
+ );
+ Init_Any_Array(D_OUT, VAL_TYPE(value), copy);
+ return R_OUT;
+ }
+
+ //-- Special actions:
+
+ case SYM_TRIM: {
+ INCLUDE_PARAMS_OF_TRIM;
+
+ UNUSED(PAR(series));
+
+ FAIL_IF_READ_ONLY_ARRAY(array);
+
+ if (REF(auto) || REF(all) || REF(lines))
+ fail (Error_Bad_Refines_Raw());
+
+ if (REF(with)) {
+ UNUSED(ARG(str));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ RELVAL *head = ARR_HEAD(array);
+ REBCNT out = index;
+ REBINT end = ARR_LEN(array);
+
+ if (REF(tail)) {
+ for (; end >= cast(REBINT, index + 1); end--) {
+ if (VAL_TYPE(head + end - 1) != REB_BLANK)
+ break;
+ }
+ Remove_Series(SER(array), end, ARR_LEN(array) - end);
+
+ // if (!(flags & AM_TRIM_HEAD) || index >= end) return;
+ }
+
+ if (REF(head)) {
+ for (; cast(REBINT, index) < end; index++) {
+ if (VAL_TYPE(head + index) != REB_BLANK) break;
+ }
+ Remove_Series(SER(array), out, index - out);
+ }
+
+ if (NOT(REF(head) || REF(tail))) {
+ for (; cast(REBINT, index) < end; index++) {
+ if (VAL_TYPE(head + index) != REB_BLANK) {
+ //
+ // Rare case of legal RELVAL bit copying... from one slot
+ // in an array to another in that same array.
+ //
+ *ARR_AT(array, out) = head[index];
+ out++;
+ }
+ }
+ Remove_Series(SER(array), out, end - out);
+ }
+
+ Move_Value(D_OUT, value);
+ return R_OUT;
+ }
+
+ case SYM_SWAP: {
+ if (NOT(ANY_ARRAY(arg)))
+ fail (arg);
+
+ FAIL_IF_READ_ONLY_ARRAY(array);
+ FAIL_IF_READ_ONLY_ARRAY(VAL_ARRAY(arg));
+
+ if (
+ index < VAL_LEN_HEAD(value)
+ && VAL_INDEX(arg) < VAL_LEN_HEAD(arg)
+ ) {
+ // RELVAL bits can be copied within the same array
+ //
+ RELVAL temp = *VAL_ARRAY_AT(value);
+ *VAL_ARRAY_AT(value) = *VAL_ARRAY_AT(arg);
+ *VAL_ARRAY_AT(arg) = temp;
+ }
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT;
+ }
+
+ case SYM_REVERSE: {
+ REBCNT len;
+ Partial1(value, D_ARG(3), &len);
+
+ FAIL_IF_READ_ONLY_ARRAY(array);
+
+ if (len != 0) {
+ //
+ // RELVAL bits may be copied from slots within the same array
+ //
+ RELVAL *front = VAL_ARRAY_AT(value);
+ RELVAL *back = front + len - 1;
+ for (len /= 2; len > 0; len--) {
+ RELVAL temp = *front;
+ *front++ = *back;
+ *back-- = temp;
+ }
+ }
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT;
+ }
+
+ case SYM_SORT: {
+ INCLUDE_PARAMS_OF_SORT;
+
+ UNUSED(PAR(series));
+ UNUSED(REF(part)); // checks limit as void
+ UNUSED(REF(skip)); // checks size as void
+ UNUSED(REF(compare)); // checks comparator as void
+
+ FAIL_IF_READ_ONLY_ARRAY(array);
+
+ Sort_Block(
+ value,
+ REF(case),
+ ARG(size), // skip size (may be void if no /SKIP)
+ ARG(comparator), // (may be void if no /COMPARE)
+ ARG(limit), // (may be void if no /PART)
+ REF(all),
+ REF(reverse)
+ );
+ Move_Value(D_OUT, value);
+ return R_OUT;
+ }
+
+ case SYM_RANDOM: {
+ INCLUDE_PARAMS_OF_RANDOM;
+
+ UNUSED(PAR(value));
+
+ if (REF(seed))
+ fail (Error_Bad_Refines_Raw());
+
+ if (REF(only)) { // pick an element out of the array
+ if (index >= VAL_LEN_HEAD(value))
+ return R_BLANK;
+
+ Init_Integer(
+ ARG(seed),
+ 1 + (Random_Int(REF(secure)) % (VAL_LEN_HEAD(value) - index))
+ );
+
+ RELVAL *slot = Pick_Block(D_OUT, value, ARG(seed));
+ if (IS_VOID(D_OUT)) {
+ assert(slot == NULL);
+ UNUSED(slot);
+ return R_VOID;
+ }
+ return R_OUT;
+
+ }
+
+ Shuffle_Block(value, REF(secure));
+ Move_Value(D_OUT, value);
+ return R_OUT;
+ }
+
+ default:
+ break; // fallthrough to error
+ }
+
+ // If it wasn't one of the block actions, fall through and let the port
+ // system try. OPEN [scheme: ...], READ [ ], etc.
+ //
+ // !!! This used to be done by sensing explicitly what a "port action"
+ // was, but that involved checking if the action was in a numeric range.
+ // The symbol-based action dispatch is more open-ended. Trying this
+ // to see how it works.
+
+ return T_Port(frame_, action);
+
+return_empty_block:
+ Init_Block(D_OUT, Make_Array(0));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBTYPE(Block)
-/*
-***********************************************************************/
+#if !defined(NDEBUG)
+
+//
+// Assert_Array_Core: C
+//
+void Assert_Array_Core(REBARR *a)
{
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBSER *ser;
- REBINT index;
- REBINT tail;
- REBINT len;
- REBVAL val;
- REBCNT args;
- REBCNT ret;
-
- // Support for port: OPEN [scheme: ...], READ [ ], etc.
- if (action >= PORT_ACTIONS && IS_BLOCK(value))
- return T_Port(ds, action);
-
- // Most common series actions: !!! speed this up!
- len = Do_Series_Action(action, value, arg);
- if (len >= 0) return len; // return code
-
- // Special case (to avoid fetch of index and tail below):
- if (action == A_MAKE || action == A_TO) {
- Make_Block_Type(action == A_MAKE, value, arg); // returned in value
- if (ANY_PATH(value)) Clear_Value_Opts(VAL_SERIES(value));
- *D_RET = *value;
- return R_RET;
- }
-
- index = (REBINT)VAL_INDEX(value);
- tail = (REBINT)VAL_TAIL(value);
- ser = VAL_SERIES(value);
-
- // Check must be in this order (to avoid checking a non-series value);
- if (action >= A_TAKE && action <= A_SORT && IS_PROTECT_SERIES(ser))
- Trap0(RE_PROTECTED);
-
- switch (action) {
-
- //-- Picking:
-
-#ifdef REMOVE_THIS
-
-//CHANGE SELECT TO USE PD_BLOCK?
-
- case A_PATH:
- if (IS_INTEGER(arg)) {
- action = A_PICK;
- goto repick;
- }
- // block/select case:
- ret = Find_Block_Simple(ser, index, arg);
- goto select_val;
-
- case A_PATH_SET:
- action = A_POKE;
- // no SELECT case allowed !!!!
-#endif
+ // Basic integrity checks (series is not marked free, etc.) Note that
+ // we don't use ASSERT_SERIES the macro here, because that checks to
+ // see if the series is an array...and if so, would call this routine
+ //
+ Assert_Series_Core(SER(a));
+
+ if (NOT(GET_SER_FLAG(a, SERIES_FLAG_ARRAY)))
+ panic (a);
+
+ RELVAL *item = ARR_HEAD(a);
+ REBCNT i;
+ for (i = 0; i < ARR_LEN(a); ++i, ++item) {
+ if (IS_END(item)) {
+ printf("Premature array end at index %d\n", cast(int, i));
+ panic (a);
+ }
+ }
+
+ if (NOT_END(item))
+ panic (item);
+
+ if (GET_SER_INFO(a, SERIES_INFO_HAS_DYNAMIC)) {
+ REBCNT rest = SER_REST(SER(a));
+
+ assert(rest > 0 && rest > i);
+ for (; i < rest - 1; ++i, ++item) {
+ if (NOT(item->header.bits & NODE_FLAG_CELL)) {
+ printf("Unwritable cell found in array rest capacity\n");
+ panic (a);
+ }
+ }
+ assert(item == ARR_AT(a, rest - 1));
+
+ RELVAL *ultimate = ARR_AT(a, rest - 1);
+ if (NOT_END(ultimate) || (ultimate->header.bits & NODE_FLAG_CELL)) {
+ printf("Implicit termination/unwritable END missing from array\n");
+ panic (a);
+ }
+ }
- case A_POKE:
- case A_PICK:
-repick:
- value = Pick_Block(value, arg);
- if (action == A_PICK) {
- if (!value) goto is_none;
- *D_RET = *value;
- } else {
- if (!value) Trap_Range(arg);
- arg = D_ARG(3);
- *value = *arg;
- *D_RET = *arg;
- }
- return R_RET;
-
-/*
- len = Get_Num_Arg(arg); // Position
- index += len;
- if (len > 0) index--;
- if (len == 0 || index < 0 || index >= tail) {
- if (action == A_PICK) goto is_none;
- Trap_Range(arg);
- }
- if (action == A_PICK) {
-pick_it:
- *D_RET = BLK_HEAD(ser)[index];
- return R_RET;
- }
- arg = D_ARG(3);
- *D_RET = *arg;
- BLK_HEAD(ser)[index] = *arg;
- return R_RET;
-*/
-
- case A_TAKE:
- // take/part:
- if (D_REF(2)) {
- len = Partial1(value, D_ARG(3));
- if (len == 0) {
-zero_blk:
- Set_Block(D_RET, Make_Block(0));
- return R_RET;
- }
- } else
- len = 1;
-
- index = VAL_INDEX(value); // /part can change index
- // take/last:
- if (D_REF(5)) index = tail - len;
- if (index < 0 || index >= tail) {
- if (!D_REF(2)) goto is_none;
- goto zero_blk;
- }
-
- // if no /part, just return value, else return block:
- if (!D_REF(2)) *D_RET = BLK_HEAD(ser)[index];
- else Set_Block(D_RET, Copy_Block_Len(ser, index, len)); // no more /DEEP
-// else Set_Block(D_RET, Copy_Block_Deep(ser, index, len, D_REF(4) ? COPY_DEEP: 0));
- Remove_Series(ser, index, len);
- return R_RET;
-
- //-- Search:
-
- case A_FIND:
- case A_SELECT:
- args = Find_Refines(ds, ALL_FIND_REFS);
-// if (ANY_BLOCK(arg) || args) {
- len = ANY_BLOCK(arg) ? VAL_BLK_LEN(arg) : 1;
- if (args & AM_FIND_PART) tail = Partial1(value, D_ARG(ARG_FIND_LENGTH));
- ret = 1;
- if (args & AM_FIND_SKIP) ret = Int32s(D_ARG(ARG_FIND_SIZE), 1);
- ret = Find_Block(ser, index, tail, arg, len, args, ret);
-// }
-/* else {
- len = 1;
- ret = Find_Block_Simple(ser, index, arg);
- }
-*/
- if (ret >= (REBCNT)tail) goto is_none;
- if (args & AM_FIND_ONLY) len = 1;
- if (action == A_FIND) {
- if (args & (AM_FIND_TAIL | AM_FIND_MATCH)) ret += len;
- VAL_INDEX(value) = ret;
- }
- else {
- ret += len;
- if (ret >= (REBCNT)tail) goto is_none;
- value = BLK_SKIP(ser, ret);
- }
- break;
-
- //-- Modification:
- case A_APPEND:
- case A_INSERT:
- case A_CHANGE:
- // Length of target (may modify index): (arg can be anything)
- len = Partial1((action == A_CHANGE) ? value : arg, DS_ARG(AN_LENGTH));
- index = VAL_INDEX(value);
- args = 0;
- if (DS_REF(AN_ONLY)) SET_FLAG(args, AN_ONLY);
- if (DS_REF(AN_PART)) SET_FLAG(args, AN_PART);
- index = Modify_Block(action, ser, index, arg, args, len, DS_REF(AN_DUP) ? Int32(DS_ARG(AN_COUNT)) : 1);
- VAL_INDEX(value) = index;
- break;
-
- case A_CLEAR:
- if (index < tail) {
- if (index == 0) Reset_Series(ser);
- else {
- SET_END(BLK_SKIP(ser, index));
- VAL_TAIL(value) = (REBCNT)index;
- }
- }
- break;
-
- //-- Creation:
-
- case A_COPY: // /PART len /DEEP /TYPES kinds
-#if 0
- args = D_REF(ARG_COPY_DEEP) ? COPY_ALL : 0;
- len = Partial1(value, D_ARG(ARG_COPY_LENGTH));
- index = (REBINT)VAL_INDEX(value);
-// VAL_SERIES(value) = (len > 0) ? Copy_Block_Deep(ser, index, len, args) : Make_Block(0);
- VAL_INDEX(value) = 0;
-#else
- {
- REBU64 types = 0;
- if (D_REF(ARG_COPY_DEEP)) {
- types |= CP_DEEP | (D_REF(ARG_COPY_TYPES) ? 0 : TS_STD_SERIES);
- }
- if D_REF(ARG_COPY_TYPES) {
- arg = D_ARG(ARG_COPY_KINDS);
- if (IS_DATATYPE(arg)) types |= TYPESET(VAL_DATATYPE(arg));
- else types |= VAL_TYPESET(arg);
- }
- len = Partial1(value, D_ARG(ARG_COPY_LENGTH));
- VAL_SERIES(value) = Copy_Block_Values(ser, VAL_INDEX(value), VAL_INDEX(value)+len, types);
- VAL_INDEX(value) = 0;
- }
-#endif
- break;
-
- //-- Special actions:
-
- case A_TRIM:
- args = Find_Refines(ds, ALL_TRIM_REFS);
- if (args & ~(AM_TRIM_HEAD|AM_TRIM_TAIL)) Trap0(RE_BAD_REFINES);
- Trim_Block(ser, index, args);
- break;
-
- case A_SWAP:
- if (SERIES_WIDE(ser) != SERIES_WIDE(VAL_SERIES(arg)))
- Trap_Arg(arg);
- if (IS_PROTECT_SERIES(VAL_SERIES(arg))) Trap0(RE_PROTECTED);
- if (index < tail && VAL_INDEX(arg) < VAL_TAIL(arg)) {
- val = *VAL_BLK_DATA(value);
- *VAL_BLK_DATA(value) = *VAL_BLK_DATA(arg);
- *VAL_BLK_DATA(arg) = val;
- }
- value = 0;
- break;
-
- case A_REVERSE:
- len = Partial1(value, D_ARG(3));
- if (len == 0) break;
- value = VAL_BLK_DATA(value);
- arg = value + len - 1;
- for (len /= 2; len > 0; len--) {
- val = *value;
- *value++ = *arg;
- *arg-- = val;
- }
- value = 0;
- break;
-
- case A_SORT:
- Sort_Block(
- value,
- D_REF(2), // case sensitive
- D_ARG(4), // skip size
- D_ARG(6), // comparator
- D_ARG(8), // part-length
- D_REF(9), // all fields
- D_REF(10) // reverse
- );
- break;
-
- case A_RANDOM:
- if (!IS_BLOCK(value)) Trap_Action(VAL_TYPE(value), action);
- if (D_REF(2)) Trap0(RE_BAD_REFINES); // seed
- if (D_REF(4)) { // /only
- if (index >= tail) goto is_none;
- len = (REBCNT)Random_Int(D_REF(3)) % (tail - index); // /secure
- arg = D_ARG(2); // pass to pick
- SET_INTEGER(arg, len+1);
- action = A_PICK;
- goto repick;
- }
- Shuffle_Block(value, D_REF(3));
- break;
-
- default:
- Trap_Action(VAL_TYPE(value), action);
- }
-
- if (!value) value = D_ARG(1);
- DS_RET_VALUE(value);
- return R_RET;
-
-is_none:
- return R_NONE;
}
+#endif
diff --git a/src/core/t-char.c b/src/core/t-char.c
index f2f2f34abb..44151278f9 100644
--- a/src/core/t-char.c
+++ b/src/core/t-char.c
@@ -1,180 +1,242 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-char.c
-** Summary: character datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-char.c
+// Summary: "character datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ REBINT CT_Char(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Char: C
+//
+REBINT CT_Char(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBINT num;
-
- if (mode >= 0) {
- if (mode < 2)
- num = LO_CASE(VAL_CHAR(a)) - LO_CASE(VAL_CHAR(b));
- else
- num = VAL_CHAR(a) - VAL_CHAR(b);
- return (num == 0);
- }
-
- num = VAL_CHAR(a) - VAL_CHAR(b);
- if (mode == -1) return (num >= 0);
- return (num > 0);
+ REBINT num;
+
+ if (mode >= 0) {
+ if (mode == 0)
+ num = LO_CASE(VAL_CHAR(a)) - LO_CASE(VAL_CHAR(b));
+ else
+ num = VAL_CHAR(a) - VAL_CHAR(b);
+ return (num == 0);
+ }
+
+ num = VAL_CHAR(a) - VAL_CHAR(b);
+ if (mode == -1) return (num >= 0);
+ return (num > 0);
}
-/***********************************************************************
-**
-*/ REBTYPE(Char)
-/*
-***********************************************************************/
+//
+// MAKE_Char: C
+//
+void MAKE_Char(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBINT chr = VAL_CHAR(D_ARG(1));
- REBINT arg;
- REBVAL *val;
-
- if (IS_BINARY_ACT(action)) {
- val = D_ARG(2);
- if (IS_CHAR(val))
- arg = VAL_CHAR(val);
- else if (IS_INTEGER(val))
- arg = VAL_INT32(val);
- else if (IS_DECIMAL(val))
- arg = (REBINT)VAL_DECIMAL(val);
- else
- Trap_Math_Args(REB_CHAR, action);
- }
-
- switch (action) {
-
- case A_ADD: chr += (REBUNI)arg; break;
- case A_SUBTRACT:
- chr -= (REBUNI)arg;
- if (IS_CHAR(D_ARG(2))) {
- DS_RET_INT(chr);
- return R_RET;
- }
- break;
- case A_MULTIPLY: chr *= arg; break;
- case A_DIVIDE:
- if (arg == 0) Trap0(RE_ZERO_DIVIDE);
- chr /= arg;
- break;
- case A_REMAINDER:
- if (arg == 0) Trap0(RE_ZERO_DIVIDE);
- chr %= arg;
- break;
-
- case A_AND: chr &= (REBUNI)arg; break;
- case A_OR: chr |= (REBUNI)arg; break;
- case A_XOR: chr ^= (REBUNI)arg; break;
-
- case A_NEGATE: chr = (REBUNI)-chr; break;
- case A_COMPLEMENT: chr = (REBUNI)~chr; break;
- case A_EVENQ: chr = (REBUNI)~chr;
- case A_ODDQ: DECIDE(chr & 1);
-
- case A_RANDOM: //!!! needs further definition ? random/zero
- if (D_REF(2)) { // /seed
- Set_Random(chr);
- return R_UNSET;
- }
- if (chr == 0) break;
- chr = (REBUNI)(1 + ((REBCNT)Random_Int(D_REF(3)) % chr)); // /secure
- break;
-
- case A_MAKE:
- case A_TO:
- val = D_ARG(2);
-
- switch(VAL_TYPE(val)) {
- case REB_CHAR:
- chr = VAL_CHAR(val);
- break;
-
- case REB_INTEGER:
- case REB_DECIMAL:
- arg = Int32(val);
- if (arg > MAX_UNI || arg < 0) goto bad_make;
- chr = arg;
- break;
-
- case REB_BINARY:
- {
- REBYTE *bp = VAL_BIN(val);
- arg = VAL_LEN(val);
- if (arg == 0) goto bad_make;
- if (*bp > 0x80) {
- if (!Legal_UTF8_Char(bp, arg)) goto bad_make;
- chr = Decode_UTF8_Char(&bp, 0); // zero on error
- if (!chr) goto bad_make;
- }
- else
- chr = *bp;
- }
- break;
+ assert(kind == REB_CHAR);
+ UNUSED(kind);
+
+ REBUNI uni;
+
+ switch(VAL_TYPE(arg)) {
+ case REB_CHAR:
+ uni = VAL_CHAR(arg);
+ break;
+
+ case REB_INTEGER:
+ case REB_DECIMAL:
+ {
+ REBINT n = Int32(arg);
+ if (n > MAX_UNI || n < 0) goto bad_make;
+ uni = n;
+ }
+ break;
+
+ case REB_BINARY:
+ {
+ const REBYTE *bp = VAL_BIN(arg);
+ REBCNT len = VAL_LEN_AT(arg);
+ if (len == 0) goto bad_make;
+ if (*bp <= 0x80) {
+ if (len != 1)
+ goto bad_make;
+
+ uni = *bp;
+ }
+ else {
+ --len;
+ bp = Back_Scan_UTF8_Char(&uni, bp, &len);
+ if (!bp || len != 0) // must be valid UTF8 and consume all data
+ goto bad_make;
+ }
+ } // case REB_BINARY
+ break;
#ifdef removed
-// case REB_ISSUE:
- // Scan 8 or 16 bit hex str, will throw on error...
- arg = Scan_Hex_Value(VAL_DATA(val), VAL_LEN(val), (REBOOL)!VAL_BYTE_SIZE(val));
- if (arg > MAX_UNI || arg < 0) goto bad_make;
- chr = arg;
- break;
+// case REB_ISSUE:
+ // Scan 8 or 16 bit hex str, will throw on error...
+ REBINT n = Scan_Hex_Value(
+ VAL_RAW_DATA_AT(arg), VAL_LEN_AT(arg), !VAL_BYTE_SIZE(arg)
+ );
+ if (n > MAX_UNI || n < 0) goto bad_make;
+ chr = n;
+ break;
#endif
- case REB_STRING:
- if (VAL_INDEX(val) >= VAL_TAIL(val)) Trap_Make(REB_CHAR, val);
- chr = GET_ANY_CHAR(VAL_SERIES(val), VAL_INDEX(val));
- break;
-
- default:
-bad_make:
- Trap_Make(REB_CHAR, val);
- }
- break;
-
- default:
- Trap_Action(REB_CHAR, action);
- }
-
- if ((chr >> 16) != 0 && (chr >> 16) != 0xffff) Trap1(RE_TYPE_LIMIT, Get_Type(REB_CHAR));
- SET_CHAR(DS_RETURN, chr);
- return R_RET;
-
-is_false:
- return R_FALSE;
-
-is_true:
- return R_TRUE;
+ case REB_STRING:
+ if (VAL_INDEX(arg) >= VAL_LEN_HEAD(arg))
+ goto bad_make;
+ uni = GET_ANY_CHAR(VAL_SERIES(arg), VAL_INDEX(arg));
+ break;
+
+ default:
+ bad_make:
+ fail (Error_Bad_Make(REB_CHAR, arg));
+ }
+
+ Init_Char(out, uni);
+}
+
+
+//
+// TO_Char: C
+//
+void TO_Char(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ MAKE_Char(out, kind, arg);
+}
+
+
+static REBINT Math_Arg_For_Char(REBVAL *arg, REBSYM action)
+{
+ switch (VAL_TYPE(arg)) {
+ case REB_CHAR:
+ return VAL_CHAR(arg);
+
+ case REB_INTEGER:
+ return VAL_INT32(arg);
+
+ case REB_DECIMAL:
+ return cast(REBINT, VAL_DECIMAL(arg));
+
+ default:
+ fail (Error_Math_Args(REB_CHAR, action));
+ }
+}
+
+
+//
+// REBTYPE: C
+//
+REBTYPE(Char)
+{
+ REBCNT chr = VAL_CHAR(D_ARG(1)); // !!! Larger than REBCHR for math ops?
+ REBINT arg;
+
+ switch (action) {
+
+ case SYM_ADD:
+ arg = Math_Arg_For_Char(D_ARG(2), action);
+ chr += cast(REBUNI, arg);
+ break;
+
+ case SYM_SUBTRACT:
+ arg = Math_Arg_For_Char(D_ARG(2), action);
+ chr -= cast(REBUNI, arg);
+ if (IS_CHAR(D_ARG(2))) {
+ Init_Integer(D_OUT, chr);
+ return R_OUT;
+ }
+ break;
+
+ case SYM_MULTIPLY:
+ arg = Math_Arg_For_Char(D_ARG(2), action);
+ chr *= arg;
+ break;
+
+ case SYM_DIVIDE:
+ arg = Math_Arg_For_Char(D_ARG(2), action);
+ if (arg == 0) fail (Error_Zero_Divide_Raw());
+ chr /= arg;
+ break;
+
+ case SYM_REMAINDER:
+ arg = Math_Arg_For_Char(D_ARG(2), action);
+ if (arg == 0) fail (Error_Zero_Divide_Raw());
+ chr %= arg;
+ break;
+
+ case SYM_AND_T:
+ arg = Math_Arg_For_Char(D_ARG(2), action);
+ chr &= cast(REBUNI, arg);
+ break;
+
+ case SYM_OR_T:
+ arg = Math_Arg_For_Char(D_ARG(2), action);
+ chr |= cast(REBUNI, arg);
+ break;
+
+ case SYM_XOR_T:
+ arg = Math_Arg_For_Char(D_ARG(2), action);
+ chr ^= cast(REBUNI, arg);
+ break;
+
+ case SYM_COMPLEMENT:
+ chr = cast(REBUNI, ~chr);
+ break;
+
+ case SYM_EVEN_Q:
+ return (cast(REBUNI, ~chr) & 1) ? R_TRUE : R_FALSE;
+
+ case SYM_ODD_Q:
+ return (chr & 1) ? R_TRUE : R_FALSE;
+
+ case SYM_RANDOM: {
+ INCLUDE_PARAMS_OF_RANDOM;
+
+ UNUSED(PAR(value));
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+
+ if (REF(seed)) {
+ Set_Random(chr);
+ return R_VOID;
+ }
+ if (chr == 0) break;
+ chr = cast(REBUNI, 1 + cast(REBCNT, Random_Int(REF(secure)) % chr));
+ break; }
+
+ default:
+ fail (Error_Illegal_Action(REB_CHAR, action));
+ }
+
+ if ((chr >> 16) != 0 && (chr >> 16) != 0xffff)
+ fail (Error_Type_Limit_Raw(Get_Type(REB_CHAR)));
+ Init_Char(D_OUT, chr);
+ return R_OUT;
}
diff --git a/src/core/t-datatype.c b/src/core/t-datatype.c
index b0d7457361..8b4403c953 100644
--- a/src/core/t-datatype.c
+++ b/src/core/t-datatype.c
@@ -1,107 +1,130 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-datatype.c
-** Summary: datatype datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-datatype.c
+// Summary: "datatype datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ REBINT CT_Datatype(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Datatype: C
+//
+REBINT CT_Datatype(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- if (mode >= 0) return (VAL_DATATYPE(a) == VAL_DATATYPE(b));
- return -1;
+ if (mode >= 0) return (VAL_TYPE_KIND(a) == VAL_TYPE_KIND(b));
+ return -1;
}
-/***********************************************************************
-**
-*/ REBFLG MT_Datatype(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
-{
- if (!IS_WORD(data)) return FALSE;
- type = VAL_WORD_CANON(data);
- if (type > REB_MAX) return FALSE;
- VAL_SET(out, REB_DATATYPE);
- VAL_DATATYPE(out) = type-1;
- VAL_TYPE_SPEC(out) = 0;
- return TRUE;
+//
+// MAKE_Datatype: C
+//
+void MAKE_Datatype(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+ if (!IS_WORD(arg))
+ fail (Error_Bad_Make(kind, arg));
+
+ REBSYM sym = VAL_WORD_SYM(arg);
+ if (sym == SYM_0 || sym > SYM_FROM_KIND(REB_MAX))
+ fail (Error_Bad_Make(kind, arg));
+
+ VAL_RESET_HEADER(out, REB_DATATYPE);
+ VAL_TYPE_KIND(out) = KIND_FROM_SYM(sym);
+ VAL_TYPE_SPEC(out) = 0;
+}
+
+
+//
+// TO_Datatype: C
+//
+void TO_Datatype(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+ MAKE_Datatype(out, kind, arg);
}
-/***********************************************************************
-**
-*/ REBTYPE(Datatype)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+REBTYPE(Datatype)
{
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBACT act;
- REBINT type = VAL_DATATYPE(value);
- REBSER *obj;
- REBINT n;
-
- switch (action) {
-
- case A_REFLECT:
- n = What_Reflector(arg); // zero on error
- if (n == OF_SPEC) {
- obj = Make_Std_Object(STD_TYPE_SPEC);
- Set_Object_Values(obj, BLK_HEAD(VAL_TYPE_SPEC(BLK_SKIP(Lib_Context, type+1))));
- SET_OBJECT(D_RET, obj);
- }
- else if (n == OF_TITLE) {
- Set_String(D_RET, Copy_Series(VAL_SERIES(BLK_HEAD(VAL_TYPE_SPEC(BLK_SKIP(Lib_Context, type+1))))));
- }
- else Trap_Reflect(VAL_TYPE(value), arg);
- break;
-
- case A_MAKE:
- case A_TO:
- if (type != REB_DATATYPE) {
- act = Value_Dispatch[type];
- if (act) return act(ds, action);
- //return R_NONE;
- Trap_Make(type, arg);
- }
- // if (IS_NONE(arg)) return R_NONE;
- if (MT_Datatype(D_RET, arg, REB_DATATYPE))
- break;
-
- Trap_Make(REB_DATATYPE, arg);
-
- default:
- Trap_Action(REB_DATATYPE, action);
- }
-
- return R_RET;
+ REBVAL *value = D_ARG(1);
+ REBVAL *arg = D_ARG(2);
+ enum Reb_Kind kind = VAL_TYPE_KIND(value);
+
+ switch (action) {
+
+ case SYM_REFLECT: {
+ REBSYM sym = VAL_WORD_SYM(arg);
+ if (sym == SYM_SPEC) {
+ //
+ // The "type specs" were loaded as an array, but this reflector
+ // wants to give back an object. Combine the array with the
+ // standard object that mirrors its field order.
+ //
+ REBCTX *context = Copy_Context_Shallow(
+ VAL_CONTEXT(Get_System(SYS_STANDARD, STD_TYPE_SPEC))
+ );
+ MANAGE_ARRAY(CTX_VARLIST(context));
+
+ assert(CTX_TYPE(context) == REB_OBJECT);
+
+ REBVAL *var = CTX_VARS_HEAD(context);
+ REBVAL *key = CTX_KEYS_HEAD(context);
+
+ // !!! Account for the "invisible" self key in the current
+ // stop-gap implementation of self, still default on MAKE OBJECT!s
+ //
+ assert(VAL_KEY_SYM(key) == SYM_SELF);
+ ++key; ++var;
+
+ RELVAL *value = ARR_HEAD(
+ VAL_TYPE_SPEC(CTX_VAR(Lib_Context, SYM_FROM_KIND(kind)))
+ );
+
+ for (; NOT_END(var); ++var, ++key) {
+ if (IS_END(value))
+ Init_Blank(var);
+ else {
+ // typespec array does not contain relative values
+ //
+ Derelativize(var, value, SPECIFIED);
+ ++value;
+ }
+ }
+
+ Init_Object(D_OUT, context);
+ }
+ else
+ fail (Error_Cannot_Reflect(VAL_TYPE(value), arg));
+ break;}
+
+ default:
+ fail (Error_Illegal_Action(REB_DATATYPE, action));
+ }
+
+ return R_OUT;
}
diff --git a/src/core/t-date.c b/src/core/t-date.c
index a514609e3b..1183a69722 100644
--- a/src/core/t-date.c
+++ b/src/core/t-date.c
@@ -1,837 +1,883 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-date.c
-** Summary: date datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-** Date and time are stored in UTC format with an optional timezone.
-** The zone must be added when a date is exported or imported, but not
-** when date computations are performed.
-**
-***********************************************************************/
-
+//
+// File: %t-date.c
+// Summary: "date datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Date and time are stored in UTC format with an optional timezone.
+// The zone must be added when a date is exported or imported, but not
+// when date computations are performed.
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ void Set_Date_UTC(REBVAL *val, REBINT y, REBINT m, REBINT d, REBI64 t, REBINT z)
-/*
-** Convert date/time/zone to UTC with zone.
-**
-***********************************************************************/
-{
- // Adjust for zone....
- VAL_YEAR(val) = y;
- VAL_MONTH(val) = m;
- VAL_DAY(val) = d;
- VAL_TIME(val) = t;
- VAL_ZONE(val) = z;
- VAL_SET(val, REB_DATE);
- if (z) Adjust_Date_Zone(val, TRUE);
-}
-
-
-/***********************************************************************
-**
-*/ void Set_Date(REBVAL *val, REBOL_DAT *dat)
-/*
-** Convert OS date struct to REBOL value struct.
-** NOTE: Input zone is in minutes.
-**
-***********************************************************************/
+//
+// Set_Date_UTC: C
+//
+// Convert date/time/zone to UTC with zone.
+//
+void Set_Date_UTC(REBVAL *val, REBINT y, REBINT m, REBINT d, REBI64 t, REBINT z)
{
- VAL_YEAR(val) = dat->year;
- VAL_MONTH(val) = dat->month;
- VAL_DAY(val) = dat->day;
- VAL_ZONE(val) = dat->zone / ZONE_MINS;
- VAL_TIME(val) = TIME_SEC(dat->time) + dat->nano;
- VAL_SET(val, REB_DATE);
+ // Adjust for zone....
+ VAL_YEAR(val) = y;
+ VAL_MONTH(val) = m;
+ VAL_DAY(val) = d;
+ VAL_NANO(val) = t;
+ VAL_ZONE(val) = z;
+ VAL_RESET_HEADER(val, REB_DATE);
+ if (z) Adjust_Date_Zone(val, TRUE);
}
-/***********************************************************************
-**
-*/ REBINT CT_Date(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Date: C
+//
+REBINT CT_Date(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBINT num = Cmp_Date(a, b);
- if (mode >= 2)
- return VAL_DATE(a).bits == VAL_DATE(b).bits && VAL_TIME(a) == VAL_TIME(b);
- if (mode >= 0) return (num == 0);
- if (mode == -1) return (num >= 0);
- return (num > 0);
+ REBINT num = Cmp_Date(a, b);
+ if (mode == 1)
+ return (
+ VAL_DATE(a).bits == VAL_DATE(b).bits
+ && VAL_NANO(a) == VAL_NANO(b)
+ );
+ if (mode >= 0) return (num == 0);
+ if (mode == -1) return (num >= 0);
+ return (num > 0);
}
-/***********************************************************************
-**
-*/ void Emit_Date(REB_MOLD *mold, REBVAL *value)
-/*
-***********************************************************************/
+//
+// Emit_Date: C
+//
+void Emit_Date(REB_MOLD *mold, const REBVAL *value_orig)
{
- REBYTE buf[64];
- REBYTE *bp = &buf[0];
- REBINT tz;
- REBYTE dash = GET_MOPT(mold, MOPT_SLASH_DATE) ? '/' : '-';
- REBVAL val = *value;
- value = &val;
-
- if (
- VAL_MONTH(value) == 0
- || VAL_MONTH(value) > 12
- || VAL_DAY(value) == 0
- || VAL_DAY(value) > 31
- ) {
- Append_Bytes(mold->series, "?date?");
- return;
- }
-
- if (VAL_TIME(value) != NO_TIME) Adjust_Date_Zone(value, FALSE);
-
-// Punctuation[GET_MOPT(mold, MOPT_COMMA_PT) ? PUNCT_COMMA : PUNCT_DOT]
-
- bp = Form_Int(bp, (REBINT)VAL_DAY(value));
- *bp++ = dash;
- memcpy(bp, Month_Names[VAL_MONTH(value)-1], 3);
- bp += 3;
- *bp++ = dash;
- bp = Form_Int_Pad(bp, (REBINT)VAL_YEAR(value), 6, -4, '0');
- *bp = 0;
-
- Append_Bytes(mold->series, buf);
-
- if (VAL_TIME(value) != NO_TIME) {
-
- Append_Byte(mold->series, '/');
- Emit_Time(mold, value);
-
- if (VAL_ZONE(value) != 0) {
-
- bp = &buf[0];
- tz = VAL_ZONE(value);
- if (tz < 0) {
- *bp++ = '-';
- tz = -tz;
- }
- else
- *bp++ = '+';
-
- bp = Form_Int(bp, tz/4);
- *bp++ = ':';
- bp = Form_Int_Pad(bp, (tz&3) * 15, 2, 2, '0');
- *bp = 0;
-
- Append_Bytes(mold->series, buf);
- }
- }
+ REBYTE buf[64];
+ REBYTE *bp = &buf[0];
+ REBINT tz;
+ REBYTE dash = GET_MOPT(mold, MOPT_SLASH_DATE) ? '/' : '-';
+
+ // We don't want to modify the incoming date value we are molding,
+ // so we make a copy that we can tweak during the emit process
+
+ DECLARE_LOCAL (value);
+ Move_Value(value, value_orig);
+
+ if (
+ VAL_MONTH(value) == 0
+ || VAL_MONTH(value) > 12
+ || VAL_DAY(value) == 0
+ || VAL_DAY(value) > 31
+ ) {
+ Append_Unencoded(mold->series, "?date?");
+ return;
+ }
+
+ if (VAL_NANO(value) != NO_TIME)
+ Adjust_Date_Zone(value, FALSE);
+
+// Punctuation[GET_MOPT(mold, MOPT_COMMA_PT) ? PUNCT_COMMA : PUNCT_DOT]
+
+ bp = Form_Int(bp, (REBINT)VAL_DAY(value));
+ *bp++ = dash;
+ memcpy(bp, Month_Names[VAL_MONTH(value)-1], 3);
+ bp += 3;
+ *bp++ = dash;
+ bp = Form_Int_Pad(bp, (REBINT)VAL_YEAR(value), 6, -4, '0');
+ *bp = 0;
+
+ Append_Unencoded(mold->series, s_cast(buf));
+
+ if (VAL_NANO(value) != NO_TIME) {
+
+ Append_Codepoint_Raw(mold->series, '/');
+ Emit_Time(mold, value);
+
+ if (VAL_ZONE(value) != 0) {
+
+ bp = &buf[0];
+ tz = VAL_ZONE(value);
+ if (tz < 0) {
+ *bp++ = '-';
+ tz = -tz;
+ }
+ else
+ *bp++ = '+';
+
+ bp = Form_Int(bp, tz/4);
+ *bp++ = ':';
+ bp = Form_Int_Pad(bp, (tz&3) * 15, 2, 2, '0');
+ *bp = 0;
+
+ Append_Unencoded(mold->series, s_cast(buf));
+ }
+ }
}
-/***********************************************************************
-**
-*/ static REBCNT Month_Length(REBCNT month, REBCNT year)
-/*
-** Given a year, determine the number of days in the month.
-** Handles all leap year calculations.
-**
-***********************************************************************/
+//
+// Month_Length: C
+//
+// Given a year, determine the number of days in the month.
+// Handles all leap year calculations.
+//
+static REBCNT Month_Length(REBCNT month, REBCNT year)
{
- if (month != 1)
- return (REBCNT)Month_Lengths[month];
-
- return (
- ((year % 4) == 0) && // divisible by four is a leap year
- (
- ((year % 100) != 0) || // except when divisible by 100
- ((year % 400) == 0) // but not when divisible by 400
- )
- ) ? 29 : 28;
+ if (month != 1)
+ return Month_Max_Days[month];
+
+ return (
+ ((year % 4) == 0) && // divisible by four is a leap year
+ (
+ ((year % 100) != 0) || // except when divisible by 100
+ ((year % 400) == 0) // but not when divisible by 400
+ )
+ ) ? 29 : 28;
}
-/***********************************************************************
-**
-*/ REBCNT Julian_Date(REBDAT date)
-/*
-** Given a year, month and day, return the number of days since the
-** beginning of that year.
-**
-***********************************************************************/
+//
+// Julian_Date: C
+//
+// Given a year, month and day, return the number of days since the
+// beginning of that year.
+//
+REBCNT Julian_Date(REBDAT date)
{
- REBCNT days;
- REBCNT i;
+ REBCNT days;
+ REBCNT i;
- days = 0;
+ days = 0;
- for (i = 0; i < (date.date.month-1); i++)
- days += Month_Length(i, date.date.year);
+ for (i = 0; i < cast(REBCNT, date.date.month - 1); i++)
+ days += Month_Length(i, date.date.year);
- return date.date.day + days;
+ return date.date.day + days;
}
-/***********************************************************************
-**
-*/ REBINT Diff_Date(REBDAT d1, REBDAT d2)
-/*
-** Calculate the difference in days between two dates.
-**
-***********************************************************************/
+//
+// Diff_Date: C
+//
+// Calculate the difference in days between two dates.
+//
+REBINT Diff_Date(REBDAT d1, REBDAT d2)
{
- REBCNT days;
- REBINT sign;
- REBCNT m, y;
- REBDAT tmp;
-
- if (d1.bits == d2.bits) return 0;
-
- if (d1.bits < d2.bits) {
- sign = -1;
- tmp = d1;
- d1 = d2;
- d2 = tmp;
- }
- else
- sign = 1;
-
- // if not same year, calculate days to end of month, year and
- // days in between years plus days in end year
- if (d1.date.year > d2.date.year) {
- days = Month_Length(d2.date.month-1, d2.date.year) - d2.date.day;
-
- for (m = d2.date.month; m < 12; m++)
- days += Month_Length(m, d2.date.year);
-
- for (y = d2.date.year + 1; y < d1.date.year; y++) {
- days += (((y % 4) == 0) && // divisible by four is a leap year
- (((y % 100) != 0) || // except when divisible by 100
- ((y % 400) == 0))) // but not when divisible by 400
- ? 366u : 365u;
- }
- return sign * (REBINT)(days + Julian_Date(d1));
- }
- return sign * (REBINT)(Julian_Date(d1) - Julian_Date(d2));
+ REBCNT days;
+ REBINT sign;
+ REBCNT m, y;
+ REBDAT tmp;
+
+ if (d1.bits == d2.bits) return 0;
+
+ if (d1.bits < d2.bits) {
+ sign = -1;
+ tmp = d1;
+ d1 = d2;
+ d2 = tmp;
+ }
+ else
+ sign = 1;
+
+ // if not same year, calculate days to end of month, year and
+ // days in between years plus days in end year
+ if (d1.date.year > d2.date.year) {
+ days = Month_Length(d2.date.month-1, d2.date.year) - d2.date.day;
+
+ for (m = d2.date.month; m < 12; m++)
+ days += Month_Length(m, d2.date.year);
+
+ for (y = d2.date.year + 1; y < d1.date.year; y++) {
+ days += (((y % 4) == 0) && // divisible by four is a leap year
+ (((y % 100) != 0) || // except when divisible by 100
+ ((y % 400) == 0))) // but not when divisible by 400
+ ? 366u : 365u;
+ }
+ return sign * (REBINT)(days + Julian_Date(d1));
+ }
+ return sign * (REBINT)(Julian_Date(d1) - Julian_Date(d2));
}
-/***********************************************************************
-**
-*/ REBCNT Week_Day(REBDAT date)
-/*
-** Return the day of the week for a specific date.
-**
-***********************************************************************/
+//
+// Week_Day: C
+//
+// Return the day of the week for a specific date.
+//
+REBCNT Week_Day(REBDAT date)
{
- REBDAT year1 = {0};
- year1.date.day = 1;
- year1.date.month = 1;
+ REBDAT year1;
+ CLEARS(&year1);
+ year1.date.day = 1;
+ year1.date.month = 1;
- return ((Diff_Date(date, year1) + 5) % 7) + 1;
+ return ((Diff_Date(date, year1) + 5) % 7) + 1;
}
-/***********************************************************************
-**
-*/ void Normalize_Time(REBI64 *sp, REBINT *dp)
-/*
-** Adjust *dp by number of days and set secs to less than a day.
-**
-***********************************************************************/
+//
+// Normalize_Time: C
+//
+// Adjust *dp by number of days and set secs to less than a day.
+//
+void Normalize_Time(REBI64 *sp, REBCNT *dp)
{
- REBI64 secs = *sp;
- REBINT day;
+ REBI64 secs = *sp;
+ REBINT day;
- if (secs == NO_TIME) return;
+ if (secs == NO_TIME) return;
- // how many days worth of seconds do we have
- day = (REBINT)(secs / TIME_IN_DAY);
- secs %= TIME_IN_DAY;
+ // how many days worth of seconds do we have
+ day = (REBINT)(secs / TIME_IN_DAY);
+ secs %= TIME_IN_DAY;
- if (secs < 0L) {
- day--;
- secs += TIME_IN_DAY;
- }
+ if (secs < 0L) {
+ day--;
+ secs += TIME_IN_DAY;
+ }
- *dp += day;
- *sp = secs;
+ *dp += day;
+ *sp = secs;
}
-/***********************************************************************
-**
-*/ static REBDAT Normalize_Date(REBINT day, REBINT month, REBINT year, REBINT tz)
-/*
-** Given a year, month and day, normalize and combine to give a new
-** date value.
-**
-***********************************************************************/
+//
+// Normalize_Date: C
+//
+// Given a year, month and day, normalize and combine to give a new
+// date value.
+//
+static REBDAT Normalize_Date(REBINT day, REBINT month, REBINT year, REBINT tz)
{
- REBINT d;
- REBDAT dr;
-
- // First we normalize the month to get the right year
- if (month<0) {
- year-=(-month+11)/12;
- month=11-((-month+11)%12);
- }
- if (month >= 12) {
- year += month / 12;
- month %= 12;
- }
-
- // Now adjust the days by stepping through each month
- while (day >= (d = (REBINT)Month_Length(month, year))) {
- day -= d;
- if (++month >= 12) {
- month = 0;
- year++;
- }
- }
- while (day < 0) {
- if (month == 0) {
- month = 11;
- year--;
- }
- else
- month--;
- day += (REBINT)Month_Length(month, year);
- }
-
- if (year < 0 || year > MAX_YEAR) Trap1(RE_TYPE_LIMIT, Get_Type(REB_DATE));
-
- dr.date.year = year;
- dr.date.month = month+1;
- dr.date.day = day+1;
- dr.date.zone = tz;
-
- return dr;
+ REBINT d;
+ REBDAT dr;
+
+ // First we normalize the month to get the right year
+ if (month<0) {
+ year-=(-month+11)/12;
+ month=11-((-month+11)%12);
+ }
+ if (month >= 12) {
+ year += month / 12;
+ month %= 12;
+ }
+
+ // Now adjust the days by stepping through each month
+ while (day >= (d = (REBINT)Month_Length(month, year))) {
+ day -= d;
+ if (++month >= 12) {
+ month = 0;
+ year++;
+ }
+ }
+ while (day < 0) {
+ if (month == 0) {
+ month = 11;
+ year--;
+ }
+ else
+ month--;
+ day += (REBINT)Month_Length(month, year);
+ }
+
+ if (year < 0 || year > MAX_YEAR)
+ fail (Error_Type_Limit_Raw(Get_Type(REB_DATE)));
+
+ dr.date.year = year;
+ dr.date.month = month+1;
+ dr.date.day = day+1;
+ dr.date.zone = tz;
+
+ return dr;
}
-/***********************************************************************
-**
-*/ void Adjust_Date_Zone(REBVAL *d, REBFLG to_utc)
-/*
-** Adjust date and time for the timezone.
-** The result should be used for output, not stored.
-**
-***********************************************************************/
+//
+// Adjust_Date_Zone: C
+//
+// Adjust date and time for the timezone.
+// The result should be used for output, not stored.
+//
+void Adjust_Date_Zone(REBVAL *d, REBOOL to_utc)
{
- REBI64 secs;
- REBCNT n;
+ REBI64 secs;
+ REBCNT n;
- if (VAL_ZONE(d) == 0) return;
+ if (VAL_ZONE(d) == 0) return;
- if (VAL_TIME(d) == NO_TIME) {
- VAL_TIME(d) = VAL_ZONE(d) = 0;
- return;
- }
+ if (VAL_NANO(d) == NO_TIME) {
+ VAL_NANO(d) = 0;
+ VAL_ZONE(d) = 0;
+ return;
+ }
- // (compiler should fold the constant)
- secs = ((i64)VAL_ZONE(d) * ((i64)ZONE_SECS * SEC_SEC));
- if (to_utc) secs = -secs;
- secs += VAL_TIME(d);
+ // (compiler should fold the constant)
+ secs = cast(i64, VAL_ZONE(d)) * (cast(i64, ZONE_SECS) * SEC_SEC);
+ if (to_utc) secs = -secs;
+ secs += VAL_NANO(d);
- VAL_TIME(d) = (secs + TIME_IN_DAY) % TIME_IN_DAY;
+ VAL_NANO(d) = (secs + TIME_IN_DAY) % TIME_IN_DAY;
- n = VAL_DAY(d) - 1;
+ n = VAL_DAY(d) - 1;
- if (secs < 0) n--;
- else if (secs >= TIME_IN_DAY) n++;
- else return;
+ if (secs < 0) n--;
+ else if (secs >= TIME_IN_DAY) n++;
+ else return;
- VAL_DATE(d) = Normalize_Date(n, VAL_MONTH(d)-1, VAL_YEAR(d), VAL_ZONE(d));
+ VAL_DATE(d) = Normalize_Date(n, VAL_MONTH(d)-1, VAL_YEAR(d), VAL_ZONE(d));
}
-/***********************************************************************
-**
-*/ void Subtract_Date(REBVAL *d1, REBVAL *d2, REBVAL *result)
-/*
-** Called by DIFFERENCE function.
-**
-***********************************************************************/
+//
+// Subtract_Date: C
+//
+// Called by DIFFERENCE function.
+//
+void Subtract_Date(REBVAL *d1, REBVAL *d2, REBVAL *result)
{
- REBINT diff;
- REBI64 t1;
- REBI64 t2;
+ REBINT diff;
+ REBI64 t1;
+ REBI64 t2;
- diff = Diff_Date(VAL_DATE(d1), VAL_DATE(d2));
- if (abs(diff) > (((1U << 31) - 1) / SECS_IN_DAY)) Trap0(RE_OVERFLOW);
+ diff = Diff_Date(VAL_DATE(d1), VAL_DATE(d2));
+ if (cast(REBCNT, abs(diff)) > (((1U << 31) - 1) / SECS_IN_DAY))
+ fail (Error_Overflow_Raw());
- t1 = VAL_TIME(d1);
- if (t1 == NO_TIME) t1 = 0L;
- t2 = VAL_TIME(d2);
- if (t2 == NO_TIME) t2 = 0L;
+ t1 = VAL_NANO(d1);
+ if (t1 == NO_TIME) t1 = 0L;
+ t2 = VAL_NANO(d2);
+ if (t2 == NO_TIME) t2 = 0L;
- VAL_SET(result, REB_TIME);
- VAL_TIME(result) = (t1 - t2) + ((REBI64)diff * TIME_IN_DAY);
+ VAL_RESET_HEADER(result, REB_TIME);
+ VAL_NANO(result) = (t1 - t2) + (cast(REBI64, diff) * TIME_IN_DAY);
}
-/***********************************************************************
-**
-*/ REBINT Cmp_Date(REBVAL *d1, REBVAL *d2)
-/*
-***********************************************************************/
+//
+// Cmp_Date: C
+//
+REBINT Cmp_Date(const RELVAL *d1, const RELVAL *d2)
{
- REBINT diff;
+ REBINT diff;
- diff = Diff_Date(VAL_DATE(d1), VAL_DATE(d2));
- if (diff == 0) diff = Cmp_Time(d1, d2);
+ diff = Diff_Date(VAL_DATE(d1), VAL_DATE(d2));
+ if (diff == 0) diff = Cmp_Time(d1, d2);
- return diff;
+ return diff;
}
-/***********************************************************************
-**
-*/ REBFLG MT_Date(REBVAL *val, REBVAL *arg, REBCNT type)
-/*
-** Given a block of values, construct a date datatype.
-**
-***********************************************************************/
-{
- REBI64 secs = NO_TIME;
- REBINT tz = 0;
- REBDAT date;
- REBCNT year, month, day;
-
- if (IS_DATE(arg)) {
- *val = *arg;
- return TRUE;
- }
-
- if (!IS_INTEGER(arg)) return FALSE;
- day = Int32s(arg++, 1);
- if (!IS_INTEGER(arg)) return FALSE;
- month = Int32s(arg++, 1);
- if (!IS_INTEGER(arg)) return FALSE;
- if (day > 99) {
- year = day;
- day = Int32s(arg++, 1);
- } else
- year = Int32s(arg++, 0);
-
- if (month < 1 || month > 12) return FALSE;
-
- if (year > MAX_YEAR || day < 1 || day > (REBINT)(Month_Lengths[month-1])) return FALSE;
-
- // Check February for leap year or century:
- if (month == 2 && day == 29) {
- if (((year % 4) != 0) || // not leap year
- ((year % 100) == 0 && // century?
- (year % 400) != 0)) return FALSE; // not leap century
- }
-
- day--;
- month--;
-
- if (IS_TIME(arg)) {
- secs = VAL_TIME(arg);
- arg++;
- }
-
- if (IS_TIME(arg)) {
- tz = (REBINT)(VAL_TIME(arg) / (ZONE_MINS * MIN_SEC));
- if (tz < -MAX_ZONE || tz > MAX_ZONE) Trap_Range(arg);
- arg++;
- }
-
- if (!IS_END(arg)) return FALSE;
-
- Normalize_Time(&secs, &day);
- date = Normalize_Date(day, month, year, tz);
-
- VAL_SET(val, REB_DATE);
- VAL_DATE(val) = date;
- VAL_TIME(val) = secs;
- Adjust_Date_Zone(val, TRUE);
-
- return TRUE;
+//
+// MAKE_Date: C
+//
+void MAKE_Date(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+ assert(kind == REB_DATE);
+ UNUSED(kind);
+
+ if (IS_DATE(arg)) {
+ Move_Value(out, arg);
+ return;
+ }
+
+ if (IS_STRING(arg)) {
+ REBCNT len;
+ REBYTE *bp = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_DATE, &len, FALSE);
+ if (NULL == Scan_Date(out, bp, len))
+ goto bad_make;
+ return;
+ }
+
+ if (ANY_ARRAY(arg) && VAL_ARRAY_LEN_AT(arg) >= 3) {
+ const RELVAL *item = VAL_ARRAY_AT(arg);
+ if (NOT(IS_INTEGER(item)))
+ goto bad_make;
+
+ REBCNT day = Int32s(item, 1);
+
+ ++item;
+ if (NOT(IS_INTEGER(item)))
+ goto bad_make;
+
+ REBCNT month = Int32s(item, 1);
+
+ ++item;
+ if (NOT(IS_INTEGER(item)))
+ goto bad_make;
+
+ REBCNT year;
+ if (day > 99) {
+ year = day;
+ day = Int32s(item, 1);
+ ++item;
+ }
+ else {
+ year = Int32s(item, 0);
+ ++item;
+ }
+
+ if (month < 1 || month > 12)
+ goto bad_make;
+
+ if (year > MAX_YEAR || day < 1 || day > Month_Max_Days[month-1])
+ goto bad_make;
+
+ // Check February for leap year or century:
+ if (month == 2 && day == 29) {
+ if (((year % 4) != 0) || // not leap year
+ ((year % 100) == 0 && // century?
+ (year % 400) != 0)) goto bad_make; // not leap century
+ }
+
+ day--;
+ month--;
+
+ REBI64 secs;
+ REBINT tz;
+ if (IS_END(item)) {
+ secs = 0;
+ tz = 0;
+ }
+ else {
+ if (NOT(IS_TIME(item)))
+ goto bad_make;
+
+ secs = VAL_NANO(item);
+ ++item;
+
+ if (IS_END(item))
+ tz = 0;
+ else {
+ if (NOT(IS_TIME(item)))
+ goto bad_make;
+
+ tz = cast(REBINT, VAL_NANO(item) / (ZONE_MINS * MIN_SEC));
+ if (tz < -MAX_ZONE || tz > MAX_ZONE)
+ fail (Error_Out_Of_Range(const_KNOWN(item)));
+ ++item;
+ }
+ }
+
+ if (NOT_END(item))
+ goto bad_make;
+
+ Normalize_Time(&secs, &day);
+
+ VAL_RESET_HEADER(out, REB_DATE);
+ VAL_DATE(out) = Normalize_Date(day, month, year, tz);
+ VAL_NANO(out) = secs;
+ Adjust_Date_Zone(out, TRUE);
+ return;
+ }
+
+bad_make:
+ fail (Error_Bad_Make(REB_DATE, arg));
}
-/***********************************************************************
-**
-*/ REBINT PD_Date(REBPVS *pvs)
-/*
-***********************************************************************/
-{
- REBVAL *data = pvs->value;
- REBVAL *arg = pvs->select;
- REBVAL *val = pvs->setval;
- REBINT i;
- REBINT n;
- REBI64 secs;
- REBINT tz;
- REBDAT date;
- REBINT day, month, year;
- REBINT num;
- REBVAL dat;
- REB_TIMEF time;
-
- // !zone! - adjust date by zone (unless /utc given)
-
- if (IS_WORD(arg)) {
- //!!! change this to an array!?
- switch (VAL_WORD_CANON(arg)) {
- case SYM_YEAR: i = 0; break;
- case SYM_MONTH: i = 1; break;
- case SYM_DAY: i = 2; break;
- case SYM_TIME: i = 3; break;
- case SYM_ZONE: i = 4; break;
- case SYM_DATE: i = 5; break;
- case SYM_WEEKDAY: i = 6; break;
- case SYM_JULIAN:
- case SYM_YEARDAY: i = 7; break;
- case SYM_UTC: i = 8; break;
- case SYM_HOUR: i = 9; break;
- case SYM_MINUTE: i = 10; break;
- case SYM_SECOND: i = 11; break;
- default: return PE_BAD_SELECT;
- }
- }
- else if (IS_INTEGER(arg)) {
- i = Int32(arg) - 1;
- if (i < 0 || i > 8) return PE_BAD_SELECT;
- }
- else
- return PE_BAD_SELECT;
-
- if (IS_DATE(data)) {
- dat = *data; // recode!
- data = &dat;
- if (i != 8) Adjust_Date_Zone(data, FALSE); // adjust for timezone
- date = VAL_DATE(data);
- day = VAL_DAY(data) - 1;
- month = VAL_MONTH(data) - 1;
- year = VAL_YEAR(data);
- secs = VAL_TIME(data);
- tz = VAL_ZONE(data);
- if (i > 8) Split_Time(secs, &time);
- }
-
- if (val == 0) {
- val = pvs->store;
- switch(i) {
- case 0:
- num = year;
- break;
- case 1:
- num = month + 1;
- break;
- case 2:
- num = day + 1;
- break;
- case 3:
- if (secs == NO_TIME) return PE_NONE;
- *val = *data;
- VAL_SET(val, REB_TIME);
- return PE_USE;
- case 4:
- if (secs == NO_TIME) return PE_NONE;
- *val = *data;
- VAL_TIME(val) = (i64)tz * ZONE_MINS * MIN_SEC;
- VAL_SET(val, REB_TIME);
- return PE_USE;
- case 5:
- // date
- *val = *data;
- VAL_TIME(val) = NO_TIME;
- VAL_ZONE(val) = 0;
- return PE_USE;
- case 6:
- // weekday
- num = Week_Day(date);
- break;
- case 7:
- // yearday
- num = (REBINT)Julian_Date(date);
- break;
- case 8:
- // utc
- *val = *data;
- VAL_ZONE(val) = 0;
- return PE_USE;
- case 9:
- num = time.h;
- break;
- case 10:
- num = time.m;
- break;
- case 11:
- if (time.n == 0) num = time.s;
- else {
- SET_DECIMAL(val, (REBDEC)time.s + (time.n * NANO));
- return PE_USE;
- }
- break;
-
- default:
- return PE_NONE;
- }
- SET_INTEGER(val, num);
- return PE_USE;
-
- } else {
-
- if (IS_INTEGER(val) || IS_DECIMAL(val)) n = Int32s(val, 0);
- else if (IS_NONE(val)) n = 0;
- else if (IS_TIME(val) && (i == 3 || i == 4));
- else if (IS_DATE(val) && (i == 3 || i == 5));
- else return PE_BAD_SET_TYPE;
-
- switch(i) {
- case 0:
- year = n;
- break;
- case 1:
- month = n - 1;
- break;
- case 2:
- day = n - 1;
- break;
- case 3:
- // time
- if (IS_NONE(val)) {
- secs = NO_TIME;
- tz = 0;
- break;
- }
- else if (IS_TIME(val) || IS_DATE(val))
- secs = VAL_TIME(val);
- else if (IS_INTEGER(val))
- secs = n * SEC_SEC;
- else if (IS_DECIMAL(val))
- secs = DEC_TO_SECS(VAL_DECIMAL(val));
- else return PE_BAD_SET_TYPE;
- break;
- case 4:
- // zone
- if (IS_TIME(val)) tz = (REBINT)(VAL_TIME(val) / (ZONE_MINS * MIN_SEC));
- else if (IS_DATE(val)) tz = VAL_ZONE(val);
- else tz = n * (60 / ZONE_MINS);
- if (tz > MAX_ZONE || tz < -MAX_ZONE) return PE_BAD_RANGE;
- break;
- case 5:
- // date
- if (!IS_DATE(val)) return PE_BAD_SET_TYPE;
- date = VAL_DATE(val);
- goto setDate;
- case 9:
- time.h = n;
- secs = Join_Time(&time);
- break;
- case 10:
- time.m = n;
- secs = Join_Time(&time);
- break;
- case 11:
- if (IS_INTEGER(val)) {
- time.s = n;
- time.n = 0;
- }
- else {
- //if (f < 0.0) Trap_Range(val);
- time.s = (REBINT)VAL_DECIMAL(val);
- time.n = (REBINT)((VAL_DECIMAL(val) - time.s) * SEC_SEC);
- }
- secs = Join_Time(&time);
- break;
-
- default:
- return PE_BAD_SET;
- }
-
- Normalize_Time(&secs, &day);
- date = Normalize_Date(day, month, year, tz);
+//
+// TO_Date: C
+//
+void TO_Date(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+ MAKE_Date(out, kind, arg);
+}
-setDate:
- data = pvs->value;
- VAL_SET(data, REB_DATE);
- VAL_DATE(data) = date;
- VAL_TIME(data) = secs;
- Adjust_Date_Zone(data, TRUE);
-
- return PE_USE;
- }
+
+static REBINT Int_From_Date_Arg(const REBVAL *opt_poke) {
+ if (IS_INTEGER(opt_poke) || IS_DECIMAL(opt_poke))
+ return Int32s(opt_poke, 0);
+ else if (IS_BLANK(opt_poke))
+ return 0;
+ else
+ fail (opt_poke);
}
-/***********************************************************************
-**
-*/ REBTYPE(Date)
-/*
-***********************************************************************/
-{
- REBI64 secs;
- REBINT tz;
- REBDAT date;
- REBINT day, month, year;
- REBVAL *val;
- REBVAL *arg;
- REBINT num;
-
- val = D_ARG(1);
- if (IS_DATE(val)) {
- date = VAL_DATE(val);
- day = VAL_DAY(val) - 1;
- month = VAL_MONTH(val) - 1;
- year = VAL_YEAR(val);
- tz = VAL_ZONE(val);
- secs = VAL_TIME(val);
- }
-
- if (DS_ARGC > 1) arg = D_ARG(2);
-
- if (IS_BINARY_ACT(action)) {
- REBINT type = VAL_TYPE(arg);
-
- if (type == REB_DATE) {
- if (action == A_SUBTRACT) {
- num = Diff_Date(date, VAL_DATE(arg));
- goto ret_int;
- }
- }
- else if (type == REB_TIME) {
- if (secs == NO_TIME) secs = 0;
- if (action == A_ADD) {
- secs += VAL_TIME(arg);
- goto fixTime;
- }
- if (action == A_SUBTRACT) {
- secs -= VAL_TIME(arg);
- goto fixTime;
- }
- }
- else if (type == REB_INTEGER) {
- num = Int32(arg);
- if (action == A_ADD) {
- day += num;
- goto fixDate;
- }
- if (action == A_SUBTRACT) {
- day -= num;
- goto fixDate;
- }
- }
- else if (type == REB_DECIMAL) {
- REBDEC dec = Dec64(arg);
- if (secs == NO_TIME) secs = 0;
- if (action == A_ADD) {
- secs += (REBI64)(dec * TIME_IN_DAY);
- goto fixTime;
- }
- if (action == A_SUBTRACT) {
- secs -= (REBI64)(dec * TIME_IN_DAY);
- goto fixTime;
- }
- }
- }
- else {
- switch(action) {
- case A_EVENQ: day = ~day;
- case A_ODDQ: DECIDE((day & 1) == 0);
-
- case A_PICK:
- Pick_Path(val, arg, 0);
- return R_TOS;
-
-/// case A_POKE:
-/// Pick_Path(val, arg, D_ARG(3));
-/// return R_ARG3;
-
- case A_MAKE:
- case A_TO:
- if (IS_DATE(arg)) {
- val = arg;
- goto ret_val;
- }
- if (IS_STRING(arg)) {
- REBYTE *bp;
- REBCNT len;
- // 30-September-10000/12:34:56.123456789AM/12:34
- bp = Qualify_String(arg, 45, &len, FALSE); // can trap, ret diff str
- if (Scan_Date(bp, len, D_RET)) return R_RET;
- }
- else if (ANY_BLOCK(arg) && VAL_BLK_LEN(arg) >= 3) {
- if (MT_Date(D_RET, VAL_BLK_DATA(arg), REB_DATE)) {
- return R_RET;
- }
- }
-// else if (IS_NONE(arg)) {
-// secs = nsec = day = month = year = tz = 0;
-// goto fixTime;
-// }
- Trap_Make(REB_DATE, arg);
-
- case A_RANDOM: //!!! needs further definition ? random/zero
- if (D_REF(2)) {
- // Note that nsecs not set often for dates (requires /precise)
- Set_Random(((REBI64)year << 48) + ((REBI64)Julian_Date(date) << 32) + secs);
- return R_UNSET;
- }
- if (year == 0) break;
- num = D_REF(3); // secure
- year = (REBCNT)Random_Range(year, num);
- month = (REBCNT)Random_Range(12, num);
- day = (REBCNT)Random_Range(31, num);
- if (secs != NO_TIME)
- secs = Random_Range(TIME_IN_DAY, num);
- goto fixDate;
-
- case A_ABSOLUTE:
- goto setDate;
- }
- }
- Trap_Action(REB_DATE, action);
+//
+// Pick_Or_Poke_Date: C
+//
+void Pick_Or_Poke_Date(
+ REBVAL *opt_out,
+ REBVAL *value,
+ const REBVAL *picker,
+ const REBVAL *opt_poke
+) {
+ REBDAT date = VAL_DATE(value);
+ REBCNT day = VAL_DAY(value) - 1;
+ REBCNT month = VAL_MONTH(value) - 1;
+ REBCNT year = VAL_YEAR(value);
+
+ REBI64 secs = VAL_NANO(value);
+ REBINT tz = VAL_ZONE(value);
+
+ REBSYM sym;
+ if (IS_WORD(picker)) {
+ sym = VAL_WORD_SYM(picker); // error later if SYM_0 or not a match
+ }
+ else if (IS_INTEGER(picker)) {
+ switch (Int32(picker)) {
+ case 1: sym = SYM_YEAR; break;
+ case 2: sym = SYM_MONTH; break;
+ case 3: sym = SYM_DAY; break;
+ case 4: sym = SYM_TIME; break;
+ case 5: sym = SYM_ZONE; break;
+ case 6: sym = SYM_DATE; break;
+ case 7: sym = SYM_WEEKDAY; break;
+ case 8: sym = SYM_JULIAN; break; // a.k.a. SYM_YEARDAY
+ case 9: sym = SYM_UTC; break;
+ case 10: sym = SYM_HOUR; break;
+ case 11: sym = SYM_MINUTE; break;
+ case 12: sym = SYM_SECOND; break;
+ default:
+ fail (picker);
+ }
+ }
+ else
+ fail (picker);
+
+ REB_TIMEF time; // only pay for split into this if needed...
+
+ if (opt_poke == NULL) {
+ assert(opt_out != NULL);
+ Move_Value(opt_out, value);
+
+ if (sym != SYM_UTC) Adjust_Date_Zone(opt_out, FALSE);
+
+ switch (sym) {
+ case SYM_YEAR:
+ Init_Integer(opt_out, year);
+ break;
+
+ case SYM_MONTH:
+ Init_Integer(opt_out, month + 1);
+ break;
+
+ case SYM_DAY:
+ Init_Integer(opt_out, day + 1);
+ break;
+
+ case SYM_TIME:
+ if (secs == NO_TIME)
+ Init_Void(opt_out);
+ else
+ VAL_RESET_HEADER(opt_out, REB_TIME);
+ break;
+
+ case SYM_ZONE:
+ if (secs == NO_TIME)
+ Init_Void(opt_out);
+ else {
+ VAL_RESET_HEADER(opt_out, REB_TIME);
+ VAL_NANO(opt_out) = cast(i64, tz) * ZONE_MINS * MIN_SEC;
+ }
+ break;
+
+ case SYM_DATE:
+ VAL_NANO(opt_out) = NO_TIME;
+ VAL_ZONE(opt_out) = 0;
+ break;
+
+ case SYM_WEEKDAY:
+ Init_Integer(opt_out, Week_Day(date));
+ break;
+
+ case SYM_JULIAN:
+ case SYM_YEARDAY:
+ Init_Integer(opt_out, cast(REBINT, Julian_Date(date)));
+ break;
+
+ case SYM_UTC:
+ VAL_ZONE(opt_out) = 0;
+ break;
+
+ case SYM_HOUR:
+ Split_Time(secs, &time);
+ Init_Integer(opt_out, time.h);
+ break;
+
+ case SYM_MINUTE:
+ Split_Time(secs, &time);
+ Init_Integer(opt_out, time.m);
+ break;
+
+ case SYM_SECOND:
+ Split_Time(secs, &time);
+ if (time.n == 0)
+ Init_Integer(opt_out, time.s);
+ else
+ Init_Decimal(opt_out, cast(REBDEC, time.s) + (time.n * NANO));
+ break;
+
+ default:
+ Init_Void(opt_out); // "out of range" PICK semantics
+ }
+ }
+ else {
+ assert(opt_out == NULL);
+
+ // Here the desire is to modify the incoming date directly. This is
+ // done by changing the components that need to change which were
+ // extracted, and building a new date out of the parts.
+
+ switch (sym) {
+ case SYM_YEAR:
+ year = Int_From_Date_Arg(opt_poke);
+ break;
+
+ case SYM_MONTH:
+ month = Int_From_Date_Arg(opt_poke) - 1;
+ break;
+
+ case SYM_DAY:
+ day = Int_From_Date_Arg(opt_poke) - 1;
+ break;
+
+ case SYM_TIME:
+ if (IS_BLANK(opt_poke)) {
+ secs = NO_TIME;
+ tz = 0;
+ break;
+ }
+ else if (IS_TIME(opt_poke) || IS_DATE(opt_poke))
+ secs = VAL_NANO(opt_poke);
+ else if (IS_INTEGER(opt_poke))
+ secs = Int_From_Date_Arg(opt_poke) * SEC_SEC;
+ else if (IS_DECIMAL(opt_poke))
+ secs = DEC_TO_SECS(VAL_DECIMAL(opt_poke));
+ else
+ fail (opt_poke);
+ break;
+
+ case SYM_ZONE:
+ if (IS_TIME(opt_poke))
+ tz = cast(REBINT, VAL_NANO(opt_poke) / (ZONE_MINS * MIN_SEC));
+ else if (IS_DATE(opt_poke))
+ tz = VAL_ZONE(opt_poke);
+ else tz = Int_From_Date_Arg(opt_poke) * (60 / ZONE_MINS);
+ if (tz > MAX_ZONE || tz < -MAX_ZONE)
+ fail (Error_Out_Of_Range(opt_poke));
+ break;
+
+ case SYM_JULIAN:
+ case SYM_WEEKDAY:
+ case SYM_UTC:
+ fail (picker);
+
+ case SYM_DATE:
+ if (!IS_DATE(opt_poke))
+ fail (opt_poke);
+ date = VAL_DATE(opt_poke);
+ goto set_without_normalize;
+
+ case SYM_HOUR:
+ Split_Time(secs, &time);
+ time.h = Int_From_Date_Arg(opt_poke);
+ secs = Join_Time(&time, FALSE);
+ break;
+
+ case SYM_MINUTE:
+ Split_Time(secs, &time);
+ time.m = Int_From_Date_Arg(opt_poke);
+ secs = Join_Time(&time, FALSE);
+ break;
+
+ case SYM_SECOND:
+ Split_Time(secs, &time);
+ if (IS_INTEGER(opt_poke)) {
+ time.s = Int_From_Date_Arg(opt_poke);
+ time.n = 0;
+ }
+ else {
+ //if (f < 0.0) fail (Error_Out_Of_Range(setval));
+ time.s = cast(REBINT, VAL_DECIMAL(opt_poke));
+ time.n = cast(REBINT,
+ (VAL_DECIMAL(opt_poke) - time.s) * SEC_SEC);
+ }
+ secs = Join_Time(&time, FALSE);
+ break;
+
+ default:
+ fail (picker);
+ }
+
+ Normalize_Time(&secs, &day);
+ date = Normalize_Date(day, month, year, tz);
+
+ set_without_normalize:
+ VAL_RESET_HEADER(value, REB_DATE);
+ VAL_DATE(value) = date;
+ VAL_NANO(value) = secs;
+ Adjust_Date_Zone(value, TRUE);
+ }
+}
-fixTime:
- Normalize_Time(&secs, &day);
-fixDate:
- date = Normalize_Date(day, month, year, tz);
+//
+// PD_Date: C
+//
+REBINT PD_Date(REBPVS *pvs)
+{
+ if (pvs->opt_setval) {
+ //
+ // !!! SET-PATH! in R3-Alpha could be used on DATE! even though it
+ // was an immediate value. It would thus modify the evaluated value,
+ // while not affecting the original (unless it was a literal value
+ // in source)
+ //
+ Pick_Or_Poke_Date(
+ NULL, KNOWN(pvs->value), pvs->picker, pvs->opt_setval
+ );
+ return PE_OK;
+ }
+
+ Pick_Or_Poke_Date(pvs->store, KNOWN(pvs->value), pvs->picker, NULL);
+ return PE_USE_STORE;
+}
-setDate:
- VAL_SET(DS_RETURN, REB_DATE);
- VAL_DATE(DS_RETURN) = date;
- VAL_TIME(DS_RETURN) = secs;
- return R_RET;
-ret_int:
- DS_RET_INT(num);
- return R_RET;
+//
+// REBTYPE: C
+//
+REBTYPE(Date)
+{
+ REBVAL *val = D_ARG(1);
+ assert(IS_DATE(val));
+
+ REBDAT date = VAL_DATE(val);
+ REBCNT day = VAL_DAY(val) - 1;
+ REBCNT month = VAL_MONTH(val) - 1;
+ REBCNT year = VAL_YEAR(val);
+ REBINT tz = VAL_ZONE(val);
+ REBI64 secs = VAL_NANO(val);
+
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+
+ if (action == SYM_SUBTRACT || action == SYM_ADD) {
+ REBINT type = VAL_TYPE(arg);
+
+ if (type == REB_DATE) {
+ if (action == SYM_SUBTRACT) {
+ Init_Integer(D_OUT, Diff_Date(date, VAL_DATE(arg)));
+ return R_OUT;
+ }
+ }
+ else if (type == REB_TIME) {
+ if (secs == NO_TIME)
+ secs = 0;
+ if (action == SYM_ADD) {
+ secs += VAL_NANO(arg);
+ goto fixTime;
+ }
+ if (action == SYM_SUBTRACT) {
+ secs -= VAL_NANO(arg);
+ goto fixTime;
+ }
+ }
+ else if (type == REB_INTEGER) {
+ REBINT num = Int32(arg);
+ if (action == SYM_ADD) {
+ day += num;
+ goto fixDate;
+ }
+ if (action == SYM_SUBTRACT) {
+ day -= num;
+ goto fixDate;
+ }
+ }
+ else if (type == REB_DECIMAL) {
+ REBDEC dec = Dec64(arg);
+ if (secs == NO_TIME) secs = 0;
+ if (action == SYM_ADD) {
+ secs += (REBI64)(dec * TIME_IN_DAY);
+ goto fixTime;
+ }
+ if (action == SYM_SUBTRACT) {
+ secs -= (REBI64)(dec * TIME_IN_DAY);
+ goto fixTime;
+ }
+ }
+ }
+ else {
+ switch(action) {
+ case SYM_EVEN_Q:
+ return ((~day) & 1) == 0 ? R_TRUE : R_FALSE;
+
+ case SYM_ODD_Q:
+ return (day & 1) == 0 ? R_TRUE : R_FALSE;
+
+ case SYM_RANDOM: {
+ INCLUDE_PARAMS_OF_RANDOM;
+
+ UNUSED(PAR(value));
+
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+
+ const REBOOL secure = REF(secure);
+
+ if (REF(seed)) {
+ //
+ // Note that nsecs not set often for dates (requires /precise)
+ //
+ Set_Random(
+ (cast(REBI64, year) << 48)
+ + (cast(REBI64, Julian_Date(date)) << 32)
+ + secs
+ );
+ return R_VOID;
+ }
+
+ if (year == 0) break;
+
+ year = cast(REBCNT, Random_Range(year, secure));
+ month = cast(REBCNT, Random_Range(12, secure));
+ day = cast(REBCNT, Random_Range(31, secure));
+
+ if (secs != NO_TIME)
+ secs = Random_Range(TIME_IN_DAY, secure);
+
+ goto fixDate;
+ }
+
+ case SYM_ABSOLUTE:
+ goto setDate;
+
+ default:
+ fail (Error_Illegal_Action(REB_DATE, action));
+ }
+ }
+ fail (Error_Illegal_Action(REB_DATE, action));
-ret_val:
- *DS_RETURN = *val;
- return R_RET;
+fixTime:
+ Normalize_Time(&secs, &day);
-is_false:
- return R_FALSE;
+fixDate:
+ date = Normalize_Date(day, month, year, tz);
-is_true:
- return R_TRUE;
+setDate:
+ VAL_RESET_HEADER(D_OUT, REB_DATE);
+ VAL_DATE(D_OUT) = date;
+ VAL_NANO(D_OUT) = secs;
+ return R_OUT;
}
diff --git a/src/core/t-decimal.c b/src/core/t-decimal.c
index f67564d1bf..e4672fe138 100644
--- a/src/core/t-decimal.c
+++ b/src/core/t-decimal.c
@@ -1,31 +1,32 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-decimal.c
-** Summary: decimal datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-decimal.c
+// Summary: "decimal datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
#include
@@ -38,448 +39,491 @@
#ifdef NO_GCVT
static char *gcvt(double value, int digits, char *buffer)
{
- sprintf(buffer, "%.*g", digits, value);
- return buffer;
+ sprintf(buffer, "%.*g", digits, value);
+ return buffer;
}
#endif
/*
- Purpose: {defines the almost_equal comparison function}
- Properties: {
- since floating point numbers are ordered and there is only
- a finite quantity of floating point numbers, it is possible
- to assign an ordinal (integer) number to any floating point number so,
- that the ordinal numbers of neighbors differ by one
-
- the function compares floating point numbers based on
- the difference of their ordinal numbers in the ordering
- of floating point numbers
-
- difference of 0 means exact equality, difference of 1 means, that
- the numbers are neighbors.
- }
- Advantages: {
- the function detects approximate equality.
-
- the function is more strict in the zero neighborhood than
- absolute-error-based approaches
-
- as opposed to relative-error-based approaches the error can be
- precisely specified, max_diff = 0 meaning exact match, max_diff = 1
- meaning that neighbors are deemed equal, max_diff = 10 meaning, that
- the numbers are deemed equal if at most 9
- distinct floating point numbers can be found between them
-
- the max_diff value may be one of the system options specified in
- the system/options object allowing users to exactly define the
- strictness of equality checks
- }
- Differences: {
- The approximate comparison currently used in R3 corresponds to the
- almost_equal function using max_diff = 10 (according to my tests).
-
- The main differences between the currently used comparison and the
- one based on the ordinal number comparison are:
- - the max_diff parameter can be adjusted, allowing
- the user to precisely specify the strictness of the comparison
- - the difference rule holds for zero too, which means, that
- zero is deemed equal with totally max_diff distinct (tiny) numbers
- }
- Notes: {
- the max_diff parameter does not need to be a REBI64 number,
- a smaller range like REBCNT may suffice
- }
+ Purpose: {defines the almost_equal comparison function}
+ Properties: {
+ since floating point numbers are ordered and there is only
+ a finite quantity of floating point numbers, it is possible
+ to assign an ordinal (integer) number to any floating point number so,
+ that the ordinal numbers of neighbors differ by one
+
+ the function compares floating point numbers based on
+ the difference of their ordinal numbers in the ordering
+ of floating point numbers
+
+ difference of 0 means exact equality, difference of 1 means, that
+ the numbers are neighbors.
+ }
+ Advantages: {
+ the function detects approximate equality.
+
+ the function is more strict in the zero neighborhood than
+ absolute-error-based approaches
+
+ as opposed to relative-error-based approaches the error can be
+ precisely specified, max_diff = 0 meaning exact match, max_diff = 1
+ meaning that neighbors are deemed equal, max_diff = 10 meaning, that
+ the numbers are deemed equal if at most 9
+ distinct floating point numbers can be found between them
+
+ the max_diff value may be one of the system options specified in
+ the system/options object allowing users to exactly define the
+ strictness of equality checks
+ }
+ Differences: {
+ The approximate comparison currently used in R3 corresponds to the
+ almost_equal function using max_diff = 10 (according to my tests).
+
+ The main differences between the currently used comparison and the
+ one based on the ordinal number comparison are:
+ - the max_diff parameter can be adjusted, allowing
+ the user to precisely specify the strictness of the comparison
+ - the difference rule holds for zero too, which means, that
+ zero is deemed equal with totally max_diff distinct (tiny) numbers
+ }
+ Notes: {
+ the max_diff parameter does not need to be a REBI64 number,
+ a smaller range like REBCNT may suffice
+ }
*/
REBOOL almost_equal(REBDEC a, REBDEC b, REBCNT max_diff) {
- union {REBDEC d; REBI64 i;} ua, ub;
- REBI64 int_diff;
+ union {REBDEC d; REBI64 i;} ua, ub;
+ REBI64 int_diff;
- ua.d = a;
- ub.d = b;
+ ua.d = a;
+ ub.d = b;
- /* Make ua.i a twos-complement ordinal number */
- if (ua.i < 0) ua.i = MIN_I64 - ua.i;
+ /* Make ua.i a twos-complement ordinal number */
+ if (ua.i < 0) ua.i = MIN_I64 - ua.i;
- /* Make ub.i a twos-complement ordinal number */
- if (ub.i < 0) ub.i = MIN_I64 - ub.i;
+ /* Make ub.i a twos-complement ordinal number */
+ if (ub.i < 0) ub.i = MIN_I64 - ub.i;
- int_diff = ua.i - ub.i;
- if (int_diff < 0) int_diff = -int_diff;
-
- return ((REBU64) int_diff <= max_diff);
+ int_diff = ua.i - ub.i;
+ if (int_diff < 0) int_diff = -int_diff;
+
+ return LOGICAL(cast(REBU64, int_diff) <= max_diff);
}
-/***********************************************************************
-**
-*/ REBFLG MT_Decimal(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+//
+// Init_Decimal_Bits: C
+//
+void Init_Decimal_Bits(REBVAL *out, const REBYTE *bp)
{
- if (!IS_END(data+1)) return FALSE;
+ VAL_RESET_HEADER(out, REB_DECIMAL);
+
+ REBYTE *dp = cast(REBYTE*, &VAL_DECIMAL(out));
+
+#ifdef ENDIAN_LITTLE
+ REBCNT n;
+ for (n = 0; n < 8; ++n)
+ dp[n] = bp[7 - n];
+#elif defined(ENDIAN_BIG)
+ REBCNT n;
+ for (n = 0; n < 8; ++n)
+ dp[n] = bp[n];
+#else
+ #error "Unsupported CPU endian"
+#endif
+}
- if (IS_DECIMAL(data))
- *out = *data;
- else if (IS_INTEGER(data)) {
- SET_DECIMAL(out, (REBDEC)VAL_INT64(data));
- }
- else return FALSE;
- SET_TYPE(out, type);
- return TRUE;
+//
+// MAKE_Decimal: C
+//
+void MAKE_Decimal(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+ REBDEC d;
+
+ switch (VAL_TYPE(arg)) {
+ case REB_DECIMAL:
+ d = VAL_DECIMAL(arg);
+ goto dont_divide_if_percent;
+
+ case REB_PERCENT:
+ d = VAL_DECIMAL(arg);
+ goto dont_divide_if_percent;
+
+ case REB_INTEGER:
+ d = cast(REBDEC, VAL_INT64(arg));
+ goto dont_divide_if_percent;
+
+ case REB_MONEY:
+ d = deci_to_decimal(VAL_MONEY_AMOUNT(arg));
+ goto dont_divide_if_percent;
+
+ case REB_LOGIC:
+ d = VAL_LOGIC(arg) ? 1.0 : 0.0;
+ goto dont_divide_if_percent;
+
+ case REB_CHAR:
+ d = cast(REBDEC, VAL_CHAR(arg));
+ goto dont_divide_if_percent;
+
+ case REB_TIME:
+ d = VAL_NANO(arg) * NANO;
+ break;
+
+ case REB_STRING:
+ {
+ REBCNT len;
+ REBYTE *bp = Temp_Byte_Chars_May_Fail(
+ arg, MAX_SCAN_DECIMAL, &len, FALSE
+ );
+
+ if (NULL == Scan_Decimal(out, bp, len, LOGICAL(kind != REB_PERCENT)))
+ goto bad_make;
+
+ d = VAL_DECIMAL(out); // may need to divide if percent, fall through
+ break;
+ }
+
+ case REB_BINARY:
+ if (VAL_LEN_AT(arg) < 8)
+ fail (arg);
+
+ Init_Decimal_Bits(out, VAL_BIN_AT(arg));
+ VAL_RESET_HEADER(out, kind);
+ d = VAL_DECIMAL(out);
+ break;
+
+ default:
+ if (ANY_ARRAY(arg) && VAL_ARRAY_LEN_AT(arg) == 2) {
+ RELVAL *item = VAL_ARRAY_AT(arg);
+ if (IS_INTEGER(item))
+ d = cast(REBDEC, VAL_INT64(item));
+ else if (IS_DECIMAL(item) || IS_PERCENT(item))
+ d = VAL_DECIMAL(item);
+ else {
+ DECLARE_LOCAL (specific);
+ Derelativize(specific, item, VAL_SPECIFIER(arg));
+
+ fail (specific);
+ }
+
+ ++item;
+
+ REBDEC exp;
+ if (IS_INTEGER(item))
+ exp = cast(REBDEC, VAL_INT64(item));
+ else if (IS_DECIMAL(item) || IS_PERCENT(item))
+ exp = VAL_DECIMAL(item);
+ else {
+ DECLARE_LOCAL (specific);
+ Derelativize(specific, item, VAL_SPECIFIER(arg));
+ fail (specific);
+ }
+
+ while (exp >= 1) {
+ //
+ // !!! Comment here said "funky. There must be a better way"
+ //
+ --exp;
+ d *= 10.0;
+ if (!FINITE(d))
+ fail (Error_Overflow_Raw());
+ }
+
+ while (exp <= -1) {
+ ++exp;
+ d /= 10.0;
+ }
+ }
+ else
+ fail (Error_Bad_Make(kind, arg));
+ }
+
+ if (kind == REB_PERCENT)
+ d /= 100.0;
+
+dont_divide_if_percent:
+ if (!FINITE(d))
+ fail (Error_Overflow_Raw());
+
+ VAL_RESET_HEADER(out, kind);
+ VAL_DECIMAL(out) = d;
+ return;
+
+bad_make:
+ fail (Error_Bad_Make(kind, arg));
}
-/***********************************************************************
-**
-*/ REBFLG Eq_Decimal(REBDEC a, REBDEC b)
-/*
-***********************************************************************/
+//
+// TO_Decimal: C
+//
+void TO_Decimal(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- return almost_equal(a, b, 10);
-#ifdef older
- REBDEC d = (COEF * a) - (COEF * b);
- static volatile REBDEC c, e;
- c = b + d; // These are stored in variables to avoid 80bit
- e = a - d; // intermediate math, which creates problems.
- if ((c - b) == 0.0 && (e - a) == 0.0) return TRUE;
- return FALSE;
-#endif
+ MAKE_Decimal(out, kind, arg);
}
-/***********************************************************************
-**
-*/ REBFLG Eq_Decimal2(REBDEC a, REBDEC b)
-/*
-***********************************************************************/
+//
+// Eq_Decimal: C
+//
+REBOOL Eq_Decimal(REBDEC a, REBDEC b)
{
- return almost_equal(a, b, 0);
+ return almost_equal(a, b, 10);
#ifdef older
- REBI64 d;
- if (a == b) return TRUE;
- d = *(REBU64*)&a - *(REBU64*)&b;
- if (d < 0) d = ~d;
- if (d <= EQ_RANGE) return TRUE;
- return FALSE;
+ REBDEC d = (COEF * a) - (COEF * b);
+ static volatile REBDEC c, e;
+ c = b + d; // These are stored in variables to avoid 80bit
+ e = a - d; // intermediate math, which creates problems.
+ if ((c - b) == 0.0 && (e - a) == 0.0) return TRUE;
+ return FALSE;
#endif
}
-/***********************************************************************
-**
-*/ REBINT CT_Decimal(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
-{
- if (mode >= 0) {
- if (mode <= 1) return almost_equal(VAL_DECIMAL(a), VAL_DECIMAL(b), 10);
- if (mode == 2) return almost_equal(VAL_DECIMAL(a), VAL_DECIMAL(b), 0);
- return VAL_INT64(a) == VAL_INT64(b); // bits are identical
- }
- if (mode == -1) return VAL_DECIMAL(a) >= VAL_DECIMAL(b);
- return VAL_DECIMAL(a) > VAL_DECIMAL(b);
-}
-/***********************************************************************
-**
-*/ static void Check_Overflow(REBDEC dval)
-/*
-***********************************************************************/
+//
+// Eq_Decimal2: C
+//
+REBOOL Eq_Decimal2(REBDEC a, REBDEC b)
{
- if (!FINITE(dval)) Trap0(RE_OVERFLOW);
+ return almost_equal(a, b, 0);
+#ifdef older
+ REBI64 d;
+ if (a == b) return TRUE;
+ d = *(REBU64*)&a - *(REBU64*)&b;
+ if (d < 0) d = ~d;
+ if (d <= EQ_RANGE) return TRUE;
+ return FALSE;
+#endif
}
-/***********************************************************************
-**
-*/ static void Binary_To_Decimal(REBVAL *bin, REBVAL *dec)
-/*
-***********************************************************************/
+//
+// CT_Decimal: C
+//
+REBINT CT_Decimal(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBI64 n = 0;
- REBSER *ser = VAL_SERIES(bin);
- REBCNT idx = VAL_INDEX(bin);
- REBCNT len = VAL_LEN(bin);
+ if (mode >= 0) {
+ if (mode == 0)
+ return almost_equal(VAL_DECIMAL(a), VAL_DECIMAL(b), 10) ? 1 : 0;
- if (len > 8) len = 8;
+ return almost_equal(VAL_DECIMAL(a), VAL_DECIMAL(b), 0) ? 1 : 0;
+ }
- for (; len; len--, idx++) n = (n << 8) | (REBI64)(GET_ANY_CHAR(ser, idx));
+ if (mode == -1)
+ return (VAL_DECIMAL(a) >= VAL_DECIMAL(b)) ? 1 : 0;
- VAL_SET(dec, REB_DECIMAL);
- VAL_INT64(dec) = n; // aliasing the bits!
+ return (VAL_DECIMAL(a) > VAL_DECIMAL(b)) ? 1 : 0;
}
-/***********************************************************************
-**
-*/ REBTYPE(Decimal)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+REBTYPE(Decimal)
{
- REBVAL *val = D_ARG(1);
- REBDEC d1 = VAL_DECIMAL(val);
- REBVAL *arg;
- REBDEC d2;
- REBINT num;
- REBDEC exp;
- REBINT type = 0;
-
- // all binary actions
- if (IS_BINARY_ACT(action)) {
-
- arg = D_ARG(2);
- type = VAL_TYPE(arg);
- if (type != REB_DECIMAL && (
- type == REB_PAIR ||
- type == REB_TUPLE ||
- type == REB_MONEY ||
- type == REB_TIME
- ) && (
- action == A_ADD ||
- action == A_MULTIPLY
- )
- ){
- *D_RET = *D_ARG(2);
- *D_ARG(2) = *D_ARG(1);
- *D_ARG(1) = *D_RET;
- return Value_Dispatch[VAL_TYPE(D_ARG(1))](ds, action);
- }
-
- // If the type of the second arg is something we can handle:
- if (type == REB_DECIMAL
- || type == REB_INTEGER
- || type == REB_PERCENT
- || type == REB_MONEY
- || type == REB_CHAR
- ){
- if (type == REB_DECIMAL) {
- d2 = VAL_DECIMAL(arg);
- } else if (type == REB_PERCENT) {
- d2 = VAL_DECIMAL(arg);
- if (action == A_DIVIDE) type = REB_DECIMAL;
- else if (!IS_PERCENT(val)) type = VAL_TYPE(val);
- } else if (type == REB_MONEY) {
- VAL_DECI(val) = decimal_to_deci(VAL_DECIMAL(val));
- VAL_SET(val, REB_MONEY);
- return T_Money(ds, action);
- } else if (type == REB_CHAR) {
- d2 = (REBDEC)VAL_CHAR(arg);
- type = REB_DECIMAL;
- } else {
- d2 = (REBDEC)VAL_INT64(arg);
- type = REB_DECIMAL;
- }
-
- switch (action) {
-
- case A_ADD:
- d1 += d2;
- goto setDec;
-
- case A_SUBTRACT:
- d1 -= d2;
- goto setDec;
-
- case A_MULTIPLY:
- d1 *= d2;
- goto setDec;
-
- case A_DIVIDE:
- case A_REMAINDER:
- if (d2 == 0.0) Trap0(RE_ZERO_DIVIDE);
- if (action == A_DIVIDE) d1 /= d2;
- else d1 = fmod(d1, d2);
- goto setDec;
-
- case A_POWER:
- if (d1 == 0) goto setDec;
- if (d2 == 0) {
- d1 = 1.0;
- goto setDec;
- }
- //if (d1 < 0 && d2 < 1 && d2 != -1)
- // Trap0(RE_POSITIVE);
- d1 = pow(d1, d2);
- goto setDec;
-
- }
- }
- Trap_Math_Args(VAL_TYPE(val), action);
- }
- else {
- type = VAL_TYPE(val);
-
- // unary actions
- switch (action) {
-
- case A_NEGATE:
- d1 = -d1;
- goto setDec;
- case A_ABSOLUTE:
- if (d1 < 0) d1 = -d1;
- goto setDec;
- case A_EVENQ:
- case A_ODDQ:
- d1 = fabs(fmod(d1, 2.0));
- DECIDE((action != A_EVENQ) != ((d1 < 0.5) || (d1 >= 1.5)));
-
- case A_MAKE:
- case A_TO:
- // MAKE decimal! 2 and MAKE 1.0 2 formats:
- if (IS_DATATYPE(val)) type = VAL_DATATYPE(val);
- else type = VAL_TYPE(val);
-
- val = D_ARG(2);
-
- switch (VAL_TYPE(val)) {
-
- case REB_DECIMAL:
- d1 = VAL_DECIMAL(val);
- goto setDec;
-
- case REB_PERCENT:
- d1 = VAL_DECIMAL(val);
- goto setDec;
-
- case REB_INTEGER:
- d1 = (REBDEC)VAL_INT64(val);
- goto setDec;
-
- case REB_MONEY:
- d1 = deci_to_decimal(VAL_DECI(val));
- goto setDec;
-
- case REB_LOGIC:
- d1 = VAL_LOGIC(val) ? 1.0 : 0.0;
- goto setDec;
-
- case REB_CHAR:
- d1 = (REBDEC)VAL_CHAR(val);
- goto setDec;
-
- case REB_TIME:
- d1 = VAL_TIME(val) * NANO;
- break;
-
- case REB_STRING:
- {
- REBYTE *bp;
- REBCNT len;
- bp = Qualify_String(val, 24, &len, FALSE);
- if (Scan_Decimal(bp, len, D_RET, type != REB_PERCENT)) {
- d1 = VAL_DECIMAL(D_RET);
- if (type == REB_PERCENT) break;
- goto setDec;
- }
- Trap_Make(type, val);
- }
-
- case REB_BINARY:
- Binary_To_Decimal(val, D_RET);
- d1 = VAL_DECIMAL(D_RET);
- break;
-
-#ifdef removed
-// case REB_ISSUE:
- {
- REBYTE *bp;
- REBCNT len;
- bp = Qualify_String(val, MAX_HEX_LEN, &len, FALSE);
- if (Scan_Hex(bp, &VAL_INT64(D_RET), len, len) == 0)
- Trap_Make(REB_DECIMAL, val);
- d1 = VAL_DECIMAL(D_RET);
- break;
- }
-#endif
-
- default:
- if (ANY_BLOCK(val) && VAL_BLK_LEN(val) == 2) {
- arg = VAL_BLK_DATA(val);
- if (IS_INTEGER(arg)) d1 = (REBDEC)VAL_INT64(arg);
- else if (IS_DECIMAL(arg) || IS_PERCENT(val)) d1 = VAL_DECIMAL(arg);
- else Trap_Make(REB_DECIMAL, arg);
-
- if (IS_INTEGER(++arg)) exp = (REBDEC)VAL_INT64(arg);
- else if (IS_DECIMAL(arg) || IS_PERCENT(val)) exp = VAL_DECIMAL(arg);
- else Trap_Make(REB_DECIMAL, arg);
- while (exp >= 1) // funky. There must be a better way
- exp--, d1 *= 10.0, Check_Overflow(d1);
- while (exp <= -1)
- exp++, d1 /= 10.0;
- } else
- Trap_Make(type, val);
- }
-
- if (type == REB_PERCENT) d1 /= 100.0;
- goto setDec;
-
- case A_ROUND:
- arg = D_ARG(3);
- num = Get_Round_Flags(ds);
- if (D_REF(2)) { // to
- if (IS_MONEY(arg)) {
- VAL_DECI(D_RET) = Round_Deci(decimal_to_deci(d1), num, VAL_DECI(arg));
- SET_TYPE(D_RET, REB_MONEY);
- return R_RET;
- }
- if (IS_TIME(arg)) Trap_Arg(arg);
-
- d1 = Round_Dec(d1, num, Dec64(arg));
- if (IS_INTEGER(arg)) {
- VAL_INT64(D_RET) = (REBI64)d1;
- SET_TYPE(D_RET, REB_INTEGER);
- return R_RET;
- }
- if (IS_PERCENT(arg)) type = REB_PERCENT;
- }
- else
- d1 = Round_Dec(d1, num | 1, type == REB_PERCENT ? 0.01L : 1.0L); // /TO
- goto setDec;
-
- case A_RANDOM:
- if (D_REF(2)) {
- Set_Random(VAL_INT64(val)); // use IEEE bits
- return R_UNSET;
- }
-#ifdef OLD_METHOD
- if (d1 > (double) (((unsigned long) -1)>>1))
- d1 = ((unsigned long) -1)>>1;
- i = (REBINT)d1;
- if (i == 0) goto setDec;
- if (i < 0) d1 = -1.0 * (1.0 + (REBDEC)(Random_Int((REBOOL)D_REF(3)) % abs(i)));
- else d1 = 1.0 + (REBDEC)(Random_Int((REBOOL)D_REF(3)) % i);
-#else
- d1 = Random_Dec(d1, D_REF(3));
-#endif
- goto setDec;
-
- case A_COMPLEMENT:
- SET_INTEGER(D_RET, ~(REBINT)d1);
- return R_RET;
- }
- }
- Trap_Action(VAL_TYPE(val), action);
+ REBVAL *val = D_ARG(1);
+ REBVAL *arg;
+ REBDEC d2;
+ enum Reb_Kind type;
+
+ REBDEC d1 = VAL_DECIMAL(val);
+
+ // !!! This used to use IS_BINARY_ACT() which is no longer available with
+ // symbol-based dispatch. Consider doing this another way.
+ //
+ if (
+ action == SYM_ADD
+ || action == SYM_SUBTRACT
+ || action == SYM_MULTIPLY
+ || action == SYM_DIVIDE
+ || action == SYM_REMAINDER
+ || action == SYM_POWER
+ ){
+ arg = D_ARG(2);
+ type = VAL_TYPE(arg);
+ if (type != REB_DECIMAL && (
+ type == REB_PAIR ||
+ type == REB_TUPLE ||
+ type == REB_MONEY ||
+ type == REB_TIME
+ ) && (
+ action == SYM_ADD ||
+ action == SYM_MULTIPLY
+ )
+ ){
+ Move_Value(D_OUT, D_ARG(2));
+ Move_Value(D_ARG(2), D_ARG(1));
+ Move_Value(D_ARG(1), D_OUT);
+ return Value_Dispatch[VAL_TYPE(D_ARG(1))](frame_, action);
+ }
+
+ // If the type of the second arg is something we can handle:
+ if (type == REB_DECIMAL
+ || type == REB_INTEGER
+ || type == REB_PERCENT
+ || type == REB_MONEY
+ || type == REB_CHAR
+ ){
+ if (type == REB_DECIMAL) {
+ d2 = VAL_DECIMAL(arg);
+ } else if (type == REB_PERCENT) {
+ d2 = VAL_DECIMAL(arg);
+ if (action == SYM_DIVIDE) type = REB_DECIMAL;
+ else if (!IS_PERCENT(val)) type = VAL_TYPE(val);
+ } else if (type == REB_MONEY) {
+ Init_Money(val, decimal_to_deci(VAL_DECIMAL(val)));
+ return T_Money(frame_, action);
+ } else if (type == REB_CHAR) {
+ d2 = (REBDEC)VAL_CHAR(arg);
+ type = REB_DECIMAL;
+ } else {
+ d2 = (REBDEC)VAL_INT64(arg);
+ type = REB_DECIMAL;
+ }
+
+ switch (action) {
+
+ case SYM_ADD:
+ d1 += d2;
+ goto setDec;
+
+ case SYM_SUBTRACT:
+ d1 -= d2;
+ goto setDec;
+
+ case SYM_MULTIPLY:
+ d1 *= d2;
+ goto setDec;
+
+ case SYM_DIVIDE:
+ case SYM_REMAINDER:
+ if (d2 == 0.0) fail (Error_Zero_Divide_Raw());
+ if (action == SYM_DIVIDE) d1 /= d2;
+ else d1 = fmod(d1, d2);
+ goto setDec;
+
+ case SYM_POWER:
+ if (d1 == 0) goto setDec;
+ if (d2 == 0) {
+ d1 = 1.0;
+ goto setDec;
+ }
+ //if (d1 < 0 && d2 < 1 && d2 != -1)
+ // fail (Error_Positive_Raw());
+ d1 = pow(d1, d2);
+ goto setDec;
+
+ default:
+ fail (Error_Math_Args(VAL_TYPE(val), action));
+ }
+ }
+ fail (Error_Math_Args(VAL_TYPE(val), action));
+ }
+ else {
+ type = VAL_TYPE(val);
+
+ // unary actions
+ switch (action) {
+
+ case SYM_COPY:
+ Move_Value(D_OUT, val);
+ return R_OUT;
+
+ case SYM_NEGATE:
+ d1 = -d1;
+ goto setDec;
+
+ case SYM_ABSOLUTE:
+ if (d1 < 0) d1 = -d1;
+ goto setDec;
+
+ case SYM_EVEN_Q:
+ d1 = fabs(fmod(d1, 2.0));
+ if (d1 < 0.5 || d1 >= 1.5)
+ return R_TRUE;
+ return R_FALSE;
+
+ case SYM_ODD_Q:
+ d1 = fabs(fmod(d1, 2.0));
+ if (d1 < 0.5 || d1 >= 1.5)
+ return R_FALSE;
+ return R_TRUE;
+
+ case SYM_ROUND: {
+ INCLUDE_PARAMS_OF_ROUND;
+
+ UNUSED(PAR(value));
+
+ REBFLGS flags = (
+ (REF(to) ? RF_TO : 0)
+ | (REF(even) ? RF_EVEN : 0)
+ | (REF(down) ? RF_DOWN : 0)
+ | (REF(half_down) ? RF_HALF_DOWN : 0)
+ | (REF(floor) ? RF_FLOOR : 0)
+ | (REF(ceiling) ? RF_CEILING : 0)
+ | (REF(half_ceiling) ? RF_HALF_CEILING : 0)
+ );
+
+ arg = ARG(scale);
+ if (REF(to)) {
+ if (IS_MONEY(arg)) {
+ Init_Money(D_OUT, Round_Deci(
+ decimal_to_deci(d1), flags, VAL_MONEY_AMOUNT(arg)
+ ));
+ return R_OUT;
+ }
+ if (IS_TIME(arg))
+ fail (arg);
+
+ d1 = Round_Dec(d1, flags, Dec64(arg));
+ if (IS_INTEGER(arg)) {
+ VAL_RESET_HEADER(D_OUT, REB_INTEGER);
+ VAL_INT64(D_OUT) = cast(REBI64, d1);
+ return R_OUT;
+ }
+ if (IS_PERCENT(arg)) type = REB_PERCENT;
+ }
+ else
+ d1 = Round_Dec(
+ d1, flags | RF_TO, type == REB_PERCENT ? 0.01L : 1.0L
+ );
+ goto setDec; }
+
+ case SYM_RANDOM: {
+ INCLUDE_PARAMS_OF_RANDOM;
+
+ UNUSED(PAR(value));
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+
+ if (REF(seed)) {
+ REBDEC d = VAL_DECIMAL(val);
+ REBI64 i;
+ assert(sizeof(d) == sizeof(i));
+ memcpy(&i, &d, sizeof(d));
+ Set_Random(i); // use IEEE bits
+ return R_VOID;
+ }
+ d1 = Random_Dec(d1, REF(secure));
+ goto setDec; }
+
+ case SYM_COMPLEMENT:
+ Init_Integer(D_OUT, ~(REBINT)d1);
+ return R_OUT;
+
+ default:
+ fail (Error_Illegal_Action(VAL_TYPE(val), action));
+ }
+ }
+
+ fail (Error_Illegal_Action(VAL_TYPE(val), action));
setDec:
- if (!FINITE(d1)) Trap0(RE_OVERFLOW);
-#ifdef not_required
- if (type == REB_PERCENT) {
- // Keep percent in smaller range (not to use e notation).
- if (d1 != 0) {
- num = (REBINT)floor(log10(fabs(d1)));
- if (num > 12 || num < -6) Trap0(RE_OVERFLOW); // use gcvt
- }
- }
-#endif
- VAL_SET(D_RET, type);
- VAL_DECIMAL(D_RET) = d1;
- ///if (type == REB_MONEY) VAL_MONEY_DENOM(D_RET)[0] = 0;
- return R_RET;
+ if (!FINITE(d1)) fail (Error_Overflow_Raw());
-is_false:
- return R_FALSE;
+ VAL_RESET_HEADER(D_OUT, type);
+ VAL_DECIMAL(D_OUT) = d1;
-is_true:
- return R_TRUE;
+ return R_OUT;
}
diff --git a/src/core/t-event.c b/src/core/t-event.c
index 570f13785d..559a0cb952 100644
--- a/src/core/t-event.c
+++ b/src/core/t-event.c
@@ -1,535 +1,485 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-event.c
-** Summary: event datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-** Events are kept compact in order to fit into normal 128 bit
-** values cells. This provides high performance for high frequency
-** events and also good memory efficiency using standard series.
-**
-***********************************************************************/
+//
+// File: %t-event.c
+// Summary: "event datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Events are kept compact in order to fit into normal 128 bit
+// values cells. This provides high performance for high frequency
+// events and also good memory efficiency using standard series.
+//
#include "sys-core.h"
#include "reb-evtypes.h"
-#include "reb-net.h"
-/***********************************************************************
-**
-*/ REBINT CT_Event(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Event: C
+//
+REBINT CT_Event(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBINT diff = Cmp_Event(a, b);
- if (mode >=0) return diff == 0;
- return -1;
+ REBINT diff = Cmp_Event(a, b);
+ if (mode >=0) return diff == 0;
+ return -1;
}
-/***********************************************************************
-**
-*/ REBINT Cmp_Event(REBVAL *t1, REBVAL *t2)
-/*
-** Given two events, compare them.
-**
-***********************************************************************/
+//
+// Cmp_Event: C
+//
+// Given two events, compare them.
+//
+REBINT Cmp_Event(const RELVAL *t1, const RELVAL *t2)
{
- REBINT diff;
+ REBINT diff;
- if (
- (diff = VAL_EVENT_MODEL(t1) - VAL_EVENT_MODEL(t2))
- || (diff = VAL_EVENT_TYPE(t1) - VAL_EVENT_TYPE(t2))
- || (diff = VAL_EVENT_XY(t1) - VAL_EVENT_XY(t2))
- ) return diff;
+ if (
+ (diff = VAL_EVENT_MODEL(t1) - VAL_EVENT_MODEL(t2))
+ || (diff = VAL_EVENT_TYPE(t1) - VAL_EVENT_TYPE(t2))
+ || (diff = VAL_EVENT_XY(t1) - VAL_EVENT_XY(t2))
+ ) return diff;
- return 0;
+ return 0;
}
-/***********************************************************************
-**
-*/ static REBFLG Set_Event_Var(REBVAL *value, REBVAL *word, REBVAL *val)
-/*
-***********************************************************************/
+//
+// Set_Event_Var: C
+//
+static REBOOL Set_Event_Var(REBVAL *event, const REBVAL *word, const REBVAL *val)
{
- REBVAL *arg;
- REBINT n;
- REBCNT w;
-
- switch (VAL_WORD_CANON(word)) {
-
- case SYM_TYPE:
- if (!IS_WORD(val) && !IS_LIT_WORD(val)) return FALSE;
- arg = Get_System(SYS_VIEW, VIEW_EVENT_TYPES);
- if (IS_BLOCK(arg)) {
- w = VAL_WORD_CANON(val);
- for (n = 0, arg = VAL_BLK(arg); NOT_END(arg); arg++, n++) {
- if (IS_WORD(arg) && VAL_WORD_CANON(arg) == w) {
- VAL_EVENT_TYPE(value) = n;
- return TRUE;
- }
- }
- Trap_Arg(val);
- }
- return FALSE;
-
- case SYM_PORT:
- if (IS_PORT(val)) {
- VAL_EVENT_MODEL(value) = EVM_PORT;
- VAL_EVENT_SER(value) = VAL_PORT(val);
- }
- else if (IS_OBJECT(val)) {
- VAL_EVENT_MODEL(value) = EVM_OBJECT;
- VAL_EVENT_SER(value) = VAL_OBJ_FRAME(val);
- }
- else if (IS_NONE(val)) {
- VAL_EVENT_MODEL(value) = EVM_GUI;
- } else return FALSE;
- break;
-
- case SYM_WINDOW:
- case SYM_GOB:
- if (IS_GOB(val)) {
- VAL_EVENT_MODEL(value) = EVM_GUI;
- VAL_EVENT_SER(value) = VAL_GOB(val);
- break;
- }
- return FALSE;
-
- case SYM_OFFSET:
- if (IS_PAIR(val)) {
- SET_EVENT_XY(value, Float_Int16(VAL_PAIR_X(val)), Float_Int16(VAL_PAIR_Y(val)));
- }
- else return FALSE;
- break;
-
- case SYM_KEY:
- //VAL_EVENT_TYPE(value) != EVT_KEY && VAL_EVENT_TYPE(value) != EVT_KEY_UP)
- VAL_EVENT_MODEL(value) = EVM_GUI;
- if (IS_CHAR(val)) {
- VAL_EVENT_DATA(value) = VAL_CHAR(val);
- }
- else if (IS_LIT_WORD(val) || IS_WORD(val)) {
- arg = Get_System(SYS_VIEW, VIEW_EVENT_KEYS);
- if (IS_BLOCK(arg)) {
- arg = VAL_BLK_DATA(arg);
- for (n = VAL_INDEX(arg); NOT_END(arg); n++, arg++) {
- if (IS_WORD(arg) && VAL_WORD_CANON(arg) == VAL_WORD_CANON(val)) {
- VAL_EVENT_DATA(value) = (n+1) << 16;
- break;
- }
- }
- if (IS_END(arg)) return FALSE;
- break;
- }
- return FALSE;
- }
- else return FALSE;
- break;
-
- case SYM_CODE:
- if (IS_INTEGER(val)) {
- VAL_EVENT_DATA(value) = VAL_INT32(val);
- }
- else return FALSE;
- break;
-
- default:
- return FALSE;
- }
-
- return TRUE;
+ RELVAL *arg;
+ REBINT n;
+
+ switch (VAL_WORD_SYM(word)) {
+ case SYM_TYPE:
+ if (!IS_WORD(val) && !IS_LIT_WORD(val)) return FALSE;
+ arg = Get_System(SYS_VIEW, VIEW_EVENT_TYPES);
+ if (IS_BLOCK(arg)) {
+ REBSTR *w = VAL_WORD_CANON(val);
+ for (n = 0, arg = VAL_ARRAY_HEAD(arg); NOT_END(arg); arg++, n++) {
+ if (IS_WORD(arg) && VAL_WORD_CANON(arg) == w) {
+ VAL_EVENT_TYPE(event) = n;
+ return TRUE;
+ }
+ }
+ fail (val);
+ }
+ return FALSE;
+
+ case SYM_PORT:
+ if (IS_PORT(val)) {
+ VAL_EVENT_MODEL(event) = EVM_PORT;
+ VAL_EVENT_SER(event) = SER(CTX_VARLIST(VAL_CONTEXT(val)));
+ }
+ else if (IS_OBJECT(val)) {
+ VAL_EVENT_MODEL(event) = EVM_OBJECT;
+ VAL_EVENT_SER(event) = SER(CTX_VARLIST(VAL_CONTEXT(val)));
+ }
+ else if (IS_BLANK(val)) {
+ VAL_EVENT_MODEL(event) = EVM_GUI;
+ } else return FALSE;
+ break;
+
+ case SYM_WINDOW:
+ case SYM_GOB:
+ if (IS_GOB(val)) {
+ VAL_EVENT_MODEL(event) = EVM_GUI;
+ VAL_EVENT_SER(event) = cast(REBSER*, VAL_GOB(val));
+ break;
+ }
+ return FALSE;
+
+ case SYM_OFFSET:
+ if (IS_PAIR(val)) {
+ SET_EVENT_XY(
+ event,
+ Float_Int16(VAL_PAIR_X(val)),
+ Float_Int16(VAL_PAIR_Y(val))
+ );
+ }
+ else return FALSE;
+ break;
+
+ case SYM_KEY:
+ //VAL_EVENT_TYPE(event) != EVT_KEY && VAL_EVENT_TYPE(value) != EVT_KEY_UP)
+ VAL_EVENT_MODEL(event) = EVM_GUI;
+ if (IS_CHAR(val)) {
+ VAL_EVENT_DATA(event) = VAL_CHAR(val);
+ }
+ else if (IS_LIT_WORD(val) || IS_WORD(val)) {
+ arg = Get_System(SYS_VIEW, VIEW_EVENT_KEYS);
+ if (IS_BLOCK(arg)) {
+ arg = VAL_ARRAY_AT(arg);
+ for (n = VAL_INDEX(arg); NOT_END(arg); n++, arg++) {
+ if (IS_WORD(arg) && VAL_WORD_CANON(arg) == VAL_WORD_CANON(val)) {
+ VAL_EVENT_DATA(event) = (n+1) << 16;
+ break;
+ }
+ }
+ if (IS_END(arg)) return FALSE;
+ break;
+ }
+ return FALSE;
+ }
+ else return FALSE;
+ break;
+
+ case SYM_CODE:
+ if (IS_INTEGER(val)) {
+ VAL_EVENT_DATA(event) = VAL_INT32(val);
+ }
+ else return FALSE;
+ break;
+
+ case SYM_FLAGS: {
+ if (NOT(IS_BLOCK(val)))
+ return FALSE;
+
+ VAL_EVENT_FLAGS(event)
+ &= ~((1 << EVF_DOUBLE) | (1 << EVF_CONTROL) | (1 << EVF_SHIFT));
+
+ RELVAL *item;
+ for (item = VAL_ARRAY_HEAD(val); NOT_END(item); ++item) {
+ if (NOT(IS_WORD(item)))
+ continue;
+
+ switch (VAL_WORD_SYM(item)) {
+ case SYM_CONTROL:
+ SET_FLAG(VAL_EVENT_FLAGS(event), EVF_CONTROL);
+ break;
+
+ case SYM_SHIFT:
+ SET_FLAG(VAL_EVENT_FLAGS(event), EVF_SHIFT);
+ break;
+
+ case SYM_DOUBLE:
+ SET_FLAG(VAL_EVENT_FLAGS(event), EVF_DOUBLE);
+ break;
+
+ default:
+ fail (Error_Invalid_Arg_Core(item, VAL_SPECIFIER(val)));
+ }
+ }
+ break; }
+
+ default:
+ return FALSE;
+ }
+
+ return TRUE;
}
-/***********************************************************************
-**
-*/ static void Set_Event_Vars(REBVAL *evt, REBVAL *blk)
-/*
-***********************************************************************/
+//
+// Set_Event_Vars: C
+//
+void Set_Event_Vars(REBVAL *evt, RELVAL *blk, REBSPC *specifier)
{
- REBVAL *var;
- REBVAL *val;
-
- while (NOT_END(blk)) {
- var = blk++;
- val = blk++;
- if (IS_END(val)) val = NONE_VALUE;
- else val = Get_Simple_Value(val);
- if (!Set_Event_Var(evt, var, val)) Trap2(RE_BAD_FIELD_SET, var, Of_Type(val));
- }
+ DECLARE_LOCAL (var);
+ DECLARE_LOCAL (val);
+
+ while (NOT_END(blk)) {
+ Derelativize(var, blk, specifier);
+ ++blk;
+
+ if (IS_END(blk))
+ Init_Blank(val);
+ else
+ Get_Simple_Value_Into(val, blk, specifier);
+
+ ++blk;
+
+ if (!Set_Event_Var(evt, var, val))
+ fail (Error_Bad_Field_Set_Raw(var, Type_Of(val)));
+ }
}
-/***********************************************************************
-**
-*/ static REBFLG Get_Event_Var(REBVAL *value, REBCNT sym, REBVAL *val)
-/*
-***********************************************************************/
+//
+// Get_Event_Var: C
+//
+static REBOOL Get_Event_Var(const REBVAL *value, REBSTR *name, REBVAL *val)
{
- REBVAL *arg;
- REBREQ *req;
- REBINT n;
- REBSER *ser;
-
- switch (sym) {
-
- case SYM_TYPE:
- if (VAL_EVENT_TYPE(value) == 0) goto is_none;
- arg = Get_System(SYS_VIEW, VIEW_EVENT_TYPES);
- if (IS_BLOCK(arg) && VAL_TAIL(arg) >= EVT_MAX) {
- *val = *VAL_BLK_SKIP(arg, VAL_EVENT_TYPE(value));
- break;
- }
- return FALSE;
-
- case SYM_PORT:
- // Most events are for the GUI:
- if (IS_EVENT_MODEL(value, EVM_GUI)) {
- *val = *Get_System(SYS_VIEW, VIEW_EVENT_PORT);
- }
- // Event holds a port:
- else if (IS_EVENT_MODEL(value, EVM_PORT)) {
- SET_PORT(val, VAL_EVENT_SER(value));
- }
- // Event holds an object:
- else if (IS_EVENT_MODEL(value, EVM_OBJECT)) {
- SET_OBJECT(val, VAL_EVENT_SER(value));
- }
- else if (IS_EVENT_MODEL(value, EVM_CALLBACK)) {
- *val = *Get_System(SYS_PORTS, PORTS_CALLBACK);
- }
- else {
- // assumes EVM_DEVICE
- // Event holds the IO-Request, which has the PORT:
- req = VAL_EVENT_REQ(value);
- if (!req || !req->port) goto is_none;
- SET_PORT(val, (REBSER*)(req->port));
- }
- break;
-
- case SYM_WINDOW:
- case SYM_GOB:
- if (IS_EVENT_MODEL(value, EVM_GUI)) {
- if (VAL_EVENT_SER(value)) {
- SET_GOB(val, VAL_EVENT_SER(value));
- break;
- }
- }
- return FALSE;
-
- case SYM_OFFSET:
- if (VAL_EVENT_TYPE(value) == EVT_KEY || VAL_EVENT_TYPE(value) == EVT_KEY_UP)
- goto is_none;
- VAL_SET(val, REB_PAIR);
- VAL_PAIR_X(val) = (REBD32)VAL_EVENT_X(value);
- VAL_PAIR_Y(val) = (REBD32)VAL_EVENT_Y(value);
- break;
-
- case SYM_KEY:
- if (VAL_EVENT_TYPE(value) != EVT_KEY && VAL_EVENT_TYPE(value) != EVT_KEY_UP)
- goto is_none;
- n = VAL_EVENT_DATA(value); // key-words in top 16, chars in lower 16
- if (n & 0xffff0000) {
- arg = Get_System(SYS_VIEW, VIEW_EVENT_KEYS);
- n = (n >> 16) - 1;
- if (IS_BLOCK(arg) && n < (REBINT)VAL_TAIL(arg)) {
- *val = *VAL_BLK_SKIP(arg, n);
- break;
- }
- return FALSE;
- }
- SET_CHAR(val, n);
- break;
-
- case SYM_FLAGS:
- if (VAL_EVENT_FLAGS(value) & (1<= EVT_MAX) {
+ Derelativize(
+ val,
+ VAL_ARRAY_AT_HEAD(arg, VAL_EVENT_TYPE(value)),
+ VAL_SPECIFIER(arg)
+ );
+ break;
+ }
+ return FALSE;
+
+ case SYM_PORT:
+ // Most events are for the GUI:
+ if (IS_EVENT_MODEL(value, EVM_GUI)) {
+ Move_Value(val, Get_System(SYS_VIEW, VIEW_EVENT_PORT));
+ }
+ // Event holds a port:
+ else if (IS_EVENT_MODEL(value, EVM_PORT)) {
+ Init_Port(val, CTX(VAL_EVENT_SER(value)));
+ }
+ // Event holds an object:
+ else if (IS_EVENT_MODEL(value, EVM_OBJECT)) {
+ Init_Object(val, CTX(VAL_EVENT_SER(value)));
+ }
+ else if (IS_EVENT_MODEL(value, EVM_CALLBACK)) {
+ Move_Value(val, Get_System(SYS_PORTS, PORTS_CALLBACK));
+ }
+ else {
+ // assumes EVM_DEVICE
+ // Event holds the IO-Request, which has the PORT:
+ req = VAL_EVENT_REQ(value);
+ if (!req || !req->port) goto is_blank;
+ Init_Port(val, CTX(req->port));
+ }
+ break;
+
+ case SYM_WINDOW:
+ case SYM_GOB:
+ if (IS_EVENT_MODEL(value, EVM_GUI)) {
+ if (VAL_EVENT_SER(value)) {
+ SET_GOB(val, cast(REBGOB*, VAL_EVENT_SER(value)));
+ break;
+ }
+ }
+ return FALSE;
+
+ case SYM_OFFSET:
+ if (VAL_EVENT_TYPE(value) == EVT_KEY || VAL_EVENT_TYPE(value) == EVT_KEY_UP)
+ goto is_blank;
+ SET_PAIR(val, VAL_EVENT_X(value), VAL_EVENT_Y(value));
+ break;
+
+ case SYM_KEY:
+ if (VAL_EVENT_TYPE(value) != EVT_KEY && VAL_EVENT_TYPE(value) != EVT_KEY_UP)
+ goto is_blank;
+ n = VAL_EVENT_DATA(value); // key-words in top 16, chars in lower 16
+ if (n & 0xffff0000) {
+ arg = Get_System(SYS_VIEW, VIEW_EVENT_KEYS);
+ n = (n >> 16) - 1;
+ if (IS_BLOCK(arg) && n < cast(REBINT, VAL_LEN_HEAD(arg))) {
+ Derelativize(
+ val,
+ VAL_ARRAY_AT_HEAD(arg, n),
+ VAL_SPECIFIER(arg)
+ );
+ break;
+ }
+ return FALSE;
+ }
+ Init_Char(val, n);
+ break;
+
+ case SYM_FLAGS:
+ if (
+ VAL_EVENT_FLAGS(value)
+ & (1<select)) {
- if (pvs->setval == 0 || NOT_END(pvs->path+1)) {
- if (!Get_Event_Var(pvs->value, VAL_WORD_CANON(pvs->select), pvs->store)) return PE_BAD_SELECT;
- return PE_USE;
- } else {
- if (!Set_Event_Var(pvs->value, pvs->select, pvs->setval)) return PE_BAD_SET;
- return PE_OK;
- }
- }
- return PE_BAD_SELECT;
+ if (IS_WORD(pvs->picker)) {
+ if (!pvs->opt_setval || NOT_END(pvs->item + 1)) {
+ if (!Get_Event_Var(
+ KNOWN(pvs->value), VAL_WORD_CANON(pvs->picker), pvs->store
+ )) {
+ fail (Error_Bad_Path_Set(pvs));
+ }
+
+ return PE_USE_STORE;
+ }
+ else {
+ if (!Set_Event_Var(
+ KNOWN(pvs->value), pvs->picker, pvs->opt_setval
+ )) {
+ fail (Error_Bad_Path_Set(pvs));
+ }
+
+ return PE_OK;
+ }
+ }
+
+ fail (Error_Bad_Path_Select(pvs));
}
-/***********************************************************************
-**
-*/ REBTYPE(Event)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+REBTYPE(Event)
{
- REBVAL *value;
- REBVAL *arg;
-
- value = D_ARG(1);
- arg = D_ARG(2);
-
- if (action == A_MAKE) {
- // Clone an existing event?
- if (IS_EVENT(value)) return R_ARG1;
- else if (IS_DATATYPE(value)) {
- if (IS_EVENT(arg)) return R_ARG2;
- //Trap_Make(REB_EVENT, value);
- VAL_SET(D_RET, REB_EVENT);
- CLEARS(&(D_RET->data.event));
- }
- else
-is_arg_error:
- Trap_Types(RE_EXPECT_VAL, REB_EVENT, VAL_TYPE(arg));
-
- // Initialize GOB from block:
- if (IS_BLOCK(arg)) Set_Event_Vars(D_RET, VAL_BLK_DATA(arg));
- else goto is_arg_error;
- }
- else Trap_Action(REB_EVENT, action);
-
- return R_RET;
+ UNUSED(frame_);
+
+ fail (Error_Illegal_Action(REB_EVENT, action));
}
-#ifdef ndef
-// case A_PATH:
- if (IS_WORD(arg)) {
- switch (VAL_WORD_CANON(arg)) {
- case SYM_TYPE: index = EF_TYPE; break;
- case SYM_PORT: index = EF_PORT; break;
- case SYM_KEY: index = EF_KEY; break;
- case SYM_OFFSET: index = EF_OFFSET; break;
- case SYM_MODE: index = EF_MODE; break;
- case SYM_TIME: index = EF_TIME; break;
-//!!! return these as options flags, not refinements.
-// case SYM_SHIFT: index = EF_SHIFT; break;
-// case SYM_CONTROL: index = EF_CONTROL; break;
-// case SYM_DOUBLE_CLICK: index = EF_DCLICK; break;
- default: Trap1(RE_INVALID_PATH, arg);
- }
- goto pick_it;
- }
- else if (!IS_INTEGER(arg))
- Trap1(RE_INVALID_PATH, arg);
- // fall thru
-
-
- case A_PICK:
- index = num = Get_Num_Arg(arg);
- if (num > 0) index--;
- if (num == 0 || index < 0 || index > EF_DCLICK) {
- if (action == A_POKE) Trap_Range(arg);
- goto is_none;
- }
-pick_it:
- switch(index) {
- case EF_TYPE:
- if (VAL_EVENT_TYPE(value) == 0) goto is_none;
- arg = Get_System(SYS_VIEW, VIEW_EVENT_TYPES);
- if (IS_BLOCK(arg) && VAL_TAIL(arg) >= EVT_MAX) {
- *D_RET = *VAL_BLK_SKIP(arg, VAL_EVENT_TYPE(value));
- return R_RET;
- }
- return R_NONE;
-
- case EF_PORT:
- // Most events are for the GUI:
- if (GET_FLAG(VAL_EVENT_FLAGS(value), EVF_NO_REQ))
- *D_RET = *Get_System(SYS_VIEW, VIEW_EVENT_PORT);
- else {
- req = VAL_EVENT_REQ(value);
- if (!req || !req->port) goto is_none;
- SET_PORT(D_RET, (REBSER*)(req->port));
- }
- return R_RET;
-
- case EF_KEY:
- if (VAL_EVENT_TYPE(value) != EVT_KEY) goto is_none;
- if (VAL_EVENT_FLAGS(value)) { // !!!!!!!!!!!!! needs mask
- VAL_SET(D_RET, REB_CHAR);
- VAL_CHAR(D_RET) = VAL_EVENT_KEY(value) & 0xff;
- } else
- Init_Word(D_RET, VAL_EVENT_XY(value));
- return R_RET;
-
- case EF_OFFSET:
- VAL_SET(D_RET, REB_PAIR);
- VAL_PAIR_X(D_RET) = VAL_EVENT_X(value);
- VAL_PAIR_Y(D_RET) = VAL_EVENT_Y(value);
- return R_RET;
-
- case EF_TIME:
- VAL_SET(D_RET, REB_INTEGER);
-//!! VAL_INT64(D_RET) = VAL_EVENT_TIME(value);
- return R_RET;
-
- case EF_SHIFT:
- VAL_SET(D_RET, REB_LOGIC);
- VAL_LOGIC(D_RET) = GET_FLAG(VAL_EVENT_FLAGS(value), EVF_SHIFT) != 0;
- return R_RET;
-
- case EF_CONTROL:
- VAL_SET(D_RET, REB_LOGIC);
- VAL_LOGIC(D_RET) = GET_FLAG(VAL_EVENT_FLAGS(value), EVF_CONTROL) != 0;
- return R_RET;
-
- case EF_DCLICK:
- VAL_SET(D_RET, REB_LOGIC);
- VAL_LOGIC(D_RET) = GET_FLAG(VAL_EVENT_FLAGS(value), EVF_DOUBLE) != 0;
- return R_RET;
-
-/* case EF_FACE:
- {
- REBWIN *wp;
- if (!IS_BLOCK(BLK_HEAD(Windows) + VAL_EVENT_WIN(value))) return R_RET None_Value;
- wp = (REBWIN *)VAL_BLK(BLK_HEAD(Windows) + VAL_EVENT_WIN(value));
- *D_RET = wp->masterFace;
- return R_RET;
- }
-*/
- }
- break;
-
-// These are used to map symbols to event field cases:
-enum rebol_event_fields {
- EF_TYPE,
- EF_KEY,
- EF_OFFSET,
- EF_TIME,
- EF_SHIFT, // Keep these? !!!
- EF_CONTROL,
- EF_DCLICK,
- EF_PORT,
- EF_MODE,
-};
-
-#endif
-
-
-/***********************************************************************
-**
-*/ void Mold_Event(REBVAL *value, REB_MOLD *mold)
-/*
-***********************************************************************/
+
+//
+// Mold_Event: C
+//
+void Mold_Event(const REBVAL *value, REB_MOLD *mold)
{
- REBVAL val;
- REBCNT field;
- REBCNT fields[] = {
- SYM_TYPE, SYM_PORT, SYM_GOB, SYM_OFFSET, SYM_KEY,
- SYM_FLAGS, SYM_CODE, SYM_DATA, 0
- };
-
- Pre_Mold(value, mold);
- Append_Byte(mold->series, '[');
- mold->indent++;
-
- for (field = 0; fields[field]; field++) {
- Get_Event_Var(value, fields[field], &val);
- if (!IS_NONE(&val)) {
- New_Indented_Line(mold);
- Append_UTF8(mold->series, Get_Sym_Name(fields[field]), -1);
- Append_Bytes(mold->series, ": ");
- if (IS_WORD(&val)) Append_Byte(mold->series, '\'');
- Mold_Value(mold, &val, TRUE);
- }
- }
-
- mold->indent--;
- New_Indented_Line(mold);
- Append_Byte(mold->series, ']');
-
- End_Mold(mold);
+ REBCNT field;
+ REBSYM fields[] = {
+ SYM_TYPE, SYM_PORT, SYM_GOB, SYM_OFFSET, SYM_KEY,
+ SYM_FLAGS, SYM_CODE, SYM_DATA, SYM_0
+ };
+
+ Pre_Mold(value, mold);
+ Append_Codepoint_Raw(mold->series, '[');
+ mold->indent++;
+
+ DECLARE_LOCAL (val);
+
+ for (field = 0; fields[field] != SYM_0; field++) {
+ Get_Event_Var(value, Canon(fields[field]), val);
+ if (!IS_BLANK(val)) {
+ New_Indented_Line(mold);
+
+ REBSTR *canon = Canon(fields[field]);
+ Append_UTF8_May_Fail(
+ mold->series, STR_HEAD(canon), STR_NUM_BYTES(canon)
+ );
+ Append_Unencoded(mold->series, ": ");
+ if (IS_WORD(val))
+ Append_Codepoint_Raw(mold->series, '\'');
+ Mold_Value(mold, val, TRUE);
+ }
+ }
+
+ mold->indent--;
+ New_Indented_Line(mold);
+ Append_Codepoint_Raw(mold->series, ']');
+
+ End_Mold(mold);
}
diff --git a/src/core/t-function.c b/src/core/t-function.c
old mode 100644
new mode 100755
index dffa3abd65..7ff6be106c
--- a/src/core/t-function.c
+++ b/src/core/t-function.c
@@ -1,167 +1,399 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-function.c
-** Summary: function related datatypes
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-function.c
+// Summary: "function related datatypes"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-static REBOOL Same_Func(REBVAL *val, REBVAL *arg)
+static REBOOL Same_Func(const RELVAL *val, const RELVAL *arg)
{
- if (VAL_TYPE(val) == VAL_TYPE(arg) &&
- VAL_FUNC_SPEC(val) == VAL_FUNC_SPEC(arg) &&
- VAL_FUNC_ARGS(val) == VAL_FUNC_ARGS(arg) &&
- VAL_FUNC_CODE(val) == VAL_FUNC_CODE(arg)) return TRUE;
- return FALSE;
+ assert(IS_FUNCTION(val) && IS_FUNCTION(arg));
+
+ if (VAL_FUNC_PARAMLIST(val) == VAL_FUNC_PARAMLIST(arg)) {
+ assert(VAL_FUNC_DISPATCHER(val) == VAL_FUNC_DISPATCHER(arg));
+ assert(VAL_FUNC_BODY(val) == VAL_FUNC_BODY(arg));
+
+ // All functions that have the same paramlist are not necessarily the
+ // "same function". For instance, every RETURN shares a common
+ // paramlist, but the binding is different in the REBVAL instances
+ // in order to know where to "exit from".
+
+ return LOGICAL(VAL_BINDING(val) == VAL_BINDING(arg));
+ }
+
+ return FALSE;
+}
+
+
+//
+// CT_Function: C
+//
+REBINT CT_Function(const RELVAL *a, const RELVAL *b, REBINT mode)
+{
+ if (mode >= 0) return Same_Func(a, b) ? 1 : 0;
+ return -1;
+}
+
+
+//
+// MAKE_Function: C
+//
+// For REB_FUNCTION and "make spec", there is a function spec block and then
+// a block of Rebol code implementing that function. In that case we expect
+// that `def` should be:
+//
+// [[spec] [body]]
+//
+// With REB_COMMAND, the code is implemented via a C DLL, under a system of
+// APIs that pre-date Rebol's open sourcing and hence Ren/C:
+//
+// [[spec] extension command-num]
+//
+// See notes in Make_Command() regarding that mechanism and meaning.
+//
+void MAKE_Function(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ assert(kind == REB_FUNCTION);
+ UNUSED(kind);
+
+ if (
+ !IS_BLOCK(arg)
+ || VAL_LEN_AT(arg) != 2
+ || !IS_BLOCK(VAL_ARRAY_AT(arg))
+ || !IS_BLOCK(VAL_ARRAY_AT(arg) + 1)
+ ){
+ fail (Error_Bad_Make(REB_FUNCTION, arg));
+ }
+
+ DECLARE_LOCAL (spec);
+ Derelativize(spec, VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg));
+
+ DECLARE_LOCAL (body);
+ Derelativize(body, VAL_ARRAY_AT(arg) + 1, VAL_SPECIFIER(arg));
+
+ // Spec-constructed functions do *not* have definitional returns
+ // added automatically. They are part of the generators. So the
+ // behavior comes--as with any other generator--from the projected
+ // code (though round-tripping it via text is not possible in
+ // general in any case due to loss of bindings.)
+ //
+ REBFUN *fun = Make_Interpreted_Function_May_Fail(
+ spec, body, MKF_ANY_VALUE
+ );
+
+ Move_Value(out, FUNC_VALUE(fun));
}
-/***********************************************************************
-**
-*/ REBINT CT_Function(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// TO_Function: C
+//
+// `to function! 'x` might be an interesting optimized 0-arity function
+// generator, which made a function that returned that value every time you
+// called it. Generalized alternative would be like `does [quote x]`,
+// which would be slower to generate the function and slower to run.
+//
+void TO_Function(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- if (mode >= 0) return Same_Func(a, b);
- return -1;
+ assert(kind == REB_FUNCTION);
+ UNUSED(kind);
+
+ UNUSED(out);
+
+ fail (arg);
}
-/***********************************************************************
-**
-*/ REBSER *As_Typesets(REBSER *types)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+REBTYPE(Function)
{
- REBVAL *val;
+ REBVAL *value = D_ARG(1);
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+
+ switch (action) {
+ case SYM_COPY: {
+ INCLUDE_PARAMS_OF_COPY;
+
+ UNUSED(PAR(value));
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(types)) {
+ UNUSED(ARG(kinds));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(deep)) {
+ // !!! always "deep", allow it?
+ }
+
+ // !!! The R3-Alpha theory was that functions could modify "their
+ // bodies" while running, effectively accruing state that one might
+ // want to snapshot. See notes on Clonify_Function about why that
+ // idea is a bad one.
+ //
+ // Instead we create another handle which executes the same function
+ // code, yet has a distinct identity. This means it would not be
+ // HIJACK'd if the function that it was copied from was.
+
+ REBFUN *underlying = FUNC_UNDERLYING(VAL_FUNC(value));
+
+ REBARR *proxy_paramlist = Copy_Array_Deep_Managed(
+ VAL_FUNC_PARAMLIST(value),
+ SPECIFIED // !!! Note: not actually "deep", just typesets
+ );
+ ARR_HEAD(proxy_paramlist)->payload.function.paramlist
+ = proxy_paramlist;
+ SER(proxy_paramlist)->link.meta = VAL_FUNC_META(value);
+ SET_SER_FLAG(proxy_paramlist, ARRAY_FLAG_PARAMLIST);
- types = Copy_Block(types, 1);
- for (val = BLK_HEAD(types); NOT_END(val); val++) {
- SET_TYPE(val, REB_TYPESET);
- }
- return types;
+ // If the function had code, then that code will be bound relative
+ // to the original paramlist that's getting hijacked. So when the
+ // proxy is called, we want the frame pushed to be relative to
+ // whatever underlied the function...even if it was foundational
+ // so `underlying = VAL_FUNC(value)`
+
+ REBFUN *proxy = Make_Function(
+ proxy_paramlist,
+ FUNC_DISPATCHER(VAL_FUNC(value)),
+ underlying,
+ NULL // not changing the specialization
+ );
+
+ // A new body_holder was created inside Make_Function().
+ //
+ *FUNC_BODY(proxy) = *VAL_FUNC_BODY(value);
+
+ Move_Value(D_OUT, FUNC_VALUE(proxy));
+ D_OUT->extra.binding = VAL_BINDING(value);
+ return R_OUT; }
+
+ case SYM_REFLECT: {
+ REBSYM sym = VAL_WORD_SYM(arg);
+
+ switch (sym) {
+ case SYM_ADDR:
+ if (IS_FUNCTION_RIN(value)) {
+ //
+ // The CFUNC is fabricated by the FFI if it's a callback, or
+ // just the wrapped DLL function if it's an ordinary routine
+ //
+ Init_Integer(
+ D_OUT, cast(REBUPT, RIN_CFUNC(VAL_FUNC_ROUTINE(value)))
+ );
+ return R_OUT;
+ }
+ break;
+
+ case SYM_WORDS:
+ Init_Block(D_OUT, List_Func_Words(value, FALSE)); // no locals
+ return R_OUT;
+
+ case SYM_BODY:
+ //
+ // A Hijacker may or may not need to splice itself in with a
+ // dispatcher. So if it does, bypass it to get to the real
+ // function implementation.
+ //
+ while (IS_FUNCTION_HIJACKER(value))
+ value = KNOWN(VAL_FUNC_BODY(value));
+
+ if (IS_FUNCTION_INTERPRETED(value)) {
+ //
+ // BODY-OF is an example of user-facing code that needs to be
+ // complicit in the "lie" about the effective bodies of the
+ // functions made by the optimized generators FUNC and PROC.
+ //
+ // Note that since the function body contains relative arrays
+ // and words, there needs to be some frame to specify them
+ // before a specific REBVAL can be made. Usually that's the
+ // frame of the running instance of the function...but because
+ // we're reflecting data out of it, we have to either unbind
+ // them or make up a frame. Making up a frame that acts like
+ // it's off the stack and the variables are dead is easiest
+ // for now...but long term perhaps unbinding them is better,
+ // though this is "more informative". See #2221.
+
+ REBOOL is_fake;
+ REBARR *body = Get_Maybe_Fake_Func_Body(&is_fake, value);
+ Init_Block(
+ D_OUT,
+ Copy_Array_Deep_Managed(
+ body,
+ AS_SPECIFIER(
+ Make_Expired_Frame_Ctx_Managed(VAL_FUNC(value))
+ )
+ )
+ );
+
+ if (is_fake) Free_Array(body); // was shallow copy
+ return R_OUT;
+ }
+
+ // For other function types, leak internal guts and hope for
+ // the best, temporarily.
+ //
+ if (IS_BLOCK(VAL_FUNC_BODY(value))) {
+ Init_Any_Array(
+ D_OUT,
+ REB_BLOCK,
+ Copy_Array_Deep_Managed(
+ VAL_ARRAY(VAL_FUNC_BODY(value)), SPECIFIED
+ )
+ );
+ }
+ else {
+ Init_Blank(D_OUT);
+ }
+ return R_OUT;
+
+ case SYM_TYPES: {
+ REBARR *copy = Make_Array(VAL_FUNC_NUM_PARAMS(value));
+ REBVAL *param;
+ REBVAL *typeset;
+
+ // The typesets have a symbol in them for the parameters, and
+ // ordinary typesets aren't supposed to have it--that's a
+ // special feature for object keys and paramlists! So clear
+ // that symbol out before giving it back.
+ //
+ param = VAL_FUNC_PARAMS_HEAD(value);
+ typeset = SINK(ARR_HEAD(copy));
+ for (; NOT_END(param); param++, typeset++) {
+ assert(VAL_PARAM_SPELLING(param) != NULL);
+ Move_Value(typeset, param);
+ INIT_TYPESET_NAME(typeset, NULL);
+ }
+ TERM_ARRAY_LEN(copy, VAL_FUNC_NUM_PARAMS(value));
+ assert(IS_END(typeset));
+
+ Init_Block(D_OUT, copy);
+ return R_OUT;
+ }
+
+ default:
+ fail (Error_Cannot_Reflect(VAL_TYPE(value), arg));
+ }
+ break; }
+
+ default:
+ break;
+ }
+
+ fail (Error_Illegal_Action(VAL_TYPE(value), action));
}
-/***********************************************************************
-**
-*/ REBFLG MT_Function(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+//
+// func-class-of: native [
+//
+// {Internal-use-only for implementing NATIVE?, ACTION?, CALLBACK?, etc.}
+//
+// func [function!]
+// ]
+//
+REBNATIVE(func_class_of)
+//
+// !!! The concept of the VAL_FUNC_CLASS was killed, because functions get
+// their classification by way of their dispatch pointers. Generally
+// speaking, functions should be a "black box" to user code, and it's only
+// at the "meta" level that a function would choose to expose whether it
+// is something like a specialization or an adaptation...but that would be
+// purely documentary, and could lie.
{
- return Make_Function(type, out, data);
+ INCLUDE_PARAMS_OF_FUNC_CLASS_OF;
+
+ REBVAL *value = ARG(func);
+ REBCNT n;
+
+ if (IS_FUNCTION_INTERPRETED(value))
+ n = 2;
+ else if (IS_FUNCTION_ACTION(value))
+ n = 3;
+ else if (IS_FUNCTION_RIN(value)) {
+ if (NOT(RIN_IS_CALLBACK(VAL_FUNC_ROUTINE(value))))
+ n = 5;
+ else
+ n = 6;
+ }
+ else if (IS_FUNCTION_SPECIALIZER(value))
+ n = 7;
+ else {
+ // !!! A shaky guess, but assume native if none of the above.
+ // (COMMAND! was once 4)
+ n = 1;
+ }
+
+ Init_Integer(D_OUT, n);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBTYPE(Function)
-/*
-***********************************************************************/
+//
+// PD_Function: C
+//
+REBINT PD_Function(REBPVS *pvs)
{
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBCNT type = VAL_TYPE(value);
- REBCNT n;
-
- switch (action) {
-
- case A_MAKE:
- case A_TO:
- // make function! [[args] [body]]
- if (IS_DATATYPE(value)) {
- n = VAL_DATATYPE(value);
- if (Make_Function(n, value, arg)) break;
- Trap_Make(n, arg);
- }
-
- // make :func []
- // make :func [[args]]
- // make :func [* [body]]
- if (ANY_FUNC(value)) {
- if (!IS_BLOCK(arg)) goto bad_arg;
- if (!ANY_FUNC(value)) goto bad_arg;
- if (!Copy_Function(value, arg)) goto bad_arg;
- break;
- }
- if (!IS_NONE(arg)) goto bad_arg;
- // fall thru...
- case A_COPY:
- Copy_Function(value, 0);
- break;
-
- case A_REFLECT:
- n = What_Reflector(arg); // zero on error
- switch (n) {
- case OF_WORDS:
- //if (type == REB_CLOSURE)
- Set_Block(value, List_Func_Words(value));
- //else
- // Set_Block(value, List_Func_Words(value));
- break;
- case OF_BODY:
-of_type:
- switch (type) {
- case REB_FUNCTION:
- case REB_CLOSURE:
- Set_Block(value, Clone_Block(VAL_FUNC_BODY(value)));
- Unbind_Block(VAL_BLK(value), TRUE);
- break;
- case REB_NATIVE:
- case REB_COMMAND:
- case REB_ACTION:
- SET_NONE(value);
- break;
- case REB_OP:
- type = VAL_GET_EXT(value); // internal datatype
- goto of_type;
- }
- break;
- case OF_SPEC:
- Set_Block(value, Clone_Block(VAL_FUNC_SPEC(value)));
- Unbind_Block(VAL_BLK(value), TRUE);
- break;
- case OF_TYPES:
- Set_Block(value, As_Typesets(VAL_FUNC_ARGS(value)));
- break;
- case OF_TITLE:
- arg = BLK_HEAD(VAL_FUNC_SPEC(value));
- for (; NOT_END(arg) && !IS_STRING(arg) && !IS_WORD(arg); arg++);
- if (!IS_STRING(arg)) return R_NONE;
- Set_String(value, Copy_Series(VAL_SERIES(arg)));
- break;
- default:
- bad_arg:
- Trap_Reflect(type, arg);
- }
- break;
-
- default: Trap_Action(type, action);
- }
-
- DS_RET_VALUE(value);
- return R_RET;
+ if (IS_BLANK(pvs->picker)) {
+ //
+ // Leave the function value as-is, and continue processing. This
+ // enables things like `append/(all [foo 'dup])/only`...
+ //
+ return PE_OK;
+ }
+
+ // The first evaluation of a GROUP! and GET-WORD! are processed by the
+ // general path mechanic before reaching this dispatch. So if it's not
+ // a word or one of those that evaluated to a word raise an error.
+ //
+ if (!IS_WORD(pvs->picker))
+ fail (Error_Bad_Refine_Raw(pvs->picker));
+
+ // We could generate a "refined" function variant at each step:
+ //
+ // `append/dup/only` => `ad: :append/dup | ado: :ad/only | ado`
+ //
+ // Generating these intermediates would be costly. They'd have updated
+ // paramlists and tax the garbage collector. So path dispatch is
+ // understood to push the canonized word to the data stack in the
+ // function case.
+ //
+ DS_PUSH(pvs->picker);
+
+ // Go ahead and canonize the word symbol so we don't have to do it each
+ // time in order to get a case-insensitive compare. (Note that canons can
+ // be GC'd, but will not be so long as an instance is on the stack.)
+ //
+ Canonize_Any_Word(DS_TOP);
+
+ // Leave the function value as is in pvs->value
+ //
+ return PE_OK;
}
diff --git a/src/core/t-gob.c b/src/core/t-gob.c
index 9df6cc1c4b..a7becaba20 100644
--- a/src/core/t-gob.c
+++ b/src/core/t-gob.c
@@ -1,912 +1,1202 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-gob.c
-** Summary: graphical object datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-gob.c
+// Summary: "graphical object datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-void Trap_Temp(void) {Trap0(501);} //!!! temp trap function
-
-const REBCNT Gob_Flag_Words[] = {
- SYM_RESIZE, GOBF_RESIZE,
- SYM_NO_TITLE, GOBF_NO_TITLE,
- SYM_NO_BORDER, GOBF_NO_BORDER,
- SYM_DROPABLE, GOBF_DROPABLE,
- SYM_TRANSPARENT, GOBF_TRANSPARENT,
- SYM_POPUP, GOBF_POPUP,
- SYM_MODAL, GOBF_MODAL,
- SYM_ON_TOP, GOBF_ON_TOP,
- SYM_HIDDEN, GOBF_HIDDEN,
- 0, 0
+#include "mem-pools.h" // low-level memory pool access
+
+const struct {
+ REBSYM sym;
+ REBUPT flags;
+} Gob_Flag_Words[] = {
+ {SYM_RESIZE, GOBF_RESIZE},
+ {SYM_NO_TITLE, GOBF_NO_TITLE},
+ {SYM_NO_BORDER, GOBF_NO_BORDER},
+ {SYM_DROPABLE, GOBF_DROPABLE},
+ {SYM_TRANSPARENT, GOBF_TRANSPARENT},
+ {SYM_POPUP, GOBF_POPUP},
+ {SYM_MODAL, GOBF_MODAL},
+ {SYM_ON_TOP, GOBF_ON_TOP},
+ {SYM_HIDDEN, GOBF_HIDDEN},
+ {SYM_ACTIVE, GOBF_ACTIVE},
+ {SYM_MINIMIZE, GOBF_MINIMIZE},
+ {SYM_MAXIMIZE, GOBF_MAXIMIZE},
+ {SYM_RESTORE, GOBF_RESTORE},
+ {SYM_FULLSCREEN, GOBF_FULLSCREEN},
+ {SYM_0, 0}
};
-/***********************************************************************
-**
-*/ REBINT CT_Gob(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Gob: C
+//
+REBINT CT_Gob(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- if (mode >= 0)
- return VAL_GOB(a) == VAL_GOB(b) && VAL_GOB_INDEX(a) == VAL_GOB_INDEX(b);
- return -1;
+ if (mode >= 0)
+ return VAL_GOB(a) == VAL_GOB(b) && VAL_GOB_INDEX(a) == VAL_GOB_INDEX(b);
+ return -1;
}
-/***********************************************************************
-**
-*/ REBGOB *Make_Gob(void)
-/*
-** Allocate a new GOB.
-**
-***********************************************************************/
+//
+// Make_Gob: C
+//
+// Allocate a new GOB.
+//
+REBGOB *Make_Gob(void)
{
- REBGOB *gob = Make_Node(GOB_POOL);
- CLEAR(gob, sizeof(REBGOB));
- GOB_W(gob) = 100;
- GOB_H(gob) = 100;
- USE_GOB(gob);
- if ((GC_Ballast -= Mem_Pools[GOB_POOL].wide) <= 0) SET_SIGNAL(SIG_RECYCLE);
- return gob;
+ REBGOB *gob = cast(REBGOB*, Make_Node(GOB_POOL));
+ CLEAR(gob, sizeof(REBGOB));
+ GOB_W(gob) = 100;
+ GOB_H(gob) = 100;
+ GOB_ALPHA(gob) = 255;
+ gob->header.bits = NODE_FLAG_NODE;
+ if ((GC_Ballast -= Mem_Pools[GOB_POOL].wide) <= 0) SET_SIGNAL(SIG_RECYCLE);
+ return gob;
}
-/***********************************************************************
-**
-*/ REBINT Cmp_Gob(REBVAL *g1, REBVAL *g2)
-/*
-***********************************************************************/
+//
+// Cmp_Gob: C
+//
+REBINT Cmp_Gob(const RELVAL *g1, const RELVAL *g2)
{
- REBINT n;
+ REBINT n;
- n = VAL_GOB(g2) - VAL_GOB(g1);
- if (n != 0) return n;
- n = VAL_GOB_INDEX(g2) - VAL_GOB_INDEX(g1);
- if (n != 0) return n;
- return 0;
+ n = VAL_GOB(g2) - VAL_GOB(g1);
+ if (n != 0) return n;
+ n = VAL_GOB_INDEX(g2) - VAL_GOB_INDEX(g1);
+ if (n != 0) return n;
+ return 0;
}
-/***********************************************************************
-**
-*/ static REBFLG Set_Pair(REBXYF *pair, REBVAL *val)
-/*
-***********************************************************************/
+//
+// Set_Pair: C
+//
+static REBOOL Set_Pair(REBXYF *pair, const REBVAL *val)
{
- if (IS_PAIR(val)) {
- pair->x = VAL_PAIR_X(val);
- pair->y = VAL_PAIR_Y(val);
- }
- else if (IS_INTEGER(val)) {
- pair->x = pair->y = (REBD32)VAL_INT64(val);
- }
- else if (IS_DECIMAL(val)) {
- pair->x = pair->y = (REBD32)VAL_DECIMAL(val);
- }
- else
- return FALSE;
-
- return TRUE;
+ if (IS_PAIR(val)) {
+ pair->x = VAL_PAIR_X(val);
+ pair->y = VAL_PAIR_Y(val);
+ }
+ else if (IS_INTEGER(val)) {
+ pair->x = pair->y = (REBD32)VAL_INT64(val);
+ }
+ else if (IS_DECIMAL(val)) {
+ pair->x = pair->y = (REBD32)VAL_DECIMAL(val);
+ }
+ else
+ return FALSE;
+
+ return TRUE;
}
-/***********************************************************************
-**
-*/ static REBCNT Find_Gob(REBGOB *gob, REBGOB *target)
-/*
-** Find a target GOB within the pane of another gob.
-** Return the index, or a -1 if not found.
-**
-***********************************************************************/
+//
+// Find_Gob: C
+//
+// Find a target GOB within the pane of another gob.
+// Return the index, or a -1 if not found.
+//
+static REBCNT Find_Gob(REBGOB *gob, REBGOB *target)
{
- REBCNT len;
- REBCNT n;
- REBGOB **ptr;
-
- if (GOB_PANE(gob)) {
- len = GOB_TAIL(gob);
- ptr = GOB_HEAD(gob);
- for (n = 0; n < len; n++, ptr++)
- if (*ptr == target) return n;
- }
- return NOT_FOUND;
+ REBCNT len;
+ REBCNT n;
+ REBGOB **ptr;
+
+ if (GOB_PANE(gob)) {
+ len = GOB_LEN(gob);
+ ptr = GOB_HEAD(gob);
+ for (n = 0; n < len; n++, ptr++)
+ if (*ptr == target) return n;
+ }
+ return NOT_FOUND;
}
-/***********************************************************************
-**
-*/ static void Detach_Gob(REBGOB *gob)
-/*
-** Remove a gob value from its parent.
-** Done normally in advance of inserting gobs into new parent.
-**
-***********************************************************************/
+//
+// Detach_Gob: C
+//
+// Remove a gob value from its parent.
+// Done normally in advance of inserting gobs into new parent.
+//
+static void Detach_Gob(REBGOB *gob)
{
- REBGOB *par;
- REBINT i;
-
- par = GOB_PARENT(gob);
- if (par && GOB_PANE(par) && (i = Find_Gob(par, gob)) != NOT_FOUND) {
- Remove_Series(GOB_PANE(par), i, 1);
- }
- GOB_PARENT(gob) = 0;
+ REBGOB *par;
+ REBCNT i;
+
+ par = GOB_PARENT(gob);
+ if (par && GOB_PANE(par) && (i = Find_Gob(par, gob)) != NOT_FOUND) {
+ Remove_Series(GOB_PANE(par), i, 1);
+ }
+ GOB_PARENT(gob) = 0;
}
-/***********************************************************************
-**
-*/ static void Insert_Gobs(REBGOB *gob, REBVAL *arg, REBCNT index, REBCNT len, REBFLG change)
-/*
-** Insert one or more gobs into a pane at the given index.
-** If index >= tail, an append occurs. Each gob has its parent
-** gob field set. (Call Detach_Gobs() before inserting.)
-**
-***********************************************************************/
+//
+// Insert_Gobs: C
+//
+// Insert one or more gobs into a pane at the given index.
+// If index >= tail, an append occurs. Each gob has its parent
+// gob field set. (Call Detach_Gobs() before inserting.)
+//
+static void Insert_Gobs(
+ REBGOB *gob,
+ const RELVAL *arg,
+ REBCNT index,
+ REBCNT len,
+ REBOOL change
+) {
+ REBGOB **ptr;
+ REBCNT n, count;
+ const RELVAL *val;
+ const RELVAL *sarg;
+ REBINT i;
+
+ // Verify they are gobs:
+ sarg = arg;
+ for (n = count = 0; n < len; n++, val++) {
+ val = arg++;
+ if (IS_WORD(val)) {
+ //
+ // For the moment, assume this GOB-or-WORD! containing block
+ // only contains non-relative values.
+ //
+ val = Get_Opt_Var_May_Fail(val, SPECIFIED);
+ }
+ if (IS_GOB(val)) {
+ count++;
+ if (GOB_PARENT(VAL_GOB(val))) {
+ // Check if inserting into same parent:
+ i = -1;
+ if (GOB_PARENT(VAL_GOB(val)) == gob) {
+ i = Find_Gob(gob, VAL_GOB(val));
+ if (i > 0 && i == (REBINT)index-1) { // a no-op
+ SET_GOB_STATE(VAL_GOB(val), GOBS_NEW);
+ return;
+ }
+ }
+ Detach_Gob(VAL_GOB(val));
+ if (i >= 0 && (REBINT)index > i) index--;
+ }
+ }
+ else
+ fail (Error_Invalid_Arg_Core(val, SPECIFIED));
+ }
+ arg = sarg;
+
+ // Create or expand the pane series:
+ if (!GOB_PANE(gob)) {
+ GOB_PANE(gob) = Make_Series(count + 1, sizeof(REBGOB*));
+ SET_GOB_LEN(gob, count);
+ index = 0;
+
+ // !!! A GOB_PANE could theoretically be MKS_UNTRACKED and manually
+ // memory managed, if that made sense. Does it?
+
+ MANAGE_SERIES(GOB_PANE(gob));
+ }
+ else {
+ if (change) {
+ if (index + count > GOB_LEN(gob)) {
+ EXPAND_SERIES_TAIL(GOB_PANE(gob), index + count - GOB_LEN(gob));
+ }
+ } else {
+ Expand_Series(GOB_PANE(gob), index, count);
+ if (index >= GOB_LEN(gob)) index = GOB_LEN(gob)-1;
+ }
+ }
+
+ ptr = GOB_AT(gob, index);
+ for (n = 0; n < len; n++) {
+ val = arg++;
+ if (IS_WORD(val)) {
+ //
+ // Again, assume no relative values
+ //
+ val = Get_Opt_Var_May_Fail(val, SPECIFIED);
+ }
+ if (IS_GOB(val)) {
+ if (GOB_PARENT(VAL_GOB(val)) != NULL)
+ fail ("GOB! not expected to have parent");
+ *ptr++ = VAL_GOB(val);
+ GOB_PARENT(VAL_GOB(val)) = gob;
+ SET_GOB_STATE(VAL_GOB(val), GOBS_NEW);
+ }
+ }
+}
+
+
+//
+// Remove_Gobs: C
+//
+// Remove one or more gobs from a pane at the given index.
+//
+static void Remove_Gobs(REBGOB *gob, REBCNT index, REBCNT len)
+{
+ REBGOB **ptr;
+ REBCNT n;
+
+ ptr = GOB_AT(gob, index);
+ for (n = 0; n < len; n++, ptr++) {
+ GOB_PARENT(*ptr) = 0;
+ }
+
+ Remove_Series(GOB_PANE(gob), index, len);
+}
+
+
+//
+// Pane_To_Array: C
+//
+// Convert pane list of gob pointers to a Rebol array of GOB! REBVALs.
+//
+static REBARR *Pane_To_Array(REBGOB *gob, REBCNT index, REBINT len)
{
- REBGOB **ptr;
- REBCNT n, count;
- REBVAL *val, *sarg;
- REBINT i;
-
- // Verify they are gobs:
- sarg = arg;
- for (n = count = 0; n < len; n++, val++) {
- val = arg++;
- if (IS_WORD(val)) val = Get_Var(val);
- if (IS_GOB(val)) {
- count++;
- if (GOB_PARENT(VAL_GOB(val))) {
- // Check if inserting into same parent:
- i = -1;
- if (GOB_PARENT(VAL_GOB(val)) == gob) {
- i = Find_Gob(gob, VAL_GOB(val));
- if (i > 0 && i == (REBINT)index-1) { // a no-op
- SET_GOB_STATE(VAL_GOB(val), GOBS_NEW);
- return;
- }
- }
- Detach_Gob(VAL_GOB(val));
- if ((REBINT)index > i) index--;
- }
- }
- }
- arg = sarg;
-
- // Create or expand the pane series:
- if (!GOB_PANE(gob)) {
- GOB_PANE(gob) = Make_Series(count, sizeof(REBGOB*), 0);
- LABEL_SERIES(GOB_PANE(gob), "gob pane");
- GOB_TAIL(gob) = count;
- index = 0;
- }
- else {
- if (change) {
- if (index + count > GOB_TAIL(gob)) {
- EXPAND_SERIES_TAIL(GOB_PANE(gob), index + count - GOB_TAIL(gob));
- }
- } else {
- Expand_Series(GOB_PANE(gob), index, count);
- if (index >= GOB_TAIL(gob)) index = GOB_TAIL(gob)-1;
- }
- }
-
- ptr = GOB_SKIP(gob, index);
- for (n = 0; n < len; n++) {
- val = arg++;
- if (IS_WORD(val)) val = Get_Var(val);
- if (IS_GOB(val)) {
- if GOB_PARENT(VAL_GOB(val)) Trap_Temp();
- *ptr++ = VAL_GOB(val);
- GOB_PARENT(VAL_GOB(val)) = gob;
- SET_GOB_STATE(VAL_GOB(val), GOBS_NEW);
- }
- }
+ REBARR *array;
+ REBGOB **gp;
+ REBVAL *val;
+
+ if (len == -1 || (len + index) > GOB_LEN(gob)) len = GOB_LEN(gob) - index;
+ if (len < 0) len = 0;
+
+ array = Make_Array(len);
+ TERM_ARRAY_LEN(array, len);
+ val = SINK(ARR_HEAD(array));
+ gp = GOB_HEAD(gob);
+ for (; len > 0; len--, val++, gp++) {
+ SET_GOB(val, *gp);
+ }
+ assert(IS_END(val));
+
+ return array;
}
-/***********************************************************************
-**
-*/ static void Remove_Gobs(REBGOB *gob, REBCNT index, REBCNT len)
-/*
-** Remove one or more gobs from a pane at the given index.
-**
-***********************************************************************/
+//
+// Gob_Flags_To_Array: C
+//
+static REBARR *Gob_Flags_To_Array(REBGOB *gob)
{
- REBGOB **ptr;
- REBCNT n;
+ REBARR *array = Make_Array(3);
- ptr = GOB_SKIP(gob, index);
- for (n = 0; n < len; n++, ptr++) {
- GOB_PARENT(*ptr) = 0;
- }
+ REBINT i;
+ for (i = 0; Gob_Flag_Words[i].sym != SYM_0; ++i) {
+ if (GET_GOB_FLAG(gob, Gob_Flag_Words[i].flags)) {
+ REBVAL *val = Alloc_Tail_Array(array);
+ Init_Word(val, Canon(Gob_Flag_Words[i].sym));
+ }
+ }
- Remove_Series(GOB_PANE(gob), index, len);
+ return array;
+}
+
+
+//
+// Set_Gob_Flag: C
+//
+static void Set_Gob_Flag(REBGOB *gob, REBSTR *name)
+{
+ REBSYM sym = STR_SYMBOL(name);
+ if (sym == SYM_0) return; // !!! fail?
+
+ REBINT i;
+ for (i = 0; Gob_Flag_Words[i].sym != SYM_0; ++i) {
+ if (SAME_SYM_NONZERO(sym, Gob_Flag_Words[i].sym)) {
+ REBCNT flag = Gob_Flag_Words[i].flags;
+ SET_GOB_FLAG(gob, flag);
+ //handle mutual exclusive states
+ switch (flag) {
+ case GOBF_RESTORE:
+ CLR_GOB_FLAG(gob, GOBF_MINIMIZE);
+ CLR_GOB_FLAG(gob, GOBF_MAXIMIZE);
+ CLR_GOB_FLAG(gob, GOBF_FULLSCREEN);
+ break;
+ case GOBF_MINIMIZE:
+ CLR_GOB_FLAG(gob, GOBF_MAXIMIZE);
+ CLR_GOB_FLAG(gob, GOBF_RESTORE);
+ CLR_GOB_FLAG(gob, GOBF_FULLSCREEN);
+ break;
+ case GOBF_MAXIMIZE:
+ CLR_GOB_FLAG(gob, GOBF_MINIMIZE);
+ CLR_GOB_FLAG(gob, GOBF_RESTORE);
+ CLR_GOB_FLAG(gob, GOBF_FULLSCREEN);
+ break;
+ case GOBF_FULLSCREEN:
+ SET_GOB_FLAG(gob, GOBF_NO_TITLE);
+ SET_GOB_FLAG(gob, GOBF_NO_BORDER);
+ CLR_GOB_FLAG(gob, GOBF_MINIMIZE);
+ CLR_GOB_FLAG(gob, GOBF_RESTORE);
+ CLR_GOB_FLAG(gob, GOBF_MAXIMIZE);
+ }
+ break;
+ }
+ }
+}
+
+
+//
+// Set_GOB_Var: C
+//
+static REBOOL Set_GOB_Var(REBGOB *gob, const REBVAL *word, const REBVAL *val)
+{
+ switch (VAL_WORD_SYM(word)) {
+ case SYM_OFFSET:
+ return Set_Pair(&(gob->offset), val);
+
+ case SYM_SIZE:
+ return Set_Pair(&gob->size, val);
+
+ case SYM_IMAGE:
+ CLR_GOB_OPAQUE(gob);
+ if (IS_IMAGE(val)) {
+ SET_GOB_TYPE(gob, GOBT_IMAGE);
+ GOB_W(gob) = (REBD32)VAL_IMAGE_WIDE(val);
+ GOB_H(gob) = (REBD32)VAL_IMAGE_HIGH(val);
+ GOB_CONTENT(gob) = VAL_SERIES(val);
+// if (!VAL_IMAGE_TRANSP(val)) SET_GOB_OPAQUE(gob);
+ }
+ else if (IS_BLANK(val)) SET_GOB_TYPE(gob, GOBT_NONE);
+ else return FALSE;
+ break;
+
+ case SYM_DRAW:
+ CLR_GOB_OPAQUE(gob);
+ if (IS_BLOCK(val)) {
+ SET_GOB_TYPE(gob, GOBT_DRAW);
+ GOB_CONTENT(gob) = VAL_SERIES(val);
+ }
+ else if (IS_BLANK(val)) SET_GOB_TYPE(gob, GOBT_NONE);
+ else return FALSE;
+ break;
+
+ case SYM_TEXT:
+ CLR_GOB_OPAQUE(gob);
+ if (IS_BLOCK(val)) {
+ SET_GOB_TYPE(gob, GOBT_TEXT);
+ GOB_CONTENT(gob) = VAL_SERIES(val);
+ }
+ else if (IS_STRING(val)) {
+ SET_GOB_TYPE(gob, GOBT_STRING);
+ GOB_CONTENT(gob) = VAL_SERIES(val);
+ }
+ else if (IS_BLANK(val)) SET_GOB_TYPE(gob, GOBT_NONE);
+ else return FALSE;
+ break;
+
+ case SYM_EFFECT:
+ CLR_GOB_OPAQUE(gob);
+ if (IS_BLOCK(val)) {
+ SET_GOB_TYPE(gob, GOBT_EFFECT);
+ GOB_CONTENT(gob) = VAL_SERIES(val);
+ }
+ else if (IS_BLANK(val)) SET_GOB_TYPE(gob, GOBT_NONE);
+ else return FALSE;
+ break;
+
+ case SYM_COLOR:
+ CLR_GOB_OPAQUE(gob);
+ if (IS_TUPLE(val)) {
+ SET_GOB_TYPE(gob, GOBT_COLOR);
+ Set_Pixel_Tuple((REBYTE*)&GOB_CONTENT(gob), val);
+ if (VAL_TUPLE_LEN(val) < 4 || VAL_TUPLE(val)[3] == 0)
+ SET_GOB_OPAQUE(gob);
+ }
+ else if (IS_BLANK(val)) SET_GOB_TYPE(gob, GOBT_NONE);
+ break;
+
+ case SYM_PANE:
+ if (GOB_PANE(gob)) Clear_Series(GOB_PANE(gob));
+ if (IS_BLOCK(val))
+ Insert_Gobs(
+ gob, VAL_ARRAY_AT(val), 0, VAL_ARRAY_LEN_AT(val), FALSE
+ );
+ else if (IS_GOB(val))
+ Insert_Gobs(gob, val, 0, 1, FALSE);
+ else if (IS_BLANK(val))
+ gob->pane = 0;
+ else
+ return FALSE;
+ break;
+
+ case SYM_ALPHA:
+ GOB_ALPHA(gob) = Clip_Int(Int32(val), 0, 255);
+ break;
+
+ case SYM_DATA:
+ SET_GOB_DTYPE(gob, GOBD_NONE);
+ if (IS_OBJECT(val)) {
+ SET_GOB_DTYPE(gob, GOBD_OBJECT);
+ SET_GOB_DATA(gob, SER(CTX_VARLIST(VAL_CONTEXT(val))));
+ }
+ else if (IS_BLOCK(val)) {
+ SET_GOB_DTYPE(gob, GOBD_BLOCK);
+ SET_GOB_DATA(gob, VAL_SERIES(val));
+ }
+ else if (IS_STRING(val)) {
+ SET_GOB_DTYPE(gob, GOBD_STRING);
+ SET_GOB_DATA(gob, VAL_SERIES(val));
+ }
+ else if (IS_BINARY(val)) {
+ SET_GOB_DTYPE(gob, GOBD_BINARY);
+ SET_GOB_DATA(gob, VAL_SERIES(val));
+ }
+ else if (IS_INTEGER(val)) {
+ SET_GOB_DTYPE(gob, GOBD_INTEGER);
+ SET_GOB_DATA(gob, cast(REBSER*, cast(REBIPT, VAL_INT64(val))));
+ }
+ else if (IS_BLANK(val))
+ SET_GOB_TYPE(gob, GOBT_NONE);
+ else return FALSE;
+ break;
+
+ case SYM_FLAGS:
+ if (IS_WORD(val)) Set_Gob_Flag(gob, VAL_WORD_SPELLING(val));
+ else if (IS_BLOCK(val)) {
+ //clear only flags defined by words
+ REBINT i;
+ for (i = 0; Gob_Flag_Words[i].sym != 0; ++i)
+ CLR_GOB_FLAG(gob, Gob_Flag_Words[i].flags);
+
+ RELVAL* item;
+ for (item = VAL_ARRAY_HEAD(val); NOT_END(item); item++)
+ if (IS_WORD(item)) Set_Gob_Flag(gob, VAL_WORD_CANON(item));
+ }
+ break;
+
+ case SYM_OWNER:
+ if (IS_GOB(val))
+ GOB_TMP_OWNER(gob) = VAL_GOB(val);
+ else
+ return FALSE;
+ break;
+
+ default:
+ return FALSE;
+ }
+ return TRUE;
}
-/***********************************************************************
-**
-*/ static REBSER *Pane_To_Block(REBGOB *gob, REBCNT index, REBINT len)
-/*
-** Convert pane list of gob pointers to a block of GOB!s.
-**
-***********************************************************************/
+//
+// Get_GOB_Var: C
+//
+static REBOOL Get_GOB_Var(REBGOB *gob, const REBVAL *word, REBVAL *val)
{
- REBSER *ser;
- REBGOB **gp;
- REBVAL *val;
-
- if (len == -1 || (len + index) > GOB_TAIL(gob)) len = GOB_TAIL(gob) - index;
- if (len < 0) len = 0;
-
- ser = Make_Block(len);
- ser->tail = len;
- val = BLK_HEAD(ser);
- gp = GOB_HEAD(gob);
- for (; len > 0; len--, val++, gp++) {
- SET_GOB(val, *gp);
- }
- SET_END(val);
-
- return ser;
+ switch (VAL_WORD_SYM(word)) {
+
+ case SYM_OFFSET:
+ SET_PAIR(val, GOB_X(gob), GOB_Y(gob));
+ break;
+
+ case SYM_SIZE:
+ SET_PAIR(val, GOB_W(gob), GOB_H(gob));
+ break;
+
+ case SYM_IMAGE:
+ if (GOB_TYPE(gob) == GOBT_IMAGE) {
+ // image
+ }
+ else goto is_blank;
+ break;
+
+ case SYM_DRAW:
+ if (GOB_TYPE(gob) == GOBT_DRAW) {
+ // !!! comment said "compiler optimizes" the init "calls below" (?)
+ Init_Block(val, ARR(GOB_CONTENT(gob)));
+ }
+ else goto is_blank;
+ break;
+
+ case SYM_TEXT:
+ if (GOB_TYPE(gob) == GOBT_TEXT) {
+ Init_Block(val, ARR(GOB_CONTENT(gob)));
+ }
+ else if (GOB_TYPE(gob) == GOBT_STRING) {
+ Init_String(val, GOB_CONTENT(gob));
+ }
+ else goto is_blank;
+ break;
+
+ case SYM_EFFECT:
+ if (GOB_TYPE(gob) == GOBT_EFFECT) {
+ Init_Block(val, ARR(GOB_CONTENT(gob)));
+ }
+ else goto is_blank;
+ break;
+
+ case SYM_COLOR:
+ if (GOB_TYPE(gob) == GOBT_COLOR) {
+ Set_Tuple_Pixel((REBYTE*)&GOB_CONTENT(gob), val);
+ }
+ else goto is_blank;
+ break;
+
+ case SYM_ALPHA:
+ Init_Integer(val, GOB_ALPHA(gob));
+ break;
+
+ case SYM_PANE:
+ if (GOB_PANE(gob))
+ Init_Block(val, Pane_To_Array(gob, 0, -1));
+ else
+ Init_Block(val, Make_Array(0));
+ break;
+
+ case SYM_PARENT:
+ if (GOB_PARENT(gob)) {
+ SET_GOB(val, GOB_PARENT(gob));
+ }
+ else
+is_blank:
+ Init_Blank(val);
+ break;
+
+ case SYM_DATA:
+ if (GOB_DTYPE(gob) == GOBD_OBJECT) {
+ Init_Object(val, CTX(GOB_DATA(gob)));
+ }
+ else if (GOB_DTYPE(gob) == GOBD_BLOCK) {
+ Init_Block(val, ARR(GOB_DATA(gob)));
+ }
+ else if (GOB_DTYPE(gob) == GOBD_STRING) {
+ Init_String(val, GOB_DATA(gob));
+ }
+ else if (GOB_DTYPE(gob) == GOBD_BINARY) {
+ Init_Binary(val, GOB_DATA(gob));
+ }
+ else if (GOB_DTYPE(gob) == GOBD_INTEGER) {
+ Init_Integer(val, (REBIPT)GOB_DATA(gob));
+ }
+ else goto is_blank;
+ break;
+
+ case SYM_FLAGS:
+ Init_Block(val, Gob_Flags_To_Array(gob));
+ break;
+
+ default:
+ return FALSE;
+ }
+ return TRUE;
}
-/***********************************************************************
-**
-*/ static REBSER *Flags_To_Block(REBGOB *gob)
-/*
-***********************************************************************/
+//
+// Set_GOB_Vars: C
+//
+static void Set_GOB_Vars(REBGOB *gob, const RELVAL *blk, REBSPC *specifier)
{
- REBSER *ser;
- REBVAL *val;
- REBINT i;
+ DECLARE_LOCAL (var);
+ DECLARE_LOCAL (val);
- ser = Make_Block(3);
+ while (NOT_END(blk)) {
+ assert(!IS_VOID(blk));
- for (i = 0; Gob_Flag_Words[i]; i += 2) {
- if (GET_GOB_FLAG(gob, Gob_Flag_Words[i+1])) {
- val = Append_Value(ser);
- Init_Word(val, Gob_Flag_Words[i]);
- }
- }
+ Derelativize(var, blk, specifier);
+ ++blk;
- return ser;
+ if (!IS_SET_WORD(var))
+ fail (Error_Unexpected_Type(REB_SET_WORD, VAL_TYPE(var)));
+
+ if (IS_END(blk))
+ fail (Error_Need_Value_Raw(var));
+
+ Derelativize(val, blk, specifier);
+ ++blk;
+
+ if (IS_SET_WORD(val))
+ fail (Error_Need_Value_Raw(var));
+
+ if (!Set_GOB_Var(gob, var, val))
+ fail (Error_Bad_Field_Set_Raw(var, Type_Of(val)));
+ }
+}
+
+
+//
+// Gob_To_Array: C
+//
+// Used by MOLD to create a block.
+//
+REBARR *Gob_To_Array(REBGOB *gob)
+{
+ REBARR *array = Make_Array(10);
+ REBVAL *val;
+ REBSYM words[] = {SYM_OFFSET, SYM_SIZE, SYM_ALPHA, SYM_0};
+ REBVAL *vals[6];
+ REBINT n = 0;
+ REBVAL *val1;
+
+ for (n = 0; words[n] != SYM_0; ++n) {
+ val = Alloc_Tail_Array(array);
+ Init_Set_Word(val, Canon(words[n]));
+ vals[n] = Alloc_Tail_Array(array);
+ Init_Blank(vals[n]);
+ }
+
+ SET_PAIR(vals[0], GOB_X(gob), GOB_Y(gob));
+ SET_PAIR(vals[1], GOB_W(gob), GOB_H(gob));
+ Init_Integer(vals[2], GOB_ALPHA(gob));
+
+ if (!GOB_TYPE(gob)) return array;
+
+ if (GOB_CONTENT(gob)) {
+ val1 = Alloc_Tail_Array(array);
+ val = Alloc_Tail_Array(array);
+
+ REBSYM sym;
+ switch (GOB_TYPE(gob)) {
+ case GOBT_COLOR:
+ sym = SYM_COLOR;
+ break;
+ case GOBT_IMAGE:
+ sym = SYM_IMAGE;
+ break;
+ case GOBT_STRING:
+ case GOBT_TEXT:
+ sym = SYM_TEXT;
+ break;
+ case GOBT_DRAW:
+ sym = SYM_DRAW;
+ break;
+ case GOBT_EFFECT:
+ sym = SYM_EFFECT;
+ break;
+ default:
+ fail ("Unknown GOB! type");
+ }
+ Init_Set_Word(val1, Canon(sym));
+ Get_GOB_Var(gob, val1, val);
+ }
+
+ return array;
}
-/***********************************************************************
-**
-*/ static void Set_Gob_Flag(REBGOB *gob, REBVAL *word)
-/*
-***********************************************************************/
+//
+// Return_Gob_Pair: C
+//
+static void Return_Gob_Pair(REBVAL *out, REBGOB *gob, REBD32 x, REBD32 y)
{
- REBINT i;
-
- for (i = 0; Gob_Flag_Words[i]; i += 2) {
- if (VAL_WORD_CANON(word) == Gob_Flag_Words[i]) {
- SET_GOB_FLAG(gob, Gob_Flag_Words[i+1]);
- break;
- }
- }
+ REBARR *blk = Make_Array(2);
+ Init_Block(out, blk);
+
+ SET_GOB(Alloc_Tail_Array(blk), gob);
+
+ REBVAL *val = Alloc_Tail_Array(blk);
+ VAL_RESET_HEADER(val, REB_PAIR);
+ VAL_PAIR_X(val) = x;
+ VAL_PAIR_Y(val) = y;
}
-/***********************************************************************
-**
-*/ static REBFLG Set_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
-/*
-***********************************************************************/
+//
+// Map_Gob_Inner: C
+//
+// Map a higher level gob coordinate to a lower level.
+// Returns GOB and sets new offset pair.
+//
+static REBGOB *Map_Gob_Inner(REBGOB *gob, REBXYF *offset)
{
- switch (VAL_WORD_CANON(word)) {
- case SYM_OFFSET:
- return Set_Pair(&(gob->offset), val);
-
- case SYM_SIZE:
- return Set_Pair(&gob->size, val);
-
- case SYM_IMAGE:
- CLR_GOB_OPAQUE(gob);
- if (IS_IMAGE(val)) {
- SET_GOB_TYPE(gob, GOBT_IMAGE);
- GOB_W(gob) = (REBD32)VAL_IMAGE_WIDE(val);
- GOB_H(gob) = (REBD32)VAL_IMAGE_HIGH(val);
- GOB_CONTENT(gob) = VAL_SERIES(val);
-// if (!VAL_IMAGE_TRANSP(val)) SET_GOB_OPAQUE(gob);
- }
- else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
- else return FALSE;
- break;
-
- case SYM_DRAW:
- CLR_GOB_OPAQUE(gob);
- if (IS_BLOCK(val)) {
- SET_GOB_TYPE(gob, GOBT_DRAW);
- GOB_CONTENT(gob) = VAL_SERIES(val);
- }
- else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
- else return FALSE;
- break;
-
- case SYM_TEXT:
- CLR_GOB_OPAQUE(gob);
- if (IS_BLOCK(val)) {
- SET_GOB_TYPE(gob, GOBT_TEXT);
- GOB_CONTENT(gob) = VAL_SERIES(val);
- }
- else if (IS_STRING(val)) {
- SET_GOB_TYPE(gob, GOBT_STRING);
- GOB_CONTENT(gob) = VAL_SERIES(val);
- }
- else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
- else return FALSE;
- break;
-
- case SYM_EFFECT:
- CLR_GOB_OPAQUE(gob);
- if (IS_BLOCK(val)) {
- SET_GOB_TYPE(gob, GOBT_EFFECT);
- GOB_CONTENT(gob) = VAL_SERIES(val);
- }
- else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
- else return FALSE;
- break;
-
- case SYM_COLOR:
- CLR_GOB_OPAQUE(gob);
- if (IS_TUPLE(val)) {
- SET_GOB_TYPE(gob, GOBT_COLOR);
- Set_Pixel_Tuple((REBYTE*)&GOB_CONTENT(gob), val);
- if (VAL_TUPLE_LEN(val) < 4 || VAL_TUPLE(val)[3] == 0)
- SET_GOB_OPAQUE(gob);
- }
- else if (IS_NONE(val)) SET_GOB_TYPE(gob, GOBT_NONE);
- break;
-
- case SYM_PANE:
- if (GOB_PANE(gob)) Clear_Series(GOB_PANE(gob));
- if (IS_BLOCK(val))
- Insert_Gobs(gob, VAL_BLK_DATA(val), 0, VAL_BLK_LEN(val), 0);
- else if (IS_GOB(val))
- Insert_Gobs(gob, val, 0, 1, 0);
- else if (IS_NONE(val))
- gob->pane = 0;
- else
- return FALSE;
- break;
-
- case SYM_ALPHA:
- GOB_ALPHA(gob) = Clip_Int(Int32(val), 0, 255);
- break;
-
- case SYM_DATA:
- SET_GOB_DTYPE(gob, GOBD_NONE);
- if (IS_OBJECT(val)) {
- SET_GOB_DTYPE(gob, GOBD_OBJECT);
- SET_GOB_DATA(gob, VAL_OBJ_FRAME(val));
- }
- else if (IS_BLOCK(val)) {
- SET_GOB_DTYPE(gob, GOBD_BLOCK);
- SET_GOB_DATA(gob, VAL_SERIES(val));
- }
- else if (IS_STRING(val)) {
- SET_GOB_DTYPE(gob, GOBD_STRING);
- SET_GOB_DATA(gob, VAL_SERIES(val));
- }
- else if (IS_BINARY(val)) {
- SET_GOB_DTYPE(gob, GOBD_BINARY);
- SET_GOB_DATA(gob, VAL_SERIES(val));
- }
- else if (IS_INTEGER(val)) {
- SET_GOB_DTYPE(gob, GOBD_INTEGER);
- SET_GOB_DATA(gob, (void*)VAL_INT32(val));
- }
- else if (IS_NONE(val))
- SET_GOB_TYPE(gob, GOBT_NONE);
- else return FALSE;
- break;
-
- case SYM_FLAGS:
- if (IS_WORD(val)) Set_Gob_Flag(gob, val);
- else if (IS_BLOCK(val)) {
- gob->flags = 0;
- for (val = VAL_BLK(val); NOT_END(val); val++) {
- if (IS_WORD(val)) Set_Gob_Flag(gob, val);
- }
- }
- break;
-
- case SYM_OWNER:
- if (IS_GOB(val))
- GOB_TMP_OWNER(gob) = VAL_GOB(val);
- else
- return FALSE;
- break;
-
- default:
- return FALSE;
- }
- return TRUE;
+ REBD32 xo = offset->x;
+ REBD32 yo = offset->y;
+ REBINT n;
+ REBINT len;
+ REBGOB **gop;
+ REBD32 x = 0;
+ REBD32 y = 0;
+ REBINT max_depth = 1000; // avoid infinite loops
+
+ while (GOB_PANE(gob) && (max_depth-- > 0)) {
+ len = GOB_LEN(gob);
+ gop = GOB_HEAD(gob) + len - 1;
+ for (n = 0; n < len; n++, gop--) {
+ if (
+ (xo >= x + GOB_X(*gop)) &&
+ (xo < x + GOB_X(*gop) + GOB_W(*gop)) &&
+ (yo >= y + GOB_Y(*gop)) &&
+ (yo < y + GOB_Y(*gop) + GOB_H(*gop))
+ ){
+ x += GOB_X(*gop);
+ y += GOB_Y(*gop);
+ gob = *gop;
+ break;
+ }
+ }
+ if (n >= len) break; // not found
+ }
+
+ offset->x -= x;
+ offset->y -= y;
+
+ return gob;
}
-/***********************************************************************
-**
-*/ static REBFLG Get_GOB_Var(REBGOB *gob, REBVAL *word, REBVAL *val)
-/*
-***********************************************************************/
+//
+// map-event: native [
+//
+// {Returns event with inner-most graphical object and coordinate.}
+//
+// event [event!]
+// ]
+//
+REBNATIVE(map_event)
{
- switch (VAL_WORD_CANON(word)) {
-
- case SYM_OFFSET:
- SET_PAIR(val, GOB_X(gob), GOB_Y(gob));
- break;
-
- case SYM_SIZE:
- SET_PAIR(val, GOB_W(gob), GOB_H(gob));
- break;
-
- case SYM_IMAGE:
- if (GOB_TYPE(gob) == GOBT_IMAGE) {
- // image
- }
- else goto is_none;
- break;
-
- case SYM_DRAW:
- if (GOB_TYPE(gob) == GOBT_DRAW) {
- Set_Block(val, GOB_CONTENT(gob)); // Note: compiler optimizes SET_BLOCKs below
- }
- else goto is_none;
- break;
-
- case SYM_TEXT:
- if (GOB_TYPE(gob) == GOBT_TEXT) {
- Set_Block(val, GOB_CONTENT(gob));
- }
- else if (GOB_TYPE(gob) == GOBT_STRING) {
- Set_String(val, GOB_CONTENT(gob));
- }
- else goto is_none;
- break;
-
- case SYM_EFFECT:
- if (GOB_TYPE(gob) == GOBT_EFFECT) {
- Set_Block(val, GOB_CONTENT(gob));
- }
- else goto is_none;
- break;
-
- case SYM_COLOR:
- if (GOB_TYPE(gob) == GOBT_COLOR) {
- Set_Tuple_Pixel((REBYTE*)&GOB_CONTENT(gob), val);
- }
- else goto is_none;
- break;
-
- case SYM_ALPHA:
- SET_INTEGER(val, GOB_ALPHA(gob));
- break;
-
- case SYM_PANE:
- if (GOB_PANE(gob))
- Set_Block(val, Pane_To_Block(gob, 0, -1));
- else
- Set_Block(val, Make_Block(0));
- break;
-
- case SYM_PARENT:
- if (GOB_PARENT(gob)) {
- SET_GOB(val, GOB_PARENT(gob));
- }
- else
-is_none:
- SET_NONE(val);
- break;
-
- case SYM_DATA:
- if (GOB_DTYPE(gob) == GOBD_OBJECT) {
- SET_OBJECT(val, GOB_DATA(gob));
- }
- else if (GOB_DTYPE(gob) == GOBD_BLOCK) {
- Set_Block(val, GOB_DATA(gob));
- }
- else if (GOB_DTYPE(gob) == GOBD_STRING) {
- Set_String(val, GOB_DATA(gob));
- }
- else if (GOB_DTYPE(gob) == GOBD_BINARY) {
- SET_BINARY(val, GOB_DATA(gob));
- }
- else if (GOB_DTYPE(gob) == GOBD_INTEGER) {
- SET_INTEGER(val, (REBINT)GOB_DATA(gob));
- }
- else goto is_none;
- break;
-
- case SYM_FLAGS:
- Set_Block(val, Flags_To_Block(gob));
- break;
-
- default:
- return FALSE;
- }
- return TRUE;
+ INCLUDE_PARAMS_OF_MAP_EVENT;
+
+ REBVAL *val = ARG(event);
+ REBGOB *gob = cast(REBGOB*, VAL_EVENT_SER(val));
+ REBXYF xy;
+
+ if (gob && GET_FLAG(VAL_EVENT_FLAGS(val), EVF_HAS_XY)) {
+ xy.x = (REBD32)VAL_EVENT_X(val);
+ xy.y = (REBD32)VAL_EVENT_Y(val);
+ VAL_EVENT_SER(val) = cast(REBSER*, Map_Gob_Inner(gob, &xy));
+ SET_EVENT_XY(val, ROUND_TO_INT(xy.x), ROUND_TO_INT(xy.y));
+ }
+
+ Move_Value(D_OUT, ARG(event));
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ static void Set_GOB_Vars(REBGOB *gob, REBVAL *blk)
-/*
-***********************************************************************/
+//
+// map-gob-offset: native [
+//
+// {Translate gob and offset to deepest gob and offset in it, return as block}
+//
+// gob [gob!]
+// "Starting object"
+// xy [pair!]
+// "Staring offset"
+// /reverse
+// "Translate from deeper gob to top gob."
+// ]
+//
+REBNATIVE(map_gob_offset)
{
- REBVAL *var;
- REBVAL *val;
-
- while (NOT_END(blk)) {
- var = blk++;
- val = blk++;
- if (!IS_SET_WORD(var)) Trap2(RE_EXPECT_VAL, Get_Type(REB_SET_WORD), Of_Type(var));
- if (IS_END(val) || IS_UNSET(val) || IS_SET_WORD(val))
- Trap1(RE_NEED_VALUE, var);
- val = Get_Simple_Value(val);
- if (!Set_GOB_Var(gob, var, val)) Trap2(RE_BAD_FIELD_SET, var, Of_Type(val));
- }
+ INCLUDE_PARAMS_OF_MAP_GOB_OFFSET;
+
+ REBGOB *gob = VAL_GOB(ARG(gob));
+ REBD32 xo = VAL_PAIR_X(ARG(xy));
+ REBD32 yo = VAL_PAIR_Y(ARG(xy));
+
+ if (REF(reverse)) {
+ REBINT max_depth = 1000; // avoid infinite loops
+ while (
+ GOB_PARENT(gob)
+ && (max_depth-- > 0)
+ && !GET_GOB_FLAG(gob, GOBF_WINDOW)
+ ){
+ xo += GOB_X(gob);
+ yo += GOB_Y(gob);
+ gob = GOB_PARENT(gob);
+ }
+ }
+ else {
+ REBXYF xy;
+ xy.x = VAL_PAIR_X(ARG(xy));
+ xy.y = VAL_PAIR_Y(ARG(xy));
+ gob = Map_Gob_Inner(gob, &xy);
+ xo = xy.x;
+ yo = xy.y;
+ }
+
+ Return_Gob_Pair(D_OUT, gob, xo, yo);
+
+ return R_OUT;
+}
+
+
+//
+// Extend_Gob_Core: C
+//
+// !!! R3-Alpha's MAKE has been unified with construction syntax, which has
+// no "parent" slot (just type and value). To try and incrementally keep
+// code working, this parameterized function is called by both REBNATIVE(make)
+// REBNATIVE(construct).
+//
+void Extend_Gob_Core(REBGOB *gob, const REBVAL *arg) {
+ //
+ // !!! See notes about derivation in REBNATIVE(make). When deriving, it
+ // appeared to copy the variables while nulling out the pane and parent
+ // fields. Then it applied the variables. It also *said* in the case of
+ // passing in another gob "merge gob provided as argument", but didn't
+ // seem to do any merging--it just overwrote. So the block and pair cases
+ // were the only ones "merging".
+
+ if (IS_BLOCK(arg)) {
+ Set_GOB_Vars(gob, VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg));
+ }
+ else if (IS_PAIR(arg)) {
+ gob->size.x = VAL_PAIR_X(arg);
+ gob->size.y = VAL_PAIR_Y(arg);
+ }
+ else
+ fail (Error_Bad_Make(REB_GOB, arg));
}
-/***********************************************************************
-**
-*/ REBSER *Gob_To_Block(REBGOB *gob)
-/*
-** Used by MOLD to create a block.
-**
-***********************************************************************/
+//
+// MAKE_Gob: C
+//
+void MAKE_Gob(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBSER *ser = Make_Block(10);
- REBVAL *val;
- REBINT words[6] = {SYM_OFFSET, SYM_SIZE, SYM_ALPHA, 0};
- REBVAL *vals[6];
- REBINT n = 0;
- REBVAL *val1;
- REBCNT sym;
-
- for (n = 0; words[n]; n++) {
- val = Append_Value(ser);
- Init_Word(val, words[n]);
- VAL_SET(val, REB_SET_WORD);
- vals[n] = Append_Value(ser);
- }
-
- SET_PAIR(vals[0], GOB_X(gob), GOB_Y(gob));
- SET_PAIR(vals[1], GOB_W(gob), GOB_H(gob));
- SET_INTEGER(vals[2], GOB_ALPHA(gob));
-
- if (!GOB_TYPE(gob)) return ser;
-
- if (GOB_CONTENT(gob)) {
- val1 = Append_Value(ser);
- val = Append_Value(ser);
- switch (GOB_TYPE(gob)) {
- case GOBT_COLOR:
- sym = SYM_COLOR;
- break;
- case GOBT_IMAGE:
- sym = SYM_IMAGE;
- break;
- case GOBT_STRING:
- case GOBT_TEXT:
- sym = SYM_TEXT;
- break;
- case GOBT_DRAW:
- sym = SYM_DRAW;
- break;
- case GOBT_EFFECT:
- sym = SYM_EFFECT;
- break;
- }
- Init_Word(val1, sym);
- VAL_SET(val1, REB_SET_WORD);
- Get_GOB_Var(gob, val1, val);
- }
-
- return ser;
+ assert(kind == REB_GOB);
+ UNUSED(kind);
+
+ REBGOB *gob = Make_Gob();
+
+ if (IS_GOB(arg)) {
+ //
+ // !!! See notes in Extend_Gob_Core; previously a parent was allowed
+ // here, but completely overwritten with a GOB! argument.
+ //
+ *gob = *VAL_GOB(arg);
+ gob->pane = NULL;
+ gob->parent = NULL;
+ }
+ else
+ Extend_Gob_Core(gob, arg);
+
+ SET_GOB(out, gob);
}
-/***********************************************************************
-**
-*/ REBFLG MT_Gob(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+//
+// TO_Gob: C
+//
+void TO_Gob(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBGOB *ngob;
+ assert(kind == REB_GOB);
+ UNUSED(kind);
- if (IS_BLOCK(data)) {
- ngob = Make_Gob();
- Set_GOB_Vars(ngob, VAL_BLK_DATA(data));
- SET_GOB(out, ngob);
- return TRUE;
- }
+ UNUSED(out);
- return FALSE;
+ fail (arg);
}
-/***********************************************************************
-**
-*/ REBINT PD_Gob(REBPVS *pvs)
-/*
-***********************************************************************/
+//
+// PD_Gob: C
+//
+REBINT PD_Gob(REBPVS *pvs)
{
- REBGOB *gob = VAL_GOB(pvs->value);
- REBCNT index;
- REBCNT tail;
-
- if (IS_WORD(pvs->select)) {
- if (pvs->setval == 0 || NOT_END(pvs->path+1)) {
- if (!Get_GOB_Var(gob, pvs->select, pvs->store)) return PE_BAD_SELECT;
- // Check for SIZE/X: types of cases:
- if (pvs->setval && IS_PAIR(pvs->store)) {
- REBVAL *sel = pvs->select;
- pvs->value = pvs->store;
- Next_Path(pvs); // sets value in pvs->store
- Set_GOB_Var(gob, sel, pvs->store); // write it back to gob
- }
- return PE_USE;
- } else {
- if (!Set_GOB_Var(gob, pvs->select, pvs->setval)) return PE_BAD_SET;
- return PE_OK;
- }
- }
- if (IS_INTEGER(pvs->select)) {
- if (!GOB_PANE(gob)) return PE_NONE;
- tail = GOB_PANE(gob) ? GOB_TAIL(gob) : 0;
- index = VAL_GOB_INDEX(pvs->value);
- index += Int32(pvs->select) - 1;
- if (index >= tail) return PE_NONE;
- gob = *GOB_SKIP(gob, index);
- index = 0;
- VAL_SET(pvs->store, REB_GOB);
- VAL_GOB(pvs->store) = gob;
- VAL_GOB_INDEX(pvs->store) = 0;
- return PE_USE;
- }
- return PE_BAD_SELECT;
+ REBGOB *gob = VAL_GOB(pvs->value);
+ REBCNT index;
+ REBCNT tail;
+
+ if (IS_WORD(pvs->picker)) {
+ if (!pvs->opt_setval || NOT_END(pvs->item + 1)) {
+ if (!Get_GOB_Var(gob, pvs->picker, pvs->store))
+ fail (Error_Bad_Path_Select(pvs));
+
+ // !!! Comment here said: "Check for SIZE/X: types of cases".
+ // See %c-path.c for an explanation of why this code steps
+ // outside the ordinary path processing to "look ahead" in the
+ // case of wanting to make it possible to use a generated PAIR!
+ // as a way of "writing back" into the values in the GOB! that
+ // were used to generate the PAIR!. There should be some
+ // overall solution to facilitating this kind of need.
+ //
+ if (pvs->opt_setval && IS_PAIR(pvs->store)) {
+ //
+ // !!! Adding to the reasons that this is dodgy, the picker
+ // can be pointing to a temporary memory cell, and when
+ // Next_Path_Throws runs arbitrary code it could be GC'd too.
+ // Have to copy -and- protect.
+ //
+ DECLARE_LOCAL (orig_picker);
+ Move_Value(orig_picker, pvs->picker);
+ PUSH_GUARD_VALUE(orig_picker);
+
+ pvs->value = pvs->store;
+ pvs->value_specifier = SPECIFIED;
+
+ if (Next_Path_Throws(pvs)) // sets value in pvs->store
+ fail (Error_No_Catch_For_Throw(pvs->store)); // Review
+
+ // write it back to gob
+ //
+ Set_GOB_Var(gob, orig_picker, pvs->store);
+ DROP_GUARD_VALUE(orig_picker);
+ }
+ return PE_USE_STORE;
+ }
+ else {
+ if (!Set_GOB_Var(gob, pvs->picker, pvs->opt_setval))
+ fail (Error_Bad_Path_Set(pvs));
+ return PE_OK;
+ }
+ }
+
+ if (IS_INTEGER(pvs->picker)) {
+ if (!GOB_PANE(gob)) return PE_NONE;
+
+ tail = GOB_PANE(gob) ? GOB_LEN(gob) : 0;
+ index = VAL_GOB_INDEX(pvs->value);
+ index += Int32(pvs->picker) - 1;
+
+ if (index >= tail) return PE_NONE;
+
+ gob = *GOB_AT(gob, index);
+ VAL_RESET_HEADER(pvs->store, REB_GOB);
+ VAL_GOB(pvs->store) = gob;
+ VAL_GOB_INDEX(pvs->store) = 0;
+ return PE_USE_STORE;
+ }
+
+ fail (Error_Bad_Path_Select(pvs));
}
-/***********************************************************************
-**
-*/ REBTYPE(Gob)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+REBTYPE(Gob)
{
- REBVAL *val;
- REBVAL *arg;
- REBGOB *gob;
- REBGOB *ngob;
- REBCNT index;
- REBCNT tail;
- REBCNT len;
-
- arg = D_ARG(2);
- val = D_RET;
- *val = *D_ARG(1);
- gob = 0;
-
- if (IS_GOB(val)) {
- gob = VAL_GOB(val);
- index = VAL_GOB_INDEX(val);
- tail = GOB_PANE(gob) ? GOB_TAIL(gob) : 0;
- }
-
- // unary actions
- switch(action) {
-
- case A_MAKE:
- ngob = Make_Gob();
- val = D_ARG(1);
-
- // Clone an existing GOB:
- if (IS_GOB(val)) { // local variable "gob" is valid
- *ngob = *gob; // Copy all values
- ngob->pane = 0;
- ngob->parent = 0;
- }
- else if (!IS_DATATYPE(val)) goto is_arg_error;
-
- // Initialize GOB from block:
- if (IS_BLOCK(arg)) {
- Set_GOB_Vars(ngob, VAL_BLK_DATA(arg));
- }
- // Merge GOB provided as argument:
- else if (IS_GOB(arg)) {
- *ngob = *VAL_GOB(arg);
- ngob->pane = 0;
- ngob->parent = 0;
- }
- else if (IS_PAIR(arg)) {
- ngob->size.x = VAL_PAIR_X(arg);
- ngob->size.y = VAL_PAIR_Y(arg);
- }
- else
- Trap_Make(REB_GOB, arg);
- // Allow NONE as argument:
-// else if (!IS_NONE(arg))
-// goto is_arg_error;
- SET_GOB(DS_RETURN, ngob);
- break;
-
- case A_PICK:
- if (!IS_NUMBER(arg) && !IS_NONE(arg)) Trap_Arg(arg);
- if (!GOB_PANE(gob)) goto is_none;
- index += Get_Num_Arg(arg) - 1;
- if (index >= tail) goto is_none;
- gob = *GOB_SKIP(gob, index);
- index = 0;
- goto set_index;
-
- case A_POKE:
- index += Get_Num_Arg(arg) - 1;
- arg = D_ARG(3);
- case A_CHANGE:
- if (!IS_GOB(arg)) goto is_arg_error;
- if (!GOB_PANE(gob) || index >= tail) Trap0(RE_PAST_END);
- if (action == A_CHANGE && (DS_REF(AN_PART) || DS_REF(AN_ONLY) || DS_REF(AN_DUP))) Trap0(RE_NOT_DONE);
- Insert_Gobs(gob, arg, index, 1, 0);
- //ngob = *GOB_SKIP(gob, index);
- //GOB_PARENT(ngob) = 0;
- //*GOB_SKIP(gob, index) = VAL_GOB(arg);
- if (action == A_POKE) {
- *DS_RETURN = *arg;
- return R_RET;
- }
- index++;
- goto set_index;
-
- case A_APPEND:
- index = tail;
- case A_INSERT:
- if (DS_REF(AN_PART) || DS_REF(AN_ONLY) || DS_REF(AN_DUP)) Trap0(RE_NOT_DONE);
- if (IS_GOB(arg)) len = 1;
- else if (IS_BLOCK(arg)) {
- len = VAL_BLK_LEN(arg);
- arg = VAL_BLK_DATA(arg);
- }
- else goto is_arg_error;;
- Insert_Gobs(gob, arg, index, len, 0);
- break;
-
- case A_CLEAR:
- if (tail > index) Remove_Gobs(gob, index, tail - index);
- break;
-
- case A_REMOVE:
- // /PART length
- len = D_REF(2) ? Get_Num_Arg(D_ARG(3)) : 1;
- if (index + len > tail) len = tail - index;
- if (index < tail && len != 0) Remove_Gobs(gob, index, len);
- break;
-
- case A_TAKE:
- len = D_REF(2) ? Get_Num_Arg(D_ARG(3)) : 1;
- if (index + len > tail) len = tail - index;
- if (index < 0 || index >= tail) goto is_none;
- if (!D_REF(2)) { // just one value
- VAL_SET(val, REB_GOB);
- VAL_GOB(val) = *GOB_SKIP(gob, index);
- VAL_GOB_INDEX(val) = 0;
- Remove_Gobs(gob, index, 1);
- return R_RET;
- } else {
- Set_Block(D_RET, Pane_To_Block(gob, index, len));
- Remove_Gobs(gob, index, len);
- }
- return R_RET;
-
- case A_NEXT:
- if (index < tail) index++;
- goto set_index;
-
- case A_BACK:
- if (index > 0) index--;
- goto set_index;
-
- case A_AT:
- index--;
- case A_SKIP:
- index += VAL_INT32(arg);
- goto set_index;
-
- case A_HEAD:
- index = 0;
- goto set_index;
-
- case A_TAIL:
- index = tail;
- goto set_index;
-
- case A_HEADQ:
- if (index == 0) goto is_true;
- goto is_false;
-
- case A_TAILQ:
- if (index >= tail) goto is_true;
- goto is_false;
-
- case A_PASTQ:
- if (index > tail) goto is_true;
- goto is_false;
-
- case A_INDEXQ:
- SET_INTEGER(val, index+1);
- break;
-
- case A_LENGTHQ:
- index = (tail > index) ? tail - index : 0;
- SET_INTEGER(val, index);
- break;
-
- case A_FIND:
- if (IS_GOB(arg)) {
- index = Find_Gob(gob, VAL_GOB(arg));
- if (index == NOT_FOUND) goto is_none;
- goto set_index;
- }
- goto is_none;
-
- case A_REVERSE:
- for (index = 0; index < tail/2; index++) {
- ngob = *GOB_SKIP(gob, tail-index-1);
- *GOB_SKIP(gob, tail-index-1) = *GOB_SKIP(gob, index);
- *GOB_SKIP(gob, index) = ngob;
- }
- return R_ARG1;
-
- default:
- Trap_Action(REB_GOB, action);
- }
- return R_RET;
+ REBVAL *val = D_ARG(1);
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+ REBGOB *gob = NULL;
+ REBGOB *ngob;
+ REBCNT index;
+ REBCNT tail;
+ REBCNT len;
+
+ Move_Value(D_OUT, val);
+
+ assert(IS_GOB(val));
+ gob = VAL_GOB(val);
+ index = VAL_GOB_INDEX(val);
+ tail = GOB_PANE(gob) ? GOB_LEN(gob) : 0;
+
+ // unary actions
+ switch(action) {
+ //
+ // !!! Note: PICK* and POKE were unified with path dispatch. The general
+ // goal is to unify these mechanisms. However, GOB! is tricky in terms
+ // of what it tried to do with a synthesized PAIR!, calling back into
+ // Next_Path_Throws(). A logical overhaul of path dispatch is needed.
+ // This code is left in case there's something to glean from it when
+ // a GOB!-based path dispatch breaks.
+ /*
+ case SYM_PICK_P:
+ if (NOT(ANY_NUMBER(arg) || IS_BLANK(arg)))
+ fail (arg);
+
+ if (!GOB_PANE(gob)) goto is_blank;
+ index += Get_Num_From_Arg(arg) - 1;
+ if (index >= tail) goto is_blank;
+ gob = *GOB_AT(gob, index);
+ index = 0;
+ goto set_index;
+
+ case SYM_POKE:
+ index += Get_Num_From_Arg(arg) - 1;
+ arg = D_ARG(3);
+ // fallthrough */
+ case SYM_CHANGE: {
+ INCLUDE_PARAMS_OF_CHANGE;
+
+ UNUSED(PAR(series));
+ UNUSED(PAR(value)); // handled as `arg`
+
+ if (!IS_GOB(arg))
+ goto is_arg_error;
+ if (!GOB_PANE(gob) || index >= tail)
+ fail (Error_Past_End_Raw());
+ if (
+ action == SYM_CHANGE
+ && (REF(part) || REF(only) || REF(dup))
+ ){
+ UNUSED(PAR(limit));
+ UNUSED(PAR(count));
+ fail (Error_Not_Done_Raw());
+ }
+
+ Insert_Gobs(gob, arg, index, 1, FALSE);
+ if (action == SYM_POKE) {
+ Move_Value(D_OUT, arg);
+ return R_OUT;
+ }
+ index++;
+ goto set_index; }
+
+ case SYM_APPEND:
+ index = tail;
+ // falls through
+ case SYM_INSERT: {
+ INCLUDE_PARAMS_OF_INSERT;
+
+ UNUSED(PAR(series));
+ UNUSED(PAR(value));
+
+ if (REF(part) || REF(only) || REF(dup)) {
+ UNUSED(PAR(limit));
+ UNUSED(PAR(count));
+ fail (Error_Not_Done_Raw());
+ }
+
+ if (IS_GOB(arg)) {
+ len = 1;
+ }
+ else if (IS_BLOCK(arg)) {
+ len = VAL_ARRAY_LEN_AT(arg);
+ arg = KNOWN(VAL_ARRAY_AT(arg)); // !!! REVIEW
+ }
+ else
+ goto is_arg_error;
+
+ Insert_Gobs(gob, arg, index, len, FALSE);
+ break; }
+
+ case SYM_CLEAR:
+ if (tail > index) Remove_Gobs(gob, index, tail - index);
+ break;
+
+ case SYM_REMOVE: {
+ INCLUDE_PARAMS_OF_REMOVE;
+
+ UNUSED(PAR(series));
+
+ if (REF(map)) {
+ UNUSED(ARG(key));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ len = REF(part) ? Get_Num_From_Arg(ARG(limit)) : 1;
+ if (index + len > tail) len = tail - index;
+ if (index < tail && len != 0) Remove_Gobs(gob, index, len);
+ break; }
+
+ case SYM_TAKE_P: {
+ INCLUDE_PARAMS_OF_TAKE_P;
+
+ UNUSED(PAR(series));
+
+ if (REF(deep))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(last))
+ fail (Error_Bad_Refines_Raw());
+
+ len = REF(part) ? Get_Num_From_Arg(ARG(limit)) : 1;
+ if (index + len > tail) len = tail - index;
+ if (index >= tail) goto is_blank;
+ if (NOT(REF(part))) { // just one value
+ VAL_RESET_HEADER(D_OUT, REB_GOB);
+ VAL_GOB(D_OUT) = *GOB_AT(gob, index);
+ VAL_GOB_INDEX(D_OUT) = 0;
+ Remove_Gobs(gob, index, 1);
+ return R_OUT;
+ }
+ else {
+ Init_Block(D_OUT, Pane_To_Array(gob, index, len));
+ Remove_Gobs(gob, index, len);
+ }
+ return R_OUT; }
+
+ case SYM_AT:
+ index--;
+ // falls through
+ case SYM_SKIP:
+ index += VAL_INT32(arg);
+ goto set_index;
+
+ case SYM_HEAD_OF:
+ index = 0;
+ goto set_index;
+
+ case SYM_TAIL_OF:
+ index = tail;
+ goto set_index;
+
+ case SYM_HEAD_Q:
+ if (index == 0) goto is_true;
+ goto is_false;
+
+ case SYM_TAIL_Q:
+ if (index >= tail) goto is_true;
+ goto is_false;
+
+ case SYM_PAST_Q:
+ if (index > tail) goto is_true;
+ goto is_false;
+
+ case SYM_INDEX_OF:
+ Init_Integer(D_OUT, index + 1);
+ break;
+
+ case SYM_LENGTH_OF:
+ index = (tail > index) ? tail - index : 0;
+ Init_Integer(D_OUT, index);
+ break;
+
+ case SYM_FIND:
+ if (IS_GOB(arg)) {
+ index = Find_Gob(gob, VAL_GOB(arg));
+ if (index == NOT_FOUND) goto is_blank;
+ goto set_index;
+ }
+ goto is_blank;
+
+ case SYM_REVERSE:
+ for (index = 0; index < tail/2; index++) {
+ ngob = *GOB_AT(gob, tail-index-1);
+ *GOB_AT(gob, tail-index-1) = *GOB_AT(gob, index);
+ *GOB_AT(gob, index) = ngob;
+ }
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT;
+
+ default:
+ fail (Error_Illegal_Action(REB_GOB, action));
+ }
+ return R_OUT;
set_index:
- VAL_SET(val, REB_GOB);
- VAL_GOB(val) = gob;
- VAL_GOB_INDEX(val) = index;
- return R_RET;
+ VAL_RESET_HEADER(D_OUT, REB_GOB);
+ VAL_GOB(D_OUT) = gob;
+ VAL_GOB_INDEX(D_OUT) = index;
+ return R_OUT;
-is_none:
- return R_NONE;
+is_blank:
+ return R_BLANK;
is_arg_error:
- Trap_Types(RE_EXPECT_VAL, REB_GOB, VAL_TYPE(arg));
+ fail (Error_Unexpected_Type(REB_GOB, VAL_TYPE(arg)));
is_false:
- return R_FALSE;
+ return R_FALSE;
is_true:
- return R_TRUE;
+ return R_TRUE;
}
diff --git a/src/core/t-image.c b/src/core/t-image.c
index b608866b5f..1beaa23313 100644
--- a/src/core/t-image.c
+++ b/src/core/t-image.c
@@ -1,1295 +1,1405 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-image.c
-** Summary: image datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-/*
-** It's a bit of a shame that alpha channels are represented with
-** an inverted level compared to many standards. Alpha zero must
-** be opaque in order for RGB tuples to be equal RGBA tuples.
-** That is: 10.20.30 = 10.20.30.0
-*/
+//
+// File: %t-image.c
+// Summary: "image datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+
#include "sys-core.h"
-#define CLEAR_IMAGE(p, x, y) memset(p, 0, x * y * sizeof(long))
+#define CLEAR_IMAGE(p, x, y) memset(p, 0, x * y * sizeof(u32))
+
+#define RESET_IMAGE(p, l) do { \
+ REBCNT *start = (REBCNT*)p; \
+ REBCNT *stop = start + l; \
+ while (start < stop) *start++ = 0xff000000; \
+} while(0)
-/***********************************************************************
-**
-*/ REBINT CT_Image(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Image: C
+//
+REBINT CT_Image(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBINT e;
+ if (mode < 0)
+ return -1;
- if (mode < 0) return -1;
- if (mode == 3) return VAL_SERIES(a) == VAL_SERIES(b) && VAL_INDEX(a) == VAL_INDEX(b);
- e = VAL_IMAGE_WIDE(a) == VAL_IMAGE_WIDE(a) && VAL_IMAGE_HIGH(b) == VAL_IMAGE_HIGH(b);
- if (e) e = (0 == Cmp_Value(a, b, mode > 1));
- return e;
+ if (
+ VAL_IMAGE_WIDE(a) == VAL_IMAGE_WIDE(a)
+ && VAL_IMAGE_HIGH(b) == VAL_IMAGE_HIGH(b)
+ ) {
+ return (0 == Cmp_Value(a, b, LOGICAL(mode == 1))) ? 1 : 0;
+ }
+
+ return 0;
}
-/***********************************************************************
-**
-*/ REBFLG MT_Image(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+void Copy_Image_Value(REBVAL *out, const REBVAL *arg, REBINT len)
{
- if (!Create_Image(data, out, 1)) return FALSE;
- VAL_SET(out, REB_IMAGE);
- return TRUE;
+ len = MAX(len, 0); // no negatives
+ len = MIN(len, cast(REBINT, VAL_IMAGE_LEN(arg)));
+
+ REBINT w = VAL_IMAGE_WIDE(arg);
+ w = MAX(w, 1);
+
+ REBINT h;
+ if (len <= w) {
+ h = 1;
+ w = len;
+ }
+ else
+ h = len / w;
+
+ if (w == 0)
+ h = 0;
+
+ REBSER *series = Make_Image(w, h, TRUE);
+ Init_Image(out, series);
+ memcpy(VAL_IMAGE_HEAD(out), VAL_IMAGE_DATA(arg), w * h * 4);
}
-/***********************************************************************
-**
-*/ void Reset_Height(REBVAL *value)
-/*
-** Set height based on tail and width.
-**
-***********************************************************************/
+//
+// MAKE_Image: C
+//
+void MAKE_Image(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBCNT w = VAL_IMAGE_WIDE(value);
- VAL_IMAGE_HIGH(value) = w ? (VAL_TAIL(value) / w) : 0;
+ if (IS_IMAGE(arg)) {
+ //
+ // make image! img
+ //
+ Copy_Image_Value(out, arg, VAL_IMAGE_LEN(arg));
+ }
+ else if (IS_BLANK(arg) || (IS_BLOCK(arg) && VAL_ARRAY_LEN_AT(arg) == 0)) {
+ //
+ // make image! [] (or none)
+ //
+ Init_Image(out, Make_Image(0, 0, TRUE));
+ }
+ else if (IS_PAIR(arg)) {
+ //
+ // make image! size
+ //
+ REBINT w = VAL_PAIR_X_INT(arg);
+ REBINT h = VAL_PAIR_Y_INT(arg);
+ w = MAX(w, 0);
+ h = MAX(h, 0);
+ Init_Image(out, Make_Image(w, h, TRUE));
+ }
+ else if (IS_BLOCK(arg)) {
+ //
+ // make image! [size rgb alpha index]
+ //
+ RELVAL *item = VAL_ARRAY_AT(arg);
+
+ if (!IS_PAIR(item)) goto bad_make;
+
+ REBINT w = VAL_PAIR_X_INT(item);
+ REBINT h = VAL_PAIR_Y_INT(item);
+ if (w < 0 || h < 0) goto bad_make;
+
+ REBSER *img = Make_Image(w, h, FALSE);
+ if (!img) goto bad_make;
+
+ Init_Image(out, img);
+
+ REBYTE *ip = IMG_DATA(img); // image pointer
+ REBCNT size = w * h;
+
+ ++item;
+
+ if (IS_END(item)) {
+ //
+ // make image! [10x20]... already done
+ }
+ else if (IS_BINARY(item)) {
+
+ // Load image data:
+ Bin_To_RGB(ip, size, VAL_BIN_AT(item), VAL_LEN_AT(item) / 3);
+ ++item;
+
+ // !!! Review handling of END here; was not explicit before and
+ // just fell through the binary and integer tests...
+
+ // Load alpha channel data:
+ if (NOT_END(item) && IS_BINARY(item)) {
+ Bin_To_Alpha(ip, size, VAL_BIN_AT(item), VAL_LEN_AT(item));
+ // VAL_IMAGE_TRANSP(value)=VITT_ALPHA;
+ ++item;
+ }
+
+ if (NOT_END(item) && IS_INTEGER(item)) {
+ VAL_INDEX(out) = (Int32s(KNOWN(item), 1) - 1);
+ ++item;
+ }
+ }
+ else if (IS_TUPLE(item)) {
+ Fill_Rect(cast(REBCNT*, ip), TO_PIXEL_TUPLE(item), w, w, h, TRUE);
+ ++item;
+ if (IS_INTEGER(item)) {
+ Fill_Alpha_Rect(
+ cast(REBCNT*, ip), cast(REBYTE, VAL_INT32(item)), w, w, h
+ );
+ // VAL_IMAGE_TRANSP(value)=VITT_ALPHA;
+ ++item;
+ }
+ }
+ else if (IS_BLOCK(item)) {
+ REBCNT bad_index;
+ if (Array_Has_Non_Tuple(&bad_index, item)) {
+ REBSPC *derived = Derive_Specifier(VAL_SPECIFIER(arg), item);
+ fail (Error_Invalid_Arg_Core(
+ VAL_ARRAY_AT_HEAD(item, bad_index),
+ derived
+ ));
+ }
+
+ Tuples_To_RGBA(
+ ip, size, KNOWN(VAL_ARRAY_AT(item)), VAL_LEN_AT(item)
+ );
+ }
+ else
+ goto bad_make;
+
+ assert(IS_IMAGE(out));
+ }
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(arg)));
+
+ return;
+
+bad_make:
+ fail (Error_Bad_Make(kind, arg));
}
-/***********************************************************************
-**
-*/ void Set_Pixel_Tuple(REBYTE *dp, REBVAL *tuple)
-/*
-***********************************************************************/
+//
+// TO_Image: C
+//
+void TO_Image(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- // Tuple to pixel.
- REBYTE *tup = VAL_TUPLE(tuple);
+ assert(kind == REB_IMAGE);
+ UNUSED(kind);
+
+ if (IS_IMAGE(arg)) {
+ Copy_Image_Value(out, arg, VAL_IMAGE_LEN(arg));
+ }
+ else if (IS_GOB(arg)) {
+ REBVAL *image = OS_GOB_TO_IMAGE(VAL_GOB(arg));
+ if (image == NULL)
+ fail (Error_Bad_Make(REB_IMAGE, arg)); // not GUI build...
+ Move_Value(out, image); // what are the GC semantics here?
+ }
+ else if (IS_BINARY(arg)) {
+ REBINT diff = VAL_LEN_AT(arg) / 4;
+ if (diff == 0)
+ fail (Error_Bad_Make(REB_IMAGE, arg));
+
+ REBINT w;
+ if (diff < 100) w = diff;
+ else if (diff < 10000) w = 100;
+ else w = 500;
+
+ REBINT h = diff / w;
+ if (w * h < diff) h++; // partial line
+
+ REBSER *series = Make_Image(w, h, TRUE);
+ Init_Image(out, series);
+ Bin_To_RGBA(
+ IMG_DATA(series),
+ w * h,
+ VAL_BIN_AT(arg),
+ VAL_LEN_AT(arg) / 4,
+ FALSE
+ );
+ }
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(arg)));
+}
- dp[C_R] = tup[0];
- dp[C_G] = tup[1];
- dp[C_B] = tup[2];
- if (VAL_TUPLE_LEN(tuple) > 3) dp[C_A] = tup[3];
+
+//
+// Reset_Height: C
+//
+// Set height based on tail and width.
+//
+void Reset_Height(REBVAL *value)
+{
+ REBCNT w = VAL_IMAGE_WIDE(value);
+ VAL_IMAGE_HIGH(value) = w ? (VAL_LEN_HEAD(value) / w) : 0;
}
-/***********************************************************************
-**
-*/ void Set_Tuple_Pixel(REBYTE *dp, REBVAL *tuple)
-/*
-***********************************************************************/
+//
+// Set_Pixel_Tuple: C
+//
+void Set_Pixel_Tuple(REBYTE *dp, const REBVAL *tuple)
{
- // Pixel to tuple.
- REBYTE *tup = VAL_TUPLE(tuple);
-
- VAL_SET(tuple, REB_TUPLE);
- VAL_TUPLE_LEN(tuple) = 4;
- tup[0] = dp[C_R];
- tup[1] = dp[C_G];
- tup[2] = dp[C_B];
- tup[3] = dp[C_A];
+ // Tuple to pixel.
+ const REBYTE *tup = VAL_TUPLE(tuple);
+
+ dp[C_R] = tup[0];
+ dp[C_G] = tup[1];
+ dp[C_B] = tup[2];
+ if (VAL_TUPLE_LEN(tuple) > 3)
+ dp[C_A] = tup[3];
+ else
+ dp[C_A] = 0xff;
}
-/***********************************************************************
-**
-*/ void Fill_Line(REBCNT *ip, REBCNT color, REBCNT len, REBOOL only)
-/*
-***********************************************************************/
+//
+// Set_Tuple_Pixel: C
+//
+void Set_Tuple_Pixel(REBYTE *dp, REBVAL *tuple)
{
- if (only) // only RGB, do not touch Alpha
- for (; len > 0; len--, ip++) *ip = (*ip & 0xff000000) | color;
- else
- for (; len > 0; len--) *ip++ = color;
+ // Pixel to tuple.
+ REBYTE *tup = VAL_TUPLE(tuple);
+
+ VAL_RESET_HEADER(tuple, REB_TUPLE);
+ VAL_TUPLE_LEN(tuple) = 4;
+ tup[0] = dp[C_R];
+ tup[1] = dp[C_G];
+ tup[2] = dp[C_B];
+ tup[3] = dp[C_A];
}
+//
+// Fill_Line: C
+//
+void Fill_Line(REBCNT *ip, REBCNT color, REBCNT len, REBOOL only)
+{
+ if (only) {// only RGB, do not touch Alpha
+ color &= 0xffffff;
+ for (; len > 0; len--, ip++) *ip = (*ip & 0xff000000) | color;
+ } else
+ for (; len > 0; len--) *ip++ = color;
+}
-/***********************************************************************
-**
-*/ void Fill_Rect(REBCNT *ip, REBCNT color, REBCNT w, REBINT dupx, REBINT dupy, REBOOL only)
-/*
-***********************************************************************/
+
+//
+// Fill_Rect: C
+//
+void Fill_Rect(REBCNT *ip, REBCNT color, REBCNT w, REBINT dupx, REBINT dupy, REBOOL only)
{
- for (; dupy > 0; dupy--, ip += w)
- Fill_Line(ip, color, dupx, only);
+ for (; dupy > 0; dupy--, ip += w)
+ Fill_Line(ip, color, dupx, only);
}
-/***********************************************************************
-**
-*/ void Fill_Alpha_Line(REBYTE *rgba, REBYTE alpha, REBINT len)
-/*
-***********************************************************************/
+//
+// Fill_Alpha_Line: C
+//
+void Fill_Alpha_Line(REBYTE *rgba, REBYTE alpha, REBINT len)
{
- for (; len > 0; len--, rgba += 4)
- rgba[C_A] = alpha;
+ for (; len > 0; len--, rgba += 4)
+ rgba[C_A] = alpha;
}
-/***********************************************************************
-**
-*/ void Fill_Alpha_Rect(REBCNT *ip, REBYTE alpha, REBINT w, REBINT dupx, REBINT dupy)
-/*
-***********************************************************************/
+//
+// Fill_Alpha_Rect: C
+//
+void Fill_Alpha_Rect(REBCNT *ip, REBYTE alpha, REBINT w, REBINT dupx, REBINT dupy)
{
- for (; dupy > 0; dupy--, ip += w)
- Fill_Alpha_Line((REBYTE *)ip, alpha, dupx);
+ for (; dupy > 0; dupy--, ip += w)
+ Fill_Alpha_Line((REBYTE *)ip, alpha, dupx);
}
-/***********************************************************************
-**
-*/ REBCNT *Find_Color(REBCNT *ip, REBCNT color, REBCNT len, REBOOL only)
-/*
-***********************************************************************/
+//
+// Find_Color: C
+//
+REBCNT *Find_Color(REBCNT *ip, REBCNT color, REBCNT len, REBOOL only)
{
- if (only) { // only RGB, do not touch Alpha
- for (; len > 0; len--, ip++)
- if (color == (*ip & 0x00ffffff)) return ip;
- } else {
- for (; len > 0; len--, ip++)
- if (color == *ip) return ip;
- }
- return 0;
+ if (only) { // only RGB, do not touch Alpha
+ for (; len > 0; len--, ip++)
+ if (color == (*ip & 0x00ffffff)) return ip;
+ } else {
+ for (; len > 0; len--, ip++)
+ if (color == *ip) return ip;
+ }
+ return 0;
}
-/***********************************************************************
-**
-*/ REBCNT *Find_Alpha(REBCNT *ip, REBCNT alpha, REBCNT len)
-/*
-***********************************************************************/
+//
+// Find_Alpha: C
+//
+REBCNT *Find_Alpha(REBCNT *ip, REBCNT alpha, REBCNT len)
{
- for (; len > 0; len--, ip++) {
- if (alpha == (*ip >> 24)) return ip;
- }
- return 0;
+ for (; len > 0; len--, ip++) {
+ if (alpha == (*ip >> 24)) return ip;
+ }
+ return 0;
}
-/***********************************************************************
-**
-*/ void RGB_To_Bin(REBYTE *bin, REBYTE *rgba, REBINT len, REBOOL alpha)
-/*
-***********************************************************************/
+//
+// RGB_To_Bin: C
+//
+void RGB_To_Bin(REBYTE *bin, REBYTE *rgba, REBINT len, REBOOL alpha)
{
- // Convert internal image (integer) to RGB/A order binary string:
- if (alpha) {
- for (; len > 0; len--, rgba += 4, bin += 4) {
- bin[0] = rgba[C_R];
- bin[1] = rgba[C_G];
- bin[2] = rgba[C_B];
- bin[3] = rgba[C_A];
- }
- } else {
- // Only the RGB part:
- for (; len > 0; len--, rgba += 4, bin += 3) {
- bin[0] = rgba[C_R];
- bin[1] = rgba[C_G];
- bin[2] = rgba[C_B];
- }
- }
+ // Convert internal image (integer) to RGB/A order binary string:
+ if (alpha) {
+ for (; len > 0; len--, rgba += 4, bin += 4) {
+ bin[0] = rgba[C_R];
+ bin[1] = rgba[C_G];
+ bin[2] = rgba[C_B];
+ bin[3] = rgba[C_A];
+ }
+ } else {
+ // Only the RGB part:
+ for (; len > 0; len--, rgba += 4, bin += 3) {
+ bin[0] = rgba[C_R];
+ bin[1] = rgba[C_G];
+ bin[2] = rgba[C_B];
+ }
+ }
}
-/***********************************************************************
-**
-*/ void Bin_To_RGB(REBYTE *rgba, REBCNT size, REBYTE *bin, REBCNT len)
-/*
-***********************************************************************/
+//
+// Bin_To_RGB: C
+//
+void Bin_To_RGB(REBYTE *rgba, REBCNT size, REBYTE *bin, REBCNT len)
{
- if (len > size) len = size; // avoid over-run
-
- // Convert RGB binary string to internal image (integer), no alpha:
- for (; len > 0; len--, rgba += 4, bin += 3) {
- rgba[C_R] = bin[0];
- rgba[C_G] = bin[1];
- rgba[C_B] = bin[2];
- }
+ if (len > size) len = size; // avoid over-run
+
+ // Convert RGB binary string to internal image (integer), no alpha:
+ for (; len > 0; len--, rgba += 4, bin += 3) {
+ rgba[C_R] = bin[0];
+ rgba[C_G] = bin[1];
+ rgba[C_B] = bin[2];
+ }
}
-/***********************************************************************
-**
-*/ void Bin_To_RGBA(REBYTE *rgba, REBCNT size, REBYTE *bin, REBINT len, REBOOL only)
-/*
-***********************************************************************/
+//
+// Bin_To_RGBA: C
+//
+void Bin_To_RGBA(REBYTE *rgba, REBCNT size, REBYTE *bin, REBINT len, REBOOL only)
{
- if (len > (REBINT)size) len = size; // avoid over-run
-
- // Convert from BGRA format to internal image (integer):
- for (; len > 0; len--, rgba += 4, bin += 4) {
- rgba[C_B] = bin[0];
- rgba[C_G] = bin[1];
- rgba[C_R] = bin[2];
- if (!only) rgba[C_A] = bin[3];
- }
+ if (len > (REBINT)size) len = size; // avoid over-run
+
+ // Convert from RGBA format to internal image (integer):
+ for (; len > 0; len--, rgba += 4, bin += 4) {
+ rgba[C_R] = bin[0];
+ rgba[C_G] = bin[1];
+ rgba[C_B] = bin[2];
+ if (!only) rgba[C_A] = bin[3];
+ }
}
-/***********************************************************************
-**
-*/ void Alpha_To_Bin(REBYTE *bin, REBYTE *rgba, REBINT len)
-/*
-***********************************************************************/
+//
+// Alpha_To_Bin: C
+//
+void Alpha_To_Bin(REBYTE *bin, REBYTE *rgba, REBINT len)
{
- for (; len > 0; len--, rgba += 4)
- *bin++ = rgba[C_A];
+ for (; len > 0; len--, rgba += 4)
+ *bin++ = rgba[C_A];
}
-/***********************************************************************
-**
-*/ void Bin_To_Alpha(REBYTE *rgba, REBCNT size, REBYTE *bin, REBINT len)
-/*
-***********************************************************************/
+//
+// Bin_To_Alpha: C
+//
+void Bin_To_Alpha(REBYTE *rgba, REBCNT size, REBYTE *bin, REBINT len)
{
- if (len > (REBINT)size) len = size; // avoid over-run
+ if (len > (REBINT)size) len = size; // avoid over-run
- for (; len > 0; len--, rgba += 4)
- rgba[C_A] = *bin++;
+ for (; len > 0; len--, rgba += 4)
+ rgba[C_A] = *bin++;
}
-/***********************************************************************
-**
-*/ REBFLG Valid_Tuples(REBVAL *blk)
-/*
-***********************************************************************/
+//
+// Array_Has_Non_Tuple: C
+//
+// Checks the given ANY-ARRAY! REBVAL from its current index position to
+// the end to see if any of its contents are not TUPLE!. If so, returns
+// TRUE and `index_out` will contain the index position from the head of
+// the array of the non-tuple. Otherwise returns FALSE.
+//
+REBOOL Array_Has_Non_Tuple(REBCNT *index_out, RELVAL *blk)
{
- REBCNT n = VAL_INDEX(blk);
- REBCNT len = VAL_LEN(blk);
+ REBCNT len;
+
+ assert(ANY_ARRAY(blk));
- blk = VAL_BLK_DATA(blk);
+ len = VAL_LEN_HEAD(blk);
+ *index_out = VAL_INDEX(blk);
- for (; n < len; n++)
- if (!IS_TUPLE(blk+n)) return n+1;
+ for (; *index_out < len; (*index_out)++)
+ if (!IS_TUPLE(VAL_ARRAY_AT_HEAD(blk, *index_out)))
+ return TRUE;
- return 0;
+ return FALSE;
}
-/***********************************************************************
-**
-*/ void Tuples_To_RGBA(REBYTE *rgba, REBCNT size, REBVAL *blk, REBCNT len)
-/*
-***********************************************************************/
+//
+// Tuples_To_RGBA: C
+//
+void Tuples_To_RGBA(REBYTE *rgba, REBCNT size, REBVAL *blk, REBCNT len)
{
- REBYTE *bin;
+ REBYTE *bin;
- if (len > size) len = size; // avoid over-run
+ if (len > size) len = size; // avoid over-run
- for (; len > 0; len--, rgba += 4, blk++) {
- bin = VAL_TUPLE(blk);
- rgba[C_R] = bin[0];
- rgba[C_G] = bin[1];
- rgba[C_B] = bin[2];
- rgba[C_A] = bin[3];
- }
+ for (; len > 0; len--, rgba += 4, blk++) {
+ bin = VAL_TUPLE(blk);
+ rgba[C_R] = bin[0];
+ rgba[C_G] = bin[1];
+ rgba[C_B] = bin[2];
+ rgba[C_A] = bin[3];
+ }
}
-/***********************************************************************
-**
-*/ void Image_To_BGRA(REBYTE *rgba, REBYTE *bin, REBINT len)
-/*
-***********************************************************************/
+//
+// Image_To_RGBA: C
+//
+void Image_To_RGBA(REBYTE *rgba, REBYTE *bin, REBINT len)
{
- // Convert from BGRA format to internal image (integer):
- for (; len > 0; len--, rgba += 4, bin += 4) {
- bin[0] = rgba[C_B];
- bin[1] = rgba[C_G];
- bin[2] = rgba[C_R];
- bin[3] = rgba[C_A];
- }
+ // Convert from internal image (integer) to RGBA binary order:
+ for (; len > 0; len--, rgba += 4, bin += 4) {
+ bin[0] = rgba[C_R];
+ bin[1] = rgba[C_G];
+ bin[2] = rgba[C_B];
+ bin[3] = rgba[C_A];
+ }
}
-#ifdef ndef
-INLINE REBCNT ARGB_To_BGR(REBCNT i)
+#ifdef NEED_ARGB_TO_BGR
+REBCNT ARGB_To_BGR(REBCNT i)
{
- return
- ((i & 0x00ff0000) >> 16) | // red
- ((i & 0x0000ff00)) | // green
- ((i & 0x000000ff) << 16); // blue
+ return
+ ((i & 0x00ff0000) >> 16) | // red
+ ((i & 0x0000ff00)) | // green
+ ((i & 0x000000ff) << 16); // blue
}
#endif
-/***********************************************************************
-**
-*/ void Mold_Image_Data(REBVAL *value, REB_MOLD *mold)
-/*
-***********************************************************************/
+//
+// Mold_Image_Data: C
+//
+void Mold_Image_Data(const REBVAL *value, REB_MOLD *mold)
{
- REBUNI *up;
- REBCNT len;
- REBCNT size;
- REBCNT *data;
+ REBUNI *up;
+ REBCNT len;
+ REBCNT size;
+ REBCNT *data;
+ REBYTE* pixel;
- Emit(mold, "IxI #{", VAL_IMAGE_WIDE(value), VAL_IMAGE_HIGH(value));
+ Emit(mold, "IxI #{", VAL_IMAGE_WIDE(value), VAL_IMAGE_HIGH(value));
- // Output RGB image:
- size = VAL_IMAGE_LEN(value); // # pixels (from index to tail)
- data = (REBCNT *)VAL_IMAGE_DATA(value);
- up = Prep_Uni_Series(mold, (size * 6) + (size / 10) + 1);
+ // Output RGB image:
+ size = VAL_IMAGE_LEN(value); // # pixels (from index to tail)
+ data = (REBCNT *)VAL_IMAGE_DATA(value);
+ up = Prep_Uni_Series(mold, (size * 6) + (size / 10) + 1);
- for (len = 0; len < size; len++) {
- if ((len % 10) == 0) *up++ = LF;
- up = Form_RGB_Uni(up, *data++);
- }
+ for (len = 0; len < size; len++) {
+ pixel = (REBYTE*)data++;
+ if ((len % 10) == 0) *up++ = LF;
+ up = Form_RGB_Uni(up, TO_RGBA_COLOR(pixel[C_R],pixel[C_G],pixel[C_B],pixel[C_A]));
+ }
- // Output Alpha channel, if it has one:
- if (Image_Has_Alpha(value, FALSE)) {
+ // Output Alpha channel, if it has one:
+ if (Image_Has_Alpha(value)) {
- Append_Bytes(mold->series, "\n} #{");
+ Append_Unencoded(mold->series, "\n} #{");
- up = Prep_Uni_Series(mold, (size * 2) + (size / 10) + 1);
+ up = Prep_Uni_Series(mold, (size * 2) + (size / 10) + 1);
- data = (REBCNT *)VAL_IMAGE_DATA(value);
- for (len = 0; len < size; len++) {
- if ((len % 10) == 0) *up++ = LF;
- up = Form_Hex2_Uni(up, *data++ >> 24);
- }
- }
- *up = 0; // tail already set from Prep.
+ data = (REBCNT *)VAL_IMAGE_DATA(value);
+ for (len = 0; len < size; len++) {
+ if ((len % 10) == 0) *up++ = LF;
+ up = Form_Hex2_Uni(up, *data++ >> 24);
+ }
+ }
+ *up = 0; // tail already set from Prep.
- Append_Bytes(mold->series, "\n}");
+ Append_Unencoded(mold->series, "\n}");
}
-/***********************************************************************
-**
-*/ REBSER *Make_Image_Binary(REBVAL *image)
-/*
-***********************************************************************/
+//
+// Make_Image_Binary: C
+//
+REBSER *Make_Image_Binary(const REBVAL *image)
{
- REBSER *ser;
-
-#ifdef XENDIAN_BIG
- ser = Make_Quad(0, VAL_IMAGE_LEN(image));
- ser->tail = VAL_IMAGE_LEN(image) * 4;
- Image_To_BGRA(VAL_IMAGE_DATA(image), QUAD_HEAD(ser), VAL_IMAGE_LEN(image));
-#else
- ser = Copy_Bytes(VAL_IMAGE_DATA(image), VAL_IMAGE_LEN(image)*4);
-#endif
- return ser;
+ REBSER *ser;
+ REBINT len;
+ len = VAL_IMAGE_LEN(image) * 4;
+ ser = Make_Binary(len);
+ SET_SERIES_LEN(ser, len);
+ Image_To_RGBA(VAL_IMAGE_DATA(image), QUAD_HEAD(ser), VAL_IMAGE_LEN(image));
+ return ser;
}
-/***********************************************************************
-**
-*/ REBSER *Make_Image(REBCNT w, REBCNT h, REBFLG error)
-/*
-** Allocate and initialize an image.
-** If error is TRUE, throw error on bad size.
-** Return zero on oversized image.
-**
-***********************************************************************/
+//
+// Make_Image: C
+//
+// Allocate and initialize an image.
+// If error is TRUE, throw error on bad size.
+// Return zero on oversized image.
+//
+REBSER *Make_Image(REBCNT w, REBCNT h, REBOOL error)
{
- REBSER *img;
-
- if (w > 0xFFFF || h > 0xFFFF) {
- if (error) Trap1(RE_SIZE_LIMIT, Get_Type(REB_IMAGE));
- else return 0;
- }
-
- img = Make_Series(w * h + 1, sizeof(REBINT), FALSE);
- LABEL_SERIES(img, "make image");
- img->tail = w * h;
- CLEAR(img->data, (img->tail + 1) * sizeof(REBINT));
- IMG_WIDE(img) = w;
- IMG_HIGH(img) = h;
- return img;
+ if (w > 0xFFFF || h > 0xFFFF) {
+ if (error)
+ fail (Error_Size_Limit_Raw(Get_Type(REB_IMAGE)));
+ return NULL;
+ }
+
+ REBSER *img = Make_Series(w * h + 1, sizeof(u32));
+ SET_SERIES_LEN(img, w * h);
+ RESET_IMAGE(SER_DATA_RAW(img), SER_LEN(img)); //length in 'pixels'
+ IMG_WIDE(img) = w;
+ IMG_HIGH(img) = h;
+ return img;
}
-/***********************************************************************
-**
-*/ void Clear_Image(REBVAL *img)
-/*
-** Clear image data.
-**
-***********************************************************************/
+//
+// Clear_Image: C
+//
+// Clear image data.
+//
+void Clear_Image(REBVAL *img)
{
- REBCNT w = VAL_IMAGE_WIDE(img);
- REBCNT h = VAL_IMAGE_HIGH(img);
- REBYTE *p = VAL_IMAGE_HEAD(img);
- CLEAR_IMAGE(p, w, h);
+ REBCNT w = VAL_IMAGE_WIDE(img);
+ REBCNT h = VAL_IMAGE_HIGH(img);
+ REBYTE *p = VAL_IMAGE_HEAD(img);
+ CLEAR_IMAGE(p, w, h);
}
-/***********************************************************************
-**
-*/ REBVAL *Create_Image(REBVAL *block, REBVAL *val, REBCNT modes)
-/*
-** Create an image value from components block [pair rgb alpha].
-**
-***********************************************************************/
+//
+// Modify_Image: C
+//
+// Insert or change image
+//
+REBVAL *Modify_Image(REBFRM *frame_, REBCNT action)
{
- REBINT w, h;
- REBYTE *ip; // image pointer
- REBCNT size;
- REBSER *img;
-
- // Check that PAIR is valid:
- if (!IS_PAIR(block)) return 0;
- w = VAL_PAIR_X_INT(block);
- h = VAL_PAIR_Y_INT(block);
- if (w < 0 || h < 0) return 0;
-
- img = Make_Image(w, h, FALSE);
- if (img == 0) return 0;
- SET_IMAGE(val, img);
-
- ip = IMG_DATA(img);
- size = w * h;
-
- //len = VAL_BLK_LEN(arg);
- block++;
- if (IS_BINARY(block)) {
-
- // Load image data:
- Bin_To_RGB(ip, size, VAL_BIN_DATA(block), VAL_LEN(block) / 3);
- block++;
-
- // Load alpha channel data:
- if (IS_BINARY(block)) {
- Bin_To_Alpha(ip, size, VAL_BIN_DATA(block), VAL_LEN(block));
-// VAL_IMAGE_TRANSP(value)=VITT_ALPHA;
- block++;
- }
-
- if (IS_INTEGER(block)) {
- VAL_INDEX(val) = (Int32s(block, 1) - 1);
- block++;
- }
- }
- else if (IS_TUPLE(block)) {
- Fill_Rect((REBCNT *)ip, TO_COLOR_TUPLE(block), w, w, h, TRUE);
- block++;
- if (IS_INTEGER(block)) {
- Fill_Alpha_Rect((REBCNT *)ip, (REBYTE)VAL_INT32(block), w, w, h);
-// VAL_IMAGE_TRANSP(value)=VITT_ALPHA;
- block++;
- }
- }
- else if (IS_BLOCK(block)) {
- if (w = Valid_Tuples(block)) Trap_Arg(block+w-1);
- Tuples_To_RGBA(ip, size, VAL_BLK_DATA(block), VAL_LEN(block));
- }
- else if (!IS_END(block)) return 0;
-
- //if (!IS_END(block)) Trap_Arg(block);
-
- return val;
+ INCLUDE_PARAMS_OF_INSERT; // currently must have same frame as CHANGE
+
+ REBVAL *value = ARG(series); // !!! confusing, very old (unused?) code!
+ REBVAL *arg = ARG(value);
+ REBVAL *len = ARG(limit); // void if no /PART
+ REBVAL *count = ARG(count); // void if no /DUP
+
+ REBINT part = 1; // /part len
+ REBINT partx, party;
+ REBINT dup = 1; // /dup count
+ REBINT dupx, dupy;
+ REBOOL only = FALSE; // /only
+ REBCNT index = VAL_INDEX(value);
+ REBCNT tail = VAL_LEN_HEAD(value);
+ REBCNT n;
+ REBINT x;
+ REBINT w;
+ REBINT y;
+ REBYTE *ip;
+
+ if (!(w = VAL_IMAGE_WIDE(value))) return value;
+
+ if (action == SYM_APPEND) {
+ index = tail;
+ action = SYM_INSERT;
+ }
+
+ x = index % w; // offset on the line
+ y = index / w; // offset line
+
+ if (REF(only))
+ only = TRUE;
+
+ // Validate that block arg is all tuple values:
+ if (IS_BLOCK(arg) && Array_Has_Non_Tuple(&n, arg))
+ fail (Error_Invalid_Arg_Core(
+ VAL_ARRAY_AT_HEAD(arg, n), VAL_SPECIFIER(arg)
+ ));
+
+ if (REF(dup)) { // "it specifies fill size"
+ if (IS_INTEGER(count)) {
+ dup = VAL_INT32(count);
+ dup = MAX(dup, 0);
+ if (dup == 0) return value;
+ }
+ else if (IS_PAIR(count)) { // rectangular dup
+ dupx = VAL_PAIR_X_INT(count);
+ dupy = VAL_PAIR_Y_INT(count);
+ dupx = MAX(dupx, 0);
+ dupx = MIN(dupx, (REBINT)w - x); // clip dup width
+ dupy = MAX(dupy, 0);
+ if (action != SYM_INSERT)
+ dupy = MIN(dupy, (REBINT)VAL_IMAGE_HIGH(value) - y);
+ else
+ dup = dupy * w;
+ if (dupx == 0 || dupy == 0) return value;
+ }
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(count)));
+ }
+
+ if (REF(part)) { // only allowed when arg is a series
+ if (IS_BINARY(arg)) {
+ if (IS_INTEGER(len)) {
+ part = VAL_INT32(len);
+ } else if (IS_BINARY(len)) {
+ part = (VAL_INDEX(len) - VAL_INDEX(arg)) / 4;
+ } else
+ fail (len);
+ part = MAX(part, 0);
+ }
+ else if (IS_IMAGE(arg)) {
+ if (IS_INTEGER(len)) {
+ part = VAL_INT32(len);
+ part = MAX(part, 0);
+ }
+ else if (IS_IMAGE(len)) {
+ if (VAL_IMAGE_WIDE(len) == 0)
+ fail (len);
+
+ partx = VAL_INDEX(len) - VAL_INDEX(arg);
+ party = partx / VAL_IMAGE_WIDE(len);
+ party = MAX(party, 1);
+ partx = MIN(partx, (REBINT)VAL_IMAGE_WIDE(arg));
+ goto len_compute;
+ }
+ else if (IS_PAIR(len)) {
+ partx = VAL_PAIR_X_INT(len);
+ party = VAL_PAIR_Y_INT(len);
+ len_compute:
+ partx = MAX(partx, 0);
+ partx = MIN(partx, (REBINT)w - x); // clip part width
+ party = MAX(party, 0);
+ if (action != SYM_INSERT)
+ party = MIN(party, (REBINT)VAL_IMAGE_HIGH(value) - y);
+ else
+ part = party * w;
+ if (partx == 0 || party == 0) return value;
+ }
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(len)));
+ }
+ else
+ fail (arg); // /part not allowed
+ }
+ else {
+ if (IS_IMAGE(arg)) { // Use image for /part sizes
+ partx = VAL_IMAGE_WIDE(arg);
+ party = VAL_IMAGE_HIGH(arg);
+ partx = MIN(partx, (REBINT)w - x); // clip part width
+ if (action != SYM_INSERT)
+ party = MIN(party, (REBINT)VAL_IMAGE_HIGH(value) - y);
+ else
+ part = party * w;
+ }
+ else if (IS_BINARY(arg)) {
+ part = VAL_LEN_AT(arg) / 4;
+ }
+ else if (IS_BLOCK(arg)) {
+ part = VAL_LEN_AT(arg);
+ }
+ else if (!IS_INTEGER(arg) && !IS_TUPLE(arg))
+ fail (Error_Invalid_Type(VAL_TYPE(arg)));
+ }
+
+ // Expand image data if necessary:
+ if (action == SYM_INSERT) {
+ if (index > tail) index = tail;
+ Expand_Series(VAL_SERIES(value), index, dup * part);
+ RESET_IMAGE(VAL_BIN(value) + (index * 4), dup * part); //length in 'pixels'
+ Reset_Height(value);
+ tail = VAL_LEN_HEAD(value);
+ only = FALSE;
+ }
+ ip = VAL_IMAGE_HEAD(value);
+
+ // Handle the datatype of the argument.
+ if (IS_INTEGER(arg) || IS_TUPLE(arg)) { // scalars
+ if (index + dup > tail) dup = tail - index; // clip it
+ ip += index * 4;
+ if (IS_INTEGER(arg)) { // Alpha channel
+ REBINT arg_int = VAL_INT32(arg);
+ if ((arg_int < 0) || (arg_int > 255))
+ fail (Error_Out_Of_Range(arg));
+ if (IS_PAIR(count)) // rectangular fill
+ Fill_Alpha_Rect(
+ cast(REBCNT*, ip), cast(REBYTE, arg_int), w, dupx, dupy
+ );
+ else
+ Fill_Alpha_Line(ip, cast(REBYTE, arg_int), dup);
+ }
+ else if (IS_TUPLE(arg)) { // RGB
+ if (IS_PAIR(count)) // rectangular fill
+ Fill_Rect((REBCNT *)ip, TO_PIXEL_TUPLE(arg), w, dupx, dupy, only);
+ else
+ Fill_Line((REBCNT *)ip, TO_PIXEL_TUPLE(arg), dup, only);
+ }
+ } else if (IS_IMAGE(arg)) {
+ Copy_Rect_Data(value, x, y, partx, party, arg, 0, 0); // dst dx dy w h src sx sy
+ }
+ else if (IS_BINARY(arg)) {
+ if (index + part > tail) part = tail - index; // clip it
+ ip += index * 4;
+ for (; dup > 0; dup--, ip += part * 4)
+ Bin_To_RGBA(ip, part, VAL_BIN_AT(arg), part, only);
+ }
+ else if (IS_BLOCK(arg)) {
+ if (index + part > tail) part = tail - index; // clip it
+ ip += index * 4;
+ for (; dup > 0; dup--, ip += part * 4)
+ Tuples_To_RGBA(ip, part, KNOWN(VAL_ARRAY_AT(arg)), part);
+ }
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(arg)));
+
+ Reset_Height(value);
+
+ if (action == SYM_APPEND) VAL_INDEX(value) = 0;
+ return value;
}
-/***********************************************************************
-**
-*/ REBVAL *Modify_Image(REBVAL *ds, REBCNT action)
-/*
-** Insert or change image
-** ACTION value arg /part len /only /dup count
-**
-***********************************************************************/
+//
+// Find_Image: C
+//
+// Finds a value in a series and returns the series at the start of it. For
+// parameters of FIND, see the action definition.
+//
+// !!! old and very broken code, untested and probably (hopefully) not
+// used by R3-View... (?)
+//
+void Find_Image(REBFRM *frame_)
{
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBVAL *len = D_ARG(4);
- REBVAL *count = D_ARG(7);
- REBINT part = 1; // /part len
- REBINT partx, party;
- REBINT dup = 1; // /dup count
- REBINT dupx, dupy;
- REBOOL only = 0; // /only
- REBCNT index = VAL_INDEX(value);
- REBCNT tail = VAL_TAIL(value);
- REBINT n;
- REBINT x;
- REBINT w;
- REBINT y;
- REBYTE *ip;
-
- if (!(w = VAL_IMAGE_WIDE(value))) return value;
-
- if (action == A_APPEND) {
- index = tail;
- action = A_INSERT;
- }
-
- x = index % w; // offset on the line
- y = index / w; // offset line
-
- if (D_REF(5)) only = 1;
-
- // Validate that block arg is all tuple values:
- if (IS_BLOCK(arg) && NZ(n = Valid_Tuples(arg))) {
- Trap_Arg(VAL_BLK_SKIP(arg, n-1));
- }
-
- // Get the /dup refinement. It specifies fill size.
- if (D_REF(6)) {
- if (IS_INTEGER(count)) {
- dup = VAL_INT32(count);
- dup = MAX(dup, 0);
- if (dup == 0) return value;
- } else if (IS_PAIR(count)) { // rectangular dup
- dupx = VAL_PAIR_X_INT(count);
- dupy = VAL_PAIR_Y_INT(count);
- dupx = MAX(dupx, 0);
- dupx = MIN(dupx, (REBINT)w - x); // clip dup width
- dupy = MAX(dupy, 0);
- if (action != A_INSERT)
- dupy = MIN(dupy, (REBINT)VAL_IMAGE_HIGH(value) - y);
- else
- dup = dupy * w;
- if (dupx == 0 || dupy == 0) return value;
- } else
- Trap_Type(count);
- }
-
- // Get the /part refinement. Only allowed when arg is a series.
- if (D_REF(3)) {
- if (IS_BINARY(arg)) {
- if (IS_INTEGER(len)) {
- part = VAL_INT32(len);
- } else if (IS_BINARY(len)) {
- part = (VAL_INDEX(len) - VAL_INDEX(arg)) / 4;
- } else
- Trap_Arg(len);
- part = MAX(part, 0);
- } else if (IS_IMAGE(arg)) {
- if (IS_INTEGER(len)) {
- part = VAL_INT32(len);
- part = MAX(part, 0);
- } else if (IS_IMAGE(len)) {
- if (!VAL_IMAGE_WIDE(len)) Trap_Arg(len);
- partx = VAL_INDEX(len) - VAL_INDEX(arg);
- party = partx / VAL_IMAGE_WIDE(len);
- party = MAX(party, 1);
- partx = MIN(partx, (REBINT)VAL_IMAGE_WIDE(arg));
- goto len_compute;
- } else if (IS_PAIR(len)) {
- partx = VAL_PAIR_X_INT(len);
- party = VAL_PAIR_Y_INT(len);
- len_compute:
- partx = MAX(partx, 0);
- partx = MIN(partx, (REBINT)w - x); // clip part width
- party = MAX(party, 0);
- if (action != A_INSERT)
- party = MIN(party, (REBINT)VAL_IMAGE_HIGH(value) - y);
- else
- part = party * w;
- if (partx == 0 || party == 0) return value;
- } else
- Trap_Type(len);
- } else
- Trap_Arg(arg); // /part not allowed
- } else {
- if (IS_IMAGE(arg)) { // Use image for /part sizes
- partx = VAL_IMAGE_WIDE(arg);
- party = VAL_IMAGE_HIGH(arg);
- partx = MIN(partx, (REBINT)w - x); // clip part width
- if (action != A_INSERT)
- party = MIN(party, (REBINT)VAL_IMAGE_HIGH(value) - y);
- else
- part = party * w;
- } else if (IS_BINARY(arg)) {
- part = VAL_LEN(arg) / 4;
- } else if (IS_BLOCK(arg)) {
- part = VAL_LEN(arg);
- } else if (! (IS_INTEGER(arg) || IS_TUPLE(arg)))
- Trap_Type(arg);
- }
-
- // Expand image data if necessary:
- if (action == A_INSERT) {
- if (index > tail) index = tail;
- Expand_Series(VAL_SERIES(value), index, dup * part);
- CLEAR(VAL_BIN(value) + (index * 4), dup * part * 4);
- Reset_Height(value);
- tail = VAL_TAIL(value);
- only = 0;
- }
- ip = VAL_IMAGE_HEAD(value);
-
- // Handle the datatype of the argument.
- if (IS_INTEGER(arg) || IS_TUPLE(arg)) { // scalars
- if (index + dup > tail) dup = tail - index; // clip it
- ip += index * 4;
- if (IS_INTEGER(arg)) { // Alpha channel
- n = VAL_INT32(arg);
- if ((n < 0) || (n > 255)) Trap_Range(arg);
- if (IS_PAIR(count)) // rectangular fill
- Fill_Alpha_Rect((REBCNT *)ip, (REBYTE)n, w, dupx, dupy);
- else
- Fill_Alpha_Line(ip, (REBYTE)n, dup);
- } else if (IS_TUPLE(arg)) { // RGB
- if (IS_PAIR(count)) // rectangular fill
- Fill_Rect((REBCNT *)ip, TO_COLOR_TUPLE(arg), w, dupx, dupy, only);
- else
- Fill_Line((REBCNT *)ip, TO_COLOR_TUPLE(arg), dup, only);
- }
- } else if (IS_IMAGE(arg)) {
- Copy_Rect_Data(value, x, y, partx, party, arg, 0, 0); // dst dx dy w h src sx sy
- } else if (IS_BINARY(arg)) {
- if (index + part > tail) part = tail - index; // clip it
- ip += index * 4;
- for (; dup > 0; dup--, ip += part * 4)
- Bin_To_RGBA(ip, part, VAL_BIN_DATA(arg), part, only);
- } else if (IS_BLOCK(arg)) {
- if (index + part > tail) part = tail - index; // clip it
- ip += index * 4;
- for (; dup > 0; dup--, ip += part * 4)
- Tuples_To_RGBA(ip, part, VAL_BLK_DATA(arg), part);
- } else Trap_Type(arg);
-
- Reset_Height(value);
-
- if (action == A_APPEND) VAL_INDEX(value) = 0;
- return value;
+ INCLUDE_PARAMS_OF_FIND;
+
+ REBVAL *value = ARG(series);
+ REBVAL *arg = ARG(value);
+ REBCNT index = VAL_INDEX(value);
+ REBCNT tail = VAL_LEN_HEAD(value);
+ REBCNT *ip = (REBCNT *)VAL_IMAGE_DATA(value); // NOTE ints not bytes
+ REBCNT *p;
+ REBINT n;
+
+ REBCNT len = tail - index;
+ if (len == 0) {
+ Init_Void(D_OUT);
+ return;
+ }
+
+ // !!! There is a general problem with refinements and actions in R3-Alpha
+ // in terms of reporting when a refinement was ignored. This is a
+ // problem that archetype-based dispatch will need to address.
+ //
+ if (
+ REF(case)
+ || REF(skip)
+ || REF(last)
+ || REF(match)
+ || REF(part)
+ || REF(reverse)
+ ){
+ UNUSED(PAR(limit));
+ UNUSED(PAR(size));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ REBOOL only; // initialization would be crossed by goto
+ only = FALSE;
+ if (IS_TUPLE(arg)) {
+ only = LOGICAL(VAL_TUPLE_LEN(arg) < 4);
+ if (REF(only)) only = TRUE;
+ p = Find_Color(ip, TO_PIXEL_TUPLE(arg), len, only);
+ }
+ else if (IS_INTEGER(arg)) {
+ n = VAL_INT32(arg);
+ if (n < 0 || n > 255) fail (Error_Out_Of_Range(arg));
+ p = Find_Alpha(ip, n, len);
+ }
+ else if (IS_IMAGE(arg)) {
+ p = 0;
+ }
+ else if (IS_BINARY(arg)) {
+ p = 0;
+ }
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(arg)));
+
+ if (p == 0) {
+ Init_Void(D_OUT);
+ return;
+ }
+
+ // Post process the search (failure or apply /match and /tail):
+
+ Move_Value(D_OUT, value);
+ n = (REBCNT)(p - (REBCNT *)VAL_IMAGE_HEAD(value));
+ if (REF(match)) {
+ if (n != cast(REBINT, index)) {
+ Init_Void(D_OUT);
+ return;
+ }
+ n++;
+ }
+ else
+ if (REF(tail))
+ ++n;
+
+ VAL_INDEX(value) = n;
+ return;
}
-/***********************************************************************
-**
-*/ REBVAL *Find_Image(REBVAL *ds)
-/*
-** Finds a value in a series and returns the series at the start of it.
-**
-** 1 image
-** 2 value [any-type!]
-** 3 /part {Limits the search to a given length or position.}
-** 4 range [number! series! port!]
-** 5 /only {ignore alpha value.}
-** 6 /case - ignored
-** 7 /any - ignored
-** 8 /with - ignored
-** 9 wild - ignored
-** 10 /skip - ignored
-** 11 size - ignored
-** 12 /match {Performs comparison and returns the tail of the match.}
-** 13 /tail {Returns the end of the string.}
-** 14 /last {Backwards from end of string.}
-** 15 /reverse {Backwards from the current position.}
-**
-***********************************************************************/
+//
+// Image_Has_Alpha: C
+//
+// !!! See code in R3-Alpha for VITT_ALPHA and the `save` flag.
+//
+REBOOL Image_Has_Alpha(const REBVAL *v)
{
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBCNT index = VAL_INDEX(value);
- REBCNT tail = VAL_TAIL(value);
- REBCNT len;
- REBCNT *ip = (REBCNT *)VAL_IMAGE_DATA(value); // NOTE ints not bytes
- REBCNT *p;
- REBINT n;
- REBOOL only = FALSE;
- REBYTE no_refs[10] = {5, 6, 7, 8, 9, 10, 13, 14}; // ref - 1 (invalid refinements)
-
- len = tail - index;
- if (!len) goto find_none;
-
- for (n = 0; n < 8; n++) // (zero based)
- if (D_REF((REBINT)no_refs[n]))
- Trap0(RE_BAD_REFINE);
-// Trap2(RE_CANNOT_USE, FRM_WORDS(me, (REBINT)no_refs[n]), Get_Global(REB_IMAGE));
-
- if (IS_TUPLE(arg)) {
- only = (REBOOL)(VAL_TUPLE_LEN(arg) < 4);
- if (D_REF(5)) only = TRUE; // /only flag
- p = Find_Color(ip, TO_COLOR_TUPLE(arg), len, only);
- } else if (IS_INTEGER(arg)) {
- n = VAL_INT32(arg);
- if (n < 0 || n > 255) Trap_Range(arg);
- p = Find_Alpha(ip, n, len);
- } else if (IS_IMAGE(arg)) {
- p = 0;
- } else if (IS_BINARY(arg)) {
- p = 0;
- } else
- Trap_Type(arg);
-
- // Post process the search (failure or apply /match and /tail):
- if (p) {
- n = (REBCNT)(p - (REBCNT *)VAL_IMAGE_HEAD(value));
- if (D_REF(11)) { // match
- if (n != (REBINT)index) goto find_none;
- n++;
- } else if (D_REF(12)) n++; // /tail
- index = n;
- VAL_INDEX(value) = index;
- return value;
- }
-find_none:
- return NONE_VALUE;
-}
+ REBCNT *p = cast(REBCNT*, VAL_IMAGE_HEAD(v));
+ int i = VAL_IMAGE_WIDE(v) * VAL_IMAGE_HIGH(v);
+ for(; i > 0; i--) {
+ if (~*p++ & 0xff000000)
+ return TRUE;
+ }
-/***********************************************************************
-**
-*/ REBFLG Image_Has_Alpha(REBVAL *v, REBFLG save)
-/*
-***********************************************************************/
-{
- int i;
- REBCNT *p;
-
-// if (VAL_IMAGE_TRANSP_TYPE(v)==VITT_NONE) return FALSE;
-// if (VAL_IMAGE_TRANSP_TYPE(v)==VITT_ALPHA) return TRUE;
-
- p = (REBCNT *)VAL_IMAGE_HEAD(v);
- i = VAL_IMAGE_WIDE(v)*VAL_IMAGE_HIGH(v);
- for(; i > 0; i--) {
- if (*p++ & 0xff000000) {
-// if (save) VAL_IMAGE_TRANSP(v) = VITT_ALPHA;
- return TRUE;
- }
- }
-// if (save) VAL_IMAGE_TRANSP(v) = VITT_NONE;
-
- return FALSE;
+ return FALSE;
}
-/***********************************************************************
-**
-*/ void Copy_Rect_Data(REBVAL *dst, REBINT dx, REBINT dy, REBINT w, REBINT h, REBVAL *src, REBINT sx, REBINT sy)
-/*
-***********************************************************************/
+//
+// Copy_Rect_Data: C
+//
+void Copy_Rect_Data(REBVAL *dst, REBINT dx, REBINT dy, REBINT w, REBINT h, REBVAL *src, REBINT sx, REBINT sy)
{
- REBCNT *sbits, *dbits;
+ REBCNT *sbits, *dbits;
- if (w <= 0 || h <= 0) return;
+ if (w <= 0 || h <= 0) return;
- // Clip at edges:
- if ((REBCNT)(dx + w) > VAL_IMAGE_WIDE(dst)) w = VAL_IMAGE_WIDE(dst) - dx;
- if ((REBCNT)(dy + h) > VAL_IMAGE_HIGH(dst)) h = VAL_IMAGE_HIGH(dst) - dy;
+ // Clip at edges:
+ if ((REBCNT)(dx + w) > VAL_IMAGE_WIDE(dst)) w = VAL_IMAGE_WIDE(dst) - dx;
+ if ((REBCNT)(dy + h) > VAL_IMAGE_HIGH(dst)) h = VAL_IMAGE_HIGH(dst) - dy;
- sbits = VAL_IMAGE_BITS(src) + sy * VAL_IMAGE_WIDE(src) + sx;
- dbits = VAL_IMAGE_BITS(dst) + dy * VAL_IMAGE_WIDE(dst) + dx;
- while (h--) {
- memcpy(dbits, sbits, w*4);
- sbits += VAL_IMAGE_WIDE(src);
- dbits += VAL_IMAGE_WIDE(dst);
- }
+ sbits = VAL_IMAGE_BITS(src) + sy * VAL_IMAGE_WIDE(src) + sx;
+ dbits = VAL_IMAGE_BITS(dst) + dy * VAL_IMAGE_WIDE(dst) + dx;
+ while (h--) {
+ memcpy(dbits, sbits, w*4);
+ sbits += VAL_IMAGE_WIDE(src);
+ dbits += VAL_IMAGE_WIDE(dst);
+ }
}
-#ifdef removed_feature
-/***********************************************************************
-**
-*/ static REBVAL* Xandor_Image(REBCNT action, REBVAL *value, REBVAL *arg)
-/*
-***********************************************************************/
-{
- REBCNT i;
- REBCNT *p3;
- REBCNT *p2 = (REBCNT*) VAL_IMAGE_BITS(value);
- REBCNT *p1 = (REBCNT*) VAL_IMAGE_BITS(arg);
- REBCNT tw, ow, aw;
- REBCNT th, oh, ah;
- REBCNT j;
-
- ow = VAL_IMAGE_WIDE(value);
- oh = VAL_IMAGE_HIGH(value);
- aw = VAL_IMAGE_WIDE(arg);
- ah = VAL_IMAGE_HIGH(arg);
- tw = MAX(ow, aw);
- th = MAX(oh, ah);
-
- *DS_RETURN = *Make_Image(tw, th);
- p3 = (REBCNT*) VAL_IMAGE_HEAD(DS_RETURN);
- CLEAR_IMAGE(p3, tw, th);
-
- for (i = 0; i < th; i++) {
- for (j = 0; j < tw; j++) {
- if (j < ow && i < oh && j < aw && i < ah)
- *(p3 + (i*tw) +j) = (REBCNT) (action == A_AND) ?
- *(p2 + (i*ow) + j) & *(p1 + (i*aw) + j) :
- (action == A_OR) ?
- *(p2 + (i*ow) + j) | *(p1 + (i*aw) + j) :
- *(p2 + (i*ow) + j) ^ *(p1 + (i*aw) + j) ;
- else {
- if (j < ow && i < oh) *(p3 + (i*tw) + j) = *(p2 + (i*ow) + j);
- if (j < aw && i < ah) *(p3 + (i*tw) + j) = *(p1 + (i*aw) + j);
- }
- }
- }
-
- return DS_RETURN;
-}
-#endif
-/***********************************************************************
-**
-*/ static REBSER *Complement_Image(REBVAL *value)
-/*
-***********************************************************************/
+//
+// Complement_Image: C
+//
+static REBSER *Complement_Image(REBVAL *value)
{
- REBCNT *img = (REBCNT*) VAL_IMAGE_DATA(value);
- REBCNT *out;
- REBINT len = VAL_IMAGE_LEN(value);
- REBSER *ser;
+ REBCNT *img = (REBCNT*) VAL_IMAGE_DATA(value);
+ REBCNT *out;
+ REBINT len = VAL_IMAGE_LEN(value);
+ REBSER *ser;
- ser = Make_Image(VAL_IMAGE_WIDE(value), VAL_IMAGE_HIGH(value), TRUE);
- out = (REBCNT*) IMG_DATA(ser);
+ ser = Make_Image(VAL_IMAGE_WIDE(value), VAL_IMAGE_HIGH(value), TRUE);
+ out = (REBCNT*) IMG_DATA(ser);
- for (; len > 0; len --) *out++ = ~ *img++;
+ for (; len > 0; len --) *out++ = ~ *img++;
- return ser;
+ return ser;
}
-/***********************************************************************
-**
-*/ REBTYPE(Image)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+REBTYPE(Image)
{
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBSER *series = VAL_SERIES(value);
- REBINT index = (REBINT)VAL_INDEX(value);
- REBINT tail;
- REBINT diff, len, w, h;
- REBVAL *val;
-
- // Clip index if past tail:
- if (action != A_MAKE && action != A_TO) {
- tail = (REBINT)SERIES_TAIL(series);
- if (index > tail) index = tail;
- }
-
- // Check must be in this order (to avoid checking a non-series value);
- if (action >= A_TAKE && action <= A_SORT && IS_PROTECT_SERIES(series))
- Trap0(RE_PROTECTED);
-
- // Dispatch action:
- switch (action) {
-
- case A_HEAD: VAL_INDEX(value) = 0; break;
- case A_TAIL: VAL_INDEX(value) = (REBCNT)tail; break;
- case A_HEADQ: DECIDE(index == 0);
- case A_TAILQ: DECIDE(index >= tail);
- case A_NEXT: if (index < tail) VAL_INDEX(value)++; break;
- case A_BACK: if (index > 0) VAL_INDEX(value)--; break;
-
-#ifdef removed_feature
- case A_AND:
- case A_OR:
- case A_XOR:
- if (IS_IMAGE(value) && IS_IMAGE(arg)) {
- Xandor_Image(action, value, arg); // sets DS_RETURN
- return R_RET;
- }
- else Trap_Action(VAL_TYPE(value), action);
-#endif
-
- case A_COMPLEMENT:
- series = Complement_Image(value);
- SET_IMAGE(value, series); // use series var not func
- break;
-
- case A_INDEXQ:
- if (D_REF(2)) {
- VAL_SET(D_RET, REB_PAIR);
- VAL_PAIR_X(D_RET) = (REBD32)(index % VAL_IMAGE_WIDE(value));
- VAL_PAIR_Y(D_RET) = (REBD32)(index / VAL_IMAGE_WIDE(value));
- return R_RET;
- } else {
- DS_RET_INT(index + 1);
- return R_RET;
- }
- case A_LENGTHQ:
- DS_RET_INT(tail > index ? tail - index : 0);
- return R_RET;
-
- case A_PICK:
- Pick_Path(value, arg, 0);
- return R_TOS;
-
- case A_POKE:
- Pick_Path(value, arg, D_ARG(3));
- return R_ARG3;
-
- case A_SKIP:
- case A_AT:
- // This logic is somewhat complicated by the fact that INTEGER args use
- // base-1 indexing, but PAIR args use base-0.
- if (IS_PAIR(arg)) {
- if (action == A_AT) action = A_SKIP;
- diff = (VAL_PAIR_Y_INT(arg) * VAL_IMAGE_WIDE(value) + VAL_PAIR_X_INT(arg)) +
- ((action == A_SKIP) ? 0 : 1);
- } else
- diff = Get_Num_Arg(arg);
-
- index += diff;
- if (action == A_SKIP) {
- if (IS_LOGIC(arg)) index--;
- } else {
- if (diff > 0) index--; // For at, pick, poke.
- }
-
- if (index > tail) index = tail;
- else if (index < 0) index = 0;
- VAL_INDEX(value) = (REBCNT)index;
- break;
+ REBVAL *value = D_ARG(1);
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+ REBSER *series;
+ REBINT index;
+ REBINT tail;
+ REBINT diff, len, w, h;
+ REBVAL *val;
+
+ // Clip index if past tail:
+ series = VAL_SERIES(value);
+ index = VAL_INDEX(value);
+ tail = (REBINT)SER_LEN(series);
+ if (index > tail) index = tail;
+
+ // Check must be in this order (to avoid checking a non-series value);
+ if (action >= SYM_TAKE_P && action <= SYM_SORT)
+ FAIL_IF_READ_ONLY_SERIES(series);
+
+ // Dispatch action:
+ switch (action) {
+
+ case SYM_HEAD_OF:
+ VAL_INDEX(value) = 0;
+ break;
+
+ case SYM_TAIL_OF:
+ VAL_INDEX(value) = (REBCNT)tail;
+ break;
+
+ case SYM_HEAD_Q:
+ return (index == 0) ? R_TRUE : R_FALSE;
+
+ case SYM_TAIL_Q:
+ return (index >= tail) ? R_TRUE : R_FALSE;
+
+ case SYM_COMPLEMENT:
+ series = Complement_Image(value);
+ Init_Image(value, series); // use series var not func
+ break;
+
+ case SYM_INDEX_OF: {
+ INCLUDE_PARAMS_OF_INDEX_OF;
+
+ UNUSED(PAR(series));
+
+ if (REF(xy)) {
+ SET_PAIR(
+ D_OUT,
+ index % VAL_IMAGE_WIDE(value),
+ index / VAL_IMAGE_WIDE(value)
+ );
+ return R_OUT;
+ }
+ else {
+ Init_Integer(D_OUT, index + 1);
+ return R_OUT;
+ }}
+ // fallthrough
+ case SYM_LENGTH_OF:
+ Init_Integer(D_OUT, tail > index ? tail - index : 0);
+ return R_OUT;
+
+ case SYM_SKIP:
+ case SYM_AT:
+ // This logic is somewhat complicated by the fact that INTEGER args use
+ // base-1 indexing, but PAIR args use base-0.
+ if (IS_PAIR(arg)) {
+ if (action == SYM_AT) action = SYM_SKIP;
+ diff = (VAL_PAIR_Y_INT(arg) * VAL_IMAGE_WIDE(value) + VAL_PAIR_X_INT(arg)) +
+ ((action == SYM_SKIP) ? 0 : 1);
+ } else
+ diff = Get_Num_From_Arg(arg);
+
+ index += diff;
+ if (action == SYM_SKIP) {
+ if (IS_LOGIC(arg)) index--;
+ } else {
+ if (diff > 0) index--; // For at, pick, poke.
+ }
+
+ if (index > tail)
+ index = tail;
+ else if (index < 0)
+ index = 0;
+ VAL_INDEX(value) = (REBCNT)index;
+ break;
#ifdef obsolete
- if (action == A_SKIP || action == A_AT) {
- }
-
- if (diff == 0 || index < 0 || index >= tail) {
- if (action == A_POKE)
- Trap_Range(arg);
- goto is_none;
- }
-
- if (action == A_POKE) {
- REBINT *dp = QUAD_SKIP(series, index));
- REBINT n;
-
- arg = D_ARG(3);
- if (IS_TUPLE(arg) && (IS_IMAGE(value))) {
- Set_Pixel_Tuple(QUAD_SKIP(series, index), arg);
- //*dp = (long) (VAL_TUPLE_LEN(arg) < 4) ?
- // ((*dp & 0xff000000) | (VAL_TUPLE(arg)[0] << 16) | (VAL_TUPLE(arg)[1] << 8) | (VAL_TUPLE(arg)[2])) :
- // ((VAL_TUPLE(arg)[3] << 24) | (VAL_TUPLE(arg)[0] << 16) | (VAL_TUPLE(arg)[1] << 8) | (VAL_TUPLE(arg)[2]));
- DS_RET_VALUE(arg);
- return R_RET;
- }
- if (IS_INTEGER(arg) && VAL_INT64(arg) > 0 && VAL_INT64(arg) < 255)
- n = VAL_INT32(arg);
- else if (IS_CHAR(arg))
- n = VAL_CHAR(arg);
- else
- Trap_Arg(arg);
-
- *dp = (*dp & 0xffffff) | (n << 24);
- DS_RET_VALUE(arg);
- return R_RET; //was value;
-
- } else {
- Set_Tuple_Pixel(QUAD_SKIP(series, index), D_RET);
- return R_RET;
- }
- break;
+ if (action == A_SKIP || action == A_AT) {
+ }
+
+ if (diff == 0 || index < 0 || index >= tail) {
+ if (action == A_POKE)
+ fail (Error_Out_Of_Range(arg));
+ goto is_blank;
+ }
+
+ if (action == A_POKE) {
+ REBINT *dp = QUAD_SKIP(series, index));
+ REBINT n;
+
+ arg = D_ARG(3);
+ if (IS_TUPLE(arg) && (IS_IMAGE(value))) {
+ Set_Pixel_Tuple(QUAD_SKIP(series, index), arg);
+ //*dp = (long) (VAL_TUPLE_LEN(arg) < 4) ?
+ // ((*dp & 0xff000000) | (VAL_TUPLE(arg)[0] << 16) | (VAL_TUPLE(arg)[1] << 8) | (VAL_TUPLE(arg)[2])) :
+ // ((VAL_TUPLE(arg)[3] << 24) | (VAL_TUPLE(arg)[0] << 16) | (VAL_TUPLE(arg)[1] << 8) | (VAL_TUPLE(arg)[2]));
+ Move_Value(D_OUT, arg);
+ return R_OUT;
+ }
+ if (IS_INTEGER(arg) && VAL_INT64(arg) > 0 && VAL_INT64(arg) < 255)
+ n = VAL_INT32(arg);
+ else if (IS_CHAR(arg))
+ n = VAL_CHAR(arg);
+ else
+ fail (arg);
+
+ *dp = (*dp & 0xffffff) | (n << 24);
+ Move_Value(D_OUT, arg);
+ return R_OUT; //was value;
+
+ } else {
+ Set_Tuple_Pixel(QUAD_SKIP(series, index), D_OUT);
+ return R_OUT;
+ }
+ break;
#endif
- case A_CLEAR: // clear series
- if (index < tail) {
- VAL_TAIL(value) = (REBCNT)index;
- Reset_Height(value);
- }
- break;
-
- case A_REMOVE: // remove series /part count
- if (D_REF(2)) {
- val = D_ARG(3);
- if (IS_INTEGER(val)) {
- len = VAL_INT32(val);
- } else if (IS_IMAGE(val)) {
- if (!VAL_IMAGE_WIDE(val)) Trap_Arg(val);
- len = VAL_INDEX(val) - VAL_INDEX(value); // may not be same, is ok
- } else
- Trap_Type(val);
- } else len = 1;
- index = (REBINT)VAL_INDEX(value);
- if (index < tail && len != 0) {
- Remove_Series(series, VAL_INDEX(value), len);
- }
- Reset_Height(value);
- break;
-
- case A_APPEND:
- case A_INSERT: // insert ser val /part len /only /dup count
- case A_CHANGE: // change ser val /part len /only /dup count
- value = Modify_Image(ds, action); // sets DS_RETURN
- break;
-
- case A_FIND: // find ser val /part len /only /case /any /with wild /match /tail
- Find_Image(ds); // sets DS_RETURN
- break;
-
- case A_TO:
- if (IS_IMAGE(arg)) goto makeCopy;
- else if (IS_GOB(arg)) {
- //value = Make_Image(ROUND_TO_INT(GOB_W(VAL_GOB(arg))), ROUND_TO_INT(GOB_H(VAL_GOB(arg))));
- //*D_RET = *value;
- series = OS_GOB_TO_IMAGE(VAL_GOB(arg));
- if (!series) Trap_Make(REB_IMAGE, arg);
- SET_IMAGE(value, series);
- break;
- }
- else if (IS_BINARY(arg)) {
- diff = VAL_LEN(arg) / 4;
- if (diff == 0) Trap_Make(REB_IMAGE, arg);
- if (diff < 100) w = diff;
- else if (diff < 10000) w = 100;
- else w = 500;
- h = diff / w;
- if (w * h < diff) h++; // partial line
- series = Make_Image(w, h, TRUE);
- SET_IMAGE(value, series);
- Bin_To_RGBA(IMG_DATA(series), w*h, VAL_BIN_DATA(arg), VAL_LEN(arg)/4, 0);
- break;
- }
- Trap_Type(arg);
- break;
-
- case A_MAKE:
- // make image! img
- if (IS_IMAGE(arg)) goto makeCopy;
-
- // make image! [] (or none)
- if (IS_IMAGE(value) && (IS_NONE(arg) || (IS_BLOCK(arg) && (VAL_BLK_LEN(arg) == 0)))) {
- arg = value;
- goto makeCopy;
- }
-
- // make image! size
- if (IS_PAIR(arg)) {
- w = VAL_PAIR_X_INT(arg);
- h = VAL_PAIR_Y_INT(arg);
- w = MAX(w, 0);
- h = MAX(h, 0);
- series = Make_Image(w, h, TRUE);
- SET_IMAGE(value, series);
- break;
- }
-// else if (IS_NONE(arg)) {
-// *value = *Make_Image(0, 0);
-// CLEAR_IMAGE(VAL_IMAGE_HEAD(value), 0, 0);
-// break;
-// }
- // make image! [size rgb alpha index]
- else if (IS_BLOCK(arg)) {
- if (Create_Image(VAL_BLK_DATA(arg), value, 0)) break;
- }
- Trap_Type(arg);
- break;
-
- case A_COPY: // copy series /part len
- if (!D_REF(2)) {
- arg = value;
- goto makeCopy;
- }
- arg = D_ARG(3); // can be image, integer, pair.
- if (IS_IMAGE(arg)) {
- if (VAL_SERIES(arg) != VAL_SERIES(value)) Trap_Arg(arg);
- len = VAL_INDEX(arg) - VAL_INDEX(value);
- arg = value;
- goto makeCopy2;
- }
- if (IS_INTEGER(arg)) {
- len = VAL_INT32(arg);
- arg = value;
- goto makeCopy2;
- }
- if (IS_PAIR(arg)) {
- w = VAL_PAIR_X_INT(arg);
- h = VAL_PAIR_Y_INT(arg);
- w = MAX(w, 0);
- h = MAX(h, 0);
- diff = MIN(VAL_TAIL(value), VAL_INDEX(value)); // index offset
- diff = MAX(0, diff);
- index = VAL_IMAGE_WIDE(value); // width
- if (index) {
- len = diff / index; // compute y offset
- diff %= index; // compute x offset
- } else len = diff = 0; // avoid div zero
- w = MIN(w, index - diff); // img-width - x-pos
- h = MIN(h, (int)(VAL_IMAGE_HIGH(value) - len)); // img-high - y-pos
- series = Make_Image(w, h, TRUE);
- SET_IMAGE(D_RET, series);
- Copy_Rect_Data(D_RET, 0, 0, w, h, value, diff, len);
-// VAL_IMAGE_TRANSP(D_RET) = VAL_IMAGE_TRANSP(value);
- return R_RET;
- }
- Trap_Type(arg);
+ case SYM_CLEAR: // clear series
+ if (index < tail) {
+ SET_SERIES_LEN(VAL_SERIES(value), cast(REBCNT, index));
+ Reset_Height(value);
+ }
+ break;
+
+ case SYM_REMOVE: {
+ INCLUDE_PARAMS_OF_REMOVE;
+
+ UNUSED(PAR(series));
+
+ if (REF(map)) {
+ UNUSED(ARG(key));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ if (REF(part)) {
+ val = ARG(limit);
+ if (IS_INTEGER(val)) {
+ len = VAL_INT32(val);
+ }
+ else if (IS_IMAGE(val)) {
+ if (!VAL_IMAGE_WIDE(val))
+ fail (val);
+ len = VAL_INDEX(val) - VAL_INDEX(value); // not same is ok
+ }
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(val)));
+ }
+ else len = 1;
+
+ index = (REBINT)VAL_INDEX(value);
+ if (index < tail && len != 0) {
+ Remove_Series(series, VAL_INDEX(value), len);
+ }
+ Reset_Height(value);
+ break; }
+
+ case SYM_APPEND:
+ case SYM_INSERT: // insert ser val /part len /only /dup count
+ case SYM_CHANGE: // change ser val /part len /only /dup count
+ value = Modify_Image(frame_, action); // sets DS_OUT
+ break;
+
+ case SYM_FIND:
+ Find_Image(frame_); // sets DS_OUT
+ return R_OUT;
+
+ case SYM_COPY: {
+ INCLUDE_PARAMS_OF_COPY;
+
+ UNUSED(PAR(value));
+
+ if (REF(deep))
+ fail (Error_Bad_Refines_Raw());
+
+ if (REF(types)) {
+ UNUSED(ARG(kinds));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ if (NOT(REF(part))) {
+ arg = value;
+ goto makeCopy;
+ }
+ arg = ARG(limit); // can be image, integer, pair.
+ if (IS_IMAGE(arg)) {
+ if (VAL_SERIES(arg) != VAL_SERIES(value))
+ fail (arg);
+ len = VAL_INDEX(arg) - VAL_INDEX(value);
+ arg = value;
+ goto makeCopy2;
+ }
+ if (IS_INTEGER(arg)) {
+ len = VAL_INT32(arg);
+ arg = value;
+ goto makeCopy2;
+ }
+ if (IS_PAIR(arg)) {
+ w = VAL_PAIR_X_INT(arg);
+ h = VAL_PAIR_Y_INT(arg);
+ w = MAX(w, 0);
+ h = MAX(h, 0);
+ diff = MIN(VAL_LEN_HEAD(value), VAL_INDEX(value)); // index offset
+ diff = MAX(0, diff);
+ index = VAL_IMAGE_WIDE(value); // width
+ if (index) {
+ len = diff / index; // compute y offset
+ diff %= index; // compute x offset
+ } else len = diff = 0; // avoid div zero
+ w = MIN(w, index - diff); // img-width - x-pos
+ h = MIN(h, (int)(VAL_IMAGE_HIGH(value) - len)); // img-high - y-pos
+ series = Make_Image(w, h, TRUE);
+ Init_Image(D_OUT, series);
+ Copy_Rect_Data(D_OUT, 0, 0, w, h, value, diff, len);
+// VAL_IMAGE_TRANSP(D_OUT) = VAL_IMAGE_TRANSP(value);
+ return R_OUT;
+ }
+ fail (Error_Invalid_Type(VAL_TYPE(arg)));
makeCopy:
- // Src image is arg.
- len = VAL_IMAGE_LEN(arg);
+ // Src image is arg.
+ len = VAL_IMAGE_LEN(arg);
makeCopy2:
- len = MAX(len, 0); // no negatives
- len = MIN(len, (REBINT)VAL_IMAGE_LEN(arg));
- w = VAL_IMAGE_WIDE(arg);
- w = MAX(w, 1);
- if (len <= w) h = 1, w = len;
- else h = len / w;
- if (w == 0) h = 0;
- series = Make_Image(w, h, TRUE);
- SET_IMAGE(D_RET, series);
- memcpy(VAL_IMAGE_HEAD(D_RET), VAL_IMAGE_DATA(arg), w * h * 4);
-// VAL_IMAGE_TRANSP(D_RET) = VAL_IMAGE_TRANSP(arg);
- return R_RET;
- break;
-
- default:
- Trap_Action(VAL_TYPE(value), action);
- }
-
- *DS_RETURN = *value;
- return R_RET;
-
-is_false:
- return R_FALSE;
-
-is_true:
- return R_TRUE;
+ Copy_Image_Value(D_OUT, arg, len);
+ return R_OUT; }
+
+ default:
+ fail (Error_Illegal_Action(VAL_TYPE(value), action));
+ }
+
+ Move_Value(D_OUT, value);
+ return R_OUT;
+}
+
+
+inline static REBOOL Adjust_Image_Pick_Index_Is_Valid(
+ REBINT *index, // gets adjusted
+ const REBVAL *value, // image
+ const REBVAL *picker
+) {
+ REBINT n;
+ if (IS_PAIR(picker)) {
+ n = (
+ VAL_PAIR_Y_INT(picker) * VAL_IMAGE_WIDE(value)
+ + VAL_PAIR_X_INT(picker)
+ ) + 1;
+ }
+ else if (IS_INTEGER(picker))
+ n = VAL_INT32(picker);
+ else if (IS_DECIMAL(picker))
+ n = cast(REBINT, VAL_DECIMAL(picker));
+ else if (IS_LOGIC(picker))
+ n = VAL_LOGIC(picker) ? 1 : 2;
+ else
+ fail (picker);
+
+ *index += n;
+ if (n > 0)
+ (*index)--;
+
+ if (n == 0 || *index < 0 || *index >= cast(REBINT, VAL_LEN_HEAD(value)))
+ return FALSE; // out of range
+
+ return TRUE;
+}
+
+
+//
+// Pick_Image: C
+//
+void Pick_Image(REBVAL *out, const REBVAL *value, const REBVAL *picker)
+{
+ REBSER *series = VAL_SERIES(value);
+
+ REBINT index = cast(REBINT, VAL_INDEX(value));
+ REBINT len = VAL_LEN_HEAD(value) - index;
+ len = MAX(len, 0);
+
+ REBYTE *src = VAL_IMAGE_DATA(value);
+
+ if (IS_WORD(picker)) {
+ switch (VAL_WORD_SYM(picker)) {
+ case SYM_SIZE:
+ SET_PAIR(
+ out,
+ VAL_IMAGE_WIDE(value),
+ VAL_IMAGE_HIGH(value)
+ );
+ break;
+
+ case SYM_RGB: {
+ REBSER *nser = Make_Binary(len * 3);
+ SET_SERIES_LEN(nser, len * 3);
+ RGB_To_Bin(QUAD_HEAD(nser), src, len, FALSE);
+ Init_Binary(out, nser);
+ break; }
+
+ case SYM_ALPHA: {
+ REBSER *nser = Make_Binary(len);
+ SET_SERIES_LEN(nser, len);
+ Alpha_To_Bin(QUAD_HEAD(nser), src, len);
+ Init_Binary(out, nser);
+ break; }
+
+ default:
+ fail (picker);
+ }
+ return;
+ }
+
+ if (Adjust_Image_Pick_Index_Is_Valid(&index, value, picker))
+ Set_Tuple_Pixel(QUAD_SKIP(series, index), out);
+ else
+ Init_Void(out);
+}
+
+
+//
+// Poke_Image_Fail_If_Read_Only: C
+//
+void Poke_Image_Fail_If_Read_Only(
+ REBVAL *value,
+ const REBVAL *picker,
+ const REBVAL *poke
+) {
+ REBSER *series = VAL_SERIES(value);
+ FAIL_IF_READ_ONLY_SERIES(series);
+
+ REBINT index = cast(REBINT, VAL_INDEX(value));
+ REBINT len = VAL_LEN_HEAD(value) - index;
+ len = MAX(len, 0);
+
+ REBYTE *src = VAL_IMAGE_DATA(value);
+
+ if (IS_WORD(picker)) {
+ switch (VAL_WORD_SYM(picker)) {
+ case SYM_SIZE:
+ if (!IS_PAIR(poke) || !VAL_PAIR_X(poke))
+ fail (poke);
+
+ VAL_IMAGE_WIDE(value) = VAL_PAIR_X_INT(poke);
+ VAL_IMAGE_HIGH(value) = MIN(
+ VAL_PAIR_Y_INT(poke),
+ cast(REBINT, VAL_LEN_HEAD(value) / VAL_PAIR_X_INT(poke))
+ );
+ break;
+
+ case SYM_RGB:
+ if (IS_TUPLE(poke)) {
+ Fill_Line(
+ cast(REBCNT*, src), TO_PIXEL_TUPLE(poke), len, TRUE
+ );
+ } else if (IS_INTEGER(poke)) {
+ REBINT byte = VAL_INT32(poke);
+ if (byte < 0 || byte > 255)
+ fail (Error_Out_Of_Range(poke));
+
+ Fill_Line(
+ cast(REBCNT*, src),
+ TO_PIXEL_COLOR(byte, byte, byte, 0xFF),
+ len,
+ TRUE
+ );
+ }
+ else if (IS_BINARY(poke)) {
+ Bin_To_RGB(
+ src,
+ len,
+ VAL_BIN_AT(poke),
+ VAL_LEN_AT(poke) / 3
+ );
+ }
+ else
+ fail (poke);
+ break;
+
+ case SYM_ALPHA:
+ if (IS_INTEGER(poke)) {
+ REBINT n = VAL_INT32(poke);
+ if (n < 0 || n > 255)
+ fail (Error_Out_Of_Range(poke));
+
+ Fill_Alpha_Line(src, cast(REBYTE, n), len);
+ }
+ else if (IS_BINARY(poke)) {
+ Bin_To_Alpha(
+ src,
+ len,
+ VAL_BIN_AT(poke),
+ VAL_LEN_AT(poke)
+ );
+ }
+ else
+ fail (poke);
+ break;
+
+ default:
+ fail (picker);
+ }
+ return;
+ }
+
+ if (!Adjust_Image_Pick_Index_Is_Valid(&index, value, picker))
+ fail (Error_Out_Of_Range(picker));
+
+ if (IS_TUPLE(poke)) { // set whole pixel
+ Set_Pixel_Tuple(QUAD_SKIP(series, index), poke);
+ return;
+ }
+
+ // set the alpha only
+
+ REBINT alpha;
+ if (
+ IS_INTEGER(poke)
+ && VAL_INT64(poke) > 0
+ && VAL_INT64(poke) < 255
+ ) {
+ alpha = VAL_INT32(poke);
+ }
+ else if (IS_CHAR(poke))
+ alpha = VAL_CHAR(poke);
+ else
+ fail (Error_Out_Of_Range(poke));
+
+ REBCNT *dp = cast(REBCNT*, QUAD_SKIP(series, index));
+ *dp = (*dp & 0xffffff) | (alpha << 24);
}
-/***********************************************************************
-**
-*/ REBINT PD_Image(REBPVS *pvs)
-/*
-***********************************************************************/
+//
+// PD_Image: C
+//
+REBINT PD_Image(REBPVS *pvs)
{
- REBVAL *data = pvs->value;
- REBVAL *sel = pvs->select;
- REBVAL *val = pvs->setval;
- REBINT n;
- REBINT len;
- REBYTE *src;
- REBINT index = (REBINT)VAL_INDEX(data);
- REBSER *nser;
- REBSER *series = VAL_SERIES(data);
- REBCNT *dp;
-
- len = VAL_TAIL(data) - index;
- len = MAX(len, 0);
- src = VAL_IMAGE_DATA(data);
-
- if (IS_PAIR(sel)) n = (VAL_PAIR_Y_INT(sel) * VAL_IMAGE_WIDE(data) + VAL_PAIR_X_INT(sel)) + 1;
- else if (IS_INTEGER(sel)) n = VAL_INT32(sel);
- else if (IS_DECIMAL(sel)) n = (REBINT)VAL_DECIMAL(sel);
- else if (IS_LOGIC(sel)) n = (VAL_LOGIC(sel) ? 1 : 2);
- else if (IS_WORD(sel)) {
- if (val == 0) {
- val = pvs->value = pvs->store;
- switch (VAL_WORD_CANON(sel)) {
-
- case SYM_SIZE:
- VAL_SET(val, REB_PAIR);
- VAL_PAIR_X(val) = (REBD32)VAL_IMAGE_WIDE(data);
- VAL_PAIR_Y(val) = (REBD32)VAL_IMAGE_HIGH(data);
- break;
-
- case SYM_RGB:
- nser = Make_Binary(len * 3);
- SERIES_TAIL(nser) = len * 3;
- RGB_To_Bin(QUAD_HEAD(nser), src, len, FALSE);
- Set_Binary(val, nser);
- break;
-
- case SYM_ALPHA:
- nser = Make_Binary(len);
- SERIES_TAIL(nser) = len;
- Alpha_To_Bin(QUAD_HEAD(nser), src, len);
- Set_Binary(val, nser);
- break;
-
- default:
- return PE_BAD_SELECT;
- }
- return PE_OK;
-
- } else {
-
- switch (VAL_WORD_CANON(sel)) {
-
- case SYM_SIZE:
- if (!IS_PAIR(val) || !VAL_PAIR_X(val)) return PE_BAD_SET;
- VAL_IMAGE_WIDE(data) = VAL_PAIR_X_INT(val);
- VAL_IMAGE_HIGH(data) = MIN(VAL_PAIR_Y_INT(val), (REBINT)VAL_TAIL(data) / VAL_PAIR_X_INT(val));
- break;
-
- case SYM_RGB:
- if (IS_TUPLE(val)) {
- Fill_Line((REBCNT *)src, TO_COLOR_TUPLE(val), len, 1);
- } else if (IS_INTEGER(val)) {
- n = VAL_INT32(val);
- if (n < 0 || n > 255) return PE_BAD_RANGE;
- Fill_Line((REBCNT *)src, TO_COLOR(n,n,n,0), len, 1);
- } else if (IS_BINARY(val)) {
- Bin_To_RGB(src, len, VAL_BIN_DATA(val), VAL_LEN(val) / 3);
- } else return PE_BAD_SET;
- break;
-
- case SYM_ALPHA:
- if (IS_INTEGER(val)) {
- n = VAL_INT32(val);
- if (n < 0 || n > 255) return PE_BAD_RANGE;
- Fill_Alpha_Line(src, (REBYTE)n, len);
- } else if (IS_BINARY(val)) {
- Bin_To_Alpha(src, len, VAL_BIN_DATA(val), VAL_LEN(val));
- } else return PE_BAD_SET;
- break;
-
- default:
- return PE_BAD_SELECT;
- }
- return PE_OK;
- }
- }
- else return PE_BAD_SELECT;
-
- // Handle index path:
- index += n;
- if (n > 0) index--;
-
- TRAP_PROTECT(series);
-
- // Out of range:
- if (n == 0 || index < 0 || index >= (REBINT)series->tail) {
- if (val) return PE_BAD_SET;
- return PE_NONE;
- }
-
- // Get the pixel:
- if (val == 0) {
- Set_Tuple_Pixel(QUAD_SKIP(series, index), pvs->store);
- return PE_USE;
- }
-
- // Set the pixel:
- if (IS_TUPLE(val) && (IS_IMAGE(data))) {
- Set_Pixel_Tuple(QUAD_SKIP(series, index), val);
- //*dp = (long) (VAL_TUPLE_LEN(val) < 4) ?
- // ((*dp & 0xff000000) | (VAL_TUPLE(val)[0] << 16) | (VAL_TUPLE(val)[1] << 8) | (VAL_TUPLE(val)[2])) :
- // ((VAL_TUPLE(val)[3] << 24) | (VAL_TUPLE(val)[0] << 16) | (VAL_TUPLE(val)[1] << 8) | (VAL_TUPLE(val)[2]));
- return PE_OK;
- }
-
- // Set the alpha only:
- if (IS_INTEGER(val) && VAL_INT64(val) > 0 && VAL_INT64(val) < 255) n = VAL_INT32(val);
- else if (IS_CHAR(val)) n = VAL_CHAR(val);
- else return PE_BAD_RANGE;
-
- dp = (REBCNT*)QUAD_SKIP(series, index);
- *dp = (*dp & 0xffffff) | (n << 24);
- return PE_OK;
+ if (pvs->opt_setval) {
+ Poke_Image_Fail_If_Read_Only(
+ KNOWN(pvs->value), pvs->picker, pvs->opt_setval
+ );
+ return PE_OK;
+ }
+
+ Pick_Image(pvs->store, KNOWN(pvs->value), pvs->picker);
+ return PE_USE_STORE;
}
diff --git a/src/core/t-integer.c b/src/core/t-integer.c
index 2585633a2d..0bd24ed02a 100644
--- a/src/core/t-integer.c
+++ b/src/core/t-integer.c
@@ -1,293 +1,580 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-integer.c
-** Summary: integer datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-integer.c
+// Summary: "integer datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
#include "sys-deci-funcs.h"
+#include "sys-int-funcs.h"
-/***********************************************************************
-**
-*/ REBINT CT_Integer(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Integer: C
+//
+REBINT CT_Integer(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- if (mode >= 0) return (VAL_INT64(a) == VAL_INT64(b));
- if (mode == -1) return (VAL_INT64(a) >= VAL_INT64(b));
- return (VAL_INT64(a) > VAL_INT64(b));
+ if (mode >= 0) return (VAL_INT64(a) == VAL_INT64(b));
+ if (mode == -1) return (VAL_INT64(a) >= VAL_INT64(b));
+ return (VAL_INT64(a) > VAL_INT64(b));
}
-/***********************************************************************
-**
-*/ REBTYPE(Integer)
-/*
-***********************************************************************/
+//
+// MAKE_Integer: C
+//
+void MAKE_Integer(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBVAL *val = D_ARG(1);
- REBVAL *val2 = D_ARG(2);
- REBI64 num;
- REBI64 arg;
- REBINT n;
-
- REBU64 p, a, b; // for overflow detection
- REBCNT a1, a0, b1, b0;
- REBFLG sgn;
- REBI64 anum;
-
- num = VAL_INT64(val);
-
- if (IS_BINARY_ACT(action)) {
-
- if (IS_INTEGER(val2)) arg = VAL_INT64(val2);
- else if (IS_CHAR(val2)) arg = VAL_CHAR(val2);
- else {
- // Decimal or other numeric second argument:
- n = 0; // use to flag special case
- switch(action) {
- // Anything added to an integer is same as adding the integer:
- case A_ADD:
- case A_MULTIPLY:
- // Swap parameter order:
- *D_RET = *val2; // Use as temp workspace
- *val2 = *val;
- *val = *D_RET;
- return Value_Dispatch[VAL_TYPE(val)](ds, action);
-
- // Only type valid to subtract from, divide into, is decimal/money:
- case A_SUBTRACT:
- n = 1;
- case A_DIVIDE:
- case A_REMAINDER:
- case A_POWER:
- if (IS_DECIMAL(val2) | IS_PERCENT(val2)) {
- SET_DECIMAL(val, (REBDEC)num); // convert main arg
- return T_Decimal(ds, action);
- }
- if (IS_MONEY(val2)) {
- VAL_DECI(val) = int_to_deci(VAL_INT64(val));
- VAL_SET(val, REB_MONEY);
- return T_Money(ds, action);
- }
- if (n > 0) {
- if (IS_TIME(val2)) {
- VAL_TIME(val) = SEC_TIME(VAL_INT64(val));
- SET_TYPE(val, REB_TIME);
- return T_Time(ds, action);
- }
- if (IS_DATE(val2)) return T_Date(ds, action);
- }
- }
- Trap_Math_Args(REB_INTEGER, action);
- }
- }
-
- switch (action) {
-
- case A_ADD:
- anum = (REBU64)num + (REBU64)arg;
- if (
- ((num < 0) == (arg < 0)) && ((num < 0) != (anum < 0))
- ) Trap0(RE_OVERFLOW);
- num = anum;
- break;
-
- case A_SUBTRACT:
- anum = (REBU64)num - (REBU64)arg;
- if (
- ((num < 0) != (arg < 0)) && ((num < 0) != (anum < 0))
- ) Trap0(RE_OVERFLOW);
- num = anum;
- break;
-
- case A_MULTIPLY:
- a = num;
- sgn = (num < 0);
- if (sgn) a = -a;
- b = arg;
- if (arg < 0) {
- sgn = !sgn;
- b = -b;
- }
- p = a * b;
- a1 = a>>32;
- a0 = a;
- b1 = b>>32;
- b0 = b;
- if (
- (a1 && b1)
- || ((REBU64)a0 * b1 + (REBU64)a1 * b0 > p >> 32)
- || ((p > (REBU64)MAX_I64) && (!sgn || (p > -(REBU64)MIN_I64)))
- ) Trap0(RE_OVERFLOW);
- num = sgn ? -p : p;
- break;
-
- case A_DIVIDE:
- if (arg == 0) Trap0(RE_ZERO_DIVIDE);
- if (num == MIN_I64 && arg == -1) Trap0(RE_OVERFLOW);
- if (num % arg == 0) {
- num = num / arg;
- break;
- }
- // Fall thru
-
- case A_POWER:
- SET_DECIMAL(val, (REBDEC)num);
- SET_DECIMAL(val2, (REBDEC)arg);
- return T_Decimal(ds, action);
-
- case A_REMAINDER:
- if (arg == 0) Trap0(RE_ZERO_DIVIDE);
- num = REM2(num, arg);
- break;
-
- case A_AND: num &= arg; break;
- case A_OR: num |= arg; break;
- case A_XOR: num ^= arg; break;
-
- case A_NEGATE:
- if (num == MIN_I64) Trap0(RE_OVERFLOW);
- num = -num;
- break;
-
- case A_COMPLEMENT: num = ~num; break;
-
- case A_ABSOLUTE:
- if (num == MIN_I64) Trap0(RE_OVERFLOW);
- if (num < 0) num = -num;
- break;
-
- case A_EVENQ: num = ~num;
- case A_ODDQ: DECIDE(num & 1);
-
- case A_ROUND:
- val2 = D_ARG(3);
- n = Get_Round_Flags(ds);
- if (D_REF(2)) { // to
- if (IS_MONEY(val2)) {
- VAL_DECI(D_RET) = Round_Deci(int_to_deci(num), n, VAL_DECI(val2));
- SET_TYPE(D_RET, REB_MONEY);
- return R_RET;
- }
- if (IS_DECIMAL(val2) || IS_PERCENT(val2)) {
- VAL_DECIMAL(D_RET) = Round_Dec((REBDEC)num, n, VAL_DECIMAL(val2));
- SET_TYPE(D_RET, VAL_TYPE(val2));
- return R_RET;
- }
- if (IS_TIME(val2)) Trap_Arg(val2);
- arg = VAL_INT64(val2);
- }
- else arg = 0L;
- num = Round_Int(num, n, arg);
- break;
-
- case A_RANDOM:
- if (D_REF(2)) { // seed
- Set_Random(num);
- return R_UNSET;
- }
- if (num == 0) break;
- num = Random_Range(num, (REBOOL)D_REF(3)); //!!! 64 bits
-#ifdef OLD_METHOD
- if (num < 0) num = -(1 + (REBI64)(arg % -num));
- else num = 1 + (REBI64)(arg % num);
-#endif
- break;
-
- case A_MAKE:
- case A_TO:
- val = D_ARG(2);
- if (IS_DECIMAL(val) || IS_PERCENT(val)) {
- if (VAL_DECIMAL(val) < MIN_D64 || VAL_DECIMAL(val) >= MAX_D64)
- Trap0(RE_OVERFLOW);
- num = (REBI64)VAL_DECIMAL(val);
- }
- else if (IS_INTEGER(val))
- num = VAL_INT64(val);
- else if (IS_MONEY(val))
- num = deci_to_int(VAL_DECI(val));
- else if (IS_ISSUE(val)) {
- REBYTE *bp;
- REBCNT len;
- bp = Get_Word_Name(val);
- len = strlen(bp);
- n = MIN(MAX_HEX_LEN, len);
- if (Scan_Hex(bp, &num, n, n) == 0) goto is_bad;
- }
- else if (IS_BINARY(val)) { // must be before STRING!
- REBYTE *bp;
- n = VAL_LEN(val);
- if (n > sizeof(REBI64)) n = sizeof(REBI64);
- num = 0;
- for (bp = VAL_BIN_DATA(val); n; n--, bp++)
- num = (num << 8) | *bp;
- }
- else if (ANY_STR(val)) {
- REBYTE *bp;
- REBCNT len;
- bp = Qualify_String(val, MAX_INT_LEN, &len, FALSE);
- if (memchr(bp, '.', len)) {
- if (Scan_Decimal(bp, len, DS_RETURN, TRUE)) {
- num = (REBINT)VAL_DECIMAL(DS_RETURN);
- break;
- }
- }
- if (Scan_Integer(bp, len, DS_RETURN))
- return R_RET;
- goto is_bad;
- }
- else if (IS_LOGIC(val)) {
- // No integer is uniquely representative of true, so TO conversions reject
- // integer-to-logic conversions. MAKE is more liberal and constructs true
- // to 1 and false to 0.
- if (action != A_MAKE) goto is_bad;
- num = VAL_LOGIC(val) ? 1 : 0;
- }
- else if (IS_CHAR(val))
- num = VAL_CHAR(val);
- // else if (IS_NONE(val)) num = 0;
- else if (IS_TIME (val)) num = SECS_IN(VAL_TIME(val));
- else goto is_bad;
- break;
-
- default:
- Trap_Action(REB_INTEGER, action);
- }
-
- SET_INTEGER(DS_RETURN, num);
- return R_RET;
-
-is_bad:
- Trap_Make(REB_INTEGER, val);
-
-is_false:
- return R_FALSE;
-
-is_true:
- return R_TRUE;
+ assert(kind == REB_INTEGER);
+ UNUSED(kind);
+
+ if (IS_LOGIC(arg)) {
+ //
+ // !!! Due to Rebol's policies on conditional truth and falsehood,
+ // it refuses to say TO FALSE is 0. MAKE has shades of meaning
+ // that are more "dialected", e.g. MAKE BLOCK! 10 creates a block
+ // with capacity 10 and not literally `[10]` (or a block with ten
+ // NONE! values in it). Under that liberal umbrella it decides
+ // that it will make an integer 0 out of FALSE due to it having
+ // fewer seeming "rules" than TO would.
+
+ if (VAL_LOGIC(arg))
+ Init_Integer(out, 1);
+ else
+ Init_Integer(out, 0);
+
+ // !!! The same principle could suggest MAKE is not bound by
+ // the "reversibility" requirement and hence could interpret
+ // binaries unsigned by default. Before getting things any
+ // weirder should probably leave it as is.
+ }
+ else {
+ // use signed logic by default (use TO-INTEGER/UNSIGNED to force
+ // unsigned interpretation or error if that doesn't make sense)
+
+ Value_To_Int64(out, arg, FALSE);
+ }
+}
+
+
+//
+// TO_Integer: C
+//
+void TO_Integer(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ assert(kind == REB_INTEGER);
+ UNUSED(kind);
+
+ // use signed logic by default (use TO-INTEGER/UNSIGNED to force
+ // unsigned interpretation or error if that doesn't make sense)
+
+ Value_To_Int64(out, arg, FALSE);
+}
+
+
+//
+// Value_To_Int64: C
+//
+// Interpret `value` as a 64-bit integer and return it in `out`.
+//
+// If `no_sign` is TRUE then use that to inform an ambiguous conversion
+// (e.g. TO-INTEGER/UNSIGNED #{FF} is 255 instead of -1). However, it
+// won't contradict the sign of unambiguous source. So the string "-1"
+// will raise an error if you try to convert it unsigned. (For this,
+// use `abs to-integer "-1"` and not `to-integer/unsigned "-1"`.)
+//
+// Because Rebol's INTEGER! uses a signed REBI64 and not an unsigned
+// REBU64, a request for unsigned interpretation is limited to using
+// 63 of those bits. A range error will be thrown otherwise.
+//
+// If a type is added or removed, update REBNATIVE(to_integer)'s spec
+//
+void Value_To_Int64(REBVAL *out, const REBVAL *value, REBOOL no_sign)
+{
+ // !!! Code extracted from REBTYPE(Integer)'s A_MAKE and A_TO cases
+ // Use SWITCH instead of IF chain? (was written w/ANY_STR test)
+
+ if (IS_INTEGER(value)) {
+ Move_Value(out, value);
+ goto check_sign;
+ }
+ if (IS_DECIMAL(value) || IS_PERCENT(value)) {
+ if (VAL_DECIMAL(value) < MIN_D64 || VAL_DECIMAL(value) >= MAX_D64)
+ fail (Error_Overflow_Raw());
+
+ Init_Integer(out, cast(REBI64, VAL_DECIMAL(value)));
+ goto check_sign;
+ }
+ else if (IS_MONEY(value)) {
+ Init_Integer(out, deci_to_int(VAL_MONEY_AMOUNT(value)));
+ goto check_sign;
+ }
+ else if (IS_BINARY(value)) { // must be before ANY_STRING() test...
+
+ // Rebol3 creates 8-byte big endian for signed 64-bit integers.
+ // Rebol2 created 4-byte big endian for signed 32-bit integers.
+ //
+ // Values originating in file formats from other systems vary widely.
+ // Note that in C the default interpretation of single bytes in most
+ // implementations of a `char` is signed.
+ //
+ // We assume big-Endian for decoding (clients can REVERSE if they
+ // want little-Endian). Also by default assume that any missing
+ // sign-extended to 64-bits based on the most significant byte
+ //
+ // #{01020304} => #{0000000001020304}
+ // #{DECAFBAD} => #{FFFFFFFFDECAFBAD}
+ //
+ // To override this interpretation and always generate an unsigned
+ // result, pass in `no_sign`. (Used by TO-INTEGER/UNSIGNED)
+ //
+ // If under these rules a number cannot be represented within the
+ // numeric range of the system's INTEGER!, it will error. This
+ // attempts to "future-proof" for other integer sizes and as an
+ // interface could support BigNums in the future.
+
+ REBYTE *bp = VAL_BIN_AT(value);
+ REBCNT n = VAL_LEN_AT(value);
+ REBOOL negative;
+ REBINT fill;
+
+ #if !defined(NDEBUG)
+ //
+ // This is what R3-Alpha did.
+ //
+ if (LEGACY(OPTIONS_FOREVER_64_BIT_INTS)) {
+ REBI64 i = 0;
+ if (n > sizeof(REBI64)) n = sizeof(REBI64);
+ for (; n; n--, bp++)
+ i = cast(REBI64, (cast(REBU64, i) << 8) | *bp);
+
+ Init_Integer(out, i);
+
+ // There was no TO-INTEGER/UNSIGNED in R3-Alpha, so even if
+ // running in compatibility mode we can check the sign if used.
+ //
+ goto check_sign;
+ }
+ #endif
+
+ if (n == 0) {
+ //
+ // !!! Should #{} empty binary be 0 or error? (Historically, 0)
+ //
+ Init_Integer(out, 0);
+ return;
+ }
+
+ // default signedness interpretation to high-bit of first byte, but
+ // override if the function was called with `no_sign`
+ //
+ negative = no_sign ? FALSE : LOGICAL(*bp >= 0x80);
+
+ // Consume any leading 0x00 bytes (or 0xFF if negative)
+ //
+ while (n != 0 && *bp == (negative ? 0xFF : 0x00)) {
+ ++bp;
+ --n;
+ }
+
+ // If we were consuming 0xFFs and passed to a byte that didn't have
+ // its high bit set, we overstepped our bounds! Go back one.
+ //
+ if (negative && n > 0 && *bp < 0x80) {
+ --bp;
+ ++n;
+ }
+
+ // All 0x00 bytes must mean 0 (or all 0xFF means -1 if negative)
+ //
+ if (n == 0) {
+ if (negative) {
+ assert(!no_sign);
+ Init_Integer(out, -1);
+ } else
+ Init_Integer(out, 0);
+ return;
+ }
+
+ // Not using BigNums (yet) so max representation is 8 bytes after
+ // leading 0x00 or 0xFF stripped away
+ //
+ if (n > 8)
+ fail (Error_Out_Of_Range_Raw(value));
+
+ REBI64 i = 0;
+
+ // Pad out to make sure any missing upper bytes match sign
+ for (fill = n; fill < 8; fill++)
+ i = cast(REBI64,
+ (cast(REBU64, i) << 8) | (negative ? 0xFF : 0x00)
+ );
+
+ // Use binary data bytes to fill in the up-to-8 lower bytes
+ //
+ while (n != 0) {
+ i = cast(REBI64, (cast(REBU64, i) << 8) | *bp);
+ bp++;
+ n--;
+ }
+
+ if (no_sign && i < 0) {
+ //
+ // bits may become signed via shift due to 63-bit limit
+ //
+ fail (Error_Out_Of_Range_Raw(value));
+ }
+
+ Init_Integer(out, i);
+ return;
+ }
+ else if (IS_ISSUE(value)) {
+ //
+ // Like converting a binary, except uses a string of codepoints
+ // from the word name conversion. Does not allow for signed
+ // interpretations, e.g. #FFFF => 65535, not -1. Unsigned makes
+ // more sense as these would be hexes likely typed in by users,
+ // who rarely do 2s-complement math in their head.
+
+ const REBYTE *bp = VAL_WORD_HEAD(value);
+ REBCNT len = LEN_BYTES(bp);
+
+ if (len > MAX_HEX_LEN) {
+ // Lacks BINARY!'s accommodation of leading 00s or FFs
+ fail (Error_Out_Of_Range_Raw(value));
+ }
+
+ if (!Scan_Hex(out, bp, len, len))
+ fail (Error_Bad_Make(REB_INTEGER, value));
+
+ // !!! Unlike binary, always assumes unsigned (should it?). Yet still
+ // might run afoul of 64-bit range limit.
+ //
+ if (VAL_INT64(out) < 0)
+ fail (Error_Out_Of_Range_Raw(value));
+
+ return;
+ }
+ else if (ANY_STRING(value)) {
+ REBCNT len;
+ REBYTE *bp = Temp_Byte_Chars_May_Fail(
+ value, VAL_LEN_AT(value), &len, FALSE
+ );
+ if (
+ memchr(bp, '.', len)
+ || memchr(bp, 'e', len)
+ || memchr(bp, 'E', len)
+ ) {
+ DECLARE_LOCAL (d);
+ if (Scan_Decimal(d, bp, len, TRUE)) {
+ if (VAL_DECIMAL(d) < MAX_I64 && VAL_DECIMAL(d) >= MIN_I64) {
+ Init_Integer(out, cast(REBI64, VAL_DECIMAL(d)));
+ goto check_sign;
+ }
+
+ fail (Error_Overflow_Raw());
+ }
+ }
+ if (Scan_Integer(out, bp, len))
+ goto check_sign;
+
+ fail (Error_Bad_Make(REB_INTEGER, value));
+ }
+ else if (IS_LOGIC(value)) {
+ //
+ // Rebol's choice is that no integer is uniquely representative of
+ // "falsehood" condition, e.g. `if 0 [print "this prints"]`. So to
+ // say TO FALSE is 0 would be disingenuous.
+ //
+ fail (Error_Bad_Make(REB_INTEGER, value));
+ }
+ else if (IS_CHAR(value)) {
+ Init_Integer(out, VAL_CHAR(value)); // always unsigned
+ return;
+ }
+ else if (IS_TIME(value)) {
+ Init_Integer(out, SECS_FROM_NANO(VAL_NANO(value))); // always unsigned
+ return;
+ }
+ else
+ fail (Error_Bad_Make(REB_INTEGER, value));
+
+check_sign:
+ if (no_sign && VAL_INT64(out) < 0)
+ fail (Error_Positive_Raw());
+}
+
+
+//
+// to-integer: native [
+//
+// {Synonym of TO INTEGER! when used without refinements, adds /UNSIGNED.}
+//
+// value [
+// integer! decimal! percent! money! char! time!
+// issue! binary! any-string!
+// ]
+// /unsigned
+// {For BINARY! interpret as unsigned, otherwise error if signed.}
+// ]
+//
+REBNATIVE(to_integer)
+{
+ INCLUDE_PARAMS_OF_TO_INTEGER;
+
+ Value_To_Int64(D_OUT, ARG(value), REF(unsigned));
+
+ return R_OUT;
+}
+
+
+//
+// REBTYPE: C
+//
+REBTYPE(Integer)
+{
+ REBVAL *val = D_ARG(1);
+ REBVAL *val2 = D_ARGC > 1 ? D_ARG(2) : NULL;
+
+ REBI64 arg;
+
+ REBI64 num = VAL_INT64(val);
+
+ // !!! This used to rely on IS_BINARY_ACT, which is no longer available
+ // in the symbol based dispatch. Consider doing another way.
+ //
+ if (
+ action == SYM_ADD
+ || action == SYM_SUBTRACT
+ || action == SYM_MULTIPLY
+ || action == SYM_DIVIDE
+ || action == SYM_POWER
+ || action == SYM_AND_T
+ || action == SYM_OR_T
+ || action == SYM_XOR_T
+ || action == SYM_REMAINDER
+ ){
+ if (IS_INTEGER(val2))
+ arg = VAL_INT64(val2);
+ else if (IS_CHAR(val2))
+ arg = VAL_CHAR(val2);
+ else {
+ // Decimal or other numeric second argument:
+ REBCNT n = 0; // use to flag special case
+ switch(action) {
+ // Anything added to an integer is same as adding the integer:
+ case SYM_ADD:
+ case SYM_MULTIPLY:
+ // Swap parameter order:
+ Move_Value(D_OUT, val2); // Use as temp workspace
+ Move_Value(val2, val);
+ Move_Value(val, D_OUT);
+ return Value_Dispatch[VAL_TYPE(val)](frame_, action);
+
+ // Only type valid to subtract from, divide into, is decimal/money:
+ case SYM_SUBTRACT:
+ n = 1;
+ /* fall through */
+ case SYM_DIVIDE:
+ case SYM_REMAINDER:
+ case SYM_POWER:
+ if (IS_DECIMAL(val2) || IS_PERCENT(val2)) {
+ Init_Decimal(val, (REBDEC)num); // convert main arg
+ return T_Decimal(frame_, action);
+ }
+ if (IS_MONEY(val2)) {
+ Init_Money(val, int_to_deci(VAL_INT64(val)));
+ return T_Money(frame_, action);
+ }
+ if (n > 0) {
+ if (IS_TIME(val2)) {
+ VAL_NANO(val) = SEC_TIME(VAL_INT64(val));
+ VAL_SET_TYPE_BITS(val, REB_TIME);
+ return T_Time(frame_, action);
+ }
+ if (IS_DATE(val2))
+ return T_Date(frame_, action);
+ }
+
+ default:
+ break;
+ }
+ fail (Error_Math_Args(REB_INTEGER, action));
+ }
+ }
+ else
+ arg = 0xDECAFBAD; // wasteful, but avoid maybe unassigned warning
+
+ switch (action) {
+
+ case SYM_COPY:
+ Move_Value(D_OUT, val);
+ return R_OUT;
+
+ case SYM_ADD: {
+ REBI64 anum;
+ if (REB_I64_ADD_OF(num, arg, &anum))
+ fail (Error_Overflow_Raw());
+ num = anum;
+ break; }
+
+ case SYM_SUBTRACT: {
+ REBI64 anum;
+ if (REB_I64_SUB_OF(num, arg, &anum))
+ fail (Error_Overflow_Raw());
+ num = anum;
+ break; }
+
+ case SYM_MULTIPLY: {
+ REBI64 p;
+ if (REB_I64_MUL_OF(num, arg, &p))
+ fail (Error_Overflow_Raw());
+ num = p;
+ break; }
+
+ case SYM_DIVIDE:
+ if (arg == 0)
+ fail (Error_Zero_Divide_Raw());
+ if (num == MIN_I64 && arg == -1)
+ fail (Error_Overflow_Raw());
+ if (num % arg == 0) {
+ num = num / arg;
+ break;
+ }
+ // Fall thru
+ case SYM_POWER:
+ Init_Decimal(val, (REBDEC)num);
+ Init_Decimal(val2, (REBDEC)arg);
+ return T_Decimal(frame_, action);
+
+ case SYM_REMAINDER:
+ if (arg == 0)
+ fail (Error_Zero_Divide_Raw());
+ num = (arg != -1) ? (num % arg) : 0; // !!! was macro called REM2 (?)
+ break;
+
+ case SYM_AND_T:
+ num &= arg;
+ break;
+
+ case SYM_OR_T:
+ num |= arg;
+ break;
+
+ case SYM_XOR_T:
+ num ^= arg;
+ break;
+
+ case SYM_NEGATE:
+ if (num == MIN_I64)
+ fail (Error_Overflow_Raw());
+ num = -num;
+ break;
+
+ case SYM_COMPLEMENT:
+ num = ~num;
+ break;
+
+ case SYM_ABSOLUTE:
+ if (num == MIN_I64)
+ fail (Error_Overflow_Raw());
+ if (num < 0)
+ num = -num;
+ break;
+
+ case SYM_EVEN_Q:
+ num = ~num;
+ // falls through
+ case SYM_ODD_Q:
+ if (num & 1)
+ return R_TRUE;
+ return R_FALSE;
+
+ case SYM_ROUND: {
+ INCLUDE_PARAMS_OF_ROUND;
+
+ UNUSED(PAR(value));
+
+ REBFLGS flags = (
+ (REF(to) ? RF_TO : 0)
+ | (REF(even) ? RF_EVEN : 0)
+ | (REF(down) ? RF_DOWN : 0)
+ | (REF(half_down) ? RF_HALF_DOWN : 0)
+ | (REF(floor) ? RF_FLOOR : 0)
+ | (REF(ceiling) ? RF_CEILING : 0)
+ | (REF(half_ceiling) ? RF_HALF_CEILING : 0)
+ );
+
+ val2 = ARG(scale);
+ if (REF(to)) {
+ if (IS_MONEY(val2)) {
+ Init_Money(D_OUT, Round_Deci(
+ int_to_deci(num), flags, VAL_MONEY_AMOUNT(val2)
+ ));
+ return R_OUT;
+ }
+ if (IS_DECIMAL(val2) || IS_PERCENT(val2)) {
+ REBDEC dec = Round_Dec(
+ cast(REBDEC, num), flags, VAL_DECIMAL(val2)
+ );
+ VAL_RESET_HEADER(D_OUT, VAL_TYPE(val2));
+ VAL_DECIMAL(D_OUT) = dec;
+ return R_OUT;
+ }
+ if (IS_TIME(val2))
+ fail (val2);
+ arg = VAL_INT64(val2);
+ }
+ else
+ arg = 0L;
+ num = Round_Int(num, flags, arg);
+ break; }
+
+ case SYM_RANDOM: {
+ INCLUDE_PARAMS_OF_RANDOM;
+
+ UNUSED(PAR(value));
+
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+
+ if (REF(seed)) {
+ Set_Random(num);
+ return R_VOID;
+ }
+ if (num == 0)
+ break;
+ num = Random_Range(num, REF(secure)); // !!! 64 bits
+ break; }
+
+ default:
+ fail (Error_Illegal_Action(REB_INTEGER, action));
+ }
+
+ Init_Integer(D_OUT, num);
+ return R_OUT;
}
diff --git a/src/core/t-library.c b/src/core/t-library.c
new file mode 100644
index 0000000000..115ecaa92a
--- /dev/null
+++ b/src/core/t-library.c
@@ -0,0 +1,112 @@
+//
+// File: %t-library.c
+// Summary: "External Library Support"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2014 Atronix Engineering, Inc.
+// Copyright 2014-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+
+#include "sys-core.h"
+
+
+//
+// CT_Library: C
+//
+REBINT CT_Library(const RELVAL *a, const RELVAL *b, REBINT mode)
+{
+ if (mode >= 0) {
+ return VAL_LIBRARY(a) == VAL_LIBRARY(b);
+ }
+ return -1;
+}
+
+
+//
+// MAKE_Library: C
+//
+void MAKE_Library(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ assert(kind == REB_LIBRARY);
+ UNUSED(kind);
+
+ if (!IS_FILE(arg))
+ fail (Error_Unexpected_Type(REB_FILE, VAL_TYPE(arg)));
+
+ REBCNT error = 0;
+
+ REBSER *path = Value_To_OS_Path(arg, FALSE);
+ void *fd = OS_OPEN_LIBRARY(SER_HEAD(REBCHR, path), &error);
+ Free_Series(path);
+
+ if (!fd)
+ fail (Error_Bad_Make(REB_LIBRARY, arg));
+
+ REBARR *singular = Alloc_Singular_Array();
+ VAL_RESET_HEADER(ARR_HEAD(singular), REB_LIBRARY);
+ ARR_HEAD(singular)->payload.library.singular = singular;
+
+ SER(singular)->misc.fd = fd;
+ SER(singular)->link.meta = NULL; // build from spec, e.g. arg?
+
+ MANAGE_ARRAY(singular);
+ Move_Value(out, KNOWN(ARR_HEAD(singular)));
+}
+
+
+//
+// TO_Library: C
+//
+void TO_Library(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ MAKE_Library(out, kind, arg);
+}
+
+
+//
+// REBTYPE: C
+//
+REBTYPE(Library)
+{
+ switch(action) {
+ case SYM_CLOSE: {
+ INCLUDE_PARAMS_OF_CLOSE;
+
+ REBVAL *lib = ARG(port); // !!! generic arg name is "port"?
+
+ if (VAL_LIBRARY_FD(lib) == NULL) {
+ // allow to CLOSE an already closed library
+ }
+ else {
+ OS_CLOSE_LIBRARY(VAL_LIBRARY_FD(lib));
+ SER(VAL_LIBRARY(lib))->misc.fd = NULL;
+ }
+ return R_VOID; }
+
+ default:
+ break;
+ }
+
+ fail (Error_Illegal_Action(REB_LIBRARY, action));
+}
diff --git a/src/core/t-logic.c b/src/core/t-logic.c
index e4bc99e215..eed4d323a1 100644
--- a/src/core/t-logic.c
+++ b/src/core/t-logic.c
@@ -1,181 +1,268 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-logic.c
-** Summary: logic datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-/*
-** Symbolic bit logic was experimental - but proved not to add much
-** value because the overhead of access offset the savings of storage.
-** It would be better to add a general purpose bit parsing dialect,
-** somewhat similar to R2's struct datatype.
-*/
+//
+// File: %t-logic.c
+// Summary: "logic datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
#include "sys-deci-funcs.h"
-/***********************************************************************
-**
-*/ REBINT CT_Logic(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// and?: native [
+//
+// {Returns true if both values are conditionally true (no "short-circuit")}
+//
+// value1 [any-value!]
+// value2 [any-value!]
+// ]
+//
+REBNATIVE(and_q)
{
- if (mode >= 0) return (VAL_LOGIC(a) == VAL_LOGIC(b));
- return -1;
+ INCLUDE_PARAMS_OF_AND_Q;
+
+ if (IS_CONDITIONAL_TRUE(ARG(value1)) && IS_CONDITIONAL_TRUE(ARG(value2)))
+ return R_TRUE;
+
+ return R_FALSE;
+}
+
+
+//
+// nor?: native [
+//
+// {Returns true if both values are conditionally false (no "short-circuit")}
+//
+// value1 [any-value!]
+// value2 [any-value!]
+// ]
+//
+REBNATIVE(nor_q)
+{
+ INCLUDE_PARAMS_OF_NOR_Q;
+
+ if (IS_CONDITIONAL_FALSE(ARG(value1)) && IS_CONDITIONAL_FALSE(ARG(value2)))
+ return R_TRUE;
+
+ return R_FALSE;
+}
+
+
+//
+// nand?: native [
+//
+// {Returns false if both values are conditionally true (no "short-circuit")}
+//
+// value1 [any-value!]
+// value2 [any-value!]
+// ]
+//
+REBNATIVE(nand_q)
+{
+ INCLUDE_PARAMS_OF_NAND_Q;
+
+ return R_FROM_BOOL(LOGICAL(
+ IS_CONDITIONAL_TRUE(ARG(value1)) && IS_CONDITIONAL_TRUE(ARG(value2))
+ ));
+}
+
+
+//
+// not?: native [
+//
+// "Returns the logic complement."
+//
+// value [any-value!]
+// "(Only LOGIC!'s FALSE and BLANK! return TRUE)"
+// ]
+//
+REBNATIVE(not_q)
+{
+ INCLUDE_PARAMS_OF_NOT_Q;
+
+ return R_FROM_BOOL(IS_CONDITIONAL_FALSE(ARG(value)));
+}
+
+
+//
+// or?: native [
+//
+// {Returns true if either value is conditionally true (no "short-circuit")}
+//
+// value1 [any-value!]
+// value2 [any-value!]
+// ]
+//
+REBNATIVE(or_q)
+{
+ INCLUDE_PARAMS_OF_OR_Q;
+
+ return R_FROM_BOOL(LOGICAL(
+ IS_CONDITIONAL_TRUE(ARG(value1)) || IS_CONDITIONAL_TRUE(ARG(value2))
+ ));
}
-/***********************************************************************
-**
-*/ REBFLG MT_Logic(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+//
+// xor?: native [
+//
+// {Returns true if only one of the two values is conditionally true.}
+//
+// value1 [any-value!]
+// value2 [any-value!]
+// ]
+//
+REBNATIVE(xor_q)
{
- if (!IS_INTEGER(data)) return FALSE;
- SET_LOGIC(out, VAL_INT64(data) != 0);
- return TRUE;
+ INCLUDE_PARAMS_OF_XOR_Q;
+
+ // Note: no boolean ^^ in C; normalize to booleans and check unequal
+ //
+ return R_FROM_BOOL(LOGICAL(
+ !IS_CONDITIONAL_TRUE(ARG(value1)) != !IS_CONDITIONAL_TRUE(ARG(value2))
+ ));
}
-#ifdef removed
-static int find_word(REBVAL *val, REBVAL *word)
+
+//
+// CT_Logic: C
+//
+REBINT CT_Logic(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBCNT sym = VAL_WORD_CANON(word);
- REBINT n;
+ if (mode >= 0) return (VAL_LOGIC(a) == VAL_LOGIC(b));
+ return -1;
+}
+
+
+//
+// MAKE_Logic: C
+//
+void MAKE_Logic(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+ assert(kind == REB_LOGIC);
+ UNUSED(kind);
+
+ // As a construction routine, MAKE takes more liberties in the
+ // meaning of its parameters, so it lets zero values be false.
+ //
+ // !!! Is there a better idea for MAKE that does not hinge on the
+ // "zero is false" concept? Is there a reason it should?
+ //
+ if (
+ IS_CONDITIONAL_FALSE(arg)
+ || (IS_INTEGER(arg) && VAL_INT64(arg) == 0)
+ || (
+ (IS_DECIMAL(arg) || IS_PERCENT(arg))
+ && (VAL_DECIMAL(arg) == 0.0)
+ )
+ || (IS_MONEY(arg) && deci_is_zero(VAL_MONEY_AMOUNT(arg)))
+ ) {
+ Init_Logic(out, FALSE);
+ }
+ else
+ Init_Logic(out, TRUE);
+}
+
- for (n = 0; NOT_END(val+n); n++) {
- if (sym == VAL_WORD_CANON(val+n)) return 1<select)) {
- if (!VAL_LOGIC_WORDS(pvs->value) ||
- !(bit = find_word(BLK_HEAD(VAL_LOGIC_WORDS(pvs->value)), sel)))
- return PE_BAD_SELECT;
- }
- else if (IS_INTEGER(sel)) {
- bit = Int32(sel);
- if (bit < 0 || bit > 31) return PE_BAD_SELECT;
- bit = 1 << bit;
- }
- else
- return PE_BAD_SELECT;
-
- if (NZ(val = pvs->setval)) {
- if (IS_LOGIC(val)) i = VAL_LOGIC(val);
- else if (IS_INTEGER(val)) i = Int32(val);
- else return PE_BAD_SET;
- if (i) VAL_LOGIC(pvs->value) |= bit;
- else VAL_LOGIC(pvs->value) &= ~bit;
- return PE_OK;
- } else {
- SET_LOGIC(pvs->store, VAL_LOGIC(pvs->value) & bit);
- return PE_USE;
- }
+ if (IS_LOGIC(arg))
+ return VAL_LOGIC(arg);
+
+ if (IS_BLANK(arg))
+ return FALSE;
+
+ fail (Error_Unexpected_Type(REB_LOGIC, VAL_TYPE(arg)));
}
-#endif
-/***********************************************************************
-**
-*/ REBTYPE(Logic)
-/*
-***********************************************************************/
+
+//
+// REBTYPE: C
+//
+REBTYPE(Logic)
{
- REBCNT val1 = VAL_LOGIC(D_ARG(1));
- REBCNT val2;
- REBVAL *arg = D_ARG(2);
-
- if (IS_BINARY_ACT(action)) {
- if (IS_LOGIC(arg)) val2 = VAL_LOGIC(arg);
- else if (IS_NONE(arg)) val2 = FALSE;
- else Trap_Types(RE_EXPECT_VAL, REB_LOGIC, VAL_TYPE(arg));
- }
-
- switch (action) {
-
- case A_AND: val1 &= val2; break;
- case A_OR: val1 |= val2; break;
- case A_XOR: val1 ^= val2; break;
- case A_COMPLEMENT: val1 = 1 & ~val1; break;
-
- case A_RANDOM:
- if (D_REF(2)) { // /seed
- // random/seed false restarts; true randomizes
- Set_Random(val1 ? (REBINT)OS_DELTA_TIME(0, 0) : 1);
- return R_UNSET;
- }
- DECIDE(Random_Int(D_REF(3)) & 1); // /secure
-
- case A_MAKE:
- case A_TO:
- // As a "Rebol conversion", TO falls in line with the rest of the
- // interpreter canon that all non-none non-logic values are
- // considered effectively "truth". As a construction routine,
- // MAKE takes more liberties in the meaning of its parameters,
- // so it lets zero values be false.
- if (IS_NONE(arg) ||
- (IS_LOGIC(arg) && !VAL_LOGIC(arg)) ||
- (IS_INTEGER(arg) && (action == A_MAKE && VAL_INT64(arg) == 0)) ||
- ((IS_DECIMAL(arg) || IS_PERCENT(arg)) && (action == A_MAKE && VAL_DECIMAL(arg) == 0.0)) ||
- (IS_MONEY(arg) && (action == A_MAKE && deci_is_zero(VAL_DECI(arg))))
- ) goto is_false;
- goto is_true;
-
-#ifdef removed
- case A_CHANGE:
- if (IS_NONE(arg)) val1 = 0;
- else if (IS_INTEGER(arg)) val1 = Int32(arg);
- else if (IS_LOGIC(arg)) val1 = TRUE;
- else Trap_Arg(arg);
- break;
-#endif
-
- default:
- Trap_Action(REB_LOGIC, action);
- }
-
- // Keep other fields AS IS!
- VAL_LOGIC(D_ARG(1)) = val1;
- return R_ARG1;
-
-is_false:
- return R_FALSE;
-
-is_true:
- return R_TRUE;
+ REBOOL val1 = VAL_LOGIC(D_ARG(1));
+ REBOOL val2;
+
+ switch (action) {
+
+ case SYM_AND_T:
+ val2 = Math_Arg_For_Logic(D_ARG(2));
+ val1 = LOGICAL(val1 && val2);
+ break;
+
+ case SYM_OR_T:
+ val2 = Math_Arg_For_Logic(D_ARG(2));
+ val1 = LOGICAL(val1 || val2);
+ break;
+
+ case SYM_XOR_T:
+ val2 = Math_Arg_For_Logic(D_ARG(2));
+ val1 = LOGICAL(!val1 != !val2);
+ break;
+
+ case SYM_COMPLEMENT:
+ val1 = NOT(val1);
+ break;
+
+ case SYM_RANDOM: {
+ INCLUDE_PARAMS_OF_RANDOM;
+
+ UNUSED(PAR(value));
+
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+
+ if (REF(seed)) {
+ // random/seed false restarts; true randomizes
+ Set_Random(val1 ? (REBINT)OS_DELTA_TIME(0, 0) : 1);
+ return R_VOID;
+ }
+ if (Random_Int(REF(secure)) & 1)
+ return R_TRUE;
+ return R_FALSE; }
+
+ default:
+ fail (Error_Illegal_Action(REB_LOGIC, action));
+ }
+
+ return val1 ? R_TRUE : R_FALSE;
}
diff --git a/src/core/t-map.c b/src/core/t-map.c
old mode 100644
new mode 100755
index 680f9ba517..fe8726edcb
--- a/src/core/t-map.c
+++ b/src/core/t-map.c
@@ -1,570 +1,768 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-map.c
-** Summary: map datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-/*
- A map is a SERIES that can also include a hash table for faster lookup.
-
- The hashing method used here is the same as that used for the
- REBOL symbol table, with the exception that this method must
- also store the value of the symbol (not just its word).
-
- The structure of the series header for a map is the same as other
- series, except that the opt series field is a pointer to a REBCNT
- series, the hash table.
-
- The hash table is an array of REBCNT integers that are index values
- into the map series. NOTE: They are one-based to avoid 0 which is an
- empty slot.
-
- Each value in the map consists of a word followed by its value.
-
- These functions are also used hashing SET operations (e.g. UNION).
-
- The series/tail / 2 is the number of values stored.
-
- The hash-series/tail is a prime number that is use for computing
- slots in the hash table.
-*/
+//
+// File: %t-map.c
+// Summary: "map datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// See %sys-map.h for an explanation of the map structure.
+//
#include "sys-core.h"
-#define MIN_DICT 8 // size to switch to hashing
-
-
-/***********************************************************************
-**
-*/ REBINT CT_Map(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Map: C
+//
+REBINT CT_Map(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- if (mode < 0) return -1;
- if (mode == 3) return VAL_SERIES(a) == VAL_SERIES(b);
- return 0 == Cmp_Block(a, b, 0);
+ if (mode < 0) return -1;
+ return 0 == Cmp_Array(a, b, FALSE);
}
-/***********************************************************************
-**
-*/ static REBSER *Make_Map(REBINT size)
-/*
-** Makes a MAP block (that holds both keys and values).
-** Size is the number of key-value pairs.
-** If size >= MIN_DICT, then a hash series is also created.
-**
-***********************************************************************/
+//
+// Make_Map: C
+//
+// Makes a MAP block (that holds both keys and values).
+// Capacity is measured in key-value pairings.
+// A hash series is also created.
+//
+static REBMAP *Make_Map(REBCNT capacity)
{
- REBSER *blk = Make_Block(size*2);
- REBSER *ser = 0;
+ REBARR *pairlist = Make_Array_Core(capacity * 2, ARRAY_FLAG_PAIRLIST);
+ SER(pairlist)->link.hashlist = Make_Hash_Sequence(capacity);
- if (size >= MIN_DICT) ser = Make_Hash_Array(size);
+ return MAP(pairlist);
+}
- blk->series = ser;
- return blk;
+//
+// Find_Key_Hashed: C
+//
+// Returns hash index (either the match or the new one).
+// A return of zero is valid (as a hash index);
+//
+// Wide: width of record (normally 2, a key and a value).
+//
+// Modes:
+// 0 - search, return hash if found or not
+// 1 - search, return hash, else return -1 if not
+// 2 - search, return hash, else append value and return -1
+//
+REBINT Find_Key_Hashed(
+ REBARR *array,
+ REBSER *hashlist,
+ const RELVAL *key, // !!! assumes key is followed by value(s) via ++
+ REBSPC *specifier,
+ REBCNT wide,
+ REBOOL cased,
+ REBYTE mode
+) {
+ REBCNT len = SER_LEN(hashlist);
+ assert(len > 0);
+
+ REBCNT hash = Hash_Value(key);
+
+ // The REBCNT[] hash array size is chosen to try and make a large enough
+ // table relative to the data that collisions will be hopefully not
+ // frequent. But they may still collide. The method R3-Alpha chose to
+ // deal with collisions was to have a "skip" amount that will go try
+ // another hash bucket until the searched for key is found or a 0
+ // entry in the hashlist is found.
+ //
+ // Note: if len and skip are co-primes is guaranteed that repeatedly
+ // adding skip (and subtracting len when needed) all positions are
+ // visited. 1 <= skip < len, and len is prime, so this is guaranteed.
+
+ REBCNT skip = hash % (len - 1) + 1;
+
+ hash = hash % len;
+
+ // a 'zombie' is a key with void value, that may be overwritten. Set to
+ // len to indicate zombie not yet encountered.
+ //
+ REBCNT zombie = len;
+
+ REBCNT uncased = len; // uncased match not yet encountered
+
+ // Scan hash table for match:
+
+ REBCNT *hashes = SER_HEAD(REBCNT, hashlist);
+ REBCNT n;
+ RELVAL *val;
+
+ if (ANY_WORD(key)) {
+ while ((n = hashes[hash])) {
+ val = ARR_AT(array, (n - 1) * wide);
+ if (ANY_WORD(val)) {
+ if (VAL_WORD_SPELLING(key) == VAL_WORD_SPELLING(val))
+ return hash; // exact match
+
+ if (NOT(cased) && uncased == len) // not cased w/no match yet
+ if (VAL_WORD_CANON(key) == VAL_WORD_CANON(val))
+ uncased = hash; // indicate uncased match found
+ }
+ else if (wide > 1 && IS_VOID(++val) && zombie == len) {
+ zombie = hash;
+ }
+ hash += skip;
+ if (hash >= len) hash -= len;
+ }
+ }
+ else if (ANY_BINSTR(key)) {
+ while ((n = hashes[hash])) {
+ val = ARR_AT(array, (n - 1) * wide);
+ if (VAL_TYPE(val) == VAL_TYPE(key)) {
+ if (0 == Compare_String_Vals(val, key, FALSE)) return hash;
+ if (
+ !cased && uncased == len
+ && 0 == Compare_String_Vals(
+ val, key, LOGICAL(!IS_BINARY(key))
+ )
+ ) {
+ uncased = hash;
+ }
+ }
+ if (wide > 1 && IS_VOID(++val) && zombie == len) {
+ zombie = hash;
+ }
+ hash += skip;
+ if (hash >= len) hash -= len;
+ }
+ } else {
+ while ((n = hashes[hash])) {
+ val = ARR_AT(array, (n - 1) * wide);
+ if (VAL_TYPE(val) == VAL_TYPE(key)) {
+ if (0 == Cmp_Value(key, val, TRUE)) {
+ return hash;
+ }
+ if (
+ !cased && uncased == len
+ && REB_CHAR == VAL_TYPE(val)
+ && 0 == Cmp_Value(key, val, FALSE)
+ ) {
+ uncased = hash;
+ }
+ }
+ if (wide > 1 && IS_VOID(++val) && zombie == len) zombie = hash;
+ hash += skip;
+ if (hash >= len) hash -= len;
+ }
+ }
+
+ //assert(n == 0);
+ if (!cased && uncased < len) hash = uncased; // uncased< match
+ else if (zombie < len) { // zombie encountered!
+ assert(mode == 0);
+ hash = zombie;
+ n = hashes[hash];
+ // new key overwrite zombie
+ *ARR_AT(array, (n - 1) * wide) = *key;
+ }
+ // Append new value the target series:
+ if (mode > 1) {
+ REBCNT index;
+ const RELVAL *src = key;
+ hashes[hash] = (ARR_LEN(array) / wide) + 1;
+
+ // This used to use Append_Values_Len, but that is a REBVAL* interface
+ // !!! Should there be an Append_Values_Core which takes RELVAL*?
+ //
+ for (index = 0; index < wide; ++src, ++index)
+ Append_Value_Core(array, src, specifier);
+ }
+
+ return (mode > 0) ? NOT_FOUND : hash;
}
-/***********************************************************************
-**
-*/ REBINT Find_Key(REBSER *series, REBSER *hser, REBVAL *key, REBINT wide, REBCNT cased, REBYTE mode)
-/*
-** Returns hash index (either the match or the new one).
-** A return of zero is valid (as a hash index);
-**
-** Wide: width of record (normally 2, a key and a value).
-**
-** Modes:
-** 0 - search, return hash if found or not
-** 1 - search, return hash, else return -1 if not
-** 2 - search, return hash, else append value and return -1
-**
-***********************************************************************/
+//
+// Rehash_Map: C
+//
+// Recompute the entire hash table for a map. Table must be large enough.
+//
+static void Rehash_Map(REBMAP *map)
{
- REBCNT *hashes;
- REBCNT skip;
- REBCNT hash;
- REBCNT len;
- REBCNT n;
- REBVAL *val;
-
- // Compute hash for value:
- len = hser->tail;
- hash = Hash_Value(key, len);
- if (!hash) Trap_Type(key);
-
- // Determine skip and first index:
- skip = (len == 0) ? 0 : (hash & 0x0000FFFF) % len;
- if (skip == 0) skip = 1;
- hash = (len == 0) ? 0 : (hash & 0x00FFFF00) % len;
-
- // Scan hash table for match:
- hashes = (REBCNT*)hser->data;
- if (ANY_WORD(key)) {
- while (NZ(n = hashes[hash])) {
- val = BLK_SKIP(series, (n-1) * wide);
- if (
- ANY_WORD(val) &&
- (VAL_WORD_SYM(key) == VAL_BIND_SYM(val) ||
- (!cased && VAL_WORD_CANON(key) == VAL_BIND_CANON(val)))
- ) return hash;
- hash += skip;
- if (hash >= len) hash -= len;
- }
- }
- else if (ANY_BINSTR(key)) {
- while (NZ(n = hashes[hash])) {
- val = BLK_SKIP(series, (n-1) * wide);
- if (
- VAL_TYPE(val) == VAL_TYPE(key)
- && 0 == Compare_String_Vals(key, val, (REBOOL)(!IS_BINARY(key) && !cased))
- ) return hash;
- hash += skip;
- if (hash >= len) hash -= len;
- }
- } else {
- while (NZ(n = hashes[hash])) {
- val = BLK_SKIP(series, (n-1) * wide);
- if (VAL_TYPE(val) == VAL_TYPE(key) && 0 == Cmp_Value(key, val, !cased)) return hash;
- hash += skip;
- if (hash >= len) hash -= len;
- }
- }
-
- // Append new value the target series:
- if (mode > 1) {
- hashes[hash] = SERIES_TAIL(series)+1;
- //Debug_Num("hash:", hashes[hash]);
- Append_Series(series, (REBYTE*)key, wide);
- //Dump_Series(series, "hash");
- }
-
- return (mode > 0) ? -1 : hash;
+ REBSER *hashlist = MAP_HASHLIST(map);
+
+ if (!hashlist) return;
+
+ REBCNT *hashes = SER_HEAD(REBCNT, hashlist);
+ REBARR *pairlist = MAP_PAIRLIST(map);
+
+ REBVAL *key = KNOWN(ARR_HEAD(pairlist));
+ REBCNT n;
+
+ for (n = 0; n < ARR_LEN(pairlist); n += 2, key += 2) {
+ const REBOOL cased = TRUE; // cased=TRUE is always fine
+
+ if (IS_VOID(key + 1)) {
+ //
+ // It's a "zombie", move last key to overwrite it
+ //
+ Move_Value(
+ key, KNOWN(ARR_AT(pairlist, ARR_LEN(pairlist) - 2))
+ );
+ Move_Value(
+ &key[1], KNOWN(ARR_AT(pairlist, ARR_LEN(pairlist) - 1))
+ );
+ SET_ARRAY_LEN_NOTERM(pairlist, ARR_LEN(pairlist) - 2);
+ }
+
+ REBCNT hash = Find_Key_Hashed(
+ pairlist, hashlist, key, SPECIFIED, 2, cased, 0
+ );
+ hashes[hash] = n / 2 + 1;
+
+ // discard zombies at end of pairlist
+ //
+ while (IS_VOID(ARR_AT(pairlist, ARR_LEN(pairlist) - 1))) {
+ SET_ARRAY_LEN_NOTERM(pairlist, ARR_LEN(pairlist) - 2);
+ }
+ }
}
-/***********************************************************************
-**
-*/ static void Rehash_Hash(REBSER *series)
-/*
-** Recompute the entire hash table. Table must be large enough.
-**
-***********************************************************************/
+//
+// Expand_Hash: C
+//
+// Expand hash series. Clear it but set its tail.
+//
+void Expand_Hash(REBSER *ser)
{
- REBVAL *val;
- REBCNT n;
- REBCNT key;
- REBCNT *hashes;
-
- if (!series->series) return;
-
- hashes = (REBCNT*)(series->series->data);
-
- val = BLK_HEAD(series);
- for (n = 0; n < series->tail; n += 2, val += 2) {
- key = Find_Key(series, series->series, val, 2, 0, 0);
- hashes[key] = n/2+1;
- }
+ REBINT pnum = Get_Hash_Prime(SER_LEN(ser) + 1);
+ if (pnum == 0) {
+ DECLARE_LOCAL (temp);
+ Init_Integer(temp, SER_LEN(ser) + 1);
+ fail (Error_Size_Limit_Raw(temp));
+ }
+
+ assert(NOT_SER_FLAG(ser, SERIES_FLAG_ARRAY));
+ Remake_Series(
+ ser,
+ pnum + 1,
+ SER_WIDE(ser),
+ SERIES_FLAG_POWER_OF_2 // NOT(NODE_FLAG_NODE) => don't keep data
+ );
+
+ Clear_Series(ser);
+ SET_SERIES_LEN(ser, pnum);
}
-/***********************************************************************
-**
-*/ static REBCNT Find_Entry(REBSER *series, REBVAL *key, REBVAL *val)
-/*
-** Try to find the entry in the map. If not found
-** and val is SET, create the entry and store the key and
-** val.
-**
-** RETURNS: the index to the VALUE or zero if there is none.
-**
-***********************************************************************/
-{
- REBSER *hser = series->series; // can be null
- REBCNT *hashes;
- REBCNT hash;
- REBVAL *v;
- REBCNT n;
-
- if (IS_NONE(key)) return 0;
-
- // We may not be large enough yet for the hash table to
- // be worthwhile, so just do a linear search:
- if (!hser) {
- if (series->tail < MIN_DICT*2) {
- v = BLK_HEAD(series);
- if (ANY_WORD(key)) {
- for (n = 0; n < series->tail; n += 2, v += 2) {
- if (ANY_WORD(v) && SAME_SYM(key, v)) {
- if (val) *++v = *val;
- return n/2+1;
- }
- }
- }
- else if (ANY_BINSTR(key)) {
- for (n = 0; n < series->tail; n += 2, v += 2) {
- if (VAL_TYPE(key) == VAL_TYPE(v) && 0 == Compare_String_Vals(key, v, (REBOOL)!IS_BINARY(v))) {
- if (val) {
- *++v = *val;
-// VAL_SERIES(v) = Copy_Series_Value(val);
-// VAL_INDEX(v) = 0;
- }
- return n/2+1;
- }
- }
- }
- else if (IS_INTEGER(key)) {
- for (n = 0; n < series->tail; n += 2, v += 2) {
- if (IS_INTEGER(v) && VAL_INT64(key) == VAL_INT64(v)) {
- if (val) *++v = *val;
- return n/2+1;
- }
- }
- }
- else if (IS_CHAR(key)) {
- for (n = 0; n < series->tail; n += 2, v += 2) {
- if (IS_CHAR(v) && VAL_CHAR(key) == VAL_CHAR(v)) {
- if (val) *++v = *val;
- return n/2+1;
- }
- }
- }
- else Trap_Type(key);
-
- if (!val) return 0;
- Append_Val(series, key);
- Append_Val(series, val); // no Copy_Series_Value(val) on strings
- return series->tail/2;
- }
-
- // Add hash table:
- //Print("hash added %d", series->tail);
- series->series = hser = Make_Hash_Array(series->tail);
- Rehash_Hash(series);
- }
-
- // Get hash table, expand it if needed:
- if (series->tail > hser->tail/2) {
- Expand_Hash(hser); // modifies size value
- Rehash_Hash(series);
- }
-
- hash = Find_Key(series, hser, key, 2, 0, 0);
- hashes = (REBCNT*)hser->data;
- n = hashes[hash];
-
- // Just a GET of value:
- if (!val) return n;
-
- // Must set the value:
- if (n) { // re-set it:
- *BLK_SKIP(series, ((n-1)*2)+1) = *val; // set it
- return n;
- }
-
- // Create new entry:
- Append_Val(series, key);
- Append_Val(series, val); // no Copy_Series_Value(val) on strings
-
- return (hashes[hash] = series->tail/2);
+//
+// Find_Map_Entry: C
+//
+// Try to find the entry in the map. If not found and val isn't void, create
+// the entry and store the key and val.
+//
+// RETURNS: the index to the VALUE or zero if there is none.
+//
+static REBCNT Find_Map_Entry(
+ REBMAP *map,
+ const RELVAL *key,
+ REBSPC *key_specifier,
+ const RELVAL *val,
+ REBSPC *val_specifier,
+ REBOOL cased // case-sensitive if true
+) {
+ assert(!IS_VOID(key));
+
+ REBSER *hashlist = MAP_HASHLIST(map); // can be null
+ REBARR *pairlist = MAP_PAIRLIST(map);
+
+ assert(hashlist);
+
+ // Get hash table, expand it if needed:
+ if (ARR_LEN(pairlist) > SER_LEN(hashlist) / 2) {
+ Expand_Hash(hashlist); // modifies size value
+ Rehash_Map(map);
+ }
+
+ REBCNT hash = Find_Key_Hashed(
+ pairlist, hashlist, key, key_specifier, 2, cased, 0
+ );
+
+ REBCNT *hashes = SER_HEAD(REBCNT, hashlist);
+ REBCNT n = hashes[hash];
+
+ // n==0 or pairlist[(n-1)*]=~key
+
+ // Just a GET of value:
+ if (!val) return n;
+
+ // If not just a GET, it may try to set the value in the map. Which means
+ // the key may need to be stored. Since copies of keys are never made,
+ // a SET must always be done with an immutable key...because if it were
+ // changed, there'd be no notification to rehash the map.
+ //
+ if (!Is_Value_Immutable(key))
+ fail (Error_Map_Key_Unlocked_Raw(key));
+
+ // Must set the value:
+ if (n) { // re-set it:
+ Derelativize(
+ ARR_AT(pairlist, ((n - 1) * 2) + 1),
+ val,
+ val_specifier
+ );
+ return n;
+ }
+
+ if (IS_VOID(val)) return 0; // trying to remove non-existing key
+
+ // Create new entry. Note that it does not copy underlying series (e.g.
+ // the data of a string), which is why the immutability test is necessary
+ //
+ Append_Value_Core(pairlist, key, key_specifier);
+ Append_Value_Core(pairlist, val, val_specifier);
+
+ return (hashes[hash] = (ARR_LEN(pairlist) / 2));
}
-/***********************************************************************
-**
-*/ REBINT Length_Map(REBSER *series)
-/*
-***********************************************************************/
+//
+// PD_Map: C
+//
+REBINT PD_Map(REBPVS *pvs)
{
- REBCNT n, c = 0;
- REBVAL *v = BLK_HEAD(series);
+ REBOOL setting = LOGICAL(pvs->opt_setval && IS_END(pvs->item + 1));
+
+ assert(IS_MAP(pvs->value));
+
+ if (setting)
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(pvs->value));
+
+ REBINT n = Find_Map_Entry(
+ VAL_MAP(pvs->value),
+ pvs->picker,
+ SPECIFIED,
+ setting ? pvs->opt_setval : NULL,
+ SPECIFIED,
+ setting // `cased` flag for case-sensitivity--use when setting only
+ );
+
+ if (n == 0) {
+ Init_Void(pvs->store);
+ return PE_USE_STORE;
+ }
+
+ REBVAL *val = KNOWN(
+ ARR_AT(MAP_PAIRLIST(VAL_MAP(pvs->value)), ((n - 1) * 2) + 1)
+ );
+ if (IS_VOID(val)) {
+ Init_Void(pvs->store);
+ return PE_USE_STORE;
+ }
+
+ pvs->value = val;
+ pvs->value_specifier = SPECIFIED;
+
+ return PE_OK;
+}
- for (n = 0; n < series->tail; n += 2, v += 2) {
- if (!IS_NONE(v+1)) c++; // must have non-none value
- }
- return c;
+//
+// Append_Map: C
+//
+static void Append_Map(
+ REBMAP *map,
+ REBARR *array,
+ REBCNT index,
+ REBSPC *specifier,
+ REBCNT len
+) {
+ RELVAL *item = ARR_AT(array, index);
+ REBCNT n = 0;
+
+ while (n < len && NOT_END(item)) {
+ if (IS_END(item + 1)) {
+ //
+ // Keys with no value not allowed, e.g. `make map! [1 "foo" 2]`
+ //
+ fail (Error_Past_End_Raw());
+ }
+
+ Find_Map_Entry(
+ map,
+ item,
+ specifier,
+ item + 1,
+ specifier,
+ TRUE
+ );
+
+ item += 2;
+ n += 2;
+ }
}
-/***********************************************************************
-**
-*/ REBINT PD_Map(REBPVS *pvs)
-/*
-***********************************************************************/
+//
+// MAKE_Map: C
+//
+void MAKE_Map(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBVAL *data = pvs->value;
- REBVAL *val = 0;
- REBINT n = 0;
-
- if (IS_END(pvs->path+1)) val = pvs->setval;
- if (IS_NONE(pvs->select)) return PE_NONE;
-
- if (!ANY_WORD(pvs->select) && !ANY_BINSTR(pvs->select) &&
- !IS_INTEGER(pvs->select) && !IS_CHAR(pvs->select))
- return PE_BAD_SELECT;
-
- n = Find_Entry(VAL_SERIES(data), pvs->select, val);
-
- if (!n) return PE_NONE;
-
- TRAP_PROTECT(VAL_SERIES(data));
- pvs->value = VAL_BLK_SKIP(data, ((n-1)*2)+1);
- return PE_OK;
+ if (ANY_NUMBER(arg)) {
+ REBMAP *map = Make_Map(Int32s(arg, 0));
+ Init_Map(out, map);
+ }
+ else {
+ // !!! R3-Alpha TO of MAP! was like MAKE but wouldn't accept just
+ // being given a size.
+ //
+ TO_Map(out, kind, arg);
+ }
}
-/***********************************************************************
-**
-*/ static void Append_Map(REBSER *ser, REBVAL *arg, REBCNT len)
-/*
-***********************************************************************/
+//
+// TO_Map: C
+//
+void TO_Map(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBVAL *val;
- REBCNT n;
-
- val = VAL_BLK_DATA(arg);
- for (n = 0; n < len && NOT_END(val) && NOT_END(val+1); val += 2, n += 2) {
- Find_Entry(ser, val, val+1);
- }
+ assert(kind == REB_MAP);
+ UNUSED(kind);
+
+ REBARR* array;
+ REBCNT len;
+ REBCNT index;
+ REBSPC *specifier;
+
+ if (IS_BLOCK(arg) || IS_GROUP(arg)) {
+ //
+ // make map! [word val word val]
+ //
+ array = VAL_ARRAY(arg);
+ index = VAL_INDEX(arg);
+ len = VAL_ARRAY_LEN_AT(arg);
+ specifier = VAL_SPECIFIER(arg);
+ }
+ else if (IS_MAP(arg)) {
+ array = MAP_PAIRLIST(VAL_MAP(arg));
+ index = 0;// maps don't have an index/"position"
+ len = ARR_LEN(array);
+ specifier = SPECIFIED; // there should be no relative values in a MAP!
+ }
+ else
+ fail (arg);
+
+ REBMAP *map = Make_Map(len / 2); // [key value key value...] + END
+ Append_Map(map, array, index, specifier, len);
+ Rehash_Map(map);
+ Init_Map(out, map);
}
-/***********************************************************************
-**
-*/ REBFLG MT_Map(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+//
+// Map_To_Array: C
+//
+// what: -1 - words, +1 - values, 0 -both
+//
+REBARR *Map_To_Array(REBMAP *map, REBINT what)
{
- REBCNT n;
- REBSER *series;
-
- if (!IS_BLOCK(data) && !IS_MAP(data)) return FALSE;
-
- n = VAL_BLK_LEN(data);
- if (n & 1) return FALSE;
-
- series = Make_Map(n/2);
-
- //COPY_BLK_PART(series, VAL_BLK_DATA(data), n);
- Append_Map(series, data, UNKNOWN);
-
- Rehash_Hash(series);
-
- Set_Series(REB_MAP, out, series);
-
- return TRUE;
+ REBCNT count = Length_Map(map);
+
+ // Copy entries to new block:
+ //
+ REBARR *array = Make_Array(count * ((what == 0) ? 2 : 1));
+ REBVAL *dest = SINK(ARR_HEAD(array));
+ REBVAL *val = KNOWN(ARR_HEAD(MAP_PAIRLIST(map)));
+ for (; NOT_END(val); val += 2) {
+ assert(NOT_END(val + 1));
+ if (!IS_VOID(val + 1)) {
+ if (what <= 0) {
+ Move_Value(dest, &val[0]);
+ ++dest;
+ }
+ if (what >= 0) {
+ Move_Value(dest, &val[1]);
+ ++dest;
+ }
+ }
+ }
+
+ TERM_ARRAY_LEN(array, cast(RELVAL*, dest) - ARR_HEAD(array));
+ assert(IS_END(dest));
+ return array;
}
-/***********************************************************************
-**
-*/ REBSER *Map_To_Block(REBSER *mapser, REBINT what)
-/*
-** mapser = series of the map
-** what: -1 - words, +1 - values, 0 -both
-**
-***********************************************************************/
+//
+// Mutate_Array_Into_Map: C
+//
+// Convert existing array to a map. The array is tested to make sure it is
+// not managed, hence it has not been put into any REBVALs that might use
+// a non-map-aware access to it. (That would risk making changes to the
+// array that did not keep the hashes in sync.)
+//
+REBMAP *Mutate_Array_Into_Map(REBARR *a)
{
- REBVAL *val;
- REBCNT cnt = 0;
- REBSER *blk;
- REBVAL *out;
-
- // Count number of set entries:
- for (val = BLK_HEAD(mapser); NOT_END(val) && NOT_END(val+1); val += 2) {
- if (!IS_NONE(val+1)) cnt++; // must have non-none value
- }
-
- // Copy entries to new block:
- blk = Make_Block(cnt * ((what == 0) ? 2 : 1));
- out = BLK_HEAD(blk);
- for (val = BLK_HEAD(mapser); NOT_END(val) && NOT_END(val+1); val += 2) {
- if (!IS_NONE(val+1)) {
- if (what <= 0) *out++ = val[0];
- if (what >= 0) *out++ = val[1];
- }
- }
-
- SET_END(out);
- blk->tail = out - BLK_HEAD(blk);
- return blk;
-}
+ REBCNT size = ARR_LEN(a);
+ // See note above--can't have this array be accessible via some ANY-BLOCK!
+ //
+ assert(NOT(IS_ARRAY_MANAGED(a)));
-/***********************************************************************
-**
-*/ void Block_As_Map(REBSER *blk)
-/*
-** Convert existing block to a map.
-**
-***********************************************************************/
-{
- REBSER *ser = 0;
- REBCNT size = SERIES_TAIL(blk);
+ SET_SER_FLAG(a, ARRAY_FLAG_PAIRLIST);
+
+ REBMAP *map = MAP(a);
+ MAP_HASHLIST(map) = Make_Hash_Sequence(size);
- if (size >= MIN_DICT) ser = Make_Hash_Array(size);
- blk->series = ser;
- Rehash_Hash(blk);
+ Rehash_Map(map);
+ return map;
}
-/***********************************************************************
-**
-*/ REBSER *Map_To_Object(REBSER *mapser)
-/*
-***********************************************************************/
+//
+// Alloc_Context_From_Map: C
+//
+REBCTX *Alloc_Context_From_Map(REBMAP *map)
{
- REBVAL *val;
- REBCNT cnt = 0;
- REBSER *frame;
- REBVAL *word;
- REBVAL *mval;
-
- // Count number of set entries:
- for (mval = BLK_HEAD(mapser); NOT_END(mval) && NOT_END(mval+1); mval += 2) {
- if (ANY_WORD(mval) && !IS_NONE(mval+1)) cnt++;
- }
-
- // See Make_Frame() - cannot use it directly because no Collect_Words
- frame = Make_Frame(cnt);
-
- word = FRM_WORD(frame, 1);
- val = FRM_VALUE(frame, 1);
- for (mval = BLK_HEAD(mapser); NOT_END(mval) && NOT_END(mval+1); mval += 2) {
- if (ANY_WORD(mval) && !IS_NONE(mval+1)) {
- VAL_SET(word, REB_SET_WORD);
- VAL_SET_OPT(word, OPTS_UNWORD);
- VAL_BIND_SYM(word) = VAL_WORD_SYM(mval);
- VAL_BIND_TYPESET(word) = ~((TYPESET(REB_END) | TYPESET(REB_UNSET))); // not END or UNSET
- word++;
- *val++ = mval[1];
- }
- }
-
- SET_END(word);
- SET_END(val);
- FRM_WORD_SERIES(frame)->tail = frame->tail = cnt + 1;
-
- return frame;
+ // Doesn't use Length_Map because it only wants to consider words.
+ //
+ // !!! Should this fail() if any of the keys aren't words? It seems
+ // a bit haphazard to have `make object! make map! [x 10 20]` and
+ // just throw out the 20 case...
+
+ REBVAL *mval = KNOWN(ARR_HEAD(MAP_PAIRLIST(map)));
+ REBCNT count = 0;
+
+ for (; NOT_END(mval); mval += 2) {
+ assert(NOT_END(mval + 1));
+ if (ANY_WORD(mval) && !IS_VOID(mval + 1))
+ ++count;
+ }
+
+ // See Alloc_Context() - cannot use it directly because no Collect_Words
+
+ REBCTX *context = Alloc_Context(REB_OBJECT, count);
+ REBVAL *key = CTX_KEYS_HEAD(context);
+ REBVAL *var = CTX_VARS_HEAD(context);
+
+ mval = KNOWN(ARR_HEAD(MAP_PAIRLIST(map)));
+
+ for (; NOT_END(mval); mval += 2) {
+ assert(NOT_END(mval + 1));
+ if (ANY_WORD(mval) && !IS_VOID(mval + 1)) {
+ // !!! Used to leave SET_WORD typed values here... but why?
+ // (Objects did not make use of the set-word vs. other distinctions
+ // that function specs did.)
+ Init_Typeset(
+ key,
+ // all types except void
+ ~FLAGIT_KIND(REB_MAX_VOID),
+ VAL_WORD_SPELLING(mval)
+ );
+ ++key;
+ Move_Value(var, &mval[1]);
+ ++var;
+ }
+ }
+
+ TERM_ARRAY_LEN(CTX_VARLIST(context), count + 1);
+ TERM_ARRAY_LEN(CTX_KEYLIST(context), count + 1);
+ assert(IS_END(key));
+ assert(IS_END(var));
+
+ return context;
}
-/***********************************************************************
-**
-*/ REBTYPE(Map)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+REBTYPE(Map)
{
- REBVAL *val = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBINT n;
- REBSER *series = VAL_SERIES(val);
-
- // Check must be in this order (to avoid checking a non-series value);
- if (action >= A_TAKE && action <= A_SORT && IS_PROTECT_SERIES(series))
- Trap0(RE_PROTECTED);
-
- switch (action) {
-
- case A_PICK: // same as SELECT for MAP! datatype
- case A_SELECT:
- n = Find_Entry(series, arg, 0);
- if (!n) return R_NONE;
- *D_RET = *VAL_BLK_SKIP(val, ((n-1)*2)+1);
- break;
-
- case A_INSERT:
- case A_APPEND:
- if (!IS_BLOCK(arg)) Trap_Arg(val);
- *D_RET = *val;
- if (DS_REF(AN_DUP)) {
- n = Int32(DS_ARG(AN_COUNT));
- if (n <= 0) break;
- }
- Append_Map(series, arg, Partial1(arg, D_ARG(AN_LENGTH)));
- break;
-
- case A_POKE: // CHECK all pokes!!! to be sure they check args now !!!
- n = Find_Entry(series, arg, D_ARG(3));
- *D_RET = *D_ARG(3);
- break;
-
- case A_LENGTHQ:
- n = Length_Map(series);
- DS_RET_INT(n);
- break;
-
- case A_MAKE:
- case A_TO:
- // make map! [word val word val]
- if (IS_BLOCK(arg) || IS_PAREN(arg) || IS_MAP(arg)) {
- if (MT_Map(D_RET, arg, 0)) return R_RET;
- Trap_Arg(arg);
-// } else if (IS_NONE(arg)) {
-// n = 3; // just a start
- // make map! 10000
- } else if (IS_NUMBER(arg)) {
- if (action == A_TO) Trap_Arg(arg);
- n = Int32s(arg, 0);
- } else
- Trap_Make(REB_MAP, Of_Type(arg));
- // positive only
- series = Make_Map(n);
- Set_Series(REB_MAP, D_RET, series);
- break;
-
- case A_COPY:
- if (MT_Map(D_RET, val, 0)) return R_RET;
- Trap_Arg(val);
-
- case A_CLEAR:
- Clear_Series(series);
- if (series->series) Clear_Series(series->series);
- Set_Series(REB_MAP, D_RET, series);
- break;
-
- case A_REFLECT:
- action = What_Reflector(arg); // zero on error
- // Adjust for compatibility with PICK:
- if (action == OF_VALUES) n = 1;
- else if (action == OF_WORDS) n = -1;
- else if (action == OF_BODY) n = 0;
- else Trap_Reflect(REB_MAP, arg);
- series = Map_To_Block(series, n);
- Set_Block(D_RET, series);
- break;
-
- case A_TAILQ:
- return (Length_Map(series) == 0) ? R_TRUE : R_FALSE;
-
- default:
- Trap_Action(REB_MAP, action);
- }
-
- return R_RET;
+ REBVAL *val = D_ARG(1);
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+
+ REBMAP *map = VAL_MAP(val);
+ REBCNT tail;
+
+ switch (action) {
+ case SYM_FIND:
+ case SYM_SELECT_P: {
+ INCLUDE_PARAMS_OF_FIND;
+
+ UNUSED(PAR(series));
+ UNUSED(PAR(value)); // handled as `arg`
+
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(skip)) {
+ UNUSED(ARG(size));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(last))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(reverse))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(tail))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(match))
+ fail (Error_Bad_Refines_Raw());
+
+ REBINT n = Find_Map_Entry(
+ map,
+ arg,
+ SPECIFIED,
+ NULL,
+ SPECIFIED,
+ REF(case)
+ );
+
+ if (n == 0)
+ return action == SYM_FIND ? R_FALSE : R_VOID;
+
+ Move_Value(
+ D_OUT,
+ KNOWN(ARR_AT(MAP_PAIRLIST(map), ((n - 1) * 2) + 1))
+ );
+
+ if (action == SYM_FIND)
+ return IS_VOID(D_OUT) ? R_FALSE : R_TRUE;
+
+ return R_OUT; }
+
+ case SYM_INSERT:
+ case SYM_APPEND: {
+ INCLUDE_PARAMS_OF_INSERT;
+
+ FAIL_IF_READ_ONLY_ARRAY(MAP_PAIRLIST(map));
+
+ UNUSED(PAR(series));
+ UNUSED(PAR(value)); // handled as arg
+
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+
+ if (!IS_BLOCK(arg))
+ fail (val);
+ Move_Value(D_OUT, val);
+ if (REF(dup)) {
+ if (Int32(ARG(count)) <= 0) break;
+ }
+
+ UNUSED(REF(part));
+ Partial1(arg, ARG(limit), &tail);
+ Append_Map(
+ map,
+ VAL_ARRAY(arg),
+ VAL_INDEX(arg),
+ VAL_SPECIFIER(arg),
+ tail
+ );
+ return R_OUT; }
+
+ case SYM_REMOVE: {
+ INCLUDE_PARAMS_OF_REMOVE;
+
+ FAIL_IF_READ_ONLY_ARRAY(MAP_PAIRLIST(map));
+
+ UNUSED(PAR(series));
+
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (NOT(REF(map)))
+ fail (Error_Illegal_Action(REB_MAP, action));
+
+ Move_Value(D_OUT, val);
+ Find_Map_Entry(
+ map, ARG(key), SPECIFIED, VOID_CELL, SPECIFIED, TRUE
+ );
+ return R_OUT; }
+
+ case SYM_LENGTH_OF:
+ Init_Integer(D_OUT, Length_Map(map));
+ return R_OUT;
+
+ case SYM_COPY: {
+ INCLUDE_PARAMS_OF_COPY;
+
+ UNUSED(PAR(value));
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(deep))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(types)) {
+ UNUSED(ARG(kinds));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ // !!! the copying map case should probably not be a MAKE case, but
+ // implemented here as copy.
+ //
+ MAKE_Map(D_OUT, REB_MAP, val); // may fail()
+ return R_OUT; }
+
+ case SYM_CLEAR:
+ FAIL_IF_READ_ONLY_ARRAY(MAP_PAIRLIST(map));
+
+ Reset_Array(MAP_PAIRLIST(map));
+
+ // !!! Review: should the space for the hashlist be reclaimed? This
+ // clears all the indices but doesn't scale back the size.
+ //
+ Clear_Series(MAP_HASHLIST(map));
+
+ Init_Map(D_OUT, map);
+ return R_OUT;
+
+ case SYM_REFLECT: {
+ REBSYM sym = VAL_WORD_SYM(arg);
+
+ REBINT n;
+ if (sym == SYM_VALUES)
+ n = 1;
+ else if (sym == SYM_WORDS)
+ n = -1;
+ else if (sym == SYM_BODY)
+ n = 0;
+ else
+ fail (Error_Cannot_Reflect(REB_MAP, arg));
+
+ REBARR *array = Map_To_Array(map, n);
+ Init_Block(D_OUT, array);
+ return R_OUT;
+ }
+
+ case SYM_TAIL_Q:
+ return (Length_Map(map) == 0) ? R_TRUE : R_FALSE;
+
+ default:
+ break;
+ }
+
+ fail (Error_Illegal_Action(REB_MAP, action));
}
diff --git a/src/core/t-money.c b/src/core/t-money.c
index 5089c5e148..7a70f14c94 100644
--- a/src/core/t-money.c
+++ b/src/core/t-money.c
@@ -1,252 +1,290 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-money.c
-** Summary: extended precision datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-money.c
+// Summary: "extended precision datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
#include "sys-deci-funcs.h"
-/***********************************************************************
-**
-*/ REBINT CT_Money(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Money: C
+//
+REBINT CT_Money(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBFLG e, g;
-
- if (mode >= 3) e = deci_is_same(VAL_DECI(a), VAL_DECI(b));
- else {
- e = deci_is_equal(VAL_DECI(a), VAL_DECI(b));
- g = 0;
- if (mode < 0) {
- g = deci_is_lesser_or_equal(VAL_DECI(b), VAL_DECI(a));
- if (mode == -1) e |= g;
- else e = g & !e;
- }
- }
- return e != 0;;
+ REBOOL e, g;
+
+ e = deci_is_equal(VAL_MONEY_AMOUNT(a), VAL_MONEY_AMOUNT(b));
+ if (mode < 0) {
+ g = deci_is_lesser_or_equal(
+ VAL_MONEY_AMOUNT(b), VAL_MONEY_AMOUNT(a)
+ );
+ if (mode == -1) e = LOGICAL(e || g);
+ else e = LOGICAL(g && !e);
+ }
+ return e ? 1 : 0;
}
-/***********************************************************************
-**
-*/ REBINT Emit_Money(REBVAL *value, REBYTE *buf, REBCNT opts)
-/*
-***********************************************************************/
+//
+// MAKE_Money: C
+//
+void MAKE_Money(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- return deci_to_string(buf, VAL_DECI(value), '$', '.');
+ assert(kind == REB_MONEY);
+ UNUSED(kind);
+
+ switch (VAL_TYPE(arg)) {
+ case REB_INTEGER:
+ Init_Money(out, int_to_deci(VAL_INT64(arg)));
+ break;
+
+ case REB_DECIMAL:
+ case REB_PERCENT:
+ Init_Money(out, decimal_to_deci(VAL_DECIMAL(arg)));
+ break;
+
+ case REB_MONEY:
+ Move_Value(out, arg);
+ return;
+
+ case REB_STRING:
+ {
+ const REBYTE *end;
+ REBYTE *str = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_MONEY, 0, FALSE);
+ Init_Money(out, string_to_deci(str, &end));
+ if (end == str || *end != 0)
+ goto bad_make;
+ break;
+ }
+
+// case REB_ISSUE:
+ case REB_BINARY:
+ Bin_To_Money_May_Fail(out, arg);
+ break;
+
+ case REB_LOGIC:
+ Init_Money(out, int_to_deci(VAL_LOGIC(arg) ? 1 : 0));
+ break;
+
+ default:
+ bad_make:
+ fail (Error_Bad_Make(REB_MONEY, arg));
+ }
+
+ VAL_RESET_HEADER(out, REB_MONEY);
}
-/***********************************************************************
-**
-*/ REBINT Bin_To_Money(REBVAL *result, REBVAL *val)
-/*
-***********************************************************************/
+//
+// TO_Money: C
+//
+void TO_Money(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBCNT len;
- REBYTE buf[MAX_HEX_LEN+4] = {0}; // binary to convert
-
- if (IS_BINARY(val)) {
- len = VAL_LEN(val);
- if (len > 12) len = 12;
- memcpy(buf, VAL_BIN_DATA(val), len);
- }
-#ifdef removed
- else if (IS_ISSUE(val)) {
- //if (!(len = Scan_Hex_Bytes(val, 24, buf))) return FALSE;
- REBYTE *ap = Get_Word_Name(val);
- REBYTE *bp = &buf[0];
- REBCNT alen;
- REBUNI c;
- len = LEN_BYTES(ap); // UTF-8 len
- if (len & 1) return FALSE; // must have even # of chars
- len /= 2;
- if (len > 12) return FALSE; // valid even for UTF-8
- for (alen = 0; alen < len; alen++) {
- if (!Scan_Hex2(ap, &c, 0)) return FALSE;
- *bp++ = (REBYTE)c;
- ap += 2;
- }
- }
-#endif
- memcpy(buf + 12 - len, buf, len); // shift to right side
- memset(buf, 0, 12 - len);
- VAL_DECI(result) = binary_to_deci(buf);
- return TRUE;
+ MAKE_Money(out, kind, arg);
}
-/***********************************************************************
-**
-*/ REBTYPE(Money)
-/*
-***********************************************************************/
+//
+// Emit_Money: C
+//
+REBINT Emit_Money(const REBVAL *value, REBYTE *buf, REBFLGS opts)
{
- REBVAL *val = D_ARG(1);
- REBVAL *arg;
- REBYTE *str;
- REBINT equal = 1;
-
- if (IS_BINARY_ACT(action)) {
- arg = D_ARG(2);
-
- if (IS_MONEY(arg))
- ;
- else if (IS_INTEGER(arg)) {
- VAL_DECI(D_RET) = int_to_deci(VAL_INT64(arg));
- arg = D_RET;
- }
- else if (IS_DECIMAL(arg) || IS_PERCENT(arg)) {
- VAL_DECI(D_RET) = decimal_to_deci(VAL_DECIMAL(arg));
- arg = D_RET;
- }
- else Trap_Math_Args(REB_MONEY, action);
-
- switch (action) {
- case A_ADD:
- VAL_DECI(D_RET) = deci_add(VAL_DECI(val), VAL_DECI(arg));
- break;
-
- case A_SUBTRACT:
- VAL_DECI(D_RET) = deci_subtract(VAL_DECI(val), VAL_DECI(arg));
- break;
-
- case A_MULTIPLY:
- VAL_DECI(D_RET) = deci_multiply(VAL_DECI(val), VAL_DECI(arg));
- break;
-
- case A_DIVIDE:
- VAL_DECI(D_RET) = deci_divide(VAL_DECI(val), VAL_DECI(arg));
- break;
-
- case A_REMAINDER:
- VAL_DECI(D_RET) = deci_mod(VAL_DECI(val), VAL_DECI(arg));
- break;
-
- default:
- Trap_Action(REB_MONEY, action);
- }
-
- SET_TYPE(D_RET, REB_MONEY);
- return R_RET;
- }
-
- switch(action) {
- case A_NEGATE:
- VAL_DECI(val).s = !VAL_DECI(val).s;
- return R_ARG1;
-
- case A_ABSOLUTE:
- VAL_DECI(val).s = 0;
- return R_ARG1;
-
- case A_ROUND:
- arg = D_ARG(3);
- if (D_REF(2)) {
- if (IS_INTEGER(arg)) VAL_DECI(arg) = int_to_deci(VAL_INT64(arg));
- else if (IS_DECIMAL(arg) || IS_PERCENT(arg)) VAL_DECI(arg) = decimal_to_deci(VAL_DECIMAL(arg));
- else if (!IS_MONEY(arg)) Trap_Arg(arg);
- }
- VAL_DECI(D_RET) = Round_Deci(VAL_DECI(val), Get_Round_Flags(ds), VAL_DECI(arg));
- if (D_REF(2)) {
- if (IS_DECIMAL(arg) || IS_PERCENT(arg)) {
- VAL_DECIMAL(D_RET) = deci_to_decimal(VAL_DECI(D_RET));
- SET_TYPE(D_RET, VAL_TYPE(arg));
- return R_RET;
- }
- if (IS_INTEGER(arg)) {
- VAL_INT64(D_RET) = deci_to_int(VAL_DECI(D_RET));;
- SET_TYPE(D_RET, REB_INTEGER);
- return R_RET;
- }
- }
- break;
-
- case A_EVENQ:
- case A_ODDQ:
- equal = 1 & (REBINT)deci_to_int(VAL_DECI(val));
- if (action == A_EVENQ) equal = !equal;
- if (equal) goto is_true;
- goto is_false;
-
- case A_MAKE:
- case A_TO:
- arg = D_ARG(2);
-
- switch (VAL_TYPE(arg)) {
-
- case REB_INTEGER:
- VAL_DECI(D_RET) = int_to_deci(VAL_INT64(arg));
- break;
-
- case REB_DECIMAL:
- case REB_PERCENT:
- VAL_DECI(D_RET) = decimal_to_deci(VAL_DECIMAL(arg));
- break;
-
- case REB_MONEY:
- return R_ARG2;
-
- case REB_STRING:
- {
- REBYTE *end;
- str = Qualify_String(arg, 36, 0, FALSE);
- VAL_DECI(D_RET) = string_to_deci(str, &end);
- if (end == str || *end != 0) Trap_Make(REB_MONEY, arg);
- break;
- }
-
-// case REB_ISSUE:
- case REB_BINARY:
- if (!Bin_To_Money(D_RET, arg)) goto err;
- break;
-
- case REB_LOGIC:
- equal = !VAL_LOGIC(arg);
-// case REB_NONE: // 'equal defaults to 1
- VAL_DECI(D_RET) = int_to_deci(equal ? 0 : 1);
- break;
-
- default:
- err:
- Trap_Make(REB_MONEY, arg);
- }
- break;
-
- default:
- Trap_Action(REB_MONEY, action);
- }
-
- SET_TYPE(D_RET, REB_MONEY);
- return R_RET;
-
-is_true: return R_TRUE;
-is_false: return R_FALSE;
+ if (opts & MOPT_LIMIT) {
+ // !!! In theory, emits should pay attention to the mold options,
+ // at least the limit.
+ }
+
+ return deci_to_string(buf, VAL_MONEY_AMOUNT(value), '$', '.');
+}
+
+
+//
+// Bin_To_Money_May_Fail: C
+//
+// Will successfully convert or fail (longjmp) with an error.
+//
+void Bin_To_Money_May_Fail(REBVAL *result, const REBVAL *val)
+{
+ REBCNT len;
+ REBYTE buf[MAX_HEX_LEN+4] = {0}; // binary to convert
+
+ if (IS_BINARY(val)) {
+ len = VAL_LEN_AT(val);
+ if (len > 12) len = 12;
+ memcpy(buf, VAL_BIN_AT(val), len);
+ }
+ else
+ fail (val);
+
+ memcpy(buf + 12 - len, buf, len); // shift to right side
+ memset(buf, 0, 12 - len);
+ Init_Money(result, binary_to_deci(buf));
+}
+
+
+static REBVAL *Math_Arg_For_Money(REBVAL *store, REBVAL *arg, REBSYM action)
+{
+ if (IS_MONEY(arg))
+ return arg;
+
+ if (IS_INTEGER(arg)) {
+ Init_Money(store, int_to_deci(VAL_INT64(arg)));
+ return store;
+ }
+
+ if (IS_DECIMAL(arg) || IS_PERCENT(arg)) {
+ Init_Money(store, decimal_to_deci(VAL_DECIMAL(arg)));
+ return store;
+ }
+
+ fail (Error_Math_Args(REB_MONEY, action));
+}
+
+
+//
+// REBTYPE: C
+//
+REBTYPE(Money)
+{
+ REBVAL *val = D_ARG(1);
+ REBVAL *arg;
+
+ switch (action) {
+ case SYM_ADD:
+ arg = Math_Arg_For_Money(D_OUT, D_ARG(2), action);
+ Init_Money(D_OUT, deci_add(
+ VAL_MONEY_AMOUNT(val), VAL_MONEY_AMOUNT(arg)
+ ));
+ break;
+
+ case SYM_SUBTRACT:
+ arg = Math_Arg_For_Money(D_OUT, D_ARG(2), action);
+ Init_Money(D_OUT, deci_subtract(
+ VAL_MONEY_AMOUNT(val), VAL_MONEY_AMOUNT(arg)
+ ));
+ break;
+
+ case SYM_MULTIPLY:
+ arg = Math_Arg_For_Money(D_OUT, D_ARG(2), action);
+ Init_Money(D_OUT, deci_multiply(
+ VAL_MONEY_AMOUNT(val), VAL_MONEY_AMOUNT(arg)
+ ));
+ break;
+
+ case SYM_DIVIDE:
+ arg = Math_Arg_For_Money(D_OUT, D_ARG(2), action);
+ Init_Money(D_OUT, deci_divide(
+ VAL_MONEY_AMOUNT(val), VAL_MONEY_AMOUNT(arg)
+ ));
+ break;
+
+ case SYM_REMAINDER:
+ arg = Math_Arg_For_Money(D_OUT, D_ARG(2), action);
+ Init_Money(D_OUT, deci_mod(
+ VAL_MONEY_AMOUNT(val), VAL_MONEY_AMOUNT(arg)
+ ));
+ break;
+
+ case SYM_NEGATE:
+ val->payload.money.s = !val->payload.money.s;
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT;
+
+ case SYM_ABSOLUTE:
+ val->payload.money.s = 0;
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT;
+
+ case SYM_ROUND: {
+ INCLUDE_PARAMS_OF_ROUND;
+
+ UNUSED(PAR(value));
+
+ REBFLGS flags = (
+ (REF(to) ? RF_TO : 0)
+ | (REF(even) ? RF_EVEN : 0)
+ | (REF(down) ? RF_DOWN : 0)
+ | (REF(half_down) ? RF_HALF_DOWN : 0)
+ | (REF(floor) ? RF_FLOOR : 0)
+ | (REF(ceiling) ? RF_CEILING : 0)
+ | (REF(half_ceiling) ? RF_HALF_CEILING : 0)
+ );
+
+ REBVAL *scale = ARG(scale);
+
+ DECLARE_LOCAL (temp);
+ if (REF(to)) {
+ if (IS_INTEGER(scale))
+ Init_Money(temp, int_to_deci(VAL_INT64(scale)));
+ else if (IS_DECIMAL(scale) || IS_PERCENT(scale))
+ Init_Money(temp, decimal_to_deci(VAL_DECIMAL(scale)));
+ else if (IS_MONEY(scale))
+ Move_Value(temp, scale);
+ else
+ fail (scale);
+ }
+ else
+ Init_Money(temp, int_to_deci(0));
+
+ Init_Money(D_OUT, Round_Deci(
+ VAL_MONEY_AMOUNT(val),
+ flags,
+ VAL_MONEY_AMOUNT(temp)
+ ));
+
+ if (REF(to)) {
+ if (IS_DECIMAL(scale) || IS_PERCENT(scale)) {
+ REBDEC dec = deci_to_decimal(VAL_MONEY_AMOUNT(D_OUT));
+ VAL_RESET_HEADER(D_OUT, VAL_TYPE(scale));
+ VAL_DECIMAL(D_OUT) = dec;
+ return R_OUT;
+ }
+ if (IS_INTEGER(scale)) {
+ REBI64 i64 = deci_to_int(VAL_MONEY_AMOUNT(D_OUT));
+ VAL_RESET_HEADER(D_OUT, REB_INTEGER);
+ VAL_INT64(D_OUT) = i64;
+ return R_OUT;
+ }
+ }
+ break; }
+
+ case SYM_EVEN_Q:
+ case SYM_ODD_Q: {
+ REBINT result = 1 & cast(REBINT, deci_to_int(VAL_MONEY_AMOUNT(val)));
+ if (action == SYM_EVEN_Q) result = !result;
+ return result ? R_TRUE : R_FALSE; }
+
+ default:
+ fail (Error_Illegal_Action(REB_MONEY, action));
+ }
+
+ VAL_RESET_HEADER(D_OUT, REB_MONEY);
+ return R_OUT;
}
diff --git a/src/core/t-none.c b/src/core/t-none.c
deleted file mode 100644
index b9029947f2..0000000000
--- a/src/core/t-none.c
+++ /dev/null
@@ -1,90 +0,0 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-none.c
-** Summary: none datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-
-#include "sys-core.h"
-
-/***********************************************************************
-**
-*/ REBINT CT_None(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
-{
- if (mode >= 0) return (VAL_TYPE(a) == VAL_TYPE(b));
- return -1;
-}
-
-
-/***********************************************************************
-**
-*/ REBFLG MT_None(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
-{
- VAL_SET(out, type);
- return TRUE;
-}
-
-
-/***********************************************************************
-**
-*/ REBTYPE(None)
-/*
-** ALSO used for unset!
-**
-***********************************************************************/
-{
- REBVAL *val = D_ARG(1);
-
- switch (action) {
-
- case A_MAKE:
- case A_TO:
- if (IS_DATATYPE(val))
- return VAL_DATATYPE(val) == REB_NONE ? R_NONE : R_UNSET;
- else
- return IS_NONE(val) ? R_NONE : R_UNSET;
-
- case A_TAILQ:
- if (IS_NONE(val)) return R_TRUE;
- goto trap_it;
- case A_INDEXQ:
- case A_LENGTHQ:
- case A_SELECT:
- case A_FIND:
- case A_REMOVE:
- case A_CLEAR:
- case A_TAKE:
- if (IS_NONE(val)) return R_NONE;
- default:
- trap_it:
- Trap_Action(VAL_TYPE(val), action);
- }
-
- return R_RET;
-}
diff --git a/src/core/t-object.c b/src/core/t-object.c
old mode 100644
new mode 100755
index 2228e88abf..8ceea01811
--- a/src/core/t-object.c
+++ b/src/core/t-object.c
@@ -1,577 +1,933 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-object.c
-** Summary: object datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-object.c
+// Summary: "object datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-static REBOOL Same_Object(REBVAL *val, REBVAL *arg)
+
+static REBOOL Equal_Context(const RELVAL *val, const RELVAL *arg)
{
- if (
- VAL_TYPE(arg) == VAL_TYPE(val) &&
- //VAL_OBJ_SPEC(val) == VAL_OBJ_SPEC(arg) &&
- VAL_OBJ_FRAME(val) == VAL_OBJ_FRAME(arg)
- ) return TRUE;
- return FALSE;
+ REBCTX *f1;
+ REBCTX *f2;
+ REBVAL *key1;
+ REBVAL *key2;
+ REBVAL *var1;
+ REBVAL *var2;
+
+ // ERROR! and OBJECT! may both be contexts, for instance, but they will
+ // not compare equal just because their keys and fields are equal
+ //
+ if (VAL_TYPE(arg) != VAL_TYPE(val)) return FALSE;
+
+ f1 = VAL_CONTEXT(val);
+ f2 = VAL_CONTEXT(arg);
+
+ // Short circuit equality: `same?` objects always equal
+ //
+ if (f1 == f2) return TRUE;
+
+ // We can't short circuit on unequal frame lengths alone, because hidden
+ // fields of objects (notably `self`) do not figure into the `equal?`
+ // of their public portions.
+
+ key1 = CTX_KEYS_HEAD(f1);
+ key2 = CTX_KEYS_HEAD(f2);
+ var1 = CTX_VARS_HEAD(f1);
+ var2 = CTX_VARS_HEAD(f2);
+
+ // Compare each entry, in order. This order dependence suggests that
+ // an object made with `make object! [[a b][a: 1 b: 2]]` will not be equal
+ // to `make object! [[b a][b: 1 a: 2]]`. Although Rebol does not allow
+ // positional picking out of objects, it does allow positional setting
+ // currently (which it likely should not), hence they are functionally
+ // distinct for now. Yet those two should probably be `equal?`.
+ //
+ for (; NOT_END(key1) && NOT_END(key2); key1++, key2++, var1++, var2++) {
+ no_advance:
+ //
+ // Hidden vars shouldn't affect the comparison.
+ //
+ if (GET_VAL_FLAG(key1, TYPESET_FLAG_HIDDEN)) {
+ key1++; var1++;
+ if (IS_END(key1)) break;
+ goto no_advance;
+ }
+ if (GET_VAL_FLAG(key2, TYPESET_FLAG_HIDDEN)) {
+ key2++; var2++;
+ if (IS_END(key2)) break;
+ goto no_advance;
+ }
+
+ // Do ordinary comparison of the typesets
+ //
+ if (Cmp_Value(key1, key2, FALSE) != 0)
+ return FALSE;
+
+ // The typesets contain a symbol as well which must match for
+ // objects to consider themselves to be equal (but which do not
+ // count in comparison of the typesets)
+ //
+ if (VAL_KEY_CANON(key1) != VAL_KEY_CANON(key2))
+ return FALSE;
+
+ // !!! A comment here said "Use Compare_Modify_Values();"...but it
+ // doesn't... it calls Cmp_Value (?)
+ //
+ if (Cmp_Value(var1, var2, FALSE) != 0)
+ return FALSE;
+ }
+
+ // Either key1 or key2 is at the end here, but the other might contain
+ // all hidden values. Which is okay. But if a value isn't hidden,
+ // they don't line up.
+ //
+ for (; NOT_END(key1); key1++, var1++) {
+ if (NOT_VAL_FLAG(key1, TYPESET_FLAG_HIDDEN))
+ return FALSE;
+ }
+ for (; NOT_END(key2); key2++, var2++) {
+ if (NOT_VAL_FLAG(key2, TYPESET_FLAG_HIDDEN))
+ return FALSE;
+ }
+
+ return TRUE;
}
-static REBOOL Equal_Object(REBVAL *val, REBVAL *arg)
+static void Append_To_Context(REBCTX *context, REBVAL *arg)
{
- REBSER *f1;
- REBSER *f2;
- REBSER *w1;
- REBSER *w2;
- REBINT n;
-
- if (VAL_TYPE(arg) != VAL_TYPE(val)) return FALSE;
-
- f1 = VAL_OBJ_FRAME(val);
- f2 = VAL_OBJ_FRAME(arg);
- if (f1 == f2) return TRUE;
- if (f1->tail != f2->tail) return FALSE;
-
- w1 = FRM_WORD_SERIES(f1);
- w2 = FRM_WORD_SERIES(f2);
- if (w1->tail != w2->tail) return FALSE;
-
- // Compare each entry:
- for (n = 1; n < (REBINT)(f1->tail); n++) {
- if (Cmp_Value(BLK_SKIP(w1, n), BLK_SKIP(w2, n), FALSE)) return FALSE;
- // Use Compare_Values();
- if (Cmp_Value(BLK_SKIP(f1, n), BLK_SKIP(f2, n), FALSE)) return FALSE;
- }
-
- return TRUE;
+ // Can be a word:
+ if (ANY_WORD(arg)) {
+ if (0 == Find_Canon_In_Context(context, VAL_WORD_CANON(arg), TRUE)) {
+ Expand_Context(context, 1); // copy word table also
+ Append_Context(context, 0, VAL_WORD_SPELLING(arg));
+ // default of Append_Context is that arg's value is void
+ }
+ return;
+ }
+
+ if (NOT(IS_BLOCK(arg)))
+ fail (arg);
+
+ // Process word/value argument block:
+
+ RELVAL *item = VAL_ARRAY_AT(arg);
+
+ struct Reb_Binder binder;
+ INIT_BINDER(&binder);
+
+ Collect_Keys_Start(COLLECT_ANY_WORD);
+
+ // Setup binding table with obj words. Binding table is empty so don't
+ // bother checking for duplicates.
+ //
+ Collect_Context_Keys(&binder, context, FALSE);
+
+ // Examine word/value argument block
+
+ RELVAL *word;
+ for (word = item; NOT_END(word); word += 2) {
+ if (!IS_WORD(word) && !IS_SET_WORD(word))
+ fail (Error_Invalid_Arg_Core(word, VAL_SPECIFIER(arg)));
+
+ REBSTR *canon = VAL_WORD_CANON(word);
+
+ if (Try_Add_Binder_Index(&binder, canon, ARR_LEN(BUF_COLLECT))) {
+ //
+ // Wasn't already collected...so we added it...
+ //
+ EXPAND_SERIES_TAIL(SER(BUF_COLLECT), 1);
+ Init_Typeset(
+ ARR_LAST(BUF_COLLECT), ALL_64, VAL_WORD_SPELLING(word)
+ );
+ }
+ if (IS_END(word + 1)) break; // fix bug#708
+ }
+
+ TERM_ARRAY_LEN(BUF_COLLECT, ARR_LEN(BUF_COLLECT));
+
+ // Append new words to obj
+ //
+ REBCNT len = CTX_LEN(context) + 1;
+ Expand_Context(context, ARR_LEN(BUF_COLLECT) - len);
+
+ RELVAL *key;
+ for (key = ARR_AT(BUF_COLLECT, len); NOT_END(key); key++) {
+ assert(IS_TYPESET(key));
+ Append_Context(context, NULL, VAL_KEY_SPELLING(key));
+ }
+
+ // Set new values to obj words
+ for (word = item; NOT_END(word); word += 2) {
+ REBCNT i = Try_Get_Binder_Index(&binder, VAL_WORD_CANON(word));
+ assert(i != 0);
+
+ REBVAL *key = CTX_KEY(context, i);
+ REBVAL *var = CTX_VAR(context, i);
+
+ if (GET_VAL_FLAG(var, VALUE_FLAG_PROTECTED))
+ fail (Error_Protected_Key(key));
+
+ if (GET_VAL_FLAG(key, TYPESET_FLAG_HIDDEN))
+ fail (Error_Hidden_Raw());
+
+ if (IS_END(word + 1)) {
+ Init_Blank(var);
+ break; // fix bug#708
+ }
+ else {
+ Derelativize(var, &word[1], VAL_SPECIFIER(arg));
+
+ // Should the VALUE_FLAG_ENFIXED be preserved here?
+ //
+ if (GET_VAL_FLAG(&word[1], VALUE_FLAG_ENFIXED))
+ SET_VAL_FLAG(var, VALUE_FLAG_ENFIXED);
+
+ }
+ }
+
+ // release binding table
+ Collect_Keys_End(&binder);
+
+ SHUTDOWN_BINDER(&binder);
}
-static void Append_Obj(REBSER *obj, REBVAL *arg)
+
+static REBCTX *Trim_Context(REBCTX *context)
{
- REBCNT i;
- REBCNT len = 0;
- REBVAL *val;
- REBVAL *start = arg;
-
- // Can be a word:
- if (ANY_WORD(arg)) {
- if (!Find_Word_Index(obj, VAL_WORD_SYM(arg), TRUE)) {
- if (VAL_WORD_CANON(arg) == SYM_SELF) Trap0(RE_SELF_PROTECTED);
- Expand_Frame(obj, 1, 1); // copy word table also
- Append_Frame(obj, 0, VAL_WORD_SYM(arg));
- // val is UNSET
- }
- return;
- }
-
- if (!IS_BLOCK(arg)) Trap_Arg(arg);
-
- // Verify word/value argument block:
- for (arg = VAL_BLK_DATA(arg); NOT_END(arg); arg += 2) {
-
- if (!IS_WORD(arg) && !IS_SET_WORD(arg)) Trap_Arg(arg);
-
- if (NZ(i = Find_Word_Index(obj, VAL_WORD_SYM(arg), TRUE))) {
- // Just change the value, do not append it.
- val = FRM_VALUE(obj, i);
- if (GET_FLAGS(VAL_OPTS(FRM_WORD(obj, i)), OPTS_HIDE, OPTS_LOCK)) {
- // Back out... reset any prior flags:
- for (; arg != VAL_BLK_DATA(start); arg -= 2) VAL_CLR_OPT(arg, OPTS_TEMP);
- if (VAL_PROTECTED(FRM_WORD(obj, i))) Trap1(RE_LOCKED_WORD, FRM_WORD(obj, i));
- Trap0(RE_HIDDEN);
- }
- // Problem above: what about prior OPTS_FLAGS? Ok to leave them as is?
- if (IS_END(arg+1)) SET_NONE(val);
- else *val = arg[1];
- VAL_SET_OPT(arg, OPTS_TEMP);
- } else {
- if (VAL_WORD_CANON(arg) == SYM_SELF) Trap0(RE_SELF_PROTECTED);
- len++;
- // was: Trap1(RE_DUP_VARS, arg);
- }
-
- if (IS_END(arg+1)) break; // fix bug#708
- }
-
- // Append new values to end of frame (if necessary):
- if (len > 0) {
- Expand_Frame(obj, len, 1); // copy word table also
- for (arg = VAL_BLK_DATA(start); NOT_END(arg); arg += 2) {
- if (VAL_GET_OPT(arg, OPTS_TEMP)) VAL_CLR_OPT(arg, OPTS_TEMP);
- else {
- val = Append_Frame(obj, 0, VAL_WORD_SYM(arg));
- if (IS_END(arg+1)) {
- SET_NONE(val);
- break;
- }
- else *val = arg[1];
- }
- }
- }
+ REBVAL *key;
+ REBVAL *var;
+
+ REBCNT copy_count = 0;
+
+ // First pass: determine size of new context to create by subtracting out
+ // any void (unset fields), NONE!, or hidden fields
+ //
+ key = CTX_KEYS_HEAD(context);
+ var = CTX_VARS_HEAD(context);
+ for (; NOT_END(var); var++, key++) {
+ if (VAL_TYPE(var) == REB_BLANK)
+ continue;
+ if (GET_VAL_FLAG(key, TYPESET_FLAG_HIDDEN))
+ continue;
+
+ ++copy_count;
+ }
+
+ // Create new context based on the size found
+ //
+ REBCTX *trimmed = Alloc_Context(VAL_TYPE(CTX_VALUE(context)), copy_count);
+
+ // Second pass: copy the values that were not skipped in the first pass
+ //
+ key = CTX_KEYS_HEAD(context);
+ var = CTX_VARS_HEAD(context);
+
+ REBVAL *var_new = CTX_VARS_HEAD(trimmed);
+ REBVAL *key_new = CTX_KEYS_HEAD(trimmed);
+
+ for (; NOT_END(var); var++, key++) {
+ if (VAL_TYPE(var) == REB_BLANK)
+ continue;
+ if (GET_VAL_FLAG(key, TYPESET_FLAG_HIDDEN))
+ continue;
+
+ Move_Value(var_new, var);
+ ++var_new;
+ Move_Value(key_new, key);
+ ++key_new;
+ }
+
+ // Terminate the new context
+ //
+ TERM_ARRAY_LEN(CTX_VARLIST(trimmed), copy_count + 1);
+ TERM_ARRAY_LEN(CTX_KEYLIST(trimmed), copy_count + 1);
+
+ return trimmed;
}
-static REBSER *Trim_Object(REBSER *obj)
+
+//
+// CT_Context: C
+//
+REBINT CT_Context(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBVAL *val;
- REBINT cnt = 0;
- REBSER *nobj;
- REBVAL *nval;
- REBVAL *word;
- REBVAL *nwrd;
-
- word = FRM_WORDS(obj)+1;
- for (val = FRM_VALUES(obj)+1; NOT_END(val); val++, word++) {
- if (VAL_TYPE(val) > REB_NONE && !VAL_GET_OPT(word, OPTS_HIDE))
- cnt++;
- }
-
- nobj = Make_Frame(cnt);
- nval = FRM_VALUES(nobj)+1;
- word = FRM_WORDS(obj)+1;
- nwrd = FRM_WORDS(nobj)+1;
- for (val = FRM_VALUES(obj)+1; NOT_END(val); val++, word++) {
- if (VAL_TYPE(val) > REB_NONE && !VAL_GET_OPT(word, OPTS_HIDE)) {
- *nval++ = *val;
- *nwrd++ = *word;
- }
- }
- SET_END(nval);
- SET_END(nwrd);
- SERIES_TAIL(nobj) = cnt+1;
- SERIES_TAIL(FRM_WORD_SERIES(nobj)) = cnt+1;
-
- return nobj;
+ if (mode < 0) return -1;
+ return Equal_Context(a, b) ? 1 : 0;
}
-/***********************************************************************
-**
-*/ REBINT CT_Object(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// MAKE_Context: C
+//
+void MAKE_Context(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- if (mode < 0) return -1;
- if (mode == 3) return Same_Object(a, b);
- return Equal_Object(a, b);
+ if (kind == REB_FRAME) {
+ //
+ // !!! Current experiment for making frames lets you give it
+ // a FUNCTION! only.
+ //
+ if (!IS_FUNCTION(arg))
+ fail (Error_Bad_Make(kind, arg));
+
+ // In order to have the frame survive the call to MAKE and be
+ // returned to the user it can't be stack allocated, because it
+ // would immediately become useless. Allocate dynamically.
+ //
+ Init_Any_Context(out, REB_FRAME, Make_Frame_For_Function(arg));
+
+ // The frame's keylist is the same as the function's paramlist, and
+ // the [0] canon value of that array can be used to find the
+ // archetype of the function. But if the `arg` is a RETURN with a
+ // binding in the REBVAL to where to return from, that unique
+ // instance information must be carried in the REBVAL of the context.
+ //
+ assert(VAL_BINDING(out) == VAL_BINDING(arg));
+ return;
+ }
+
+ if (kind == REB_OBJECT && IS_BLANK(arg)) {
+ //
+ // Special case (necessary?) to return an empty object.
+ //
+ Init_Object(
+ out,
+ Construct_Context(
+ REB_OBJECT,
+ NULL, // head
+ SPECIFIED,
+ NULL
+ )
+ );
+ return;
+ }
+
+ if (kind == REB_OBJECT && IS_BLOCK(arg)) {
+ //
+ // Simple object creation with no evaluation, so all values are
+ // handled "as-is". Should have a spec block and a body block.
+ //
+ // Note: In %r3-legacy.r, the old evaluative MAKE OBJECT! is
+ // done by redefining MAKE itself, and calling the CONSTRUCT
+ // generator if the make def is not the [[spec][body]] format.
+
+ if (
+ VAL_LEN_AT(arg) != 2
+ || !IS_BLOCK(VAL_ARRAY_AT(arg)) // spec
+ || !IS_BLOCK(VAL_ARRAY_AT(arg) + 1) // body
+ ) {
+ fail (Error_Bad_Make(kind, arg));
+ }
+
+ // !!! Spec block is currently ignored, but required.
+
+ Init_Object(
+ out,
+ Construct_Context(
+ REB_OBJECT,
+ VAL_ARRAY_AT(VAL_ARRAY_AT(arg) + 1),
+ VAL_SPECIFIER(arg),
+ NULL // no parent
+ )
+ );
+
+ return;
+ }
+
+ // make error! [....]
+ //
+ // arg is block/string, but let Make_Error_Object_Throws do the
+ // type checking.
+ //
+ if (kind == REB_ERROR) {
+ //
+ // !!! Evaluation should not happen during a make. FAIL should
+ // be the primitive that does the evaluations, and then call
+ // into this with the reduced block.
+ //
+ if (Make_Error_Object_Throws(out, arg))
+ fail (Error_No_Catch_For_Throw(out));
+
+ return;
+ }
+
+ // `make object! 10` - currently not prohibited for any context type
+ //
+ if (ANY_NUMBER(arg)) {
+ //
+ // !!! Temporary! Ultimately SELF will be a user protocol.
+ // We use Make_Selfish_Context while MAKE is filling in for
+ // what will be responsibility of the generators, just to
+ // get "completely fake SELF" out of index slot [0]
+ //
+ REBCTX *context = Make_Selfish_Context_Detect(
+ kind, // type
+ END, // values to scan for toplevel set-words (empty)
+ NULL // parent
+ );
+
+ // !!! Allocation when SELF is not the responsibility of MAKE
+ // will be more basic and look like this.
+ //
+ /*
+ REBINT n = Int32s(arg, 0);
+ context = Alloc_Context(kind, n);
+ VAL_RESET_HEADER(CTX_VALUE(context), target);
+ CTX_SPEC(context) = NULL;
+ CTX_BODY(context) = NULL; */
+ Init_Any_Context(out, kind, context);
+
+ return;
+ }
+
+ // make object! map!
+ if (IS_MAP(arg)) {
+ REBCTX *context = Alloc_Context_From_Map(VAL_MAP(arg));
+ Init_Any_Context(out, kind, context);
+ return;
+ }
+
+ fail (Error_Bad_Make(kind, arg));
}
-/***********************************************************************
-**
-*/ REBINT CT_Frame(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// TO_Context: C
+//
+void TO_Context(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- if (mode < 0) return -1;
- return VAL_SERIES(a) == VAL_SERIES(b);
+ if (kind == REB_ERROR) {
+ //
+ // arg is checked to be block or string
+ //
+ if (Make_Error_Object_Throws(out, arg))
+ fail (Error_No_Catch_For_Throw(out));
+
+ return;
+ }
+
+ if (kind == REB_OBJECT) {
+ if (IS_ERROR(arg)) {
+ if (VAL_ERR_NUM(arg) < 100)
+ fail (arg);
+ }
+
+ // !!! Contexts hold canon values now that are typed, this init
+ // will assert--a TO conversion would thus need to copy the varlist
+ //
+ Init_Object(out, VAL_CONTEXT(arg));
+ return;
+ }
+
+ fail (Error_Bad_Make(kind, arg));
}
-
-/***********************************************************************
-**
-*/ REBFLG MT_Object(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+//
+// PD_Context: C
+//
+REBINT PD_Context(REBPVS *pvs)
{
- if (!IS_BLOCK(data)) return FALSE;
- VAL_OBJ_FRAME(out) = Construct_Object(0, VAL_BLK_DATA(data), 0);
- VAL_SET(out, type);
- if (type == REB_ERROR) {
- Make_Error_Object(out, out);
- }
- return TRUE;
+ REBCTX *c = VAL_CONTEXT(pvs->value);
+
+ if (NOT(IS_WORD(pvs->picker)))
+ fail (Error_Bad_Path_Select(pvs));
+
+ REBCNT n = Find_Canon_In_Context(
+ c, VAL_WORD_CANON(pvs->picker), FALSE
+ );
+
+ if (n == 0) {
+ //
+ // !!! The logic for allowing a GET-PATH! to be void if it's the last
+ // lookup that fails here is hacked in, but desirable for parity
+ // with the behavior of GET-WORD!
+ //
+ if (IS_GET_PATH(pvs->orig) && IS_END(pvs->item + 1)) {
+ Init_Void(pvs->store);
+ return PE_USE_STORE;
+ }
+ fail (Error_Bad_Path_Select(pvs));
+ }
+
+ if (CTX_VARS_UNAVAILABLE(c))
+ fail (Error_No_Relative_Raw(pvs->picker));
+
+ if (pvs->opt_setval && IS_END(pvs->item + 1)) {
+ FAIL_IF_READ_ONLY_CONTEXT(c);
+
+ if (GET_VAL_FLAG(CTX_VAR(c, n), VALUE_FLAG_PROTECTED))
+ fail (Error_Protected_Word_Raw(pvs->picker));
+ }
+
+ pvs->value = CTX_VAR(c, n);
+ pvs->value_specifier = SPECIFIED;
+
+ return PE_SET_IF_END;
}
-/***********************************************************************
-**
-*/ REBINT PD_Object(REBPVS *pvs)
-/*
-***********************************************************************/
+//
+// meta-of: native [
+//
+// {Get a reference to the "meta" object associated with a value.}
+//
+// value [function! object! module!]
+// ]
+//
+REBNATIVE(meta_of)
+//
+// The first implementation of linking a "meta object" to another object
+// originates from the original module system--where it was called the
+// "module spec". By moving it out of object REBVALs to the misc field of
+// a keylist, it becomes possible to change the meta object and have that
+// change seen by all references.
+//
+// As modules are still the first client of this meta information, it works
+// a similar way. It is mutable by all references by default, unless
+// it is protected.
+//
+// !!! This feature is under development and expected to extend to functions
+// and possibly other types of values--both as the meta information, and
+// as being able to have the meta information.
{
- REBINT n = 0;
-
- if (!VAL_OBJ_FRAME(pvs->value)) {
- return PE_NONE; // Error objects may not have a frame.
- }
-
- if (IS_WORD(pvs->select)) {
- n = Find_Word_Index(VAL_OBJ_FRAME(pvs->value), VAL_WORD_SYM(pvs->select), FALSE);
- }
-// else if (IS_INTEGER(pvs->select)) {
-// n = Int32s(pvs->select, 1);
-// }
- else return PE_BAD_SELECT;
-
- if (n <= 0 || (REBCNT)n >= SERIES_TAIL(VAL_OBJ_FRAME(pvs->value)))
- return PE_BAD_SELECT;
-
- if (pvs->setval && IS_END(pvs->path+1) && VAL_PROTECTED(VAL_FRM_WORD(pvs->value, n)))
- Trap1(RE_LOCKED_WORD, pvs->select);
-
- pvs->value = VAL_OBJ_VALUES(pvs->value) + n;
- return PE_SET;
- // if setval, check PROTECT mode!!!
- // VAL_FLAGS((VAL_OBJ_VALUES(value) + n)) &= ~FLAGS_CLEAN;
+ INCLUDE_PARAMS_OF_META_OF;
+
+ REBVAL *value = ARG(value);
+
+ REBCTX *meta;
+ if (IS_FUNCTION(value))
+ meta = VAL_FUNC_META(value);
+ else {
+ assert(ANY_CONTEXT(value));
+ meta = VAL_CONTEXT_META(value);
+ }
+
+ if (!meta) return R_BLANK;
+
+ Init_Object(D_OUT, meta);
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBTYPE(Object)
-/*
-** Handles object! and error! datatypes.
-**
-***********************************************************************/
+//
+// set-meta: native [
+//
+// {Set "meta" object associated with all references to a value.}
+//
+// return: []
+// value [function! object! module!]
+// meta [object! blank!]
+// ]
+//
+REBNATIVE(set_meta)
+//
+// !!! You cannot currently put meta information onto a FRAME!, because the
+// slot where the meta information would go is where the meta information
+// would live for the function--since frames use a functions "paramlist"
+// as their keylist. Types taken are deliberately narrow for the moment.
{
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBINT n;
- REBVAL *val;
- REBSER *obj, *src_obj;
- REBCNT type = 0;
-
- switch (action) {
-
- case A_MAKE:
- // make object! | error! | module! | task!
- if (IS_DATATYPE(value)) {
-
- type = VAL_DATATYPE(value); // target type
-
- if (IS_BLOCK(arg)) {
-
- // make object! [init]
- if (type == REB_OBJECT) {
- obj = Make_Object(0, VAL_BLK_DATA(arg));
- SET_OBJECT(ds, obj); // GC save
- arg = Do_Bind_Block(obj, arg); // GC-OK
- if (THROWN(arg)) {
- DS_RET_VALUE(arg);
- return R_RET;
- }
- break; // returns obj
- }
-
- if (type == REB_MODULE) {
- *value = *Make_Module(arg);
- type = 0;
- // VAL_MOD_BODY(value) = VAL_SERIES(arg);
- // VAL_SET(value, REB_MODULE); // GC protected
- // DO_BLK(arg);
- break; // returns value
- }
-
- // make task! [init]
- if (type == REB_TASK) {
- // Does it include a spec?
- if (IS_BLOCK(VAL_BLK(arg))) {
- arg = VAL_BLK(arg);
- if (!IS_BLOCK(arg+1)) Trap_Make(REB_TASK, value);
- obj = Make_Module_Spec(arg);
- VAL_MOD_BODY(value) = VAL_SERIES(arg+1);
- } else {
- obj = Make_Module_Spec(0);
- VAL_MOD_BODY(value) = VAL_SERIES(arg);
- }
- break; // returns obj
- }
- }
-
- // make error! [....]
- if (type == REB_ERROR) {
- Make_Error_Object(arg, value); // arg is block/string, returns value
- type = 0;
- break; // returns value
- }
-
- // make object! 10
- if (IS_NUMBER(arg)) {
- n = Int32s(arg, 0);
- obj = Make_Frame(n);
- break; // returns obj
- }
-
- // make object! map!
- if (IS_MAP(arg)) {
- obj = Map_To_Object(VAL_SERIES(arg));
- break; // returns obj
- }
-
- //if (IS_NONE(arg)) {obj = Make_Frame(0); break;}
-
- Trap_Make(type, arg);
- }
-
- // make parent-object ....
- if (IS_OBJECT(value)) {
- type = REB_OBJECT;
- src_obj = VAL_OBJ_FRAME(value);
-
- // make parent none | []
- if (IS_NONE(arg) || (IS_BLOCK(arg) && IS_EMPTY(arg))) {
- obj = Copy_Block_Values(src_obj, 0, SERIES_TAIL(src_obj), TS_CLONE);
- Rebind_Frame(src_obj, obj);
- break; // returns obj
- }
-
- // make parent [...]
- if (IS_BLOCK(arg)) {
- obj = Make_Object(src_obj, VAL_BLK_DATA(arg));
- Rebind_Frame(src_obj, obj);
- SET_OBJECT(ds, obj);
- arg = Do_Bind_Block(obj, arg); // GC-OK
- if (THROWN(arg)) {
- DS_RET_VALUE(arg);
- return R_RET;
- }
- break; // returns obj
- }
-
- // make parent-object object
- if (IS_OBJECT(arg)) {
- obj = Merge_Frames(src_obj, VAL_OBJ_FRAME(arg));
- break; // returns obj
- }
- }
- Trap_Make(VAL_TYPE(value), value);
-
- case A_TO:
- // special conversions to object! | error! | module!
- if (IS_DATATYPE(value)) {
- type = VAL_DATATYPE(value);
- if (type == REB_ERROR) {
- Make_Error_Object(arg, value); // arg is block/string, returns value
- type = 0; // type already set
- break; // returns value
- }
- else if (type == REB_OBJECT) {
- if (IS_ERROR(arg)) {
- if (VAL_ERR_NUM(arg) < 100) Trap_Arg(arg);
- obj = VAL_ERR_OBJECT(arg);
- break; // returns obj
- }
- }
- else if (type == REB_MODULE) {
- if (!IS_BLOCK(arg) || IS_EMPTY(arg)) Trap_Make(REB_MODULE, arg);
- val = VAL_BLK_DATA(arg); // module spec
- if (!IS_OBJECT(val)) Trap_Arg(val);
- obj = VAL_OBJ_FRAME(val);
- val++; // module object
- if (!IS_OBJECT(val)) Trap_Arg(val);
- VAL_MOD_SPEC(val) = obj;
- *value = *val;
- VAL_SET(value, REB_MODULE);
- type = 0; // type already set
- break; // returns value
- }
- }
- else type = VAL_TYPE(value);
- Trap_Make(type, arg);
-
- case A_APPEND:
- TRAP_PROTECT(VAL_SERIES(value));
- if (IS_OBJECT(value)) {
- Append_Obj(VAL_OBJ_FRAME(value), arg);
- return R_ARG1;
- }
- else
- Trap_Action(VAL_TYPE(value), action); // !!! needs better error
-
- case A_LENGTHQ:
- if (IS_OBJECT(value)) {
- DS_RET_INT(SERIES_TAIL(VAL_OBJ_FRAME(value))-1);
- return R_RET;
- }
- Trap_Action(VAL_TYPE(value), action);
-
- case A_COPY:
- // Note: words are not copied and bindings not changed!
- {
- REBU64 types = 0;
- if (D_REF(ARG_COPY_PART)) Trap0(RE_BAD_REFINES);
- if (D_REF(ARG_COPY_DEEP)) {
- types |= CP_DEEP | (D_REF(ARG_COPY_TYPES) ? 0 : TS_STD_SERIES);
- }
- if D_REF(ARG_COPY_TYPES) {
- arg = D_ARG(ARG_COPY_KINDS);
- if (IS_DATATYPE(arg)) types |= TYPESET(VAL_DATATYPE(arg));
- else types |= VAL_TYPESET(arg);
- }
- VAL_OBJ_FRAME(value) = obj = Copy_Block(VAL_OBJ_FRAME(value), 0);
- if (types != 0) Copy_Deep_Values(obj, 1, SERIES_TAIL(obj), types);
- break; // returns value
- }
- case A_SELECT:
- case A_FIND:
- n = 0;
- if (IS_WORD(arg))
- n = Find_Word_Index(VAL_OBJ_FRAME(value), VAL_WORD_SYM(arg), FALSE);
-
- if (n <= 0 || (REBCNT)n >= SERIES_TAIL(VAL_OBJ_FRAME(value)))
- return R_NONE;
-
- if (action == A_FIND) goto is_true;
-
- value = VAL_OBJ_VALUES(value) + n;
- break;
-
- case A_REFLECT:
- action = What_Reflector(arg); // zero on error
- if (action == OF_SPEC) {
- if (!VAL_MOD_SPEC(value)) return R_NONE;
- VAL_OBJ_FRAME(value) = VAL_MOD_SPEC(value);
- VAL_SET(value, REB_OBJECT);
- break;
- }
- // Adjust for compatibility with PICK:
- if (action == OF_VALUES) action = 2;
- else if (action == OF_BODY) action = 3;
- if (action < 1 || action > 3) Trap_Reflect(VAL_TYPE(value), arg);
-#ifdef obsolete
- goto reflect;
-
- case A_PICK:
- action = Get_Num_Arg(arg); // integer, decimal, logic
- if (action < 1 || action > 3) Trap_Arg(arg);
- if (action < 3) action |= 4; // add SELF to list
-reflect:
-#endif
- if (THROWN(value)) Trap0(RE_THROW_USAGE);
- Set_Block(value, Make_Object_Block(VAL_OBJ_FRAME(value), action));
- break;
-
- case A_TRIM:
- if (Find_Refines(ds, ALL_TRIM_REFS)) Trap0(RE_BAD_REFINES); // none allowed
- type = VAL_TYPE(value);
- obj = Trim_Object(VAL_OBJ_FRAME(value));
- break;
-
- case A_TAILQ:
- if (IS_OBJECT(value)) {
- SET_LOGIC(DS_RETURN, SERIES_TAIL(VAL_OBJ_FRAME(value)) <= 1);
- return R_RET;
- }
- Trap_Action(VAL_TYPE(value), action);
-
- default:
- Trap_Action(VAL_TYPE(value), action);
- }
-
- if (type) {
- VAL_SET(value, type);
- VAL_OBJ_FRAME(value) = obj;
- }
-
- DS_RET_VALUE(value);
- return R_RET;
-
-is_true:
- return R_TRUE;
+ INCLUDE_PARAMS_OF_SET_META;
+
+ REBCTX *meta;
+ if (ANY_CONTEXT(ARG(meta))) {
+ meta = VAL_CONTEXT(ARG(meta));
+ }
+ else {
+ assert(IS_BLANK(ARG(meta)));
+ meta = NULL;
+ }
+
+ REBVAL *value = ARG(value);
+
+ if (IS_FUNCTION(value))
+ SER(VAL_FUNC_PARAMLIST(value))->link.meta = meta;
+ else {
+ assert(ANY_CONTEXT(value));
+ INIT_CONTEXT_META(VAL_CONTEXT(value), meta);
+ }
+
+ return R_VOID;
}
-/***********************************************************************
-**
-*/ REBINT PD_Frame(REBPVS *pvs)
-/*
-** pvs->value points to the first value in frame (SELF).
-**
-***********************************************************************/
+//
+// Copy_Context_Core: C
+//
+// R3-Alpha hadn't factored out a routine to copy objects, it was just in the
+// COPY action. This is a basic factoring of that, which had the ability to
+// specify what types would be copied and whether they would be done deeply.
+//
+REBCTX *Copy_Context_Core(REBCTX *original, REBOOL deep, REBU64 types)
{
- REBCNT sym;
- REBCNT s;
- REBVAL *word;
- REBVAL *val;
-
- if (IS_WORD(pvs->select)) {
- sym = VAL_WORD_SYM(pvs->select);
- s = SYMBOL_TO_CANON(sym);
- word = BLK_SKIP(VAL_FRM_WORDS(pvs->value), 1);
- for (val = pvs->value + 1; NOT_END(val); val++, word++) {
- if (sym == VAL_BIND_SYM(word) || s == VAL_BIND_CANON(word)) {
- if (VAL_GET_OPT(word, OPTS_HIDE)) break;
- if (VAL_PROTECTED(word)) Trap1(RE_LOCKED_WORD, word);
- pvs->value = val;
- return PE_SET;
- }
- }
- }
- return PE_BAD_SELECT;
+ REBARR *varlist = Copy_Array_Shallow(CTX_VARLIST(original), SPECIFIED);
+ SET_SER_FLAG(varlist, ARRAY_FLAG_VARLIST);
+
+ // The type information and fields in the rootvar (at head of the varlist)
+ // are filled in because it's a copy, but the varlist needs to be updated
+ // in the copy to the one just created.
+ //
+ ARR_HEAD(varlist)->payload.any_context.varlist = varlist;
+
+ REBCTX *copy = CTX(varlist); // now a well-formed context
+
+ // Reuse the keylist of the original. (If the context of the source or
+ // the copy are expanded, the sharing is unlinked and a copy is made).
+ //
+ INIT_CTX_KEYLIST_SHARED(copy, CTX_KEYLIST(original));
+
+ if (types != 0) {
+ Clonify_Values_Len_Managed(
+ CTX_VARS_HEAD(copy),
+ SPECIFIED,
+ CTX_LEN(copy),
+ deep,
+ types
+ );
+ }
+
+ return copy;
}
-/***********************************************************************
-**
-*/ REBTYPE(Frame)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+// Handles object!, module!, and error! datatypes.
+//
+REBTYPE(Context)
{
- switch (action) {
- case A_MAKE:
- case A_TO:
- Trap_Make(REB_FRAME, D_ARG(2));
- }
-
- return R_ARG1;
+ REBVAL *value = D_ARG(1);
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+
+ switch (action) {
+ case SYM_APPEND:
+ FAIL_IF_READ_ONLY_CONTEXT(VAL_CONTEXT(value));
+ if (!IS_OBJECT(value) && !IS_MODULE(value))
+ fail (Error_Illegal_Action(VAL_TYPE(value), action));
+ Append_To_Context(VAL_CONTEXT(value), arg);
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT;
+
+ case SYM_LENGTH_OF:
+ if (!IS_OBJECT(value))
+ fail (Error_Illegal_Action(VAL_TYPE(value), action));
+ Init_Integer(D_OUT, CTX_LEN(VAL_CONTEXT(value)));
+ return R_OUT;
+
+ case SYM_COPY: { // Note: words are not copied and bindings not changed!
+ INCLUDE_PARAMS_OF_COPY;
+
+ UNUSED(PAR(value));
+
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ REBU64 types;
+ if (REF(types)) {
+ if (IS_DATATYPE(ARG(kinds)))
+ types = FLAGIT_KIND(VAL_TYPE_KIND(ARG(kinds)));
+ else
+ types = VAL_TYPESET_BITS(ARG(kinds));
+ }
+ else if (REF(deep))
+ types = TS_STD_SERIES;
+ else
+ types = 0;
+
+ Init_Any_Context(
+ D_OUT,
+ VAL_TYPE(value),
+ Copy_Context_Core(VAL_CONTEXT(value), REF(deep), types)
+ );
+ return R_OUT; }
+
+ case SYM_SELECT_P:
+ case SYM_FIND: {
+ if (!IS_WORD(arg))
+ return R_BLANK;
+
+ REBCNT n = Find_Canon_In_Context(
+ VAL_CONTEXT(value), VAL_WORD_CANON(arg), FALSE
+ );
+
+ if (n == 0)
+ return R_BLANK;
+
+ if (cast(REBCNT, n) > CTX_LEN(VAL_CONTEXT(value)))
+ return R_BLANK;
+
+ if (action == SYM_FIND) return R_TRUE;
+
+ Move_Value(D_OUT, CTX_VAR(VAL_CONTEXT(value), n));
+ return R_OUT;
+ }
+
+ case SYM_REFLECT: {
+ REBSYM sym = VAL_WORD_SYM(arg);
+ REBCNT reflector;
+
+ switch (sym) {
+ case SYM_WORDS: reflector = 1; break;
+ case SYM_VALUES: reflector = 2; break;
+ case SYM_BODY: reflector = 3; break;
+ default:
+ fail (Error_Cannot_Reflect(VAL_TYPE(value), arg));
+ }
+
+ Init_Block(D_OUT, Context_To_Array(VAL_CONTEXT(value), reflector));
+ return R_OUT; }
+
+ case SYM_TRIM: {
+ INCLUDE_PARAMS_OF_TRIM;
+
+ UNUSED(ARG(series));
+
+ if (
+ REF(head) || REF(tail)
+ || REF(auto) || REF(all) || REF(lines)
+ ){
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ if (REF(with)) {
+ UNUSED(ARG(str));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ Init_Any_Context(
+ D_OUT,
+ VAL_TYPE(value),
+ Trim_Context(VAL_CONTEXT(value))
+ );
+ return R_OUT; }
+
+ case SYM_TAIL_Q:
+ if (IS_OBJECT(value)) {
+ Init_Logic(D_OUT, LOGICAL(CTX_LEN(VAL_CONTEXT(value)) == 0));
+ return R_OUT;
+ }
+ fail (Error_Illegal_Action(VAL_TYPE(value), action));
+
+ default:
+ break;
+ }
+
+ fail (Error_Illegal_Action(VAL_TYPE(value), action));
}
-#ifdef later
-/***********************************************************************
-**
-** Get_Obj_Mods -- return a block of modified words from an object
-**
-***********************************************************************/
-REBVAL *Get_Obj_Mods(REBFRM *frame, REBVAL **inter_block)
+//
+// construct: native [
+//
+// "Creates an ANY-CONTEXT! instance"
+//
+// spec [datatype! block! any-context!]
+// "Datatype to create, specification, or parent/prototype context"
+// body [block! any-context! blank!]
+// "keys and values defining instance contents (bindings modified)"
+// /only
+// "Values are kept as-is"
+// ]
+//
+REBNATIVE(construct)
+//
+// CONSTRUCT in Ren-C is an effective replacement for what MAKE ANY-OBJECT!
+// was able to do in Rebol2 and R3-Alpha. It takes a spec that can be an
+// ANY-CONTEXT! datatype, or it can be a parent ANY-CONTEXT!, or a block that
+// represents a "spec".
+//
+// !!! This assumes you want a SELF defined. The entire concept of SELF
+// needs heavy review, but at minimum this needs an override to match the
+// ` return` or ` local` for functions.
+//
+// !!! This mutates the bindings of the body block passed in, should it
+// be making a copy instead (at least by default, perhaps with performance
+// junkies saying `construct/rebind` or something like that?
{
- REBVAL *obj = D_ARG(1);
- REBVAL *words, *val;
- REBFRM *frm = VAL_OBJ_FRAME(obj);
- REBSER *ser = Make_Block(2);
- REBOOL clear = D_REF(2);
- //DISABLE_GC;
-
- val = BLK_HEAD(frm->values);
- words = BLK_HEAD(frm->words);
- for (; NOT_END(val); val++, words++)
- if (!(VAL_FLAGS(val) & FLAGS_CLEAN)) {
- Append_Val(ser, words);
- if (clear) VAL_FLAGS(val) |= FLAGS_CLEAN;
- }
- if (!STR_LEN(ser)) {
- ENABLE_GC;
- goto is_none;
- }
-
- Bind_Block(frm, BLK_HEAD(ser), FALSE);
- VAL_SERIES(Temp_Blk_Value) = ser;
- //ENABLE_GC;
- return Temp_Blk_Value;
+ INCLUDE_PARAMS_OF_CONSTRUCT;
+
+ REBVAL *spec = ARG(spec);
+ REBVAL *body = ARG(body);
+ REBCTX *parent = NULL;
+
+ enum Reb_Kind target;
+ REBCTX *context;
+
+ if (IS_STRUCT(spec)) {
+ //
+ // !!! Compatibility for `MAKE struct [...]` from Atronix R3. There
+ // isn't any real "inheritance management" for structs but it allows
+ // the re-use of the structure's field definitions, so it is a means
+ // of saving on memory (?)
+ //
+ REBSTU *stu = Copy_Struct_Managed(VAL_STRUCT(spec));
+
+ Move_Value(D_OUT, STU_VALUE(stu));
+
+ // !!! Comment said "only accept value initialization"
+ //
+ Init_Struct_Fields(D_OUT, body);
+ return R_OUT;
+ }
+ else if (IS_GOB(spec)) {
+ //
+ // !!! Compatibility for `MAKE gob [...]` or `MAKE gob NxN` from
+ // R3-Alpha GUI. Start by copying the gob (minus pane and parent),
+ // then apply delta to its properties from arg. Doesn't save memory,
+ // or keep any parent linkage--could be done in user code as a copy
+ // and then apply the difference.
+ //
+ REBGOB *gob = Make_Gob();
+ *gob = *VAL_GOB(spec);
+ gob->pane = NULL;
+ gob->parent = NULL;
+
+ if (!IS_BLOCK(body))
+ fail (Error_Bad_Make(REB_GOB, body));
+
+ Extend_Gob_Core(gob, body);
+ SET_GOB(D_OUT, gob);
+ return R_OUT;
+ }
+ else if (IS_EVENT(spec)) {
+ //
+ // !!! As with GOB!, the 2-argument form of MAKE-ing an event is just
+ // a shorthand for copy-and-apply. Could be user code.
+ //
+ if (!IS_BLOCK(body))
+ fail (Error_Bad_Make(REB_EVENT, body));
+
+ Move_Value(D_OUT, spec); // !!! very "shallow" clone of the event
+ Set_Event_Vars(
+ D_OUT,
+ VAL_ARRAY_AT(body),
+ VAL_SPECIFIER(body)
+ );
+ return R_OUT;
+ }
+ else if (ANY_CONTEXT(spec)) {
+ parent = VAL_CONTEXT(spec);
+ target = VAL_TYPE(spec);
+ }
+ else if (IS_DATATYPE(spec)) {
+ //
+ // Should this be supported, or just assume OBJECT! ? There are
+ // problems trying to create a FRAME! without a function (for
+ // instance), and making an ERROR! from scratch is currently dangerous
+ // as well though you can derive them.
+ //
+ fail ("DATATYPE! not supported for SPEC of CONSTRUCT");
+ }
+ else {
+ assert(IS_BLOCK(spec));
+ target = REB_OBJECT;
+ }
+
+ // This parallels the code originally in CONSTRUCT. Run it if the /ONLY
+ // refinement was passed in.
+ //
+ if (REF(only)) {
+ Init_Object(
+ D_OUT,
+ Construct_Context(
+ REB_OBJECT,
+ VAL_ARRAY_AT(body),
+ VAL_SPECIFIER(body),
+ parent
+ )
+ );
+ return R_OUT;
+ }
+
+ // This code came from REBTYPE(Context) for implementing MAKE OBJECT!.
+ // Now that MAKE ANY-CONTEXT! has been pulled back, it no longer does
+ // any evaluation or creates SELF fields. It also obeys the rule that
+ // the first argument is an exemplar of the type to create only, bringing
+ // uniformity to MAKE.
+ //
+ if (
+ (target == REB_OBJECT || target == REB_MODULE)
+ && (IS_BLOCK(body) || IS_BLANK(body))) {
+
+ // First we scan the object for top-level set words in
+ // order to make an appropriately sized context. Then
+ // we put it into an object in D_OUT to GC protect it.
+ //
+ context = Make_Selfish_Context_Detect(
+ target, // type
+ // scan for toplevel set-words
+ IS_BLANK(body)
+ ? cast(const RELVAL*, END) // needed by gcc/g++ 2.95 (bug)
+ : VAL_ARRAY_AT(body),
+ parent
+ );
+ Init_Object(D_OUT, context);
+
+ if (!IS_BLANK(body)) {
+ //
+ // !!! This binds the actual body data, not a copy of it
+ // (functions make a copy of the body they are passed to
+ // be rebound). This seems wrong.
+ //
+ Bind_Values_Deep(VAL_ARRAY_AT(body), context);
+
+ // Do the block into scratch space (we ignore the result,
+ // unless it is thrown in which case it must be returned.
+ //
+ DECLARE_LOCAL (dummy);
+ if (Do_Any_Array_At_Throws(dummy, body)) {
+ Move_Value(D_OUT, dummy);
+ return R_OUT_IS_THROWN;
+ }
+ }
+
+ return R_OUT;
+ }
+
+ // "multiple inheritance" case when both spec and body are objects.
+ //
+ // !!! As with most R3-Alpha concepts, this needs review.
+ //
+ if ((target == REB_OBJECT) && parent && IS_OBJECT(body)) {
+ //
+ // !!! Again, the presumption that the result of a merge is to
+ // be selfish should not be hardcoded in the C, but part of
+ // the generator choice by the person doing the derivation.
+ //
+ context = Merge_Contexts_Selfish(parent, VAL_CONTEXT(body));
+ Init_Object(D_OUT, context);
+ return R_OUT;
+ }
+
+ fail ("Unsupported CONSTRUCT arguments");
}
-#endif
diff --git a/src/core/t-pair.c b/src/core/t-pair.c
index 0363950225..24d17218f8 100644
--- a/src/core/t-pair.c
+++ b/src/core/t-pair.c
@@ -1,364 +1,376 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-pair.c
-** Summary: pair datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-pair.c
+// Summary: "pair datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ REBINT CT_Pair(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Pair: C
+//
+REBINT CT_Pair(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- if (mode >= 0) return Cmp_Pair(a, b) == 0; // works for INTEGER=0 too (spans x y)
- if (IS_PAIR(b) && 0 == VAL_INT64(b)) { // for negative? and positive?
- if (mode == -1)
- return (VAL_PAIR_X(a) >= 0 || VAL_PAIR_Y(a) >= 0); // not LT
- return (VAL_PAIR_X(a) > 0 && VAL_PAIR_Y(a) > 0); // NOT LTE
- }
- return -1;
+ if (mode >= 0) return Cmp_Pair(a, b) == 0; // works for INTEGER=0 too (spans x y)
+ if (IS_PAIR(b) && 0 == VAL_INT64(b)) { // for negative? and positive?
+ if (mode == -1)
+ return (VAL_PAIR_X(a) >= 0 || VAL_PAIR_Y(a) >= 0); // not LT
+ return (VAL_PAIR_X(a) > 0 && VAL_PAIR_Y(a) > 0); // NOT LTE
+ }
+ return -1;
}
-/***********************************************************************
-**
-*/ REBFLG MT_Pair(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+//
+// MAKE_Pair: C
+//
+void MAKE_Pair(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBD32 x;
- REBD32 y;
-
- if (IS_PAIR(data)) {
- *out = *data;
- return TRUE;
- }
+ assert(kind == REB_PAIR);
+ UNUSED(kind);
+
+ if (IS_PAIR(arg)) {
+ Move_Value(out, arg);
+ return;
+ }
+
+ if (IS_STRING(arg)) {
+ //
+ // -1234567890x-1234567890
+ //
+ REBCNT len;
+ REBYTE *bp
+ = Temp_Byte_Chars_May_Fail(arg, VAL_LEN_AT(arg), &len, FALSE);
+
+ if (NULL == Scan_Pair(out, bp, len))
+ goto bad_make;
+
+ return;
+ }
+
+ REBDEC x;
+ REBDEC y;
+
+ if (IS_INTEGER(arg)) {
+ x = VAL_INT32(arg);
+ y = VAL_INT32(arg);
+ }
+ else if (IS_DECIMAL(arg)) {
+ x = VAL_DECIMAL(arg);
+ y = VAL_DECIMAL(arg);
+ }
+ else if (IS_BLOCK(arg) && VAL_LEN_AT(arg) == 2) {
+ RELVAL *item = VAL_ARRAY_AT(arg);
+
+ if (IS_INTEGER(item))
+ x = cast(REBDEC, VAL_INT64(item));
+ else if (IS_DECIMAL(item))
+ x = cast(REBDEC, VAL_DECIMAL(item));
+ else
+ goto bad_make;
+
+ ++item;
+ if (IS_END(item))
+ goto bad_make;
+
+ if (IS_INTEGER(item))
+ y = cast(REBDEC, VAL_INT64(item));
+ else if (IS_DECIMAL(item))
+ y = cast(REBDEC, VAL_DECIMAL(item));
+ else
+ goto bad_make;
+ }
+ else
+ goto bad_make;
+
+ SET_PAIR(out, x, y);
+ return;
+
+bad_make:
+ fail (Error_Bad_Make(REB_PAIR, arg));
+}
- if (!IS_BLOCK(data)) return FALSE;
- data = VAL_BLK_DATA(data);
+//
+// TO_Pair: C
+//
+void TO_Pair(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ MAKE_Pair(out, kind, arg);
+}
- if (IS_INTEGER(data)) x = (REBD32)VAL_INT64(data);
- else if (IS_DECIMAL(data)) x = (REBD32)VAL_DECIMAL(data);
- else return FALSE;
- data++;
- if (IS_INTEGER(data)) y = (REBD32)VAL_INT64(data);
- else if (IS_DECIMAL(data)) y = (REBD32)VAL_DECIMAL(data);
- else return FALSE;
+//
+// Cmp_Pair: C
+//
+// Given two pairs, compare them.
+//
+REBINT Cmp_Pair(const RELVAL *t1, const RELVAL *t2)
+{
+ REBDEC diff;
- VAL_SET(out, REB_PAIR);
- VAL_PAIR_X(out) = x;
- VAL_PAIR_Y(out) = y;
- return TRUE;
+ if ((diff = VAL_PAIR_Y(t1) - VAL_PAIR_Y(t2)) == 0)
+ diff = VAL_PAIR_X(t1) - VAL_PAIR_X(t2);
+ return (diff > 0.0) ? 1 : ((diff < 0.0) ? -1 : 0);
}
-/***********************************************************************
-**
-*/ REBINT Cmp_Pair(REBVAL *t1, REBVAL *t2)
-/*
-** Given two pairs, compare them.
-**
-***********************************************************************/
+//
+// Min_Max_Pair: C
+//
+void Min_Max_Pair(REBVAL *out, const REBVAL *a, const REBVAL *b, REBOOL maxed)
{
- REBD32 diff;
-
- if ((diff = VAL_PAIR_Y(t1) - VAL_PAIR_Y(t2)) == 0)
- diff = VAL_PAIR_X(t1) - VAL_PAIR_X(t2);
- return (diff > 0.0) ? 1 : ((diff < 0.0) ? -1 : 0);
+ // !!! This used to use REBXYF (a structure containing "X" and "Y" as
+ // floats). It's not clear why floats would be preferred here, and
+ // also not clear what the types should be if they were mixed (INTEGER!
+ // vs. DECIMAL! for the X or Y). REBXYF is now a structure only used
+ // in GOB! so it is taken out of mention here.
+
+ float ax;
+ float ay;
+ if (IS_PAIR(a)) {
+ ax = VAL_PAIR_X(a);
+ ay = VAL_PAIR_Y(a);
+ }
+ else if (IS_INTEGER(a))
+ ax = ay = cast(REBDEC, VAL_INT64(a));
+ else
+ fail (a);
+
+ float bx;
+ float by;
+ if (IS_PAIR(b)) {
+ bx = VAL_PAIR_X(b);
+ by = VAL_PAIR_Y(b);
+ }
+ else if (IS_INTEGER(b))
+ bx = by = cast(REBDEC, VAL_INT64(b));
+ else
+ fail (b);
+
+ if (maxed)
+ SET_PAIR(out, MAX(ax, bx), MAX(ay, by));
+ else
+ SET_PAIR(out, MIN(ax, bx), MIN(ay, by));
}
-/***********************************************************************
-**
-*/ REBINT Min_Max_Pair(REBVAL *ds, REBFLG maxed)
-/*
-***********************************************************************/
+//
+// PD_Pair: C
+//
+REBINT PD_Pair(REBPVS *pvs)
{
- REBXYF aa;
- REBXYF bb;
- REBXYF *cc;
- REBVAL *a = D_ARG(1);
- REBVAL *b = D_ARG(2);
- REBVAL *c = D_RET;
-
- if (IS_PAIR(a)) aa = VAL_PAIR(a);
- else if (IS_INTEGER(a)) aa.x = aa.y = (REBD32)VAL_INT64(a);
- else Trap_Arg(a);
-
- if (IS_PAIR(b)) bb = VAL_PAIR(b);
- else if (IS_INTEGER(b)) bb.x = bb.y = (REBD32)VAL_INT64(b);
- else Trap_Arg(b);
-
- cc = &VAL_PAIR(c);
- if (maxed) {
- cc->x = MAX(aa.x, bb.x);
- cc->y = MAX(aa.y, bb.y);
- }
- else {
- cc->x = MIN(aa.x, bb.x);
- cc->y = MIN(aa.y, bb.y);
- }
- SET_TYPE(c, REB_PAIR);
-
- return R_RET;
+ const REBVAL *sel = pvs->picker;
+ REBINT n = 0;
+ REBDEC dec;
+
+ if (IS_WORD(sel)) {
+ if (VAL_WORD_SYM(sel) == SYM_X)
+ n = 1;
+ else if (VAL_WORD_SYM(sel) == SYM_Y)
+ n = 2;
+ else
+ fail (Error_Bad_Path_Select(pvs));
+ }
+ else if (IS_INTEGER(sel)) {
+ n = Int32(sel);
+ if (n != 1 && n != 2)
+ fail (Error_Bad_Path_Select(pvs));
+ }
+ else fail (Error_Bad_Path_Select(pvs));
+
+ if (pvs->opt_setval) {
+ const REBVAL *setval = pvs->opt_setval;
+
+ if (IS_INTEGER(setval))
+ dec = cast(REBDEC, VAL_INT64(setval));
+ else if (IS_DECIMAL(setval))
+ dec = VAL_DECIMAL(setval);
+ else
+ fail (Error_Bad_Path_Set(pvs));
+
+ if (n == 1)
+ VAL_PAIR_X(pvs->value) = dec;
+ else
+ VAL_PAIR_Y(pvs->value) = dec;
+ }
+ else {
+ dec = (n == 1 ? VAL_PAIR_X(pvs->value) : VAL_PAIR_Y(pvs->value));
+ Init_Decimal(pvs->store, dec);
+ return PE_USE_STORE;
+ }
+
+ return PE_OK;
}
-/***********************************************************************
-**
-*/ REBINT PD_Pair(REBPVS *pvs)
-/*
-***********************************************************************/
-{
- REBVAL *sel;
- REBVAL *val;
- REBINT n = 0;
- REBD32 dec;
-
- if (IS_WORD(sel = pvs->select)) {
- if (VAL_WORD_CANON(sel) == SYM_X) n = 1;
- else if (VAL_WORD_CANON(sel) == SYM_Y) n = 2;
- else return PE_BAD_SELECT;
- }
- else if (IS_INTEGER(sel)) {
- n = Int32(sel);
- if (n != 1 && n !=2) return PE_BAD_SELECT;
- }
- else
- return PE_BAD_SELECT;
-
- if (NZ(val = pvs->setval)) {
- if (IS_INTEGER(val)) dec = (REBD32)VAL_INT64(val);
- else if (IS_DECIMAL(val)) dec = (REBD32)VAL_DECIMAL(val);
- else return PE_BAD_SET;
- if (n == 1) VAL_PAIR_X(pvs->value) = dec;
- else VAL_PAIR_Y(pvs->value) = dec;
- } else {
- dec = (n == 1 ? VAL_PAIR_X(pvs->value) : VAL_PAIR_Y(pvs->value));
- SET_DECIMAL(pvs->store, dec);
- return PE_USE;
- }
-
- return PE_OK;
+static void Get_Math_Arg_For_Pair(
+ REBDEC *x_out,
+ REBDEC *y_out,
+ REBVAL *arg,
+ REBSYM action
+){
+ switch (VAL_TYPE(arg)) {
+ case REB_PAIR:
+ *x_out = VAL_PAIR_X(arg);
+ *y_out = VAL_PAIR_Y(arg);
+ break;
+
+ case REB_INTEGER:
+ *x_out = *y_out = cast(REBDEC, VAL_INT64(arg));
+ break;
+
+ case REB_DECIMAL:
+ case REB_PERCENT:
+ *x_out = *y_out = cast(REBDEC, VAL_DECIMAL(arg));
+ break;
+
+ default:
+ fail (Error_Math_Args(REB_PAIR, action));
+ }
+
}
-/***********************************************************************
-**
-*/ REBTYPE(Pair)
-/*
-***********************************************************************/
+
+//
+// REBTYPE: C
+//
+REBTYPE(Pair)
{
- REBVAL *val;
- REBVAL *arg;
- REBINT n;
- REBD32 x1, x2;
- REBD32 y1, y2;
-
- val = D_ARG(1);
- x1 = VAL_PAIR_X(val);
- y1 = VAL_PAIR_Y(val);
- if (DS_ARGC > 1) arg = D_ARG(2);
-
- if (IS_BINARY_ACT(action)) {
- n = VAL_TYPE(arg);
-
- if (n == REB_PAIR) { // handle PAIR - PAIR cases
- x2 = VAL_PAIR_X(arg);
- y2 = VAL_PAIR_Y(arg);
- }
- else if (n == REB_INTEGER) {
- x2 = y2 = (REBD32)VAL_INT64(arg);
- }
- else if (n == REB_DECIMAL || n == REB_PERCENT) {
- x2 = y2 = (REBD32)VAL_DECIMAL(arg);
- }
- else
- Trap_Math_Args(REB_PAIR, action);
-
- switch (action) {
-
- case A_ADD:
- x1 += x2;
- y1 += y2;
- goto setPair;
-
- case A_SUBTRACT:
- x1 -= x2;
- y1 -= y2;
- goto setPair;
-
- case A_MULTIPLY:
- x1 *= x2;
- y1 *= y2;
- goto setPair;
-
- case A_DIVIDE:
- case A_REMAINDER:
- if (x2 == 0 || y2 == 0) Trap0(RE_ZERO_DIVIDE);
- if (action == A_DIVIDE) {
- x1 /= x2;
- y1 /= y2;
- }
- else {
- x1 = (REBD32)fmod(x1, x2);
- y1 = (REBD32)fmod(y1, y2);
- }
- goto setPair;
- }
- Trap_Math_Args(REB_PAIR, action);
- }
- // Unary actions:
- else {
- switch(action) {
-
-#ifdef temp
- case A_ODDQ:
- DECIDE((x1 & 1) && (y1 & 1));
-
- case A_EVENQ:
- DECIDE((x1 & 1) == 0 && (y1 & 1) == 0);
-#endif
- case A_NEGATE:
- x1 = -x1;
- y1 = -y1;
- goto setPair;
-#ifdef temp
- case A_COMPLEMENT:
- x1 = ~x1;
- y1 = ~y1;
- goto setPair;
-#endif
- case A_ABSOLUTE:
- if (x1 < 0) x1 = -x1;
- if (y1 < 0) y1 = -y1;
- goto setPair;
-
- case A_ROUND:
- {
- REBDEC d64;
- n = Get_Round_Flags(ds);
- if (D_REF(2))
- d64 = Dec64(D_ARG(3));
- else {
- d64 = 1.0L;
- n |= 1;
- }
- x1 = (REBD32)Round_Dec(x1, n, d64);
- y1 = (REBD32)Round_Dec(y1, n, d64);
- }
- goto setPair;
-
- case A_REVERSE:
- x2 = x1;
- x1 = y1;
- y1 = x2;
- goto setPair;
-
- case A_RANDOM:
- if (D_REF(2)) Trap0(RE_BAD_REFINES); // seed
- x1 = (REBD32)Random_Range((REBINT)x1, (REBOOL)D_REF(3));
- y1 = (REBD32)Random_Range((REBINT)y1, (REBOOL)D_REF(3));
- goto setPair;
-
- case A_PICK:
- if (IS_WORD(arg)) {
- if (VAL_WORD_CANON(arg) == SYM_X) n = 0;
- else if (VAL_WORD_CANON(arg) == SYM_Y) n = 1;
- else Trap_Arg(arg);
- }
- else {
- n = Get_Num_Arg(arg);
- if (n < 1 || n > 2) Trap_Range(arg);
- n--;
- }
-/// case A_POKE:
-/// if (action == A_POKE) {
-/// arg = D_ARG(3);
-/// if (IS_INTEGER(arg)) {
-/// if (index == 0) x1 = VAL_INT32(arg);
-/// else y1 = VAL_INT32(arg);
-/// }
-/// else if (IS_DECIMAL(arg)) {
-/// if (index == 0) x1 = (REBINT)VAL_DECIMAL(arg);
-/// else y1 = (REBINT)VAL_DECIMAL(arg);
-/// } else
-/// Trap_Arg(arg);
-/// goto setPair;
-/// }
- SET_DECIMAL(DS_RETURN, n == 0 ? x1 : y1);
- return R_RET;
-
- case A_MAKE:
- case A_TO:
- val = D_ARG(2);
- x1 = y1 = 0;
-// if (IS_NONE(val)) goto setPair;
- if (IS_PAIR(val)) {
- *DS_RETURN = *val;
- return R_RET;
- }
- if (IS_STRING(val)) {
- REBYTE *bp;
- REBCNT len;
- // -1234567890x-1234567890
- bp = Qualify_String(val, 24, &len, FALSE);
- if (Scan_Pair(bp, len, DS_RETURN)) return R_RET;
- }
- if (IS_INTEGER(val)) {
- x1 = y1 = (REBD32)VAL_INT64(val);
- goto setPair;
- }
- if (IS_DECIMAL(val)) {
- x1 = y1 = (REBD32)VAL_DECIMAL(val);
- goto setPair;
- }
- if (ANY_BLOCK(val) && VAL_LEN(val) <= 2) {
- if (MT_Pair(D_RET, val, REB_PAIR))
- return R_RET;
- }
- Trap_Make(REB_PAIR, val);
- }
- }
- Trap_Action(REB_PAIR, action);
+ REBVAL *val = D_ARG(1);
+
+ REBDEC x1 = VAL_PAIR_X(val);
+ REBDEC y1 = VAL_PAIR_Y(val);
+
+ REBDEC x2;
+ REBDEC y2;
+
+ switch (action) {
+
+ case SYM_COPY: {
+ goto setPair;
+ }
+
+ case SYM_ADD:
+ Get_Math_Arg_For_Pair(&x2, &y2, D_ARG(2), action);
+ x1 += x2;
+ y1 += y2;
+ goto setPair;
+
+ case SYM_SUBTRACT:
+ Get_Math_Arg_For_Pair(&x2, &y2, D_ARG(2), action);
+ x1 -= x2;
+ y1 -= y2;
+ goto setPair;
+
+ case SYM_MULTIPLY:
+ Get_Math_Arg_For_Pair(&x2, &y2, D_ARG(2), action);
+ x1 *= x2;
+ y1 *= y2;
+ goto setPair;
+
+ case SYM_DIVIDE:
+ case SYM_REMAINDER:
+ Get_Math_Arg_For_Pair(&x2, &y2, D_ARG(2), action);
+ if (x2 == 0 || y2 == 0) fail (Error_Zero_Divide_Raw());
+ if (action == SYM_DIVIDE) {
+ x1 /= x2;
+ y1 /= y2;
+ }
+ else {
+ x1 = cast(REBDEC, fmod(x1, x2));
+ y1 = cast(REBDEC, fmod(y1, y2));
+ }
+ goto setPair;
+
+ case SYM_NEGATE:
+ x1 = -x1;
+ y1 = -y1;
+ goto setPair;
+
+ case SYM_ABSOLUTE:
+ if (x1 < 0) x1 = -x1;
+ if (y1 < 0) y1 = -y1;
+ goto setPair;
+
+ case SYM_ROUND: {
+ INCLUDE_PARAMS_OF_ROUND;
+
+ UNUSED(PAR(value));
+
+ REBFLGS flags = (
+ (REF(to) ? RF_TO : 0)
+ | (REF(even) ? RF_EVEN : 0)
+ | (REF(down) ? RF_DOWN : 0)
+ | (REF(half_down) ? RF_HALF_DOWN : 0)
+ | (REF(floor) ? RF_FLOOR : 0)
+ | (REF(ceiling) ? RF_CEILING : 0)
+ | (REF(half_ceiling) ? RF_HALF_CEILING : 0)
+ );
+
+ if (REF(to)) {
+ x1 = Round_Dec(x1, flags, Dec64(ARG(scale)));
+ y1 = Round_Dec(y1, flags, Dec64(ARG(scale)));
+ }
+ else {
+ x1 = Round_Dec(x1, flags | RF_TO, 1.0L);
+ y1 = Round_Dec(y1, flags | RF_TO, 1.0L);
+ }
+ goto setPair; }
+
+ case SYM_REVERSE:
+ x2 = x1;
+ x1 = y1;
+ y1 = x2;
+ goto setPair;
+
+ case SYM_RANDOM: {
+ INCLUDE_PARAMS_OF_RANDOM;
+
+ UNUSED(PAR(value));
+
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(seed))
+ fail (Error_Bad_Refines_Raw());
+
+ x1 = cast(REBDEC, Random_Range(cast(REBINT, x1), REF(secure)));
+ y1 = cast(REBDEC, Random_Range(cast(REBINT, y1), REF(secure)));
+ goto setPair; }
+
+ default:
+ break;
+ }
+
+ fail (Error_Illegal_Action(REB_PAIR, action));
setPair:
- VAL_SET(DS_RETURN, REB_PAIR);
- VAL_PAIR_X(DS_RETURN) = x1;
- VAL_PAIR_Y(DS_RETURN) = y1;
- return R_RET;
-
-//is_false:
-// return R_FALSE;
-
-//is_true:
-// return R_TRUE;
+ SET_PAIR(D_OUT, x1, y1);
+ return R_OUT;
}
diff --git a/src/core/t-port.c b/src/core/t-port.c
index feca5d96d7..46e1eadb48 100644
--- a/src/core/t-port.c
+++ b/src/core/t-port.c
@@ -1,115 +1,193 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-port.c
-** Summary: port datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-port.c
+// Summary: "port datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ REBINT CT_Port(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Port: C
+//
+REBINT CT_Port(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- if (mode < 0) return -1;
- return VAL_OBJ_FRAME(a) == VAL_OBJ_FRAME(b);
+ if (mode < 0) return -1;
+ return VAL_CONTEXT(a) == VAL_CONTEXT(b);
}
-/***********************************************************************
-**
-*/ REBFLG MT_Port(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+//
+// MAKE_Port: C
+//
+// Create a new port. This is done by calling the MAKE_PORT
+// function stored in the system/intrinsic object.
+//
+void MAKE_Port(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- return FALSE;
+ assert(kind == REB_PORT);
+ UNUSED(kind);
+
+ const REBOOL fully = TRUE; // error if not all arguments consumed
+
+ if (Apply_Only_Throws(
+ out, fully, Sys_Func(SYS_CTX_MAKE_PORT_P), arg, END
+ )){
+ // Gave back an unhandled RETURN, BREAK, CONTINUE, etc...
+ fail (Error_No_Catch_For_Throw(out));
+ }
+
+ // !!! Shouldn't this be testing for !IS_PORT( ) ?
+ if (IS_BLANK(out))
+ fail (Error_Invalid_Spec_Raw(arg));
}
-/***********************************************************************
-**
-*/ static REBVAL *As_Port(REBVAL *value)
-/*
-** Make the port object if necessary.
-**
-***********************************************************************/
+//
+// TO_Port: C
+//
+void TO_Port(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBVAL *ds;
-
- if (IS_PORT(value)) return value;
+ assert(kind == REB_PORT);
+ UNUSED(kind);
+
+ if (!IS_OBJECT(arg))
+ fail (Error_Bad_Make(REB_PORT, arg));
+
+ // !!! cannot convert TO a PORT! without copying the whole context...
+ // which raises the question of why convert an object to a port,
+ // vs. making it as a port to begin with (?) Look into why
+ // system/standard/port is made with CONTEXT and not with MAKE PORT!
+ //
+ REBCTX *context = Copy_Context_Shallow(VAL_CONTEXT(arg));
+ VAL_RESET_HEADER(CTX_VALUE(context), REB_PORT);
+ Init_Port(out, context);
+}
- value = Make_Port(value);
- ds = DS_RETURN;
- *D_ARG(1) = *value;
- return D_ARG(1);
+//
+// Retrigger_Append_As_Write: C
+//
+// !!! In R3-Alpha, for the convenience of being able to APPEND to something
+// that may be a FILE!-based PORT! or a BINARY! or STRING! with a unified
+// interface, the APPEND command was re-interpreted as a WRITE/APPEND. But
+// it was done with presumption that APPEND and WRITE had compatible frames,
+// which generally speaking they do not.
+//
+// This moves the functionality to an actual retriggering which calls whatever
+// WRITE/APPEND would do in a generic fashion with a new frame. Not all
+// ports do this, as some have their own interpretation of APPEND. It's
+// hacky, but still not as bad as it was. Review.
+//
+REB_R Retrigger_Append_As_Write(REBFRM *frame_) {
+ INCLUDE_PARAMS_OF_APPEND;
+
+ // !!! Something like `write/append %foo.txt "data"` knows to convert
+ // %foo.txt to a port before trying the write, but if you say
+ // `append %foo.txt "data"` you get `%foo.txtdata`. Some actions are like
+ // this, e.g. PICK, where they can't do the automatic conversion.
+ //
+ assert(IS_PORT(ARG(series))); // !!! poorly named
+ UNUSED(ARG(series));
+ if (NOT(
+ IS_BINARY(ARG(value))
+ || IS_STRING(ARG(value))
+ || IS_BLOCK(ARG(value)))
+ ){
+ fail (ARG(value));
+ }
+
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(dup)) {
+ UNUSED(ARG(count));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ REBARR *a = Make_Array(2);
+ Move_Value(Alloc_Tail_Array(a), &PG_Write_Action);
+ Init_Word(Alloc_Tail_Array(a), Canon(SYM_APPEND));
+
+ DECLARE_LOCAL (write_append);
+ Init_Path(write_append, a);
+
+ if (Apply_Only_Throws(
+ D_OUT, TRUE, write_append, D_ARG(1), D_ARG(2), END
+ )){
+ return R_OUT_IS_THROWN;
+ }
+
+ return R_OUT;
}
-/***********************************************************************
-**
-*/ REBTYPE(Port)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+// !!! The concept of port dispatch from R3-Alpha is that it delegates to a
+// handler which may be native code or user code.
+//
+REBTYPE(Port)
{
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
-
- switch (action) {
-
- case A_READ:
- case A_WRITE:
- case A_QUERY:
- case A_OPEN:
- case A_CREATE:
- case A_DELETE:
- case A_RENAME:
- value = As_Port(value);
- case A_UPDATE:
- default:
- return Do_Port_Action(VAL_PORT(value), action); // Result on stack
-
- case A_REFLECT:
- return T_Object(ds, action);
- break;
-
- case A_MAKE:
- if (IS_DATATYPE(value)) value = Make_Port(arg);
- else Trap_Make(REB_PORT, value);
- break;
-
- case A_TO:
- if (!(IS_DATATYPE(value) && IS_OBJECT(arg))) Trap_Make(REB_PORT, arg);
- value = arg;
- VAL_SET(value, REB_PORT);
- break;
- }
-
- DS_Ret_Val(value);
- return R_RET;
+ REBVAL *value = D_ARG(1);
+
+ switch (action) {
+
+ case SYM_READ:
+ case SYM_WRITE:
+ case SYM_QUERY:
+ case SYM_OPEN:
+ case SYM_CREATE:
+ case SYM_DELETE:
+ case SYM_RENAME: {
+ // !!! We are going to "re-apply" the call frame with routines that
+ // are going to read the D_ARG(1) slot *implicitly* regardless of
+ // what value points to.
+ //
+ if (!IS_PORT(value)) {
+ DECLARE_LOCAL (temp);
+ MAKE_Port(temp, REB_PORT, value);
+ Move_Value(value, temp);
+ }
+ break; }
+
+ case SYM_UPDATE:
+ break;
+
+ case SYM_REFLECT:
+ return T_Context(frame_, action);
+
+ default:
+ break;
+ }
+
+ return Do_Port_Action(frame_, VAL_CONTEXT(value), action);
}
diff --git a/src/core/t-routine.c b/src/core/t-routine.c
new file mode 100755
index 0000000000..320522e215
--- /dev/null
+++ b/src/core/t-routine.c
@@ -0,0 +1,1544 @@
+//
+// File: %t-routine.c
+// Summary: "Support for calling non-Rebol C functions in DLLs w/Rebol args)"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2014 Atronix Engineering, Inc.
+// Copyright 2014-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// This code was contributed by Atronix Engineering:
+//
+// http://www.atronixengineering.com/downloads/
+//
+// It will only work if your build (-D)efines "-DHAVE_LIBFFI_AVAILABLE".
+//
+// Not defining HAVE_LIBFFI_AVAILABLE will produce a short list of
+// non-working "stubs" that match the interface of . These can
+// allow t-routine.c to compile anyway. That assists with maintenance
+// of the code and keeping it on the radar--even among those doing core
+// coding who are not building against the FFI.
+//
+
+#include "sys-core.h"
+
+#include "mem-pools.h" // low-level memory pool access
+
+#if !defined(HAVE_LIBFFI_AVAILABLE)
+
+ ffi_type ffi_type_void = { 0, 0, FFI_TYPE_VOID, NULL };
+ ffi_type ffi_type_uint8 = { 0, 0, FFI_TYPE_UINT8, NULL };
+ ffi_type ffi_type_sint8 = { 0, 0, FFI_TYPE_SINT8, NULL };
+ ffi_type ffi_type_uint16 = { 0, 0, FFI_TYPE_UINT16, NULL };
+ ffi_type ffi_type_sint16 = { 0, 0, FFI_TYPE_SINT16, NULL };
+ ffi_type ffi_type_uint32 = { 0, 0, FFI_TYPE_UINT32, NULL };
+ ffi_type ffi_type_sint32 = { 0, 0, FFI_TYPE_SINT32, NULL };
+ ffi_type ffi_type_uint64 = { 0, 0, FFI_TYPE_UINT64, NULL };
+ ffi_type ffi_type_sint64 = { 0, 0, FFI_TYPE_SINT64, NULL };
+ ffi_type ffi_type_float = { 0, 0, FFI_TYPE_FLOAT, NULL };
+ ffi_type ffi_type_double = { 0, 0, FFI_TYPE_DOUBLE, NULL };
+ ffi_type ffi_type_pointer = { 0, 0, FFI_TYPE_POINTER, NULL };
+
+ ffi_status ffi_prep_cif(
+ ffi_cif *cif,
+ ffi_abi abi,
+ unsigned int nargs,
+ ffi_type *rtype,
+ ffi_type **atypes
+ ){
+ UNUSED(cif);
+ UNUSED(abi);
+ UNUSED(nargs);
+ UNUSED(rtype);
+ UNUSED(atypes);
+
+ fail (Error_Not_Ffi_Build_Raw());
+ }
+
+ ffi_status ffi_prep_cif_var(
+ ffi_cif *cif,
+ ffi_abi abi,
+ unsigned int nfixedargs,
+ unsigned int ntotalargs,
+ ffi_type *rtype,
+ ffi_type **atypes
+ ){
+ UNUSED(cif);
+ UNUSED(abi);
+ UNUSED(nfixedargs);
+ UNUSED(ntotalargs);
+ UNUSED(rtype);
+ UNUSED(atypes);
+
+ fail (Error_Not_Ffi_Build_Raw());
+ }
+
+ void ffi_call(
+ ffi_cif *cif,
+ void (*fn)(void),
+ void *rvalue,
+ void **avalue
+ ){
+ UNUSED(cif);
+ UNUSED(fn);
+ UNUSED(rvalue);
+ UNUSED(avalue);
+
+ fail (Error_Not_Ffi_Build_Raw());
+ }
+
+ void *ffi_closure_alloc(size_t size, void **code) {
+ UNUSED(size);
+ UNUSED(code);
+
+ fail (Error_Not_Ffi_Build_Raw());
+ }
+
+ ffi_status ffi_prep_closure_loc(
+ ffi_closure *closure,
+ ffi_cif *cif,
+ void (*fun)(ffi_cif *, void *, void **, void *),
+ void *user_data,
+ void *codeloc
+ ){
+ UNUSED(closure);
+ UNUSED(cif);
+ UNUSED(fun);
+ UNUSED(user_data);
+ UNUSED(codeloc);
+
+ fail (Error_Not_Ffi_Build_Raw());
+ }
+
+ void ffi_closure_free(void *closure) {
+ UNUSED(closure);
+
+ fail (Error_Not_Ffi_Build_Raw());
+ }
+#endif
+
+
+// There is a platform-dependent list of legal ABIs which the MAKE-ROUTINE
+// and MAKE-CALLBACK natives take as an option via refinement
+//
+static ffi_abi Abi_From_Word(const REBVAL *word) {
+ switch (VAL_WORD_SYM(word)) {
+ case SYM_DEFAULT:
+ return FFI_DEFAULT_ABI;
+
+#ifdef X86_WIN64
+ case SYM_WIN64:
+ return FFI_WIN64;
+
+#elif defined(X86_WIN32) || defined(TO_LINUX_X86) || defined(TO_LINUX_X64)
+ case SYM_STDCALL:
+ return FFI_STDCALL;
+
+ case SYM_SYSV:
+ return FFI_SYSV;
+
+ case SYM_THISCALL:
+ return FFI_THISCALL;
+
+ case SYM_FASTCALL:
+ return FFI_FASTCALL;
+
+#ifdef X86_WIN32
+ case SYM_MS_CDECL:
+ return FFI_MS_CDECL;
+#else
+ case SYM_UNIX64:
+ return FFI_UNIX64;
+#endif //X86_WIN32
+
+#elif defined (TO_LINUX_ARM)
+ case SYM_VFP:
+ return FFI_VFP;
+
+ case SYM_SYSV:
+ return FFI_SYSV;
+
+#elif defined (TO_LINUX_MIPS)
+ case SYM_O32:
+ return FFI_O32;
+
+ case SYM_N32:
+ return FFI_N32;
+
+ case SYM_N64:
+ return FFI_N64;
+
+ case SYM_O32_SOFT_FLOAT:
+ return FFI_O32_SOFT_FLOAT;
+
+ case SYM_N32_SOFT_FLOAT:
+ return FFI_N32_SOFT_FLOAT;
+
+ case SYM_N64_SOFT_FLOAT:
+ return FFI_N64_SOFT_FLOAT;
+#endif //X86_WIN64
+
+ default:
+ break;
+ }
+
+ fail (word);
+}
+
+
+//
+// Writes into `out` a Rebol value representing the "schema", which describes
+// either a basic FFI type or the layout of a STRUCT! (not including data).
+//
+static void Schema_From_Block_May_Fail(
+ REBVAL *schema_out, // => INTEGER! or HANDLE! for struct
+ REBVAL *param_out, // => TYPESET!
+ const REBVAL *blk
+){
+ TRASH_CELL_IF_DEBUG(schema_out);
+ TRASH_CELL_IF_DEBUG(param_out);
+
+ assert(IS_BLOCK(blk));
+ if (VAL_LEN_AT(blk) == 0)
+ fail (blk);
+
+ RELVAL *item = VAL_ARRAY_AT(blk);
+
+ DECLARE_LOCAL (def);
+ DECLARE_LOCAL (temp);
+
+ if (IS_WORD(item) && VAL_WORD_SYM(item) == SYM_STRUCT_X) {
+ //
+ // [struct! [...struct definition...]]
+
+ ++item;
+ if (IS_END(item) || !IS_BLOCK(item))
+ fail (blk);
+
+ // Use the block spec to build a temporary structure through the same
+ // machinery that implements `make struct! [...]`
+
+ Derelativize(def, item, VAL_SPECIFIER(blk));
+
+ MAKE_Struct(temp, REB_STRUCT, def); // may fail()
+ assert(IS_STRUCT(temp));
+
+ // !!! It should be made possible to create a schema without going
+ // through a struct creation. There are "raw" structs with no memory,
+ // which would avoid the data series (not the REBSTU array, though)
+ //
+ Init_Block(schema_out, VAL_STRUCT_SCHEMA(temp));
+
+ // !!! Saying any STRUCT! is legal here in the typeset suggests any
+ // structure is legal to pass into a routine. Yet structs in C
+ // have different sizes (and static type checking so you can't pass
+ // one structure in the place of another. Actual struct compatibility
+ // is not checked until runtime, when the call happens.
+ //
+ Init_Typeset(param_out, FLAGIT_KIND(REB_STRUCT), NULL);
+ return;
+ }
+
+ if (VAL_LEN_AT(blk) != 1)
+ fail (blk);
+
+ if (IS_WORD(item)) {
+ //
+ // Drop the binding off word (then note SYM_VOID turns schema to blank)
+ //
+ Init_Word(schema_out, VAL_WORD_SPELLING(item));
+
+ switch (VAL_WORD_SYM(item)) {
+ case SYM_VOID:
+ Init_Blank(schema_out); // only valid for return types
+ Init_Typeset(param_out, FLAGIT_KIND(REB_MAX_VOID), NULL);
+ break;
+
+ case SYM_UINT8:
+ Init_Typeset(param_out, FLAGIT_KIND(REB_INTEGER), NULL);
+ break;
+
+ case SYM_INT8:
+ Init_Typeset(param_out, FLAGIT_KIND(REB_INTEGER), NULL);
+ break;
+
+ case SYM_UINT16:
+ Init_Typeset(param_out, FLAGIT_KIND(REB_INTEGER), NULL);
+ break;
+
+ case SYM_INT16:
+ Init_Typeset(param_out, FLAGIT_KIND(REB_INTEGER), NULL);
+ break;
+
+ case SYM_UINT32:
+ Init_Typeset(param_out, FLAGIT_KIND(REB_INTEGER), NULL);
+ break;
+
+ case SYM_INT32:
+ Init_Typeset(param_out, FLAGIT_KIND(REB_INTEGER), NULL);
+ break;
+
+ case SYM_UINT64:
+ Init_Typeset(param_out, FLAGIT_KIND(REB_INTEGER), NULL);
+ break;
+
+ case SYM_INT64:
+ Init_Typeset(param_out, FLAGIT_KIND(REB_INTEGER), NULL);
+ break;
+
+ case SYM_FLOAT:
+ Init_Typeset(param_out, FLAGIT_KIND(REB_DECIMAL), NULL);
+ break;
+
+ case SYM_DOUBLE:
+ Init_Typeset(param_out, FLAGIT_KIND(REB_DECIMAL), NULL);
+ break;
+
+ case SYM_POINTER:
+ Init_Typeset(
+ param_out,
+ FLAGIT_KIND(REB_INTEGER)
+ | FLAGIT_KIND(REB_STRING)
+ | FLAGIT_KIND(REB_BINARY)
+ | FLAGIT_KIND(REB_VECTOR)
+ | FLAGIT_KIND(REB_FUNCTION), // legal if routine or callback
+ NULL
+ );
+ break;
+
+ case SYM_REBVAL:
+ Init_Typeset(param_out, ALL_64, NULL);
+ break;
+
+ default:
+ fail ("Invalid FFI type indicator");
+ }
+ return;
+ }
+
+ fail (blk);
+}
+
+
+//
+// According to the libffi documentation, the arguments "must be suitably
+// aligned; it is the caller's responsibility to ensure this".
+//
+// We assume the store's data pointer will have suitable alignment for any
+// type (currently Make_Series() is expected to match malloc() in this way).
+// This will round the offset positions to an alignment appropriate for the
+// type size given.
+//
+// This means sequential arguments in the store may have padding between them.
+//
+inline static void *Expand_And_Align_Core(
+ REBUPT *offset_out,
+ REBCNT align,
+ REBSER *store,
+ REBCNT size
+){
+ REBCNT padding = SER_LEN(store) % align;
+ if (padding != 0)
+ padding = align - padding;
+
+ *offset_out = SER_LEN(store) + padding;
+ EXPAND_SERIES_TAIL(store, padding + size);
+ return SER_DATA_RAW(store) + *offset_out;
+}
+
+inline static void *Expand_And_Align(
+ REBUPT *offset_out,
+ REBSER *store,
+ REBCNT size // assumes align == size
+){
+ return Expand_And_Align_Core(offset_out, size, store, size);
+}
+
+
+//
+// Convert a Rebol value into a bit pattern suitable for the expectations of
+// the FFI for how a C argument would be represented. (e.g. turn an
+// INTEGER! into the appropriate representation of an `int` in memory.)
+//
+static REBUPT arg_to_ffi(
+ REBSER *store,
+ void *dest,
+ const REBVAL *arg,
+ const REBVAL *schema,
+ const REBVAL *param
+){
+ // Only one of dest or store should be non-NULL. This allows to write
+ // either to a known pointer of sufficient size (dest) or to a series
+ // that will expand enough to accommodate the data (store).
+ //
+ assert(store == NULL ? dest != NULL : dest == NULL);
+
+#if !defined(NDEBUG)
+ //
+ // If the value being converted has a "name"--e.g. the FFI Routine
+ // interface named it in the spec--then `param` contains that name, for
+ // reporting any errors in the conversion.
+ //
+ // !!! Shouldn't the argument have already had its type checked by the
+ // calling process?
+ //
+ if (param)
+ assert(arg != NULL && IS_TYPESET(param));
+ else
+ assert(arg == NULL); // return value, so just make space (no arg data)
+#endif
+
+ REBFRM *frame_ = FS_TOP; // So you can use the D_xxx macros
+
+ REBUPT offset;
+ if (!dest)
+ offset = 0;
+
+ if (IS_BLOCK(schema)) {
+ REBFLD *top = VAL_ARRAY(schema);
+
+ assert(FLD_IS_STRUCT(top));
+ assert(NOT(FLD_IS_ARRAY(top))); // !!! wasn't supported--should be?
+
+ // !!! In theory a struct has to be aligned to its maximal alignment
+ // needed by a fundamental member. We'll assume that the largest
+ // is sizeof(void*) here...this may waste some space in the padding
+ // between arguments, but that shouldn't have any semantic effect.
+ //
+ if (!dest)
+ dest = Expand_And_Align_Core(
+ &offset,
+ sizeof(void*),
+ store,
+ FLD_WIDE(top) // !!! What about FLD_LEN_BYTES_TOTAL ?
+ );
+
+ if (arg == NULL) {
+ //
+ // Return values don't have an incoming argument to fill into the
+ // calling frame.
+ //
+ return offset;
+ }
+
+ // !!! There wasn't any compatibility checking here before (not even
+ // that the arg was a struct. :-/ It used a stored STRUCT! from
+ // when the routine was specified to know what the size should be,
+ // and didn't pay attention to the size of the passed-in struct.
+ //
+ // (One reason it didn't use the size of the passed-struct is
+ // because it couldn't do so in the return case where arg was null)
+
+ if (!IS_STRUCT(arg))
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+
+ if (STU_SIZE(VAL_STRUCT(arg)) != FLD_WIDE(top))
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+
+ memcpy(dest, VAL_STRUCT_DATA_AT(arg), STU_SIZE(VAL_STRUCT(arg)));
+
+ return offset;
+ }
+
+ assert(IS_WORD(schema));
+
+ switch (VAL_WORD_SYM(schema)) {
+ case SYM_UINT8:{
+ u8 u;
+ if (!dest)
+ dest = Expand_And_Align(&offset, store, sizeof(u));
+ if (!arg) break;
+
+ if (!IS_INTEGER(arg))
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+
+ u = cast(u8, VAL_INT64(arg));
+ memcpy(dest, &u, sizeof(u));
+ break;}
+
+ case SYM_INT8:{
+ i8 i;
+ if (!dest)
+ dest = Expand_And_Align(&offset, store, sizeof(i));
+ if (!arg) break;
+
+ if (!IS_INTEGER(arg))
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+
+ i = cast(i8, VAL_INT64(arg));
+ memcpy(dest, &i, sizeof(i));
+ break;}
+
+ case SYM_UINT16:{
+ u16 u;
+ if (!dest)
+ dest = Expand_And_Align(&offset, store, sizeof(u));
+ if (!arg) break;
+
+ if (!IS_INTEGER(arg))
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+
+ u = cast(u16, VAL_INT64(arg));
+ memcpy(dest, &u, sizeof(u));
+ break;}
+
+ case SYM_INT16:{
+ i16 i;
+ if (!dest)
+ dest = Expand_And_Align(&offset, store, sizeof(i));
+ if (!arg) break;
+
+ if (!IS_INTEGER(arg))
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+
+ i = cast(i16, VAL_INT64(arg));
+ memcpy(dest, &i, sizeof(i));
+ break;}
+
+ case SYM_UINT32:{
+ u32 u;
+ if (!dest)
+ dest = Expand_And_Align(&offset, store, sizeof(u));
+ if (!arg) break;
+
+ if (!IS_INTEGER(arg))
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+
+ u = cast(u32, VAL_INT64(arg));
+ memcpy(dest, &u, sizeof(u));
+ break;}
+
+ case SYM_INT32:{
+ i32 i;
+ if (!dest)
+ dest = Expand_And_Align(&offset, store, sizeof(i));
+ if (!arg) break;
+
+ if (!IS_INTEGER(arg))
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+
+ i = cast(i32, VAL_INT64(arg));
+ memcpy(dest, &i, sizeof(i));
+ break;}
+
+ case SYM_UINT64:
+ case SYM_INT64:{
+ REBI64 i;
+ if (!dest)
+ dest = Expand_And_Align(&offset, store, sizeof(i));
+ if (!arg) break;
+
+ if (!IS_INTEGER(arg))
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+
+ i = VAL_INT64(arg);
+ memcpy(dest, &i, sizeof(REBI64));
+ break;}
+
+ case SYM_POINTER:{
+ //
+ // Note: Function pointers and data pointers may not be same size.
+ //
+ if (!dest)
+ dest = Expand_And_Align(&offset, store, sizeof(void*));
+ if (!arg) break;
+
+ switch (VAL_TYPE(arg)) {
+ case REB_INTEGER:{
+ REBIPT ipt = VAL_INT64(arg); // REBIPT is like C99's intptr_t
+ memcpy(dest, &ipt, sizeof(void*));
+ break;}
+
+ case REB_STRING:
+ case REB_BINARY:
+ case REB_VECTOR:{
+ // !!! This is a questionable idea, giving out pointers directly
+ // into Rebol series data. One issue is that the recipient of
+ // the data doesn't know whether to interpret it as REBYTE[] or as
+ // REBUNI[]...because it's passing the raw data of strings which
+ // can be wide or not based on things that have happened in the
+ // lifetime of that string. Another is that the data may be
+ // relocated in memory if any modifications happen during a
+ // callback...so the memory is not "stable".
+ //
+ REBYTE *raw_ptr = VAL_RAW_DATA_AT(arg);
+ memcpy(dest, &raw_ptr, sizeof(raw_ptr)); // copies a *pointer*!
+ break;}
+
+ case REB_FUNCTION:{
+ if (!IS_FUNCTION_RIN(arg))
+ fail (Error_Only_Callback_Ptr_Raw()); // actually routines too
+
+ CFUNC* cfunc = RIN_CFUNC(VAL_FUNC_ROUTINE(arg));
+ if (sizeof(cfunc) != sizeof(void*)) // not necessarily true
+ fail ("Void pointer size not equal to function pointer size");
+ memcpy(dest, &cfunc, sizeof(void*));
+ break;}
+
+ default:
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+ }
+ break;} // end case FFI_TYPE_POINTER
+
+ case SYM_REBVAL: {
+ if (!dest)
+ dest = Expand_And_Align(&offset, store, sizeof(REBVAL*));
+ if (!arg) break;
+
+ memcpy(dest, &arg, sizeof(REBVAL*)); // copies a *pointer*!
+ break; }
+
+ case SYM_FLOAT:{
+ float f;
+ if (!dest)
+ dest = Expand_And_Align(&offset, store, sizeof(f));
+ if (!arg) break;
+
+ if (!IS_DECIMAL(arg))
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+
+ f = cast(float, VAL_DECIMAL(arg));
+ memcpy(dest, &f, sizeof(f));
+ break;}
+
+ case SYM_DOUBLE:{
+ double d;
+ if (!dest)
+ dest = Expand_And_Align(&offset, store, sizeof(d));
+ if (!arg) break;
+
+ if (!IS_DECIMAL(arg))
+ fail (Error_Arg_Type(D_LABEL_SYM, param, VAL_TYPE(arg)));
+
+ d = VAL_DECIMAL(arg);
+ memcpy(dest, &d, sizeof(double));
+ break;}
+
+ case SYM_STRUCT_X:
+ //
+ // structs should be processed above by the HANDLE! case, not WORD!
+ //
+ assert(FALSE);
+ case SYM_VOID:
+ //
+ // can't return a meaningful offset for "void"--it's only valid for
+ // return types, so caller should check and not try to pass it in.
+ //
+ assert(FALSE);
+ default:
+ fail (arg);
+ }
+
+ return offset;
+}
+
+
+/* convert the return value to rebol
+ */
+static void ffi_to_rebol(
+ REBVAL *out,
+ const REBVAL *schema,
+ void *ffi_rvalue
+) {
+ if (IS_BLOCK(schema)) {
+ REBFLD *top = VAL_ARRAY(schema);
+
+ assert(FLD_IS_STRUCT(top));
+ assert(NOT(FLD_IS_ARRAY(top))); // !!! wasn't supported, should be?
+
+ REBSTU *stu = Alloc_Singular_Array();
+
+ REBSER *data = Make_Series(
+ FLD_WIDE(top), // !!! what about FLD_LEN_BYTES_TOTAL ?
+ sizeof(REBYTE)
+ );
+ memcpy(SER_HEAD(REBYTE, data), ffi_rvalue, FLD_WIDE(top));
+ MANAGE_SERIES(data);
+
+ VAL_RESET_HEADER(out, REB_STRUCT);
+ out->payload.structure.stu = stu;
+ out->payload.structure.data = data;
+ out->extra.struct_offset = 0;
+
+ *ARR_HEAD(stu) = *out; // save canon value
+ SER(stu)->link.schema = top;
+ MANAGE_ARRAY(stu);
+
+ assert(STU_DATA_HEAD(stu) == BIN_HEAD(data));
+ return;
+ }
+
+ assert(IS_WORD(schema));
+
+ switch (VAL_WORD_SYM(schema)) {
+ case SYM_UINT8:
+ Init_Integer(out, *cast(u8*, ffi_rvalue));
+ break;
+
+ case SYM_INT8:
+ Init_Integer(out, *cast(i8*, ffi_rvalue));
+ break;
+
+ case SYM_UINT16:
+ Init_Integer(out, *cast(u16*, ffi_rvalue));
+ break;
+
+ case SYM_INT16:
+ Init_Integer(out, *cast(i16*, ffi_rvalue));
+ break;
+
+ case SYM_UINT32:
+ Init_Integer(out, *cast(u32*, ffi_rvalue));
+ break;
+
+ case SYM_INT32:
+ Init_Integer(out, *cast(i32*, ffi_rvalue));
+ break;
+
+ case SYM_UINT64:
+ Init_Integer(out, *cast(u64*, ffi_rvalue));
+ break;
+
+ case SYM_INT64:
+ Init_Integer(out, *cast(i64*, ffi_rvalue));
+ break;
+
+ case SYM_POINTER:
+ Init_Integer(out, cast(REBUPT, *cast(void**, ffi_rvalue)));
+ break;
+
+ case SYM_FLOAT:
+ Init_Decimal(out, *cast(float*, ffi_rvalue));
+ break;
+
+ case SYM_DOUBLE:
+ Init_Decimal(out, *cast(double*, ffi_rvalue));
+ break;
+
+ case SYM_REBVAL:
+ Move_Value(out, *cast(const REBVAL**, ffi_rvalue));
+ break;
+
+ case SYM_VOID:
+ assert(FALSE); // not covered by generic routine.
+ default:
+ assert(FALSE);
+ //
+ // !!! Was reporting Error_Invalid_Arg on uninitialized `out`
+ //
+ fail ("Unknown FFI type indicator");
+ }
+}
+
+
+//
+// Routine_Dispatcher: C
+//
+REB_R Routine_Dispatcher(REBFRM *f)
+{
+ REBRIN *rin = FUNC_ROUTINE(f->phase);
+
+ if (RIN_LIB(rin) == NULL) {
+ //
+ // lib is NULL when routine is constructed from address directly,
+ // so there's nothing to track whether that gets loaded or unloaded
+ }
+ else {
+ if (IS_LIB_CLOSED(RIN_LIB(rin)))
+ fail (Error_Bad_Library_Raw());
+ }
+
+ REBCNT num_fixed = RIN_NUM_FIXED_ARGS(rin);
+
+ REBCNT num_variable;
+ REBDSP dsp_orig = DSP; // variadic args pushed to stack, so save base ptr
+
+ if (NOT(RIN_IS_VARIADIC(rin)))
+ num_variable = 0;
+ else {
+ // The function specification should have one extra parameter for
+ // the variadic source ("...")
+ //
+ assert(FUNC_NUM_PARAMS(f->phase) == num_fixed + 1);
+
+ REBVAL *vararg = FRM_ARG(f, num_fixed + 1); // 1-based
+ assert(IS_VARARGS(vararg) && f->binding == NULL);
+
+ // Evaluate the VARARGS! feed of values to the data stack. This way
+ // they will be available to be counted, to know how big to make the
+ // FFI argument series.
+ //
+ do {
+ REB_R r = Do_Vararg_Op_May_Throw(f->out, vararg, VARARG_OP_TAKE);
+
+ if (r == R_OUT_IS_THROWN)
+ return R_OUT_IS_THROWN;
+ if (r == R_VOID)
+ break;
+ assert(r == R_OUT);
+
+ DS_PUSH(f->out);
+ SET_END(f->out); // expected by Do_Vararg_Op
+ } while (TRUE);
+
+ // !!! The Atronix va_list interface required a type to be specified
+ // for each argument--achieving what you would get if you used a
+ // C cast on each variadic argument. Such as:
+ //
+ // printf reduce ["%d, %f" 10 + 20 [int32] 12.34 [float]]
+ //
+ // While this provides generality, it may be useful to use defaulting
+ // like C's where integer types default to `int` and floating point
+ // types default to `double`. In the VARARGS!-based syntax it could
+ // offer several possibilities:
+ //
+ // (printf "%d, %f" (10 + 20) 12.34)
+ // (printf "%d, %f" [int32 10 + 20] 12.34)
+ // (printf "%d, %f" [int32] 10 + 20 [float] 12.34)
+ //
+ // For the moment, this is following the idea that there must be
+ // pairings of values and then blocks (though the values are evaluated
+ // expressions).
+ //
+ if ((DSP - dsp_orig) % 2 != 0)
+ fail ("Variadic FFI functions must alternate blocks and values");
+
+ num_variable = (DSP - dsp_orig) / 2;
+ }
+
+ REBCNT num_args = num_fixed + num_variable;
+
+ // The FFI arguments are passed by void*. Those void pointers point to
+ // transformations of the Rebol arguments into ranges of memory of
+ // various sizes. This is the backing store for those arguments, which
+ // is appended to for each one. The memory is freed after the call.
+ //
+ // The offsets array has one element for each argument. These point at
+ // indexes of where each FFI variable resides. Offsets are used instead
+ // of pointers in case the store has to be resized, which may move the
+ // base of the series. Hence the offsets must be mutated into pointers
+ // at the last minute before the FFI call.
+ //
+ REBSER *store = Make_Series(1, sizeof(REBYTE));
+
+ void *ret_offset;
+ if (!IS_BLANK(RIN_RET_SCHEMA(rin))) {
+ ret_offset = cast(void*, arg_to_ffi(
+ store, // ffi-converted arg appended here
+ NULL, // dest pointer must be NULL if store is non-NULL
+ NULL, // arg: none (we're only making space--leave uninitialized)
+ RIN_RET_SCHEMA(rin),
+ NULL // param: none (it's a return value/output)
+ ));
+ }
+ else {
+ // Shouldn't be used (assigned to NULL later) but avoid maybe
+ // uninitialized warning.
+ //
+ ret_offset = cast(void*, cast(REBUPT, 0xDECAFBAD));
+ }
+
+ REBSER *arg_offsets;
+ if (num_args == 0)
+ arg_offsets = NULL; // don't waste time with the alloc + free
+ else
+ arg_offsets = Make_Series(num_args, sizeof(void*));
+
+ REBCNT i = 0;
+
+ // First gather the fixed parameters from the frame. They are known to
+ // be of correct general types (they were checked by Do_Core for the call)
+ // but a STRUCT! might not be compatible with the type of STRUCT! in
+ // the parameter specification. They might also be out of range, e.g.
+ // a too-large or negative INTEGER! passed to a uint8. Could fail() here.
+ //
+ for (; i < num_fixed; ++i) {
+ REBUPT offset = arg_to_ffi(
+ store, // ffi-converted arg appended here
+ NULL, // dest pointer must be NULL if store is non-NULL
+ FRM_ARG(f, i + 1), // 1-based
+ RIN_ARG_SCHEMA(rin, i), // 0-based
+ FUNC_PARAM(f->phase, i + 1) // 1-based
+ );
+ *SER_AT(void*, arg_offsets, i) = cast(void*, offset); // convert later
+ }
+
+ // If an FFI routine takes a fixed number of arguments, then its Call
+ // InterFace (CIF) can be created just once. This will be in the RIN_CIF.
+ // However a variadic routine requires a CIF that matches the number
+ // and types of arguments for that specific call.
+ //
+ // Note that because these pointers need to be freed by HANDLE! cleanup,
+ // they need to remember the size. OS_ALLOC() is used, at least until
+ // HANDLE! is changed to support sizes.
+ //
+ ffi_cif *cif; // pre-made if not variadic, built for this call otherwise
+ ffi_type **args_fftypes = NULL; // ffi_type*[] if num_variable > 0
+
+ if (NOT(RIN_IS_VARIADIC(rin))) {
+ cif = RIN_CIF(rin);
+ }
+ else {
+ assert(IS_BLANK(RIN_AT(rin, IDX_ROUTINE_CIF)));
+
+ // CIF creation requires a C array of argument descriptions that is
+ // contiguous across both the fixed and variadic parts. Start by
+ // filling in the ffi_type*s for all the fixed args.
+ //
+ args_fftypes = OS_ALLOC_N(ffi_type*, num_fixed + num_variable);
+
+ for (i = 0; i < num_fixed; ++i)
+ args_fftypes[i] = SCHEMA_FFTYPE(RIN_ARG_SCHEMA(rin, i));
+
+ DECLARE_LOCAL (schema);
+ DECLARE_LOCAL (param);
+
+ REBDSP dsp;
+ for (dsp = dsp_orig + 1; i < num_args; dsp += 2, ++i) {
+ //
+ // This param is used with the variadic type spec, and is
+ // initialized as it would be for an ordinary FFI argument. This
+ // means its allowed type flags are set, which is not really
+ // necessary. Whatever symbol name is used here will be seen
+ // in error reports.
+ //
+ Schema_From_Block_May_Fail(
+ schema,
+ param, // sets type bits in param
+ DS_AT(dsp + 1) // will error if this is not a block
+ );
+
+ args_fftypes[i] = SCHEMA_FFTYPE(schema);
+
+ INIT_TYPESET_NAME(param, Canon(SYM_ELLIPSIS));
+
+ *SER_AT(void*, arg_offsets, i) = cast(void*, arg_to_ffi(
+ store, // data appended to store
+ NULL, // dest pointer must be NULL if store is non-NULL
+ DS_AT(dsp), // arg
+ schema,
+ param // used for typecheck, VAL_TYPESET_SYM for error msgs
+ ));
+ }
+
+ DS_DROP_TO(dsp_orig); // done w/args (converted to bytes in `store`)
+
+ cif = OS_ALLOC(ffi_cif);
+
+ ffi_status status = ffi_prep_cif_var( // "_var"-iadic prep_cif version
+ cif,
+ RIN_ABI(rin),
+ num_fixed, // just fixed
+ num_args, // fixed plus variable
+ IS_BLANK(RIN_RET_SCHEMA(rin))
+ ? &ffi_type_void
+ : SCHEMA_FFTYPE(RIN_RET_SCHEMA(rin)), // return FFI type
+ args_fftypes // arguments FFI types
+ );
+
+ if (status != FFI_OK) {
+ OS_FREE(cif);
+ OS_FREE(args_fftypes);
+ fail ("FFI: Couldn't prep CIF_VAR");
+ }
+ }
+
+ // Now that all the additions to store have been made, we want to change
+ // the offsets of each FFI argument into actual pointers (since the
+ // data won't be relocated)
+ {
+ if (IS_BLANK(RIN_RET_SCHEMA(rin)))
+ ret_offset = NULL;
+ else
+ ret_offset = SER_DATA_RAW(store) + cast(REBUPT, ret_offset);
+
+ REBCNT i;
+ for (i = 0; i < num_args; ++i) {
+ REBUPT off = cast(REBUPT, *SER_AT(void*, arg_offsets, i));
+ assert(off == 0 || off < SER_LEN(store));
+ *SER_AT(void*, arg_offsets, i) = SER_DATA_RAW(store) + off;
+ }
+ }
+
+ // ** THE ACTUAL FFI CALL **
+ //
+ // Note that the "offsets" are now actually pointers.
+ {
+ SET_UNREADABLE_BLANK(&Callback_Error); // !!! is it already?
+
+ ffi_call(
+ cif,
+ RIN_CFUNC(rin),
+ ret_offset, // actually a real pointer now (no longer an offset)
+ (num_args == 0)
+ ? NULL
+ : SER_HEAD(void*, arg_offsets) // also real pointers now
+ );
+
+ if (!IS_BLANK_RAW(&Callback_Error))
+ fail (VAL_CONTEXT(&Callback_Error)); // asserts if not ERROR!
+ }
+
+ if (IS_BLANK(RIN_RET_SCHEMA(rin)))
+ Init_Void(f->out);
+ else
+ ffi_to_rebol(f->out, RIN_RET_SCHEMA(rin), ret_offset);
+
+ if (num_args != 0)
+ Free_Series(arg_offsets);
+
+ Free_Series(store);
+
+ if (num_variable != 0) {
+ OS_FREE(cif);
+ OS_FREE(args_fftypes);
+ }
+
+ // Note: cannot "throw" a Rebol value across an FFI boundary.
+
+ assert(!THROWN(f->out));
+ return R_OUT;
+}
+
+
+// The GC-able HANDLE! used by callbacks contains a ffi_closure pointer that
+// needs to be freed when the handle references go away (really only one
+// reference is likely--in the FUNC_BODY of the callback, but still this is
+// how the GC gets hooked in Ren-C)
+//
+static void cleanup_ffi_closure(const REBVAL *v) {
+ ffi_closure_free(VAL_HANDLE_POINTER(ffi_closure, v));
+}
+
+static void cleanup_cif(const REBVAL *v) {
+ FREE(ffi_cif, VAL_HANDLE_POINTER(ffi_cif, v));
+}
+
+static void cleanup_args_fftypes(const REBVAL *v) {
+ FREE_N(ffi_type*, VAL_HANDLE_LEN(v), VAL_HANDLE_POINTER(ffi_type*, v));
+}
+
+
+//
+// Callbacks allow C code to call Rebol functions. It does so by creating a
+// stub function pointer that can be passed in slots where C code expected
+// a C function pointer. When such stubs are triggered, the FFI will call
+// this dispatcher--which was registered using ffi_prep_closure_loc().
+//
+// An example usage of this feature is in %qsort.r, where the C library
+// function qsort() is made to use a custom comparison function that is
+// actually written in Rebol.
+//
+static void callback_dispatcher(
+ ffi_cif *cif,
+ void *ret,
+ void **args,
+ void *user_data
+){
+ if (!IS_BLANK_RAW(&Callback_Error)) // !!!is this possible?
+ return;
+
+ REBRIN *rin = cast(REBRIN*, user_data);
+ assert(!RIN_IS_VARIADIC(rin));
+ assert(cif->nargs == RIN_NUM_FIXED_ARGS(rin));
+
+ // We do not want to longjmp() out of the callback if there is an error.
+ // It needs to allow the FFI processing to unwind the stack normally so
+ // that it's in a good state. Therefore this must trap any fail()s.
+ //
+ struct Reb_State state;
+ REBCTX *error;
+
+ PUSH_TRAP(&error, &state);
+
+// The first time through the following code 'error' will be NULL, but...
+// `fail` can longjmp here, so 'error' won't be NULL *if* that happens!
+
+ if (error) {
+ Init_Error(&Callback_Error, error);
+ return;
+ }
+
+ // Build an array of code to run which represents the call. The first
+ // item in that array will be the callback function value, and then
+ // the arguments will be the remaining values.
+ //
+ REBARR *code = Make_Array(1 + cif->nargs);
+ RELVAL *elem = ARR_HEAD(code);
+ Move_Value(elem, FUNC_VALUE(RIN_CALLBACK_FUNC(rin)));
+ ++elem;
+
+ REBCNT i;
+ for (i = 0; i < cif->nargs; ++i, ++elem)
+ ffi_to_rebol(SINK(elem), RIN_ARG_SCHEMA(rin, i), args[i]);
+
+ TERM_ARRAY_LEN(code, 1 + cif->nargs);
+ MANAGE_ARRAY(code); // DO requires managed arrays (guarded while running)
+
+ DECLARE_LOCAL (result);
+ if (Do_At_Throws(result, code, 0, SPECIFIED))
+ fail (Error_No_Catch_For_Throw(result)); // !!! Tunnel throws out?
+
+ if (cif->rtype->type == FFI_TYPE_VOID)
+ assert(IS_BLANK(RIN_RET_SCHEMA(rin)));
+ else {
+ DECLARE_LOCAL (param);
+ Init_Typeset(param, 0, Canon(SYM_RETURN));
+ arg_to_ffi(
+ NULL, // store must be NULL if dest is non-NULL,
+ ret, // destination pointer
+ result,
+ RIN_RET_SCHEMA(rin),
+ param // parameter used for symbol in error only
+ );
+ }
+
+ DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
+}
+
+
+//
+// Alloc_Ffi_Function_For_Spec: C
+//
+// This allocates a REBFUN designed for using with the FFI--though it does
+// not fill in the actual code to call. That is done by the caller, which
+// needs to be done differently if it runs a C function (routine) or if it
+// makes Rebol code callable as if it were a C function (callback).
+//
+// It has a HANDLE! holding a Routine INfo structure (RIN) which describes
+// the FFI argument types. For callbacks, this cannot be automatically
+// deduced from the parameters of the Rebol function it wraps--because there
+// are multiple possible mappings (e.g. differently sized C types all of
+// which are passed in from Rebol's INTEGER!)
+//
+// The spec format is a block which is similar to the spec for functions:
+//
+// [
+// "document"
+// arg1 [type1 type2] "note"
+// arg2 [type3] "note"
+// ...
+// argn [typen] "note"
+// return: [type] "note"
+// ]
+//
+static REBFUN *Alloc_Ffi_Function_For_Spec(REBVAL *ffi_spec, ffi_abi abi) {
+ assert(IS_BLOCK(ffi_spec));
+
+ REBRIN *r = Make_Array(IDX_ROUTINE_MAX);
+
+ Init_Integer(RIN_AT(r, IDX_ROUTINE_ABI), abi);
+
+ // Caller will update these in the returned function.
+ //
+ SET_UNREADABLE_BLANK(RIN_AT(r, IDX_ROUTINE_CFUNC));
+ SET_UNREADABLE_BLANK(RIN_AT(r, IDX_ROUTINE_CLOSURE));
+ SET_UNREADABLE_BLANK(RIN_AT(r, IDX_ROUTINE_ORIGIN)); // LIBRARY!/FUNCTION!
+
+ Init_Blank(RIN_AT(r, IDX_ROUTINE_RET_SCHEMA)); // returns void as default
+
+ const REBCNT capacity_guess = 8; // !!! Magic number...why 8? (can grow)
+
+ REBARR *paramlist = Make_Array(capacity_guess);
+
+ // first slot is reserved for the "canon value", see `struct Reb_Function`
+ //
+ REBVAL *rootparam = Alloc_Tail_Array(paramlist);
+
+ // arguments can be complex, defined as structures. A "schema" is a
+ // REBVAL that holds either an INTEGER! for simple types, or a HANDLE!
+ // for compound ones.
+ //
+ // Note that in order to avoid deep walking the schemas after construction
+ // to convert them from unmanaged to managed, they are managed at the
+ // time of creation. This means that the array of them has to be
+ // guarded across any evaluations, since the routine being built is not
+ // ready for GC visibility.
+ //
+ // !!! Should the spec analysis be allowed to do evaluation? (it does)
+ //
+ REBARR *args_schemas = Make_Array(capacity_guess);
+ MANAGE_ARRAY(args_schemas);
+ PUSH_GUARD_ARRAY(args_schemas);
+
+ REBCNT num_fixed = 0; // number of fixed (non-variadic) arguments
+ REBOOL is_variadic = FALSE; // default to not being variadic
+
+ RELVAL *item = VAL_ARRAY_AT(ffi_spec);
+ for (; NOT_END(item); ++item) {
+ if (IS_STRING(item))
+ continue; // !!! TBD: extract FUNC_META information from spec notes
+
+ switch (VAL_TYPE(item)) {
+ case REB_WORD:{
+ REBSTR *name = VAL_WORD_SPELLING(item);
+
+ if (SAME_STR(name, Canon(SYM_ELLIPSIS))) { // variadic
+ if (is_variadic)
+ fail ("FFI: Duplicate ... indicating variadic");
+
+ is_variadic = TRUE;
+
+ REBVAL *param = Alloc_Tail_Array(paramlist);
+
+ // Currently the rule is that if VARARGS! is itself a valid
+ // parameter type, then the varargs will not chain. We want
+ // chaining as opposed to passing the parameter pack to the
+ // C code to process (it wouldn't know what to do with it)
+ //
+ Init_Typeset(
+ param,
+ ALL_64 & ~FLAGIT_KIND(REB_VARARGS),
+ Canon(SYM_VARARGS)
+ );
+ SET_VAL_FLAG(param, TYPESET_FLAG_VARIADIC);
+ INIT_VAL_PARAM_CLASS(param, PARAM_CLASS_NORMAL);
+ }
+ else { // ordinary argument
+ if (is_variadic)
+ fail ("FFI: Variadic must be final parameter");
+
+ REBVAL *param = Alloc_Tail_Array(paramlist);
+
+ ++item;
+
+ DECLARE_LOCAL (block);
+ Derelativize(block, item, VAL_SPECIFIER(ffi_spec));
+
+ Schema_From_Block_May_Fail(
+ Alloc_Tail_Array(args_schemas), // schema (out)
+ param, // param (out)
+ block // block (in)
+ );
+
+ INIT_TYPESET_NAME(param, name);
+ INIT_VAL_PARAM_CLASS(param, PARAM_CLASS_NORMAL);
+ ++num_fixed;
+ }
+ break;}
+
+ case REB_SET_WORD:
+ switch (VAL_WORD_SYM(item)) {
+ case SYM_RETURN:{
+ if (!IS_BLANK(RIN_AT(r, IDX_ROUTINE_RET_SCHEMA)))
+ fail ("FFI: Return already specified");
+
+ ++item;
+
+ DECLARE_LOCAL (block);
+ Derelativize(block, item, VAL_SPECIFIER(ffi_spec));
+
+ DECLARE_LOCAL (param);
+ Schema_From_Block_May_Fail(
+ RIN_AT(r, IDX_ROUTINE_RET_SCHEMA),
+ param, // dummy (a return/output has no arg to typecheck)
+ block
+ );
+ break;}
+
+ default:
+ fail (KNOWN(item));
+ }
+ break;
+
+ default:
+ fail (KNOWN(item));
+ }
+ }
+
+ Init_Logic(RIN_AT(r, IDX_ROUTINE_IS_VARIADIC), is_variadic);
+
+ TERM_ARRAY_LEN(r, IDX_ROUTINE_MAX);
+ ASSERT_ARRAY(args_schemas);
+ Init_Block(RIN_AT(r, IDX_ROUTINE_ARG_SCHEMAS), args_schemas);
+
+ if (RIN_IS_VARIADIC(r)) {
+ //
+ // Each individual call needs to use `ffi_prep_cif_var` to make the
+ // proper variadic CIF for that call.
+ //
+ Init_Blank(RIN_AT(r, IDX_ROUTINE_CIF));
+ Init_Blank(RIN_AT(r, IDX_ROUTINE_ARG_FFTYPES));
+ }
+ else {
+ // The same CIF can be used for every call of the routine if it is
+ // not variadic. The CIF must stay alive for the entire the lifetime
+ // of the args_fftypes, apparently.
+ //
+ ffi_cif *cif = ALLOC(ffi_cif);
+
+ ffi_type **args_fftypes;
+ if (num_fixed == 0)
+ args_fftypes = NULL;
+ else
+ args_fftypes = ALLOC_N(ffi_type*, num_fixed);
+
+ REBCNT i;
+ for (i = 0; i < num_fixed; ++i)
+ args_fftypes[i] = SCHEMA_FFTYPE(RIN_ARG_SCHEMA(r, i));
+
+ if (
+ FFI_OK != ffi_prep_cif(
+ cif,
+ abi,
+ num_fixed,
+ IS_BLANK(RIN_RET_SCHEMA(r))
+ ? &ffi_type_void
+ : SCHEMA_FFTYPE(RIN_RET_SCHEMA(r)),
+ args_fftypes // NULL if 0 fixed args
+ )
+ ){
+ fail ("FFI: Couldn't prep CIF");
+ }
+
+ Init_Handle_Managed(
+ RIN_AT(r, IDX_ROUTINE_CIF),
+ cif,
+ 0,
+ &cleanup_cif
+ );
+
+ if (args_fftypes == NULL)
+ Init_Blank(RIN_AT(r, IDX_ROUTINE_ARG_FFTYPES));
+ else
+ Init_Handle_Managed(
+ RIN_AT(r, IDX_ROUTINE_ARG_FFTYPES),
+ args_fftypes,
+ num_fixed,
+ &cleanup_args_fftypes
+ ); // lifetime must match cif lifetime
+ }
+
+ DROP_GUARD_ARRAY(args_schemas);
+
+ // Now fill in the canon value of the paramlist so it is an actual "REBFUN"
+ //
+ VAL_RESET_HEADER(rootparam, REB_FUNCTION);
+ rootparam->payload.function.paramlist = paramlist;
+ rootparam->extra.binding = NULL;
+
+ SET_SER_FLAG(paramlist, ARRAY_FLAG_PARAMLIST);
+ MANAGE_ARRAY(paramlist);
+ SER(paramlist)->link.meta = NULL;
+
+ REBFUN *fun = Make_Function(
+ paramlist,
+ &Routine_Dispatcher,
+ NULL, // no underlying function, this is fundamental
+ NULL // not providing a specialization
+ );
+
+ // The "body" value of a routine is the routine info array.
+ //
+ Init_Block(FUNC_BODY(fun), r);
+
+ return fun; // still needs to have function or callback info added!
+}
+
+
+//
+// make-routine: native [
+//
+// {Create a bridge for interfacing with arbitrary C code in a DLL}
+//
+// return: [function!]
+// lib [library!]
+// {Library DLL that function lives in (get with MAKE LIBRARY!)}
+// name [string!]
+// {Linker name of the function in the DLL}
+// ffi-spec [block!]
+// {Description of what C argument types the function takes}
+// /abi
+// {Specify the Application Binary Interface (vs. using default)}
+// abi-type [word!]
+// {'CDECL, 'FASTCALL, 'STDCALL, etc.}
+// ]
+//
+REBNATIVE(make_routine)
+//
+// !!! Would be nice if this could just take a filename and the lib management
+// was automatic, e.g. no LIBRARY! type.
+{
+ INCLUDE_PARAMS_OF_MAKE_ROUTINE;
+
+ ffi_abi abi;
+ if (REF(abi))
+ abi = Abi_From_Word(ARG(abi_type));
+ else
+ abi = FFI_DEFAULT_ABI;
+
+ // Make sure library wasn't closed with CLOSE
+ //
+ REBLIB *lib = VAL_LIBRARY(ARG(lib));
+ if (lib == NULL)
+ fail (ARG(lib));
+
+ // Try to find the C function pointer in the DLL, if it's there.
+ // OS_FIND_FUNCTION takes a char* on both Windows and Posix. The
+ // string that gets here could be REBUNI wide or BYTE_SIZE(), so
+ // make sure it's turned into a char* before passing.
+ //
+ // !!! Should it error if any bytes need to be UTF8 encoded?
+ //
+ REBVAL *name = ARG(name);
+ REBCNT b_index = VAL_INDEX(name);
+ REBCNT b_len = VAL_LEN_AT(name);
+ REBSER *byte_sized = Temp_Bin_Str_Managed(name, &b_index, &b_len);
+
+ CFUNC *cfunc = OS_FIND_FUNCTION(
+ LIB_FD(lib),
+ SER_AT(char, byte_sized, b_index) // name may not be at head index
+ );
+ if (cfunc == NULL)
+ fail ("FFI: Couldn't find function in library");
+
+ // Process the parameter types into a function, then fill it in
+
+ REBFUN *fun = Alloc_Ffi_Function_For_Spec(ARG(ffi_spec), abi);
+ REBRIN *r = FUNC_ROUTINE(fun);
+
+ Init_Handle_Cfunc(RIN_AT(r, IDX_ROUTINE_CFUNC), cfunc, 0);
+ Move_Value(RIN_AT(r, IDX_ROUTINE_ORIGIN), ARG(lib));
+
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+ return R_OUT;
+}
+
+
+//
+// make-routine-raw: native [
+//
+// {Create a bridge for interfacing with a C function, by pointer}
+//
+// return: [function!]
+// pointer [integer!]
+// {Raw address of function in memory}
+// ffi-spec [block!]
+// {Description of what C argument types the function takes}
+// /abi
+// {Specify the Application Binary Interface (vs. using default)}
+// abi-type [word!]
+// {'CDECL, 'FASTCALL, 'STDCALL, etc.}
+// ]
+//
+REBNATIVE(make_routine_raw)
+//
+// !!! Would be nice if this could just take a filename and the lib management
+// was automatic, e.g. no LIBRARY! type.
+{
+ INCLUDE_PARAMS_OF_MAKE_ROUTINE_RAW;
+
+ ffi_abi abi;
+ if (REF(abi))
+ abi = Abi_From_Word(ARG(abi_type));
+ else
+ abi = FFI_DEFAULT_ABI;
+
+ // Cannot cast directly to a function pointer from a 64-bit value
+ // on 32-bit systems; first cast to (U)nsigned int that holds (P)oin(T)er
+ //
+ CFUNC *cfunc = cast(CFUNC*, cast(REBUPT, VAL_INT64(ARG(pointer))));
+ if (cfunc == NULL)
+ fail ("FFI: NULL pointer not allowed for raw MAKE-ROUTINE");
+
+ REBFUN *fun = Alloc_Ffi_Function_For_Spec(ARG(ffi_spec), abi);
+ REBRIN *r = FUNC_ROUTINE(fun);
+
+ Init_Handle_Cfunc(RIN_AT(r, IDX_ROUTINE_CFUNC), cfunc, 0);
+ Init_Blank(RIN_AT(r, IDX_ROUTINE_ORIGIN)); // no LIBRARY! in this case.
+
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+ return R_OUT;
+}
+
+
+//
+// make-callback: native [
+//
+// {Wrap function so it can be called in raw C code with a function pointer.}
+//
+// return: [function!]
+// action [function!]
+// {The existing Rebol function whose functionality is being wrapped}
+// ffi-spec [block!]
+// {Description of what C types each Rebol argument should map to}
+// /abi
+// {Specify the Application Binary Interface (vs. using default)}
+// abi-type [word!]
+// {'CDECL, 'FASTCALL, 'STDCALL, etc.}
+// ]
+//
+REBNATIVE(make_callback)
+{
+ INCLUDE_PARAMS_OF_MAKE_CALLBACK;
+
+ ffi_abi abi;
+ if (REF(abi))
+ abi = Abi_From_Word(ARG(abi_type));
+ else
+ abi = FFI_DEFAULT_ABI;
+
+ REBFUN *fun = Alloc_Ffi_Function_For_Spec(ARG(ffi_spec), abi);
+ REBRIN *r = FUNC_ROUTINE(fun);
+
+ void *thunk; // actually CFUNC (FFI uses void*, may not be same size!)
+ ffi_closure *closure = cast(ffi_closure*, ffi_closure_alloc(
+ sizeof(ffi_closure), &thunk
+ ));
+
+ if (closure == NULL)
+ fail ("FFI: Couldn't allocate closure");
+
+ ffi_status status = ffi_prep_closure_loc(
+ closure,
+ RIN_CIF(r),
+ callback_dispatcher, // when thunk is called it calls this function...
+ r, // ...and this piece of data is passed to callback_dispatcher
+ thunk
+ );
+
+ if (status != FFI_OK)
+ fail ("FFI: Couldn't prep closure");
+
+ if (sizeof(void*) != sizeof(CFUNC*))
+ fail ("FFI does not work when void* size differs from CFUNC* size");
+
+ // It's the FFI's fault for using the wrong type for the thunk. Use a
+ // memcpy in order to get around strict checks that absolutely refuse to
+ // let you do a cast here.
+ //
+ CFUNC *cfunc_thunk;
+ memcpy(&cfunc_thunk, &thunk, sizeof(cfunc_thunk));
+
+ Init_Handle_Cfunc(RIN_AT(r, IDX_ROUTINE_CFUNC), cfunc_thunk, 0);
+ Init_Handle_Managed(
+ RIN_AT(r, IDX_ROUTINE_CLOSURE),
+ closure,
+ 0,
+ &cleanup_ffi_closure
+ );
+ Move_Value(RIN_AT(r, IDX_ROUTINE_ORIGIN), ARG(action));
+
+ Move_Value(D_OUT, FUNC_VALUE(fun));
+ return R_OUT;
+}
diff --git a/src/core/t-string.c b/src/core/t-string.c
index 26d23a658a..c8c7847513 100644
--- a/src/core/t-string.c
+++ b/src/core/t-string.c
@@ -1,836 +1,1234 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-string.c
-** Summary: string related datatypes
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-string.c
+// Summary: "string related datatypes"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#include "sys-scan.h"
#include "sys-deci-funcs.h"
+#include "sys-int-funcs.h"
-/***********************************************************************
-**
-*/ REBINT CT_String(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+
+//
+// CT_String: C
+//
+REBINT CT_String(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBINT num;
+ REBINT num;
- if (mode == 3)
- return VAL_SERIES(a) == VAL_SERIES(b) && VAL_INDEX(a) == VAL_INDEX(b);
+ num = Compare_String_Vals(a, b, NOT(mode == 1));
- num = Compare_String_Vals(a, b, (REBOOL) !(mode > 1));
- if (mode >= 0) return (num == 0);
- if (mode == -1) return (num >= 0);
- return (num > 0);
+ if (mode >= 0) return (num == 0) ? 1 : 0;
+ if (mode == -1) return (num >= 0) ? 1 : 0;
+ return (num > 0) ? 1 : 0;
}
/***********************************************************************
**
-** Local Utility Functions
+** Local Utility Functions
**
***********************************************************************/
+// !!! "STRING value to CHAR value (save some code space)" <-- what?
static void str_to_char(REBVAL *out, REBVAL *val, REBCNT idx)
{
- // STRING value to CHAR value (save some code space)
- SET_CHAR(out, GET_ANY_CHAR(VAL_SERIES(val), idx));
+ // Note: out may equal val, do assignment in two steps
+ REBUNI codepoint = GET_ANY_CHAR(VAL_SERIES(val), idx);
+ Init_Char(out, codepoint);
}
+
static void swap_chars(REBVAL *val1, REBVAL *val2)
{
- REBUNI c1;
- REBUNI c2;
- REBSER *s1 = VAL_SERIES(val1);
- REBSER *s2 = VAL_SERIES(val2);
-
- c1 = GET_ANY_CHAR(s1, VAL_INDEX(val1));
- c2 = GET_ANY_CHAR(s2, VAL_INDEX(val2));
-
- if (BYTE_SIZE(s1) && c2 > 0xff) Widen_String(s1);
- SET_ANY_CHAR(s1, VAL_INDEX(val1), c2);
-
- if (BYTE_SIZE(s2) && c1 > 0xff) Widen_String(s2);
- SET_ANY_CHAR(s2, VAL_INDEX(val2), c1);
+ REBUNI c1;
+ REBUNI c2;
+ REBSER *s1 = VAL_SERIES(val1);
+ REBSER *s2 = VAL_SERIES(val2);
+
+ c1 = GET_ANY_CHAR(s1, VAL_INDEX(val1));
+ c2 = GET_ANY_CHAR(s2, VAL_INDEX(val2));
+
+ if (BYTE_SIZE(s1) && c2 > 0xff) Widen_String(s1, TRUE);
+ SET_ANY_CHAR(s1, VAL_INDEX(val1), c2);
+
+ if (BYTE_SIZE(s2) && c1 > 0xff) Widen_String(s2, TRUE);
+ SET_ANY_CHAR(s2, VAL_INDEX(val2), c1);
}
+
static void reverse_string(REBVAL *value, REBCNT len)
{
- REBCNT n;
- REBCNT m;
- REBUNI c;
-
- if (VAL_BYTE_SIZE(value)) {
- REBYTE *bp = VAL_BIN_DATA(value);
-
- for (n = 0, m = len-1; n < len / 2; n++, m--) {
- c = bp[n];
- bp[n] = bp[m];
- bp[m] = (REBYTE)c;
- }
- }
- else {
- REBUNI *up = VAL_UNI_DATA(value);
-
- for (n = 0, m = len-1; n < len / 2; n++, m--) {
- c = up[n];
- up[n] = up[m];
- up[m] = c;
- }
- }
+ REBCNT n;
+ REBCNT m;
+ REBUNI c;
+
+ if (VAL_BYTE_SIZE(value)) {
+ REBYTE *bp = VAL_BIN_AT(value);
+
+ for (n = 0, m = len-1; n < len / 2; n++, m--) {
+ c = bp[n];
+ bp[n] = bp[m];
+ bp[m] = (REBYTE)c;
+ }
+ }
+ else {
+ REBUNI *up = VAL_UNI_AT(value);
+
+ for (n = 0, m = len-1; n < len / 2; n++, m--) {
+ c = up[n];
+ up[n] = up[m];
+ up[m] = c;
+ }
+ }
}
-static REBCNT find_string(REBSER *series, REBCNT index, REBCNT end, REBVAL *target, REBCNT len, REBCNT flags, REBINT skip)
-{
- REBCNT start = index;
-
- if (flags & (AM_FIND_REVERSE | AM_FIND_LAST)) {
- skip = -1;
- start = 0;
- if (flags & AM_FIND_LAST) index = end - len;
- else index--;
- }
-
- if (ANY_BINSTR(target)) {
- // Do the optimal search or the general search?
- if (BYTE_SIZE(series) && VAL_BYTE_SIZE(target) && !(flags & ~(AM_FIND_CASE|AM_FIND_MATCH)))
- return Find_Byte_Str(series, start, VAL_BIN_DATA(target), len, !GET_FLAG(flags, ARG_FIND_CASE-1), GET_FLAG(flags, ARG_FIND_MATCH-1));
- else
- return Find_Str_Str(series, start, index, end, skip, VAL_SERIES(target), VAL_INDEX(target), len, flags & (AM_FIND_MATCH|AM_FIND_CASE));
- }
- else if (IS_BINARY(target)) {
- return Find_Byte_Str(series, start, VAL_BIN_DATA(target), len, 0, GET_FLAG(flags, ARG_FIND_MATCH-1));
- }
- else if (IS_CHAR(target)) {
- return Find_Str_Char(series, start, index, end, skip, VAL_CHAR(target), flags);
- }
- else if (IS_INTEGER(target)) {
- return Find_Str_Char(series, start, index, end, skip, (REBUNI)VAL_INT32(target), flags);
- }
- else if (IS_BITSET(target)) {
- return Find_Str_Bitset(series, start, index, end, skip, VAL_SERIES(target), flags);
- }
-
- return NOT_FOUND;
-}
-static REBSER *make_string(REBVAL *arg, REBOOL make)
-{
- REBSER *ser = 0;
-
- // MAKE 123
- if (make && (IS_INTEGER(arg) || IS_DECIMAL(arg))) {
- ser = Make_Binary(Int32s(arg, 0));
- }
- // MAKE/TO
- else if (IS_BINARY(arg)) {
- REBYTE *bp = VAL_BIN_DATA(arg);
- REBCNT len = VAL_LEN(arg);
- switch (What_UTF(bp, len)) {
- case 0:
- break;
- case 8: // UTF-8 encoded
- bp += 3;
- len -= 3;
- break;
- default:
- Trap0(RE_BAD_DECODE);
- }
- ser = Decode_UTF_String(bp, len, 8); // UTF-8
- }
- // MAKE/TO
- else if (ANY_BINSTR(arg)) {
- ser = Copy_String(VAL_SERIES(arg), VAL_INDEX(arg), VAL_LEN(arg));
- }
- // MAKE/TO
- else if (ANY_WORD(arg)) {
- ser = Copy_Mold_Value(arg, TRUE);
- //ser = Append_UTF8(0, Get_Word_Name(arg), -1);
- }
- // MAKE/TO #"A"
- else if (IS_CHAR(arg)) {
- ser = (VAL_CHAR(arg) > 0xff) ? Make_Unicode(2) : Make_Binary(2);
- Append_Byte(ser, VAL_CHAR(arg));
- }
- // MAKE/TO
-// else if (IS_NONE(arg)) {
-// ser = Make_Binary(0);
-// }
- else
- ser = Copy_Form_Value(arg, 1<= index);
+
+ if (target_len > end - index) // series not long enough to have target
+ return NOT_FOUND;
+
+ REBCNT start = index;
+
+ if (flags & (AM_FIND_REVERSE | AM_FIND_LAST)) {
+ skip = -1;
+ start = 0;
+ if (flags & AM_FIND_LAST) index = end - target_len;
+ else index--;
+ }
+
+ if (ANY_BINSTR(target)) {
+ // Do the optimal search or the general search?
+ if (
+ BYTE_SIZE(series)
+ && VAL_BYTE_SIZE(target)
+ && !(flags & ~(AM_FIND_CASE|AM_FIND_MATCH))
+ ) {
+ return Find_Byte_Str(
+ series,
+ start,
+ VAL_BIN_AT(target),
+ target_len,
+ NOT(flags & AM_FIND_CASE),
+ LOGICAL(flags & AM_FIND_MATCH)
+ );
+ }
+ else {
+ return Find_Str_Str(
+ series,
+ start,
+ index,
+ end,
+ skip,
+ VAL_SERIES(target),
+ VAL_INDEX(target),
+ target_len,
+ flags & (AM_FIND_MATCH|AM_FIND_CASE)
+ );
+ }
+ }
+ else if (IS_BINARY(target)) {
+ const REBOOL uncase = FALSE;
+ return Find_Byte_Str(
+ series,
+ start,
+ VAL_BIN_AT(target),
+ target_len,
+ uncase, // "don't treat case insensitively"
+ LOGICAL(flags & AM_FIND_MATCH)
+ );
+ }
+ else if (IS_CHAR(target)) {
+ return Find_Str_Char(
+ VAL_CHAR(target),
+ series,
+ start,
+ index,
+ end,
+ skip,
+ flags
+ );
+ }
+ else if (IS_INTEGER(target)) {
+ return Find_Str_Char(
+ cast(REBUNI, VAL_INT32(target)),
+ series,
+ start,
+ index,
+ end,
+ skip,
+ flags
+ );
+ }
+ else if (IS_BITSET(target)) {
+ return Find_Str_Bitset(
+ series,
+ start,
+ index,
+ end,
+ skip,
+ VAL_SERIES(target),
+ flags
+ );
+ }
+
+ return NOT_FOUND;
}
-static REBSER *Make_Binary_BE64(REBVAL *arg)
-{
- REBSER *ser = Make_Binary(9);
- REBI64 n = VAL_INT64(arg);
- REBINT count;
- REBYTE *bp = BIN_HEAD(ser);
-
- for (count = 7; count >= 0; count--) {
- bp[count] = (REBYTE)(n & 0xff);
- n >>= 8;
- }
- bp[8] = 0;
- ser->tail = 8;
-
- return ser;
-}
-static REBSER *make_binary(REBVAL *arg, REBOOL make)
+static REBSER *MAKE_TO_String_Common(const REBVAL *arg)
{
- REBSER *ser;
-
- // MAKE BINARY! 123
- switch (VAL_TYPE(arg)) {
- case REB_INTEGER:
- case REB_DECIMAL:
- if (make) ser = Make_Binary(Int32s(arg, 0));
- else ser = Make_Binary_BE64(arg);
- break;
-
- // MAKE/TO BINARY! BINARY!
- case REB_BINARY:
- ser = Copy_Bytes(VAL_BIN_DATA(arg), VAL_LEN(arg));
- break;
-
- // MAKE/TO BINARY!
- case REB_STRING:
- case REB_FILE:
- case REB_EMAIL:
- case REB_URL:
- case REB_TAG:
-// case REB_ISSUE:
- ser = Encode_UTF8_Value(arg, VAL_LEN(arg), 0);
- break;
-
- case REB_BLOCK:
- // Join_Binary returns a shared buffer, so produce a copy:
- ser = Copy_Series(Join_Binary(arg));
- break;
-
- // MAKE/TO BINARY!
- case REB_TUPLE:
- ser = Copy_Bytes(VAL_TUPLE(arg), VAL_TUPLE_LEN(arg));
- break;
-
- // MAKE/TO BINARY!
- case REB_CHAR:
- ser = Make_Binary(6);
- ser->tail = Encode_UTF8_Char(BIN_HEAD(ser), VAL_CHAR(arg));
- break;
-
- // MAKE/TO BINARY!
- case REB_BITSET:
- ser = Copy_Bytes(VAL_BIN(arg), VAL_TAIL(arg));
- break;
-
- // MAKE/TO BINARY!
- case REB_IMAGE:
- ser = Make_Image_Binary(arg);
- break;
-
- case REB_MONEY:
- ser = Make_Binary(12);
- ser->tail = 12;
- deci_to_binary(ser->data, VAL_DECI(arg));
- ser->data[12] = 0;
- break;
-
- default:
- ser = 0;
- }
-
- return ser;
+ REBSER *ser = 0;
+
+ // MAKE/TO
+ if (IS_BINARY(arg)) {
+ REBYTE *bp = VAL_BIN_AT(arg);
+ REBCNT len = VAL_LEN_AT(arg);
+ switch (What_UTF(bp, len)) {
+ case 0:
+ break;
+ case 8: // UTF-8 encoded
+ bp += 3;
+ len -= 3;
+ break;
+ default:
+ fail (Error_Bad_Utf8_Raw());
+ }
+ ser = Decode_UTF_String(bp, len, 8); // UTF-8
+ }
+ // MAKE/TO
+ else if (ANY_BINSTR(arg)) {
+ ser = Copy_String_Slimming(VAL_SERIES(arg), VAL_INDEX(arg), VAL_LEN_AT(arg));
+ }
+ // MAKE/TO
+ else if (ANY_WORD(arg)) {
+ ser = Copy_Mold_Value(arg, 0 /* opts... MOPT_0? */);
+ }
+ // MAKE/TO #"A"
+ else if (IS_CHAR(arg)) {
+ ser = (VAL_CHAR(arg) > 0xff) ? Make_Unicode(2) : Make_Binary(2);
+ Append_Codepoint_Raw(ser, VAL_CHAR(arg));
+ }
+ else
+ ser = Copy_Form_Value(arg, 1 << MOPT_TIGHT);
+
+ return ser;
}
-/***********************************************************************
-**
-*/ REBFLG MT_String(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+
+static REBSER *Make_Binary_BE64(const REBVAL *arg)
{
- REBCNT i;
-
- if (!ANY_BINSTR(data)) return FALSE;
- *out = *data++;
- VAL_SET(out, type);
- i = IS_INTEGER(data) ? Int32(data) - 1 : 0;
- if (i > VAL_TAIL(out)) i = VAL_TAIL(out); // clip it
- VAL_INDEX(out) = i;
- return TRUE;
+ REBSER *ser = Make_Binary(8);
+
+ REBYTE *bp = BIN_HEAD(ser);
+
+ REBI64 i;
+ REBDEC d;
+ const REBYTE *cp;
+ if (IS_INTEGER(arg)) {
+ assert(sizeof(REBI64) == 8);
+ i = VAL_INT64(arg);
+ cp = cast(const REBYTE*, &i);
+ }
+ else {
+ assert(sizeof(REBDEC) == 8);
+ d = VAL_DECIMAL(arg);
+ cp = cast(const REBYTE*, &d);
+ }
+
+#ifdef ENDIAN_LITTLE
+ REBCNT n;
+ for (n = 0; n < 8; ++n)
+ bp[n] = cp[7 - n];
+#elif defined(ENDIAN_BIG)
+ REBCNT n;
+ for (n = 0; n < 8; ++n)
+ bp[n] = cp[n];
+#else
+ #error "Unsupported CPU endian"
+#endif
+
+ TERM_BIN_LEN(ser, 8);
+ return ser;
}
-/***********************************************************************
-**
-*/ static int Compare_Chr(const void *v1, const void *v2)
-/*
-***********************************************************************/
+static REBSER *make_binary(const REBVAL *arg, REBOOL make)
{
- return ((int)*(REBYTE*)v1) - ((int)*(REBYTE*)v2);
+ REBSER *ser;
+
+ // MAKE BINARY! 123
+ switch (VAL_TYPE(arg)) {
+ case REB_INTEGER:
+ case REB_DECIMAL:
+ if (make) ser = Make_Binary(Int32s(arg, 0));
+ else ser = Make_Binary_BE64(arg);
+ break;
+
+ // MAKE/TO BINARY! BINARY!
+ case REB_BINARY:
+ ser = Copy_Bytes(VAL_BIN_AT(arg), VAL_LEN_AT(arg));
+ break;
+
+ // MAKE/TO BINARY!
+ case REB_STRING:
+ case REB_FILE:
+ case REB_EMAIL:
+ case REB_URL:
+ case REB_TAG:
+// case REB_ISSUE:
+ ser = Make_UTF8_From_Any_String(arg, VAL_LEN_AT(arg), 0);
+ break;
+
+ case REB_BLOCK:
+ // Join_Binary returns a shared buffer, so produce a copy:
+ ser = Copy_Sequence(Join_Binary(arg, -1));
+ break;
+
+ // MAKE/TO BINARY!
+ case REB_TUPLE:
+ ser = Copy_Bytes(VAL_TUPLE(arg), VAL_TUPLE_LEN(arg));
+ break;
+
+ // MAKE/TO BINARY!
+ case REB_CHAR:
+ ser = Make_Binary(6);
+ TERM_SEQUENCE_LEN(ser, Encode_UTF8_Char(BIN_HEAD(ser), VAL_CHAR(arg)));
+ break;
+
+ // MAKE/TO BINARY!
+ case REB_BITSET:
+ ser = Copy_Bytes(VAL_BIN(arg), VAL_LEN_HEAD(arg));
+ break;
+
+ // MAKE/TO BINARY!
+ case REB_IMAGE:
+ ser = Make_Image_Binary(arg);
+ break;
+
+ case REB_MONEY:
+ ser = Make_Binary(12);
+ deci_to_binary(BIN_HEAD(ser), VAL_MONEY_AMOUNT(arg));
+ TERM_SEQUENCE_LEN(ser, 12);
+ break;
+
+ default:
+ ser = 0;
+ }
+
+ return ser;
}
-/***********************************************************************
-**
-*/ static int Compare_Chr_Rev(const void *v1, const void *v2)
-/*
-***********************************************************************/
-{
- return ((int)*(REBYTE*)v2) - ((int)*(REBYTE*)v1);
+//
+// MAKE_String: C
+//
+void MAKE_String(REBVAL *out, enum Reb_Kind kind, const REBVAL *def) {
+ REBSER *ser; // goto would cross initialization
+
+ if (IS_INTEGER(def)) {
+ //
+ // !!! R3-Alpha tolerated decimal, e.g. `make string! 3.14`, which
+ // is semantically nebulous (round up, down?) and generally bad.
+ //
+ ser = Make_Binary(Int32s(def, 0));
+ Init_Any_Series(out, kind, ser);
+ return;
+ }
+ else if (IS_BLOCK(def)) {
+ //
+ // The construction syntax for making strings or binaries that are
+ // preloaded with an offset into the data is #[binary [#{0001} 2]].
+ // In R3-Alpha make definitions didn't have to be a single value
+ // (they are for compatibility between construction syntax and MAKE
+ // in Ren-C). So the positional syntax was #[binary! #{0001} 2]...
+ // while #[binary [#{0001} 2]] would join the pieces together in order
+ // to produce #{000102}. That behavior is not available in Ren-C.
+
+ if (VAL_ARRAY_LEN_AT(def) != 2)
+ goto bad_make;
+
+ RELVAL *any_binstr = VAL_ARRAY_AT(def);
+ if (!ANY_BINSTR(any_binstr))
+ goto bad_make;
+ if (IS_BINARY(any_binstr) != LOGICAL(kind == REB_BINARY))
+ goto bad_make;
+
+ RELVAL *index = VAL_ARRAY_AT(def) + 1;
+ if (!IS_INTEGER(index))
+ goto bad_make;
+
+ REBINT i = Int32(index) - 1 + VAL_INDEX(any_binstr);
+ if (i < 0 || i > cast(REBINT, VAL_LEN_AT(any_binstr)))
+ goto bad_make;
+
+ Init_Any_Series_At(out, kind, VAL_SERIES(any_binstr), i);
+ return;
+ }
+
+ if (kind == REB_BINARY)
+ ser = make_binary(def, TRUE);
+ else
+ ser = MAKE_TO_String_Common(def);
+
+ if (!ser)
+ goto bad_make;
+
+ Init_Any_Series_At(out, kind, ser, 0);
+ return;
+
+bad_make:
+ fail (Error_Bad_Make(kind, def));
}
-/***********************************************************************
-**
-*/ static void Sort_String(REBVAL *string, REBFLG ccase, REBVAL *skipv, REBVAL *compv, REBVAL *part, REBFLG all, REBFLG rev)
-/*
-***********************************************************************/
+//
+// TO_String: C
+//
+void TO_String(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBCNT len;
- REBCNT skip = 1;
- REBCNT size = 1;
- int (*sfunc)(const void *v1, const void *v2);
-
- // Determine length of sort:
- len = Partial(string, 0, part, 0);
- if (len <= 1) return;
-
- // Skip factor:
- if (!IS_NONE(skipv)) {
- skip = Get_Num_Arg(skipv);
- if (skip <= 0 || len % skip != 0 || skip > len)
- Trap_Arg(skipv);
- }
-
- // Use fast quicksort library function:
- if (skip > 1) len /= skip, size *= skip;
- sfunc = rev ? Compare_Chr_Rev : Compare_Chr;
-
- //!!uni - needs to compare wide chars too
- qsort((void *)VAL_DATA(string), len, size * SERIES_WIDE(VAL_SERIES(string)), sfunc);
-}
+ REBSER *ser;
+ if (kind == REB_BINARY)
+ ser = make_binary(arg, FALSE);
+ else
+ ser = MAKE_TO_String_Common(arg);
+ if (ser == NULL)
+ fail (arg);
-/***********************************************************************
-**
-*/ REBINT PD_String(REBPVS *pvs)
-/*
-***********************************************************************/
-{
- REBVAL *data = pvs->value;
- REBVAL *val = pvs->setval;
- REBINT n = 0;
- REBCNT i;
- REBINT c;
- REBSER *ser = VAL_SERIES(data);
-
- if (IS_INTEGER(pvs->select)) {
- n = Int32(pvs->select) + VAL_INDEX(data) - 1;
- }
- else return PE_BAD_SELECT;
-
- if (val == 0) {
- if (n < 0 || (REBCNT)n >= SERIES_TAIL(ser)) return PE_NONE;
- if (IS_BINARY(data)) {
- SET_INTEGER(pvs->store, *BIN_SKIP(ser, n));
- } else {
- SET_CHAR(pvs->store, GET_ANY_CHAR(ser, n));
- }
- return PE_USE;
- }
-
- if (n < 0 || (REBCNT)n >= SERIES_TAIL(ser)) return PE_BAD_RANGE;
-
- if (IS_CHAR(val)) {
- c = VAL_CHAR(val);
- if (c > MAX_CHAR) return PE_BAD_SET;
- }
- else if (IS_INTEGER(val)) {
- c = Int32(val);
- if (c > MAX_CHAR || c < 0) return PE_BAD_SET;
- if (IS_BINARY(data)) { // special case for binary
- if (c > 0xff) Trap_Range(val);
- BIN_HEAD(ser)[n] = (REBYTE)c;
- return PE_OK;
- }
- }
- else if (ANY_BINSTR(val)) {
- i = VAL_INDEX(val);
- if (i >= VAL_TAIL(val)) return PE_BAD_SET;
- c = GET_ANY_CHAR(VAL_SERIES(val), i);
- }
- else
- return PE_BAD_SELECT;
-
- TRAP_PROTECT(ser);
-
- if (BYTE_SIZE(ser) && c > 0xff) Widen_String(ser);
- SET_ANY_CHAR(ser, n, c);
-
- return PE_OK;
+ Init_Any_Series(out, kind, ser);
}
-/***********************************************************************
-**
-*/ REBINT PD_File(REBPVS *pvs)
-/*
-***********************************************************************/
+//
+// to-string: native [
+//
+// {Like TO STRING! but with additional options.}
+//
+// value [any-value!]
+// {Value to convert to a string.}
+// /astral
+// {Provide special handling for codepoints bigger than 0xFFFF}
+// handler [function! string! char! blank!]
+// {If function, receives integer argument of large codepoint value}
+// ]
+//
+REBNATIVE(to_string)
{
- REBSER *ser;
- REB_MOLD mo = {0};
- REBCNT n;
- REBUNI c;
- REBSER *arg;
-
- if (pvs->setval) return PE_BAD_SET;
+ INCLUDE_PARAMS_OF_TO_STRING;
+
+ REBVAL *value = ARG(value);
+
+ if (NOT(REF(astral)) || NOT(IS_BINARY(value))) {
+ TO_String(D_OUT, REB_STRING, value); // just act like TO STRING!
+ return R_OUT;
+ }
+
+ // Ordinarily, UTF8 decoding is done into the unicode buffer. The number
+ // of unicode codepoints is guaranteed to be <= the number of UTF8 bytes,
+ // so the length is used as a conservative bound. Since we don't know
+ // how many astral codepoints there are, it's not easy to know the size
+ // in advance. So the series may be expanded multiple times.
+ //
+ REBSER *ser = Make_Unicode(VAL_LEN_AT(value));
+ if (Decode_UTF8_Maybe_Astral_Throws(
+ D_OUT,
+ ser,
+ VAL_BIN_AT(value),
+ VAL_LEN_AT(value),
+ TRUE, // cr/lf => lf conversion is done by TO_String (review)
+ ARG(handler)
+ )){
+ return R_OUT_IS_THROWN;
+ }
+
+ // !!! Note also that since this conversion does not go through the
+ // unicode buffer, so it's not copied out with "slimming" if it turns out
+ // to not contain wide chars.
+
+ Init_String(D_OUT, ser);
+ return R_OUT;
+}
- ser = Copy_Series_Value(pvs->value);
- n = SERIES_TAIL(ser);
- if (n > 0) c = GET_ANY_CHAR(ser, n-1);
- if (n == 0 || c != '/') Append_Byte(ser, '/');
+enum COMPARE_CHR_FLAGS {
+ CC_FLAG_WIDE = 1 << 0, // String is REBUNI[] and not REBYTE[]
+ CC_FLAG_CASE = 1 << 1, // Case sensitive sort
+ CC_FLAG_REVERSE = 1 << 2 // Reverse sort order
+};
- if (ANY_STR(pvs->select))
- arg = VAL_SERIES(pvs->select);
- else {
- Reset_Mold(&mo);
- Mold_Value(&mo, pvs->select, 0);
- arg = mo.series;
- }
- c = GET_ANY_CHAR(arg, 0);
- n = (c == '/' || c == '\\') ? 1 : 0;
- Append_String(ser, arg, n, arg->tail-n);
+//
+// Compare_Chr: C
+//
+// This function is called by qsort_r, on behalf of the string sort
+// function. The `thunk` is an argument passed through from the caller
+// and given to us by the sort routine, which tells us about the string
+// and the kind of sort that was requested.
+//
+static int Compare_Chr(void *thunk, const void *v1, const void *v2)
+{
+ REBCNT * const flags = cast(REBCNT*, thunk);
+
+ REBUNI c1;
+ REBUNI c2;
+ if (*flags & CC_FLAG_WIDE) {
+ c1 = *cast(const REBUNI*, v1);
+ c2 = *cast(const REBUNI*, v2);
+ }
+ else {
+ c1 = cast(REBUNI, *cast(const REBYTE*, v1));
+ c2 = cast(REBUNI, *cast(const REBYTE*, v2));
+ }
+
+ if (*flags & CC_FLAG_CASE) {
+ if (*flags & CC_FLAG_REVERSE)
+ return *cast(const REBYTE*, v2) - *cast(const REBYTE*, v1);
+ else
+ return *cast(const REBYTE*, v1) - *cast(const REBYTE*, v2);
+ }
+ else {
+ if (*flags & CC_FLAG_REVERSE) {
+ if (c1 < UNICODE_CASES)
+ c1 = UP_CASE(c1);
+ if (c2 < UNICODE_CASES)
+ c2 = UP_CASE(c2);
+ return c2 - c1;
+ }
+ else {
+ if (c1 < UNICODE_CASES)
+ c1 = UP_CASE(c1);
+ if (c2 < UNICODE_CASES)
+ c2 = UP_CASE(c2);
+ return c1 - c2;
+ }
+ }
+}
- Set_Series(VAL_TYPE(pvs->value), pvs->store, ser);
- return PE_USE;
+//
+// Sort_String: C
+//
+static void Sort_String(
+ REBVAL *string,
+ REBOOL ccase,
+ REBVAL *skipv,
+ REBVAL *compv,
+ REBVAL *part,
+ REBOOL rev
+) {
+ if (!IS_VOID(compv))
+ fail (Error_Bad_Refine_Raw(compv)); // !!! didn't seem to be supported (?)
+
+ REBCNT len;
+ REBCNT skip = 1;
+ REBCNT size = 1;
+ REBCNT thunk = 0;
+
+ // Determine length of sort:
+ len = Partial(string, 0, part);
+ if (len <= 1) return;
+
+ // Skip factor:
+ if (!IS_VOID(skipv)) {
+ skip = Get_Num_From_Arg(skipv);
+ if (skip <= 0 || len % skip != 0 || skip > len)
+ fail (skipv);
+ }
+
+ // Use fast quicksort library function:
+ if (skip > 1) len /= skip, size *= skip;
+
+ if (!VAL_BYTE_SIZE(string)) thunk |= CC_FLAG_WIDE;
+ if (ccase) thunk |= CC_FLAG_CASE;
+ if (rev) thunk |= CC_FLAG_REVERSE;
+
+ reb_qsort_r(
+ VAL_RAW_DATA_AT(string),
+ len,
+ size * SER_WIDE(VAL_SERIES(string)),
+ &thunk,
+ Compare_Chr
+ );
}
-/***********************************************************************
-**
-*/ REBTYPE(String)
-/*
-***********************************************************************/
+//
+// PD_String: C
+//
+REBINT PD_String(REBPVS *pvs)
{
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBINT index;
- REBINT tail;
- REBINT len;
- REBSER *ser;
- REBCNT type;
- REBCNT args;
- REBCNT ret;
-
- if ((IS_FILE(value) || IS_URL(value)) && action >= PORT_ACTIONS) {
- return T_Port(ds, action);
- }
-
- len = Do_Series_Action(action, value, arg);
- if (len >= 0) return len;
-
- // Common setup code for all actions:
- if (action != A_MAKE && action != A_TO) {
- index = (REBINT)VAL_INDEX(value);
- tail = (REBINT)VAL_TAIL(value);
- }
-
- // Check must be in this order (to avoid checking a non-series value);
- if (action >= A_TAKE && action <= A_SORT && IS_PROTECT_SERIES(VAL_SERIES(value)))
- Trap0(RE_PROTECTED);
-
- switch (action) {
-
- //-- Modification:
- case A_APPEND:
- case A_INSERT:
- case A_CHANGE:
- //Modify_String(action, value, arg);
- // Length of target (may modify index): (arg can be anything)
- len = Partial1((action == A_CHANGE) ? value : arg, DS_ARG(AN_LENGTH));
- index = VAL_INDEX(value);
- args = 0;
- if (IS_BINARY(value)) SET_FLAG(args, AN_SERIES); // special purpose
- if (DS_REF(AN_PART)) SET_FLAG(args, AN_PART);
- index = Modify_String(action, VAL_SERIES(value), index, arg, args, len, DS_REF(AN_DUP) ? Int32(DS_ARG(AN_COUNT)) : 1);
- VAL_INDEX(value) = index;
- break;
-
- //-- Search:
- case A_SELECT:
- ret = ALL_SELECT_REFS;
- goto find;
- case A_FIND:
- ret = ALL_FIND_REFS;
-find:
- args = Find_Refines(ds, ret);
-
- if (IS_BINARY(value)) {
- args |= AM_FIND_CASE;
- if (!IS_BINARY(arg) && !IS_INTEGER(arg) && !IS_BITSET(arg)) Trap0(RE_NOT_SAME_TYPE);
- if (IS_INTEGER(arg)) {
- if (VAL_INT64(arg) < 0 || VAL_INT64(arg) > 255) Trap_Range(arg);
- len = 1;
- }
- }
- else {
- if (IS_CHAR(arg) || IS_BITSET(arg)) len = 1;
- else if (!ANY_STR(arg)) {
- Set_String(arg, Copy_Form_Value(arg, 0));
- }
- }
-
- if (ANY_BINSTR(arg)) len = VAL_LEN(arg);
-
- if (args & AM_FIND_PART) tail = Partial(value, 0, D_ARG(ARG_FIND_LENGTH), 0);
- ret = 1; // skip size
- if (args & AM_FIND_SKIP) ret = Partial(value, 0, D_ARG(ARG_FIND_SIZE), 0);
-
- ret = find_string(VAL_SERIES(value), index, tail, arg, len, args, ret);
-
- if (ret >= (REBCNT)tail) goto is_none;
- if (args & AM_FIND_ONLY) len = 1;
-
- if (action == A_FIND) {
- if (args & (AM_FIND_TAIL | AM_FIND_MATCH)) ret += len;
- VAL_INDEX(value) = ret;
- }
- else {
- ret++;
- if (ret >= (REBCNT)tail) goto is_none;
- if (IS_BINARY(value)) {
- SET_INTEGER(value, *BIN_SKIP(VAL_SERIES(value), ret));
- }
- else
- str_to_char(value, value, ret);
- }
- break;
-
- //-- Picking:
- case A_PICK:
- case A_POKE:
- len = Get_Num_Arg(arg); // Position
- index += len - 1;
- //if (len > 0) index--;
- if (index < 0 || index >= tail) {
- if (action == A_PICK) goto is_none;
- Trap_Range(arg);
- }
- if (action == A_PICK) {
-pick_it:
- if (IS_BINARY(value)) {
- SET_INTEGER(DS_RETURN, *VAL_BIN_SKIP(value, index));
- }
- else
- str_to_char(DS_RETURN, value, index);
- return R_RET;
- }
- else {
- REBUNI c;
- arg = D_ARG(3);
- if (IS_CHAR(arg))
- c = VAL_CHAR(arg);
- else if (IS_INTEGER(arg) && VAL_UNT64(arg) <= MAX_CHAR)
- c = VAL_INT32(arg);
- else Trap_Arg(arg);
-
- ser = VAL_SERIES(value);
- if (IS_BINARY(value)) {
- if (c > 0xff) Trap_Range(arg);
- BIN_HEAD(ser)[index] = (REBYTE)c;
- }
- else {
- if (BYTE_SIZE(ser) && c > 0xff) Widen_String(ser);
- SET_ANY_CHAR(ser, index, c);
- }
- value = arg;
- }
- break;
-
- case A_TAKE:
- if (D_REF(2)) {
- len = Partial(value, 0, D_ARG(3), 0);
- if (len == 0) {
-zero_str:
- Set_Series(VAL_TYPE(value), D_RET, Make_Binary(0));
- return R_RET;
- }
- } else
- len = 1;
-
- index = VAL_INDEX(value); // /part can change index
-
- // take/last:
- if (D_REF(5)) index = tail - len;
- if (index < 0 || index >= tail) {
- if (!D_REF(2)) goto is_none;
- goto zero_str;
- }
-
- ser = VAL_SERIES(value);
- // if no /part, just return value, else return string:
- if (!D_REF(2)) {
- if (IS_BINARY(value)) {
- SET_INTEGER(value, *VAL_BIN_SKIP(value, index));
- } else
- str_to_char(value, value, index);
- }
- else Set_Series(VAL_TYPE(value), value, Copy_String(ser, index, len));
- Remove_Series(ser, index, len);
- break;
-
- case A_CLEAR:
- if (index < tail) {
- if (index == 0) Reset_Series(VAL_SERIES(value));
- else {
- VAL_TAIL(value) = (REBCNT)index;
- TERM_SERIES(VAL_SERIES(value));
- }
- }
- break;
-
- //-- Creation:
-
- case A_COPY:
- len = Partial(value, 0, D_ARG(3), 0); // Can modify value index.
- ser = Copy_String(VAL_SERIES(value), VAL_INDEX(value), len);
- goto ser_exit;
-
- case A_MAKE:
- case A_TO:
- // Determine the datatype to create:
- type = VAL_TYPE(value);
- if (type == REB_DATATYPE) type = VAL_DATATYPE(value);
-
- if (IS_NONE(arg)) Trap_Make(type, arg);
-
- ser = (type != REB_BINARY)
- ? make_string(arg, (REBOOL)(action == A_MAKE))
- : make_binary(arg, (REBOOL)(action == A_MAKE));
-
- if (ser) goto str_exit;
- Trap_Arg(arg);
-
- //-- Bitwise:
-
- case A_AND:
- case A_OR:
- case A_XOR:
- if (!IS_BINARY(arg)) Trap_Arg(arg);
- VAL_LIMIT_SERIES(value);
- VAL_LIMIT_SERIES(arg);
- ser = Xandor_Binary(action, value, arg);
- goto ser_exit;
-
- case A_COMPLEMENT:
- if (!IS_BINARY(arg)) Trap_Arg(arg);
- ser = Complement_Binary(value);
- goto ser_exit;
-
- //-- Special actions:
-
- case A_TRIM:
- // Check for valid arg combinations:
- args = Find_Refines(ds, ALL_TRIM_REFS);
- if (
- (args & (AM_TRIM_ALL | AM_TRIM_WITH)) &&
- (args & (AM_TRIM_HEAD | AM_TRIM_TAIL | AM_TRIM_LINES | AM_TRIM_AUTO)) ||
- (args & AM_TRIM_AUTO) &&
- (args & (AM_TRIM_HEAD | AM_TRIM_TAIL | AM_TRIM_LINES | AM_TRIM_ALL | AM_TRIM_WITH))
- )
- Trap0(RE_BAD_REFINES);
-
- Trim_String(VAL_SERIES(value), VAL_INDEX(value), VAL_LEN(value), args, D_ARG(ARG_TRIM_STR));
- break;
-
- case A_SWAP:
- if (VAL_TYPE(value) != VAL_TYPE(arg)) Trap0(RE_NOT_SAME_TYPE);
- if (IS_PROTECT_SERIES(VAL_SERIES(arg))) Trap0(RE_PROTECTED);
- if (index < tail && VAL_INDEX(arg) < VAL_TAIL(arg))
- swap_chars(value, arg);
- // Trap_Range(arg); // ignore range error
- break;
-
- case A_REVERSE:
- len = Partial(value, 0, D_ARG(3), 0);
- if (len > 0) reverse_string(value, len);
- break;
-
- case A_SORT:
- Sort_String(
- value,
- D_REF(2), // case sensitive
- D_ARG(4), // skip size
- D_ARG(6), // comparator
- D_ARG(8), // part-length
- D_REF(9), // all fields
- D_REF(10) // reverse
- );
- break;
-
- case A_RANDOM:
- if (D_REF(2)) { // seed
- Set_Random(Compute_CRC(VAL_BIN_DATA(value), VAL_LEN(value)));
- return R_UNSET;
- }
- if (D_REF(4)) { // /only
- if (index >= tail) goto is_none;
- index += (REBCNT)Random_Int(D_REF(3)) % (tail - index); // /secure
- goto pick_it;
- }
- Shuffle_String(value, D_REF(3)); // /secure
- break;
-
- default:
- Trap_Action(VAL_TYPE(value), action);
- }
-
- DS_RET_VALUE(value);
- return R_RET;
-
-ser_exit:
- type = VAL_TYPE(value);
-str_exit:
- Set_Series(type, D_RET, ser);
- return R_RET;
-
-is_none:
- return R_NONE;
+ REBSER *ser = VAL_SERIES(pvs->value);
+
+ // Note: There was some more careful management of overflow here in the
+ // PICK and POKE actions, before unification. But otherwise the code
+ // was less thorough. Consider integrating this bit, though it seems
+ // that a more codebase-wide review should be given to the issue.
+ //
+ /*
+ REBINT len = Get_Num_From_Arg(arg);
+ if (
+ REB_I32_SUB_OF(len, 1, &len)
+ || REB_I32_ADD_OF(index, len, &index)
+ || index < 0 || index >= tail
+ ){
+ fail (Error_Out_Of_Range(arg));
+ }
+ */
+
+ if (pvs->opt_setval == NULL) { // PICK-ing
+ if (IS_INTEGER(pvs->picker)) {
+ REBINT n = Int32(pvs->picker) + VAL_INDEX(pvs->value) - 1;
+ if (n < 0 || cast(REBCNT, n) >= SER_LEN(ser)) {
+ Init_Void(pvs->store);
+ return PE_USE_STORE;
+ }
+
+ if (IS_BINARY(pvs->value))
+ Init_Integer(pvs->store, *BIN_AT(ser, n));
+ else
+ Init_Char(pvs->store, GET_ANY_CHAR(ser, n));
+
+ return PE_USE_STORE;
+ }
+
+ if (
+ IS_BINARY(pvs->value)
+ || NOT(IS_WORD(pvs->picker) || ANY_STRING(pvs->picker))
+ ){
+ fail (Error_Bad_Path_Select(pvs));
+ }
+
+ // !!! This is a historical and questionable feature, where path
+ // picking a string or word or otherwise out of a FILE! or URL! will
+ // generate a new FILE! or URL! with a slash in it.
+ //
+ // >> x: %foo
+ // >> type-of quote x/bar
+ // == path!
+ //
+ // >> x/bar
+ // == %foo/bar ;-- a FILE!
+ //
+ // This can only be done with evaluations, since FILE! and URL! have
+ // slashes in their literal form:
+ //
+ // >> type-of quote %foo/bar
+ // == file!
+ //
+ // Because Ren-C unified picking and pathing, this somewhat odd
+ // feature is now part of PICKing a string from another string.
+
+ REBSER *ser = Copy_Sequence_At_Position(KNOWN(pvs->value));
+
+ // This makes sure there's always a "/" at the end of the file before
+ // appending new material via a picker:
+ //
+ // >> x: %foo
+ // >> (x)/("bar")
+ // == %foo/bar
+ //
+ REBCNT len = SER_LEN(ser);
+ if (len == 0)
+ Append_Codepoint_Raw(ser, '/');
+ else {
+ REBUNI ch_last = GET_ANY_CHAR(ser, len - 1);
+ if (ch_last != '/')
+ Append_Codepoint_Raw(ser, '/');
+ }
+
+ REB_MOLD mo;
+ CLEARS(&mo);
+ Push_Mold(&mo);
+
+ Mold_Value(&mo, pvs->picker, FALSE);
+
+ // The `skip` logic here regarding slashes and backslashes apparently
+ // is for an exception to the rule of appending the molded content.
+ // It doesn't want two slashes in a row:
+ //
+ // >> x/("/bar")
+ // == %foo/bar
+ //
+ // !!! Review if this makes sense under a larger philosophy of string
+ // path composition.
+ //
+ REBUNI ch_start = GET_ANY_CHAR(mo.series, mo.start);
+ REBCNT skip = (ch_start == '/' || ch_start == '\\') ? 1 : 0;
+
+ // !!! Would be nice if there was a better way of doing this that didn't
+ // involve reaching into mo.start and mo.series.
+ //
+ Append_String(
+ ser, // dst
+ mo.series, // src
+ mo.start + skip, // i
+ SER_LEN(mo.series) - mo.start - skip // len
+ );
+
+ Drop_Mold(&mo);
+
+ // Note: pvs->value may point to pvs->store
+ //
+ Init_Any_Series(pvs->store, VAL_TYPE(pvs->value), ser);
+ return PE_USE_STORE;
+ }
+
+ // Otherwise, POKE-ing
+
+ FAIL_IF_READ_ONLY_SERIES(ser);
+
+ if (NOT(IS_INTEGER(pvs->picker)))
+ fail (Error_Bad_Path_Select(pvs));
+
+ REBINT n = Int32(pvs->picker) + VAL_INDEX(pvs->value) - 1;
+ if (n < 0 || cast(REBCNT, n) >= SER_LEN(ser))
+ fail (Error_Bad_Path_Range(pvs));
+
+ const REBVAL *setval = pvs->opt_setval;
+
+ REBINT c;
+ if (IS_CHAR(setval)) {
+ c = VAL_CHAR(setval);
+ if (c > MAX_CHAR)
+ fail (Error_Bad_Path_Set(pvs));
+ }
+ else if (IS_INTEGER(setval)) {
+ c = Int32(setval);
+ if (c > MAX_CHAR || c < 0)
+ fail (Error_Bad_Path_Set(pvs));
+ }
+ else if (ANY_BINSTR(setval)) {
+ REBCNT i = VAL_INDEX(setval);
+ if (i >= VAL_LEN_HEAD(setval))
+ fail (Error_Bad_Path_Set(pvs));
+
+ c = GET_ANY_CHAR(VAL_SERIES(setval), i);
+ }
+ else
+ fail (Error_Bad_Path_Select(pvs));
+
+ if (IS_BINARY(pvs->value)) {
+ if (c > 0xff)
+ fail (Error_Out_Of_Range(setval));
+
+ BIN_HEAD(ser)[n] = cast(REBYTE, c);
+ return PE_OK;
+ }
+
+ if (BYTE_SIZE(ser) && c > 0xff)
+ Widen_String(ser, TRUE);
+
+ SET_ANY_CHAR(ser, n, c);
+
+ return PE_OK;
}
-#ifdef oldcode
-/***********************************************************************
-**
-x*/ void Modify_StringX(REBCNT action, REBVAL *string, REBVAL *arg)
-/*
-** Actions: INSERT, APPEND, CHANGE
-**
-** string [string!] {Series at point to insert}
-** value [any-type!] {The value to insert}
-** /part {Limits to a given length or position.}
-** length [number! series! pair!]
-** /only {Inserts a series as a series.}
-** /dup {Duplicates the insert a specified number of times.}
-** count [number! pair!]
-**
-***********************************************************************/
+//
+// REBTYPE: C
+//
+REBTYPE(String)
{
- REBSER *series = VAL_SERIES(string);
- REBCNT index = VAL_INDEX(string);
- REBCNT tail = VAL_TAIL(string);
- REBINT rlen; // length to be removed
- REBINT ilen = 1; // length to be inserted
- REBINT cnt = 1; // DUP count
- REBINT size;
- REBVAL *val;
- REBSER *arg_ser = 0; // argument series
-
- // Length of target (may modify index): (arg can be anything)
- rlen = Partial1((action == A_CHANGE) ? string : arg, DS_ARG(AN_LENGTH));
-
- index = VAL_INDEX(string);
- if (action == A_APPEND || index > tail) index = tail;
-
- // If the arg is not a string, then we need to create a string:
- if (IS_BINARY(string)) {
- if (IS_INTEGER(arg)) {
- if (VAL_INT64(arg) > 255 || VAL_INT64(arg) < 0)
- Trap_Range(arg);
- arg_ser = Make_Binary(1);
- Append_Byte(arg_ser, VAL_CHAR(arg)); // check for size!!!
- }
- else if (!ANY_BINSTR(arg)) Trap_Arg(arg);
- }
- else if (IS_BLOCK(arg)) {
- // MOVE!
- REB_MOLD mo = {0};
- arg_ser = mo.series = Make_Unicode(VAL_BLK_LEN(arg) * 10); // GC!?
- for (val = VAL_BLK_DATA(arg); NOT_END(val); val++)
- Mold_Value(&mo, val, 0);
- }
- else if (IS_CHAR(arg)) {
- // Optimize this case !!!
- arg_ser = Make_Unicode(1);
- Append_Byte(arg_ser, VAL_CHAR(arg));
- }
- else if (!ANY_STR(arg) || IS_TAG(arg)) {
- arg_ser = Copy_Form_Value(arg, 0);
- }
- if (arg_ser) Set_String(arg, arg_ser);
- else arg_ser = VAL_SERIES(arg);
-
- // Length of insertion:
- ilen = (action != A_CHANGE && DS_REF(AN_PART)) ? rlen : VAL_LEN(arg);
-
- // If Source == Destination we need to prevent possible conflicts.
- // Clone the argument just to be safe.
- // (Note: It may be possible to optimize special cases like append !!)
- if (series == VAL_SERIES(arg)) {
- arg_ser = Copy_Series_Part(arg_ser, VAL_INDEX(arg), ilen); // GC!?
- }
-
- // Get /DUP count:
- if (DS_REF(AN_DUP)) {
- cnt = Int32(DS_ARG(AN_COUNT));
- if (cnt <= 0) return; // no changes
- }
-
- // Total to insert:
- size = cnt * ilen;
-
- if (action != A_CHANGE) {
- // Always expand series for INSERT and APPEND actions:
- Expand_Series(series, index, size);
- } else {
- if (size > rlen)
- Expand_Series(series, index, size-rlen);
- else if (size < rlen && DS_REF(AN_PART))
- Remove_Series(series, index, rlen-size);
- else if (size + index > tail) {
- EXPAND_SERIES_TAIL(series, size - (tail - index));
- }
- }
-
- // For dup count:
- for (; cnt > 0; cnt--) {
- Insert_String(series, index, arg_ser, VAL_INDEX(arg), ilen, TRUE);
- index += ilen;
- }
-
- TERM_SERIES(series);
-
- VAL_INDEX(string) = (action == A_APPEND) ? 0 : index;
+ REBSER *ser;
+ TRASH_POINTER_IF_DEBUG(ser); // `goto return_ser;` will return this
+
+ REBVAL *value = D_ARG(1);
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+
+ // Common operations for any series type (length, head, etc.)
+ {
+ REB_R r = Series_Common_Action_Maybe_Unhandled(frame_, action);
+ if (r != R_UNHANDLED)
+ return r;
+ }
+
+ // Common setup code for all actions:
+ //
+ REBINT index = cast(REBINT, VAL_INDEX(value));
+ REBINT tail = cast(REBINT, VAL_LEN_HEAD(value));
+
+ switch (action) {
+
+ //-- Modification:
+ case SYM_APPEND:
+ case SYM_INSERT:
+ case SYM_CHANGE: {
+ INCLUDE_PARAMS_OF_INSERT;
+
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(value));
+
+ UNUSED(PAR(series));
+ UNUSED(PAR(value));
+
+ if (REF(only)) {
+ // !!! Doesn't pay attention...all string appends are /ONLY
+ }
+
+ REBINT len;
+ Partial1(
+ (action == SYM_CHANGE) ? value : arg,
+ ARG(limit),
+ cast(REBCNT*, &len)
+ );
+ index = VAL_INDEX(value);
+
+ REBFLGS flags = 0;
+ if (IS_BINARY(value))
+ flags |= AM_BINARY_SERIES;
+ if (REF(part))
+ flags |= AM_PART;
+ index = Modify_String(
+ action,
+ VAL_SERIES(value),
+ index,
+ arg,
+ flags,
+ len,
+ REF(dup) ? Int32(ARG(count)) : 1
+ );
+ ENSURE_SERIES_MANAGED(VAL_SERIES(value));
+ VAL_INDEX(value) = index;
+ break; }
+
+ //-- Search:
+ case SYM_SELECT_P:
+ case SYM_FIND: {
+ INCLUDE_PARAMS_OF_FIND;
+
+ UNUSED(PAR(series));
+ UNUSED(PAR(value));
+
+ REBFLGS flags = (
+ (REF(only) ? AM_FIND_ONLY : 0)
+ | (REF(match) ? AM_FIND_MATCH : 0)
+ | (REF(reverse) ? AM_FIND_REVERSE : 0)
+ | (REF(case) ? AM_FIND_CASE : 0)
+ | (REF(last) ? AM_FIND_LAST : 0)
+ | (REF(tail) ? AM_FIND_TAIL : 0)
+ );
+
+ REBINT len;
+ if (IS_BINARY(value)) {
+ flags |= AM_FIND_CASE;
+
+ if (!IS_BINARY(arg) && !IS_INTEGER(arg) && !IS_BITSET(arg))
+ fail (Error_Not_Same_Type_Raw());
+
+ if (IS_INTEGER(arg)) {
+ if (VAL_INT64(arg) < 0 || VAL_INT64(arg) > 255)
+ fail (Error_Out_Of_Range(arg));
+ len = 1;
+ }
+ }
+ else {
+ if (IS_CHAR(arg) || IS_BITSET(arg))
+ len = 1;
+ else if (!IS_STRING(arg)) {
+ //
+ // !! This FORM creates a temporary value that is then handed
+ // over to the GC. Not only could the temporary value be
+ // unmanaged (and freed), a more efficient matching could
+ // be done e.g. of `FIND "" ` without having
+ // to create an entire series just to include the delimiters.
+ //
+ REBSER *copy = Copy_Form_Value(arg, 0);
+ Init_String(arg, copy);
+ }
+ }
+
+ if (ANY_BINSTR(arg))
+ len = VAL_LEN_AT(arg);
+
+ if (REF(part))
+ tail = Partial(value, 0, ARG(limit));
+
+ REBCNT skip;
+ if (REF(skip))
+ skip = Partial(value, 0, ARG(size));
+ else
+ skip = 1;
+
+ REBCNT ret = find_string(
+ VAL_SERIES(value), index, tail, arg, len, flags, skip
+ );
+
+ if (ret >= (REBCNT)tail)
+ return R_BLANK;
+
+ if (REF(only))
+ len = 1;
+
+ if (action == SYM_FIND) {
+ if (REF(tail) || REF(match))
+ ret += len;
+ VAL_INDEX(value) = ret;
+ }
+ else {
+ ret++;
+ if (ret >= (REBCNT)tail) return R_BLANK;
+ if (IS_BINARY(value)) {
+ Init_Integer(value, *BIN_AT(VAL_SERIES(value), ret));
+ }
+ else
+ str_to_char(value, value, ret);
+ }
+ break; }
+
+ case SYM_TAKE_P: {
+ INCLUDE_PARAMS_OF_TAKE_P;
+
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(value));
+
+ UNUSED(PAR(series));
+
+ if (REF(deep))
+ fail (Error_Bad_Refines_Raw());
+
+ REBINT len;
+ if (REF(part)) {
+ len = Partial(value, 0, ARG(limit));
+ if (len == 0) {
+ Init_Any_Series(D_OUT, VAL_TYPE(value), Make_Binary(0));
+ return R_OUT;
+ }
+ } else
+ len = 1;
+
+ index = VAL_INDEX(value); // /PART can change index
+
+ if (REF(last))
+ index = tail - len;
+ if (index < 0 || index >= tail) {
+ if (NOT(REF(part)))
+ return R_BLANK;
+ Init_Any_Series(D_OUT, VAL_TYPE(value), Make_Binary(0));
+ return R_OUT;
+ }
+
+ ser = VAL_SERIES(value);
+
+ // if no /PART, just return value, else return string
+ //
+ if (NOT(REF(part))) {
+ if (IS_BINARY(value)) {
+ Init_Integer(value, *VAL_BIN_AT_HEAD(value, index));
+ } else
+ str_to_char(value, value, index);
+ }
+ else {
+ enum Reb_Kind kind = VAL_TYPE(value);
+ Init_Any_Series(
+ value, kind, Copy_String_Slimming(ser, index, len)
+ );
+ }
+ Remove_Series(ser, index, len);
+ break; }
+
+ case SYM_CLEAR: {
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(value));
+
+ if (index < tail) {
+ if (index == 0)
+ Reset_Sequence(VAL_SERIES(value));
+ else
+ TERM_SEQUENCE_LEN(VAL_SERIES(value), cast(REBCNT, index));
+ }
+ break; }
+
+ //-- Creation:
+
+ case SYM_COPY: {
+ INCLUDE_PARAMS_OF_COPY;
+
+ UNUSED(PAR(value));
+
+ if (REF(deep))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(types)) {
+ UNUSED(ARG(kinds));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ UNUSED(REF(part));
+ REBINT len = Partial(value, 0, ARG(limit)); // Can modify value index.
+ ser = Copy_String_Slimming(VAL_SERIES(value), VAL_INDEX(value), len);
+ goto return_ser; }
+
+ //-- Bitwise:
+
+ case SYM_AND_T:
+ case SYM_OR_T:
+ case SYM_XOR_T: {
+ if (NOT(IS_BINARY(arg)))
+ fail (arg);
+
+ if (VAL_INDEX(value) > VAL_LEN_HEAD(value))
+ VAL_INDEX(value) = VAL_LEN_HEAD(value);
+
+ if (VAL_INDEX(arg) > VAL_LEN_HEAD(arg))
+ VAL_INDEX(arg) = VAL_LEN_HEAD(arg);
+
+ ser = Xandor_Binary(action, value, arg);
+ goto return_ser; }
+
+ case SYM_COMPLEMENT: {
+ if (NOT(IS_BINARY(value)))
+ fail (value);
+
+ ser = Complement_Binary(value);
+ goto return_ser; }
+
+ // Arithmetic operations are allowed on BINARY!, because it's too limiting
+ // to not allow `#{4B} + 1` => `#{4C}`. Allowing the operations requires
+ // a default semantic of binaries as unsigned arithmetic, since one
+ // does not want `#{FF} + 1` to be #{FE}. It uses a big endian
+ // interpretation, so `#{00FF} + 1` is #{0100}
+ //
+ // Since Rebol is a language with mutable semantics by default, `add x y`
+ // will mutate x by default (if X is not an immediate type). `+` is an
+ // enfixing of `add-of` which copies the first argument before adding.
+ //
+ // To try and maximize usefulness, the semantic chosen is that any
+ // arithmetic that would go beyond the bounds of the length is considered
+ // an overflow. Hence the size of the result binary will equal the size
+ // of the original binary. This means that `#{0100} - 1` is #{00FF},
+ // not #{FF}.
+ //
+ // !!! The code below is extremely slow and crude--using an odometer-style
+ // loop to do the math. What's being done here is effectively "bigint"
+ // math, and it might be that it would share code with whatever big
+ // integer implementation was used; e.g. integers which exceeded the size
+ // of the platform REBI64 would use BINARY! under the hood.
+
+ case SYM_SUBTRACT:
+ case SYM_ADD: {
+ if (NOT(IS_BINARY(value)))
+ fail (value);
+
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(value));
+
+ REBINT amount;
+ if (IS_INTEGER(arg))
+ amount = VAL_INT32(arg);
+ else if (IS_BINARY(arg))
+ fail (arg); // should work
+ else
+ fail (arg); // what about other types?
+
+ if (action == SYM_SUBTRACT)
+ amount = -amount;
+
+ if (amount == 0) { // adding or subtracting 0 works, even #{} + 0
+ Move_Value(D_OUT, value);
+ return R_OUT;
+ }
+ else if (VAL_LEN_AT(value) == 0) // add/subtract to #{} otherwise
+ fail (Error_Overflow_Raw());
+
+ while (amount != 0) {
+ REBCNT wheel = VAL_LEN_HEAD(value) - 1;
+ while (TRUE) {
+ REBYTE *b = VAL_BIN_AT_HEAD(value, wheel);
+ if (amount > 0) {
+ if (*b == 255) {
+ if (wheel == VAL_INDEX(value))
+ fail (Error_Overflow_Raw());
+
+ *b = 0;
+ --wheel;
+ continue;
+ }
+ ++(*b);
+ --amount;
+ break;
+ }
+ else {
+ if (*b == 0) {
+ if (wheel == VAL_INDEX(value))
+ fail (Error_Overflow_Raw());
+
+ *b = 255;
+ --wheel;
+ continue;
+ }
+ --(*b);
+ ++amount;
+ break;
+ }
+ }
+ }
+ Move_Value(D_OUT, value);
+ return R_OUT; }
+
+ //-- Special actions:
+
+ case SYM_TRIM: {
+ INCLUDE_PARAMS_OF_TRIM;
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(value));
+
+ UNUSED(PAR(series));
+
+ ser = VAL_SERIES(value);
+
+ if (REF(all) || REF(with)) {
+ if (REF(head) || REF(tail) || REF(lines) || REF(auto))
+ fail (Error_Bad_Refines_Raw());
+
+ Whitespace_Replace_With(ser, index, tail, ARG(str));
+ }
+ else if (REF(auto)) {
+ if (REF(head) || REF(tail) || REF(lines) || REF(all) || REF(with))
+ fail (Error_Bad_Refines_Raw());
+
+ Trim_String_Auto(ser, index, tail);
+ }
+ else if (REF(lines)) {
+ Trim_String_Lines(ser, index, tail);
+ }
+ else {
+ Trim_String_Head_Tail(
+ ser,
+ index,
+ tail,
+ REF(head),
+ REF(tail)
+ );
+ }
+ break; }
+
+ case SYM_SWAP: {
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(value));
+
+ if (VAL_TYPE(value) != VAL_TYPE(arg))
+ fail (Error_Not_Same_Type_Raw());
+
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(arg));
+
+ if (index < tail && VAL_INDEX(arg) < VAL_LEN_HEAD(arg))
+ swap_chars(value, arg);
+ break; }
+
+ case SYM_REVERSE: {
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(value));
+
+ REBINT len = Partial(value, 0, D_ARG(3));
+ if (len > 0)
+ reverse_string(value, len);
+ break; }
+
+ case SYM_SORT: {
+ INCLUDE_PARAMS_OF_SORT;
+
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(value));
+
+ UNUSED(PAR(series));
+ UNUSED(REF(skip));
+ UNUSED(REF(compare));
+ UNUSED(REF(part));
+
+ if (REF(all)) {// Not Supported
+ fail (Error_Bad_Refine_Raw(ARG(all)));
+ }
+
+ Sort_String(
+ value,
+ REF(case),
+ ARG(size), // skip size (void if not /SKIP)
+ ARG(comparator), // (void if not /COMPARE)
+ ARG(limit), // (void if not /PART)
+ REF(reverse)
+ );
+ break; }
+
+ case SYM_RANDOM: {
+ INCLUDE_PARAMS_OF_RANDOM;
+
+ UNUSED(PAR(value));
+
+ FAIL_IF_READ_ONLY_SERIES(VAL_SERIES(value));
+
+ if (REF(seed)) {
+ //
+ // Use the string contents as a seed. R3-Alpha would try and
+ // treat it as byte-sized hence only take half the data into
+ // account if it were REBUNI-wide. This multiplies the number
+ // of bytes by the width and offsets by the size.
+ //
+ Set_Random(
+ Compute_CRC(
+ SER_AT_RAW(
+ SER_WIDE(VAL_SERIES(value)),
+ VAL_SERIES(value),
+ VAL_INDEX(value)
+ ),
+ VAL_LEN_AT(value) * SER_WIDE(VAL_SERIES(value))
+ )
+ );
+ return R_VOID;
+ }
+
+ if (REF(only)) {
+ if (index >= tail)
+ return R_BLANK;
+ index += (REBCNT)Random_Int(REF(secure)) % (tail - index);
+ if (IS_BINARY(value)) { // same as PICK
+ Init_Integer(D_OUT, *VAL_BIN_AT_HEAD(value, index));
+ }
+ else
+ str_to_char(D_OUT, value, index);
+ return R_OUT;
+ }
+ Shuffle_String(value, REF(secure));
+ break; }
+
+ default:
+ // Let the port system try the action, e.g. OPEN %foo.txt
+ //
+ if ((IS_FILE(value) || IS_URL(value)))
+ return T_Port(frame_, action);
+
+ fail (Error_Illegal_Action(VAL_TYPE(value), action));
+ }
+
+ Move_Value(D_OUT, value);
+ return R_OUT;
+
+return_ser:
+ Init_Any_Series(D_OUT, VAL_TYPE(value), ser);
+ return R_OUT;
}
-#endif
diff --git a/src/core/t-struct.c b/src/core/t-struct.c
new file mode 100644
index 0000000000..5106badb0a
--- /dev/null
+++ b/src/core/t-struct.c
@@ -0,0 +1,1611 @@
+//
+// File: %t-struct.c
+// Summary: "C struct object datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2014 Atronix Engineering, Inc.
+// Copyright 2014-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+
+#include "sys-core.h"
+
+
+// The managed HANDLE! for a ffi_type will have a reference in structs that
+// use it. Basic non-struct FFI_TYPE_XXX use the stock ffi_type_xxx pointers
+// that do not have to be freed, so they use simple HANDLE! which do not
+// register this cleanup hook.
+//
+static void cleanup_ffi_type(const REBVAL *v) {
+ ffi_type *fftype = VAL_HANDLE_POINTER(ffi_type, v);
+ if (fftype->type == FFI_TYPE_STRUCT)
+ OS_FREE(fftype->elements);
+ OS_FREE(fftype);
+}
+
+
+static void fail_if_non_accessible(const REBVAL *val)
+{
+ if (VAL_STRUCT_INACCESSIBLE(val)) {
+ DECLARE_LOCAL (i);
+ Init_Integer(i, cast(REBUPT, VAL_STRUCT_DATA_HEAD(val)));
+ fail (Error_Bad_Memory_Raw(i, val));
+ }
+}
+
+static void get_scalar(
+ REBVAL *out,
+ REBSTU *stu,
+ REBFLD *field,
+ REBCNT n // element index, starting from 0
+){
+ assert(n == 0 || FLD_IS_ARRAY(field));
+
+ REBCNT offset =
+ STU_OFFSET(stu) + FLD_OFFSET(field) + (n * FLD_WIDE(field));
+
+ if (FLD_IS_STRUCT(field)) {
+ //
+ // In order for the schema to participate in GC it must be a series.
+ // Currently this series is created with a single value of the root
+ // schema in the case of a struct expansion. This wouldn't be
+ // necessary if each field that was a structure offered a REBSER
+ // already... !!! ?? !!! ... it will be necessary if the schemas
+ // are to uniquely carry an ffi_type freed when they are GC'd
+ //
+ REBSTU *sub_stu = Alloc_Singular_Array();
+ SER(sub_stu)->link.schema = field;
+ REBVAL *single = SINK(ARR_HEAD(sub_stu));
+
+ // In this case the structure lives at an offset inside another.
+ //
+ // Note: The original code allowed this for STU_INACCESSIBLE(stu).
+ //
+ VAL_RESET_HEADER(single, REB_STRUCT);
+ MANAGE_ARRAY(sub_stu);
+ single->payload.structure.stu = sub_stu;
+
+ // The parent data may be a singular array for a HANDLE! or a BINARY!
+ // series, depending on whether the data is owned by Rebol or not.
+ // That series pointer is being referenced again here.
+ //
+ single->payload.structure.data =
+ ARR_HEAD(stu)->payload.structure.data;
+ single->extra.struct_offset = offset;
+
+ // With all fields initialized, assign canon value as result
+ //
+ Move_Value(out, single);
+ assert(VAL_STRUCT_SIZE(out) == FLD_WIDE(field));
+ return;
+ }
+
+ if (STU_INACCESSIBLE(stu)) {
+ //
+ // !!! This just gets void with no error...that seems like a bad idea,
+ // if the data is truly inaccessible.
+ //
+ Init_Void(out);
+ return;
+ }
+
+ REBYTE *p = offset + STU_DATA_HEAD(stu);
+
+ switch (FLD_TYPE_SYM(field)) {
+ case SYM_UINT8:
+ Init_Integer(out, *cast(u8*, p));
+ break;
+
+ case SYM_INT8:
+ Init_Integer(out, *cast(i8*, p));
+ break;
+
+ case SYM_UINT16:
+ Init_Integer(out, *cast(u16*, p));
+ break;
+
+ case SYM_INT16:
+ Init_Integer(out, *cast(i8*, p));
+ break;
+
+ case SYM_UINT32:
+ Init_Integer(out, *cast(u32*, p));
+ break;
+
+ case SYM_INT32:
+ Init_Integer(out, *cast(i32*, p));
+ break;
+
+ case SYM_UINT64:
+ Init_Integer(out, *cast(u64*, p));
+ break;
+
+ case SYM_INT64:
+ Init_Integer(out, *cast(i64*, p));
+ break;
+
+ case SYM_FLOAT:
+ Init_Decimal(out, *cast(float*, p));
+ break;
+
+ case SYM_DOUBLE:
+ Init_Decimal(out, *cast(double*, p));
+ break;
+
+ case SYM_POINTER:
+ Init_Integer(out, cast(REBUPT, *cast(void**, p)));
+ break;
+
+ case SYM_REBVAL:
+ Move_Value(out, cast(const REBVAL*, p));
+ break;
+
+ default:
+ assert(FALSE);
+ fail ("Unknown FFI type indicator");
+ }
+}
+
+
+//
+// Get_Struct_Var: C
+//
+static REBOOL Get_Struct_Var(REBVAL *out, REBSTU *stu, const REBVAL *word)
+{
+ REBARR *fieldlist = STU_FIELDLIST(stu);
+
+ RELVAL *item = ARR_HEAD(fieldlist);
+ for (; NOT_END(item); ++item) {
+ REBFLD *field = VAL_ARRAY(item);
+ if (STR_CANON(FLD_NAME(field)) != VAL_WORD_CANON(word))
+ continue;
+
+ if (FLD_IS_ARRAY(field)) {
+ //
+ // Structs contain packed data for the field type in an array.
+ // This data cannot expand or contract, and is not in a
+ // Rebol-compatible format. A Rebol Array is made by
+ // extracting the information.
+ //
+ // !!! Perhaps a fixed-size VECTOR! could have its data
+ // pointer into these arrays?
+ //
+ REBCNT dimension = FLD_DIMENSION(field);
+ REBARR *array = Make_Array(dimension);
+ REBCNT n;
+ for (n = 0; n < dimension; ++n) {
+ REBVAL *dest = SINK(ARR_AT(array, n));
+ get_scalar(dest, stu, field, n);
+ }
+ TERM_ARRAY_LEN(array, dimension);
+ Init_Block(out, array);
+ }
+ else
+ get_scalar(out, stu, field, 0);
+
+ return TRUE;
+ }
+
+ return FALSE; // word not found in struct's field symbols
+}
+
+
+//
+// Struct_To_Array: C
+//
+// Used by MOLD to create a block.
+//
+// Cannot fail(), because fail() could call MOLD on a struct!, which will end
+// up infinitive recursive calls.
+//
+REBARR *Struct_To_Array(REBSTU *stu)
+{
+ REBARR *fieldlist = STU_FIELDLIST(stu);
+ RELVAL *item = ARR_HEAD(fieldlist);
+
+ REBDSP dsp_orig = DSP;
+
+ // fail_if_non_accessible(STU_TO_VAL(stu));
+
+ for(; NOT_END(item); ++item) {
+ REBFLD *field = VAL_ARRAY(item);
+
+ DS_PUSH_TRASH;
+ Init_Set_Word(DS_TOP, FLD_NAME(field)); // required name
+
+ REBARR *typespec = Make_Array(2); // required type
+
+ if (FLD_IS_STRUCT(field)) {
+ Init_Word(Alloc_Tail_Array(typespec), Canon(SYM_STRUCT_X));
+
+ DECLARE_LOCAL (nested);
+ get_scalar(nested, stu, field, 0);
+
+ PUSH_GUARD_VALUE(nested); // is this guard still necessary?
+ Init_Block(
+ Alloc_Tail_Array(typespec),
+ Struct_To_Array(VAL_STRUCT(nested))
+ );
+ DROP_GUARD_VALUE(nested);
+ }
+ else {
+ // Elemental type (from a fixed list of known C types)
+ //
+ Init_Word(Alloc_Tail_Array(typespec), Canon(FLD_TYPE_SYM(field)));
+ }
+
+ // "optional dimension and initialization."
+ //
+ // !!! Comment said the initialization was optional, but it seems
+ // that the initialization always happens (?)
+ //
+ if (FLD_IS_ARRAY(field)) {
+ //
+ // Dimension becomes INTEGER! in a BLOCK! (to look like a C array)
+ //
+ REBCNT dimension = FLD_DIMENSION(field);
+ REBARR *one_int = Alloc_Singular_Array();
+ Init_Integer(ARR_HEAD(one_int), dimension);
+ Init_Block(Alloc_Tail_Array(typespec), one_int);
+
+ // Initialization seems to be just another block after that (?)
+ //
+ REBARR *init = Make_Array(dimension);
+ REBCNT n;
+ for (n = 0; n < dimension; n ++) {
+ REBVAL *dest = SINK(ARR_AT(init, n));
+ get_scalar(dest, stu, field, n);
+ }
+ TERM_ARRAY_LEN(init, dimension);
+ Init_Block(Alloc_Tail_Array(typespec), init);
+ }
+ else {
+ REBVAL *dest = Alloc_Tail_Array(typespec);
+ get_scalar(dest, stu, field, 0);
+ }
+
+ DS_PUSH_TRASH;
+ Init_Block(DS_TOP, typespec); // required type
+ }
+
+ return Pop_Stack_Values(dsp_orig);
+}
+
+
+static REBOOL same_fields(REBARR *tgt_fieldlist, REBARR *src_fieldlist)
+{
+ if (ARR_LEN(tgt_fieldlist) != ARR_LEN(src_fieldlist))
+ return FALSE;
+
+ RELVAL *tgt_item = ARR_HEAD(tgt_fieldlist);
+ RELVAL *src_item = ARR_HEAD(src_fieldlist);
+
+ for (; NOT_END(src_item); ++src_item, ++tgt_item) {
+ REBFLD *src_field = VAL_ARRAY(src_item);
+ REBFLD *tgt_field = VAL_ARRAY(tgt_item);
+
+ if (
+ FLD_IS_STRUCT(tgt_field) &&
+ !same_fields(FLD_FIELDLIST(tgt_field), FLD_FIELDLIST(src_field))
+ ){
+ return FALSE;
+ }
+
+ if (NOT(
+ SAME_SYM_NONZERO(
+ FLD_TYPE_SYM(tgt_field), FLD_TYPE_SYM(src_field)
+ )
+ )){
+ return FALSE;
+ }
+
+ if (FLD_IS_ARRAY(tgt_field)) {
+ if (!FLD_IS_ARRAY(src_field))
+ return FALSE;
+
+ if (FLD_DIMENSION(tgt_field) != FLD_DIMENSION(src_field))
+ return FALSE;
+ }
+
+ if (FLD_OFFSET(tgt_field) != FLD_OFFSET(src_field))
+ return FALSE;
+
+ assert(FLD_WIDE(tgt_field) == FLD_WIDE(src_field));
+ }
+
+ assert(IS_END(tgt_item));
+
+ return TRUE;
+}
+
+
+static REBOOL assign_scalar_core(
+ REBYTE *data_head,
+ REBCNT offset,
+ REBFLD *field,
+ REBCNT n,
+ const REBVAL *val
+){
+ assert(n == 0 || FLD_IS_ARRAY(field));
+
+ void *data = data_head +
+ offset + FLD_OFFSET(field) + (n * FLD_WIDE(field));
+
+ if (FLD_IS_STRUCT(field)) {
+ if (!IS_STRUCT(val))
+ fail (Error_Invalid_Type(VAL_TYPE(val)));
+
+ if (FLD_WIDE(field) != VAL_STRUCT_SIZE(val))
+ fail (val);
+
+ if (!same_fields(FLD_FIELDLIST(field), VAL_STRUCT_FIELDLIST(val)))
+ fail (val);
+
+ memcpy(data, VAL_STRUCT_DATA_AT(val), FLD_WIDE(field));
+
+ return TRUE;
+ }
+
+ // All other types take numbers
+
+ i64 i;
+ double d;
+
+ switch (VAL_TYPE(val)) {
+ case REB_DECIMAL:
+ d = VAL_DECIMAL(val);
+ i = cast(i64, d);
+ break;
+
+ case REB_INTEGER:
+ i = VAL_INT64(val);
+ d = cast(double, i);
+ break;
+
+ default:
+ fail (Error_Invalid_Type(VAL_TYPE(val)));
+ }
+
+ switch (FLD_TYPE_SYM(field)) {
+ case SYM_INT8:
+ if (i > 0x7f || i < -128)
+ fail (Error_Overflow_Raw());
+ *cast(i8*, data) = cast(i8, i);
+ break;
+
+ case SYM_UINT8:
+ if (i > 0xff || i < 0)
+ fail (Error_Overflow_Raw());
+ *cast(u8*, data) = cast(u8, i);
+ break;
+
+ case SYM_INT16:
+ if (i > 0x7fff || i < -0x8000)
+ fail (Error_Overflow_Raw());
+ *cast(i16*, data) = cast(i16, i);
+ break;
+
+ case SYM_UINT16:
+ if (i > 0xffff || i < 0)
+ fail (Error_Overflow_Raw());
+ *cast(u16*, data) = cast(u16, i);
+ break;
+
+ case SYM_INT32:
+ if (i > MAX_I32 || i < MIN_I32)
+ fail (Error_Overflow_Raw());
+ *cast(i32*, data) = cast(i32, i);
+ break;
+
+ case SYM_UINT32:
+ if (i > MAX_U32 || i < 0)
+ fail (Error_Overflow_Raw());
+ *cast(u32*, data) = cast(u32, i);
+ break;
+
+ case SYM_INT64:
+ *cast(i64*, data) = i;
+ break;
+
+ case SYM_UINT64:
+ if (i < 0)
+ fail (Error_Overflow_Raw());
+ *cast(u64*, data) = cast(u64, i);
+ break;
+
+ case SYM_FLOAT:
+ *cast(float*, data) = cast(float, d);
+ break;
+
+ case SYM_DOUBLE:
+ *cast(double*, data) = d;
+ break;
+
+ case SYM_POINTER:
+ if (sizeof(void*) == 4 && i > MAX_U32)
+ fail (Error_Overflow_Raw());
+ *cast(void**, data) = cast(void*, cast(REBUPT, i));
+ break;
+
+ case SYM_REBVAL:
+ //
+ // !!! This is a dangerous thing to be doing in generic structs, but
+ // for the main purpose of REBVAL (tunneling) it should be okay so
+ // long as the REBVAL* that is passed in is actually a pointer into
+ // a frame's args.
+ //
+ *cast(const REBVAL**, data) = val;
+ break;
+
+ default:
+ assert(FALSE);
+ return FALSE;
+ }
+
+ return TRUE;
+}
+
+
+inline static REBOOL assign_scalar(
+ REBSTU *stu,
+ REBFLD *field,
+ REBCNT n,
+ const REBVAL *val
+) {
+ return assign_scalar_core(
+ STU_DATA_HEAD(stu), STU_OFFSET(stu), field, n, val
+ );
+}
+
+
+//
+// Set_Struct_Var: C
+//
+static REBOOL Set_Struct_Var(
+ REBSTU *stu,
+ const REBVAL *word,
+ const REBVAL *elem,
+ const REBVAL *val
+) {
+ REBARR *fieldlist = STU_FIELDLIST(stu);
+ RELVAL *item = ARR_HEAD(fieldlist);
+
+ for (; NOT_END(item); ++item) {
+ REBFLD *field = VAL_ARRAY(item);
+
+ if (VAL_WORD_CANON(word) != STR_CANON(FLD_NAME(field)))
+ continue;
+
+ if (FLD_IS_ARRAY(field)) {
+ if (elem == NULL) { // set the whole array
+ if (!IS_BLOCK(val))
+ return FALSE;
+
+ REBCNT dimension = FLD_DIMENSION(field);
+ if (dimension != VAL_LEN_AT(val))
+ return FALSE;
+
+ REBCNT n = 0;
+ for(n = 0; n < dimension; ++n) {
+ if (!assign_scalar(
+ stu, field, n, KNOWN(VAL_ARRAY_AT_HEAD(val, n))
+ )) {
+ return FALSE;
+ }
+ }
+ }
+ else { // set only one element
+ if (!IS_INTEGER(elem) || VAL_INT32(elem) != 1)
+ return FALSE;
+
+ return assign_scalar(stu, field, 0, val);
+ }
+ return TRUE;
+ }
+
+ return assign_scalar(stu, field, 0, val);
+ }
+
+ return FALSE;
+}
+
+
+/* parse struct attribute */
+static void parse_attr (REBVAL *blk, REBINT *raw_size, REBUPT *raw_addr)
+{
+ REBVAL *attr = KNOWN(VAL_ARRAY_AT(blk));
+
+ *raw_size = -1;
+ *raw_addr = 0;
+
+ while (NOT_END(attr)) {
+ if (NOT(IS_SET_WORD(attr)))
+ fail (attr);
+
+ switch (VAL_WORD_SYM(attr)) {
+ case SYM_RAW_SIZE:
+ ++ attr;
+ if (NOT_END(attr) && IS_INTEGER(attr)) {
+ if (*raw_size > 0)
+ fail ("FFI: duplicate raw size");
+
+ *raw_size = VAL_INT64(attr);
+ if (*raw_size <= 0)
+ fail ("FFI: raw size cannot be zero");
+ }
+ else
+ fail (attr);
+ break;
+
+ case SYM_RAW_MEMORY:
+ ++ attr;
+ if (NOT_END(attr) && IS_INTEGER(attr)) {
+ if (*raw_addr != 0)
+ fail ("FFI: duplicate raw memory");
+
+ *raw_addr = cast(REBU64, VAL_INT64(attr));
+ if (*raw_addr == 0)
+ fail ("FFI: void pointer illegal for raw memory");
+ }
+ else
+ fail (attr);
+ break;
+
+ case SYM_EXTERN: {
+ ++ attr;
+
+ if (*raw_addr != 0)
+ fail ("FFI: raw memory is exclusive with extern");
+
+ if (IS_END(attr) || NOT(IS_BLOCK(attr)) || VAL_LEN_AT(attr) != 2)
+ fail (attr);
+
+ REBVAL *lib = KNOWN(VAL_ARRAY_AT_HEAD(attr, 0));
+ if (NOT(IS_LIBRARY(lib)))
+ fail (attr);
+ if (IS_LIB_CLOSED(VAL_LIBRARY(lib)))
+ fail (Error_Bad_Library_Raw());
+
+ REBVAL *sym = KNOWN(VAL_ARRAY_AT_HEAD(attr, 1));
+ if (NOT(ANY_BINSTR(sym)))
+ fail (sym);
+
+ CFUNC *addr = OS_FIND_FUNCTION(
+ VAL_LIBRARY_FD(lib),
+ s_cast(VAL_RAW_DATA_AT(sym))
+ );
+ if (addr == NULL)
+ fail (Error_Symbol_Not_Found_Raw(sym));
+
+ *raw_addr = cast(REBUPT, addr);
+ break; }
+
+ // !!! This alignment code was commented out for some reason.
+ /*
+ case SYM_ALIGNMENT:
+ ++ attr;
+ if (!IS_INTEGER(attr))
+ fail (attr);
+
+ alignment = VAL_INT64(attr);
+ break;
+ */
+
+ default:
+ fail (attr);
+ }
+
+ ++ attr;
+ }
+}
+
+
+// The managed handle logic always assumes a cleanup function, so it doesn't
+// have to test for NULL.
+//
+static void cleanup_noop(const REBVAL *v) {
+#ifdef NDEBUG
+ UNUSED(v);
+#else
+ assert(IS_HANDLE(v));
+#endif
+}
+
+
+//
+// set storage memory to external addr: raw_addr
+//
+// "External Storage" is the idea that a STRUCT! which is modeling a C
+// struct doesn't use a BINARY! series as the backing store, rather a pointer
+// that is external to the system. When Atronix added the FFI initially,
+// this was done by creating a separate type of REBSER that could use an
+// external pointer. This uses a managed HANDLE! for the same purpose, as
+// a less invasive way of doing the same thing.
+//
+static REBSER *make_ext_storage(
+ REBCNT len,
+ REBINT raw_size,
+ REBUPT raw_addr
+) {
+ if (raw_size >= 0 && raw_size != cast(REBINT, len)) {
+ DECLARE_LOCAL (i);
+ Init_Integer(i, raw_size);
+ fail (Error_Invalid_Data_Raw(i));
+ }
+
+ DECLARE_LOCAL (handle);
+ Init_Handle_Managed(handle, cast(REBYTE*, raw_addr), len, &cleanup_noop);
+
+ return SER(handle->extra.singular);
+}
+
+
+//
+// Total_Struct_Dimensionality: C
+//
+// This recursively counts the total number of data elements inside of a
+// struct. This includes for instance every array element inside a
+// nested struct's field, along with its fields.
+//
+// !!! Is this really how char[1000] would be handled in the FFI? By
+// creating 1000 ffi_types? :-/
+//
+static REBCNT Total_Struct_Dimensionality(REBARR *fields)
+{
+ REBCNT n_fields = 0;
+
+ RELVAL *item = ARR_HEAD(fields);
+ for (; NOT_END(item); ++item) {
+ REBFLD *field = VAL_ARRAY(item);
+
+ if (FLD_IS_STRUCT(field))
+ n_fields += Total_Struct_Dimensionality(FLD_FIELDLIST(field));
+ else
+ n_fields += FLD_IS_ARRAY(field) ? FLD_DIMENSION(field) : 1;
+ }
+ return n_fields;
+}
+
+
+//
+// Prepare_Field_For_FFI: C
+//
+// The main reason structs exist is so that they can be used with the FFI,
+// and the FFI requires you to set up a "ffi_type" C struct describing
+// each datatype. This is a helper function that sets up proper ffi_type.
+// There are stock types for the primitives, but each structure needs its
+// own.
+//
+static void Prepare_Field_For_FFI(REBFLD *schema)
+{
+ assert(IS_UNREADABLE_IF_DEBUG(FLD_AT(schema, IDX_FIELD_FFTYPE)));
+
+ ffi_type *fftype;
+
+ if (!FLD_IS_STRUCT(schema)) {
+ fftype = Get_FFType_For_Sym(FLD_TYPE_SYM(schema));
+ assert(fftype != NULL);
+
+ // The FFType pointers returned by Get_FFType_For_Sym should not be
+ // freed, so a "simple" handle is used that just holds the pointer.
+ //
+ Init_Handle_Simple(FLD_AT(schema, IDX_FIELD_FFTYPE), fftype, 0);
+ return;
+ }
+
+ // For struct fields--on the other hand--it's necessary to do a custom
+ // allocation for a new type registered with the FFI.
+ //
+ fftype = OS_ALLOC(ffi_type);
+ fftype->type = FFI_TYPE_STRUCT;
+
+ // "This is set by libffi; you should initialize it to zero."
+ // http://www.atmark-techno.com/~yashi/libffi.html#Structures
+ //
+ fftype->size = 0;
+ fftype->alignment = 0;
+
+ REBARR *fieldlist = FLD_FIELDLIST(schema);
+
+ REBCNT dimensionality = Total_Struct_Dimensionality(fieldlist);
+ fftype->elements = OS_ALLOC_N(ffi_type*, dimensionality + 1); // NULL term
+
+ RELVAL *item = ARR_HEAD(fieldlist);
+
+ REBCNT j = 0;
+ for (; NOT_END(item); ++item) {
+ REBFLD *field = VAL_ARRAY(item);
+ REBCNT dimension = FLD_IS_ARRAY(field) ? FLD_DIMENSION(field) : 1;
+
+ REBCNT n = 0;
+ for (n = 0; n < dimension; ++n)
+ fftype->elements[j++] = FLD_FFTYPE(field);
+ }
+
+ fftype->elements[j] = NULL;
+
+ Init_Handle_Managed(
+ FLD_AT(schema, IDX_FIELD_FFTYPE),
+ fftype,
+ dimensionality + 1,
+ &cleanup_ffi_type
+ );
+}
+
+
+//
+// This takes a spec like `[int32 [2]]` and sets the output field's properties
+// by recognizing a finite set of FFI type keywords defined in %words.r.
+//
+// This also allows for embedded structure types. If the type is not being
+// included by reference, but rather with a sub-definition inline, then it
+// will actually be creating a new `inner` STRUCT! value. Since this value
+// is managed and not referred to elsewhere, there can't be evaluations.
+//
+static void Parse_Field_Type_May_Fail(
+ REBFLD *field,
+ REBVAL *spec,
+ REBVAL *inner // will be set only if STRUCT!
+){
+ TRASH_CELL_IF_DEBUG(inner);
+
+ RELVAL *val = VAL_ARRAY_AT(spec);
+
+ if (IS_END(val))
+ fail ("Empty field type in FFI");
+
+ if (IS_WORD(val)) {
+ REBSYM sym = VAL_WORD_SYM(val);
+
+ // Initialize the type symbol with the unbound word by default (will
+ // be overwritten in the struct cases).
+ //
+ Init_Word(FLD_AT(field, IDX_FIELD_TYPE), Canon(sym));
+
+ switch (sym) {
+ case SYM_UINT8:
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), 1);
+ Prepare_Field_For_FFI(field);
+ break;
+
+ case SYM_INT8:
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), 1);
+ Prepare_Field_For_FFI(field);
+ break;
+
+ case SYM_UINT16:
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), 2);
+ Prepare_Field_For_FFI(field);
+ break;
+
+ case SYM_INT16:
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), 2);
+ Prepare_Field_For_FFI(field);
+ break;
+
+ case SYM_UINT32:
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), 4);
+ Prepare_Field_For_FFI(field);
+ break;
+
+ case SYM_INT32:
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), 4);
+ Prepare_Field_For_FFI(field);
+ break;
+
+ case SYM_UINT64:
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), 8);
+ Prepare_Field_For_FFI(field);
+ break;
+
+ case SYM_INT64:
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), 8);
+ Prepare_Field_For_FFI(field);
+ break;
+
+ case SYM_FLOAT:
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), 4);
+ Prepare_Field_For_FFI(field);
+ break;
+
+ case SYM_DOUBLE:
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), 8);
+ Prepare_Field_For_FFI(field);
+ break;
+
+ case SYM_POINTER:
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), sizeof(void*));
+ Prepare_Field_For_FFI(field);
+ break;
+
+ case SYM_STRUCT_X: {
+ ++ val;
+ if (!IS_BLOCK(val))
+ fail (Error_Unexpected_Type(REB_BLOCK, VAL_TYPE(val)));
+
+ DECLARE_LOCAL (specified);
+ Derelativize(specified, val, VAL_SPECIFIER(spec));
+ MAKE_Struct(inner, REB_STRUCT, specified); // may fail()
+
+ Init_Integer(
+ FLD_AT(field, IDX_FIELD_WIDE),
+ VAL_STRUCT_DATA_LEN(inner)
+ );
+ Init_Block(
+ FLD_AT(field, IDX_FIELD_TYPE),
+ VAL_STRUCT_FIELDLIST(inner)
+ );
+
+ // Borrow the same ffi_type* that was built for the inner struct
+ // (What about just storing the STRUCT! value itself in the type
+ // field, instead of the array of fields?)
+ //
+ Move_Value(
+ FLD_AT(field, IDX_FIELD_FFTYPE),
+ FLD_AT(VAL_STRUCT_SCHEMA(inner), IDX_FIELD_FFTYPE)
+ );
+ break; }
+
+ case SYM_REBVAL: {
+ //
+ // While most data types have some kind of proxying of when you
+ // pass a Rebol value in (such as turning an INTEGER! into bits
+ // for a C `int`) if the argument is marked as being a REBVAL
+ // then the VAL_TYPE is ignored, and it acts like a pointer to
+ // the actual argument in the frame...whatever that may be.
+ //
+ // !!! The initial FFI implementation from Atronix would actually
+ // store sizeof(REBVAL) in the struct, not sizeof(REBVAL*). The
+ // struct's binary data was then hooked into the garbage collector
+ // to make sure that cell was marked. Because the intended use
+ // of the feature is "tunneling" a value from a routine's frame
+ // to a callback's frame, the lifetime of the REBVAL* should last
+ // for the entirety of the routine it was passed to.
+ //
+ Init_Integer(FLD_AT(field, IDX_FIELD_WIDE), sizeof(REBVAL*));
+ Prepare_Field_For_FFI(field);
+ break; }
+
+ default:
+ fail (Error_Invalid_Type(VAL_TYPE(val)));
+ }
+ }
+ else if (IS_STRUCT(val)) {
+ //
+ // [b: [struct-a] val-a]
+ //
+ Init_Integer(
+ FLD_AT(field, IDX_FIELD_WIDE),
+ VAL_STRUCT_DATA_LEN(val)
+ );
+ Init_Block(
+ FLD_AT(field, IDX_FIELD_TYPE),
+ VAL_STRUCT_FIELDLIST(val)
+ );
+
+ // Borrow the same ffi_type* that the struct uses, see above note
+ // regarding alternative ideas.
+ //
+ Move_Value(
+ FLD_AT(field, IDX_FIELD_FFTYPE),
+ FLD_AT(VAL_STRUCT_SCHEMA(val), IDX_FIELD_FFTYPE)
+ );
+ Derelativize(inner, val, VAL_SPECIFIER(spec));
+ }
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(val)));
+
+ ++ val;
+
+ // Find out the array dimension (if there is one)
+ //
+ if (IS_END(val)) {
+ Init_Blank(FLD_AT(field, IDX_FIELD_DIMENSION)); // scalar
+ }
+ else if (IS_BLOCK(val)) {
+ //
+ // make struct! [a: [int32 [2]] [0 0]]
+ //
+ DECLARE_LOCAL (ret);
+ if (Do_At_Throws(
+ ret,
+ VAL_ARRAY(val),
+ VAL_INDEX(val),
+ VAL_SPECIFIER(spec)
+ )) {
+ // !!! Does not check for thrown cases...what should this
+ // do in case of THROW, BREAK, QUIT?
+ fail (Error_No_Catch_For_Throw(ret));
+ }
+
+ if (!IS_INTEGER(ret))
+ fail (Error_Unexpected_Type(REB_INTEGER, VAL_TYPE(val)));
+
+ Init_Integer(FLD_AT(field, IDX_FIELD_DIMENSION), VAL_INT64(ret));
+ ++ val;
+ }
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(val)));
+}
+
+
+//
+// Init_Struct_Fields: C
+//
+// a: make struct! [uint 8 i: 1]
+// b: make a [i: 10]
+//
+void Init_Struct_Fields(REBVAL *ret, REBVAL *spec)
+{
+ REBVAL *blk = NULL;
+
+ for (blk = KNOWN(VAL_ARRAY_AT(spec)); NOT_END(blk); blk += 2) {
+ REBVAL *word = blk;
+ REBVAL *fld_val = blk + 1;
+
+ if (IS_BLOCK(word)) { // options: raw-memory, etc
+ REBINT raw_size = -1;
+ REBUPT raw_addr = 0;
+
+ // make sure no other field initialization
+ if (VAL_LEN_HEAD(spec) != 1)
+ fail (spec);
+
+ parse_attr(word, &raw_size, &raw_addr);
+ ret->payload.structure.data
+ = make_ext_storage(VAL_STRUCT_SIZE(ret), raw_size, raw_addr);
+
+ break;
+ }
+ else if (NOT(IS_SET_WORD(word)))
+ fail (word);
+
+ if (IS_END(fld_val))
+ fail (Error_Need_Value_Raw(fld_val));
+
+ REBARR *fieldlist = VAL_STRUCT_FIELDLIST(ret);
+ RELVAL *item = ARR_HEAD(fieldlist);
+
+ for (; NOT_END(item); ++item) {
+ REBFLD *field = VAL_ARRAY(item);
+
+ if (STR_CANON(FLD_NAME(field)) != VAL_WORD_CANON(word))
+ continue;
+
+ if (FLD_IS_ARRAY(field)) {
+ if (IS_BLOCK(fld_val)) {
+ REBCNT dimension = FLD_DIMENSION(field);
+
+ if (VAL_LEN_AT(fld_val) != dimension)
+ fail (fld_val);
+
+ REBCNT n = 0;
+ for (n = 0; n < dimension; ++n) {
+ if (NOT(assign_scalar(
+ VAL_STRUCT(ret),
+ field,
+ n,
+ KNOWN(VAL_ARRAY_AT_HEAD(fld_val, n))
+ ))) {
+ fail (fld_val);
+ }
+ }
+ }
+ else if (IS_INTEGER(fld_val)) { // interpret as a data pointer
+ void *ptr = cast(void *,
+ cast(REBUPT, VAL_INT64(fld_val))
+ );
+
+ // assuming valid pointer to enough space
+ memcpy(
+ VAL_STRUCT_DATA_HEAD(ret) + FLD_OFFSET(field),
+ ptr,
+ FLD_LEN_BYTES_TOTAL(field)
+ );
+ }
+ else
+ fail (fld_val);
+ }
+ else {
+ if (NOT(assign_scalar(VAL_STRUCT(ret), field, 0, fld_val)))
+ fail (fld_val);
+ }
+ return;
+ }
+
+ fail ("FFI: field not in the parent struct");
+ }
+}
+
+
+//
+// MAKE_Struct: C
+//
+// Format:
+// make struct! [
+// field1 [type1]
+// field2: [type2] field2-init-value
+// field3: [struct [field1 [type1]]]
+// field4: [type1[3]]
+// ...
+// ]
+//
+void MAKE_Struct(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg) {
+ assert(kind == REB_STRUCT);
+ UNUSED(kind);
+
+ if (NOT(IS_BLOCK(arg)))
+ fail (arg);
+
+ REBINT max_fields = 16;
+
+//
+// SET UP SCHEMA
+//
+ // Every struct has a "schema"--this is a description (potentially
+ // hierarchical) of its fields, including any nested structs. The
+ // schema should be shared between common instances of the same struct.
+ //
+ REBFLD *schema = Make_Array(IDX_FIELD_MAX);
+ Init_Blank(FLD_AT(schema, IDX_FIELD_NAME)); // no symbol for struct itself
+ // we'll be filling in the IDX_FIELD_TYPE slot with an array of fields
+ Init_Blank(FLD_AT(schema, IDX_FIELD_DIMENSION)); // not an array
+
+ SET_UNREADABLE_BLANK(FLD_AT(schema, IDX_FIELD_FFTYPE));
+
+ Init_Blank(FLD_AT(schema, IDX_FIELD_OFFSET)); // the offset is not used
+ // we'll be filling in the IDX_FIELD_WIDE at the end.
+
+
+//
+// PROCESS FIELDS
+//
+
+ u64 offset = 0; // offset in data
+
+ REBINT raw_size = -1;
+ REBUPT raw_addr = 0;
+
+ DECLARE_LOCAL (specified);
+
+ RELVAL *item = VAL_ARRAY_AT(arg);
+ if (NOT_END(item) && IS_BLOCK(item)) {
+ //
+ // !!! This would suggest raw-size, raw-addr, or extern can be leading
+ // in the struct definition, perhaps as:
+ //
+ // make struct! [[raw-size] ...]
+ //
+ Derelativize(specified, item, VAL_SPECIFIER(arg));
+ parse_attr(specified, &raw_size, &raw_addr);
+ ++item;
+ }
+
+ // !!! This makes binary data for each struct level? ???
+ //
+ REBSER *data_bin;
+ if (raw_addr == 0)
+ data_bin = Make_Binary(max_fields << 2);
+ else
+ data_bin = NULL; // not used, but avoid maybe uninitialized warning
+
+ REBINT field_idx = 0; // for field index
+ REBIXO eval_idx = 0; // for spec block evaluation
+
+ REBDSP dsp_orig = DSP; // use data stack to accumulate fields (BLOCK!s)
+
+ DECLARE_LOCAL (spec);
+ DECLARE_LOCAL (init); // for result to save in data
+
+ while (NOT_END(item)) {
+
+ // Add another field...
+
+ REBFLD *field = Make_Array(IDX_FIELD_MAX);
+
+ SET_UNREADABLE_BLANK(FLD_AT(field, IDX_FIELD_FFTYPE));
+ Init_Integer(FLD_AT(field, IDX_FIELD_OFFSET), offset);
+
+ // Must be a word or a set-word, with set-words initializing
+
+ REBOOL expect_init;
+ if (IS_SET_WORD(item)) {
+ expect_init = TRUE;
+ if (raw_addr) {
+ // initialization is not allowed for raw memory struct
+ fail (Error_Invalid_Arg_Core(item, VAL_SPECIFIER(arg)));
+ }
+ }
+ else if (IS_WORD(item))
+ expect_init = FALSE;
+ else
+ fail (Error_Invalid_Type(VAL_TYPE(item)));
+
+ Init_Word(FLD_AT(field, IDX_FIELD_NAME), VAL_WORD_SPELLING(item));
+
+ ++item;
+ if (IS_END(item) || !IS_BLOCK(item))
+ fail (Error_Invalid_Arg_Core(item, VAL_SPECIFIER(arg)));
+
+ Derelativize(spec, item, VAL_SPECIFIER(arg));
+
+ // Fills in the width, dimension, type, and ffi_type (if needed)
+ //
+ Parse_Field_Type_May_Fail(field, spec, init);
+
+ REBCNT dimension = FLD_IS_ARRAY(field) ? FLD_DIMENSION(field) : 1;
+ ++item;
+
+ // !!! Why does the fail take out as an argument? (Copied from below)
+
+ if (FLD_WIDE(field) > MAX_U32)
+ fail (Error_Size_Limit_Raw(out));
+ if (dimension > MAX_U32)
+ fail (Error_Size_Limit_Raw(out));
+
+ u64 step = cast(u64, FLD_WIDE(field)) * cast(u64, dimension);
+
+ if (step > VAL_STRUCT_LIMIT)
+ fail (Error_Size_Limit_Raw(out));
+
+ if (raw_addr == 0)
+ EXPAND_SERIES_TAIL(data_bin, step);
+
+ if (expect_init) {
+ if (IS_END(item))
+ fail (arg);
+
+ if (IS_BLOCK(item)) {
+ Derelativize(specified, item, VAL_SPECIFIER(arg));
+
+ if (Reduce_Any_Array_Throws(
+ init, specified, REDUCE_FLAG_DROP_BARS
+ )){
+ fail (Error_No_Catch_For_Throw(init));
+ }
+
+ ++item;
+ }
+ else {
+ eval_idx = DO_NEXT_MAY_THROW(
+ init,
+ VAL_ARRAY(arg),
+ item - VAL_ARRAY_AT(arg),
+ VAL_SPECIFIER(arg)
+ );
+ if (eval_idx == THROWN_FLAG)
+ fail (Error_No_Catch_For_Throw(init));
+
+ if (eval_idx == END_FLAG)
+ item = VAL_ARRAY_TAIL(arg);
+ else
+ item = VAL_ARRAY_AT_HEAD(item, cast(REBCNT, eval_idx));
+ }
+
+ if (FLD_IS_ARRAY(field)) {
+ if (IS_INTEGER(init)) { // interpreted as a C pointer
+ void *ptr = cast(void *, cast(REBUPT, VAL_INT64(init)));
+
+ // assume valid pointer to enough space
+ memcpy(
+ SER_AT(REBYTE, data_bin, cast(REBCNT, offset)),
+ ptr,
+ FLD_LEN_BYTES_TOTAL(field)
+ );
+ }
+ else if (IS_BLOCK(init)) {
+ REBCNT n = 0;
+
+ if (VAL_LEN_AT(init) != FLD_DIMENSION(field))
+ fail (init);
+
+ // assign
+ for (n = 0; n < FLD_DIMENSION(field); n ++) {
+ if (!assign_scalar_core(
+ BIN_HEAD(data_bin),
+ offset,
+ field,
+ n,
+ KNOWN(VAL_ARRAY_AT_HEAD(init, n))
+ )) {
+ fail ("FFI: Failed to assign element value");
+ }
+ }
+ }
+ else
+ fail (Error_Unexpected_Type(REB_BLOCK, VAL_TYPE(item)));
+ }
+ else {
+ // scalar
+ if (!assign_scalar_core(
+ BIN_HEAD(data_bin), offset, field, 0, init
+ )) {
+ fail ("FFI: Failed to assign scalar value");
+ }
+ }
+ }
+ else if (raw_addr == 0) {
+ if (FLD_IS_STRUCT(field)) {
+ REBCNT n = 0;
+ for (n = 0; n < FLD_DIMENSION(field); n ++) {
+ memcpy(
+ SER_AT(
+ REBYTE,
+ data_bin,
+ cast(REBCNT, offset) + (n * FLD_WIDE(field))
+ ),
+ VAL_STRUCT_DATA_HEAD(init),
+ FLD_WIDE(field)
+ );
+ }
+ }
+ else {
+ memset(
+ SER_AT(REBYTE, data_bin, cast(REBCNT, offset)),
+ 0,
+ FLD_LEN_BYTES_TOTAL(field)
+ );
+ }
+ }
+
+ offset += step;
+
+ //if (alignment != 0) {
+ // offset = ((offset + alignment - 1) / alignment) * alignment;
+
+ if (offset > VAL_STRUCT_LIMIT)
+ fail (Error_Size_Limit_Raw(out));
+
+ ++ field_idx;
+
+ TERM_ARRAY_LEN(field, 6);
+ ASSERT_ARRAY(field);
+
+ DS_PUSH_TRASH;
+ Init_Block(DS_TOP, field); // really should be an OBJECT!
+ }
+
+ REBARR *fieldlist = Pop_Stack_Values(dsp_orig);
+ ASSERT_ARRAY(fieldlist);
+
+ Init_Block(FLD_AT(schema, IDX_FIELD_TYPE), fieldlist);
+ Prepare_Field_For_FFI(schema);
+
+ Init_Integer(FLD_AT(schema, IDX_FIELD_WIDE), offset); // total size known
+
+ TERM_ARRAY_LEN(schema, IDX_FIELD_MAX);
+ ASSERT_ARRAY(schema);
+
+//
+// FINALIZE VALUE
+//
+
+ REBSTU *stu = Alloc_Singular_Array();
+
+ // Set it to blank so the Kill_Series can be called upon in case of error
+ // thrown before it is fully constructed.
+ //
+ Init_Blank(ARR_HEAD(stu));
+
+ MANAGE_ARRAY(schema);
+ SER(stu)->link.schema = schema;
+
+ VAL_RESET_HEADER(out, REB_STRUCT);
+ out->payload.structure.stu = stu;
+ if (raw_addr) {
+ out->payload.structure.data
+ = make_ext_storage(
+ FLD_LEN_BYTES_TOTAL(schema), raw_size, raw_addr
+ );
+ }
+ else {
+ MANAGE_SERIES(data_bin);
+ out->payload.structure.data = data_bin;
+ }
+ out->extra.struct_offset = 0;
+
+ *ARR_HEAD(stu) = *out;
+ MANAGE_ARRAY(stu);
+}
+
+
+//
+// TO_Struct: C
+//
+void TO_Struct(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ MAKE_Struct(out, kind, arg);
+}
+
+
+//
+// PD_Struct: C
+//
+REBINT PD_Struct(REBPVS *pvs)
+{
+ REBSTU *stu = VAL_STRUCT(pvs->value);
+ if (!IS_WORD(pvs->picker))
+ fail (Error_Bad_Path_Select(pvs));
+
+ fail_if_non_accessible(KNOWN(pvs->value));
+
+ if (!pvs->opt_setval || NOT_END(pvs->item + 1)) {
+ if (NOT(Get_Struct_Var(pvs->store, stu, pvs->picker)))
+ fail (Error_Bad_Path_Select(pvs));
+
+ // !!! Comment here said "Setting element to an array in the struct"
+ // and gave the example `struct/field/1: 0`. What is thus happening
+ // here is that the ordinary SET-PATH! dispatch which goes one step
+ // at a time can't work to update something whose storage is not
+ // a REBVAL*. So (struct/field) produces a temporary BLOCK! out of
+ // the C array data, and if the set just sets an element in that
+ // block then it will be forgotten and have no effect.
+ //
+ // So the workaround is to bypass ordinary dispatch and call it to
+ // look ahead manually by one step. Whatever change is made to
+ // the block is then turned around and re-set in the underlying
+ // memory that produced it.
+ //
+ // A better general mechanism for this kind of problem is needed,
+ // although it only affects "extension types" which use natively
+ // packed structures to store their state instead of REBVAL. (See
+ // a similar technique used by PD_Gob)
+ //
+ if (
+ pvs->opt_setval
+ && IS_BLOCK(pvs->store)
+ && IS_END(pvs->item + 2)
+ ) {
+ // !!! This is dodgy; it has to copy (as picker is a pointer to
+ // a memory cell it may not own), has to guard (as the next path
+ // evaluation may not protect the result...)
+ //
+ DECLARE_LOCAL (sel_orig);
+ Move_Value(sel_orig, pvs->picker);
+ PUSH_GUARD_VALUE(sel_orig);
+
+ pvs->value = pvs->store;
+ pvs->value_specifier = SPECIFIED;
+
+ if (Next_Path_Throws(pvs)) { // updates pvs->store, pvs->picker
+ DROP_GUARD_VALUE(sel_orig);
+ fail (Error_No_Catch_For_Throw(pvs->store)); // !!! Review
+ }
+
+ DECLARE_LOCAL (specific);
+ Derelativize(specific, pvs->value, pvs->value_specifier);
+
+ if (!Set_Struct_Var(stu, sel_orig, pvs->picker, specific))
+ fail (Error_Bad_Path_Set(pvs));
+
+ DROP_GUARD_VALUE(sel_orig);
+
+ return PE_OK;
+ }
+
+ return PE_USE_STORE;
+ }
+ else {
+ // setting (because opt_setval is non-NULL, and at end of path)
+
+ if (!Set_Struct_Var(stu, pvs->picker, NULL, pvs->opt_setval))
+ fail (Error_Bad_Path_Set(pvs));
+
+ return PE_OK;
+ }
+
+ fail (Error_Bad_Path_Select(pvs));
+}
+
+
+//
+// Cmp_Struct: C
+//
+REBINT Cmp_Struct(const RELVAL *s, const RELVAL *t)
+{
+ REBINT n = VAL_STRUCT_FIELDLIST(s) - VAL_STRUCT_FIELDLIST(t);
+ fail_if_non_accessible(const_KNOWN(s));
+ fail_if_non_accessible(const_KNOWN(t));
+ if (n != 0) {
+ return n;
+ }
+ n = VAL_STRUCT(s) - VAL_STRUCT(t);
+ return n;
+}
+
+
+//
+// CT_Struct: C
+//
+REBINT CT_Struct(const RELVAL *a, const RELVAL *b, REBINT mode)
+{
+ switch (mode) {
+ case 1: // strict equality
+ return 0 == Cmp_Struct(a, b);
+
+ case 0: // coerced equality
+ if (Cmp_Struct(a, b) == 0)
+ return 1;
+
+ return (
+ IS_STRUCT(a) && IS_STRUCT(b)
+ && same_fields(VAL_STRUCT_FIELDLIST(a), VAL_STRUCT_FIELDLIST(b))
+ && VAL_STRUCT_SIZE(a) == VAL_STRUCT_SIZE(b)
+ && !memcmp(
+ VAL_STRUCT_DATA_HEAD(a),
+ VAL_STRUCT_DATA_HEAD(b),
+ VAL_STRUCT_SIZE(a)
+ )
+ );
+
+ default:
+ return -1;
+ }
+ return -1;
+}
+
+
+//
+// Copy_Struct_Managed: C
+//
+REBSTU *Copy_Struct_Managed(REBSTU *src)
+{
+ fail_if_non_accessible(STU_VALUE(src));
+
+ assert(ARR_LEN(src) == 1);
+ assert(IS_STRUCT(ARR_AT(src, 0)));
+
+ // This doesn't copy the data out of the array, or the schema...just the
+ // value. In fact, the schema is in the misc field and has to just be
+ // linked manually.
+ //
+ REBSTU *copy = Copy_Array_Shallow(src, SPECIFIED);
+ SER(copy)->link.schema = SER(src)->link.schema;
+
+ // Update the binary data with a copy of its sequence.
+ //
+ // !!! Note that this leaves the offset intact, and will wind up making a
+ // copy as big as struct the instance is embedded into if nonzero offset.
+
+ REBSER *bin_copy = Make_Binary(STU_DATA_LEN(src));
+ memcpy(BIN_HEAD(bin_copy), STU_DATA_HEAD(src), STU_DATA_LEN(src));
+ TERM_BIN_LEN(bin_copy, STU_DATA_LEN(src));
+ STU_VALUE(copy)->payload.structure.data = bin_copy;
+ assert(STU_DATA_HEAD(copy) == BIN_HEAD(bin_copy));
+
+ MANAGE_SERIES(bin_copy);
+ MANAGE_ARRAY(copy);
+ return copy;
+}
+
+
+//
+// REBTYPE: C
+//
+REBTYPE(Struct)
+{
+ REBVAL *val;
+ REBVAL *arg;
+
+ val = D_ARG(1);
+
+ Init_Void(D_OUT);
+ // unary actions
+ switch(action) {
+
+ case SYM_CHANGE: {
+ arg = D_ARG(2);
+ if (!IS_BINARY(arg))
+ fail (Error_Unexpected_Type(REB_BINARY, VAL_TYPE(arg)));
+
+ if (VAL_LEN_AT(arg) != VAL_STRUCT_DATA_LEN(val))
+ fail (arg);
+
+ memcpy(
+ VAL_STRUCT_DATA_HEAD(val),
+ BIN_HEAD(VAL_SERIES(arg)),
+ VAL_STRUCT_DATA_LEN(val)
+ );
+ Move_Value(D_OUT, val);
+ break; }
+
+ case SYM_REFLECT: {
+ arg = D_ARG(2);
+ switch (VAL_WORD_SYM(arg)) {
+ case SYM_VALUES: {
+ fail_if_non_accessible(val);
+ REBSER *bin = Make_Binary(VAL_STRUCT_SIZE(val));
+ memcpy(
+ BIN_HEAD(bin),
+ VAL_STRUCT_DATA_AT(val),
+ VAL_STRUCT_SIZE(val)
+ );
+ TERM_BIN_LEN(bin, VAL_STRUCT_SIZE(val));
+ Init_Binary(D_OUT, bin);
+ break; }
+
+ case SYM_SPEC:
+ Init_Block(D_OUT, Struct_To_Array(VAL_STRUCT(val)));
+ break;
+
+ case SYM_ADDR:
+ Init_Integer(D_OUT, cast(REBUPT, VAL_STRUCT_DATA_AT(val)));
+ break;
+
+ default:
+ fail (Error_Cannot_Reflect(REB_STRUCT, arg));
+ }
+ break; }
+
+ case SYM_LENGTH_OF:
+ Init_Integer(D_OUT, VAL_STRUCT_DATA_LEN(val));
+ break;
+
+ default:
+ fail (Error_Illegal_Action(REB_STRUCT, action));
+ }
+ return R_OUT;
+}
+
+
+//
+// destroy-struct-storage: native [
+//
+// {Destroy the external memory associated the struct}
+//
+// struct [struct!]
+// /free
+// {Specify the function to free the memory}
+// free-func [function!]
+// ]
+//
+REBNATIVE(destroy_struct_storage)
+{
+ INCLUDE_PARAMS_OF_DESTROY_STRUCT_STORAGE;
+
+ REBSER *data = ARG(struct)->payload.structure.data;
+ if (NOT_SER_FLAG(data, SERIES_FLAG_ARRAY))
+ fail (Error_No_External_Storage_Raw());
+
+ RELVAL *handle = ARR_HEAD(ARR(data));
+
+ DECLARE_LOCAL (pointer);
+ Init_Integer(pointer, cast(REBUPT, VAL_HANDLE_POINTER(void, handle)));
+
+ if (VAL_HANDLE_LEN(handle) == 0)
+ fail (Error_Already_Destroyed_Raw(pointer));
+
+ // TBD: assert handle length was correct for memory block size
+
+ SET_HANDLE_LEN(handle, 0);
+
+ if (REF(free)) {
+ if (NOT(IS_FUNCTION_RIN(ARG(free_func))))
+ fail (Error_Free_Needs_Routine_Raw());
+
+ if (Do_Va_Throws(D_OUT, ARG(free_func), pointer, END))
+ return R_OUT_IS_THROWN;
+ }
+
+ return R_VOID;
+}
diff --git a/src/core/t-time.c b/src/core/t-time.c
index 57539f9e05..dfed2ead44 100644
--- a/src/core/t-time.c
+++ b/src/core/t-time.c
@@ -1,551 +1,705 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-time.c
-** Summary: time datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-time.c
+// Summary: "time datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ void Split_Time(REBI64 t, REB_TIMEF *tf)
-/*
-***********************************************************************/
+//
+// Split_Time: C
+//
+void Split_Time(REBI64 t, REB_TIMEF *tf)
{
- // note: negative sign will be lost.
- REBI64 h, m, s, n, i;
-
- if (t < 0) t = -t;
-
- h = t / HR_SEC;
- i = t - (h * HR_SEC);
- m = i / MIN_SEC;
- i = i - (m * MIN_SEC);
- s = i / SEC_SEC;
- n = i - (s * SEC_SEC);
-
- tf->h = (REBCNT)h;
- tf->m = (REBCNT)m;
- tf->s = (REBCNT)s;
- tf->n = (REBCNT)n;
+ // note: negative sign will be lost.
+ REBI64 h, m, s, n, i;
+
+ if (t < 0) t = -t;
+
+ h = t / HR_SEC;
+ i = t - (h * HR_SEC);
+ m = i / MIN_SEC;
+ i = i - (m * MIN_SEC);
+ s = i / SEC_SEC;
+ n = i - (s * SEC_SEC);
+
+ tf->h = (REBCNT)h;
+ tf->m = (REBCNT)m;
+ tf->s = (REBCNT)s;
+ tf->n = (REBCNT)n;
}
-/***********************************************************************
-**
-*/ REBI64 Join_Time(REB_TIMEF *tf)
-/*
-***********************************************************************/
+//
+// Join_Time: C
+//
+// !! A REB_TIMEF has lost the sign bit available on the REBI64
+// used for times. If you want to make it negative, you need
+// pass in a flag here. (Flag added to help document the
+// issue, as previous code falsely tried to judge the sign
+// of tf->h, which is always positive.)
+//
+REBI64 Join_Time(REB_TIMEF *tf, REBOOL neg)
{
- REBFLG neg = tf->h < 0;
- REBI64 t;
+ REBI64 t;
- t = tf->h * HR_SEC + tf->m * MIN_SEC + tf->s * SEC_SEC + tf->n;
- return (neg ? -t : t);
+ t = (tf->h * HR_SEC) + (tf->m * MIN_SEC) + (tf->s * SEC_SEC) + tf->n;
+ return neg ? -t : t;
}
-/***********************************************************************
-**
-*/ REBYTE *Scan_Time(REBYTE *cp, REBCNT len, REBVAL *value)
-/*
-** Scan string and convert to time. Return zero if error.
-**
-***********************************************************************/
+//
+// Scan_Time: C
+//
+// Scan string and convert to time. Return zero if error.
+//
+const REBYTE *Scan_Time(REBVAL *out, const REBYTE *cp, REBCNT len)
{
- REBYTE *sp;
- REBYTE merid = FALSE;
- REBOOL neg = FALSE;
- REBINT part1, part2, part3 = -1;
- REBINT part4 = -1;
-
- if (*cp == '-') cp++, neg = TRUE;
- else if (*cp == '+') cp++;
-
- if (*cp == '-' || *cp == '+') return 0; // small hole: --1:23
-
- // Can be:
- // HH:MM as part1:part2
- // HH:MM:SS as part1:part2:part3
- // HH:MM:SS.DD as part1:part2:part3.part4
- // MM:SS.DD as part1:part2.part4
- cp = Grab_Int(cp, &part1);
- if (part1 > MAX_HOUR) return 0;
- if (*cp++ != ':') return 0;
- sp = Grab_Int(cp, &part2);
- if (part2 < 0 || sp == cp) return 0;
- cp = sp;
- if (*cp == ':') { // optional seconds
- sp = cp + 1;
- cp = Grab_Int(sp, &part3);
- if (part3 < 0 || cp == sp) return 0; //part3 = -1;
- }
- if (*cp == '.' || *cp == ',') {
- sp = ++cp;
- cp = Grab_Int_Scale(sp, &part4, 9);
- if (part4 == 0) part4 = -1;
- }
- if ((UP_CASE(*cp) == 'A' || UP_CASE(*cp) == 'P') && (UP_CASE(cp[1]) == 'M')) {
- merid = (REBYTE)UP_CASE(*cp);
- cp += 2;
- }
-
- if (part3 >= 0 || part4 < 0) { // HH:MM mode
- if (merid) {
- if (part1 > 12) return 0;
- if (part1 == 12) part1 = 0;
- if (merid == 'P') part1 += 12;
- }
- if (part3 < 0) part3 = 0;
- VAL_TIME(value) = HOUR_TIME(part1) + MIN_TIME(part2) + SEC_TIME(part3);
- } else { // MM:SS mode
- if (merid) return 0; // no AM/PM for minutes
- VAL_TIME(value) = MIN_TIME(part1) + SEC_TIME(part2);
- }
-
- if (part4 > 0) VAL_TIME(value) += part4;
-
- if (neg) VAL_TIME(value) = -VAL_TIME(value);
- VAL_SET(value, REB_TIME);
-
- return cp;
+ TRASH_CELL_IF_DEBUG(out);
+ cast(void, len); // !!! should len be paid attention to?
+
+ REBOOL neg;
+ if (*cp == '-') {
+ ++cp;
+ neg = TRUE;
+ }
+ else if (*cp == '+') {
+ ++cp;
+ neg = FALSE;
+ }
+ else
+ neg = FALSE;
+
+ if (*cp == '-' || *cp == '+')
+ return NULL; // small hole: --1:23
+
+ // Can be:
+ // HH:MM as part1:part2
+ // HH:MM:SS as part1:part2:part3
+ // HH:MM:SS.DD as part1:part2:part3.part4
+ // MM:SS.DD as part1:part2.part4
+
+ REBINT part1 = -1;
+ cp = Grab_Int(cp, &part1);
+ if (part1 > MAX_HOUR)
+ return NULL;
+
+ if (*cp++ != ':')
+ return NULL;
+
+ const REBYTE *sp;
+
+ REBINT part2 = -1;
+ sp = Grab_Int(cp, &part2);
+ if (part2 < 0 || sp == cp)
+ return NULL;
+
+ cp = sp;
+
+ REBINT part3 = -1;
+ if (*cp == ':') { // optional seconds
+ sp = cp + 1;
+ cp = Grab_Int(sp, &part3);
+ if (part3 < 0 || cp == sp)
+ return NULL;
+ }
+
+ REBINT part4 = -1;
+ if (*cp == '.' || *cp == ',') {
+ sp = ++cp;
+ cp = Grab_Int_Scale(sp, &part4, 9);
+ if (part4 == 0)
+ part4 = -1;
+ }
+
+ REBYTE merid;
+ if (
+ (UP_CASE(*cp) == 'A' || UP_CASE(*cp) == 'P')
+ && (UP_CASE(cp[1]) == 'M')
+ ){
+ merid = cast(REBYTE, UP_CASE(*cp));
+ cp += 2;
+ }
+ else
+ merid = '\0';
+
+ VAL_RESET_HEADER(out, REB_TIME);
+
+ if (part3 >= 0 || part4 < 0) { // HH:MM mode
+ if (merid != '\0') {
+ if (part1 > 12)
+ return NULL;
+
+ if (part1 == 12)
+ part1 = 0;
+
+ if (merid == 'P')
+ part1 += 12;
+ }
+
+ if (part3 < 0)
+ part3 = 0;
+
+ VAL_NANO(out) = HOUR_TIME(part1) + MIN_TIME(part2) + SEC_TIME(part3);
+ }
+ else {
+ // MM:SS mode
+
+ if (merid != '\0')
+ return NULL; // no AM/PM for minutes
+
+ VAL_NANO(out) = MIN_TIME(part1) + SEC_TIME(part2);
+ }
+
+ if (part4 > 0)
+ VAL_NANO(out) += part4;
+
+ if (neg)
+ VAL_NANO(out) = -VAL_NANO(out);
+
+ return cp;
}
-/***********************************************************************
-**
-*/ void Emit_Time(REB_MOLD *mold, REBVAL *value)
-/*
-***********************************************************************/
+//
+// Emit_Time: C
+//
+void Emit_Time(REB_MOLD *mold, const REBVAL *value)
{
- REB_TIMEF tf;
- REBYTE *fmt;
+ REB_TIMEF tf;
+ const char *fmt;
- Split_Time(VAL_TIME(value), &tf); // loses sign
+ Split_Time(VAL_NANO(value), &tf); // loses sign
- if (tf.s == 0 && tf.n == 0) fmt = "I:2";
- else fmt = "I:2:2";
+ if (tf.s == 0 && tf.n == 0) fmt = "I:2";
+ else fmt = "I:2:2";
- if (VAL_TIME(value) < (REBI64)0) Append_Byte(mold->series, '-');
- Emit(mold, fmt, tf.h, tf.m, tf.s, 0);
+ if (VAL_NANO(value) < cast(REBI64, 0))
+ Append_Codepoint_Raw(mold->series, '-');
- if (tf.n > 0) Emit(mold, ".i", tf.n);
+ Emit(mold, fmt, tf.h, tf.m, tf.s, 0);
+
+ if (tf.n > 0) Emit(mold, ".i", tf.n);
}
-/***********************************************************************
-**
-*/ REBINT CT_Time(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Time: C
+//
+REBINT CT_Time(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBINT num = Cmp_Time(a, b);
- if (mode >= 0) return (num == 0);
- if (mode == -1) return (num >= 0);
- return (num > 0);
+ REBINT num = Cmp_Time(a, b);
+ if (mode >= 0) return (num == 0);
+ if (mode == -1) return (num >= 0);
+ return (num > 0);
}
-/***********************************************************************
-**
-*/ REBI64 Make_Time(REBVAL *val)
-/*
-** Returns NO_TIME if error.
-**
-***********************************************************************/
+//
+// Make_Time: C
+//
+// Returns NO_TIME if error.
+//
+REBI64 Make_Time(const REBVAL *val)
{
- REBI64 secs = 0;
-
- if (IS_TIME(val)) {
- secs = VAL_TIME(val);
- }
- else if (IS_STRING(val)) {
- REBYTE *bp;
- REBCNT len;
- bp = Qualify_String(val, 30, &len, FALSE); // can trap, ret diff str
- if (!Scan_Time(bp, len, val)) goto no_time;
- secs = VAL_TIME(val);
- }
- else if (IS_INTEGER(val)) {
- if (VAL_INT64(val) < -MAX_SECONDS || VAL_INT64(val) > MAX_SECONDS)
- Trap_Range(val);
- secs = VAL_INT64(val) * SEC_SEC;
- }
- else if (IS_DECIMAL(val)) {
- if (VAL_DECIMAL(val) < (REBDEC)(-MAX_SECONDS) || VAL_DECIMAL(val) > (REBDEC)MAX_SECONDS)
- Trap_Range(val);
- secs = DEC_TO_SECS(VAL_DECIMAL(val));
- }
- else if (ANY_BLOCK(val) && VAL_BLK_LEN(val) <= 3) {
- REBFLG neg = FALSE;
- REBINT i;
-
- val = VAL_BLK_DATA(val);
- if (!IS_INTEGER(val)) goto no_time;
- i = Int32(val);
- if (i < 0) i = -i, neg = TRUE;
- secs = i * 3600;
- if (secs > MAX_SECONDS) goto no_time;
-
- if (NOT_END(++val)) {
- if (!IS_INTEGER(val)) goto no_time;
- if ((i = Int32(val)) < 0) goto no_time;
- secs += i * 60;
- if (secs > MAX_SECONDS) goto no_time;
-
- if (NOT_END(++val)) {
- if (IS_INTEGER(val)) {
- if ((i = Int32(val)) < 0) goto no_time;
- secs += i;
- if (secs > MAX_SECONDS) goto no_time;
- }
- else if (IS_DECIMAL(val)) {
- if (secs + (REBI64)VAL_DECIMAL(val) + 1 > MAX_SECONDS) goto no_time;
- // added in below
- }
- else goto no_time;
- }
- }
- secs *= SEC_SEC;
- if (IS_DECIMAL(val)) secs += DEC_TO_SECS(VAL_DECIMAL(val));
- if (neg) secs = -secs;
- }
- else
- no_time: return NO_TIME;
-
- return secs;
+ if (IS_TIME(val)) {
+ return VAL_NANO(val);
+ }
+ else if (IS_STRING(val)) {
+ REBCNT len;
+ REBYTE *bp = Temp_Byte_Chars_May_Fail(val, MAX_SCAN_TIME, &len, FALSE);
+
+ DECLARE_LOCAL (temp);
+ if (Scan_Time(temp, bp, len) == NULL)
+ goto no_time;
+
+ return VAL_NANO(temp);
+ }
+ else if (IS_INTEGER(val)) {
+ if (VAL_INT64(val) < -MAX_SECONDS || VAL_INT64(val) > MAX_SECONDS)
+ fail (Error_Out_Of_Range(val));
+
+ return VAL_INT64(val) * SEC_SEC;
+ }
+ else if (IS_DECIMAL(val)) {
+ if (
+ VAL_DECIMAL(val) < cast(REBDEC, -MAX_SECONDS)
+ || VAL_DECIMAL(val) > cast(REBDEC, MAX_SECONDS)
+ ){
+ fail (Error_Out_Of_Range(val));
+ }
+ return DEC_TO_SECS(VAL_DECIMAL(val));
+ }
+ else if (ANY_ARRAY(val) && VAL_ARRAY_LEN_AT(val) <= 3) {
+ RELVAL *item = VAL_ARRAY_AT(val);
+ if (NOT(IS_INTEGER(item)))
+ goto no_time;
+
+ REBOOL neg;
+ REBI64 i = Int32(item);
+ if (i < 0) {
+ i = -i;
+ neg = TRUE;
+ }
+ else
+ neg = FALSE;
+
+ REBI64 secs = i * 3600;
+ if (secs > MAX_SECONDS)
+ goto no_time;
+
+ if (NOT_END(++item)) {
+ if (NOT(IS_INTEGER(item)))
+ goto no_time;
+
+ if ((i = Int32(item)) < 0)
+ goto no_time;
+
+ secs += i * 60;
+ if (secs > MAX_SECONDS)
+ goto no_time;
+
+ if (NOT_END(++item)) {
+ if (IS_INTEGER(item)) {
+ if ((i = Int32(item)) < 0)
+ goto no_time;
+
+ secs += i;
+ if (secs > MAX_SECONDS) goto no_time;
+ }
+ else if (IS_DECIMAL(item)) {
+ if (secs + cast(REBI64, VAL_DECIMAL(item)) + 1 > MAX_SECONDS)
+ goto no_time;
+
+ // added in below
+ }
+ else
+ goto no_time;
+ }
+ }
+
+ secs *= SEC_SEC;
+ if (IS_DECIMAL(item))
+ secs += DEC_TO_SECS(VAL_DECIMAL(item));
+
+ if (neg)
+ secs = -secs;
+
+ return secs;
+ }
+
+no_time:
+ return NO_TIME;
}
-/***********************************************************************
-**
-*/ REBFLG MT_Time(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+//
+// MAKE_Time: C
+//
+void MAKE_Time(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBI64 secs = Make_Time(data);
+ assert(kind == REB_TIME);
+ UNUSED(kind);
+
+ REBI64 secs = Make_Time(arg);
+ if (secs == NO_TIME)
+ fail (Error_Bad_Make(REB_TIME, arg));
- if (secs == NO_TIME) return FALSE;
+ VAL_RESET_HEADER(out, REB_TIME);
+ VAL_NANO(out) = secs;
+ VAL_DATE(out).bits = 0;
+}
- VAL_SET(out, REB_TIME);
- VAL_TIME(out) = secs;
- VAL_DATE(out).bits = 0;
- return TRUE;
+//
+// TO_Time: C
+//
+void TO_Time(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ MAKE_Time(out, kind, arg);
}
-/***********************************************************************
-**
-*/ REBINT Cmp_Time(REBVAL *v1, REBVAL *v2)
-/*
-** Given two times, compare them.
-**
-***********************************************************************/
+//
+// Cmp_Time: C
+//
+// Given two times, compare them.
+//
+REBINT Cmp_Time(const RELVAL *v1, const RELVAL *v2)
{
- REBI64 t1 = VAL_TIME(v1);
- REBI64 t2 = VAL_TIME(v2);
-
- if (t1 == NO_TIME) t1 = 0L;
- if (t2 == NO_TIME) t2 = 0L;
- if (t2 == t1) return 0;
- if (t1 > t2) return 1;
- return -1;
+ REBI64 t1 = VAL_NANO(v1);
+ REBI64 t2 = VAL_NANO(v2);
+
+ if (t1 == NO_TIME)
+ t1 = 0L;
+ if (t2 == NO_TIME)
+ t2 = 0L;
+ if (t2 == t1)
+ return 0;
+ if (t1 > t2)
+ return 1;
+ return -1;
}
-/***********************************************************************
-**
-*/ REBINT PD_Time(REBPVS *pvs)
-/*
-***********************************************************************/
+//
+// Pick_Time: C
+//
+void Pick_Time(REBVAL *out, const REBVAL *value, const REBVAL *picker)
{
- REBVAL *val;
- REBINT i;
- REBINT n;
- REBDEC f;
- REB_TIMEF tf;
-
- if (IS_WORD(pvs->select)) {
- switch (VAL_WORD_CANON(pvs->select)) {
- case SYM_HOUR: i = 0; break;
- case SYM_MINUTE: i = 1; break;
- case SYM_SECOND: i = 2; break;
- default: return PE_BAD_SELECT;
- }
- }
- else if (IS_INTEGER(pvs->select))
- i = VAL_INT32(pvs->select) - 1;
- else
- return PE_BAD_SELECT;
-
- Split_Time(VAL_TIME(pvs->value), &tf); // loses sign
-
- if (!(val = pvs->setval)) {
- val = pvs->store;
- switch(i) {
- case 0: // hours
- SET_INTEGER(val, tf.h);
- break;
- case 1:
- SET_INTEGER(val, tf.m);
- break;
- case 2:
- if (tf.n == 0)
- SET_INTEGER(val, tf.s);
- else
- SET_DECIMAL(val, (REBDEC)tf.s + (tf.n * NANO));
- break;
- default:
- return PE_NONE;
- }
- return PE_USE;
-
- } else {
- if (IS_INTEGER(val) || IS_DECIMAL(val)) n = Int32s(val, 0);
- else if (IS_NONE(val)) n = 0;
- else return PE_BAD_SET;
-
- switch(i) {
- case 0:
- tf.h = n;
- break;
- case 1:
- tf.m = n;
- break;
- case 2:
- if (IS_DECIMAL(val)) {
- f = VAL_DECIMAL(val);
- if (f < 0.0) Trap_Range(val);
- tf.s = (REBINT)f;
- tf.n = (REBINT)((f - tf.s) * SEC_SEC);
- }
- else {
- tf.s = n;
- tf.n = 0;
- }
- break;
- default:
- return PE_BAD_SELECT;
- }
-
- VAL_TIME(pvs->value) = Join_Time(&tf);
- return PE_OK;
- }
+ REBINT i;
+ if (IS_WORD(picker)) {
+ switch (VAL_WORD_SYM(picker)) {
+ case SYM_HOUR: i = 0; break;
+ case SYM_MINUTE: i = 1; break;
+ case SYM_SECOND: i = 2; break;
+ default:
+ fail (picker);
+ }
+ }
+ else if (IS_INTEGER(picker))
+ i = VAL_INT32(picker) - 1;
+ else
+ fail (picker);
+
+ REB_TIMEF tf;
+ Split_Time(VAL_NANO(value), &tf); // loses sign
+
+ switch(i) {
+ case 0: // hours
+ Init_Integer(out, tf.h);
+ break;
+ case 1: // minutes
+ Init_Integer(out, tf.m);
+ break;
+ case 2: // seconds
+ if (tf.n == 0)
+ Init_Integer(out, tf.s);
+ else
+ Init_Decimal(out, cast(REBDEC, tf.s) + (tf.n * NANO));
+ break;
+ default:
+ Init_Void(out); // "out of range" behavior for pick
+ }
+}
+
+
+//
+// Poke_Time_Immediate: C
+//
+void Poke_Time_Immediate(
+ REBVAL *value,
+ const REBVAL *picker,
+ const REBVAL *poke
+) {
+ REBINT i;
+ if (IS_WORD(picker)) {
+ switch (VAL_WORD_SYM(picker)) {
+ case SYM_HOUR: i = 0; break;
+ case SYM_MINUTE: i = 1; break;
+ case SYM_SECOND: i = 2; break;
+ default:
+ fail (picker);
+ }
+ }
+ else if (IS_INTEGER(picker))
+ i = VAL_INT32(picker) - 1;
+ else
+ fail (picker);
+
+ REB_TIMEF tf;
+ Split_Time(VAL_NANO(value), &tf); // loses sign
+
+ REBINT n;
+ if (IS_INTEGER(poke) || IS_DECIMAL(poke))
+ n = Int32s(poke, 0);
+ else if (IS_BLANK(poke))
+ n = 0;
+ else
+ fail (poke);
+
+ switch(i) {
+ case 0:
+ tf.h = n;
+ break;
+ case 1:
+ tf.m = n;
+ break;
+ case 2:
+ if (IS_DECIMAL(poke)) {
+ REBDEC f = VAL_DECIMAL(poke);
+ if (f < 0.0)
+ fail (Error_Out_Of_Range(poke));
+
+ tf.s = cast(REBINT, f);
+ tf.n = cast(REBINT, (f - tf.s) * SEC_SEC);
+ }
+ else {
+ tf.s = n;
+ tf.n = 0;
+ }
+ break;
+ default:
+ fail (picker);
+ }
+
+ VAL_NANO(value) = Join_Time(&tf, FALSE);
}
-/***********************************************************************
-**
-*/ REBTYPE(Time)
-/*
-***********************************************************************/
+//
+// PD_Time: C
+//
+REBINT PD_Time(REBPVS *pvs)
{
- REBI64 secs;
- REBVAL *val;
- REBVAL *arg;
- REBI64 num;
-
- val = D_ARG(1);
-
- secs = VAL_TIME(val); // note: not always valid REB_TIME (e.g. MAKE)
-
- if (DS_ARGC > 1) arg = D_ARG(2);
-
- if (IS_BINARY_ACT(action)) {
- REBINT type = VAL_TYPE(arg);
-
- if (type == REB_TIME) { // handle TIME - TIME cases
- REBI64 secs2 = VAL_TIME(arg);
- REBINT diff;
-
- diff = Cmp_Time(val, arg);
- switch (action) {
-
- case A_ADD:
- secs = Add_Max(REB_TIME, secs, secs2, MAX_TIME);
- goto fixTime;
-
- case A_SUBTRACT:
- secs = Add_Max(REB_TIME, secs, -secs2, MAX_TIME);
- goto fixTime;
-
- case A_DIVIDE:
- if (secs2 == 0) Trap0(RE_ZERO_DIVIDE);
- //secs /= secs2;
- VAL_SET(DS_RETURN, REB_DECIMAL);
- VAL_DECIMAL(DS_RETURN) = (REBDEC)secs / (REBDEC)secs2;
- return R_RET;
-
- case A_REMAINDER:
- if (secs2 == 0) Trap0(RE_ZERO_DIVIDE);
- secs %= secs2;
- goto setTime;
- }
- }
- else if (type == REB_INTEGER) { // handle TIME - INTEGER cases
-
- num = VAL_INT64(arg);
-
- switch(action) {
- case A_ADD:
- secs = Add_Max(REB_TIME, secs, num * SEC_SEC, MAX_TIME);
- goto fixTime;
-
- case A_SUBTRACT:
- secs = Add_Max(REB_TIME, secs, num * -SEC_SEC, MAX_TIME);
- goto fixTime;
-
- case A_MULTIPLY:
- secs *= num;
- if (secs < -MAX_TIME || secs > MAX_TIME)
- Trap1(RE_TYPE_LIMIT, Get_Type(REB_TIME));
- goto setTime;
-
- case A_DIVIDE:
- if (num == 0) Trap0(RE_ZERO_DIVIDE);
- secs /= num;
- DS_RET_INT(secs);
- goto setTime;
-
- case A_REMAINDER:
- if (num == 0) Trap0(RE_ZERO_DIVIDE);
- secs %= num;
- goto setTime;
- }
- }
- else if (type == REB_DECIMAL) { // handle TIME - DECIMAL cases
- REBDEC dec = VAL_DECIMAL(arg);
-
- switch(action) {
- case A_ADD:
- secs = Add_Max(REB_TIME, secs, (i64)(dec * SEC_SEC), MAX_TIME);
- goto fixTime;
-
- case A_SUBTRACT:
- secs = Add_Max(REB_TIME, secs, (i64)(dec * -SEC_SEC), MAX_TIME);
- goto fixTime;
-
- case A_MULTIPLY:
- secs = (REBI64)(secs * dec);
- goto setTime;
-
- case A_DIVIDE:
- if (dec == 0.0) Trap0(RE_ZERO_DIVIDE);
- secs = (REBI64)(secs / dec);
- goto setTime;
-
-// case A_REMAINDER:
-// ld = fmod(ld, VAL_DECIMAL(arg));
-// goto decTime;
- }
- }
- else if (type == REB_DATE && action == A_ADD) { // TIME + DATE case
- // Swap args and call DATE datatupe:
- *D_ARG(3) = *val; // (temporary location for swap)
- *D_ARG(1) = *arg;
- *D_ARG(2) = *D_ARG(3);
- T_Date(ds, action);
- return R_RET;
- }
- Trap_Math_Args(REB_TIME, action);
- }
- else {
- // unary actions
- switch(action) {
-
- case A_ODDQ:
- DECIDE((SECS_IN(secs) & 1) != 0);
-
- case A_EVENQ:
- DECIDE((SECS_IN(secs) & 1) == 0);
-
- case A_NEGATE:
- secs = -secs;
- goto setTime;
-
- case A_ABSOLUTE:
- if (secs < 0) secs = -secs;
- goto setTime;
-
- case A_ROUND:
- if (D_REF(2)) {
- arg = D_ARG(3);
- if (IS_TIME(arg)) {
- secs = Round_Int(secs, Get_Round_Flags(ds), VAL_TIME(arg));
- }
- else if (IS_DECIMAL(arg)) {
- VAL_DECIMAL(arg) = Round_Dec((REBDEC)secs, Get_Round_Flags(ds), Dec64(arg) * SEC_SEC) / SEC_SEC;
- VAL_SET(arg, REB_DECIMAL);
- return R_ARG3;
- }
- else if (IS_INTEGER(arg)) {
- VAL_INT64(arg) = Round_Int(secs, 1, Int32(arg) * SEC_SEC) / SEC_SEC;
- VAL_SET(arg, REB_INTEGER);
- return R_ARG3;
- }
- else Trap_Arg(arg);
- }
- else {
- secs = Round_Int(secs, Get_Round_Flags(ds) | 1, SEC_SEC);
- }
- goto fixTime;
-
- case A_RANDOM:
- if (D_REF(2)) {
- Set_Random(secs);
- return R_UNSET;
- }
- secs = Random_Range(secs / SEC_SEC, D_REF(3)) * SEC_SEC;
- goto fixTime;
-
- case A_PICK:
- Pick_Path(val, arg, 0);
- return R_TOS;
-
-/// case A_POKE:
-/// Pick_Path(val, arg, D_ARG(3));
-/// return R_ARG3;
-
- case A_MAKE:
- case A_TO:
- secs = Make_Time(arg);
- if (secs == NO_TIME) Trap_Make(REB_TIME, arg);
- goto setTime;
- }
- }
- Trap_Action(REB_TIME, action);
+ if (pvs->opt_setval) {
+ //
+ // !!! Since TIME! is an immediate value, allowing a SET-PATH! will
+ // modify the result of the expression but not the source.
+ //
+ Poke_Time_Immediate(KNOWN(pvs->value), pvs->picker, pvs->opt_setval);
+ return PE_OK;
+ }
+
+ Pick_Time(pvs->store, KNOWN(pvs->value), pvs->picker);
+ return PE_USE_STORE;
+}
-fixTime:
-setTime:
- VAL_TIME(D_RET) = secs;
- VAL_SET(D_RET, REB_TIME);
- return R_RET;
-is_false:
- return R_FALSE;
+//
+// REBTYPE: C
+//
+REBTYPE(Time)
+{
+ REBVAL *val = D_ARG(1);
+
+ REBI64 secs = VAL_NANO(val);
+
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+
+ // !!! This used to use IS_BINARY_ACT(), which is not available under
+ // the symbol-based dispatch. Consider doing another way.
+ //
+ if (
+ action == SYM_ADD
+ || action == SYM_SUBTRACT
+ || action == SYM_MULTIPLY
+ || action == SYM_DIVIDE
+ || action == SYM_REMAINDER
+ ){
+ REBINT type = VAL_TYPE(arg);
+
+ assert(arg);
+
+ if (type == REB_TIME) { // handle TIME - TIME cases
+ REBI64 secs2 = VAL_NANO(arg);
+
+ switch (action) {
+
+ case SYM_ADD:
+ secs = Add_Max(REB_TIME, secs, secs2, MAX_TIME);
+ goto fixTime;
+
+ case SYM_SUBTRACT:
+ secs = Add_Max(REB_TIME, secs, -secs2, MAX_TIME);
+ goto fixTime;
+
+ case SYM_DIVIDE:
+ if (secs2 == 0) fail (Error_Zero_Divide_Raw());
+ //secs /= secs2;
+ VAL_RESET_HEADER(D_OUT, REB_DECIMAL);
+ VAL_DECIMAL(D_OUT) = (REBDEC)secs / (REBDEC)secs2;
+ return R_OUT;
+
+ case SYM_REMAINDER:
+ if (secs2 == 0) fail (Error_Zero_Divide_Raw());
+ secs %= secs2;
+ goto setTime;
+
+ default:
+ fail (Error_Math_Args(REB_TIME, action));
+ }
+ }
+ else if (type == REB_INTEGER) { // handle TIME - INTEGER cases
+ REBI64 num = VAL_INT64(arg);
+
+ switch(action) {
+ case SYM_ADD:
+ secs = Add_Max(REB_TIME, secs, num * SEC_SEC, MAX_TIME);
+ goto fixTime;
+
+ case SYM_SUBTRACT:
+ secs = Add_Max(REB_TIME, secs, num * -SEC_SEC, MAX_TIME);
+ goto fixTime;
+
+ case SYM_MULTIPLY:
+ secs *= num;
+ if (secs < -MAX_TIME || secs > MAX_TIME)
+ fail (Error_Type_Limit_Raw(Get_Type(REB_TIME)));
+ goto setTime;
+
+ case SYM_DIVIDE:
+ if (num == 0) fail (Error_Zero_Divide_Raw());
+ secs /= num;
+ Init_Integer(D_OUT, secs);
+ goto setTime;
+
+ case SYM_REMAINDER:
+ if (num == 0) fail (Error_Zero_Divide_Raw());
+ secs %= num;
+ goto setTime;
+
+ default:
+ fail (Error_Math_Args(REB_TIME, action));
+ }
+ }
+ else if (type == REB_DECIMAL) { // handle TIME - DECIMAL cases
+ REBDEC dec = VAL_DECIMAL(arg);
+
+ switch(action) {
+ case SYM_ADD:
+ secs = Add_Max(REB_TIME, secs, (i64)(dec * SEC_SEC), MAX_TIME);
+ goto fixTime;
+
+ case SYM_SUBTRACT:
+ secs = Add_Max(REB_TIME, secs, (i64)(dec * -SEC_SEC), MAX_TIME);
+ goto fixTime;
+
+ case SYM_MULTIPLY:
+ secs = (REBI64)(secs * dec);
+ goto setTime;
+
+ case SYM_DIVIDE:
+ if (dec == 0.0) fail (Error_Zero_Divide_Raw());
+ secs = (REBI64)(secs / dec);
+ goto setTime;
+
+// case SYM_REMAINDER:
+// ld = fmod(ld, VAL_DECIMAL(arg));
+// goto decTime;
+
+ default:
+ fail (Error_Math_Args(REB_TIME, action));
+ }
+ }
+ else if (type == REB_DATE && action == SYM_ADD) { // TIME + DATE case
+ // Swap args and call DATE datatupe:
+ Move_Value(D_ARG(3), val); // (temporary location for swap)
+ Move_Value(D_ARG(1), arg);
+ Move_Value(D_ARG(2), D_ARG(3));
+ return T_Date(frame_, action);
+ }
+ fail (Error_Math_Args(REB_TIME, action));
+ }
+ else {
+ // unary actions
+ switch(action) {
+
+ case SYM_ODD_Q:
+ return ((SECS_FROM_NANO(secs) & 1) != 0) ? R_TRUE : R_FALSE;
+
+ case SYM_EVEN_Q:
+ return ((SECS_FROM_NANO(secs) & 1) == 0) ? R_TRUE : R_FALSE;
+
+ case SYM_NEGATE:
+ secs = -secs;
+ goto setTime;
+
+ case SYM_ABSOLUTE:
+ if (secs < 0) secs = -secs;
+ goto setTime;
+
+ case SYM_ROUND: {
+ INCLUDE_PARAMS_OF_ROUND;
+
+ UNUSED(PAR(value));
+
+ REBFLGS flags = (
+ (REF(to) ? RF_TO : 0)
+ | (REF(even) ? RF_EVEN : 0)
+ | (REF(down) ? RF_DOWN : 0)
+ | (REF(half_down) ? RF_HALF_DOWN : 0)
+ | (REF(floor) ? RF_FLOOR : 0)
+ | (REF(ceiling) ? RF_CEILING : 0)
+ | (REF(half_ceiling) ? RF_HALF_CEILING : 0)
+ );
+
+ if (REF(to)) {
+ arg = ARG(scale);
+ if (IS_TIME(arg)) {
+ secs = Round_Int(secs, flags, VAL_NANO(arg));
+ }
+ else if (IS_DECIMAL(arg)) {
+ VAL_DECIMAL(arg) = Round_Dec(
+ cast(REBDEC, secs),
+ flags,
+ Dec64(arg) * SEC_SEC
+ );
+ VAL_DECIMAL(arg) /= SEC_SEC;
+ VAL_RESET_HEADER(arg, REB_DECIMAL);
+ Move_Value(D_OUT, ARG(scale));
+ return R_OUT;
+ }
+ else if (IS_INTEGER(arg)) {
+ VAL_INT64(arg) = Round_Int(secs, 1, Int32(arg) * SEC_SEC) / SEC_SEC;
+ VAL_RESET_HEADER(arg, REB_INTEGER);
+ Move_Value(D_OUT, ARG(scale));
+ return R_OUT;
+ }
+ else
+ fail (arg);
+ }
+ else {
+ secs = Round_Int(secs, flags | RF_TO, SEC_SEC);
+ }
+ goto fixTime; }
+
+ case SYM_RANDOM: {
+ INCLUDE_PARAMS_OF_RANDOM;
+
+ UNUSED(PAR(value));
+
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+
+ if (REF(seed)) {
+ Set_Random(secs);
+ return R_VOID;
+ }
+ secs = Random_Range(secs / SEC_SEC, REF(secure)) * SEC_SEC;
+ goto fixTime; }
+
+ default:
+ break;
+ }
+ }
+ fail (Error_Illegal_Action(REB_TIME, action));
-is_true:
- return R_TRUE;
+fixTime:
+setTime:
+ VAL_RESET_HEADER(D_OUT, REB_TIME);
+ VAL_NANO(D_OUT) = secs;
+ return R_OUT;
}
diff --git a/src/core/t-tuple.c b/src/core/t-tuple.c
index cf6c92e970..8947b0f149 100644
--- a/src/core/t-tuple.c
+++ b/src/core/t-tuple.c
@@ -1,386 +1,495 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-tuple.c
-** Summary: tuple datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-tuple.c
+// Summary: "tuple datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ REBINT CT_Tuple(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// CT_Tuple: C
+//
+REBINT CT_Tuple(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBINT num = Cmp_Tuple(a, b);
- if (mode > 1) return (num == 0 && VAL_TUPLE_LEN(a) == VAL_TUPLE_LEN(b));
- if (mode >= 0) return (num == 0);
- if (mode == -1) return (num >= 0);
- return (num > 0);
+ REBINT num = Cmp_Tuple(a, b);
+ if (mode > 1) return (num == 0 && VAL_TUPLE_LEN(a) == VAL_TUPLE_LEN(b));
+ if (mode >= 0) return (num == 0);
+ if (mode == -1) return (num >= 0);
+ return (num > 0);
}
-/***********************************************************************
-**
-*/ REBFLG MT_Tuple(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+
+//
+// MAKE_Tuple: C
+//
+void MAKE_Tuple(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBYTE *vp;
- REBINT len = 0;
- REBINT n;
-
- vp = VAL_TUPLE(out);
- for (; NOT_END(data); data++, vp++, len++) {
- if (len >= 10) return FALSE;
- if (IS_INTEGER(data)) {
- n = Int32(data);
- }
- else if (IS_CHAR(data)) {
- n = VAL_CHAR(data);
- }
- else return FALSE;
- if (n > 255 || n < 0) return FALSE;
- *vp = n;
- }
-
- VAL_TUPLE_LEN(out) = len;
-
- for (; len < 10; len++) *vp++ = 0;
-
- VAL_SET(out, type);
- return TRUE;
+ assert(kind == REB_TUPLE);
+ UNUSED(kind);
+
+ if (IS_TUPLE(arg)) {
+ Move_Value(out, arg);
+ return;
+ }
+
+ VAL_RESET_HEADER(out, REB_TUPLE);
+ REBYTE *vp = VAL_TUPLE(out);
+
+ // !!! Net lookup parses IP addresses out of `tcp://93.184.216.34` or
+ // similar URL!s. In Rebol3 these captures come back the same type
+ // as the input instead of as STRING!, which was a latent bug in the
+ // network code of the 12-Dec-2012 release:
+ //
+ // https://github.com/rebol/rebol/blob/master/src/mezz/sys-ports.r#L110
+ //
+ // All attempts to convert a URL!-flavored IP address failed. Taking
+ // URL! here fixes it, though there are still open questions.
+ //
+ if (IS_STRING(arg) || IS_URL(arg)) {
+ REBCNT len;
+ REBYTE *ap = Temp_Byte_Chars_May_Fail(arg, MAX_SCAN_TUPLE, &len, FALSE);
+ if (Scan_Tuple(out, ap, len) != NULL)
+ return;
+ fail (arg);
+ }
+
+ if (ANY_ARRAY(arg)) {
+ REBCNT len = 0;
+ REBINT n;
+
+ RELVAL *item = VAL_ARRAY_AT(arg);
+
+ for (; NOT_END(item); ++item, ++vp, ++len) {
+ if (len >= MAX_TUPLE)
+ goto bad_make;
+ if (IS_INTEGER(item)) {
+ n = Int32(item);
+ }
+ else if (IS_CHAR(item)) {
+ n = VAL_CHAR(item);
+ }
+ else
+ goto bad_make;
+
+ if (n > 255 || n < 0)
+ goto bad_make;
+ *vp = n;
+ }
+
+ VAL_TUPLE_LEN(out) = len;
+
+ for (; len < MAX_TUPLE; len++) *vp++ = 0;
+ return;
+ }
+
+ REBCNT alen;
+
+ if (IS_ISSUE(arg)) {
+ REBUNI c;
+ const REBYTE *ap = VAL_WORD_HEAD(arg);
+ REBCNT len = LEN_BYTES(ap); // UTF-8 len
+ if (len & 1)
+ fail (arg); // must have even # of chars
+ len /= 2;
+ if (len > MAX_TUPLE)
+ fail (arg); // valid even for UTF-8
+ VAL_TUPLE_LEN(out) = len;
+ for (alen = 0; alen < len; alen++) {
+ const REBOOL unicode = FALSE;
+ if (!Scan_Hex2(ap, &c, unicode))
+ fail (arg);
+ *vp++ = cast(REBYTE, c);
+ ap += 2;
+ }
+ }
+ else if (IS_BINARY(arg)) {
+ REBYTE *ap = VAL_BIN_AT(arg);
+ REBCNT len = VAL_LEN_AT(arg);
+ if (len > MAX_TUPLE) len = MAX_TUPLE;
+ VAL_TUPLE_LEN(out) = len;
+ for (alen = 0; alen < len; alen++) *vp++ = *ap++;
+ }
+ else
+ fail (arg);
+
+ for (; alen < MAX_TUPLE; alen++) *vp++ = 0;
+ return;
+
+bad_make:
+ fail (Error_Bad_Make(REB_TUPLE, arg));
}
-/***********************************************************************
-**
-*/ REBINT Cmp_Tuple(REBVAL *t1, REBVAL *t2)
-/*
-** Given two tuples, compare them.
-**
-***********************************************************************/
+//
+// TO_Tuple: C
+//
+void TO_Tuple(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBCNT len;
- REBYTE *vp1, *vp2;
- REBINT n;
-
- len = MAX(VAL_TUPLE_LEN(t1), VAL_TUPLE_LEN(t2));
- vp1 = VAL_TUPLE(t1);
- vp2 = VAL_TUPLE(t2);
-
- for (;len > 0; len--, vp1++,vp2++) {
- n = (REBINT)(*vp1 - *vp2);
- if (n != 0)
- return n;
- }
- return 0;
+ MAKE_Tuple(out, kind, arg);
}
-/***********************************************************************
-**
-*/ REBINT PD_Tuple(REBPVS *pvs)
-/*
-** Implements PATH and SET_PATH for tuple.
-** Sets DS_TOP if found. Always returns 0.
-**
-***********************************************************************/
+//
+// Cmp_Tuple: C
+//
+// Given two tuples, compare them.
+//
+REBINT Cmp_Tuple(const RELVAL *t1, const RELVAL *t2)
{
- REBVAL *val;
- REBINT n;
- REBINT i;
- REBYTE *dat;
- REBINT len;
-
- dat = VAL_TUPLE(pvs->value);
- len = VAL_TUPLE_LEN(pvs->value);
- if (len < 3) len = 3;
- n = Get_Num_Arg(pvs->select);
-
- if (NZ(val = pvs->setval)) {
- if (n <= 0 || n > MAX_TUPLE) return PE_BAD_SELECT;
- if (IS_INTEGER(val) || IS_DECIMAL(val)) i = Int32(val);
- else if (IS_NONE(val)) {
- n--;
- CLEAR(dat+n, MAX_TUPLE-n);
- VAL_TUPLE_LEN(pvs->value) = n;
- return PE_OK;
- }
- else return PE_BAD_SET;
- if (i < 0) i = 0;
- else if (i > 255) i = 255;
- dat[n-1] = i;
- if (n > len) VAL_TUPLE_LEN(pvs->value) = n;
- return PE_OK;
- } else {
- if (n > 0 && n <= len) {
- SET_INTEGER(pvs->store, dat[n-1]);
- return PE_USE;
- }
- else return PE_NONE;
- }
+ REBCNT len;
+ const REBYTE *vp1, *vp2;
+ REBINT n;
+
+ len = MAX(VAL_TUPLE_LEN(t1), VAL_TUPLE_LEN(t2));
+ vp1 = VAL_TUPLE(t1);
+ vp2 = VAL_TUPLE(t2);
+
+ for (;len > 0; len--, vp1++,vp2++) {
+ n = (REBINT)(*vp1 - *vp2);
+ if (n != 0)
+ return n;
+ }
+ return 0;
}
-/***********************************************************************
-**
-*/ REBINT Emit_Tuple(REBVAL *value, REBYTE *out)
-/*
-** The out array must be large enough to hold longest tuple.
-** Longest is: (3 digits + '.') * 11 nums + 1 term => 45
-**
-***********************************************************************/
+//
+// Pick_Tuple: C
+//
+void Pick_Tuple(REBVAL *out, const REBVAL *value, const REBVAL *picker)
{
- REBCNT len;
- REBYTE *tp;
- REBYTE *start = out;
-
- len = VAL_TUPLE_LEN(value);
- tp = (REBYTE *)VAL_TUPLE(value);
- for (; len > 0; len--, tp++) {
- out = Form_Int(out, *tp);
- *out++ = '.';
- }
-
- len = VAL_TUPLE_LEN(value);
- while (len++ < 3) {
- *out++ = '0';
- *out++ = '.';
- }
- *--out = 0;
-
- return out-start;
+ const REBYTE *dat = VAL_TUPLE(value);
+
+ REBINT len = VAL_TUPLE_LEN(value);
+ if (len < 3)
+ len = 3;
+
+ REBINT n = Get_Num_From_Arg(picker);
+ if (n > 0 && n <= len)
+ Init_Integer(out, dat[n - 1]);
+ else
+ Init_Void(out);
}
-/***********************************************************************
-**
-*/ REBTYPE(Tuple)
-/*
-***********************************************************************/
+//
+// Poke_Tuple_Immediate: C
+//
+// !!! Note: In the current implementation, tuples are immediate values.
+// So a POKE only changes the `value` in your hand.
+//
+void Poke_Tuple_Immediate(
+ REBVAL *value,
+ const REBVAL *picker,
+ const REBVAL *poke
+) {
+ REBYTE *dat = VAL_TUPLE(value);
+
+ REBINT len = VAL_TUPLE_LEN(value);
+ if (len < 3)
+ len = 3;
+
+ REBINT n = Get_Num_From_Arg(picker);
+ if (n <= 0 || n > cast(REBINT, MAX_TUPLE))
+ fail (Error_Out_Of_Range(picker));
+
+ REBINT i;
+ if (IS_INTEGER(poke) || IS_DECIMAL(poke))
+ i = Int32(poke);
+ else if (IS_BLANK(poke)) {
+ n--;
+ CLEAR(dat + n, MAX_TUPLE - n);
+ VAL_TUPLE_LEN(value) = n;
+ return;
+ }
+ else
+ fail (poke);
+
+ if (i < 0)
+ i = 0;
+ else if (i > 255)
+ i = 255;
+
+ dat[n - 1] = i;
+ if (n > len)
+ VAL_TUPLE_LEN(value) = n;
+}
+
+
+//
+// PD_Tuple: C
+//
+REBINT PD_Tuple(REBPVS *pvs)
{
- REBVAL *value;
- REBVAL *arg;
- REBYTE *vp;
- REBYTE *ap;
- REBINT len;
- REBINT alen;
- REBINT v;
- REBINT a;
- REBDEC dec;
-
- value = D_ARG(1);
- if (IS_TUPLE(value)) {
- vp = VAL_TUPLE(value);
- len = VAL_TUPLE_LEN(value);
- }
- arg = D_ARG(2);
-
- if (IS_BINARY_ACT(action)) {
- if (IS_INTEGER(arg)) {
- a = VAL_INT32(arg);
- ap = 0;
- } else if (IS_DECIMAL(arg) || IS_PERCENT(arg)) {
- dec=VAL_DECIMAL(arg);
- a = (REBINT)dec;
- ap = 0;
- } else if (IS_TUPLE(arg)) {
- ap = VAL_TUPLE(arg);
- alen = VAL_TUPLE_LEN(arg);
- if (len < alen)
- len = VAL_TUPLE_LEN(value) = alen;
- } else Trap_Math_Args(REB_TUPLE, action);
-
- for (;len > 0; len--, vp++) {
- v = *vp;
- if (ap)
- a = (REBINT) *ap++;
- switch (action) {
- case A_ADD: v += a; break;
- case A_SUBTRACT: v -= a; break;
- case A_MULTIPLY:
- if (IS_DECIMAL(arg) || IS_PERCENT(arg))
- v=(REBINT)(v*dec);
- else
- v *= a;
- break;
- case A_DIVIDE:
- if (IS_DECIMAL(arg) || IS_PERCENT(arg)) {
- if (dec == 0.0) Trap0(RE_ZERO_DIVIDE);
- v=(REBINT)Round_Dec(v/dec, 0, 1.0);
- } else {
- if (a == 0) Trap0(RE_ZERO_DIVIDE);
- v /= a;
- }
- break;
- case A_REMAINDER:
- if (a == 0) Trap0(RE_ZERO_DIVIDE);
- v %= a;
- break;
- case A_AND: v &= a; break;
- case A_OR: v |= a; break;
- case A_XOR: v ^= a; break;
- default:
- Trap_Action(REB_TUPLE, action);
- }
-
- if (v > 255) v = 255;
- else if (v < 0) v = 0;
- *vp = (REBYTE) v;
- }
- goto ret_value;
- }
-
- // !!!! merge with SWITCH below !!!
- if (action == A_COMPLEMENT) {
- for (;len > 0; len--, vp++)
- *vp = (REBYTE)~*vp;
- goto ret_value;
- }
- if (action == A_RANDOM) {
- if (D_REF(2)) Trap0(RE_BAD_REFINES); // seed
- for (;len > 0; len--, vp++) {
- if (*vp)
- *vp = (REBYTE)(Random_Int(D_REF(3)) % (1+*vp));
- }
- goto ret_value;
- }
-/*
- if (action == A_ZEROQ) {
- for (;len > 0; len--, vp++) {
- if (*vp != 0)
- goto is_false;
- }
- goto is_true;
- }
-*/
- //a = 1; //???
- switch (action) {
- case A_LENGTHQ:
- len = MAX(len, 3);
- DS_RET_INT(len);
- return R_RET;
-
- case A_PICK:
- Pick_Path(value, arg, 0);
- return R_TOS;
-
-/// case A_POKE:
-/// Pick_Path(value, arg, D_ARG(3));
-/// return R_ARG3;
-
- case A_REVERSE:
- if (D_REF(2)) {
- len = Get_Num_Arg(D_ARG(3));
- if (len < 0) Trap_Range(D_ARG(3));
- len = MIN(len, VAL_TUPLE_LEN(value));
- }
- if (len > 0) {
- //len = MAX(len, 3);
- for (v = 0; v < len/2; v++) {
- a = vp[len-v-1];
- vp[len-v-1] = vp[v];
- vp[v] = a;
- }
- }
- goto ret_value;
+ if (pvs->opt_setval) {
+ //
+ // !!! Is this a good idea? It means `x: 10.10.10 | y: (x/2: 20)` does
+ // result in y being 10.20.10, but x is unchanged.
+ //
+ Poke_Tuple_Immediate(
+ KNOWN(pvs->value), pvs->picker, pvs->opt_setval
+ );
+ return PE_OK;
+ }
+
+ Pick_Tuple(pvs->store, KNOWN(pvs->value), pvs->picker);
+ return PE_USE_STORE;
+}
+
+
+//
+// Emit_Tuple: C
+//
+// The out array must be large enough to hold longest tuple.
+// Longest is: (3 digits + '.') * 11 nums + 1 term => 45
+//
+REBINT Emit_Tuple(const REBVAL *value, REBYTE *out)
+{
+ REBCNT len = VAL_TUPLE_LEN(value);
+ const REBYTE *tp = cast(const REBYTE *, VAL_TUPLE(value));
+ REBYTE *start = out;
+
+ for (; len > 0; len--, tp++) {
+ out = Form_Int(out, *tp);
+ *out++ = '.';
+ }
+
+ len = VAL_TUPLE_LEN(value);
+ while (len++ < 3) {
+ *out++ = '0';
+ *out++ = '.';
+ }
+ *--out = 0;
+
+ return out-start;
+}
+
+
+//
+// REBTYPE: C
+//
+// !!! The TUPLE type from Rebol is something of an oddity, plus written as
+// more-or-less spaghetti code. It is likely to be replaced with something
+// generalized better, but is grudgingly kept working in the meantime.
+//
+REBTYPE(Tuple)
+{
+ REBVAL *value = D_ARG(1);
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+ const REBYTE *ap;
+ REBCNT len;
+ REBCNT alen;
+ REBINT a;
+ REBDEC dec;
+
+ assert(IS_TUPLE(value));
+
+ REBYTE *vp = VAL_TUPLE(value);
+ len = VAL_TUPLE_LEN(value);
+
+ // !!! This used to depend on "IS_BINARY_ACT", a concept that does not
+ // exist any longer with symbol-based action dispatch. Patch with more
+ // elegant mechanism.
+ //
+ if (
+ action == SYM_ADD
+ || action == SYM_SUBTRACT
+ || action == SYM_MULTIPLY
+ || action == SYM_DIVIDE
+ || action == SYM_REMAINDER
+ || action == SYM_AND_T
+ || action == SYM_OR_T
+ || action == SYM_XOR_T
+ ){
+ assert(vp);
+
+ if (IS_INTEGER(arg)) {
+ dec = -207.6382; // unused but avoid maybe uninitialized warning
+ a = VAL_INT32(arg);
+ ap = 0;
+ }
+ else if (IS_DECIMAL(arg) || IS_PERCENT(arg)) {
+ dec = VAL_DECIMAL(arg);
+ a = cast(REBINT, dec);
+ ap = 0;
+ }
+ else if (IS_TUPLE(arg)) {
+ dec = -251.8517; // unused but avoid maybe uninitialized warning
+ ap = VAL_TUPLE(arg);
+ alen = VAL_TUPLE_LEN(arg);
+ if (len < alen)
+ len = VAL_TUPLE_LEN(value) = alen;
+ a = 646699; // unused but avoid maybe uninitialized warning
+ }
+ else
+ fail (Error_Math_Args(REB_TUPLE, action));
+
+ for (;len > 0; len--, vp++) {
+ REBINT v = *vp;
+ if (ap)
+ a = (REBINT) *ap++;
+
+ switch (action) {
+ case SYM_ADD: v += a; break;
+
+ case SYM_SUBTRACT: v -= a; break;
+
+ case SYM_MULTIPLY:
+ if (IS_DECIMAL(arg) || IS_PERCENT(arg))
+ v = cast(REBINT, v * dec);
+ else
+ v *= a;
+ break;
+
+ case SYM_DIVIDE:
+ if (IS_DECIMAL(arg) || IS_PERCENT(arg)) {
+ if (dec == 0.0)
+ fail (Error_Zero_Divide_Raw());
+
+ v = cast(REBINT, Round_Dec(v / dec, 0, 1.0));
+ }
+ else {
+ if (a == 0)
+ fail (Error_Zero_Divide_Raw());
+ v /= a;
+ }
+ break;
+
+ case SYM_REMAINDER:
+ if (a == 0)
+ fail (Error_Zero_Divide_Raw());
+ v %= a;
+ break;
+
+ case SYM_AND_T:
+ v &= a;
+ break;
+
+ case SYM_OR_T:
+ v |= a;
+ break;
+
+ case SYM_XOR_T:
+ v ^= a;
+ break;
+
+ default:
+ fail (Error_Illegal_Action(REB_TUPLE, action));
+ }
+
+ if (v > 255) v = 255;
+ else if (v < 0) v = 0;
+ *vp = (REBYTE) v;
+ }
+ goto ret_value;
+ }
+
+ // !!!! merge with SWITCH below !!!
+ if (action == SYM_COMPLEMENT) {
+ for (;len > 0; len--, vp++)
+ *vp = (REBYTE)~*vp;
+ goto ret_value;
+ }
+ if (action == SYM_RANDOM) {
+ INCLUDE_PARAMS_OF_RANDOM;
+
+ UNUSED(PAR(value));
+
+ if (REF(only))
+ fail (Error_Bad_Refines_Raw());
+
+ if (REF(seed))
+ fail (Error_Bad_Refines_Raw());
+ for (; len > 0; len--, vp++) {
+ if (*vp)
+ *vp = cast(REBYTE, Random_Int(REF(secure)) % (1 + *vp));
+ }
+ goto ret_value;
+ }
+
+ switch (action) {
+ case SYM_LENGTH_OF:
+ len = MAX(len, 3);
+ Init_Integer(D_OUT, len);
+ return R_OUT;
+
+ case SYM_REVERSE: {
+ INCLUDE_PARAMS_OF_REVERSE;
+
+ UNUSED(PAR(series));
+
+ if (REF(part)) {
+ len = Get_Num_From_Arg(ARG(limit));
+ len = MIN(len, VAL_TUPLE_LEN(value));
+ }
+ if (len > 0) {
+ REBCNT i;
+ //len = MAX(len, 3);
+ for (i = 0; i < len/2; i++) {
+ a = vp[len - i - 1];
+ vp[len - i - 1] = vp[i];
+ vp[i] = a;
+ }
+ }
+ goto ret_value; }
/*
poke_it:
- a = Get_Num_Arg(arg);
- if (a <= 0 || a > len) {
- if (action == A_PICK) return R_NONE;
- Trap_Range(arg);
- }
- if (action == A_PICK) {
- DS_RET_INT(vp[a-1]);
- return R_RET;
- }
- // Poke:
- if (!IS_INTEGER(D_ARG(3))) Trap_Arg(D_ARG(3));
- v = VAL_INT32(D_ARG(3));
- if (v < 0)
- v = 0;
- if (v > 255)
- v = 255;
- vp[a-1] = v;
- goto ret_value;
+ a = Get_Num_From_Arg(arg);
+ if (a <= 0 || a > len) {
+ if (action == A_PICK) return R_BLANK;
+ fail (Error_Out_Of_Range(arg));
+ }
+ if (action == A_PICK) {
+ Init_Integer(D_OUT, vp[a-1]);
+ return R_OUT;
+ }
+ // Poke:
+ if (NOT(IS_INTEGER(D_ARG(3))))
+ fail (D_ARG(3));
+ v = VAL_INT32(D_ARG(3));
+ if (v < 0)
+ v = 0;
+ if (v > 255)
+ v = 255;
+ vp[a-1] = v;
+ goto ret_value;
*/
- case A_MAKE:
- case A_TO:
- if (IS_TUPLE(arg)) {
- return R_ARG2;
- }
- if (IS_STRING(arg)) {
- ap = Qualify_String(arg, 11*4+1, &len, FALSE); // can trap, ret diff str
- if (Scan_Tuple(ap, len, D_RET)) return R_RET;
- goto bad_arg;
- }
- if (ANY_BLOCK(arg)) {
- if (!MT_Tuple(D_RET, VAL_BLK_DATA(arg), REB_TUPLE)) Trap_Make(REB_TUPLE, arg);
- return R_RET;
- }
-
- VAL_SET(value, REB_TUPLE);
- vp = VAL_TUPLE(value);
- if (IS_ISSUE(arg)) {
- REBUNI c;
- ap = Get_Word_Name(arg);
- len = LEN_BYTES(ap); // UTF-8 len
- if (len & 1) goto bad_arg; // must have even # of chars
- len /= 2;
- if (len > MAX_TUPLE) goto bad_arg; // valid even for UTF-8
- VAL_TUPLE_LEN(value) = len;
- for (alen = 0; alen < len; alen++) {
- if (!Scan_Hex2(ap, &c, 0)) goto bad_arg;
- *vp++ = (REBYTE)c;
- ap += 2;
- }
- }
- else if (IS_BINARY(arg)) {
- ap = VAL_BIN_DATA(arg);
- len = VAL_LEN(arg);
- if (len > MAX_TUPLE) len = MAX_TUPLE;
- VAL_TUPLE_LEN(value) = len;
- for (alen = 0; alen < len; alen++) *vp++ = *ap++;
- }
- else goto bad_arg;
-
- for (; alen < MAX_TUPLE; alen++) *vp++ = 0;
- goto ret_value;
-
-bad_arg:
- Trap_Make(REB_TUPLE, arg);
- }
-
- Trap_Action(REB_TUPLE, action);
+ fail (Error_Bad_Make(REB_TUPLE, arg));
+
+ default:
+ break;
+ }
+
+ fail (Error_Illegal_Action(REB_TUPLE, action));
ret_value:
- *DS_RETURN = *value;
- return R_RET;
+ Move_Value(D_OUT, value);
+ return R_OUT;
}
diff --git a/src/core/t-typeset.c b/src/core/t-typeset.c
index 30b6370e5e..c2a828df8f 100644
--- a/src/core/t-typeset.c
+++ b/src/core/t-typeset.c
@@ -1,266 +1,339 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-typeset.c
-** Summary: typeset datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-typeset.c
+// Summary: "typeset datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-/***********************************************************************
-**
-*/ const REBU64 Typesets[] =
-/*
-** Order of symbols is important- used below for Make_Typeset().
-**
-************************************************************************/
-{
- 1, 0, // First (0th) typeset is not valid
- SYM_ANY_TYPEX, ((REBU64)1< 1)
- *Append_Frame(Lib_Context, 0, (REBCNT)(Typesets[n])) = *value;
- }
+ REBDSP dsp_orig = DSP;
+
+ REBINT n;
+ for (n = 0; Typesets[n].sym != 0; n++) {
+ //
+ // Note: the symbol in the typeset is not the symbol of a word holding
+ // the typesets, rather an extra data field used when the typeset is
+ // in a context key slot to identify that field's name
+ //
+ DS_PUSH_TRASH;
+ Init_Typeset(DS_TOP, Typesets[n].bits, NULL);
+
+ Move_Value(
+ Append_Context(Lib_Context, NULL, Canon(Typesets[n].sym)),
+ DS_TOP
+ );
+ }
+
+ Init_Block(ROOT_TYPESETS, Pop_Stack_Values(dsp_orig));
}
-/***********************************************************************
-**
-*/ REBFLG Make_Typeset(REBVAL *block, REBVAL *value, REBFLG load)
-/*
-** block - block of datatypes (datatype words ok too)
-** value - value to hold result (can be word-spec type too)
-**
-***********************************************************************/
+//
+// Init_Typeset: C
+//
+// Name should be set when a typeset is being used as a function parameter
+// specifier, or as a key in an object.
+//
+void Init_Typeset(RELVAL *value, REBU64 bits, REBSTR *opt_name)
{
- REBVAL *val;
- REBCNT sym;
- REBSER *types = VAL_SERIES(ROOT_TYPESETS);
-
- VAL_TYPESET(value) = 0;
-
- for (; NOT_END(block); block++) {
- val = 0;
- if (IS_WORD(block)) {
- //Print("word: %s", Get_Word_Name(block));
- sym = VAL_WORD_SYM(block);
- if (VAL_WORD_FRAME(block)) { // Get word value
- val = Get_Var(block);
- } else if (sym < REB_MAX) { // Accept datatype word
- TYPE_SET(value, VAL_WORD_SYM(block)-1);
- continue;
- } // Special typeset symbols:
- else if (sym >= SYM_ANY_TYPEX && sym <= SYM_ANY_BLOCKX)
- val = BLK_SKIP(types, sym - SYM_ANY_TYPEX + 1);
- }
- if (!val) val = block;
- if (IS_DATATYPE(val)) {
- TYPE_SET(value, VAL_DATATYPE(val));
- } else if (IS_TYPESET(val)) {
- VAL_TYPESET(value) |= VAL_TYPESET(val);
- } else {
- if (load) return FALSE;
- Trap_Arg(block);
- }
- }
-
- return TRUE;
+ VAL_RESET_HEADER(value, REB_TYPESET);
+ INIT_TYPESET_NAME(value, opt_name);
+ VAL_TYPESET_BITS(value) = bits;
}
-/***********************************************************************
-**
-*/ REBFLG MT_Typeset(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
-{
- if (!IS_BLOCK(data)) return FALSE;
-
- if (!Make_Typeset(VAL_BLK(data), out, TRUE)) return FALSE;
- VAL_SET(out, REB_TYPESET);
-
- return TRUE;
+//
+// Update_Typeset_Bits_Core: C
+//
+// This sets the bits in a bitset according to a block of datatypes. There
+// is special handling by which BAR! will set the "variadic" bit on the
+// typeset, which is heeded by functions only.
+//
+// !!! R3-Alpha supported fixed word symbols for datatypes and typesets.
+// Confusingly, this means that if you have said `word!: integer!` and use
+// WORD!, you will get the integer type... but if WORD! is unbound then it
+// will act as WORD!. Also, is essentially having "keywords" and should be
+// reviewed to see if anything actually used it.
+//
+REBOOL Update_Typeset_Bits_Core(
+ RELVAL *typeset,
+ const RELVAL head[],
+ REBSPC *specifier
+) {
+ assert(IS_TYPESET(typeset));
+ VAL_TYPESET_BITS(typeset) = 0;
+
+ const RELVAL *item = head;
+ if (NOT_END(item) && IS_BLOCK(item)) { // Double blocks signal variadic
+ if (NOT_END(item + 1))
+ fail ("Invalid double-block in typeset");
+
+ item = VAL_ARRAY_AT(item);
+ SET_VAL_FLAG(typeset, TYPESET_FLAG_VARIADIC);
+ }
+
+ for (; NOT_END(item); item++) {
+ const RELVAL *var = NULL;
+
+ if (IS_WORD(item))
+ var = Get_Opt_Var_May_Fail(item, specifier);
+
+ if (var == NULL)
+ var = item;
+
+ // Though MAKE FUNCTION! at its lowest level attempts to avoid any
+ // keywords, there are native-optimized function generators that do
+ // use them. Since this code is shared by both, it may or may not
+ // set typeset flags as a parameter. Default to always for now.
+ //
+ const REBOOL keywords = TRUE;
+
+ if (
+ keywords && IS_TAG(item) && (
+ 0 == Compare_String_Vals(item, ROOT_ELLIPSIS_TAG, TRUE)
+ )
+ ) {
+ // Notational convenience for variadic.
+ // func [x [<...> integer!]] => func [x [[integer!]]]
+ //
+ SET_VAL_FLAG(typeset, TYPESET_FLAG_VARIADIC);
+ }
+ else if (
+ IS_BAR(item) || (keywords && IS_TAG(item) && (
+ 0 == Compare_String_Vals(item, ROOT_END_TAG, TRUE)
+ ))
+ ) {
+ // A BAR! in a typeset spec for functions indicates a tolerance
+ // of endability. Notational convenience:
+ //
+ // func [x [ integer!]] => func [x [| integer!]]
+ //
+ SET_VAL_FLAG(typeset, TYPESET_FLAG_ENDABLE);
+ }
+ else if (
+ IS_BLANK(item) || (keywords && IS_TAG(item) && (
+ 0 == Compare_String_Vals(item, ROOT_OPT_TAG, TRUE)
+ ))
+ ) {
+ // A BLANK! in a typeset spec for functions indicates a willingness
+ // to take an optional. (This was once done with the "UNSET!"
+ // datatype, but now that there isn't a user-exposed unset data
+ // type this is not done.) Still, since REB_MAX_VOID is available
+ // internally it is used in the type filtering here.
+ //
+ // func [x [ integer!]] => func [x [_ integer!]]
+ //
+ // !!! As with BAR! for variadics, review if this makes sense to
+ // allow with `make typeset!` instead of just function specs.
+ // Note however that this is required for the legacy compatibility
+ // of ANY-TYPE!, which included UNSET! because it was a datatype
+ // in R3-Alpha and Rebol2.
+ //
+ TYPE_SET(typeset, REB_MAX_VOID);
+ }
+ else if (IS_DATATYPE(var)) {
+ TYPE_SET(typeset, VAL_TYPE_KIND(var));
+ }
+ else if (IS_TYPESET(var)) {
+ VAL_TYPESET_BITS(typeset) |= VAL_TYPESET_BITS(var);
+ }
+ else
+ fail (Error_Invalid_Arg_Core(item, specifier));
+ }
+
+ return TRUE;
}
-/***********************************************************************
-**
-*/ REBINT Find_Typeset(REBVAL *block)
-/*
-***********************************************************************/
+//
+// MAKE_Typeset: C
+//
+void MAKE_Typeset(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBVAL value;
- REBVAL *val;
- REBINT n;
+ assert(kind == REB_TYPESET);
+ UNUSED(kind);
- VAL_SET(&value, REB_TYPESET);
- Make_Typeset(block, &value, 0);
+ if (IS_TYPESET(arg)) {
+ Move_Value(out, arg);
+ return;
+ }
- val = VAL_BLK_SKIP(ROOT_TYPESETS, 1);
+ if (!IS_BLOCK(arg)) goto bad_make;
- for (n = 1; NOT_END(val); val++, n++) {
- if (EQUAL_TYPESET(&value, val)){
- //Print("FTS: %d", n);
- return n;
- }
- }
+ Init_Typeset(out, 0, NULL);
+ Update_Typeset_Bits_Core(out, VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg));
+ return;
-// Print("Size Typesets: %d", VAL_TAIL(ROOT_TYPESETS));
- Append_Val(VAL_SERIES(ROOT_TYPESETS), &value);
- return n;
+bad_make:
+ fail (Error_Bad_Make(REB_TYPESET, arg));
+}
+
+
+//
+// TO_Typeset: C
+//
+void TO_Typeset(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ MAKE_Typeset(out, kind, arg);
}
-/***********************************************************************
-**
-*/ REBSER *Typeset_To_Block(REBVAL *tset)
-/*
-** Converts typeset value to a block of datatypes.
-** No order is specified.
-**
-***********************************************************************/
+//
+// Typeset_To_Array: C
+//
+// Converts typeset value to a block of datatypes.
+// No order is specified.
+//
+REBARR *Typeset_To_Array(const REBVAL *tset)
{
- REBSER *block;
- REBVAL *value;
- REBINT n;
- REBINT size = 0;
-
- for (n = 0; n < REB_MAX; n++) {
- if (TYPE_CHECK(tset, n)) size++;
- }
-
- block = Make_Block(size);
-
- // Convert bits to types:
- for (n = 0; n < REB_MAX; n++) {
- if (TYPE_CHECK(tset, n)) {
- value = Append_Value(block);
- Set_Datatype(value, n);
- }
- }
- return block;
+ REBARR *block;
+ REBVAL *value;
+ REBINT n;
+ REBINT size = 0;
+
+ for (n = 0; n < REB_MAX; n++) {
+ if (TYPE_CHECK(tset, cast(enum Reb_Kind, n))) size++;
+ }
+
+ block = Make_Array(size);
+
+ // Convert bits to types:
+ for (n = 0; n < REB_MAX; n++) {
+ if (TYPE_CHECK(tset, cast(enum Reb_Kind, n))) {
+ value = Alloc_Tail_Array(block);
+ if (n == 0) {
+ //
+ // !!! A NONE! value is currently supported in typesets to
+ // indicate that they take optional values. This may wind up
+ // as a feature of MAKE FUNCTION! only.
+ //
+ Init_Blank(value);
+ }
+ else
+ Val_Init_Datatype(value, cast(enum Reb_Kind, n));
+ }
+ }
+ return block;
}
-/***********************************************************************
-**
-*/ REBTYPE(Typeset)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+REBTYPE(Typeset)
{
- REBVAL *val = D_ARG(1);
- REBVAL *arg = D_ARG(2);
-
- switch (action) {
-
- case A_FIND:
- if (IS_DATATYPE(arg)) {
- DECIDE(TYPE_CHECK(val, VAL_DATATYPE(arg)));
- }
- Trap_Arg(arg);
-
- case A_MAKE:
- case A_TO:
- if (IS_BLOCK(arg)) {
- VAL_SET(D_RET, REB_TYPESET);
- Make_Typeset(VAL_BLK_DATA(arg), D_RET, 0);
- return R_RET;
- }
- // if (IS_NONE(arg)) {
- // VAL_SET(arg, REB_TYPESET);
- // VAL_TYPESET(arg) = 0L;
- // return R_ARG2;
- // }
- if (IS_TYPESET(arg)) return R_ARG2;
- Trap_Make(REB_TYPESET, arg);
-
- case A_AND:
- case A_OR:
- case A_XOR:
- if (IS_DATATYPE(arg)) VAL_TYPESET(arg) = TYPESET(VAL_DATATYPE(arg));
- else if (!IS_TYPESET(arg)) Trap_Arg(arg);
-
- if (action == A_OR) VAL_TYPESET(val) |= VAL_TYPESET(arg);
- else if (action == A_AND) VAL_TYPESET(val) &= VAL_TYPESET(arg);
- else VAL_TYPESET(val) ^= VAL_TYPESET(arg);
- return R_ARG1;
-
- case A_COMPLEMENT:
- VAL_TYPESET(val) = ~VAL_TYPESET(val);
- return R_ARG1;
-
- default:
- Trap_Action(REB_TYPESET, action);
- }
-
-is_true:
- return R_TRUE;
-
-is_false:
- return R_FALSE;
+ REBVAL *val = D_ARG(1);
+ REBVAL *arg = D_ARGC > 1 ? D_ARG(2) : NULL;
+
+ switch (action) {
+
+ case SYM_FIND:
+ if (IS_DATATYPE(arg))
+ return R_FROM_BOOL(TYPE_CHECK(val, VAL_TYPE_KIND(arg)));
+
+ fail (arg);
+
+ case SYM_AND_T:
+ case SYM_OR_T:
+ case SYM_XOR_T:
+ if (IS_DATATYPE(arg)) {
+ VAL_TYPESET_BITS(arg) = FLAGIT_KIND(VAL_TYPE(arg));
+ }
+ else if (NOT(IS_TYPESET(arg)))
+ fail (arg);
+
+ if (action == SYM_OR_T)
+ VAL_TYPESET_BITS(val) |= VAL_TYPESET_BITS(arg);
+ else if (action == SYM_AND_T)
+ VAL_TYPESET_BITS(val) &= VAL_TYPESET_BITS(arg);
+ else
+ VAL_TYPESET_BITS(val) ^= VAL_TYPESET_BITS(arg);
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT;
+
+ case SYM_COMPLEMENT:
+ VAL_TYPESET_BITS(val) = ~VAL_TYPESET_BITS(val);
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT;
+
+ default:
+ fail (Error_Illegal_Action(REB_TYPESET, action));
+ }
}
diff --git a/src/core/t-utype.c b/src/core/t-utype.c
deleted file mode 100644
index dc968f183c..0000000000
--- a/src/core/t-utype.c
+++ /dev/null
@@ -1,94 +0,0 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-utype.c
-** Summary: user defined datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes: NOT IMPLEMENTED
-**
-***********************************************************************/
-
-#include "sys-core.h"
-
-#define SET_UTYPE(v,f) VAL_UTYPE_FUNC(v) = (f), VAL_UTYPE_DATA(v) = 0, VAL_SET(v, REB_UTYPE)
-
-
-/***********************************************************************
-**
-*/ REBINT CT_Utype(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
-{
- return FALSE;
-}
-
-
-/***********************************************************************
-**
-*/ REBFLG MT_Utype(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
-{
- return FALSE;
-}
-
-
-/***********************************************************************
-**
-*/ REBTYPE(Utype)
-/*
-***********************************************************************/
-{
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBVAL *spec;
- REBVAL *body;
-
- if (action == A_MAKE) {
- // MAKE udef! [spec body]
- if (IS_DATATYPE(value)) {
- if (!IS_BLOCK(arg)) Trap_Arg(arg);
- spec = VAL_BLK(arg);
- if (!IS_BLOCK(spec)) Trap_Arg(arg);
- body = VAL_BLK_SKIP(arg, 1);
- if (!IS_BLOCK(body)) Trap_Arg(arg);
-
- spec = Get_System(SYS_STANDARD, STD_UTYPE);
- if (!IS_OBJECT(spec)) Trap_Arg(spec);
- SET_UTYPE(D_RET, Make_Object(VAL_OBJ_FRAME(spec), body));
- VAL_UTYPE_DATA(D_RET) = 0;
- return R_RET;
- }
- else Trap_Arg(arg);
- }
-
- if (!IS_UTYPE(value)) Trap1(RE_INVALID_TYPE, Get_Type(REB_UTYPE));
-// if (!VAL_UTYPE_DATA(D_RET) || SERIES_TAIL(VAL_UTYPE_FUNC(value)) <= action)
-// Trap_Action(REB_UTYPE, action);
-
- body = OFV(VAL_UTYPE_FUNC(value), action);
- if (!IS_FUNCTION(body)) Trap_Action(REB_UTYPE, action);
-
- Do_Function(body);
-
- return R_RET;
-}
diff --git a/src/core/t-varargs.c b/src/core/t-varargs.c
new file mode 100644
index 0000000000..cc6abc2ae1
--- /dev/null
+++ b/src/core/t-varargs.c
@@ -0,0 +1,668 @@
+//
+// File: %t-varargs.h
+// Summary: "Variadic Argument Type and Services"
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2016-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// The VARARGS! data type implements an abstraction layer over a call frame
+// or arbitrary array of values. All copied instances of a REB_VARARGS value
+// remain in sync as values are TAKE-d out of them. Once they report
+// reaching a TAIL? they will always report TAIL?...until the call that
+// spawned them is off the stack, at which point they will report an error.
+//
+
+#include "sys-core.h"
+
+
+#define R_For_Vararg_End(op) \
+ ((op) == VARARG_OP_TAIL_Q ? R_TRUE : R_VOID)
+
+
+// Some VARARGS! are generated from a block with no frame, while others
+// have a frame. It would be inefficient to force the creation of a frame on
+// each call for a BLOCK!-based varargs. So rather than doing so, there's a
+// prelude which sees if it can answer the current query just from looking one
+// unit ahead.
+//
+inline static REB_R Vararg_Op_If_No_Advance(
+ REBVAL *out,
+ enum Reb_Vararg_Op op,
+ const RELVAL *look,
+ REBSPC *specifier,
+ enum Reb_Param_Class pclass
+){
+ if (IS_END(look))
+ return R_For_Vararg_End(op); // exhausted
+
+ if (IS_BAR(look)) {
+ //
+ // Only hard quotes are allowed to see BAR! (and if they do, they
+ // are *encouraged* to test the evaluated bit and error on literals,
+ // unless they have a *really* good reason to do otherwise)
+ //
+ if (pclass == PARAM_CLASS_HARD_QUOTE) {
+ if (op == VARARG_OP_TAIL_Q)
+ return R_FALSE;
+ if (op == VARARG_OP_FIRST) {
+ Init_Bar(out);
+ return R_OUT;
+ }
+ assert(op == VARARG_OP_TAKE);
+ return R_UNHANDLED; // advance frame/array to consume BAR!
+ }
+
+ return R_For_Vararg_End(op);
+ }
+
+ if (
+ (pclass == PARAM_CLASS_NORMAL || pclass == PARAM_CLASS_TIGHT)
+ && IS_WORD(look)
+ ){
+ // When a variadic argument is being TAKE-n, deferred left hand side
+ // argument needs to be seen as end of variadic input. Otherwise,
+ // `summation 1 2 3 |> 100` acts as `summation 1 2 (3 |> 100)`.
+ // Deferred operators need to act somewhat as an expression barrier.
+ //
+ // Same rule applies for "tight" arguments, `sum 1 2 3 + 4` with
+ // sum being variadic and tight needs to act as `(sum 1 2 3) + 4`
+ //
+ // Look ahead, and if actively bound see if it's to an enfix function
+ // and the rules apply. Note the raw check is faster, no need to
+ // separately test for IS_END()
+
+ const REBVAL *child_gotten = Get_Opt_Var_Else_End(look, specifier);
+
+ if (VAL_TYPE_OR_0(child_gotten) == REB_FUNCTION) {
+ if (GET_VAL_FLAG(child_gotten, VALUE_FLAG_ENFIXED)) {
+ if (
+ pclass == PARAM_CLASS_TIGHT
+ || GET_VAL_FLAG(child_gotten, FUNC_FLAG_DEFERS_LOOKBACK)
+ ){
+ return R_For_Vararg_End(op);
+ }
+ }
+ }
+ }
+
+ // The odd circumstances which make things simulate END--as well as an
+ // actual END--are all taken care of, so we're not "at the TAIL?"
+ //
+ if (op == VARARG_OP_TAIL_Q)
+ return R_FALSE;
+
+ if (op == VARARG_OP_FIRST) {
+ if (pclass != PARAM_CLASS_HARD_QUOTE)
+ fail (Error_Varargs_No_Look_Raw()); // hard quote only
+
+ Derelativize(out, look, specifier);
+ SET_VAL_FLAG(out, VALUE_FLAG_UNEVALUATED);
+
+ return R_OUT; // only a lookahead, no need to advance
+ }
+
+ return R_UNHANDLED; // must advance, may need to create a frame to do so
+}
+
+
+//
+// Do_Vararg_Op_May_Throw: C
+//
+// Service routine for working with a VARARGS!. Supports TAKE-ing or just
+// returning whether it's at the end or not. The TAKE is not actually a
+// destructive operation on underlying data--merely a semantic chosen to
+// convey feeding forward with no way to go back.
+//
+// Whether the parameter is quoted or evaluated is determined by the typeset
+// information of the `param`. The typeset in the param is also used to
+// check the result, and if an error is delivered it will use the name of
+// the parameter symbol in the fail() message.
+//
+// * returns THROWN_FLAG if it takes from an evaluating vararg that throws
+//
+// * returns END_FLAG if it reaches the end of an entire input chain
+//
+// * returns VA_LIST_FLAG if the input is not exhausted
+//
+// Note: Returning VA_LIST_FLAG is probably a lie, since the odds of the
+// underlying varargs being from a FRAME! running on a C `va_list` aren't
+// necessarily that high. For now it is a good enough signal simply because
+// it is not an index number, so it is an opaque way of saying "there is
+// still more data"--and it's the same type as END_FLAG and THROWN_FLAG.
+//
+REB_R Do_Vararg_Op_May_Throw(
+ REBVAL *out,
+ RELVAL *vararg,
+ enum Reb_Vararg_Op op
+) {
+ assert(IS_END(out));
+
+ const RELVAL *param; // for type checking
+ enum Reb_Param_Class pclass;
+
+ REBVAL *arg; // for updating VALUE_FLAG_UNEVALUATED
+ REBSTR *label;
+
+ if (vararg->extra.binding == NULL) {
+ //
+ // A vararg created from a block AND never passed as an argument
+ // so no typeset or quoting settings available. Treat as "normal"
+ // parameter.
+ //
+ assert(
+ NOT_SER_FLAG(
+ vararg->payload.varargs.feed, ARRAY_FLAG_VARLIST
+ )
+ );
+ pclass = PARAM_CLASS_NORMAL;
+ param = NULL; // doesn't correspond to a real varargs parameter
+ arg = NULL; // no corresponding varargs argument either
+ label = Canon(SYM___ANONYMOUS__);
+ }
+ else {
+ REBCTX *context = CTX(vararg->extra.binding);
+ REBFRM *param_frame = CTX_FRAME_IF_ON_STACK(context);
+
+ // If the VARARGS! has a call frame, then ensure that the call frame
+ // where the VARARGS! originated is still on the stack.
+ //
+ if (param_frame == NULL)
+ fail (Error_Varargs_No_Stack_Raw());
+
+ param = FUNC_FACADE_HEAD(param_frame->phase)
+ + vararg->payload.varargs.param_offset;
+ pclass = VAL_PARAM_CLASS(param);
+
+ arg = param_frame->args_head + vararg->payload.varargs.param_offset;
+
+ label = FRM_LABEL(param_frame);
+ }
+
+ REB_R r;
+
+ if (NOT_SER_FLAG(vararg->payload.varargs.feed, ARRAY_FLAG_VARLIST)) {
+ //
+ // We are processing an ANY-ARRAY!-based varargs, which came from
+ // either a MAKE VARARGS! on an ANY-ARRAY! value -or- from a
+ // MAKE ANY-ARRAY! on a varargs (which reified the varargs into an
+ // array during that creation, flattening its entire output).
+
+ REBARR *array1 = vararg->payload.varargs.feed;
+ REBVAL *shared = KNOWN(ARR_HEAD(array1));
+
+ assert(IS_END(shared) || (IS_BLOCK(shared) && ARR_LEN(array1) == 1));
+
+ r = Vararg_Op_If_No_Advance(
+ out,
+ op,
+ IS_END(shared) ? END : VAL_ARRAY_AT(shared),
+ IS_END(shared) ? SPECIFIED : VAL_SPECIFIER(shared),
+ pclass
+ );
+
+ if (r != R_UNHANDLED)
+ goto type_check_and_return;
+
+ switch (pclass) {
+ case PARAM_CLASS_NORMAL:
+ case PARAM_CLASS_TIGHT: {
+ DECLARE_FRAME (f);
+ Push_Frame_At(
+ f,
+ VAL_ARRAY(shared),
+ VAL_INDEX(shared),
+ VAL_SPECIFIER(shared),
+ pclass == PARAM_CLASS_NORMAL
+ ? DO_FLAG_FULFILLING_ARG
+ : DO_FLAG_FULFILLING_ARG | DO_FLAG_NO_LOOKAHEAD
+ );
+
+ // Note: Do_Next_In_Subframe_Throws() is not needed here because
+ // this is a single use frame, whose state can be overwritten.
+ //
+ if (Do_Next_In_Frame_Throws(out, f)) {
+ Drop_Frame(f);
+ return R_OUT_IS_THROWN;
+ }
+
+ if (IS_END(f->value))
+ SET_END(shared); // signal end to all varargs sharing value
+ else {
+ // The indexor is "prefetched", so though the temp_frame would
+ // be ready to use again we're throwing it away, and need to
+ // effectively "undo the prefetch" by taking it down by 1.
+ //
+ assert(f->index > 0);
+ VAL_INDEX(shared) = f->index - 1; // seen by all sharings
+ }
+
+ Drop_Frame(f);
+ break; }
+
+ case PARAM_CLASS_HARD_QUOTE:
+ Derelativize(out, VAL_ARRAY_AT(shared), VAL_SPECIFIER(shared));
+ SET_VAL_FLAG(out, VALUE_FLAG_UNEVALUATED);
+ VAL_INDEX(shared) += 1;
+ break;
+
+ case PARAM_CLASS_SOFT_QUOTE:
+ if (IS_QUOTABLY_SOFT(VAL_ARRAY_AT(shared))) {
+ if (Eval_Value_Core_Throws(
+ out, VAL_ARRAY_AT(shared), VAL_SPECIFIER(shared)
+ )){
+ return R_OUT_IS_THROWN;
+ }
+ }
+ else { // not a soft-"exception" case, quote ordinarily
+ Derelativize(out, VAL_ARRAY_AT(shared), VAL_SPECIFIER(shared));
+ SET_VAL_FLAG(out, VALUE_FLAG_UNEVALUATED);
+ }
+ VAL_INDEX(shared) += 1;
+ break;
+
+ default:
+ fail ("Invalid variadic parameter class");
+ }
+ }
+ else {
+ // "Ordinary" case... use the original frame implied by the VARARGS!
+ // (so long as it is still live on the stack)
+
+ REBCTX *context = CTX(vararg->payload.varargs.feed);
+ REBFRM *f = CTX_FRAME_IF_ON_STACK(context);
+ if (f == NULL)
+ fail (Error_Varargs_No_Stack_Raw());
+
+ r = Vararg_Op_If_No_Advance(
+ out,
+ op,
+ f->value,
+ f->specifier,
+ pclass
+ );
+
+ if (r != R_UNHANDLED)
+ goto type_check_and_return;
+
+ // Note that evaluative cases here need Do_Next_In_Subframe_Throws(),
+ // because a function is running and the frame state can't be
+ // overwritten by an arbitrary evaluation.
+ //
+ switch (pclass) {
+ case PARAM_CLASS_NORMAL:
+ if (Do_Next_In_Subframe_Throws(out, f, DO_FLAG_FULFILLING_ARG))
+ return R_OUT_IS_THROWN;
+ break;
+
+ case PARAM_CLASS_TIGHT:
+ if (Do_Next_In_Subframe_Throws(
+ out,
+ f,
+ DO_FLAG_FULFILLING_ARG | DO_FLAG_NO_LOOKAHEAD
+ )){
+ return R_OUT_IS_THROWN;
+ }
+ break;
+
+ case PARAM_CLASS_HARD_QUOTE:
+ Quote_Next_In_Frame(out, f);
+ break;
+
+ case PARAM_CLASS_SOFT_QUOTE:
+ if (IS_QUOTABLY_SOFT(f->value)) {
+ if (Eval_Value_Core_Throws(out, f->value, f->specifier))
+ return R_OUT_IS_THROWN;
+
+ Fetch_Next_In_Frame(f);
+ }
+ else { // not a soft-"exception" case, quote ordinarily
+ Quote_Next_In_Frame(out, f);
+ }
+ break;
+
+ default:
+ fail ("Invalid variadic parameter class");
+ }
+ }
+
+ r = R_OUT;
+
+type_check_and_return:
+ if (r != R_OUT) {
+ assert(
+ op == VARARG_OP_TAIL_Q ? r == R_TRUE || r == R_FALSE : r == R_VOID
+ );
+ return r;
+ }
+
+ assert(NOT(THROWN(out))); // should have returned above
+
+ if (param && NOT(TYPE_CHECK(param, VAL_TYPE(out))))
+ fail (Error_Arg_Type(label, param, VAL_TYPE(out)));
+
+ if (arg) {
+ if (GET_VAL_FLAG(out, VALUE_FLAG_UNEVALUATED))
+ SET_VAL_FLAG(arg, VALUE_FLAG_UNEVALUATED);
+ else
+ CLEAR_VAL_FLAG(arg, VALUE_FLAG_UNEVALUATED);
+ }
+
+ return R_OUT; // may be at end now, but reflect that at *next* call
+}
+
+
+//
+// MAKE_Varargs: C
+//
+void MAKE_Varargs(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ assert(kind == REB_VARARGS);
+ UNUSED(kind);
+
+ // With MAKE VARARGS! on an ANY-ARRAY!, the array is the backing store
+ // (shared) that the varargs interface cannot affect, but changes to
+ // the array will change the varargs.
+ //
+ if (ANY_ARRAY(arg)) {
+ //
+ // Make a single-element array to hold a reference+index to the
+ // incoming ANY-ARRAY!. This level of indirection means all
+ // VARARGS! copied from this will update their indices together.
+ //
+ REBARR *array1 = Alloc_Singular_Array();
+ Move_Value(ARR_HEAD(array1), arg);
+ MANAGE_ARRAY(array1);
+
+ VAL_RESET_HEADER(out, REB_VARARGS);
+ out->extra.binding = NULL;
+ #if !defined(NDEBUG)
+ out->payload.varargs.param_offset = -1020;
+ #endif
+ out->payload.varargs.feed = array1;
+
+ return;
+ }
+
+ // !!! Permit FRAME! ?
+
+ fail (Error_Bad_Make(REB_VARARGS, arg));
+}
+
+
+//
+// TO_Varargs: C
+//
+void TO_Varargs(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
+{
+ assert(kind == REB_VARARGS);
+ UNUSED(kind);
+
+ UNUSED(out);
+
+ fail (arg);
+}
+
+
+//
+// PD_Varargs: C
+//
+// Implements the PICK* operation.
+//
+REBINT PD_Varargs(REBPVS *pvs)
+{
+ if (NOT(IS_INTEGER(pvs->picker)))
+ fail (pvs->picker);
+
+ if (VAL_INT32(pvs->picker) != 1)
+ fail (Error_Varargs_No_Look_Raw());
+
+ DECLARE_LOCAL (specific);
+ Derelativize(specific, pvs->value, pvs->value_specifier);
+
+ REB_R r = Do_Vararg_Op_May_Throw(pvs->store, specific, VARARG_OP_FIRST);
+ if (r == R_OUT_IS_THROWN)
+ assert(FALSE); // VARARG_OP_FIRST can't throw
+ else if (r == R_VOID)
+ Init_Void(pvs->store);
+ else
+ assert(r == R_OUT);
+
+ return PE_USE_STORE;
+}
+
+
+//
+// REBTYPE: C
+//
+// Handles the very limited set of operations possible on a VARARGS!
+// (evaluation state inspector/modifier during a DO).
+//
+REBTYPE(Varargs)
+{
+ REBVAL *value = D_ARG(1);
+
+ switch (action) {
+ // !!! SYM_PICK_P moved into PD_Varargs functionality, which PICK* uses
+
+ case SYM_TAIL_Q: {
+ REB_R r = Do_Vararg_Op_May_Throw(
+ m_cast(REBVAL*, END), value, VARARG_OP_TAIL_Q // won't write `out`
+ );
+ assert(r == R_TRUE || r == R_FALSE); // cannot throw
+ return r; }
+
+ case SYM_TAKE_P: {
+ INCLUDE_PARAMS_OF_TAKE_P;
+
+ UNUSED(PAR(series));
+ if (REF(deep))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(last))
+ fail (Error_Varargs_Take_Last_Raw());
+
+ if (NOT(REF(part)))
+ return Do_Vararg_Op_May_Throw(D_OUT, value, VARARG_OP_TAKE);
+
+ REBDSP dsp_orig = DSP;
+
+ REBINT limit;
+ if (IS_INTEGER(ARG(limit))) {
+ limit = VAL_INT32(ARG(limit));
+ if (limit < 0)
+ limit = 0;
+ }
+ else if (IS_BAR(ARG(limit))) {
+ limit = 0; // not used, but avoid maybe uninitalized warning
+ }
+ else
+ fail (ARG(limit));
+
+ while (limit-- > 0) {
+ REB_R r = Do_Vararg_Op_May_Throw(D_OUT, value, VARARG_OP_TAKE);
+
+ if (r == R_OUT_IS_THROWN)
+ return R_OUT_IS_THROWN;
+ if (r == R_VOID)
+ break;
+ assert(r == R_OUT);
+
+ DS_PUSH(D_OUT);
+ }
+
+ // !!! What if caller wanted a REB_GROUP, REB_PATH, or an /INTO?
+ //
+ Init_Block(D_OUT, Pop_Stack_Values(dsp_orig));
+ return R_OUT;
+ }
+
+ default:
+ break;
+ }
+
+ fail (Error_Illegal_Action(REB_VARARGS, action));
+}
+
+
+//
+// CT_Varargs: C
+//
+// Simple comparison function stub (required for every type--rules TBD for
+// levels of "exactness" in equality checking, or sort-stable comparison.)
+//
+REBINT CT_Varargs(const RELVAL *a, const RELVAL *b, REBINT mode)
+{
+ cast(void, mode);
+
+ // !!! For the moment, say varargs are the same if they have the same
+ // source feed from which the data comes. (This check will pass even
+ // expired varargs, because the expired stub should be kept alive as
+ // long as its identity is needed).
+ //
+ if (a->payload.varargs.feed == b->payload.varargs.feed)
+ return 1;
+ return 0;
+}
+
+
+//
+// Mold_Varargs: C
+//
+// !!! The molding behavior was implemented to help with debugging the type,
+// but is not ready for prime-time. Rather than risk crashing or presenting
+// incomplete information, it's very minimal for now. Review after the
+// VARARGS! have stabilized somewhat just how much information can (or should)
+// be given when printing these out (they should not "lookahead")
+//
+void Mold_Varargs(const REBVAL *v, REB_MOLD *mold) {
+ assert(IS_VARARGS(v));
+
+ Pre_Mold(v, mold); // #[varargs! or make varargs!
+
+ Append_Codepoint_Raw(mold->series, '[');
+
+ if (v->extra.binding == NULL) {
+ Append_Unencoded(mold->series, "???");
+ }
+ else {
+ REBCTX *context = CTX(v->extra.binding);
+ REBFRM *param_frame = CTX_FRAME_IF_ON_STACK(context);
+
+ if (param_frame == NULL) {
+ Append_Unencoded(mold->series, "???");
+ }
+ else {
+ const RELVAL *param
+ = FUNC_FACADE_HEAD(param_frame->phase)
+ + v->payload.varargs.param_offset;
+
+ enum Reb_Param_Class pclass = VAL_PARAM_CLASS(param);
+ enum Reb_Kind kind;
+ switch (pclass) {
+ case PARAM_CLASS_NORMAL:
+ kind = REB_WORD;
+ break;
+
+ case PARAM_CLASS_TIGHT:
+ kind = REB_ISSUE;
+ break;
+
+ case PARAM_CLASS_HARD_QUOTE:
+ kind = REB_GET_WORD;
+ break;
+
+ case PARAM_CLASS_SOFT_QUOTE:
+ kind = REB_LIT_WORD;
+ break;
+
+ default:
+ panic (NULL);
+ };
+
+ // Note varargs_param is distinct from f->param!
+ DECLARE_LOCAL (param_word);
+ Init_Any_Word(
+ param_word, kind, VAL_PARAM_SPELLING(param)
+ );
+
+ Mold_Value(mold, param_word, TRUE);
+ }
+ }
+
+ Append_Unencoded(mold->series, " <= ");
+
+ REBARR *feed = v->payload.varargs.feed;
+
+ if (NOT_SER_FLAG(feed, ARRAY_FLAG_VARLIST)) {
+ REBARR *array1 = feed;
+
+ { // Just [...] for now
+ Append_Unencoded(mold->series, "[...]");
+ goto skip_complex_mold_for_now;
+ }
+
+ if (IS_END(ARR_HEAD(array1)))
+ Append_Unencoded(mold->series, "*exhausted*");
+ else
+ Mold_Value(mold, ARR_HEAD(array1), TRUE);
+ }
+ else if (NOT(IS_ARRAY_MANAGED(feed))) {
+ //
+ // This can happen if you internally try and PROBE() a varargs
+ // item that is residing in the argument slots for a function,
+ // while that function is still fulfilling its arguments.
+ //
+ Append_Unencoded(mold->series, "** varargs frame not fulfilled");
+ }
+ else {
+ REBCTX *context = CTX(feed);
+ REBFRM *f = CTX_FRAME_IF_ON_STACK(context);
+
+ if (f == NULL) {
+ Append_Unencoded(mold->series, "**unavailable: call ended **");
+ }
+ else {
+ {// Just [...] for now
+ Append_Unencoded(mold->series, "[...]");
+ goto skip_complex_mold_for_now;
+ }
+
+ if (IS_END(f->value))
+ Append_Unencoded(mold->series, "*exhausted*");
+ else {
+ Mold_Value(mold, f->value, TRUE);
+
+ if (f->flags.bits & DO_FLAG_VA_LIST)
+ Append_Unencoded(mold->series, "*C varargs, pending*");
+ else
+ Mold_Array_At(
+ mold, f->source.array, cast(REBCNT, f->index), NULL
+ );
+ }
+ }
+ }
+
+skip_complex_mold_for_now:
+ Append_Codepoint_Raw(mold->series, ']');
+
+ End_Mold(mold);
+}
diff --git a/src/core/t-vector.c b/src/core/t-vector.c
index f6cb0b2ce6..9be02f9152 100644
--- a/src/core/t-vector.c
+++ b/src/core/t-vector.c
@@ -1,669 +1,756 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-vector.c
-** Summary: vector datatype
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-vector.c
+// Summary: "vector datatype"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#define SET_VECTOR(v,s) VAL_SERIES(v)=(s), VAL_INDEX(v)=0, VAL_SET(v, REB_VECTOR)
+#define Init_Vector(v,s) \
+ Init_Any_Series((v), REB_VECTOR, (s))
// Encoding Format:
-// stored in series->size for now
-// [d d d d d d d d 0 0 0 0 t s b b]
+// stored in series->size for now
+// [d d d d d d d d 0 0 0 0 t s b b]
// Encoding identifiers:
enum {
- VTSI08 = 0,
- VTSI16,
- VTSI32,
- VTSI64,
-
- VTUI08,
- VTUI16,
- VTUI32,
- VTUI64,
-
- VTSF08, // not used
- VTSF16, // not used
- VTSF32,
- VTSF64,
+ VTSI08 = 0,
+ VTSI16,
+ VTSI32,
+ VTSI64,
+
+ VTUI08,
+ VTUI16,
+ VTUI32,
+ VTUI64,
+
+ VTSF08, // not used
+ VTSF16, // not used
+ VTSF32,
+ VTSF64
};
-#define VECT_TYPE(s) ((s)->size & 0xff)
+#define VECT_TYPE(s) ((s)->misc.size & 0xff)
static REBCNT bit_sizes[4] = {8, 16, 32, 64};
REBU64 f_to_u64(float n) {
- union {
- REBU64 u;
- REBDEC d;
- } t;
- t.d = n;
- return t.u;
+ union {
+ REBU64 u;
+ REBDEC d;
+ } t;
+ t.d = n;
+ return t.u;
}
-
+
REBU64 get_vect(REBCNT bits, REBYTE *data, REBCNT n)
{
- switch (bits) {
- case VTSI08:
- return (REBI64) ((char*)data)[n];
+ switch (bits) {
+ case VTSI08:
+ return (REBI64) ((i8*)data)[n];
+
+ case VTSI16:
+ return (REBI64) ((i16*)data)[n];
- case VTSI16:
- return (REBI64) ((short*)data)[n];
+ case VTSI32:
+ return (REBI64) ((i32*)data)[n];
- case VTSI32:
- return (REBI64) ((long*)data)[n];
+ case VTSI64:
+ return (REBI64) ((i64*)data)[n];
- case VTSI64:
- return (REBI64) ((i64*)data)[n];
+ case VTUI08:
+ return (REBU64) ((u8*)data)[n];
- case VTUI08:
- return (REBU64) ((unsigned char*)data)[n];
+ case VTUI16:
+ return (REBU64) ((u16*)data)[n];
- case VTUI16:
- return (REBU64) ((unsigned short*)data)[n];
+ case VTUI32:
+ return (REBU64) ((u32*)data)[n];
- case VTUI32:
- return (REBU64) ((unsigned long*)data)[n];
+ case VTUI64:
+ return (REBU64) ((i64*)data)[n];
- case VTUI64:
- return (REBU64) ((i64*)data)[n];
+ case VTSF08:
+ case VTSF16:
+ case VTSF32:
+ return f_to_u64(((float*)data)[n]);
- case VTSF08:
- case VTSF16:
- case VTSF32:
- return f_to_u64(((float*)data)[n]);
-
- case VTSF64:
- return ((REBU64*)data)[n];
- }
+ case VTSF64:
+ return ((REBU64*)data)[n];
+ }
- return 0;
+ return 0;
}
void set_vect(REBCNT bits, REBYTE *data, REBCNT n, REBI64 i, REBDEC f) {
- switch (bits) {
-
- case VTSI08:
- ((char*)data)[n] = (char)i;
- break;
-
- case VTSI16:
- ((short*)data)[n] = (short)i;
- break;
-
- case VTSI32:
- ((long*)data)[n] = (long)i;
- break;
-
- case VTSI64:
- ((i64*)data)[n] = (i64)i;
- break;
-
- case VTUI08:
- ((unsigned char*)data)[n] = (unsigned char)i;
- break;
-
- case VTUI16:
- ((unsigned short*)data)[n] = (unsigned short)i;
- break;
-
- case VTUI32:
- ((unsigned long*)data)[n] = (unsigned long)i;
- break;
-
- case VTUI64:
- ((i64*)data)[n] = (u64)i;
- break;
-
- case VTSF08:
- case VTSF16:
- case VTSF32:
- ((float*)data)[n] = (float)f;
- break;
-
- case VTSF64:
- ((double*)data)[n] = f;
- break;
- }
+ switch (bits) {
+
+ case VTSI08:
+ ((i8*)data)[n] = (i8)i;
+ break;
+
+ case VTSI16:
+ ((i16*)data)[n] = (i16)i;
+ break;
+
+ case VTSI32:
+ ((i32*)data)[n] = (i32)i;
+ break;
+
+ case VTSI64:
+ ((i64*)data)[n] = (i64)i;
+ break;
+
+ case VTUI08:
+ ((u8*)data)[n] = (u8)i;
+ break;
+
+ case VTUI16:
+ ((u16*)data)[n] = (u16)i;
+ break;
+
+ case VTUI32:
+ ((u32*)data)[n] = (u32)i;
+ break;
+
+ case VTUI64:
+ ((i64*)data)[n] = (u64)i;
+ break;
+
+ case VTSF08:
+ case VTSF16:
+ case VTSF32:
+ ((float*)data)[n] = (float)f;
+ break;
+
+ case VTSF64:
+ ((double*)data)[n] = f;
+ break;
+ }
}
-void Set_Vector_Row(REBSER *ser, REBVAL *blk)
+void Set_Vector_Row(REBSER *ser, const REBVAL *blk)
{
- REBCNT idx = VAL_INDEX(blk);
- REBCNT len = VAL_LEN(blk);
- REBVAL *val;
- REBCNT n = 0;
- REBCNT bits = VECT_TYPE(ser);
- REBI64 i = 0;
- REBDEC f = 0;
-
- if (IS_BLOCK(blk)) {
- val = VAL_BLK_DATA(blk);
-
- for (; NOT_END(val); val++) {
- if (IS_INTEGER(val)) {
- i = VAL_INT64(val);
- if (bits > VTUI64) f = (REBDEC)(i);
- }
- else if (IS_DECIMAL(val)) {
- f = VAL_DECIMAL(val);
- if (bits <= VTUI64) i = (REBINT)(f);
- }
- else Trap_Arg(val);
- //if (n >= ser->tail) Expand_Vector(ser);
- set_vect(bits, ser->data, n++, i, f);
- }
- }
- else {
- REBYTE *data = VAL_BIN_DATA(blk);
- for (; len > 0; len--, idx++) {
- set_vect(bits, ser->data, n++, (REBI64)(data[idx]), f);
- }
- }
+ REBCNT idx = VAL_INDEX(blk);
+ REBCNT len = VAL_LEN_AT(blk);
+ RELVAL *val;
+ REBCNT n = 0;
+ REBCNT bits = VECT_TYPE(ser);
+ REBI64 i = 0;
+ REBDEC f = 0;
+
+ if (IS_BLOCK(blk)) {
+ val = VAL_ARRAY_AT(blk);
+
+ for (; NOT_END(val); val++) {
+ if (IS_INTEGER(val)) {
+ i = VAL_INT64(val);
+ if (bits > VTUI64) f = (REBDEC)(i);
+ }
+ else if (IS_DECIMAL(val)) {
+ f = VAL_DECIMAL(val);
+ if (bits <= VTUI64) i = (REBINT)(f);
+ }
+ else fail (Error_Invalid_Arg_Core(val, VAL_SPECIFIER(blk)));
+ //if (n >= ser->tail) Expand_Vector(ser);
+ set_vect(bits, SER_DATA_RAW(ser), n++, i, f);
+ }
+ }
+ else {
+ REBYTE *data = VAL_BIN_AT(blk);
+ for (; len > 0; len--, idx++) {
+ set_vect(
+ bits, SER_DATA_RAW(ser), n++, cast(REBI64, data[idx]), f
+ );
+ }
+ }
}
-/***********************************************************************
-**
-*/ REBSER *Make_Vector_Block(REBVAL *vect)
-/*
-** Convert a vector to a block.
-**
-***********************************************************************/
+//
+// Vector_To_Array: C
+//
+// Convert a vector to a block.
+//
+REBARR *Vector_To_Array(const REBVAL *vect)
{
- REBCNT len = VAL_LEN(vect);
- REBYTE *data = VAL_SERIES(vect)->data;
- REBCNT type = VECT_TYPE(VAL_SERIES(vect));
- REBSER *ser = Make_Block(len);
- REBCNT n;
- REBVAL *val;
-
- if (len > 0) {
- val = BLK_HEAD(ser);
- for (n = VAL_INDEX(vect); n < VAL_TAIL(vect); n++, val++) {
- VAL_SET(val, (type >= VTSF08) ? REB_DECIMAL : REB_INTEGER);
- VAL_INT64(val) = get_vect(type, data, n); // can be int or decimal
- }
- }
-
- SET_END(val);
- ser->tail = len;
-
- return ser;
+ REBCNT len = VAL_LEN_AT(vect);
+ if (len <= 0)
+ fail (vect);
+
+ REBARR *array = Make_Array(len);
+
+ REBYTE *data = SER_DATA_RAW(VAL_SERIES(vect));
+ REBCNT type = VECT_TYPE(VAL_SERIES(vect));
+
+ RELVAL *val = ARR_HEAD(array);
+ REBCNT n;
+ for (n = VAL_INDEX(vect); n < VAL_LEN_HEAD(vect); n++, val++) {
+ VAL_RESET_HEADER(val, (type >= VTSF08) ? REB_DECIMAL : REB_INTEGER);
+ VAL_INT64(val) = get_vect(type, data, n); // can be int or decimal
+ }
+
+ TERM_ARRAY_LEN(array, len);
+ assert(IS_END(val));
+
+ return array;
}
-/***********************************************************************
-**
-*/ REBINT Compare_Vector(REBVAL *v1, REBVAL *v2)
-/*
-***********************************************************************/
+//
+// Compare_Vector: C
+//
+REBINT Compare_Vector(const RELVAL *v1, const RELVAL *v2)
{
- REBCNT l1 = VAL_LEN(v1);
- REBCNT l2 = VAL_LEN(v2);
- REBCNT len = MIN(l1, l2);
- REBCNT n;
- REBU64 i1;
- REBU64 i2;
- REBYTE *d1 = VAL_SERIES(v1)->data;
- REBYTE *d2 = VAL_SERIES(v2)->data;
- REBCNT b1 = VECT_TYPE(VAL_SERIES(v1));
- REBCNT b2 = VECT_TYPE(VAL_SERIES(v2));
-
- if (
- (b1 >= VTSF08 && b2 < VTSF08)
- || (b2 >= VTSF08 && b1 < VTSF08)
- ) Trap0(RE_NOT_SAME_TYPE);
-
- for (n = 0; n < len; n++) {
- i1 = get_vect(b1, d1, n + VAL_INDEX(v1));
- i2 = get_vect(b2, d2, n + VAL_INDEX(v2));
- if (i1 != i2) break;
- }
-
- if (n != len) {
- if (i1 > i2) return 1;
- return -1;
- }
-
- return l1 - l2;
+ REBCNT l1 = VAL_LEN_AT(v1);
+ REBCNT l2 = VAL_LEN_AT(v2);
+ REBCNT len = MIN(l1, l2);
+ REBCNT n;
+ REBU64 i1;
+ REBU64 i2;
+ REBYTE *d1 = SER_DATA_RAW(VAL_SERIES(v1));
+ REBYTE *d2 = SER_DATA_RAW(VAL_SERIES(v2));
+ REBCNT b1 = VECT_TYPE(VAL_SERIES(v1));
+ REBCNT b2 = VECT_TYPE(VAL_SERIES(v2));
+
+ if ((b1 >= VTSF08 && b2 < VTSF08) || (b2 >= VTSF08 && b1 < VTSF08))
+ fail (Error_Not_Same_Type_Raw());
+
+ for (n = 0; n < len; n++) {
+ i1 = get_vect(b1, d1, n + VAL_INDEX(v1));
+ i2 = get_vect(b2, d2, n + VAL_INDEX(v2));
+ if (i1 != i2) break;
+ }
+
+ if (n != len) {
+ if (i1 > i2) return 1;
+ return -1;
+ }
+
+ return l1 - l2;
}
-/***********************************************************************
-**
-*/ void Shuffle_Vector(REBVAL *vect, REBFLG secure)
-/*
-***********************************************************************/
+//
+// Shuffle_Vector: C
+//
+void Shuffle_Vector(REBVAL *vect, REBOOL secure)
{
- REBCNT n;
- REBCNT k;
- REBU64 swap;
- REBYTE *data = VAL_SERIES(vect)->data;
- REBCNT type = VECT_TYPE(VAL_SERIES(vect));
- REBCNT idx = VAL_INDEX(vect);
-
- // We can do it as INTS, because we just deal with the bits:
- if (type == VTSF32) type = VTUI32;
- else if (type == VTSF64) type = VTUI64;
-
- for (n = VAL_LEN(vect); n > 1;) {
- k = idx + (REBCNT)Random_Int(secure) % n;
- n--;
- swap = get_vect(type, data, k);
- set_vect(type, data, k, get_vect(type, data, n + idx), 0);
- set_vect(type, data, n + idx, swap, 0);
- }
+ REBCNT n;
+ REBCNT k;
+ REBU64 swap;
+ REBYTE *data = SER_DATA_RAW(VAL_SERIES(vect));
+ REBCNT type = VECT_TYPE(VAL_SERIES(vect));
+ REBCNT idx = VAL_INDEX(vect);
+
+ // We can do it as INTS, because we just deal with the bits:
+ if (type == VTSF32) type = VTUI32;
+ else if (type == VTSF64) type = VTUI64;
+
+ for (n = VAL_LEN_AT(vect); n > 1;) {
+ k = idx + (REBCNT)Random_Int(secure) % n;
+ n--;
+ swap = get_vect(type, data, k);
+ set_vect(type, data, k, get_vect(type, data, n + idx), 0);
+ set_vect(type, data, n + idx, swap, 0);
+ }
}
-/***********************************************************************
-**
-*/ void Set_Vector_Value(REBVAL *var, REBSER *series, REBCNT index)
-/*
-***********************************************************************/
+//
+// Set_Vector_Value: C
+//
+void Set_Vector_Value(REBVAL *var, REBSER *series, REBCNT index)
{
- REBYTE *data = series->data;
- REBCNT bits = VECT_TYPE(series);
-
- var->data.integer = get_vect(bits, data, index);
- if (bits >= VTSF08) SET_TYPE(var, REB_DECIMAL);
- else SET_TYPE(var, REB_INTEGER);
+ REBYTE *data = SER_DATA_RAW(series);
+ REBCNT bits = VECT_TYPE(series);
+
+ if (bits >= VTSF08) {
+ VAL_RESET_HEADER(var, REB_DECIMAL);
+ REBU64 u = get_vect(bits, data, index);
+ Init_Decimal_Bits(var, cast(REBYTE*, &u));
+ }
+ else {
+ VAL_RESET_HEADER(var, REB_INTEGER);
+ VAL_INT64(var) = get_vect(bits, data, index);
+ }
}
-/***********************************************************************
-**
-*/ REBSER *Make_Vector(REBINT type, REBINT sign, REBINT dims, REBINT bits, REBINT size)
-/*
-** type: the datatype
-** sign: signed or unsigned
-** dims: number of dimensions
-** bits: number of bits per unit (8, 16, 32, 64)
-** size: size of array ?
-**
-***********************************************************************/
+//
+// Make_Vector: C
+//
+// type: the datatype
+// sign: signed or unsigned
+// dims: number of dimensions
+// bits: number of bits per unit (8, 16, 32, 64)
+// size: size of array ?
+//
+REBSER *Make_Vector(REBINT type, REBINT sign, REBINT dims, REBINT bits, REBINT size)
{
- REBCNT len;
- REBSER *ser;
-
- len = size * dims;
- if (len > 0x7fffffff) return 0;
- ser = Make_Series(len+1, bits/8, TRUE); // !!! can width help extend the len?
- LABEL_SERIES(ser, "make vector");
- CLEAR(ser->data, len*bits/8);
- ser->tail = len; // !!! another way to do it?
-
- // Store info about the vector (could be moved to flags if necessary):
- switch (bits) {
- case 8: bits = 0; break;
- case 16: bits = 1; break;
- case 32: bits = 2; break;
- case 64: bits = 3; break;
- }
- ser->size = (dims << 8) | (type << 3) | (sign << 2) | bits;
-
- return ser;
+ REBCNT len = size * dims;
+ if (len > 0x7fffffff)
+ fail ("vector size too big");
+
+ REBSER *ser = Make_Series_Core(len + 1, bits/8, SERIES_FLAG_POWER_OF_2);
+ CLEAR(SER_DATA_RAW(ser), (len * bits) / 8);
+ SET_SERIES_LEN(ser, len);
+
+ // Store info about the vector (could be moved to flags if necessary):
+ switch (bits) {
+ case 8: bits = 0; break;
+ case 16: bits = 1; break;
+ case 32: bits = 2; break;
+ case 64: bits = 3; break;
+ }
+ ser->misc.size = (dims << 8) | (type << 3) | (sign << 2) | bits;
+
+ return ser;
}
-/***********************************************************************
-**
-*/ REBVAL *Make_Vector_Spec(REBVAL *bp, REBVAL *value)
-/*
-** Make a vector from a block spec.
-**
-** make vector! [integer! 32 100]
-** make vector! [decimal! 64 100]
-** make vector! [unsigned integer! 32]
-** Fields:
-** signed: signed, unsigned
-** datatypes: integer, decimal
-** dimensions: 1 - N
-** bitsize: 1, 8, 16, 32, 64
-** size: integer units
-** init: block of values
-**
-***********************************************************************/
+
+//
+// Make_Vector_Spec: C
+//
+// Make a vector from a block spec.
+//
+// make vector! [integer! 32 100]
+// make vector! [decimal! 64 100]
+// make vector! [unsigned integer! 32]
+// Fields:
+// signed: signed, unsigned
+// datatypes: integer, decimal
+// dimensions: 1 - N
+// bitsize: 1, 8, 16, 32, 64
+// size: integer units
+// init: block of values
+//
+REBOOL Make_Vector_Spec(REBVAL *out, const RELVAL head[], REBSPC *specifier)
{
- REBINT type = -1; // 0 = int, 1 = float
- REBINT sign = -1; // 0 = signed, 1 = unsigned
- REBINT dims = 1;
- REBINT bits = 32;
- REBCNT size = 1;
- REBSER *vect;
- REBVAL *iblk = 0;
-
- // UNSIGNED
- if (IS_WORD(bp) && VAL_WORD_CANON(bp) == SYM_UNSIGNED) {
- sign = 1;
- bp++;
- }
-
- // INTEGER! or DECIMAL!
- if (IS_WORD(bp)) {
- if (VAL_WORD_CANON(bp) == (REB_INTEGER+1)) // integer! symbol
- type = 0;
- else if (VAL_WORD_CANON(bp) == (REB_DECIMAL+1)) { // decimal! symbol
- type = 1;
- if (sign > 0) return 0;
- }
- else return 0;
- bp++;
- }
-
- if (type < 0) type = 0;
- if (sign < 0) sign = 0;
-
- // BITS
- if (IS_INTEGER(bp)) {
- bits = Int32(bp);
- if (
- (bits == 32 || bits == 64)
- ||
- (type == 0 && (bits == 8 || bits == 16))
- ) bp++;
- else return 0;
- } else return 0;
-
- // SIZE
- if (IS_INTEGER(bp)) {
- size = Int32(bp);
- if (size < 0) return 0;
- bp++;
- }
-
- // Initial data:
- if (IS_BLOCK(bp) || IS_BINARY(bp)) {
- REBCNT len = VAL_LEN(bp);
- if (IS_BINARY(bp) && type == 1) return 0;
- if (len > size) size = len;
- iblk = bp;
- bp++;
- }
-
- // Index offset:
- if (IS_INTEGER(bp)) {
- VAL_INDEX(value) = (Int32s(bp, 1) - 1);
- bp++;
- }
- else VAL_INDEX(value) = 0;
-
- if (NOT_END(bp)) return 0;
-
- vect = Make_Vector(type, sign, dims, bits, size);
- if (!vect) return 0;
-
- if (iblk) Set_Vector_Row(vect, iblk);
-
- SET_TYPE(value, REB_VECTOR);
- VAL_SERIES(value) = vect;
- // index set earlier
-
- return value;
+ REBINT type = -1; // 0 = int, 1 = float
+ REBINT sign = -1; // 0 = signed, 1 = unsigned
+ REBINT dims = 1;
+ REBINT bits = 32;
+ REBCNT size = 1;
+
+ const RELVAL *item = head;
+
+ if (specifier) {
+ //
+ // The specifier would be needed if variables were going to be looked
+ // up, but isn't required for just symbol comparisons or extracting
+ // integer values.
+ }
+
+ // UNSIGNED
+ if (IS_WORD(item) && VAL_WORD_SYM(item) == SYM_UNSIGNED) {
+ sign = 1;
+ ++item;
+ }
+
+ // INTEGER! or DECIMAL!
+ if (IS_WORD(item)) {
+ if (SAME_SYM_NONZERO(VAL_WORD_SYM(item), SYM_FROM_KIND(REB_INTEGER)))
+ type = 0;
+ else if (
+ SAME_SYM_NONZERO(VAL_WORD_SYM(item), SYM_FROM_KIND(REB_DECIMAL))
+ ){
+ type = 1;
+ if (sign > 0)
+ return FALSE;
+ }
+ else
+ return FALSE;
+ ++item;
+ }
+
+ if (type < 0)
+ type = 0;
+ if (sign < 0)
+ sign = 0;
+
+ // BITS
+ if (IS_INTEGER(item)) {
+ bits = Int32(item);
+ if (
+ (bits == 32 || bits == 64)
+ || (type == 0 && (bits == 8 || bits == 16))
+ ){
+ ++item;
+ }
+ else
+ return FALSE;
+ }
+ else
+ return FALSE;
+
+ // SIZE
+ if (NOT_END(item) && IS_INTEGER(item)) {
+ if (Int32(item) < 0)
+ return FALSE;
+ size = Int32(item);
+ ++item;
+ }
+
+ // Initial data:
+
+ const REBVAL *iblk;
+ if (NOT_END(item) && (IS_BLOCK(item) || IS_BINARY(item))) {
+ REBCNT len = VAL_LEN_AT(item);
+ if (IS_BINARY(item) && type == 1)
+ return FALSE;
+ if (len > size)
+ size = len;
+ iblk = const_KNOWN(item);
+ ++item;
+ }
+ else
+ iblk = NULL;
+
+ // Index offset:
+ REBCNT index;
+ if (NOT_END(item) && IS_INTEGER(item)) {
+ index = (Int32s(item, 1) - 1);
+ ++item;
+ }
+ else
+ index = 0;
+
+ if (NOT_END(item))
+ return FALSE;
+
+ REBSER *vect = Make_Vector(type, sign, dims, bits, size);
+ if (vect == NULL)
+ return FALSE;
+
+ if (iblk != NULL)
+ Set_Vector_Row(vect, iblk);
+
+ Init_Any_Series_At(out, REB_VECTOR, vect, index);
+ return TRUE;
}
-/***********************************************************************
-**
-*/ REBFLG MT_Vector(REBVAL *out, REBVAL *data, REBCNT type)
-/*
-***********************************************************************/
+//
+// MAKE_Vector: C
+//
+void MAKE_Vector(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- if (Make_Vector_Spec(data, out)) return TRUE;
- return FALSE;
+ // CASE: make vector! 100
+ if (IS_INTEGER(arg) || IS_DECIMAL(arg)) {
+ REBINT size = Int32s(arg, 0);
+ if (size < 0) goto bad_make;
+ REBSER *ser = Make_Vector(0, 0, 1, 32, size);
+ Init_Vector(out, ser);
+ return;
+ }
+
+ TO_Vector(out, kind, arg); // may fail()
+ return;
+
+bad_make:
+ fail (Error_Bad_Make(kind, arg));
}
-/***********************************************************************
-**
-*/ REBINT CT_Vector(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// TO_Vector: C
+//
+void TO_Vector(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBINT n = Compare_Vector(a, b); // needs to be expanded for equality
- if (mode >= 0) {
- return n == 0;
- }
- if (mode == -1) return n >= 0;
- return n > 0;
+ if (IS_BLOCK(arg)) {
+ if (Make_Vector_Spec(out, VAL_ARRAY_AT(arg), VAL_SPECIFIER(arg)))
+ return;
+ }
+ fail (Error_Bad_Make(kind, arg));
}
-/***********************************************************************
-**
-*/ REBINT PD_Vector(REBPVS *pvs)
-/*
-***********************************************************************/
+//
+// CT_Vector: C
+//
+REBINT CT_Vector(const RELVAL *a, const RELVAL *b, REBINT mode)
{
- REBSER *vect;
- REBINT n;
- REBINT dims;
- REBINT bits;
- REBYTE *vp;
- REBI64 i;
- REBDEC f;
-
- if (IS_INTEGER(pvs->select) || IS_DECIMAL(pvs->select))
- n = Int32(pvs->select);
- else return PE_BAD_SELECT;
-
- n += VAL_INDEX(pvs->value);
- vect = VAL_SERIES(pvs->value);
- vp = vect->data;
- bits = VECT_TYPE(vect);
- dims = vect->size >> 8;
-
- if (pvs->setval == 0) {
-
- // Check range:
- if (n <= 0 || (REBCNT)n > vect->tail) return PE_NONE;
-
- // Get element value:
- pvs->store->data.integer = get_vect(bits, vp, n-1); // 64 bits
- if (bits < VTSF08) {
- SET_TYPE(pvs->store, REB_INTEGER);
- } else {
- SET_TYPE(pvs->store, REB_DECIMAL);
- }
-
- return PE_USE;
- }
-
- //--- Set Value...
- TRAP_PROTECT(vect);
-
- if (n <= 0 || (REBCNT)n > vect->tail) return PE_BAD_RANGE;
-
- if (IS_INTEGER(pvs->setval)) {
- i = VAL_INT64(pvs->setval);
- if (bits > VTUI64) f = (REBDEC)(i);
- }
- else if (IS_DECIMAL(pvs->setval)) {
- f = VAL_DECIMAL(pvs->setval);
- if (bits <= VTUI64) i = (REBINT)(f);
- }
- else return PE_BAD_SET;
-
- set_vect(bits, vp, n-1, i, f);
-
- return PE_OK;
+ REBINT n = Compare_Vector(a, b); // needs to be expanded for equality
+ if (mode >= 0) {
+ return n == 0;
+ }
+ if (mode == -1) return n >= 0;
+ return n > 0;
}
-/***********************************************************************
-**
-*/ REBTYPE(Vector)
-/*
-***********************************************************************/
+//
+// Pick_Vector: C
+//
+void Pick_Vector(REBVAL *out, const REBVAL *value, const REBVAL *picker) {
+ REBSER *vect = VAL_SERIES(value);
+
+ REBINT n;
+ if (IS_INTEGER(picker) || IS_DECIMAL(picker))
+ n = Int32(picker);
+ else
+ fail (picker);
+
+ n += VAL_INDEX(value);
+
+ if (n <= 0 || cast(REBCNT, n) > SER_LEN(vect)) {
+ Init_Void(out); // out of range of vector data
+ return;
+ }
+
+ REBYTE *vp = SER_DATA_RAW(vect);
+ REBINT bits = VECT_TYPE(vect);
+
+ if (bits < VTSF08)
+ Init_Integer(out, get_vect(bits, vp, n - 1)); // 64-bit
+ else {
+ VAL_RESET_HEADER(out, REB_DECIMAL);
+ REBI64 i = get_vect(bits, vp, n - 1);
+ Init_Decimal_Bits(out, cast(REBYTE*, &i));
+ }
+}
+
+
+//
+// Poke_Vector_Fail_If_Read_Only: C
+//
+void Poke_Vector_Fail_If_Read_Only(
+ REBVAL *value,
+ const REBVAL *picker,
+ const REBVAL *poke
+) {
+ REBSER *vect = VAL_SERIES(value);
+ FAIL_IF_READ_ONLY_SERIES(vect);
+
+ REBINT n;
+ if (IS_INTEGER(picker) || IS_DECIMAL(picker))
+ n = Int32(picker);
+ else
+ fail (picker);
+
+ n += VAL_INDEX(value);
+
+ if (n <= 0 || cast(REBCNT, n) > SER_LEN(vect))
+ fail (Error_Out_Of_Range(picker));
+
+ REBYTE *vp = SER_DATA_RAW(vect);
+ REBINT bits = VECT_TYPE(vect);
+
+ REBI64 i;
+ REBDEC f;
+ if (IS_INTEGER(poke)) {
+ i = VAL_INT64(poke);
+ if (bits > VTUI64)
+ f = cast(REBDEC, i);
+ else {
+ // !!! REVIEW: f was not set in this case; compiler caught the
+ // unused parameter. So fill with distinctive garbage to make it
+ // easier to search for if it ever is.
+ f = -646.699;
+ }
+ }
+ else if (IS_DECIMAL(poke)) {
+ f = VAL_DECIMAL(poke);
+ if (bits <= VTUI64)
+ i = cast(REBINT, f);
+ else
+ i = 0xDECAFBAD; // not used, but avoid maybe uninitalized warning
+ }
+ else
+ fail (poke);
+
+ set_vect(bits, vp, n - 1, i, f);
+}
+
+
+//
+// PD_Vector: C
+//
+// Path dispatch acts like PICK for GET-PATH! and POKE for SET-PATH!
+//
+REBINT PD_Vector(REBPVS *pvs)
{
- REBVAL *value = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBINT type;
- REBCNT size;
- REBSER *vect;
- REBSER *ser;
-
- type = Do_Series_Action(action, value, arg);
- if (type >= 0) return type;
-
- vect = VAL_SERIES(value); // not valid for MAKE or TO
-
- // Check must be in this order (to avoid checking a non-series value);
- if (action >= A_TAKE && action <= A_SORT && IS_PROTECT_SERIES(vect))
- Trap0(RE_PROTECTED);
-
- switch (action) {
-
- case A_PICK:
- Pick_Path(value, arg, 0);
- return R_TOS;
-
- case A_POKE:
- Pick_Path(value, arg, D_ARG(3));
- return R_ARG3;
-
- case A_MAKE:
- // We only allow MAKE VECTOR! ...
- if (!IS_DATATYPE(value)) goto bad_make;
-
- // CASE: make vector! 100
- if (IS_INTEGER(arg) || IS_DECIMAL(arg)) {
- size = Int32s(arg, 0);
- if (size < 0) goto bad_make;
- ser = Make_Vector(0, 0, 1, 32, size);
- SET_VECTOR(value, ser);
- break;
- }
-// if (IS_NONE(arg)) {
-// ser = Make_Vector(0, 0, 1, 32, 0);
-// SET_VECTOR(value, ser);
-// break;
-// }
- // fall thru
-
- case A_TO:
- // CASE: make vector! [...]
- if (IS_BLOCK(arg) && Make_Vector_Spec(VAL_BLK_DATA(arg), value)) break;
- goto bad_make;
-
- case A_LENGTHQ:
- //bits = 1 << (vect->size & 3);
- SET_INTEGER(D_RET, vect->tail);
- return R_RET;
-
- case A_COPY:
- ser = Copy_Series(vect);
- ser->size = vect->size; // attributes
- SET_VECTOR(value, ser);
- break;
-
- case A_RANDOM:
- if (D_REF(2) || D_REF(4)) Trap0(RE_BAD_REFINES); // /seed /only
- Shuffle_Vector(value, D_REF(3));
- return R_ARG1;
-
- default:
- Trap_Action(VAL_TYPE(value), action);
- }
-
- *D_RET = *value;
- return R_RET;
+ if (pvs->opt_setval) {
+ Poke_Vector_Fail_If_Read_Only(
+ KNOWN(pvs->value), pvs->picker, pvs->opt_setval
+ );
+ return PE_OK;
+ }
+
+ Pick_Vector(pvs->store, KNOWN(pvs->value), pvs->picker);
+ return PE_USE_STORE;
+}
-bad_make:
- Trap_Make(REB_VECTOR, arg);
- DEAD_END;
+
+//
+// REBTYPE: C
+//
+REBTYPE(Vector)
+{
+ REBVAL *value = D_ARG(1);
+ REBSER *ser;
+
+ // Common operations for any series type (length, head, etc.)
+ {
+ REB_R r = Series_Common_Action_Maybe_Unhandled(frame_, action);
+ if (r != R_UNHANDLED)
+ return r;
+ }
+
+ REBSER *vect = VAL_SERIES(value);
+
+ switch (action) {
+
+ case SYM_LENGTH_OF:
+ //bits = 1 << (vect->size & 3);
+ Init_Integer(D_OUT, SER_LEN(vect));
+ return R_OUT;
+
+ case SYM_COPY: {
+ INCLUDE_PARAMS_OF_COPY;
+
+ UNUSED(PAR(value));
+ if (REF(part)) {
+ UNUSED(ARG(limit));
+ fail (Error_Bad_Refines_Raw());
+ }
+ if (REF(deep))
+ fail (Error_Bad_Refines_Raw());
+ if (REF(types)) {
+ UNUSED(ARG(kinds));
+ fail (Error_Bad_Refines_Raw());
+ }
+
+ ser = Copy_Sequence(vect);
+ ser->misc.size = vect->misc.size; // attributes
+ Init_Vector(value, ser);
+ break; }
+
+ case SYM_RANDOM: {
+ INCLUDE_PARAMS_OF_RANDOM;
+ UNUSED(PAR(value));
+
+ FAIL_IF_READ_ONLY_SERIES(vect);
+
+ if (REF(seed) || REF(only))
+ fail (Error_Bad_Refines_Raw());
+
+ Shuffle_Vector(value, REF(secure));
+ Move_Value(D_OUT, D_ARG(1));
+ return R_OUT; }
+
+ default:
+ fail (Error_Illegal_Action(VAL_TYPE(value), action));
+ }
+
+ Move_Value(D_OUT, value);
+ return R_OUT;
}
-
-/***********************************************************************
-**
-*/ void Mold_Vector(REBVAL *value, REB_MOLD *mold, REBFLG molded)
-/*
-***********************************************************************/
+
+//
+// Mold_Vector: C
+//
+void Mold_Vector(const REBVAL *value, REB_MOLD *mold, REBOOL molded)
{
- REBSER *vect = VAL_SERIES(value);
- REBYTE *data = vect->data;
- REBCNT bits = VECT_TYPE(vect);
-// REBCNT dims = vect->size >> 8;
- REBCNT len;
- REBCNT n;
- REBCNT c;
- union {REBU64 i; REBDEC d;} v;
- REBYTE buf[32];
- REBYTE l;
-
- if (GET_MOPT(mold, MOPT_MOLD_ALL)) {
- len = VAL_TAIL(value);
- n = 0;
- } else {
- len = VAL_LEN(value);
- n = VAL_INDEX(value);
- }
-
- if (molded) {
- REBCNT type = (bits >= VTSF08) ? REB_DECIMAL : REB_INTEGER;
- Pre_Mold(value, mold);
- if (!GET_MOPT(mold, MOPT_MOLD_ALL)) Append_Byte(mold->series, '[');
- if (bits >= VTUI08 && bits <= VTUI64) Append_Bytes(mold->series, "unsigned ");
- Emit(mold, "N I I [", type+1, bit_sizes[bits & 3], len);
- if (len) New_Indented_Line(mold);
- }
-
- c = 0;
- for (; n < vect->tail; n++) {
- v.i = get_vect(bits, data, n);
- if (bits < VTSF08) {
- l = Emit_Integer(buf, v.i);
- } else {
- l = Emit_Decimal(buf, v.d, 0, '.', mold->digits);
- }
- Append_Bytes_Len(mold->series, buf, l);
-
- if ((++c > 7) && (n+1 < vect->tail)) {
- New_Indented_Line(mold);
- c = 0;
- }
- else
- Append_Byte(mold->series, ' ');
- }
-
- if (len) mold->series->tail--; // remove final space
-
- if (molded) {
- if (len) New_Indented_Line(mold);
- Append_Byte(mold->series, ']');
- if (!GET_MOPT(mold, MOPT_MOLD_ALL)) {
- Append_Byte(mold->series, ']');
- }
- else {
- Post_Mold(value, mold);
- }
- }
+ REBSER *vect = VAL_SERIES(value);
+ REBYTE *data = SER_DATA_RAW(vect);
+ REBCNT bits = VECT_TYPE(vect);
+// REBCNT dims = vect->size >> 8;
+ REBCNT len;
+ REBCNT n;
+ REBCNT c;
+ union {REBU64 i; REBDEC d;} v;
+ REBYTE buf[32];
+ REBYTE l;
+
+ if (GET_MOPT(mold, MOPT_MOLD_ALL)) {
+ len = VAL_LEN_HEAD(value);
+ n = 0;
+ } else {
+ len = VAL_LEN_AT(value);
+ n = VAL_INDEX(value);
+ }
+
+ if (molded) {
+ enum Reb_Kind kind = (bits >= VTSF08) ? REB_DECIMAL : REB_INTEGER;
+ Pre_Mold(value, mold);
+ if (!GET_MOPT(mold, MOPT_MOLD_ALL))
+ Append_Codepoint_Raw(mold->series, '[');
+ if (bits >= VTUI08 && bits <= VTUI64)
+ Append_Unencoded(mold->series, "unsigned ");
+ Emit(
+ mold,
+ "N I I [",
+ Canon(SYM_FROM_KIND(kind)),
+ bit_sizes[bits & 3],
+ len
+ );
+ if (len)
+ New_Indented_Line(mold);
+ }
+
+ c = 0;
+ for (; n < SER_LEN(vect); n++) {
+ v.i = get_vect(bits, data, n);
+ if (bits < VTSF08) {
+ l = Emit_Integer(buf, v.i);
+ } else {
+ l = Emit_Decimal(buf, v.d, 0, '.', mold->digits);
+ }
+ Append_Unencoded_Len(mold->series, s_cast(buf), l);
+
+ if ((++c > 7) && (n + 1 < SER_LEN(vect))) {
+ New_Indented_Line(mold);
+ c = 0;
+ }
+ else
+ Append_Codepoint_Raw(mold->series, ' ');
+ }
+
+ if (len) {
+ //
+ // remove final space (overwritten with terminator)
+ //
+ TERM_UNI_LEN(mold->series, UNI_LEN(mold->series) - 1);
+ }
+
+ if (molded) {
+ if (len) New_Indented_Line(mold);
+ Append_Codepoint_Raw(mold->series, ']');
+ if (!GET_MOPT(mold, MOPT_MOLD_ALL)) {
+ Append_Codepoint_Raw(mold->series, ']');
+ }
+ else {
+ Post_Mold(value, mold);
+ }
+ }
}
diff --git a/src/core/t-word.c b/src/core/t-word.c
index 68ea8c8033..4144da37e5 100644
--- a/src/core/t-word.c
+++ b/src/core/t-word.c
@@ -1,133 +1,169 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: t-word.c
-** Summary: word related datatypes
-** Section: datatypes
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
+//
+// File: %t-word.c
+// Summary: "word related datatypes"
+// Section: datatypes
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
#include "sys-core.h"
-#ifdef not_used
-/***********************************************************************
-**
-** REBFLG MT_Word(REBVAL *out, REBVAL *data, REBCNT type)
-**
-***********************************************************************/
+
+//
+// CT_Word: C
+//
+// !!! The R3-Alpha code did a non-ordering comparison; it only tells whether
+// the words are equal or not (1 or 0). This creates bad invariants for
+// sorting etc. Review.
+//
+REBINT CT_Word(const RELVAL *a, const RELVAL *b, REBINT mode)
+{
+ REBINT e;
+ REBINT diff;
+ if (mode >= 0) {
+ if (mode == 1) {
+ //
+ // Symbols must be exact match, case-sensitively
+ //
+ if (VAL_WORD_SPELLING(a) != VAL_WORD_SPELLING(b))
+ return 0;
+ }
+ else {
+ // Different cases acceptable, only check for a canon match
+ //
+ if (VAL_WORD_CANON(a) != VAL_WORD_CANON(b))
+ return 0;
+ }
+
+ return 1;
+ }
+ else {
+ diff = Compare_Word(a, b, FALSE);
+ if (mode == -1) e = diff >= 0;
+ else e = diff > 0;
+ }
+ return e;
+}
+
+
+//
+// MAKE_Word: C
+//
+void MAKE_Word(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- if (!IS_WORD(data)) return FALSE;
- *out = *data;
- VAL_SET(out, type);
- return TRUE;
+ if (ANY_WORD(arg)) {
+ //
+ // Only reset the type, not all the header bits (the bits must
+ // stay in sync with the binding state)
+ //
+ Move_Value(out, arg);
+ VAL_SET_TYPE_BITS(out, kind);
+ return;
+ }
+
+ if (IS_STRING(arg)) {
+ REBCNT len;
+ const REBOOL allow_utf8 = TRUE;
+
+ // Set name. Rest is set below. If characters in the source
+ // string are > 0x80 they will be encoded to UTF8 to be stored
+ // in the symbol.
+ //
+ REBYTE *bp = Temp_Byte_Chars_May_Fail(
+ arg, MAX_SCAN_WORD, &len, allow_utf8
+ );
+
+ if (kind == REB_ISSUE) {
+ if (NULL == Scan_Issue(out, bp, len))
+ fail (Error_Bad_Char_Raw(arg));
+ }
+ else {
+ if (NULL == Scan_Any_Word(out, kind, bp, len))
+ fail (Error_Bad_Char_Raw(arg));
+ }
+ }
+ else if (IS_CHAR(arg)) {
+ REBYTE buf[8];
+ REBCNT len = Encode_UTF8_Char(&buf[0], VAL_CHAR(arg));
+ if (NULL == Scan_Any_Word(out, kind, &buf[0], len))
+ fail (Error_Bad_Char_Raw(arg));
+ }
+ else if (IS_DATATYPE(arg)) {
+ Init_Any_Word(out, kind, Canon(VAL_TYPE_SYM(arg)));
+ }
+ else if (IS_LOGIC(arg)) {
+ Init_Any_Word(
+ out,
+ kind,
+ VAL_LOGIC(arg) ? Canon(SYM_TRUE) : Canon(SYM_FALSE)
+ );
+ }
+ else
+ fail (Error_Unexpected_Type(REB_WORD, VAL_TYPE(arg)));
}
-#endif
-/***********************************************************************
-**
-*/ REBINT CT_Word(REBVAL *a, REBVAL *b, REBINT mode)
-/*
-***********************************************************************/
+//
+// TO_Word: C
+//
+void TO_Word(REBVAL *out, enum Reb_Kind kind, const REBVAL *arg)
{
- REBINT e;
- REBINT diff;
- if (mode >= 0) {
- e = VAL_WORD_CANON(a) == VAL_WORD_CANON(b);
- if (mode == 1) e &= VAL_WORD_INDEX(a) == VAL_WORD_INDEX(b)
- && VAL_WORD_FRAME(a) == VAL_WORD_FRAME(b);
- else if (mode >= 2) {
- e = (VAL_WORD_SYM(a) == VAL_WORD_SYM(b) &&
- VAL_WORD_INDEX(a) == VAL_WORD_INDEX(b) &&
- VAL_WORD_FRAME(a) == VAL_WORD_FRAME(b));
- }
- } else {
- diff = Compare_Word(a, b, FALSE);
- if (mode == -1) e = diff >= 0;
- else e = diff > 0;
- }
- return e;
+ MAKE_Word(out, kind, arg);
}
-/***********************************************************************
-**
-*/ REBTYPE(Word)
-/*
-***********************************************************************/
+//
+// REBTYPE: C
+//
+// The future plan for WORD! types is that they will be unified somewhat with
+// strings...but that bound words will have read-only data. Under such a
+// plan, string-converting words would not be necessary for basic textual
+// operations.
+//
+REBTYPE(Word)
{
- REBVAL *val = D_ARG(1);
- REBVAL *arg = D_ARG(2);
- REBCNT type = VAL_TYPE(val);
- REBINT diff;
- REBCNT sym;
-
- switch (action) {
- case A_LENGTHQ:
- diff = LEN_BYTES(Get_Sym_Name(VAL_WORD_SYM(val)));
- if (type != REB_WORD) diff++;
- DS_Ret_Int(diff);
- break;
-
- case A_MAKE:
- case A_TO:
- // TO word! ...
- if (type == REB_DATATYPE) type = (REBCNT)VAL_DATATYPE(val);
- if (ANY_WORD(arg)) {
- VAL_SET(arg, type);
- return R_ARG2;
- }
- else {
- if (IS_STRING(arg)) {
- REBYTE *bp;
- REBCNT len;
- // Set sym. Rest is set below.
- bp = Qualify_String(arg, 255, &len, TRUE);
- if (type == REB_ISSUE) sym = Scan_Issue(bp, len);
- else sym = Scan_Word(bp, len);
- if (!sym) Trap1(RE_BAD_CHAR, arg);
- }
- else if (IS_CHAR(arg)) {
- REBYTE buf[8];
- sym = Encode_UTF8_Char(&buf[0], VAL_CHAR(arg)); //returns length
- sym = Scan_Word(&buf[0], sym);
- if (!sym) Trap1(RE_BAD_CHAR, arg);
- }
- else if (IS_DATATYPE(arg)) {
- sym = VAL_DATATYPE(arg)+1;
- }
- else if (IS_LOGIC(arg)) {
- sym = IS_TRUE(arg) ? SYM_TRUE : SYM_FALSE;
- }
- else Trap_Types(RE_EXPECT_VAL, REB_WORD, VAL_TYPE(arg));
- Set_Word(D_RET, sym, 0, 0);
- VAL_SET(D_RET, type);
- }
- break;
-
- default:
- Trap_Action(type, action);
- }
-
- return R_RET;
+ REBVAL *val = D_ARG(1);
+
+ switch (action) {
+ case SYM_LENGTH_OF: {
+ const REBYTE *bp = STR_HEAD(VAL_WORD_SPELLING(val));
+ REBCNT len = 0;
+ while (TRUE) {
+ REBUNI ch;
+ if (!(bp = Back_Scan_UTF8_Char(&ch, bp, &len)))
+ fail (Error_Bad_Utf8_Raw());
+ if (ch == 0)
+ break;
+ }
+ Init_Integer(D_OUT, len);
+ return R_OUT; }
+
+ default:
+ assert(ANY_WORD(val));
+ fail (Error_Illegal_Action(VAL_TYPE(val), action));
+ }
+
+ return R_OUT;
}
diff --git a/src/core/u-bmp.c b/src/core/u-bmp.c
deleted file mode 100644
index 8ed8c1d58a..0000000000
--- a/src/core/u-bmp.c
+++ /dev/null
@@ -1,618 +0,0 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: u-bmp.c
-** Summary: conversion to and from BMP graphics format
-** Section: utility
-** Notes:
-** This is an optional part of R3. This file can be replaced by
-** library function calls into an updated implementation.
-**
-***********************************************************************/
-
-#include "sys-core.h"
-
-//**********************************************************************
-
-#define WADJUST(x) (((x * 3L + 3) / 4) * 4)
-
-typedef unsigned char BYTE;
-typedef unsigned short WORD;
-typedef unsigned int DWORD;
-typedef int LONG;
-
-typedef struct tagBITMAP
-{
- int bmType;
- int bmWidth;
- int bmHeight;
- int bmWidthBytes;
- BYTE bmPlanes;
- BYTE bmBitsPixel;
- void *bmBits;
-} BITMAP;
-typedef BITMAP *PBITMAP;
-typedef BITMAP *NPBITMAP;
-typedef BITMAP *LPBITMAP;
-
-/* Bitmap Header structures */
-typedef struct tagRGBTRIPLE
-{
- BYTE rgbtBlue;
- BYTE rgbtGreen;
- BYTE rgbtRed;
-} RGBTRIPLE;
-typedef RGBTRIPLE *LPRGBTRIPLE;
-
-typedef struct tagRGBQUAD
-{
- BYTE rgbBlue;
- BYTE rgbGreen;
- BYTE rgbRed;
- BYTE rgbReserved;
-} RGBQUAD;
-typedef RGBQUAD *LPRGBQUAD;
-
-/* structures for defining DIBs */
-typedef struct tagBITMAPCOREHEADER
-{
- DWORD bcSize;
- short bcWidth;
- short bcHeight;
- WORD bcPlanes;
- WORD bcBitCount;
-} BITMAPCOREHEADER;
-typedef BITMAPCOREHEADER* PBITMAPCOREHEADER;
-typedef BITMAPCOREHEADER *LPBITMAPCOREHEADER;
-
-char *mapBITMAPCOREHEADER = "lssss";
-
-typedef struct tagBITMAPINFOHEADER
-{
- DWORD biSize;
- LONG biWidth;
- LONG biHeight;
- WORD biPlanes;
- WORD biBitCount;
- DWORD biCompression;
- DWORD biSizeImage;
- LONG biXPelsPerMeter;
- LONG biYPelsPerMeter;
- DWORD biClrUsed;
- DWORD biClrImportant;
-} BITMAPINFOHEADER;
-
-char *mapBITMAPINFOHEADER = "lllssllllll";
-
-typedef BITMAPINFOHEADER* PBITMAPINFOHEADER;
-typedef BITMAPINFOHEADER *LPBITMAPINFOHEADER;
-
-/* constants for the biCompression field */
-#define BI_RGB 0L
-#define BI_RLE8 1L
-#define BI_RLE4 2L
-
-typedef struct tagBITMAPINFO
-{
- BITMAPINFOHEADER bmiHeader;
- RGBQUAD bmiColors[1];
-} BITMAPINFO;
-typedef BITMAPINFO* PBITMAPINFO;
-typedef BITMAPINFO *LPBITMAPINFO;
-
-typedef struct tagBITMAPCOREINFO
-{
- BITMAPCOREHEADER bmciHeader;
- RGBTRIPLE bmciColors[1];
-} BITMAPCOREINFO;
-typedef BITMAPCOREINFO* PBITMAPCOREINFO;
-typedef BITMAPCOREINFO *LPBITMAPCOREINFO;
-
-typedef struct tagBITMAPFILEHEADER
-{
- char bfType[2];
- DWORD bfSize;
- WORD bfReserved1;
- WORD bfReserved2;
- DWORD bfOffBits;
-} BITMAPFILEHEADER;
-typedef BITMAPFILEHEADER* PBITMAPFILEHEADER;
-typedef BITMAPFILEHEADER *LPBITMAPFILEHEADER;
-
-char *mapBITMAPFILEHEADER = "bblssl";
-
-typedef RGBQUAD *RGBQUADPTR;
-
-//**********************************************************************
-
-static int longaligned(void) {
- static char filldata[] = {0,0,1,1,1,1};
- struct {
- unsigned short a;
- unsigned int b;
- } a={0};
- memcpy(&a, filldata, 6);
- if (a.b != 0x01010101) return TRUE;
- return FALSE;
-}
-
-void Map_Bytes(void *dstp, REBYTE **srcp, char *map) {
- REBYTE *src = *srcp;
- REBYTE *dst = dstp;
- char c;
-#ifdef ENDIAN_LITTLE
- while ((c = *map++) != 0) {
- switch(c) {
- case 'b':
- *dst++ = *src++;
- break;
-
- case 's':
- *((short *)dst) = *((short *)src);
- dst += sizeof(short);
- src += 2;
- break;
-
- case 'l':
- if (longaligned()) {
- while(((unsigned long)dst)&3)
- dst++;
- }
- *((REBCNT *)dst) = *((REBCNT *)src);
- dst += sizeof(REBCNT);
- src += 4;
- break;
- }
- }
-#else
- while ((c = *map++) != 0) {
- switch(c) {
- case 'b':
- *dst++ = *src++;
- break;
-
- case 's':
- *((short *)dst) = src[0]|(src[1]<<8);
- dst += sizeof(short);
- src += 2;
- break;
-
- case 'l':
- if (longaligned()) {
- while (((unsigned long)dst)&3)
- dst++;
- }
- *((REBCNT *)dst) = src[0]|(src[1]<<8)|
- (src[2]<<16)|(src[3]<<24);
- dst += sizeof(REBCNT);
- src += 4;
- break;
- }
- }
-#endif
- *srcp = src;
-}
-
-void Unmap_Bytes(void *srcp, REBYTE **dstp, char *map) {
- REBYTE *src = srcp;
- REBYTE *dst = *dstp;
- char c;
-#ifdef ENDIAN_LITTLE
- while ((c = *map++) != 0) {
- switch(c) {
- case 'b':
- *dst++ = *src++;
- break;
-
- case 's':
- *((short *)dst) = *((short *)src);
- src += sizeof(short);
- dst += 2;
- break;
-
- case 'l':
- if (longaligned()) {
- while(((unsigned long)src)&3)
- src++;
- }
- *((REBCNT *)dst) = *((REBCNT *)src);
- src += sizeof(REBCNT);
- dst += 4;
- break;
- }
- }
-#else
- while ((c = *map++) != 0) {
- switch(c) {
- case 'b':
- *dst++ = *src++;
- break;
-
- case 's':
- *((short *)dst) = src[0]|(src[1]<<8);
- src += sizeof(short);
- dst += 2;
- break;
-
- case 'l':
- if (longaligned()) {
- while (((unsigned long)src)&3)
- src++;
- }
- *((REBCNT *)dst) = src[0]|(src[1]<<8)|
- (src[2]<<16)|(src[3]<<24);
- src += sizeof(REBCNT);
- dst += 4;
- break;
- }
- }
-#endif
- *dstp = dst;
-}
-
-
-/***********************************************************************
-**
-*/ static void Decode_BMP_Image(REBCDI *codi)
-/*
-** Input: BMP encoded image (codi->data, len)
-** Output: Image bits (codi->bits, w, h)
-** Error: Code in codi->error
-** Return: Success as TRUE or FALSE
-**
-***********************************************************************/
-{
- REBINT i, j, x, y, c;
- REBINT colors, compression, bitcount;
- REBINT w, h;
- BITMAPFILEHEADER bmfh;
- BITMAPINFOHEADER bmih;
- BITMAPCOREHEADER bmch;
- REBYTE *cp, *tp;
- REBCNT *dp;
- RGBQUADPTR color;
- RGBQUADPTR ctab = 0;
-
- cp = codi->data;
- Map_Bytes(&bmfh, &cp, mapBITMAPFILEHEADER);
- if (bmfh.bfType[0] != 'B' || bmfh.bfType[1] != 'M') {
- codi->error = CODI_ERR_SIGNATURE;
- return;
- }
- if (codi->action == CODI_IDENTIFY) return; // no error means success
-
- tp = cp;
- Map_Bytes(&bmih, &cp, mapBITMAPINFOHEADER);
- if (bmih.biSize < sizeof(BITMAPINFOHEADER)) {
- cp = tp;
- Map_Bytes(&bmch, &cp, mapBITMAPCOREHEADER);
-
- w = bmch.bcWidth;
- h = bmch.bcHeight;
- compression = 0;
- bitcount = bmch.bcBitCount;
-
- if (bmch.bcBitCount < 24)
- colors = 1 << bmch.bcBitCount;
- else
- colors = 0;
-
- if (colors) {
- ctab = (RGBQUADPTR)Make_Mem(colors * sizeof(RGBQUAD));
- for (i = 0; idata))
- cp = codi->data + bmfh.bfOffBits;
-
- codi->w = w;
- codi->h = h;
- codi->bits = Make_Mem(w * h * 4);
-
- dp = (REBCNT *) codi->bits;
- dp += w * h - w;
-
- for (y = 0; yrgbRed << 16) |
- ((int)color->rgbGreen << 8) | color->rgbBlue;
- x >>= 1;
- }
- i = (w+7) / 8;
- break;
-
- case 4:
- for (i = 0; i> 4;
- }
- else
- x = c & 0xf;
- if (x > colors) {
- codi->error = CODI_ERR_BAD_TABLE;
- goto error;
- }
- color = &ctab[x];
- *dp++ = ((int)color->rgbRed << 16) |
- ((int)color->rgbGreen << 8) | color->rgbBlue;
- }
- i = (w+1) / 2;
- break;
-
- case 8:
- for (i = 0; i colors) {
- codi->error = CODI_ERR_BAD_TABLE;
- goto error;
- }
- color = &ctab[c];
- *dp++ = ((int)color->rgbRed << 16) |
- ((int)color->rgbGreen << 8) | color->rgbBlue;
- }
- break;
-
- case 24:
- for (i = 0; ierror = CODI_ERR_BIT_LEN;
- goto error;
- }
- while (i++ % 4)
- cp++;
- break;
-
- case BI_RLE4:
- i = 0;
- for (;;) {
- c = *cp++ & 0xff;
-
- if (c == 0) {
- c = *cp++ & 0xff;
- if (c == 0 || c == 1)
- break;
- if (c == 2) {
- codi->error = CODI_ERR_BAD_TABLE;
- goto error;
- }
- for (j = 0; j>4];
- }
- else
- color = &ctab[x&0x0f];
- *dp++ = ((int)color->rgbRed << 16) |
- ((int)color->rgbGreen << 8) | color->rgbBlue;
- }
- j = (c+1) / 2;
- while (j++%2)
- cp++;
- }
- else {
- x = *cp++ & 0xff;
- for (j = 0; jerror = CODI_ERR_BAD_TABLE;
- goto error;
- }
- if (j&1)
- color = &ctab[x&0x0f];
- else
- color = &ctab[x>>4];
- *dp++ = ((int)color->rgbRed << 16) |
- ((int)color->rgbGreen << 8) | color->rgbBlue;
- }
- }
- }
- break;
-
- case BI_RLE8:
- i = 0;
- for (;;) {
- c = *cp++ & 0xff;
-
- if (c == 0) {
- c = *cp++ & 0xff;
- if (c == 0 || c == 1)
- break;
- if (c == 2) {
- codi->error = CODI_ERR_BAD_TABLE;
- goto error;
- }
- for (j = 0; jrgbRed << 16) |
- ((int)color->rgbGreen << 8) | color->rgbBlue;
- }
- while (j++ % 2)
- cp++;
- }
- else {
- x = *cp++ & 0xff;
- for (j = 0; jrgbRed << 16) |
- ((int)color->rgbGreen << 8) | color->rgbBlue;
- }
- }
- }
- break;
-
- default:
- codi->error = CODI_ERR_ENCODING;
- goto error;
- }
- dp -= 2 * w;
- }
-error:
- if (ctab) free(ctab);
-}
-
-
-/***********************************************************************
-**
-*/ static void Encode_BMP_Image(REBCDI *codi)
-/*
-** Input: Image bits (codi->bits, w, h)
-** Output: BMP encoded image (codi->data, len)
-** Error: Code in codi->error
-** Return: Success as TRUE or FALSE
-**
-***********************************************************************/
-{
- REBINT i, y;
- REBINT w, h;
- REBYTE *cp;
- REBCNT *dp, v;
- BITMAPFILEHEADER bmfh;
- BITMAPINFOHEADER bmih;
-
- w = codi->w;
- h = codi->h;
-
- memset(&bmfh, 0, sizeof(bmfh));
- bmfh.bfType[0] = 'B';
- bmfh.bfType[1] = 'M';
- bmfh.bfSize = 14 + 40 + h * WADJUST(w);
- bmfh.bfOffBits = 14 + 40;
-
- // Create binary string:
- cp = codi->data = Make_Mem(bmfh.bfSize);
- codi->len = bmfh.bfSize;
- Unmap_Bytes(&bmfh, &cp, mapBITMAPFILEHEADER);
-
- memset(&bmih, 0, sizeof(bmih));
- bmih.biSize = 40;
- bmih.biWidth = w;
- bmih.biHeight = h;
- bmih.biPlanes = 1;
- bmih.biBitCount = 24;
- bmih.biCompression = 0;
- bmih.biSizeImage = 0;
- bmih.biXPelsPerMeter = 0;
- bmih.biYPelsPerMeter = 0;
- bmih.biClrUsed = 0;
- bmih.biClrImportant = 0;
- Unmap_Bytes(&bmih, &cp, mapBITMAPINFOHEADER);
-
- dp = (REBCNT *) codi->bits;
- dp += w * h - w;
-
- for (y = 0; y> 8) & 0xff;
- cp[2] = (v >> 16) & 0xff;
- cp += 3;
- }
- i = w * 3;
- while (i++ % 4)
- *cp++ = 0;
- dp -= 2 * w;
- }
-}
-
-
-/***********************************************************************
-**
-*/ REBINT Codec_BMP_Image(REBCDI *codi)
-/*
-***********************************************************************/
-{
- codi->error = 0;
-
- if (codi->action == CODI_IDENTIFY) {
- Decode_BMP_Image(codi);
- return CODI_CHECK; // error code is inverted result
- }
-
- if (codi->action == CODI_DECODE) {
- Decode_BMP_Image(codi);
- return CODI_IMAGE;
- }
-
- if (codi->action == CODI_ENCODE) {
- Encode_BMP_Image(codi);
- return CODI_BINARY;
- }
-
- codi->error = CODI_ERR_NA;
- return CODI_ERROR;
-}
-
-
-/***********************************************************************
-**
-*/ void Init_BMP_Codec(void)
-/*
-***********************************************************************/
-{
- Register_Codec("bmp", Codec_BMP_Image);
-}
diff --git a/src/core/u-compress.c b/src/core/u-compress.c
index 0f3bd35b02..74180f622a 100644
--- a/src/core/u-compress.c
+++ b/src/core/u-compress.c
@@ -1,137 +1,426 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: u-compress.c
-** Summary: interface to zlib compression
-** Section: utility
-** Notes:
-**
-***********************************************************************/
+//
+// File: %u-compress.c
+// Summary: "interface to zlib compression"
+// Section: utility
+// Project: "Rebol 3 Interpreter and Run-time (Ren-C branch)"
+// Homepage: https://github.com/metaeducation/ren-c/
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// Copyright 2012 REBOL Technologies
+// Copyright 2012-2017 Rebol Open Source Contributors
+// REBOL is a trademark of REBOL Technologies
+//
+// See README.md and CREDITS.md for more information.
+//
+// Licensed under the Apache License, Version 2.0 (the "License");
+// you may not use this file except in compliance with the License.
+// You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing, software
+// distributed under the License is distributed on an "AS IS" BASIS,
+// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+// See the License for the specific language governing permissions and
+// limitations under the License.
+//
+//=////////////////////////////////////////////////////////////////////////=//
+//
+// The Rebol executable includes a version of zlib which has been extracted
+// from the GitHub archive and pared down into a single .h and .c file.
+// This wraps that functionality into functions that compress and decompress
+// BINARY! REBSERs.
+//
+// Classically, Rebol added a 32-bit size header onto the front of compressed
+// data, indicating the uncompressed size. This is the default BINARY! format
+// returned by COMPRESS. However, it only used a 32-bit number...gzip also
+// includes the length modulo 32. This means that if the data is < 4MB in
+// size you can use the length with gzip:
+//
+// http://stackoverflow.com/a/9213826/211160
+//
+// Options are offered for using zlib envelope, gzip envelope, or raw deflate.
+//
+// !!! Technically zlib is designed to do "streaming" compression. Those
+// features are not exposed by this interface, although they are implemented
+// in the zlib code.
+//
#include "sys-core.h"
#include "sys-zlib.h"
-/*
- * This number represents the top file size that,
- * if the data is random, will produce a larger output
- * file than input. The number is really a bit smaller
- * but we like to be safe. -- SN
- */
-#define STERLINGS_MAGIC_NUMBER 10000
-
-/*
- * This number represents the largest that a small file that expands
- * on compression can expand. The actual value is closer to
- * 500 bytes but why take chances? -- SN
- */
-#define STERLINGS_MAGIC_FIX 1024
-
-/*
- * The why_compress_constant is here to satisfy the condition that
- * somebody might just try compressing some big file that is already well
- * compressed (or expands for some other wild reason). So we allocate
- * a compression buffer a bit larger than the original file size.
- * 10% is overkill for really large files so some other limit might
- * be a good idea.
-*/
-#define WHY_COMPRESS_CONSTANT 0.1
-
-/***********************************************************************
-**
-*/ REBSER *Compress(REBSER *input, REBINT index, REBINT len, REBFLG use_crc)
-/*
-** Compress a binary (only).
-** data
-** /part
-** length
-** /crc32
-**
-** Note: If the file length is "small", it can't overrun on
-** compression too much so we use our magic numbers; otherwise,
-** we'll just be safe by a percentage of the file size. This may
-** be a bit much, though.
-**
-***********************************************************************/
+
+//
+// REBCNT_To_Bytes: C
+//
+// Get endian-independent encoding of a 32-bit unsigned integer to 4 bytes
+//
+static void REBCNT_To_Bytes(REBYTE *out, REBCNT in)
+{
+ assert(sizeof(REBCNT) == 4);
+ out[0] = cast(REBYTE, in);
+ out[1] = cast(REBYTE, in >> 8);
+ out[2] = cast(REBYTE, in >> 16);
+ out[3] = cast(REBYTE, in >> 24);
+}
+
+
+//
+// Bytes_To_REBCNT: C
+//
+// Decode endian-independent sequence of 4 bytes back into a 32-bit unsigned
+//
+static REBCNT Bytes_To_REBCNT(const REBYTE * const in)
{
- REBCNT size;
- REBSER *output;
- REBINT err;
- REBYTE out_size[4];
-
- if (len < 0) Trap0(RE_PAST_END); // !!! better msg needed
- size = len + (len > STERLINGS_MAGIC_NUMBER ? len / 10 + 12 : STERLINGS_MAGIC_FIX);
- output = Make_Binary(size);
-
- //DISABLE_GC; // !!! why??
- // dest, dest-len, src, src-len, level
- err = Z_compress2(BIN_HEAD(output), (uLongf*)&size, BIN_HEAD(input) + index, len, use_crc);
- if (err) {
- if (err == Z_MEM_ERROR) Trap0(RE_NO_MEMORY);
- SET_INTEGER(DS_RETURN, err);
- Trap1(RE_BAD_PRESS, DS_RETURN); //!!!provide error string descriptions
- }
- SET_STR_END(output, size);
- SERIES_TAIL(output) = size;
- Long_To_Bytes(out_size, (REBCNT)len); // Tag the size to the end.
- Append_Series(output, (REBYTE*)out_size, 4);
- if (SERIES_AVAIL(output) > 1024) // Is there wasted space?
- output = Copy_Series(output); // Trim it down if too big. !!! Revisit this based on mem alloc alg.
- //ENABLE_GC;
-
- return output;
+ assert(sizeof(REBCNT) == 4);
+ return cast(REBCNT, in[0])
+ | cast(REBCNT, in[1] << 8)
+ | cast(REBCNT, in[2] << 16)
+ | cast(REBCNT, in[3] << 24);
}
-/***********************************************************************
-**
-*/ REBSER *Decompress(REBSER *input, REBCNT index, REBINT len, REBCNT limit, REBFLG use_crc)
-/*
-** Decompress a binary (only).
-**
-***********************************************************************/
+//
+// Zlib has these magic unnamed bit flags which are passed as windowBits:
+//
+// "windowBits can also be greater than 15 for optional gzip
+// decoding. Add 32 to windowBits to enable zlib and gzip
+// decoding with automatic header detection, or add 16 to
+// decode only the gzip format (the zlib format will return
+// a Z_DATA_ERROR)."
+//
+// Compression obviously can't read your mind to decide what kind you want,
+// but decompression can discern non-raw zlib vs. gzip. It might be useful
+// to still be "strict" and demand you to know which kind you have in your
+// hand, to make a dependency on gzip explicit (in case you're looking for
+// that and want to see if you could use a lighter build without it...)
+//
+static const int window_bits_zlib = MAX_WBITS;
+static const int window_bits_gzip = MAX_WBITS | 16; // "+ 16"
+static const int window_bits_detect_zlib_gzip = MAX_WBITS | 32; // "+ 32"
+static const int window_bits_zlib_raw = -(MAX_WBITS);
+static const int window_bits_gzip_raw = -(MAX_WBITS | 16); // "raw gzip" ?!
+
+
+//
+// Error_Compression: C
+//
+// Zlib gives back string error messages. We use them or fall
+// back on the integer code if there is no message.
+//
+static REBCTX *Error_Compression(const z_stream *strm, int ret)
{
- REBCNT size;
- REBSER *output;
- REBINT err;
-
- if (len < 0 || (index + len > BIN_LEN(input))) len = BIN_LEN(input) - index;
-
- // Get the size from the end and make the output buffer that size.
- if (len <= 4) Trap0(RE_PAST_END); // !!! better msg needed
- size = Bytes_To_Long(BIN_SKIP(input, len) - 4);
-
- if (limit && size > limit) Trap_Num(RE_SIZE_LIMIT, size);
-
- output = Make_Binary(size);
-
- //DISABLE_GC;
- err = Z_uncompress(BIN_HEAD(output), (uLongf*)&size, BIN_HEAD(input) + index, len, use_crc);
- if (err) {
- if (PG_Boot_Phase < 2) return 0;
- if (err == Z_MEM_ERROR) Trap0(RE_NO_MEMORY);
- SET_INTEGER(DS_RETURN, err);
- Trap1(RE_BAD_PRESS, DS_RETURN); //!!!provide error string descriptions
- }
- SET_STR_END(output, size);
- SERIES_TAIL(output) = size;
- //ENABLE_GC;
- return output;
+ if (ret == Z_MEM_ERROR) {
+ //
+ // We do not technically know the amount of memory that zlib asked
+ // for and did not get. Hence categorizing it as an "out of memory"
+ // error might be less useful than leaving as a compression error,
+ // but that is what the old code here historically did.
+ //
+ fail (Error_No_Memory(0));
+ }
+
+ DECLARE_LOCAL (arg);
+ if (strm->msg != NULL)
+ Init_String(arg, Make_UTF8_May_Fail(strm->msg));
+ else
+ Init_Integer(arg, ret);
+
+ return Error_Bad_Compression_Raw(arg);
+}
+
+
+//
+// Compress: C
+//
+// !!! Adds 32-bit size info to zlib non-raw compressions for compatibility
+// with Rebol2 and R3-Alpha, at the cost of inventing yet-another-format.
+// Consider removing.
+//
+REBSER *Compress(
+ REBSER *input,
+ REBINT index,
+ REBCNT len,
+ REBOOL gzip,
+ REBOOL raw
+) {
+ int ret;
+
+ assert(BYTE_SIZE(input)); // must be BINARY!
+
+ // compression level can be a value from 1 to 9, or Z_DEFAULT_COMPRESSION
+ // if you want it to pick what the library author considers the "worth it"
+ // tradeoff of time to generally suggest.
+ //
+ z_stream strm;
+ strm.zalloc = Z_NULL;
+ strm.zfree = Z_NULL;
+ strm.opaque = Z_NULL;
+
+ // Should there be detection? (This suppresses unused const warning.)
+ //
+ UNUSED(window_bits_detect_zlib_gzip);
+
+ ret = deflateInit2(
+ &strm,
+ Z_DEFAULT_COMPRESSION,
+ Z_DEFLATED,
+ raw
+ ? (gzip ? window_bits_gzip_raw : window_bits_zlib_raw)
+ : (gzip ? window_bits_gzip : window_bits_zlib),
+ 8,
+ Z_DEFAULT_STRATEGY
+ );
+
+ if (ret != Z_OK)
+ fail (Error_Compression(&strm, ret));
+
+ // http://stackoverflow.com/a/4938401/211160
+ //
+ REBCNT buf_size = deflateBound(&strm, len);
+
+ strm.avail_in = len;
+ strm.next_in = BIN_HEAD(input) + index;
+
+ REBSER *output = Make_Binary(buf_size);
+ strm.avail_out = buf_size;
+ strm.next_out = BIN_HEAD(output);
+
+ ret = deflate(&strm, Z_FINISH);
+ deflateEnd(&strm);
+
+ if (ret != Z_STREAM_END)
+ fail (Error_Compression(&strm, ret));
+
+ TERM_BIN_LEN(output, buf_size - strm.avail_out);
+
+ if (gzip) {
+ #if !defined(NDEBUG)
+ //
+ // GZIP contains its own CRC. It also has a 32-bit uncompressed
+ // length, conveniently (and perhaps confusingly) at the tail in the
+ // same format that R3-Alpha and Rebol2 used.
+
+ REBCNT gzip_len = Bytes_To_REBCNT(
+ SER_DATA_RAW(output)
+ + buf_size
+ - strm.avail_out
+ - sizeof(REBCNT)
+ );
+ assert(len == gzip_len);
+ #endif
+ }
+ else if (!raw) {
+ //
+ // Add 32-bit length to the end.
+ //
+ // !!! In ZLIB format the length can be found by decompressing, but
+ // not known a priori. So this is for efficiency. It would likely be
+ // better to not include this as it only confuses matters for those
+ // expecting the data to be in a known format...though it means that
+ // clients who wanted to decompress to a known allocation size would
+ // have to save the size somewhere.
+ //
+ REBYTE out_size[sizeof(REBCNT)];
+ REBCNT_To_Bytes(out_size, cast(REBCNT, len));
+ Append_Series(output, cast(REBYTE*, out_size), sizeof(REBCNT));
+ }
+
+ // !!! Trim if more than 1K extra capacity, review logic
+ //
+ if (SER_AVAIL(output) > 1024) {
+ REBSER *smaller = Copy_Sequence(output);
+ Free_Series(output);
+ output = smaller;
+ }
+
+ return output;
+}
+
+
+//
+// Decompress: C
+//
+REBSER *Decompress(
+ const REBYTE *input,
+ REBCNT len,
+ REBINT max,
+ REBOOL gzip,
+ REBOOL raw
+) {
+ int ret;
+
+ z_stream strm;
+ strm.zalloc = Z_NULL;
+ strm.zfree = Z_NULL;
+ strm.opaque = Z_NULL;
+ strm.total_out = 0;
+
+ // We only subtract out the double-checking size if this came from a
+ // zlib compression without /ONLY.
+ //
+ strm.avail_in = (!raw && !gzip) ? len - sizeof(REBCNT) : len;
+ strm.next_in = input;
+
+ // !!! Zlib can detect decompression...use window_bits_detect_zlib_gzip?
+ //
+ ret = inflateInit2(
+ &strm,
+ raw
+ ? (gzip ? window_bits_gzip_raw : window_bits_zlib_raw)
+ : (gzip ? window_bits_gzip : window_bits_zlib)
+ );
+ if (ret != Z_OK)
+ fail (Error_Compression(&strm, ret));
+
+ // Zlib internally allocates state which must be freed, and is not series
+ // memory. *But* the following code is a mixture of Zlib code and Rebol
+ // code (e.g. Extend_Series may run out of memory). If any error is
+ // raised, a longjmp skips `inflateEnd()` and the Zlib state is leaked,
+ // ruining the pristine Valgrind output.
+ //
+ // Since we do the trap anyway, this is the way we handle explicit errors
+ // called in the code below also.
+ //
+ struct Reb_State state;
+ REBCTX *error;
+
+ PUSH_UNHALTABLE_TRAP(&error, &state);
+
+// The first time through the following code 'error' will be NULL, but...
+// `fail` can longjmp here, so 'error' won't be NULL *if* that happens!
+
+ if (error) {
+ //
+ // output will already have been freed
+ //
+ inflateEnd(&strm);
+ fail (error);
+ }
+
+ REBCNT buf_size;
+ if (gzip || !raw) {
+ //
+ // Both gzip and Rebol's envelope have the size living in the last
+ // 4 bytes of the payload.
+ //
+ assert(sizeof(REBCNT) == 4);
+ if (len <= sizeof(REBCNT)) {
+ // !!! Better error message needed
+ fail (Error_Past_End_Raw());
+ }
+ buf_size = Bytes_To_REBCNT(input + len - sizeof(REBCNT));
+
+ // If we know the size is too big go ahead and report an error
+ // before doing the buffer allocation
+ //
+ if (max >= 0 && buf_size > cast(REBCNT, max)) {
+ DECLARE_LOCAL (temp);
+ Init_Integer(temp, max);
+
+ // NOTE: You can hit this if you 'make prep' without doing a full
+ // rebuild. 'make clean' and build again, it should go away.
+ //
+ fail (Error_Size_Limit_Raw(temp));
+ }
+ }
+ else {
+ // We need some logic for dealing with guessing the size of a zlib
+ // compression when there's no header. There is no way a priori to
+ // know what that size will be:
+ //
+ // http://stackoverflow.com/q/929757/211160
+ //
+ // If the user's pass in for the "max" seems in the ballpark of a
+ // compression ratio (as opposed to some egregious large number)
+ // then use it, because often that will be the exact size.
+ //
+ // If the guess is wrong, then the decompression has to keep making
+ // a bigger buffer and trying to continue. Better heuristics welcome.
+
+ // "Typical zlib compression ratios are from 1:2 to 1:5"
+
+ if (max >= 0 && (cast(REBCNT, max) < len * 6))
+ buf_size = max;
+ else
+ buf_size = len * 3;
+ }
+
+ // Since the initialization succeeded, go ahead and make the output buffer
+ //
+ REBSER *output = Make_Binary(buf_size);
+ strm.avail_out = buf_size;
+ strm.next_out = BIN_HEAD(output);
+
+ // Loop through and allocate a larger buffer each time we find the
+ // decompression did not run to completion. Stop if we exceed max.
+ //
+ while (TRUE) {
+
+ // Perform the inflation
+ //
+ ret = inflate(&strm, Z_NO_FLUSH);
+
+ if (ret == Z_STREAM_END) {
+ //
+ // Finished with the buffer being big enough...
+ //
+ break;
+ }
+
+ if (ret != Z_OK)
+ fail (Error_Compression(&strm, ret));
+
+ // Still more data to come. Use remaining data amount to guess
+ // size to add.
+ //
+ REBCNT old_size = buf_size;
+
+ if (max >= 0 && buf_size >= cast(REBCNT, max)) {
+ DECLARE_LOCAL (temp);
+ Init_Integer(temp, max);
+
+ // NOTE: You can hit this on 'make prep' without doing a full
+ // rebuild. 'make clean' and build again, it should go away.
+ //
+ fail (Error_Size_Limit_Raw(temp));
+ }
+
+ buf_size = buf_size + strm.avail_in * 3;
+ if (max >= 0 && buf_size > cast(REBCNT, max))
+ buf_size = max;
+
+ assert(strm.avail_out == 0); // !!! is this guaranteed?
+ assert(
+ strm.next_out == BIN_HEAD(output) + old_size - strm.avail_out
+ );
+
+ Extend_Series(output, buf_size - old_size);
+
+ // Extending keeps the content but may realloc the pointer, so
+ // put it at the same spot to keep writing to
+ //
+ strm.next_out = BIN_HEAD(output) + old_size - strm.avail_out;
+
+ strm.avail_out += buf_size - old_size;
+ }
+
+ TERM_BIN_LEN(output, strm.total_out);
+
+ // !!! Trim if more than 1K extra capacity, review logic
+ //
+ if (SER_AVAIL(output) > 1024) {
+ REBSER *smaller = Copy_Sequence(output);
+ Free_Series(output);
+ output = smaller;
+ }
+
+ DROP_TRAP_SAME_STACKLEVEL_AS_PUSH(&state);
+
+ // Make this the last thing done so strm variables can be read up to end
+ //
+ inflateEnd(&strm);
+
+ return output;
}
diff --git a/src/core/u-dialect.c b/src/core/u-dialect.c
deleted file mode 100644
index eba3e6dfa6..0000000000
--- a/src/core/u-dialect.c
+++ /dev/null
@@ -1,548 +0,0 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: u-dialect.c
-** Summary: support for dialecting
-** Section: utility
-** Author: Carl Sassenrath
-** Notes:
-**
-***********************************************************************/
-
-#include "sys-core.h"
-#include "reb-dialect.h"
-
-typedef struct Reb_Dialect_Parse {
- REBSER *dialect; // dialect object
- REBSER *fargs; // formal arg block
- REBCNT fargi; // start index in fargs
- REBSER *args; // argument block
- REBCNT argi; // current arg index
- REBINT cmd; // command id
- REBINT len; // limit of current command
- REBSER *out; // result block
- REBINT outi; // result block index
- REBINT flags;
- REBINT missed; // counter of arg misses
- REBVAL *contexts; // contexts to search for variables
-} REBDIA;
-
-enum {
- RDIA_NO_CMD, // do not store command in block
- RDIA_LIT_CMD, // 'command
- RDIA_ALL, // all commands, do not reset output
-};
-
-static REBINT Delect_Debug = 0;
-static REBINT Total_Missed = 0;
-static char *Dia_Fmt = "DELECT - cmd: %s length: %d missed: %d total: %d";
-
-
-/***********************************************************************
-**
-*/ static int Find_Command(REBSER *dialect, REBVAL *word)
-/*
-** Given a word, check to see if it is in the dialect object.
-** If so, return its index. If not, return 0.
-**
-***********************************************************************/
-{
- REBINT n;
-
- if (dialect == VAL_WORD_FRAME(word)) n = VAL_WORD_INDEX(word);
- else {
- if (NZ(n = Find_Word_Index(dialect, VAL_WORD_SYM(word), FALSE))) {
- VAL_WORD_FRAME(word) = dialect;
- VAL_WORD_INDEX(word) = n;
- }
- else return 0;
- }
-
- // If keyword (not command) return negated index:
- if (IS_NONE(FRM_VALUES(dialect) + n)) return -n;
- return n;
-}
-
-
-/***********************************************************************
-**
-*/ static int Count_Dia_Args(REBVAL *args)
-/*
-** Return number of formal args provided to the function.
-** This is just a guess, because * repeats count as zero.
-**
-***********************************************************************/
-{
- REBINT n = 0;
-
- for (; NOT_END(args); args++) {
- if (IS_WORD(args)) {
- if (VAL_WORD_SYM(args) == SYM__P) { // skip: * type
- if (NOT_END(args+1)) args++;
- } else n++;
- }
- else if (IS_DATATYPE(args) || IS_TYPESET(args)) n++;
- }
- return n;
-}
-
-
-/***********************************************************************
-**
-*/ static REBVAL *Eval_Arg(REBDIA *dia)
-/*
-** Handle all values passed in a dialect.
-**
-** Contexts can be used for finding a word in a block of
-** contexts without using a path.
-**
-** Returns zero on error.
-** Note: stack used to hold temp values
-**
-***********************************************************************/
-{
- REBVAL *value = BLK_SKIP(dia->args, dia->argi);
-
- switch (VAL_TYPE(value)) {
-
- case REB_WORD:
- // Only look it up if not part of dialect:
- if (Find_Command(dia->dialect, value) == 0) {
- REBVAL *val = value; // save
- if (dia->contexts) {
- value = Find_In_Contexts(VAL_WORD_CANON(value), dia->contexts);
- if (value) break;
- }
- value = Get_Var_No_Trap(val); // may return zero
- }
- break;
-
- case REB_PATH:
- if (Do_Path(&value, 0)) return 0;
- value = DS_TOP;
- break;
-
- case REB_LIT_WORD:
- DS_PUSH(value);
- value = DS_TOP;
- VAL_SET(value, REB_WORD);
- break;
-
- case REB_PAREN:
- value = DO_BLK(value);
- DS_SKIP; // do not overwrite TOS
- break;
- }
-
- return value;
-}
-
-
-/***********************************************************************
-**
-*/ static REBINT Add_Arg(REBDIA *dia, REBVAL *value)
-/*
-** Add an actual argument to the output block.
-**
-** Note that the argument may be out sequence with the formal
-** arguments so we must scan for a slot that matches.
-**
-** Returns:
-** 1: arg matches a formal arg and has been stored
-** 0: no arg of that type was found
-** -N: error (type block contains a bad value)
-**
-***********************************************************************/
-{
- REBINT type = 0;
- REBINT accept = 0;
- REBVAL *fargs;
- REBINT fargi;
- REBVAL *outp;
- REBINT rept = 0;
-
- outp = BLK_SKIP(dia->out, dia->outi);
-
- // Scan all formal args, looking for one that matches given value:
- for (fargi = dia->fargi;; fargi++) {
-
- //Debug_Fmt("Add_Arg fargi: %d outi: %d", fargi, outi);
-
- if (IS_END(fargs = BLK_SKIP(dia->fargs, fargi))) return 0;
-
-again:
- // Formal arg can be a word (type or refinement), datatype, or * (repeater):
- if (IS_WORD(fargs)) {
-
- // If word is a datatype name:
- type = VAL_WORD_CANON(fargs);
- if (type < REB_MAX) {
- type--; // the type id
- }
- else if (type == SYM__P) {
- // repeat: * integer!
- rept = 1;
- fargs++;
- goto again;
- }
- else {
- // typeset or refinement
- REBVAL *temp;
-
- type = -1;
-
- // Is it a refinement word?
- if (IS_WORD(value) && VAL_WORD_CANON(fargs) == VAL_WORD_CANON(value)) {
- accept = 4;
- }
- // Is it a typeset?
- else if (NZ(temp = Get_Var_No_Trap(fargs)) && IS_TYPESET(temp)) {
- if (TYPE_CHECK(temp, VAL_TYPE(value))) accept = 1;
- }
- else if (!IS_WORD(value)) return 0; // do not search past a refinement
- //else return -REB_DIALECT_BAD_SPEC;
- }
- }
- // It's been reduced and is an actual datatype or typeset:
- else if (IS_DATATYPE(fargs)) {
- type = VAL_DATATYPE(fargs);
- }
- else if (IS_TYPESET(fargs)) {
- if (TYPE_CHECK(fargs, VAL_TYPE(value))) accept = 1;
- } else
- return -REB_DIALECT_BAD_SPEC;
-
- // Make room for it in the output block:
- if (IS_END(outp))
- outp = Append_Value(dia->out);
- else if (!IS_NONE(outp)) {
- // There's already an arg in this slot, so skip it...
- if (dia->cmd > 1) outp++;
- if (!rept) continue; // see if there's another farg that will work for it
- // Look for first empty slot:
- while (NOT_END(outp) && !IS_NONE(outp)) outp++;
- if (IS_END(outp)) outp = Append_Value(dia->out);
- }
-
- // The datatype was correct from above!
- if (accept) break;
-
- //Debug_Fmt("want: %d got: %d rept: %d", type, VAL_TYPE(value), rept);
-
- // Direct match to datatype or to integer/decimal coersions:
- if (type == (REBINT)VAL_TYPE(value)) {
- accept = 1;
- break;
- }
- else if (type == REB_INTEGER && IS_DECIMAL(value)) {
- accept = 2;
- break;
- }
- else if (type == REB_DECIMAL && IS_INTEGER(value)) {
- accept = 3;
- break;
- }
-
- dia->missed++; // for debugging
-
- // Repeat did not match, so stop repeating and remove unused output slot:
- if (rept) {
- Remove_Last(dia->out);
- outp--;
- rept = 0;
- continue;
- }
-
- if (dia->cmd > 1) outp++; // skip output slot (for non-default values)
- }
-
- // Process the result:
- switch (accept) {
-
- case 1:
- *outp = *value;
- break;
-
- case 2:
- SET_INTEGER(outp, (REBI64)VAL_DECIMAL(value));
- break;
-
- case 3:
- SET_DECIMAL(outp, (REBDEC)VAL_INT64(value));
- break;
-
- case 4: // refinement:
- dia->fargi = fargs - BLK_HEAD(dia->fargs) + 1;
- dia->outi = outp - BLK_HEAD(dia->out) + 1;
- *outp = *value;
- return 1;
-
- case 0:
- return 0;
- }
-
- // Optimization: arg was in correct order:
- if (!rept && fargi == (signed)(dia->fargi)) {
- dia->fargi++;
- dia->outi++;
- }
-
- return 1;
-}
-
-
-/***********************************************************************
-**
-*/ static REBINT Do_Cmd(REBDIA *dia)
-/*
-** Returns the length of command processed or error. See below.
-**
-***********************************************************************/
-{
- REBVAL *fargs;
- REBINT size;
- REBVAL *val;
- REBINT err;
- REBINT n;
-
- // Get formal arguments block for this command:
- fargs = FRM_VALUES(dia->dialect) + dia->cmd;
- if (!IS_BLOCK(fargs)) return -REB_DIALECT_BAD_SPEC;
- dia->fargs = VAL_SERIES(fargs);
- fargs = VAL_BLK_DATA(fargs);
- size = Count_Dia_Args(fargs); // approximate
-
- // Preallocate output block (optimize for large blocks):
- if (dia->len > size) size = dia->len;
- if (GET_FLAG(dia->flags, RDIA_ALL)) {
- Extend_Series(dia->out, size+1);
- }
- else {
- Resize_Series(dia->out, size+1); // tail = 0
- CLEAR_SERIES(dia->out); // Be sure it is entirely cleared
- }
-
- // Insert command word:
- if (!GET_FLAG(dia->flags, RDIA_NO_CMD)) {
- val = Append_Value(dia->out);
- Set_Word(val, FRM_WORD_SYM(dia->dialect, dia->cmd), dia->dialect, dia->cmd);
- if (GET_FLAG(dia->flags, RDIA_LIT_CMD)) VAL_SET(val, REB_LIT_WORD);
- dia->outi++;
- size++;
- }
- if (dia->cmd > 1) dia->argi++; // default cmd has no word arg
-
- // Foreach argument provided:
- for (n = dia->len; n > 0; n--, dia->argi++) {
- val = Eval_Arg(dia);
- if (!val)
- return -REB_DIALECT_BAD_ARG;
- if (IS_END(val)) break;
- if (!IS_NONE(val)) {
- //Print("n %d len %d argi %d", n, dia->len, dia->argi);
- err = Add_Arg(dia, val); // 1: good, 0: no-type, -N: error
- if (err == 0) return n; // remainder
- if (err < 0) return err;
- }
- }
-
- // If not enough args, pad with NONE values:
- if (dia->cmd > 1) {
- for (n = SERIES_TAIL(dia->out); n < size; n++) {
- Append_Value(dia->out);
- }
- }
-
- dia->outi = SERIES_TAIL(dia->out);
-
- return 0;
-}
-
-
-/***********************************************************************
-**
-*/ static REBINT Do_Dia(REBDIA *dia)
-/*
-** Process the next command in the dialect.
-** Returns the length of command processed.
-** Zero indicates end of block.
-** Negative indicate error.
-** The args holds resulting args.
-**
-***********************************************************************/
-{
- REBVAL *next = BLK_SKIP(dia->args, dia->argi);
- REBVAL *head;
- REBINT err;
-
- if (IS_END(next)) return 0;
-
- // Find the command if a word is provided:
- if (IS_WORD(next) || IS_LIT_WORD(next)) {
- if (IS_LIT_WORD(next)) SET_FLAG(dia->flags, RDIA_LIT_CMD);
- dia->cmd = Find_Command(dia->dialect, next);
- }
-
- // Handle defaults - process values before a command is reached:
- if (dia->cmd <= 1) {
- dia->cmd = 1;
- dia->len = 1;
- err = Do_Cmd(dia); // DEFAULT cmd
- // It must be processed, else it is not in the dialect.
- // Check for noop result:
- if (err > 0) err = -REB_DIALECT_BAD_ARG;
- return err;
- }
-
- // Delimit the command - search for next command or end:
- for (head = ++next; NOT_END(next); next++) {
- if ((IS_WORD(next) || IS_LIT_WORD(next)) && Find_Command(dia->dialect, next) > 1) break;
- }
-
- // Note: command may be shorter than length provided here (defaults):
- dia->len = next - head; // length of args, not including command
- err = Do_Cmd(dia);
- if (GET_FLAG(dia->flags, RDIA_LIT_CMD)) dia->cmd += DIALECT_LIT_CMD;
- return err;
-}
-
-
-/***********************************************************************
-**
-*/ REBINT Do_Dialect(REBSER *dialect, REBSER *block, REBCNT *index, REBSER **out)
-/*
-** Format for dialect is:
-** CMD arg1 arg2 arg3 CMD arg1 arg2 ...
-**
-** Returns:
-** cmd value or error as result (or zero for end)
-** index is updated
-** if *out is zero, then we create a new output block
-**
-** The arg sequence is terminated by:
-** 1. Maximum # of args for command
-** 2. An arg that is not of a specified datatype for CMD
-** 3. Encountering a new CMD
-** 4. End of the dialect block
-**
-***********************************************************************/
-{
- REBDIA dia;
- REBINT n;
- REBINT dsp = DSP; // Save stack position
-
- CLEARS(&dia);
-
- if (*index >= SERIES_TAIL(block)) return 0; // end of block
-
- DISABLE_GC; // Avoid GC during Dialect (prevents unknown crash problem)
-
- if (!*out) *out = Make_Block(25);
-
- dia.dialect = dialect;
- dia.args = block;
- dia.argi = *index;
- dia.out = *out;
- SET_FLAG(dia.flags, RDIA_NO_CMD);
-
- //Print("DSP: %d Dinp: %r - %m", DSP, BLK_SKIP(block, *index), block);
- n = Do_Dia(&dia);
- //Print("DSP: %d Dout: CMD: %d %m", DSP, dia.cmd, *out);
- DSP = dsp; // pop any temp values used above
-
- if (Delect_Debug > 0) {
- Total_Missed += dia.missed;
- // !!!! debug
- if (dia.missed) Debug_Fmt(Dia_Fmt, Get_Field_Name(dia.dialect, dia.cmd), dia.out->tail, dia.missed, Total_Missed);
- }
-
- if (n < 0) return n; //error
- *index = dia.argi;
-
- ENABLE_GC;
-
- return dia.cmd;
-}
-
-
-/***********************************************************************
-**
-*/ REBNATIVE(delect)
-/*
-***********************************************************************/
-{
- REBDIA dia;
- REBINT err;
- REBFLG all;
-
- CLEARS(&dia);
-
- dia.dialect = VAL_OBJ_FRAME(D_ARG(1));
- dia.args = VAL_SERIES(D_ARG(2));
- dia.argi = VAL_INDEX(D_ARG(2));
- dia.out = VAL_SERIES(D_ARG(3));
- dia.outi = VAL_INDEX(D_ARG(3));
-
- if (dia.argi >= SERIES_TAIL(dia.args)) return R_NONE; // end of block
-
- if (D_REF(4)) { // in
- if (!IS_BLOCK(dia.contexts = D_ARG(5))) Trap_Arg(dia.contexts);
- dia.contexts = VAL_BLK_DATA(dia.contexts);
- }
-
- if (NZ(all = D_REF(6))) {
- SET_FLAG(dia.flags, RDIA_ALL);
- Resize_Series(dia.out, VAL_LEN(D_ARG(2)));
- while (TRUE) {
- dia.cmd = 0;
- dia.len = 0;
- dia.fargi = 0;
- err = Do_Dia(&dia);
- //Debug_Fmt("Ret: %d argi: %d outi: %d len: %d", err, dia.argi, dia.outi, dia.len);
- if (err < 0 || IS_END(BLK_SKIP(dia.args, dia.argi))) break;
- }
- }
- else
- err = Do_Dia(&dia);
-
- DS_RELOAD(ds);
-
- VAL_INDEX(D_ARG(2)) = MIN(dia.argi, SERIES_TAIL(dia.args));
-
- if (Delect_Debug > 0) {
- Total_Missed += dia.missed;
- if (dia.missed) Debug_Fmt(Dia_Fmt, Get_Field_Name(dia.dialect, dia.cmd), dia.out->tail, dia.missed, Total_Missed);
- }
-
- if (err < 0) Trap_Arg(D_ARG(2)); // !!! needs better error
-
- return R_ARG2;
-}
-
-
-/***********************************************************************
-**
-*/ void Trace_Delect(REBINT level)
-/*
-***********************************************************************/
-{
- Delect_Debug = level;
-}
diff --git a/src/core/u-gif.c b/src/core/u-gif.c
deleted file mode 100644
index fda8b01ea0..0000000000
--- a/src/core/u-gif.c
+++ /dev/null
@@ -1,347 +0,0 @@
-/***********************************************************************
-**
-** REBOL [R3] Language Interpreter and Run-time Environment
-**
-** Copyright 2012 REBOL Technologies
-** REBOL is a trademark of REBOL Technologies
-**
-** Licensed under the Apache License, Version 2.0 (the "License");
-** you may not use this file except in compliance with the License.
-** You may obtain a copy of the License at
-**
-** http://www.apache.org/licenses/LICENSE-2.0
-**
-** Unless required by applicable law or agreed to in writing, software
-** distributed under the License is distributed on an "AS IS" BASIS,
-** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-** See the License for the specific language governing permissions and
-** limitations under the License.
-**
-************************************************************************
-**
-** Module: u-gif.c
-** Summary: GIF image format conversion
-** Section: utility
-** Notes:
-** This is an optional part of R3. This file can be replaced by
-** library function calls into an updated implementation.
-**
-***********************************************************************/
-
-#include "sys-core.h"
-
-
-#define MAX_STACK_SIZE 4096
-#define NULL_CODE (-1)
-#define BitSet(byte,bit) (((byte) & (bit)) == (bit))
-#define LSBFirstOrder(x,y) (((y) << 8) | (x))
-
-static REBINT interlace_rate[4] = { 8, 8, 4, 2 },
- interlace_start[4] = { 0, 4, 2, 1 };
-
-
-#ifdef COMP_IMAGES
-// Because graphics.c is not included, we must have a copy here.
-void Chrom_Key_Alpha(REBVAL *v,REBCNT col,REBINT blitmode) {
- REBOOL found=FALSE;
- int i;
- REBCNT *p;
-
- p=(REBCNT *)VAL_IMAGE_HEAD(v);
- i=VAL_IMAGE_WIDTH(v)*VAL_IMAGE_HEIGHT(v);
- switch(blitmode) {
- case BLIT_MODE_COLOR:
- for(;i>0;i--,p++) {
- if(*p==col) {
- found=TRUE;
- *p=col|0xff000000;
- }
- }
- case BLIT_MODE_LUMA:
- for(;i>0;i--,p++) {
- if(BRIGHT(((REBRGB *)p))<=col) {
- found=TRUE;
- *p|=0xff000000;
- }
- }
- break;
- }
- if(found)
- VAL_IMAGE_TRANSP(v)=VITT_ALPHA;
-}
-#endif
-
-/***********************************************************************
-**
-*/ void Decode_LZW(REBCNT *data, REBYTE **cpp, REBYTE *colortab, REBINT w, REBINT h, REBOOL interlaced)
-/*
-** Perform LZW decompression.
-**
-***********************************************************************/
-{
- REBYTE *cp = *cpp;
- REBYTE *rp;
- REBINT available, clear, code_mask, code_size, end_of_info, in_code;
- REBINT old_code, bits, code, count, x, y, data_size, row, i;
- REBCNT *dp, datum;
- short *prefix;
- REBYTE first, *pixel_stack, *suffix, *top_stack;
-
- suffix = Make_Mem(MAX_STACK_SIZE * (sizeof(REBYTE) + sizeof(REBYTE) + sizeof(short)));
- pixel_stack = suffix + MAX_STACK_SIZE;
- prefix = (short *)(pixel_stack + MAX_STACK_SIZE);
-
- data_size = *cp++;
- clear = 1 << data_size;
- end_of_info = clear + 1;
- available = clear + 2;
- old_code = NULL_CODE;
- code_size = data_size + 1;
- code_mask = (1 << code_size) - 1;
-
- for (code=0; code>= code_size;
- bits -= code_size;
-
- // sanity check
- if (code > available || code == end_of_info)
- break;
- // time to reset the tables
- if (code == clear) {
- code_size = data_size + 1;
- code_mask = (1 << code_size) - 1;
- available = clear + 2;
- old_code = NULL_CODE;
- continue;
- }
- // if we are the first code, just stack it
- if (old_code == NULL_CODE) {
- *top_stack++ = suffix[code];
- old_code = code;
- first = code;
- continue;
- }
- in_code = code;
- if (code == available) {
- *top_stack++ = first;
- code = old_code;
- }
- while (code > clear) {
- *top_stack++ = suffix[code];
- code = prefix[code];
- }
- first = suffix[code];
-
- // add a new string to the table
- if (available >= MAX_STACK_SIZE)
- break;
- *top_stack++ = first;
- prefix[available] = old_code;
- suffix[available++] = first;
- if ((available & code_mask) == 0 && available < MAX_STACK_SIZE) {
- code_size++;
- code_mask += available;
- }
- old_code = in_code;
- }
- top_stack--;
- rp = colortab + 3 * *top_stack;
- *dp++ = rp[2] | (rp[1] << 8) | (rp[0] << 16);
- x++;
- }
- if (interlaced) {
- row += interlace_rate[i];
- if (row >= h) {
- row = interlace_start[++i];
- }
- dp = data + row * w;
- }
- }
- *cpp = cp + count + 1;
- Free_Mem(suffix, MAX_STACK_SIZE * (sizeof(REBYTE) + sizeof(REBYTE) + sizeof(short)));
-}
-
-
-/***********************************************************************
-**
-*/ void Decode_GIF_Image(REBCDI *codi)
-/*
-** Input: GIF encoded image (codi->data, len)
-** Output: Image bits (codi->bits, w, h)
-** Error: Code in codi->error
-** Return: Success as TRUE or FALSE
-**
-***********************************************************************/
-{
- REBINT w, h;
- REBINT transparency_index;
- REBYTE c, *global_colormap, *colormap;
- REBCNT global_colors, image_count, local_colormap;
- REBCNT colors;
- REBYTE *cp;
- REBCNT *dp;
- REBOOL interlaced;
- REBYTE *end;
-
- cp = codi->data;
- end = codi->data + codi->len;
-
- if (strncmp((char *)cp, "GIF87", 5) != 0 && strncmp((char *)cp, "GIF89", 5) != 0) {
- codi->error = CODI_ERR_SIGNATURE;
- return;
- }
- if (codi->action == CODI_IDENTIFY) return; // no error means success
-
- global_colors = 0;
- global_colormap = (unsigned char *) NULL;
- if (cp[10] & 0x80) {
- // Read global colormap.
- global_colors = 1 << ((cp[10] & 0x07) + 1);
- global_colormap = cp + 13;
- cp += global_colors * 3;
- }
- cp += 13;
- transparency_index = -1;
- image_count = 0;
- for (;;) {
- if (cp >= end) break;
- c = *cp++;
-
- if (c == ';')
- break; // terminator
-
- if (c == '!') {
- // GIF Extension block.
- c = *cp++;
- switch (c) {
- case 0xf9:
- // Transparency extension block.
- while (cp[0] != 0 && cp[5] != 0)
- cp += 5;
- if ((cp[1] & 0x01) == 1)
- transparency_index = cp[4];
- cp += cp[0] + 1 + 1;
- break;
-
- default:
- while (cp[0] != 0)
- cp += cp[0] + 1;
- cp++;
- break;
- }
- }
-
- if (c != ',') continue;
-
- image_count++;
- interlaced = (cp[8] & 0x40) != 0;
- local_colormap = cp[8] & 0x80;
-
- w = LSBFirstOrder(cp[4],cp[5]);
- h = LSBFirstOrder(cp[6],cp[7]);
- // if(w * h * 4 > VAL_STR_LEN(img))
- // h = 4 * VAL_STR_LEN(img) / w;
-
- // Inititialize colormap.
- colors = !local_colormap ? global_colors : 1 << ((cp[8] & 0x07)+1);
- if (!local_colormap) {
- colormap = global_colormap;
- }
- else {
- colormap = cp + 9;
- cp += 3 * colors;
- }
- cp += 9;
-
-/*
- if (image_count == 2) {
- VAL_SERIES(Temp2_Value) = Make_Block(0, 0);
- VAL_INIT(Temp2_Value, REB_BLOCK);
- VAL_INDEX(Temp2_Value) = 0;
- Append_Series(VAL_SERIES(Temp2_Value), (REBMEM *)Temp_Value, 1);
- }
-*/
- dp = codi->bits = (u32 *)Make_Mem(w * h * 4);
- codi->w = w;
- codi->h = h;
-
- Decode_LZW(dp, &cp, colormap, w, h, interlaced);
-
- if(transparency_index >= 0) {
- int ADD_alpha_key_detection;
- REBYTE *p=colormap+3*transparency_index;
- ///Chroma_Key_Alpha(Temp_Value, (REBCNT)(p[2]|(p[1]<<8)|(p[0]<<16)), BLIT_MODE_COLOR);
- }
-
-// if (image_count == 1)
-// *Temp2_Value = *Temp_Value;
-// else
-// Append_Series(VAL_SERIES(Temp2_Value), (REBMEM *)Temp_Value, 1);
- }
-}
-
-
-/***********************************************************************
-**
-*/ REBINT Codec_GIF_Image(REBCDI *codi)
-/*
-***********************************************************************/
-{
- codi->error = 0;
-
- if (codi->action == CODI_IDENTIFY) {
- Decode_GIF_Image(codi);
- return CODI_CHECK; // error code is inverted result
- }
-
- if (codi->action == CODI_DECODE) {
- Decode_GIF_Image(codi);
- return CODI_IMAGE;
- }
-
- codi->error = CODI_ERR_NA;
- return CODI_ERROR;
-}
-
-
-/***********************************************************************
-**
-*/ void Init_GIF_Codec(void)
-/*
-***********************************************************************/
-{
- Register_Codec("gif", Codec_GIF_Image);
-}
diff --git a/src/core/u-md5.c b/src/core/u-md5.c
index 958e8707b5..73675819d6 100644
--- a/src/core/u-md5.c
+++ b/src/core/u-md5.c
@@ -1,126 +1,127 @@
#include "sys-core.h"
#include
-#include