_darcs
*.obj
*.o
+*.s
*.exe
Factor/factor
*.a
temp
logs
work
-misc/wordsize
\ No newline at end of file
+build-support/wordsize
EXE_OBJS = $(PLAF_EXE_OBJS)
-default: misc/wordsize
- $(MAKE) `./misc/target`
+default:
+ $(MAKE) `./build-support/factor.sh make-target`
help:
@echo "Run '$(MAKE)' with one of the following parameters:"
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
-misc/wordsize: misc/wordsize.c
- gcc misc/wordsize.c -o misc/wordsize
-
clean:
rm -f vm/*.o
rm -f factor*.dll libfactor*.*
* Contents
-- Platform support
- Compiling the Factor VM
- Libraries needed for compilation
- Bootstrapping the Factor image
- Source organization
- Community
-* Platform support
-
-Factor supports the following platforms:
-
- Linux/x86
- Linux/AMD64
- Linux/PowerPC
- Linux/ARM
- Mac OS X/x86
- Mac OS X/PowerPC
- FreeBSD/x86
- FreeBSD/AMD64
- OpenBSD/x86
- OpenBSD/AMD64
- Solaris/x86
- Solaris/AMD64
- MS Windows/x86 (XP and above)
- MS Windows CE/ARM
-
-Please donate time or hardware if you wish to see Factor running on
-other platforms. In particular, we are interested in:
-
- Windows/AMD64
- Mac OS X/AMD64
- Solaris/UltraSPARC
- Linux/MIPS
-
* Compiling the Factor VM
The Factor runtime is written in GNU C99, and is built with GNU make and
gcc.
-Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
-3.3 or earlier. If you are using gcc 4.3, you might get an unusable
-Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the
-command-line arguments for make.
+Factor supports various platforms. For an up-to-date list, see
+<http://factorcode.org/getfactor.fhtml>.
+
+Factor requires gcc 3.4 or later.
+
+On x86, Factor /will not/ build using gcc 3.3 or earlier.
+
+If you are using gcc 4.3, you might get an unusable Factor binary unless
+you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
+arguments for make.
-Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of
-targets and build options. Then run 'make' with the appropriate target
-for your platform.
+Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
Compilation will yield an executable named 'factor' on Unix,
-'factor-nt.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
+'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
* Libraries needed for compilation
-For X11 support, you need recent development libraries for libc, Freetype,
-X11, OpenGL and GLUT. On a Debian-derived Linux distribution (like Ubuntu),
-you can use the line
+For X11 support, you need recent development libraries for libc,
+Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
+(like Ubuntu), you can use the line
-sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
+ sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
-to grab everything (if you're on a non-debian-derived distro please tell us
-what the equivalent command is on there and it can be added :)
+to grab everything (if you're on a non-debian-derived distro please tell
+us what the equivalent command is on there and it can be added).
* Bootstrapping the Factor image
-The boot images are no longer included with the Factor distribution
-due to size concerns. Instead, download a boot image from:
-
- http://factorcode.org/images/
-
Once you have compiled the Factor runtime, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture.
-Once you download the right image, bootstrap the system with the
+Boot images can be obtained from <http://factorcode.org/images/latest/>.
+
+Once you download the right image, bootstrap Factor with the
following command line:
./factor -i=boot.<cpu>.image
-Or this command for Mac OS X systems:
-
-./Factor.app/Contents/MacOS/factor -i=boot.<cpu>.image
-
Bootstrap can take a while, depending on your system. When the process
completes, a 'factor.image' file will be generated. Note that this image
is both CPU and OS-specific, so in general cannot be shared between
* Running Factor on Mac OS X - Cocoa UI
-On Mac OS X 10.4 and later, a Cocoa UI is available in addition to the
-terminal listener. If you are using Mac OS X 10.3, you can only run the
-X11 UI, as documented in the next section.
+On Mac OS X, a Cocoa UI is available in addition to the terminal
+listener.
The 'factor' executable runs the terminal listener:
* Running Factor on Mac OS X - X11 UI
-The X11 UI is available on Mac OS X, however its use is not recommended
-since it does not integrate with the host OS. However, if you are
-running Mac OS X 10.3, it is your only choice.
+The X11 UI is also available on Mac OS X, however its use is not
+recommended since it does not integrate with the host OS.
When compiling Factor, pass the X11=1 parameter:
- make macosx-ppc X11=1
+ make X11=1
Then bootstrap with the following switches:
- ./factor -i=boot.ppc.image -ui-backend=x11
+ ./factor -i=boot.<cpu>.image -ui-backend=x11
Now if $DISPLAY is set, running ./factor will start the UI.
If you did not download the binary package, you can bootstrap Factor in
the command prompt:
- factor-nt.exe -i=boot.x86.32.image
+ factor.exe -i=boot.<cpu>.image
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
To run the listener in the command prompt:
- factor-nt.exe -run=listener
+ factor.exe -run=listener
* The Factor FAQ
-The Factor FAQ lives online at http://factorcode.org/faq.fhtml
+The Factor FAQ is available at <http://factorcode.org/faq.fhtml>.
* Command line usage
-The Factor VM supports a number of command line switches. To read
-command line usage documentation, either enter the following in the UI
-listener:
+Factor supports a number of command line switches. To read command line
+usage documentation, enter the following in the UI listener:
"command-line" about
* Source organization
-The following two directories are managed by the module system; consult
-the documentation for details:
+The Factor source tree is organized as follows:
+ build-support/ - scripts used for compiling Factor
core/ - Factor core library and compiler
extra/ - more libraries
-
-The following directories contain additional files:
-
- misc/ - editor modes, icons, etc
- vm/ - sources for the Factor runtime, written in C
fonts/ - TrueType fonts used by UI
+ misc/ - editor modes, icons, etc
unmaintained/ - unmaintained contributions, please help!
+ vm/ - sources for the Factor VM, written in C
* Community
--- /dev/null
+#!/usr/bin/env bash
+
+# Programs returning != 0 will not cause script to exit
+set +e
+
+# Case insensitive string comparison
+shopt -s nocaseglob
+#shopt -s nocasematch
+
+ECHO=echo
+OS=
+ARCH=
+WORD=
+NO_UI=
+GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
+GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
+
+test_program_installed() {
+ if ! [[ -n `type -p $1` ]] ; then
+ return 0;
+ fi
+ return 1;
+}
+
+ensure_program_installed() {
+ installed=0;
+ for i in $* ;
+ do
+ $ECHO -n "Checking for $i..."
+ test_program_installed $i
+ if [[ $? -eq 0 ]]; then
+ echo -n "not "
+ else
+ installed=$(( $installed + 1 ))
+ fi
+ $ECHO "found!"
+ done
+ if [[ $installed -eq 0 ]] ; then
+ $ECHO -n "Install "
+ if [[ $# -eq 1 ]] ; then
+ $ECHO -n $1
+ else
+ $ECHO -n "any of [ $* ]"
+ fi
+ $ECHO " and try again."
+ exit 1
+ fi
+}
+
+check_ret() {
+ RET=$?
+ if [[ $RET -ne 0 ]] ; then
+ $ECHO $1 failed
+ exit 2
+ fi
+}
+
+check_gcc_version() {
+ $ECHO -n "Checking gcc version..."
+ GCC_VERSION=`$CC --version`
+ check_ret gcc
+ if [[ $GCC_VERSION == *3.3.* ]] ; then
+ $ECHO "bad!"
+ $ECHO "You have a known buggy version of gcc (3.3)"
+ $ECHO "Install gcc 3.4 or higher and try again."
+ exit 3
+ fi
+ $ECHO "ok."
+}
+
+set_downloader() {
+ test_program_installed wget curl
+ if [[ $? -ne 0 ]] ; then
+ DOWNLOADER=wget
+ else
+ DOWNLOADER="curl -O"
+ fi
+}
+
+set_md5sum() {
+ test_program_installed md5sum
+ if [[ $? -ne 0 ]] ; then
+ MD5SUM=md5sum
+ else
+ MD5SUM="md5 -r"
+ fi
+}
+
+set_gcc() {
+ case $OS in
+ openbsd) ensure_program_installed egcc; CC=egcc;;
+ netbsd) if [[ $WORD -eq 64 ]] ; then
+ CC=/usr/pkg/gcc34/bin/gcc
+ else
+ CC=gcc
+ fi ;;
+ *) CC=gcc;;
+ esac
+}
+
+set_make() {
+ case $OS in
+ netbsd) MAKE='gmake';;
+ freebsd) MAKE='gmake';;
+ openbsd) MAKE='gmake';;
+ dragonflybsd) MAKE='gmake';;
+ *) MAKE='make';;
+ esac
+ if ! [[ $MAKE -eq 'gmake' ]] ; then
+ ensure_program_installed gmake
+ fi
+}
+
+check_installed_programs() {
+ ensure_program_installed chmod
+ ensure_program_installed uname
+ ensure_program_installed git
+ ensure_program_installed wget curl
+ ensure_program_installed gcc
+ ensure_program_installed make gmake
+ ensure_program_installed md5sum md5
+ ensure_program_installed cut
+ check_gcc_version
+}
+
+check_library_exists() {
+ GCC_TEST=factor-library-test.c
+ GCC_OUT=factor-library-test.out
+ $ECHO -n "Checking for library $1..."
+ $ECHO "int main(){return 0;}" > $GCC_TEST
+ $CC $GCC_TEST -o $GCC_OUT -l $1
+ if [[ $? -ne 0 ]] ; then
+ $ECHO "not found!"
+ $ECHO "Warning: library $1 not found."
+ $ECHO "***Factor will compile NO_UI=1"
+ NO_UI=1
+ fi
+ rm -f $GCC_TEST
+ check_ret rm
+ rm -f $GCC_OUT
+ check_ret rm
+ $ECHO "found."
+}
+
+check_X11_libraries() {
+ check_library_exists freetype
+ check_library_exists GLU
+ check_library_exists GL
+ check_library_exists X11
+}
+
+check_libraries() {
+ case $OS in
+ linux) check_X11_libraries;;
+ esac
+}
+
+check_factor_exists() {
+ if [[ -d "factor" ]] ; then
+ $ECHO "A directory called 'factor' already exists."
+ $ECHO "Rename or delete it and try again."
+ exit 4
+ fi
+}
+
+find_os() {
+ $ECHO "Finding OS..."
+ uname_s=`uname -s`
+ check_ret uname
+ case $uname_s in
+ CYGWIN_NT-5.2-WOW64) OS=winnt;;
+ *CYGWIN_NT*) OS=winnt;;
+ *CYGWIN*) OS=winnt;;
+ *darwin*) OS=macosx;;
+ *Darwin*) OS=macosx;;
+ *linux*) OS=linux;;
+ *Linux*) OS=linux;;
+ *NetBSD*) OS=netbsd;;
+ *FreeBSD*) OS=freebsd;;
+ *OpenBSD*) OS=openbsd;;
+ *DragonFly*) OS=dragonflybsd;;
+ esac
+}
+
+find_architecture() {
+ $ECHO "Finding ARCH..."
+ uname_m=`uname -m`
+ check_ret uname
+ case $uname_m in
+ i386) ARCH=x86;;
+ i686) ARCH=x86;;
+ amd64) ARCH=x86;;
+ ppc64) ARCH=ppc;;
+ *86) ARCH=x86;;
+ *86_64) ARCH=x86;;
+ "Power Macintosh") ARCH=ppc;;
+ esac
+}
+
+write_test_program() {
+ echo "#include <stdio.h>" > $C_WORD.c
+ echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
+}
+
+find_word_size() {
+ $ECHO "Finding WORD..."
+ C_WORD=factor-word-size
+ write_test_program
+ gcc -o $C_WORD $C_WORD.c
+ WORD=$(./$C_WORD)
+ check_ret $C_WORD
+ rm -f $C_WORD*
+}
+
+set_factor_binary() {
+ case $OS in
+ # winnt) FACTOR_BINARY=factor-nt;;
+ # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
+ *) FACTOR_BINARY=factor;;
+ esac
+}
+
+echo_build_info() {
+ $ECHO OS=$OS
+ $ECHO ARCH=$ARCH
+ $ECHO WORD=$WORD
+ $ECHO FACTOR_BINARY=$FACTOR_BINARY
+ $ECHO MAKE_TARGET=$MAKE_TARGET
+ $ECHO BOOT_IMAGE=$BOOT_IMAGE
+ $ECHO MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
+ $ECHO GIT_PROTOCOL=$GIT_PROTOCOL
+ $ECHO GIT_URL=$GIT_URL
+ $ECHO DOWNLOADER=$DOWNLOADER
+ $ECHO CC=$CC
+ $ECHO MAKE=$MAKE
+}
+
+set_build_info() {
+ if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
+ $ECHO "OS: $OS"
+ $ECHO "ARCH: $ARCH"
+ $ECHO "WORD: $WORD"
+ $ECHO "OS, ARCH, or WORD is empty. Please report this"
+ exit 5
+ fi
+
+ MAKE_TARGET=$OS-$ARCH-$WORD
+ MAKE_IMAGE_TARGET=$ARCH.$WORD
+ BOOT_IMAGE=boot.$ARCH.$WORD.image
+ if [[ $OS == macosx && $ARCH == ppc ]] ; then
+ MAKE_IMAGE_TARGET=$OS-$ARCH
+ MAKE_TARGET=$OS-$ARCH
+ BOOT_IMAGE=boot.macosx-ppc.image
+ fi
+ if [[ $OS == linux && $ARCH == ppc ]] ; then
+ MAKE_IMAGE_TARGET=$OS-$ARCH
+ MAKE_TARGET=$OS-$ARCH
+ BOOT_IMAGE=boot.linux-ppc.image
+ fi
+}
+
+find_build_info() {
+ find_os
+ find_architecture
+ find_word_size
+ set_factor_binary
+ set_build_info
+ set_downloader
+ set_gcc
+ set_make
+ echo_build_info
+}
+
+invoke_git() {
+ git $*
+ check_ret git
+}
+
+git_clone() {
+ echo "Downloading the git repository from factorcode.org..."
+ invoke_git clone $GIT_URL
+}
+
+git_pull_factorcode() {
+ echo "Updating the git repository from factorcode.org..."
+ invoke_git pull $GIT_URL master
+}
+
+cd_factor() {
+ cd factor
+ check_ret cd
+}
+
+invoke_make() {
+ $MAKE $*
+ check_ret $MAKE
+}
+
+make_clean() {
+ invoke_make clean
+}
+
+make_factor() {
+ invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5
+}
+
+update_boot_images() {
+ echo "Deleting old images..."
+ rm checksums.txt* > /dev/null 2>&1
+ rm $BOOT_IMAGE.* > /dev/null 2>&1
+ rm temp/staging.*.image > /dev/null 2>&1
+ if [[ -f $BOOT_IMAGE ]] ; then
+ get_url http://factorcode.org/images/latest/checksums.txt
+ factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
+ set_md5sum
+ case $OS in
+ netbsd) disk_md5=`md5 $BOOT_IMAGE | cut -f4 -d' '`;;
+ *) disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '` ;;
+ esac
+ echo "Factorcode md5: $factorcode_md5";
+ echo "Disk md5: $disk_md5";
+ if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
+ echo "Your disk boot image matches the one on factorcode.org."
+ else
+ rm $BOOT_IMAGE > /dev/null 2>&1
+ get_boot_image;
+ fi
+ else
+ get_boot_image
+ fi
+}
+
+get_boot_image() {
+ echo "Downloading boot image $BOOT_IMAGE."
+ get_url http://factorcode.org/images/latest/$BOOT_IMAGE
+}
+
+get_url() {
+ if [[ $DOWNLOADER -eq "" ]] ; then
+ set_downloader;
+ fi
+ echo $DOWNLOADER $1 ;
+ $DOWNLOADER $1
+ check_ret $DOWNLOADER
+}
+
+maybe_download_dlls() {
+ if [[ $OS == winnt ]] ; then
+ get_url http://factorcode.org/dlls/freetype6.dll
+ get_url http://factorcode.org/dlls/zlib1.dll
+ get_url http://factorcode.org/dlls/OpenAL32.dll
+ get_url http://factorcode.org/dlls/alut.dll
+ get_url http://factorcode.org/dlls/comerr32.dll
+ get_url http://factorcode.org/dlls/gssapi32.dll
+ get_url http://factorcode.org/dlls/iconv.dll
+ get_url http://factorcode.org/dlls/k5sprt32.dll
+ get_url http://factorcode.org/dlls/krb5_32.dll
+ get_url http://factorcode.org/dlls/libcairo-2.dll
+ get_url http://factorcode.org/dlls/libeay32.dll
+ get_url http://factorcode.org/dlls/libiconv2.dll
+ get_url http://factorcode.org/dlls/libintl3.dll
+ get_url http://factorcode.org/dlls/libpq.dll
+ get_url http://factorcode.org/dlls/libxml2.dll
+ get_url http://factorcode.org/dlls/libxslt.dll
+ get_url http://factorcode.org/dlls/msvcr71.dll
+ get_url http://factorcode.org/dlls/ogg.dll
+ get_url http://factorcode.org/dlls/pgaevent.dll
+ get_url http://factorcode.org/dlls/sqlite3.dll
+ get_url http://factorcode.org/dlls/ssleay32.dll
+ get_url http://factorcode.org/dlls/theora.dll
+ get_url http://factorcode.org/dlls/vorbis.dll
+ chmod 777 *.dll
+ check_ret chmod
+ fi
+}
+
+get_config_info() {
+ find_build_info
+ check_installed_programs
+ check_libraries
+}
+
+bootstrap() {
+ ./$FACTOR_BINARY -i=$BOOT_IMAGE
+}
+
+install() {
+ check_factor_exists
+ get_config_info
+ git_clone
+ cd_factor
+ make_factor
+ get_boot_image
+ maybe_download_dlls
+ bootstrap
+}
+
+
+update() {
+ get_config_info
+ git_pull_factorcode
+ make_clean
+ make_factor
+}
+
+update_bootstrap() {
+ update_boot_images
+ bootstrap
+}
+
+refresh_image() {
+ ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit"
+ check_ret factor
+}
+
+make_boot_image() {
+ ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit"
+ check_ret factor
+
+}
+
+install_build_system_apt() {
+ ensure_program_installed yes
+ yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
+ check_ret sudo
+}
+
+install_build_system_port() {
+ test_program_installed git
+ if [[ $? -ne 1 ]] ; then
+ ensure_program_installed yes
+ echo "git not found."
+ echo "This script requires either git-core or port."
+ echo "If it fails, install git-core or port and try again."
+ ensure_program_installed port
+ echo "Installing git-core with port...this will take awhile."
+ yes | sudo port install git-core
+ fi
+}
+
+usage() {
+ echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target"
+ echo "If you are behind a firewall, invoke as:"
+ echo "env GIT_PROTOCOL=http $0 <command>"
+}
+
+case "$1" in
+ install) install ;;
+ install-x11) install_build_system_apt; install ;;
+ install-macosx) install_build_system_port; install ;;
+ self-update) update; make_boot_image; bootstrap;;
+ quick-update) update; refresh_image ;;
+ update) update; update_bootstrap ;;
+ bootstrap) get_config_info; bootstrap ;;
+ dlls) get_config_info; maybe_download_dlls;;
+ net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
+ make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
+ *) usage ;;
+esac
--- /dev/null
+#include <stdio.h>
+#include <sys/event.h>
+
+#if defined(__FreeBSD__)
+ #define BSD
+ #define FREEBSD
+ #define UNIX
+#endif
+
+#if defined(__NetBSD__)
+ #define BSD
+ #define NETBSD
+ #define UNIX
+#endif
+
+#if defined(__OpenBSD__)
+ #define BSD
+ #define OPENBSD
+ #define UNIX
+#endif
+
+#if defined(__APPLE__)
+ #define BSD
+ #define MACOSX
+ #define UNIX
+#endif
+
+#if defined(linux)
+ #define LINUX
+ #define UNIX
+#endif
+
+#if defined(__amd64__) || defined(__x86_64__)
+ #define BIT64
+#else
+ #define BIT32
+#endif
+
+#if defined(UNIX)
+ #include <sys/types.h>
+ #include <sys/stat.h>
+ #include <sys/socket.h>
+ #include <sys/errno.h>
+ #include <sys/mman.h>
+ #include <sys/syslimits.h>
+ #include <fcntl.h>
+ #include <unistd.h>
+#endif
+
+#define BL printf(" ");
+#define QUOT printf("\"");
+#define NL printf("\n");
+#define LB printf("{"); BL
+#define RB BL printf("}");
+#define SEMI printf(";");
+#define grovel(t) printf("TYPEDEF: "); printf("%d", sizeof(t)); BL printf(#t); NL
+#define grovel2impl(t,n) BL BL BL BL LB QUOT printf(#t); QUOT BL QUOT printf((n)); QUOT RB
+#define grovel2(t,n) grovel2impl(t,n) NL
+#define grovel2end(t,n) grovel2impl(t,n) BL SEMI NL
+#define header(os) printf("vvv %s vvv", (os)); NL
+#define footer(os) printf("^^^ %s ^^^", (os)); NL
+#define header2(os,struct) printf("vvv %s %s vvv", (os), (struct)); NL
+#define footer2(os,struct) printf("^^^ %s %s ^^^", (os), (struct)); NL
+#define struct(n) printf("C-STRUCT: %s\n", (n));
+#define constant(n) printf("#define "); printf(#n); printf(" %d (HEX: %04x)", (n), (n)); NL
+
+void openbsd_types()
+{
+ header2("openbsd", "types");
+ grovel(dev_t);
+ grovel(gid_t);
+ grovel(ino_t);
+ grovel(int32_t);
+ grovel(int64_t);
+ grovel(mode_t);
+ grovel(nlink_t);
+ grovel(off_t);
+ grovel(struct timespec);
+ grovel(uid_t);
+ footer2("openbsd", "types");
+}
+
+void openbsd_stat()
+{
+ header2("openbsd", "stat");
+ struct("stat");
+ grovel2(dev_t, "st_dev");
+ grovel2(ino_t, "st_ino");
+ grovel2(mode_t, "st_mode");
+ grovel2(nlink_t, "st_nlink");
+ grovel2(uid_t, "st_uid");
+ grovel2(gid_t, "st_gid");
+ grovel2(dev_t, "st_rdev");
+ grovel2(int32_t, "st_lspare0");
+ grovel2(struct timespec, "st_atim");
+ grovel2(struct timespec, "st_mtim");
+ grovel2(struct timespec, "st_ctim");
+ grovel2(off_t, "st_size");
+ grovel2(int64_t, "st_blocks");
+ grovel2(u_int32_t, "st_blksize");
+ grovel2(u_int32_t, "st_flags");
+ grovel2(u_int32_t, "st_gen");
+ grovel2(int32_t, "st_lspare1");
+ grovel2(struct timespec, "st_birthtimespec");
+ grovel2(int64_t, "st_qspare1");
+ grovel2end(int64_t, "st_qspare2");
+ footer2("openbsd", "stat");
+}
+
+void unix_types()
+{
+ grovel(dev_t);
+ grovel(gid_t);
+ grovel(ino_t);
+ grovel(int32_t);
+ grovel(int64_t);
+ grovel(mode_t);
+ grovel(nlink_t);
+ grovel(off_t);
+ grovel(struct timespec);
+ grovel(struct stat);
+ grovel(time_t);
+ grovel(uid_t);
+}
+
+void unix_constants()
+{
+ constant(O_RDONLY);
+ constant(O_WRONLY);
+ constant(O_RDWR);
+ constant(O_APPEND);
+ constant(O_CREAT);
+ constant(O_TRUNC);
+ constant(O_EXCL);
+ constant(FD_SETSIZE);
+ constant(SOL_SOCKET);
+ constant(SO_REUSEADDR);
+ constant(SO_OOBINLINE);
+ constant(SO_SNDTIMEO);
+ constant(SO_RCVTIMEO);
+ constant(F_SETFL);
+ constant(O_NONBLOCK);
+ constant(EINTR);
+ constant(EAGAIN);
+ constant(EINPROGRESS);
+ constant(PROT_READ);
+ constant(PROT_WRITE);
+ constant(MAP_FILE);
+ constant(MAP_SHARED);
+ constant(PATH_MAX);
+ grovel(pid_t);
+
+}
+
+int main() {
+#ifdef FREEBSD
+ grovel(blkcnt_t);
+ grovel(blksize_t);
+ grovel(fflags_t);
+#endif
+
+#ifdef OPENBSD
+ openbsd_stat();
+ openbsd_types();
+#endif
+ grovel(blkcnt_t);
+ grovel(blksize_t);
+ //grovel(fflags_t);
+ grovel(ssize_t);
+
+ grovel(size_t);
+ grovel(struct kevent);
+#ifdef UNIX
+ unix_types();
+ unix_constants();
+#endif
+
+ return 0;
+}
{ $examples "Here is a typical usage of " { $link add-library } ":"
{ $code
"<< \"freetype\" {"
- " { [ macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
- " { [ windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
- " { [ t ] [ drop ] }"
+ " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
+ " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
+ " [ drop ]"
"} cond >>"
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."
$nl
"This is the safest approach, however it can lead to code heap leaks when repeatedly reloading code which defines callbacks. If you are " { $emphasis "completely sure" } " that no running C code is holding a reference to any callbacks, you can blow them all away:"
-{ $code "USE: alien callbacks get clear-hash code-gc" }
+{ $code "USE: alien callbacks get clear-hash gc" }
"This will reclaim all callback bodies which are otherwise unreachable from the dictionary (that is, their associated callback words have since been redefined, recompiled or forgotten)." ;
ARTICLE: "alien-callback" "Calling Factor from C"
"Callbacks can be defined and passed to C code as function pointers; the C code can then invoke the callback and run Factor code:"
{ $subsection alien-callback }
-"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
-{ $subsection "alien-callback-gc" } ;
+"There are some caveats concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
+{ $subsection "alien-callback-gc" }
+{ $see-also "byte-arrays-gc" } ;
ARTICLE: "dll.private" "DLL handles"
"DLL handles are a built-in class of objects which represent loaded native libraries. DLL handles are instances of the " { $link dll } " class, and have a literal syntax used for debugging prinouts; see " { $link "syntax-aliens" } "."
"The C library interface is entirely self-contained; there is no C code which one must write in order to wrap a library."
$nl
"C library interface words are found in the " { $vocab-link "alien" } " vocabulary."
-{ $warning "Since C does not retain runtime type information or do any kind of runtime type checking, any C library interface is not pointer safe. Improper use of C functions can crash the runtime or corrupt memory in unpredictible ways." }
+{ $warning "C does not perform runtime type checking, automatic memory management or array bounds checks. Incorrect usage of C library functions can lead to crashes, data corruption, and security exploits." }
{ $subsection "loading-libs" }
{ $subsection "alien-invoke" }
{ $subsection "alien-callback" }
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math namespaces sequences system
-kernel.private tuples bit-arrays byte-arrays float-arrays
-shuffle arrays macros ;
+kernel.private bit-arrays byte-arrays float-arrays arrays ;
IN: alien
! Some predicate classes used by the compiler for optimization
! purposes
-PREDICATE: alien simple-alien
+PREDICATE: simple-alien < alien
underlying-alien not ;
UNION: simple-c-ptr
DEFER: pinned-c-ptr?
-PREDICATE: alien pinned-alien
+PREDICATE: pinned-alien < alien
underlying-alien pinned-c-ptr? ;
UNION: pinned-c-ptr
: <alien> ( address -- alien )
f <displaced-alien> { simple-c-ptr } declare ; inline
-: alien>native-string ( alien -- string )
- windows? [ alien>u16-string ] [ alien>char-string ] if ;
-
-: dll-path ( dll -- string )
- (dll-path) alien>native-string ;
-
M: alien equal?
over alien? [
2dup [ expired? ] either? [
[ expired? ] both?
] [
- [ alien-address ] 2apply =
+ [ alien-address ] bi@ =
] if
] [
2drop f
: library ( name -- library ) libraries get at ;
: <library> ( path abi -- library )
- over dup [ dlopen ] when \ library construct-boa ;
+ over dup [ dlopen ] when \ library boa ;
: load-library ( name -- dll )
library dup [ library-dll ] when ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;
-TUPLE: alien-callback return parameters abi quot xt ;
-
-TUPLE: alien-callback-error ;
+ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
- \ alien-callback-error construct-empty throw ;
+ alien-callback-error ;
-TUPLE: alien-indirect return parameters abi ;
-
-TUPLE: alien-indirect-error ;
+ERROR: alien-indirect-error ;
: alien-indirect ( ... funcptr return parameters abi -- )
- \ alien-indirect-error construct-empty throw ;
-
-TUPLE: alien-invoke library function return parameters ;
+ alien-indirect-error ;
-TUPLE: alien-invoke-error library symbol ;
+ERROR: alien-invoke-error library symbol ;
: alien-invoke ( ... return library function parameters -- ... )
- 2over \ alien-invoke-error construct-boa throw ;
+ 2over alien-invoke-error ;
{ $subsection >c-ushort-array }\r
{ $subsection >c-void*-array }\r
{ $subsection c-bool-array> }\r
-{ $subsection c-char*-array> }\r
{ $subsection c-char-array> }\r
{ $subsection c-double-array> }\r
{ $subsection c-float-array> }\r
{ $subsection c-uint-array> }\r
{ $subsection c-ulong-array> }\r
{ $subsection c-ulonglong-array> }\r
-{ $subsection c-ushort*-array> }\r
{ $subsection c-ushort-array> }\r
{ $subsection c-void*-array> } ;\r
\r
{ $subsection double-nth }\r
{ $subsection set-double-nth }\r
{ $subsection void*-nth }\r
-{ $subsection set-void*-nth }\r
-{ $subsection char*-nth }\r
-{ $subsection ushort*-nth } ;\r
+{ $subsection set-void*-nth } ;\r
\r
ARTICLE: "c-arrays" "C arrays"\r
"C arrays are allocated in the same manner as other C data; see " { $link "c-byte-arrays" } " and " { $link "malloc" } "."\r
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays alien.c-types alien.structs
-sequences math kernel generator.registers
-namespaces libc ;
+sequences math kernel namespaces libc cpu.architecture ;
IN: alien.arrays
UNION: value-type array struct-type ;
M: array stack-size drop "void*" stack-size ;
-M: value-type c-type-reg-class drop T{ int-regs } ;
+M: value-type c-type-reg-class drop int-regs ;
-M: value-type c-type-prep drop f ;
+M: value-type c-type-boxer-quot drop f ;
+
+M: value-type c-type-unboxer-quot drop f ;
M: value-type c-type-getter
drop [ swap <displaced-alien> ] ;
{ <c-object> malloc-object } related-words
-HELP: string>char-alien ( string -- array )
-{ $values { "string" string } { "array" byte-array } }
-{ $description "Copies the string to a new byte array, converting it to 8-bit ASCII and adding a trailing null byte." }
-{ $errors "Throws an error if the string contains null characters, or characters beyond the 8-bit range." } ;
-
-{ string>char-alien alien>char-string malloc-char-string } related-words
-
-HELP: alien>char-string ( c-ptr -- string )
-{ $values { "c-ptr" c-ptr } { "string" string } }
-{ $description "Reads a null-terminated 8-bit C string from the specified address." } ;
-
-HELP: string>u16-alien ( string -- array )
-{ $values { "string" string } { "array" byte-array } }
-{ $description "Copies the string to a new byte array in UCS-2 format with a trailing null byte." }
-{ $errors "Throws an error if the string contains null characters." } ;
-
-{ string>u16-alien alien>u16-string malloc-u16-string } related-words
-
-HELP: alien>u16-string ( c-ptr -- string )
-{ $values { "c-ptr" c-ptr } { "string" string } }
-{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
-
HELP: memory>byte-array
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
-HELP: malloc-char-string
-{ $values { "string" string } { "alien" c-ptr } }
-{ $description "Allocates an unmanaged memory block, and stores a string in 8-bit ASCII encoding with a trailing null byte to the block." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if memory allocation fails." } ;
-
-HELP: malloc-u16-string
-{ $values { "string" string } { "alien" c-ptr } }
-{ $description "Allocates an unmanaged memory block, and stores a string in UCS2 encoding with a trailing null character to the block." }
-{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if memory allocation fails." } ;
-
HELP: define-nth
{ $values { "name" "a word name" } { "vocab" "a vocabulary name" } }
{ $description "Defines a word " { $snippet { $emphasis "name" } "-nth" } " with stack effect " { $snippet "( n c-ptr -- value )" } " for reading the value with C type " { $snippet "name" } " stored at an alien pointer, displaced by a multiple of the C type's size." }
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
+ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
+"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
+$nl
+"In particular, a byte array can only be passed as a parameter if the the C function does not use the parameter after one of the following occurs:"
+{ $list
+ "the C function returns"
+ "the C function calls Factor code via a callback"
+}
+"Returning from C to Factor, as well as invoking Factor code via a callback, may trigger garbage collection, and if the function had stored a pointer to the byte array somewhere, this pointer may cease to be valid."
+$nl
+"If this condition is not satisfied, " { $link "malloc" } " must be used instead."
+{ $warning "Failure to comply with these requirements can lead to crashes, data corruption, and security exploits." } ;
+
ARTICLE: "c-out-params" "Output parameters in C"
"A frequently-occurring idiom in C code is the \"out parameter\". If a C function returns more than one value, the caller passes pointers of the correct type, and the C function writes its return values to those locations."
$nl
{ $subsection *float }
{ $subsection *double }
{ $subsection *void* }
-{ $subsection *char* }
-{ $subsection *ushort* }
"Note that while structure and union types do not get these words defined for them, there is no loss of generality since " { $link <void*> } " and " { $link *void* } " may be used." ;
ARTICLE: "c-types-specs" "C type specifiers"
{ $subsection <c-object> }
{ $subsection <c-array> }
{ $warning
-"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the function does not store a pointer to the byte array in some global structure, or retain it in any way after returning."
-$nl
-"Long-lived data for use by C libraries can be allocated manually, just as when programming in C. See " { $link "malloc" } "." }
+"The Factor garbage collector can move byte arrays around, and code passing byte arrays to C must obey important guidelines. See " { $link "byte-arrays-gc" } "." }
{ $see-also "c-arrays" } ;
ARTICLE: "malloc" "Manual memory management"
-"Sometimes data passed to C functions must be allocated at a fixed address, and so garbage collector managed byte arrays cannot be used. See the warning at the bottom of " { $link "c-byte-arrays" } " for a description of when this is the case."
+"Sometimes data passed to C functions must be allocated at a fixed address. See " { $link "byte-arrays-gc" } " for an explanation of when this is the case."
$nl
"Allocating a C datum with a fixed address:"
{ $subsection malloc-object }
{ $subsection malloc }
{ $subsection calloc }
{ $subsection realloc }
-"The return value of the above three words must always be checked for a memory allocation failure:"
-{ $subsection check-ptr }
"You must always free pointers returned by any of the above words when the block of memory is no longer in use:"
{ $subsection free }
"You can unsafely copy a range of bytes from one memory location to another:"
"A wrapper for temporarily allocating a block of memory:"
{ $subsection with-malloc } ;
-ARTICLE: "c-strings" "C strings"
-"The C library interface defines two types of C strings:"
-{ $table
- { "C type" "Notes" }
- { { $snippet "char*" } "8-bit per character null-terminated ASCII" }
- { { $snippet "ushort*" } "16-bit per character null-terminated UCS-2" }
-}
-"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
-"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
-{ $subsection string>char-alien }
-{ $subsection string>u16-alien }
-{ $subsection malloc-char-string }
-{ $subsection malloc-u16-string }
-"The first two allocate " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } "."
-$nl
-"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
-{ $subsection alien>char-string }
-{ $subsection alien>u16-string } ;
-
ARTICLE: "c-data" "Passing data between Factor and C"
-"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
+"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers."
+$nl
+"Furthermore, Factor's garbage collector can move objects in memory; for a discussion of the consequences, see " { $link "byte-arrays-gc" } "."
{ $subsection "c-types-specs" }
{ $subsection "c-byte-arrays" }
{ $subsection "malloc" }
{ $subsection "c-strings" }
{ $subsection "c-arrays" }
{ $subsection "c-out-params" }
+"Important guidelines for passing data in byte arrays:"
+{ $subsection "byte-arrays-gc" }
"C-style enumerated types are supported:"
{ $subsection POSTPONE: C-ENUM: }
"C types can be aliased for convenience and consitency with native library documentation:"
IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
-sequences system libc ;
-
-[ "\u0000ff" ]
-[ "\u0000ff" string>char-alien alien>char-string ]
-unit-test
-
-[ "hello world" ]
-[ "hello world" string>char-alien alien>char-string ]
-unit-test
-
-[ "hello\u00abcdworld" ]
-[ "hello\u00abcdworld" string>u16-alien alien>u16-string ]
-unit-test
-
-[ t ] [ f expired? ] unit-test
-
-[ "hello world" ] [
- "hello world" malloc-char-string
- dup alien>char-string swap free
-] unit-test
-
-[ "hello world" ] [
- "hello world" malloc-u16-string
- dup alien>u16-string swap free
-] unit-test
+sequences system libc alien.strings io.encodings.utf8 ;
: foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
TYPEDEF: uchar* MyLPBYTE
-[ t ] [ "char*" c-type "MyLPBYTE" c-type eq? ] unit-test
+[ t ] [ { "char*" utf8 } c-type "MyLPBYTE" c-type = ] unit-test
[
0 B{ 1 2 3 4 } <displaced-alien> <void*>
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bit-arrays byte-arrays float-arrays arrays
-generator.registers assocs kernel kernel.private libc math
+assocs kernel kernel.private libc math
namespaces parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
-layouts system compiler.units io.files io.encodings.binary ;
+layouts system compiler.units io.files io.encodings.binary
+accessors combinators ;
IN: alien.c-types
DEFER: <int>
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type
-boxer prep unboxer
+boxer boxer-quot unboxer unboxer-quot
getter setter
reg-class size align stack-align? ;
+: new-c-type ( class -- type )
+ new
+ int-regs >>reg-class ;
+
: <c-type> ( -- type )
- T{ int-regs } { set-c-type-reg-class } \ c-type construct ;
+ \ c-type new-c-type ;
SYMBOL: c-types
c-types [ H{ } assoc-like ] change
] bind
-TUPLE: no-c-type name ;
-
-: no-c-type ( type -- * ) \ no-c-type construct-boa throw ;
+ERROR: no-c-type name ;
: (c-type) ( name -- type/f )
c-types get-global at dup [
: parse-array-type ( name -- array )
"[" split unclip
- >r [ "]" ?tail drop string>number ] map r> add* ;
+ >r [ "]" ?tail drop string>number ] map r> prefix ;
M: string c-type ( name -- type )
CHAR: ] over member? [
: malloc-byte-array ( byte-array -- alien )
dup length dup malloc [ -rot memcpy ] keep ;
-: malloc-char-string ( string -- alien )
- string>char-alien malloc-byte-array ;
-
-: malloc-u16-string ( string -- alien )
- string>u16-alien malloc-byte-array ;
-
: memory>byte-array ( alien len -- byte-array )
dup <byte-array> [ -rot memcpy ] keep ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;
-DEFER: >c-ushort-array
-
-: string>u16-memory ( string base -- )
- >r >c-ushort-array r> byte-array>memory ;
-
: (define-nth) ( word type quot -- )
- >r heap-size [ rot * ] swap add* r> append define-inline ;
+ >r heap-size [ rot * ] swap prefix r> append define-inline ;
: nth-word ( name vocab -- word )
>r "-nth" append r> create ;
: define-c-type ( type name vocab -- )
>r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
-TUPLE: long-long-type ;
+TUPLE: long-long-type < c-type ;
-: <long-long-type> ( type -- type )
- long-long-type construct-delegate ;
+: <long-long-type> ( -- type )
+ long-long-type new-c-type ;
M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ;
f swap box-parameter ;
: define-deref ( name vocab -- )
- >r dup CHAR: * add* r> create
- swap c-getter 0 add* define-inline ;
+ >r dup CHAR: * prefix r> create
+ swap c-getter 0 prefix define-inline ;
: define-out ( name vocab -- )
over [ <c-object> tuck 0 ] over c-setter append swap
- >r >r constructor-word r> r> add* define-inline ;
+ >r >r constructor-word r> r> prefix define-inline ;
: c-bool> ( int -- ? )
zero? not ;
: define-from-array ( type vocab -- )
[ from-array-word ] 2keep c-array>quot define ;
-: <primitive-type> ( getter setter width boxer unboxer -- type )
- <c-type>
- [ set-c-type-unboxer ] keep
- [ set-c-type-boxer ] keep
- [ set-c-type-size ] 2keep
- [ set-c-type-align ] keep
- [ set-c-type-setter ] keep
- [ set-c-type-getter ] keep ;
-
: define-primitive-type ( type name -- )
"alien.c-types"
- [ define-c-type ] 2keep
- [ define-deref ] 2keep
- [ define-to-array ] 2keep
- [ define-from-array ] 2keep
- define-out ;
+ {
+ [ define-c-type ]
+ [ define-deref ]
+ [ define-to-array ]
+ [ define-from-array ]
+ [ define-out ]
+ } 2cleave ;
: expand-constants ( c-type -- c-type' )
#! We use word-def call instead of execute to get around
#! staging violations
dup array? [
unclip >r [ dup word? [ word-def call ] when ] map
- r> add*
+ r> prefix
] when ;
: malloc-file-contents ( path -- alien len )
binary file-contents dup malloc-byte-array swap length ;
[
- [ alien-cell ]
- [ set-alien-cell ]
- bootstrap-cell
- "box_alien"
- "alien_offset" <primitive-type>
+ <c-type>
+ [ alien-cell ] >>getter
+ [ set-alien-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_alien" >>boxer
+ "alien_offset" >>unboxer
"void*" define-primitive-type
- [ alien-signed-8 ]
- [ set-alien-signed-8 ]
- 8
- "box_signed_8"
- "to_signed_8" <primitive-type> <long-long-type>
+ <long-long-type>
+ [ alien-signed-8 ] >>getter
+ [ set-alien-signed-8 ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_signed_8" >>boxer
+ "to_signed_8" >>unboxer
"longlong" define-primitive-type
- [ alien-unsigned-8 ]
- [ set-alien-unsigned-8 ]
- 8
- "box_unsigned_8"
- "to_unsigned_8" <primitive-type> <long-long-type>
+ <long-long-type>
+ [ alien-unsigned-8 ] >>getter
+ [ set-alien-unsigned-8 ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_unsigned_8" >>boxer
+ "to_unsigned_8" >>unboxer
"ulonglong" define-primitive-type
- [ alien-signed-cell ]
- [ set-alien-signed-cell ]
- bootstrap-cell
- "box_signed_cell"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-cell ] >>getter
+ [ set-alien-signed-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_signed_cell" >>boxer
+ "to_fixnum" >>unboxer
"long" define-primitive-type
- [ alien-unsigned-cell ]
- [ set-alien-unsigned-cell ]
- bootstrap-cell
- "box_unsigned_cell"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-cell ] >>getter
+ [ set-alien-unsigned-cell ] >>setter
+ bootstrap-cell >>size
+ bootstrap-cell >>align
+ "box_unsigned_cell" >>boxer
+ "to_cell" >>unboxer
"ulong" define-primitive-type
- [ alien-signed-4 ]
- [ set-alien-signed-4 ]
- 4
- "box_signed_4"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-4 ] >>getter
+ [ set-alien-signed-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_signed_4" >>boxer
+ "to_fixnum" >>unboxer
"int" define-primitive-type
- [ alien-unsigned-4 ]
- [ set-alien-unsigned-4 ]
- 4
- "box_unsigned_4"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-4 ] >>getter
+ [ set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_unsigned_4" >>boxer
+ "to_cell" >>unboxer
"uint" define-primitive-type
- [ alien-signed-2 ]
- [ set-alien-signed-2 ]
- 2
- "box_signed_2"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-2 ] >>getter
+ [ set-alien-signed-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ "box_signed_2" >>boxer
+ "to_fixnum" >>unboxer
"short" define-primitive-type
- [ alien-unsigned-2 ]
- [ set-alien-unsigned-2 ]
- 2
- "box_unsigned_2"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-2 ] >>getter
+ [ set-alien-unsigned-2 ] >>setter
+ 2 >>size
+ 2 >>align
+ "box_unsigned_2" >>boxer
+ "to_cell" >>unboxer
"ushort" define-primitive-type
- [ alien-signed-1 ]
- [ set-alien-signed-1 ]
- 1
- "box_signed_1"
- "to_fixnum" <primitive-type>
+ <c-type>
+ [ alien-signed-1 ] >>getter
+ [ set-alien-signed-1 ] >>setter
+ 1 >>size
+ 1 >>align
+ "box_signed_1" >>boxer
+ "to_fixnum" >>unboxer
"char" define-primitive-type
- [ alien-unsigned-1 ]
- [ set-alien-unsigned-1 ]
- 1
- "box_unsigned_1"
- "to_cell" <primitive-type>
+ <c-type>
+ [ alien-unsigned-1 ] >>getter
+ [ set-alien-unsigned-1 ] >>setter
+ 1 >>size
+ 1 >>align
+ "box_unsigned_1" >>boxer
+ "to_cell" >>unboxer
"uchar" define-primitive-type
- [ alien-unsigned-4 zero? not ]
- [ 1 0 ? set-alien-unsigned-4 ]
- 4
- "box_boolean"
- "to_boolean" <primitive-type>
+ <c-type>
+ [ alien-unsigned-4 zero? not ] >>getter
+ [ 1 0 ? set-alien-unsigned-4 ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_boolean" >>boxer
+ "to_boolean" >>unboxer
"bool" define-primitive-type
- [ alien-float ]
- [ >r >r >float r> r> set-alien-float ]
- 4
- "box_float"
- "to_float" <primitive-type>
+ <c-type>
+ [ alien-float ] >>getter
+ [ >r >r >float r> r> set-alien-float ] >>setter
+ 4 >>size
+ 4 >>align
+ "box_float" >>boxer
+ "to_float" >>unboxer
+ single-float-regs >>reg-class
+ [ >float ] >>unboxer-quot
"float" define-primitive-type
- T{ float-regs f 4 } "float" c-type set-c-type-reg-class
- [ >float ] "float" c-type set-c-type-prep
-
- [ alien-double ]
- [ >r >r >float r> r> set-alien-double ]
- 8
- "box_double"
- "to_double" <primitive-type>
+ <c-type>
+ [ alien-double ] >>getter
+ [ >r >r >float r> r> set-alien-double ] >>setter
+ 8 >>size
+ 8 >>align
+ "box_double" >>boxer
+ "to_double" >>unboxer
+ double-float-regs >>reg-class
+ [ >float ] >>unboxer-quot
"double" define-primitive-type
- T{ float-regs f 8 } "double" c-type set-c-type-reg-class
- [ >float ] "double" c-type set-c-type-prep
-
- [ alien-cell alien>char-string ]
- [ set-alien-cell ]
- bootstrap-cell
- "box_char_string"
- "alien_offset" <primitive-type>
- "char*" define-primitive-type
-
- "char*" "uchar*" typedef
-
- [ string>char-alien ] "char*" c-type set-c-type-prep
-
- [ alien-cell alien>u16-string ]
- [ set-alien-cell ]
- 4
- "box_u16_string"
- "alien_offset" <primitive-type>
- "ushort*" define-primitive-type
-
- [ string>u16-alien ] "ushort*" c-type set-c-type-prep
-
- win64? "longlong" "long" ? "ptrdiff_t" typedef
-
+ os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
] with-compilation-unit
-IN: alien.compiler.tests\r
-USING: alien alien.c-types alien.syntax compiler kernel\r
-namespaces namespaces tools.test sequences inference words\r
-arrays parser quotations continuations inference.backend effects\r
-namespaces.private io io.streams.string memory system threads\r
-tools.test ;\r
-\r
-FUNCTION: void ffi_test_0 ;\r
-[ ] [ ffi_test_0 ] unit-test\r
-\r
-FUNCTION: int ffi_test_1 ;\r
-[ 3 ] [ ffi_test_1 ] unit-test\r
-\r
-FUNCTION: int ffi_test_2 int x int y ;\r
-[ 5 ] [ 2 3 ffi_test_2 ] unit-test\r
-[ "hi" 3 ffi_test_2 ] must-fail\r
-\r
-FUNCTION: int ffi_test_3 int x int y int z int t ;\r
-[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test\r
-\r
-FUNCTION: float ffi_test_4 ;\r
-[ 1.5 ] [ ffi_test_4 ] unit-test\r
-\r
-FUNCTION: double ffi_test_5 ;\r
-[ 1.5 ] [ ffi_test_5 ] unit-test\r
-\r
-FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;\r
-[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test\r
-[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail\r
-[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail\r
-\r
-C-STRUCT: foo\r
- { "int" "x" }\r
- { "int" "y" }\r
-;\r
-\r
-: make-foo ( x y -- foo )\r
- "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;\r
-\r
-FUNCTION: int ffi_test_11 int a foo b int c ;\r
-\r
-[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test\r
-\r
-FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;\r
-\r
-[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test\r
-\r
-FUNCTION: foo ffi_test_14 int x int y ;\r
-\r
-[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test\r
-\r
-FUNCTION: char* ffi_test_15 char* x char* y ;\r
-\r
-[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test\r
-[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test\r
-[ 1 2 ffi_test_15 ] must-fail\r
-\r
-C-STRUCT: bar\r
- { "long" "x" }\r
- { "long" "y" }\r
- { "long" "z" }\r
-;\r
-\r
-FUNCTION: bar ffi_test_16 long x long y long z ;\r
-\r
-[ 11 6 -7 ] [\r
- 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z\r
-] unit-test\r
-\r
-C-STRUCT: tiny\r
- { "int" "x" }\r
-;\r
-\r
-FUNCTION: tiny ffi_test_17 int x ;\r
-\r
-[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test\r
-\r
-[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with\r
-\r
-: indirect-test-1\r
- "int" { } "cdecl" alien-indirect ;\r
-\r
-{ 1 1 } [ indirect-test-1 ] must-infer-as\r
-\r
-[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test\r
-\r
-[ -1 indirect-test-1 ] must-fail\r
-\r
-: indirect-test-2\r
- "int" { "int" "int" } "cdecl" alien-indirect data-gc ;\r
-\r
-{ 3 1 } [ indirect-test-2 ] must-infer-as\r
-\r
-[ 5 ]\r
-[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]\r
-unit-test\r
-\r
-: indirect-test-3\r
- "int" { "int" "int" "int" "int" } "stdcall" alien-indirect\r
- data-gc ;\r
-\r
-<< "f-stdcall" f "stdcall" add-library >>\r
-\r
-[ f ] [ "f-stdcall" load-library ] unit-test\r
-[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test\r
-\r
-: ffi_test_18 ( w x y z -- int )\r
- "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }\r
- alien-invoke data-gc ;\r
-\r
-[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test\r
-\r
-: ffi_test_19 ( x y z -- bar )\r
- "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }\r
- alien-invoke data-gc ;\r
-\r
-[ 11 6 -7 ] [\r
- 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z\r
-] unit-test\r
-\r
-FUNCTION: double ffi_test_6 float x float y ;\r
-[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test\r
-[ "a" "b" ffi_test_6 ] must-fail\r
-\r
-FUNCTION: double ffi_test_7 double x double y ;\r
-[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test\r
-\r
-FUNCTION: double ffi_test_8 double x float y double z float t int w ;\r
-[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test\r
-\r
-FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;\r
-[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test\r
-\r
-FUNCTION: void ffi_test_20 double x1, double x2, double x3,\r
- double y1, double y2, double y3,\r
- double z1, double z2, double z3 ;\r
-\r
-[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test\r
-\r
-! Make sure XT doesn't get clobbered in stack frame\r
-\r
-: ffi_test_31\r
- "void"\r
- f "ffi_test_31"\r
- { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }\r
- alien-invoke code-gc 3 ;\r
-\r
-[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test\r
-\r
-FUNCTION: longlong ffi_test_21 long x long y ;\r
-\r
-[ 121932631112635269 ]\r
-[ 123456789 987654321 ffi_test_21 ] unit-test\r
-\r
-FUNCTION: long ffi_test_22 long x longlong y longlong z ;\r
-\r
-[ 987655432 ]\r
-[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test\r
-\r
-[ 1111 f 123456789 ffi_test_22 ] must-fail\r
-\r
-C-STRUCT: rect\r
- { "float" "x" }\r
- { "float" "y" }\r
- { "float" "w" }\r
- { "float" "h" }\r
-;\r
-\r
-: <rect>\r
- "rect" <c-object>\r
- [ set-rect-h ] keep\r
- [ set-rect-w ] keep\r
- [ set-rect-y ] keep\r
- [ set-rect-x ] keep ;\r
-\r
-FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;\r
-\r
-[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test\r
-\r
-[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail\r
-\r
-FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;\r
-\r
-[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test\r
-\r
-! Test odd-size structs\r
-C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;\r
-\r
-FUNCTION: test-struct-1 ffi_test_24 ;\r
-\r
-[ B{ 1 } ] [ ffi_test_24 ] unit-test\r
-\r
-C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;\r
-\r
-FUNCTION: test-struct-2 ffi_test_25 ;\r
-\r
-[ B{ 1 2 } ] [ ffi_test_25 ] unit-test\r
-\r
-C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;\r
-\r
-FUNCTION: test-struct-3 ffi_test_26 ;\r
-\r
-[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test\r
-\r
-C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;\r
-\r
-FUNCTION: test-struct-4 ffi_test_27 ;\r
-\r
-[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test\r
-\r
-C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;\r
-\r
-FUNCTION: test-struct-5 ffi_test_28 ;\r
-\r
-[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test\r
-\r
-C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;\r
-\r
-FUNCTION: test-struct-6 ffi_test_29 ;\r
-\r
-[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test\r
-\r
-C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;\r
-\r
-FUNCTION: test-struct-7 ffi_test_30 ;\r
-\r
-[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test\r
-\r
-C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;\r
-\r
-FUNCTION: double ffi_test_32 test-struct-8 x int y ;\r
-\r
-[ 9.0 ] [\r
- "test-struct-8" <c-object>\r
- 1.0 over set-test-struct-8-x\r
- 2.0 over set-test-struct-8-y\r
- 3 ffi_test_32\r
-] unit-test\r
-\r
-C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;\r
-\r
-FUNCTION: double ffi_test_33 test-struct-9 x int y ;\r
-\r
-[ 9.0 ] [\r
- "test-struct-9" <c-object>\r
- 1.0 over set-test-struct-9-x\r
- 2.0 over set-test-struct-9-y\r
- 3 ffi_test_33\r
-] unit-test\r
-\r
-C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;\r
-\r
-FUNCTION: double ffi_test_34 test-struct-10 x int y ;\r
-\r
-[ 9.0 ] [\r
- "test-struct-10" <c-object>\r
- 1.0 over set-test-struct-10-x\r
- 2 over set-test-struct-10-y\r
- 3 ffi_test_34\r
-] unit-test\r
-\r
-C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;\r
-\r
-FUNCTION: double ffi_test_35 test-struct-11 x int y ;\r
-\r
-[ 9.0 ] [\r
- "test-struct-11" <c-object>\r
- 1 over set-test-struct-11-x\r
- 2 over set-test-struct-11-y\r
- 3 ffi_test_35\r
-] unit-test\r
-\r
-C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;\r
-\r
-: make-struct-12\r
- "test-struct-12" <c-object>\r
- [ set-test-struct-12-x ] keep ;\r
-\r
-FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;\r
-\r
-[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test\r
-\r
-! Test callbacks\r
-\r
-: callback-1 "void" { } "cdecl" [ ] alien-callback ;\r
-\r
-[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test\r
-\r
-[ t ] [ callback-1 alien? ] unit-test\r
-\r
-: callback_test_1 "void" { } "cdecl" alien-indirect ;\r
-\r
-[ ] [ callback-1 callback_test_1 ] unit-test\r
-\r
-: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;\r
-\r
-[ ] [ callback-2 callback_test_1 ] unit-test\r
-\r
-: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;\r
-\r
-[ t ] [ \r
- namestack*\r
- 3 "x" set callback-3 callback_test_1\r
- namestack* eq?\r
-] unit-test\r
-\r
-[ 5 ] [ \r
- [\r
- 3 "x" set callback-3 callback_test_1 "x" get\r
- ] with-scope\r
-] unit-test\r
-\r
-: callback-4\r
- "void" { } "cdecl" [ "Hello world" write ] alien-callback\r
- data-gc ;\r
-\r
-[ "Hello world" ] [ \r
- [ callback-4 callback_test_1 ] with-string-writer\r
-] unit-test\r
-\r
-: callback-5\r
- "void" { } "cdecl" [ data-gc ] alien-callback ;\r
-\r
-[ "testing" ] [\r
- "testing" callback-5 callback_test_1\r
-] unit-test\r
-\r
-: callback-5a\r
- "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;\r
-\r
-! Hack; if we're on ARM, we probably don't have much RAM, so\r
-! skip this test.\r
-cpu "arm" = [\r
- [ "testing" ] [\r
- "testing" callback-5a callback_test_1\r
- ] unit-test\r
-] unless\r
-\r
-: callback-6\r
- "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;\r
-\r
-[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test\r
-\r
-: callback-7\r
- "void" { } "cdecl" [ 1000 sleep ] alien-callback ;\r
-\r
-[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test\r
-\r
-[ f ] [ namespace global eq? ] unit-test\r
-\r
-: callback-8\r
- "void" { } "cdecl" [\r
- [ continue ] callcc0\r
- ] alien-callback ;\r
-\r
-[ ] [ callback-8 callback_test_1 ] unit-test\r
+IN: alien.compiler.tests
+USING: alien alien.c-types alien.syntax compiler kernel
+namespaces namespaces tools.test sequences inference words
+arrays parser quotations continuations inference.backend effects
+namespaces.private io io.streams.string memory system threads
+tools.test math ;
+
+FUNCTION: void ffi_test_0 ;
+[ ] [ ffi_test_0 ] unit-test
+
+FUNCTION: int ffi_test_1 ;
+[ 3 ] [ ffi_test_1 ] unit-test
+
+FUNCTION: int ffi_test_2 int x int y ;
+[ 5 ] [ 2 3 ffi_test_2 ] unit-test
+[ "hi" 3 ffi_test_2 ] must-fail
+
+FUNCTION: int ffi_test_3 int x int y int z int t ;
+[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test
+
+FUNCTION: float ffi_test_4 ;
+[ 1.5 ] [ ffi_test_4 ] unit-test
+
+FUNCTION: double ffi_test_5 ;
+[ 1.5 ] [ ffi_test_5 ] unit-test
+
+FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ;
+[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test
+[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail
+[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail
+
+C-STRUCT: foo
+ { "int" "x" }
+ { "int" "y" }
+;
+
+: make-foo ( x y -- foo )
+ "foo" <c-object> [ set-foo-y ] keep [ set-foo-x ] keep ;
+
+FUNCTION: int ffi_test_11 int a foo b int c ;
+
+[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test
+
+FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ;
+
+[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test
+
+FUNCTION: foo ffi_test_14 int x int y ;
+
+[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test
+
+FUNCTION: char* ffi_test_15 char* x char* y ;
+
+[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test
+[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test
+[ 1 2 ffi_test_15 ] must-fail
+
+C-STRUCT: bar
+ { "long" "x" }
+ { "long" "y" }
+ { "long" "z" }
+;
+
+FUNCTION: bar ffi_test_16 long x long y long z ;
+
+[ 11 6 -7 ] [
+ 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z
+] unit-test
+
+C-STRUCT: tiny
+ { "int" "x" }
+;
+
+FUNCTION: tiny ffi_test_17 int x ;
+
+[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test
+
+[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
+
+: indirect-test-1
+ "int" { } "cdecl" alien-indirect ;
+
+{ 1 1 } [ indirect-test-1 ] must-infer-as
+
+[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
+
+[ -1 indirect-test-1 ] must-fail
+
+: indirect-test-2
+ "int" { "int" "int" } "cdecl" alien-indirect gc ;
+
+{ 3 1 } [ indirect-test-2 ] must-infer-as
+
+[ 5 ]
+[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ]
+unit-test
+
+: indirect-test-3
+ "int" { "int" "int" "int" "int" } "stdcall" alien-indirect
+ gc ;
+
+<< "f-stdcall" f "stdcall" add-library >>
+
+[ f ] [ "f-stdcall" load-library ] unit-test
+[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test
+
+: ffi_test_18 ( w x y z -- int )
+ "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" }
+ alien-invoke gc ;
+
+[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test
+
+: ffi_test_19 ( x y z -- bar )
+ "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" }
+ alien-invoke gc ;
+
+[ 11 6 -7 ] [
+ 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z
+] unit-test
+
+FUNCTION: double ffi_test_6 float x float y ;
+[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
+[ "a" "b" ffi_test_6 ] must-fail
+
+FUNCTION: double ffi_test_7 double x double y ;
+[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test
+
+FUNCTION: double ffi_test_8 double x float y double z float t int w ;
+[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test
+
+FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ;
+[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test
+
+FUNCTION: void ffi_test_20 double x1, double x2, double x3,
+ double y1, double y2, double y3,
+ double z1, double z2, double z3 ;
+
+[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test
+
+! Make sure XT doesn't get clobbered in stack frame
+
+: ffi_test_31
+ "void"
+ f "ffi_test_31"
+ { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
+ alien-invoke gc 3 ;
+
+[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
+
+FUNCTION: longlong ffi_test_21 long x long y ;
+
+[ 121932631112635269 ]
+[ 123456789 987654321 ffi_test_21 ] unit-test
+
+FUNCTION: long ffi_test_22 long x longlong y longlong z ;
+
+[ 987655432 ]
+[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test
+
+[ 1111 f 123456789 ffi_test_22 ] must-fail
+
+C-STRUCT: rect
+ { "float" "x" }
+ { "float" "y" }
+ { "float" "w" }
+ { "float" "h" }
+;
+
+: <rect>
+ "rect" <c-object>
+ [ set-rect-h ] keep
+ [ set-rect-w ] keep
+ [ set-rect-y ] keep
+ [ set-rect-x ] keep ;
+
+FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ;
+
+[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 <rect> 7 8 9 ffi_test_12 ] unit-test
+
+[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail
+
+FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ;
+
+[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test
+
+! Test odd-size structs
+C-STRUCT: test-struct-1 { { "char" 1 } "x" } ;
+
+FUNCTION: test-struct-1 ffi_test_24 ;
+
+[ B{ 1 } ] [ ffi_test_24 ] unit-test
+
+C-STRUCT: test-struct-2 { { "char" 2 } "x" } ;
+
+FUNCTION: test-struct-2 ffi_test_25 ;
+
+[ B{ 1 2 } ] [ ffi_test_25 ] unit-test
+
+C-STRUCT: test-struct-3 { { "char" 3 } "x" } ;
+
+FUNCTION: test-struct-3 ffi_test_26 ;
+
+[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test
+
+C-STRUCT: test-struct-4 { { "char" 4 } "x" } ;
+
+FUNCTION: test-struct-4 ffi_test_27 ;
+
+[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test
+
+C-STRUCT: test-struct-5 { { "char" 5 } "x" } ;
+
+FUNCTION: test-struct-5 ffi_test_28 ;
+
+[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test
+
+C-STRUCT: test-struct-6 { { "char" 6 } "x" } ;
+
+FUNCTION: test-struct-6 ffi_test_29 ;
+
+[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test
+
+C-STRUCT: test-struct-7 { { "char" 7 } "x" } ;
+
+FUNCTION: test-struct-7 ffi_test_30 ;
+
+[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test
+
+C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ;
+
+FUNCTION: double ffi_test_32 test-struct-8 x int y ;
+
+[ 9.0 ] [
+ "test-struct-8" <c-object>
+ 1.0 over set-test-struct-8-x
+ 2.0 over set-test-struct-8-y
+ 3 ffi_test_32
+] unit-test
+
+C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ;
+
+FUNCTION: double ffi_test_33 test-struct-9 x int y ;
+
+[ 9.0 ] [
+ "test-struct-9" <c-object>
+ 1.0 over set-test-struct-9-x
+ 2.0 over set-test-struct-9-y
+ 3 ffi_test_33
+] unit-test
+
+C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ;
+
+FUNCTION: double ffi_test_34 test-struct-10 x int y ;
+
+[ 9.0 ] [
+ "test-struct-10" <c-object>
+ 1.0 over set-test-struct-10-x
+ 2 over set-test-struct-10-y
+ 3 ffi_test_34
+] unit-test
+
+C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ;
+
+FUNCTION: double ffi_test_35 test-struct-11 x int y ;
+
+[ 9.0 ] [
+ "test-struct-11" <c-object>
+ 1 over set-test-struct-11-x
+ 2 over set-test-struct-11-y
+ 3 ffi_test_35
+] unit-test
+
+C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+
+: make-struct-12
+ "test-struct-12" <c-object>
+ [ set-test-struct-12-x ] keep ;
+
+FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
+
+[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
+
+FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ;
+
+[ t ] [ 31 2^ 32 2^ ffi_test_38 63 2^ = ] unit-test
+
+! Test callbacks
+
+: callback-1 "void" { } "cdecl" [ ] alien-callback ;
+
+[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test
+
+[ t ] [ callback-1 alien? ] unit-test
+
+: callback_test_1 "void" { } "cdecl" alien-indirect ;
+
+[ ] [ callback-1 callback_test_1 ] unit-test
+
+: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+
+[ ] [ callback-2 callback_test_1 ] unit-test
+
+: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ;
+
+[ t ] [
+ namestack*
+ 3 "x" set callback-3 callback_test_1
+ namestack* eq?
+] unit-test
+
+[ 5 ] [
+ [
+ 3 "x" set callback-3 callback_test_1 "x" get
+ ] with-scope
+] unit-test
+
+: callback-4
+ "void" { } "cdecl" [ "Hello world" write ] alien-callback
+ gc ;
+
+[ "Hello world" ] [
+ [ callback-4 callback_test_1 ] with-string-writer
+] unit-test
+
+: callback-5
+ "void" { } "cdecl" [ gc ] alien-callback ;
+
+[ "testing" ] [
+ "testing" callback-5 callback_test_1
+] unit-test
+
+: callback-5a
+ "void" { } "cdecl" [ 8000000 f <array> drop ] alien-callback ;
+
+! Hack; if we're on ARM, we probably don't have much RAM, so
+! skip this test.
+! cpu "arm" = [
+! [ "testing" ] [
+! "testing" callback-5a callback_test_1
+! ] unit-test
+! ] unless
+
+: callback-6
+ "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+
+[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
+
+: callback-7
+ "void" { } "cdecl" [ 1000 sleep ] alien-callback ;
+
+[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
+
+[ f ] [ namespace global eq? ] unit-test
+
+: callback-8
+ "void" { } "cdecl" [
+ [ continue ] callcc0
+ ] alien-callback ;
+
+[ ] [ callback-8 callback_test_1 ] unit-test
+
+: callback-9
+ "int" { "int" "int" "int" } "cdecl" [
+ + + 1+
+ ] alien-callback ;
+
+FUNCTION: void ffi_test_36_point_5 ( ) ;
+
+[ ] [ ffi_test_36_point_5 ] unit-test
+
+FUNCTION: int ffi_test_37 ( void* func ) ;
+
+[ 1 ] [ callback-9 ffi_test_37 ] unit-test
+
+[ 7 ] [ callback-9 ffi_test_37 ] unit-test
USING: arrays generator generator.registers generator.fixup
hashtables kernel math namespaces sequences words
inference.state inference.backend inference.dataflow system
-math.parser classes alien.arrays alien.c-types alien.structs
-alien.syntax cpu.architecture alien inspector quotations assocs
-kernel.private threads continuations.private libc combinators
-compiler.errors continuations layouts ;
+math.parser classes alien.arrays alien.c-types alien.strings
+alien.structs alien.syntax cpu.architecture alien inspector
+quotations assocs kernel.private threads continuations.private
+libc combinators compiler.errors continuations layouts accessors
+;
IN: alien.compiler
-! Common protocol for alien-invoke/alien-callback/alien-indirect
-GENERIC: alien-node-parameters ( node -- seq )
-GENERIC: alien-node-return ( node -- ctype )
-GENERIC: alien-node-abi ( node -- str )
+TUPLE: #alien-node < node return parameters abi ;
+
+TUPLE: #alien-callback < #alien-node quot xt ;
+
+TUPLE: #alien-indirect < #alien-node ;
+
+TUPLE: #alien-invoke < #alien-node library function ;
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
- ] [
- drop f
- ] if ;
+ ] [ drop f ] if ;
: alien-node-parameters* ( node -- seq )
- dup alien-node-parameters
- swap alien-node-return large-struct? [ "void*" add* ] when ;
+ dup parameters>>
+ swap return>> large-struct? [ "void*" prefix ] when ;
: alien-node-return* ( node -- ctype )
- alien-node-return dup large-struct? [ drop "void" ] when ;
+ return>> dup large-struct? [ drop "void" ] when ;
: c-type-stack-align ( type -- align )
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
: alien-invoke-frame ( node -- n )
#! One cell is temporary storage, temp@
- dup alien-node-return return-size
+ dup return>> return-size
swap alien-stack-frame +
cell + ;
M: int-regs reg-size drop cell ;
-M: float-regs reg-size float-regs-size ;
+M: single-float-regs reg-size drop 4 ;
+
+M: double-float-regs reg-size drop 8 ;
+
+GENERIC: reg-class-variable ( register-class -- symbol )
+
+M: reg-class reg-class-variable ;
+
+M: float-regs reg-class-variable drop float-regs ;
GENERIC: inc-reg-class ( register-class -- )
-: (inc-reg-class)
- dup class inc
+M: reg-class inc-reg-class
+ dup reg-class-variable inc
fp-shadows-int? [ reg-size stack-params +@ ] [ drop ] if ;
-M: int-regs inc-reg-class
- (inc-reg-class) ;
-
M: float-regs inc-reg-class
- dup (inc-reg-class)
+ dup call-next-method
fp-shadows-int? [ reg-size cell /i int-regs +@ ] [ drop ] if ;
: reg-class-full? ( class -- ? )
- dup class get swap param-regs length >= ;
+ [ reg-class-variable get ] [ param-regs length ] bi >= ;
: spill-param ( reg-class -- n reg-class )
- reg-size stack-params dup get -rot +@ T{ stack-params } ;
+ stack-params get
+ >r reg-size stack-params +@ r>
+ stack-params ;
: fastcall-param ( reg-class -- n reg-class )
- [ dup class get swap inc-reg-class ] keep ;
+ [ reg-class-variable get ] [ inc-reg-class ] [ ] tri ;
: alloc-parameter ( parameter -- reg reg-class )
c-type-reg-class dup reg-class-full?
pick "void" = [ drop nip call ] [ nip call ] if ; inline
: alien-invoke-stack ( node extra -- )
- over alien-node-parameters length + dup reify-curries
+ over parameters>> length + dup reify-curries
over consume-values
- dup alien-node-return "void" = 0 1 ?
+ dup return>> "void" = 0 1 ?
swap produce-values ;
-: (make-prep-quot) ( parameters -- )
+: (param-prep-quot) ( parameters -- )
dup empty? [
drop
] [
- unclip c-type c-type-prep %
- \ >r , (make-prep-quot) \ r> ,
+ unclip c-type c-type-unboxer-quot %
+ \ >r , (param-prep-quot) \ r> ,
] if ;
-: make-prep-quot ( node -- quot )
- alien-node-parameters
- [ <reversed> (make-prep-quot) ] [ ] make ;
+: param-prep-quot ( node -- quot )
+ parameters>> [ <reversed> (param-prep-quot) ] [ ] make ;
: unbox-parameters ( offset node -- )
- alien-node-parameters [
+ parameters>> [
%prepare-unbox >r over + r> unbox-parameter
] reverse-each-parameter drop ;
#! parameters. If the C function is returning a structure,
#! the first parameter is an implicit target area pointer,
#! so we need to use a different offset.
- alien-node-return dup large-struct?
+ return>> dup large-struct?
[ heap-size %prepare-box-struct cell ] [ drop 0 ] if ;
: objects>registers ( node -- )
] with-param-regs ;
: box-return* ( node -- )
- alien-node-return [ ] [ box-return ] if-void ;
+ return>> [ ] [ box-return ] if-void ;
+
+: (return-prep-quot) ( parameters -- )
+ dup empty? [
+ drop
+ ] [
+ unclip c-type c-type-boxer-quot %
+ \ >r , (return-prep-quot) \ r> ,
+ ] if ;
-M: alien-invoke alien-node-parameters alien-invoke-parameters ;
-M: alien-invoke alien-node-return alien-invoke-return ;
+: callback-prep-quot ( node -- quot )
+ parameters>> [ <reversed> (return-prep-quot) ] [ ] make ;
-M: alien-invoke alien-node-abi
- alien-invoke-library library
- [ library-abi ] [ "cdecl" ] if* ;
+: return-prep-quot ( node -- quot )
+ [ return>> [ ] [ 1array (return-prep-quot) ] if-void ] [ ] make ;
M: alien-invoke-error summary
drop
: stdcall-mangle ( symbol node -- symbol )
"@"
- swap alien-node-parameters parameter-sizes drop
+ swap parameters>> parameter-sizes drop
number>string 3append ;
TUPLE: no-such-library name ;
drop +linkage+ ;
: no-such-library ( name -- )
- \ no-such-library construct-boa
+ \ no-such-library boa
compiling-word get compiler-error ;
TUPLE: no-such-symbol name ;
drop +linkage+ ;
: no-such-symbol ( name -- )
- \ no-such-symbol construct-boa
+ \ no-such-symbol boa
compiling-word get compiler-error ;
: check-dlsym ( symbols dll -- )
] if ;
: alien-invoke-dlsym ( node -- symbols dll )
- dup alien-invoke-function dup pick stdcall-mangle 2array
- swap alien-invoke-library library dup [ library-dll ] when
+ dup function>> dup pick stdcall-mangle 2array
+ swap library>> library dup [ dll>> ] when
2dup check-dlsym ;
\ alien-invoke [
! Four literals
4 ensure-values
- \ alien-invoke empty-node
+ #alien-invoke new
! Compile-time parameters
- pop-parameters over set-alien-invoke-parameters
- pop-literal nip over set-alien-invoke-function
- pop-literal nip over set-alien-invoke-library
- pop-literal nip over set-alien-invoke-return
+ pop-parameters >>parameters
+ pop-literal nip >>function
+ pop-literal nip >>library
+ pop-literal nip >>return
! Quotation which coerces parameters to required types
- dup make-prep-quot recursive-state get infer-quot
+ dup param-prep-quot f infer-quot
+ ! Set ABI
+ dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
! Add node to IR
dup node,
! Magic #: consume exactly the number of inputs
- 0 alien-invoke-stack
+ dup 0 alien-invoke-stack
+ ! Quotation which coerces return value to required type
+ return-prep-quot f infer-quot
] "infer" set-word-prop
-M: alien-invoke generate-node
+M: #alien-invoke generate-node
dup alien-invoke-frame [
end-basic-block
%prepare-alien-invoke
iterate-next
] with-stack-frame ;
-M: alien-indirect alien-node-parameters alien-indirect-parameters ;
-M: alien-indirect alien-node-return alien-indirect-return ;
-M: alien-indirect alien-node-abi alien-indirect-abi ;
-
M: alien-indirect-error summary
drop "Words calling ``alien-indirect'' must be compiled with the optimizing compiler." ;
! Three literals and function pointer
4 ensure-values
4 reify-curries
- \ alien-indirect empty-node
+ #alien-indirect new
! Compile-time parameters
- pop-literal nip over set-alien-indirect-abi
- pop-parameters over set-alien-indirect-parameters
- pop-literal nip over set-alien-indirect-return
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
! Quotation which coerces parameters to required types
- dup make-prep-quot [ dip ] curry recursive-state get infer-quot
+ dup param-prep-quot [ dip ] curry f infer-quot
! Add node to IR
dup node,
! Magic #: consume the function pointer, too
- 1 alien-invoke-stack
+ dup 1 alien-invoke-stack
+ ! Quotation which coerces return value to required type
+ return-prep-quot f infer-quot
] "infer" set-word-prop
-M: alien-indirect generate-node
+M: #alien-indirect generate-node
dup alien-invoke-frame [
! Flush registers
end-basic-block
: register-callback ( word -- ) dup callbacks get set-at ;
-M: alien-callback alien-node-parameters alien-callback-parameters ;
-M: alien-callback alien-node-return alien-callback-return ;
-M: alien-callback alien-node-abi alien-callback-abi ;
-
M: alien-callback-error summary
drop "Words calling ``alien-callback'' must be compiled with the optimizing compiler." ;
: callback-bottom ( node -- )
- alien-callback-xt [ word-xt drop <alien> ] curry
- recursive-state get infer-quot ;
+ xt>> [ word-xt drop <alien> ] curry
+ f infer-quot ;
\ alien-callback [
4 ensure-values
- \ alien-callback empty-node dup node,
- pop-literal nip over set-alien-callback-quot
- pop-literal nip over set-alien-callback-abi
- pop-parameters over set-alien-callback-parameters
- pop-literal nip over set-alien-callback-return
- gensym dup register-callback over set-alien-callback-xt
+ #alien-callback new dup node,
+ pop-literal nip >>quot
+ pop-literal nip >>abi
+ pop-parameters >>parameters
+ pop-literal nip >>return
+ gensym dup register-callback >>xt
callback-bottom
] "infer" set-word-prop
slip
wait-to-return ; inline
-: prepare-callback-return ( ctype -- quot )
- alien-node-return {
+: callback-return-quot ( ctype -- quot )
+ return>> {
{ [ dup "void" = ] [ drop [ ] ] }
{ [ dup large-struct? ] [ heap-size [ memcpy ] curry ] }
- { [ t ] [ c-type c-type-prep ] }
+ [ c-type c-type-unboxer-quot ]
} cond ;
: wrap-callback-quot ( node -- quot )
[
- dup alien-callback-quot
- swap prepare-callback-return append ,
- [ callback-context construct-empty do-callback ] %
+ [ callback-prep-quot ]
+ [ quot>> ]
+ [ callback-return-quot ] tri 3append ,
+ [ callback-context new do-callback ] %
] [ ] make ;
: %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
: callback-unwind ( node -- n )
{
- { [ dup alien-node-abi "stdcall" = ] [ alien-stack-frame ] }
- { [ dup alien-node-return large-struct? ] [ drop 4 ] }
- { [ t ] [ drop 0 ] }
+ { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] }
+ { [ dup return>> large-struct? ] [ drop 4 ] }
+ [ drop 0 ]
} cond ;
: %callback-return ( node -- )
callback-unwind %unwind ;
: generate-callback ( node -- )
- dup alien-callback-xt dup [
+ dup xt>> dup [
init-templates
- %save-word-xt
%prologue-later
dup alien-stack-frame [
- dup registers>objects
- dup wrap-callback-quot %alien-callback
- %callback-return
+ [ registers>objects ]
+ [ wrap-callback-quot %alien-callback ]
+ [ %callback-return ]
+ tri
] with-stack-frame
] with-generator ;
-M: alien-callback generate-node
+M: #alien-callback generate-node
end-basic-block generate-callback iterate-next ;
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types parser threads words kernel.private
-kernel ;
+USING: alien alien.c-types alien.strings parser threads words
+kernel.private kernel io.encodings.utf8 ;
IN: alien.remote-control
: eval-callback
"void*" { "char*" } "cdecl"
- [ eval>string malloc-char-string ] alien-callback ;
+ [ eval>string utf8 malloc-string ] alien-callback ;
: yield-callback
"void" { } "cdecl" [ yield ] alien-callback ;
--- /dev/null
+USING: help.markup help.syntax strings byte-arrays alien libc
+debugger ;
+IN: alien.strings
+
+HELP: string>alien
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
+{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
+{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
+
+{ string>alien alien>string malloc-string } related-words
+
+HELP: alien>string
+{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
+{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
+
+HELP: malloc-string
+{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
+{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
+{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
+{ $errors "Throws an error if one of the following conditions occurs:"
+ { $list
+ "the string contains null code points"
+ "the string contains characters not representable using the encoding specified"
+ "memory allocation fails"
+ }
+} ;
+
+HELP: string>symbol
+{ $values { "str" string } { "alien" alien } }
+{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
+$nl
+"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
+
+HELP: utf16n
+{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
+{ $see-also "encodings-introduction" } ;
+
+ARTICLE: "c-strings" "C strings"
+"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
+$nl
+"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function. If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
+$nl
+"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
+{ $subsection string>alien }
+{ $subsection malloc-string }
+"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
+$nl
+"A word to read strings from arbitrary addresses:"
+{ $subsection alien>string }
+"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
+
+ABOUT: "c-strings"
--- /dev/null
+USING: alien.strings tools.test kernel libc
+io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
+io.encodings.ascii alien ;
+IN: alien.strings.tests
+
+[ "\u0000ff" ]
+[ "\u0000ff" latin1 string>alien latin1 alien>string ]
+unit-test
+
+[ "hello world" ]
+[ "hello world" latin1 string>alien latin1 alien>string ]
+unit-test
+
+[ "hello\u00abcdworld" ]
+[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ]
+unit-test
+
+[ t ] [ f expired? ] unit-test
+
+[ "hello world" ] [
+ "hello world" ascii malloc-string
+ dup ascii alien>string swap free
+] unit-test
+
+[ "hello world" ] [
+ "hello world" utf16n malloc-string
+ dup utf16n alien>string swap free
+] unit-test
+
+[ f ] [ f utf8 alien>string ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays sequences kernel accessors math alien.accessors
+alien.c-types byte-arrays words io io.encodings
+io.streams.byte-array io.streams.memory io.encodings.utf8
+io.encodings.utf16 system alien strings cpu.architecture ;
+IN: alien.strings
+
+GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
+
+M: c-ptr alien>string
+ >r <memory-stream> r> <decoder>
+ "\0" swap stream-read-until drop ;
+
+M: f alien>string
+ drop ;
+
+ERROR: invalid-c-string string ;
+
+: check-string ( string -- )
+ 0 over memq? [ invalid-c-string ] [ drop ] if ;
+
+GENERIC# string>alien 1 ( string encoding -- byte-array )
+
+M: c-ptr string>alien drop ;
+
+M: string string>alien
+ over check-string
+ <byte-writer>
+ [ stream-write ]
+ [ 0 swap stream-write1 ]
+ [ stream>> >byte-array ]
+ tri ;
+
+: malloc-string ( string encoding -- alien )
+ string>alien malloc-byte-array ;
+
+PREDICATE: string-type < pair
+ first2 [ "char*" = ] [ word? ] bi* and ;
+
+M: string-type c-type ;
+
+M: string-type heap-size
+ drop "void*" heap-size ;
+
+M: string-type c-type-align
+ drop "void*" c-type-align ;
+
+M: string-type c-type-stack-align?
+ drop "void*" c-type-stack-align? ;
+
+M: string-type unbox-parameter
+ drop "void*" unbox-parameter ;
+
+M: string-type unbox-return
+ drop "void*" unbox-return ;
+
+M: string-type box-parameter
+ drop "void*" box-parameter ;
+
+M: string-type box-return
+ drop "void*" box-return ;
+
+M: string-type stack-size
+ drop "void*" stack-size ;
+
+M: string-type c-type-reg-class
+ drop int-regs ;
+
+M: string-type c-type-boxer
+ drop "void*" c-type-boxer ;
+
+M: string-type c-type-unboxer
+ drop "void*" c-type-unboxer ;
+
+M: string-type c-type-boxer-quot
+ second [ alien>string ] curry [ ] like ;
+
+M: string-type c-type-unboxer-quot
+ second [ string>alien ] curry [ ] like ;
+
+M: string-type c-type-getter
+ drop [ alien-cell ] ;
+
+M: string-type c-type-setter
+ drop [ set-alien-cell ] ;
+
+TUPLE: utf16n ;
+
+! Native-order UTF-16
+
+: utf16n ( -- descriptor )
+ little-endian? utf16le utf16be ? ; foldable
+
+M: utf16n <decoder> drop utf16n <decoder> ;
+
+M: utf16n <encoder> drop utf16n <encoder> ;
+
+: alien>native-string ( alien -- string )
+ os windows? [ utf16n ] [ utf8 ] if alien>string ;
+
+: dll-path ( dll -- string )
+ (dll-path) alien>native-string ;
+
+: string>symbol ( str -- alien )
+ [ os wince? [ utf16n ] [ utf8 ] if string>alien ]
+ over string? [ call ] [ map ] if ;
+
+{ "char*" utf8 } "char*" typedef
+{ "char*" utf16n } "wchar_t*" typedef
+"char*" "uchar*" typedef
IN: alien.structs
USING: alien.c-types strings help.markup help.syntax
-alien.syntax sequences io arrays ;
+alien.syntax sequences io arrays slots.deprecated
+kernel words slots assocs namespaces ;
+
+! Deprecated code
+: ($spec-reader-values) ( slot-spec class -- element )
+ dup ?word-name swap 2array
+ over slot-spec-name
+ rot slot-spec-type 2array 2array
+ [ { $instance } swap suffix ] assoc-map ;
+
+: $spec-reader-values ( slot-spec class -- )
+ ($spec-reader-values) $values ;
+
+: $spec-reader-description ( slot-spec class -- )
+ [
+ "Outputs the value stored in the " ,
+ { $snippet } rot slot-spec-name suffix ,
+ " slot of " ,
+ { $instance } swap suffix ,
+ " instance." ,
+ ] { } make $description ;
+
+: $spec-reader ( reader slot-specs class -- )
+ >r slot-of-reader r>
+ over [
+ 2dup $spec-reader-values
+ 2dup $spec-reader-description
+ ] when 2drop ;
+
+GENERIC: slot-specs ( help-type -- specs )
+
+M: word slot-specs "slots" word-prop ;
+
+: $slot-reader ( reader -- )
+ first dup "reading" word-prop [ slot-specs ] keep
+ $spec-reader ;
+
+: $spec-writer-values ( slot-spec class -- )
+ ($spec-reader-values) reverse $values ;
+
+: $spec-writer-description ( slot-spec class -- )
+ [
+ "Stores a new value to the " ,
+ { $snippet } rot slot-spec-name suffix ,
+ " slot of " ,
+ { $instance } swap suffix ,
+ " instance." ,
+ ] { } make $description ;
+
+: $spec-writer ( writer slot-specs class -- )
+ >r slot-of-writer r>
+ over [
+ 2dup $spec-writer-values
+ 2dup $spec-writer-description
+ dup ?word-name 1array $side-effects
+ ] when 2drop ;
+
+: $slot-writer ( reader -- )
+ first dup "writing" word-prop [ slot-specs ] keep
+ $spec-writer ;
M: string slot-specs c-type struct-type-fields ;
IN: alien.structs.tests
USING: alien alien.syntax alien.c-types kernel tools.test
-sequences system libc words vocabs namespaces ;
+sequences system libc words vocabs namespaces layouts ;
C-STRUCT: bar
{ "int" "x" }
[ 36 ] [ "bar" heap-size ] unit-test
[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
-! This was actually only correct on Windows/x86:
-
-! C-STRUCT: align-test
-! { "int" "x" }
-! { "double" "y" } ;
-!
-! [ 16 ] [ "align-test" heap-size ] unit-test
-!
-! cell 4 = [
-! C-STRUCT: one
-! { "long" "a" } { "double" "b" } { "int" "c" } ;
-!
-! [ 24 ] [ "one" heap-size ] unit-test
-! ] when
+C-STRUCT: align-test
+ { "int" "x" }
+ { "double" "y" } ;
+
+os winnt? cpu x86? and [
+ [ 16 ] [ "align-test" heap-size ] unit-test
+
+ cell 4 = [
+ C-STRUCT: one
+ { "long" "a" } { "double" "b" } { "int" "c" } ;
+
+ [ 24 ] [ "one" heap-size ] unit-test
+ ] when
+] when
: MAX_FOOS 30 ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
namespaces parser sequences strings words libc slots
-alien.c-types cpu.architecture ;
+slots.deprecated alien.c-types cpu.architecture ;
IN: alien.structs
: align-offset ( offset type -- offset )
] reduce ;
: define-struct-slot-word ( spec word quot -- )
- rot slot-spec-offset add* define-inline ;
+ rot slot-spec-offset prefix define-inline ;
: define-getter ( type spec -- )
[ set-reader-props ] keep
- dup slot-spec-reader
- over slot-spec-type c-getter
+ [ ]
+ [ slot-spec-reader ]
+ [
+ slot-spec-type
+ [ c-getter ] [ c-type c-type-boxer-quot ] bi append
+ ] tri
define-struct-slot-word ;
: define-setter ( type spec -- )
[ set-writer-props ] keep
- dup slot-spec-writer
- over slot-spec-type c-setter
+ [ ]
+ [ slot-spec-writer ]
+ [ slot-spec-type c-setter ] tri
define-struct-slot-word ;
: define-field ( type spec -- )
: (define-struct) ( name vocab size align fields -- )
>r [ align ] keep r>
- struct-type construct-boa
+ struct-type boa
-rot define-c-type ;
: make-field ( struct-name vocab type field-name -- spec )
-! Copyright (C) 2005, 2007 Slava Pestov, Alex Chapman.
+! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien alien.c-types alien.structs alien.arrays
-kernel math namespaces parser sequences words quotations
-math.parser splitting effects prettyprint prettyprint.sections
-prettyprint.backend assocs combinators ;
+alien.strings kernel math namespaces parser sequences words
+quotations math.parser splitting effects prettyprint
+prettyprint.sections prettyprint.backend assocs combinators ;
IN: alien.syntax
<PRIVATE
: parse-arglist ( return seq -- types effect )
- 2 group dup keys swap values
+ 2 group dup keys swap values [ "," ?tail drop ] map
rot dup "void" = [ drop { } ] [ 1array ] if <effect> ;
: function-quot ( type lib func types -- quot )
{
{ [ dup expired? ] [ drop "( alien expired )" text ] }
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
- { [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] }
+ [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
} cond ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;
: >array ( seq -- array ) { } clone-like ;
-M: object new drop f <array> ;
+M: object new-sequence drop f <array> ;
-M: f new drop dup zero? [ drop f ] [ f <array> ] if ;
+M: f new-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
M: array like drop dup array? [ >array ] unless ;
: 4array ( w x y z -- array ) { } 4sequence ; flushable
-PREDICATE: array pair length 2 number= ;
+PREDICATE: pair < array length 2 number= ;
"To make an assoc into an alist:"
{ $subsection >alist } ;
+ARTICLE: "enums" "Enumerations"
+"An enumeration provides a view of a sequence as an assoc mapping integer indices to elements:"
+{ $subsection enum }
+{ $subsection <enum> }
+"Inverting a permutation using enumerations:"
+{ $example "USING: assocs sorting prettyprint ;" ": invert <enum> >alist sort-values keys ;" "{ 2 0 4 1 3 } invert ." "{ 1 3 0 4 2 }" } ;
+
+HELP: enum
+{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
+$nl
+"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
+
+HELP: <enum>
+{ $values { "seq" sequence } { "enum" enum } }
+{ $description "Creates a new enumeration." } ;
+
ARTICLE: "assocs-protocol" "Associative mapping protocol"
"All associative mappings must be instances of a mixin class:"
{ $subsection assoc }
ARTICLE: "assocs-sets" "Set-theoretic operations on assocs"
"It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)."
{ $subsection subassoc? }
-{ $subsection intersect }
+{ $subsection assoc-intersect }
{ $subsection update }
-{ $subsection union }
-{ $subsection diff }
+{ $subsection assoc-union }
+{ $subsection assoc-diff }
{ $subsection remove-all }
{ $subsection substitute }
{ $subsection substitute-here }
-{ $see-also key? } ;
+{ $see-also key? assoc-contains? assoc-all? "sets" } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
"Utility operations built up from the " { $link "assocs-protocol" } ":"
{ $subsection assoc-map }
{ $subsection assoc-push-if }
{ $subsection assoc-subset }
+{ $subsection assoc-contains? }
{ $subsection assoc-all? }
"Three additional combinators:"
{ $subsection cache }
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
+HELP: assoc-contains?
+{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
+{ $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;
+
HELP: assoc-all?
{ $values { "assoc" assoc } { "quot" "a quotation with stack effect " { $snippet "( key value -- ? )" } } { "?" "a boolean" } }
-{ $description "Applies a predicate quotation to entry in the assoc. Outputs true if the assoc yields true for each entry (which includes the case where the assoc is empty)." } ;
+{ $description "Tests if all entries in the assoc satisfy a predicate by applying the quotation to each entry in turn. a predicate quotation to entry in the assoc. Iteration stops if an entry is found for which the quotation outputs " { $link f } ". If the assoc is empty, always outputs " { $link t } "." } ;
HELP: subassoc?
{ $values { "assoc1" assoc } { "assoc2" assoc } { "?" "a new assoc" } }
{ keys values } related-words
-HELP: intersect
+HELP: assoc-intersect
{ $values { "assoc1" assoc } { "assoc2" assoc } { "intersection" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." }
{ $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ;
{ $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." }
{ $side-effects "assoc1" } ;
-HELP: union
+HELP: assoc-union
{ $values { "assoc1" assoc } { "assoc2" assoc } { "union" "a new assoc" } }
{ $description "Outputs a assoc consisting of all entries from " { $snippet "assoc1" } " and " { $snippet "assoc2" } ", with entries from " { $snippet "assoc2" } " taking precedence in case the corresponding values are not equal." } ;
-HELP: diff
+HELP: assoc-diff
{ $values { "assoc1" assoc } { "assoc2" assoc } { "diff" "a new assoc" } }
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " whose key is not contained in " { $snippet "assoc1" } "." }
;
] [
H{ { "factor" "rocks" } { "dup" "sq" } { 3 4 } }
H{ { "factor" "rocks" } { 1 2 } { 2 3 } { 3 4 } }
- intersect
+ assoc-intersect
] unit-test
[
H{ { 1 2 } { 2 3 } { 6 5 } }
] [
H{ { 2 4 } { 6 5 } } H{ { 1 2 } { 2 3 } }
- union
+ assoc-union
] unit-test
[ H{ { 1 2 } { 2 3 } } t ] [
- f H{ { 1 2 } { 2 3 } } [ union ] 2keep swap union dupd =
+ f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd =
] unit-test
[
H{ { 1 f } }
] [
- H{ { 1 f } } H{ { 1 f } } intersect
+ H{ { 1 f } } H{ { 1 f } } assoc-intersect
] unit-test
[ { 1 3 } ] [ H{ { 2 2 } } { 1 2 3 } remove-all ] unit-test
] [
F{ 1.0 2.0 } [ dup ] H{ } map>assoc
] unit-test
+
+[ { 3 } ] [
+ [
+ 3
+ H{ } clone
+ 2 [
+ 2dup [ , f ] cache drop
+ ] times
+ 2drop
+ ] { } make
+] unit-test
-! Copyright (C) 2007 Daniel Ehrenberg
+! Copyright (C) 2007, 2008 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays math sequences.private vectors ;
+USING: kernel sequences arrays math sequences.private vectors
+accessors ;
IN: assocs
MIXIN: assoc
>r over r> hashcode* 2/ >r dupd hashcode* r> bitxor
] { } assoc>map hashcode* ;
-: intersect ( assoc1 assoc2 -- intersection )
+: assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-subset ;
: update ( assoc1 assoc2 -- )
swap [ swapd set-at ] curry assoc-each ;
-: union ( assoc1 assoc2 -- union )
- 2dup [ assoc-size ] 2apply + pick new-assoc
+: assoc-union ( assoc1 assoc2 -- union )
+ 2dup [ assoc-size ] bi@ + pick new-assoc
[ rot update ] keep [ swap update ] keep ;
-: diff ( assoc1 assoc2 -- diff )
+: assoc-diff ( assoc1 assoc2 -- diff )
swap [ nip key? not ] curry assoc-subset ;
: remove-all ( assoc seq -- subseq )
(substitute) map ;
: cache ( key assoc quot -- value )
- 2over at [
+ 2over at* [
>r 3drop r>
] [
- pick rot >r >r call dup r> r> set-at
- ] if* ; inline
+ drop pick rot >r >r call dup r> r> set-at
+ ] if ; inline
: change-at ( key assoc quot -- )
[ >r at r> call ] 3keep drop set-at ; inline
: value-at ( value assoc -- key/f )
swap [ = nip ] curry assoc-find 2drop ;
+: zip ( keys values -- alist )
+ 2array flip ; inline
+
: search-alist ( key alist -- pair i )
[ first = ] with find swap ; inline
M: f assoc-like drop dup assoc-empty? [ drop f ] when ;
INSTANCE: sequence assoc
+
+TUPLE: enum seq ;
+
+C: <enum> enum
+
+M: enum at*
+ seq>> 2dup bounds-check?
+ [ nth t ] [ 2drop f f ] if ;
+
+M: enum set-at seq>> set-nth ;
+
+M: enum delete-at enum-seq delete-nth ;
+
+M: enum >alist ( enum -- alist )
+ seq>> [ length ] keep zip ;
+
+M: enum assoc-size seq>> length ;
+
+M: enum clear-assoc seq>> delete-all ;
+
+INSTANCE: enum assoc
{ t f t } { f t f }
] [
{ t f t } >bit-array dup clone dup [ not ] change-each
- [ >array ] 2apply
+ [ >array ] bi@
] unit-test
[
M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
-M: bit-array new drop <bit-array> ;
+M: bit-array new-sequence drop <bit-array> ;
M: bit-array equal?
over bit-array? [ sequence= ] [ 2drop f ] if ;
+++ /dev/null
-USING: arrays bit-arrays help.markup help.syntax kernel\r
-bit-vectors.private combinators ;\r
-IN: bit-vectors\r
-\r
-ARTICLE: "bit-vectors" "Bit vectors"\r
-"A bit vector is a resizable mutable sequence of bits. The literal syntax is covered in " { $link "syntax-bit-vectors" } ". Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."\r
-$nl\r
-"Bit vectors form a class:"\r
-{ $subsection bit-vector }\r
-{ $subsection bit-vector? }\r
-"Creating bit vectors:"\r
-{ $subsection >bit-vector }\r
-{ $subsection <bit-vector> }\r
-"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"\r
-{ $code "?V{ } clone" } ;\r
-\r
-ABOUT: "bit-vectors"\r
-\r
-HELP: bit-vector\r
-{ $description "The class of resizable bit vectors. See " { $link "syntax-bit-vectors" } " for syntax and " { $link "bit-vectors" } " for general information." } ;\r
-\r
-HELP: <bit-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }\r
-{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;\r
-\r
-HELP: >bit-vector\r
-{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }\r
-{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;\r
-\r
-HELP: bit-array>vector\r
-{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }\r
-{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }\r
-{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ;\r
+++ /dev/null
-IN: bit-vectors.tests\r
-USING: tools.test bit-vectors vectors sequences kernel math ;\r
-\r
-[ 0 ] [ 123 <bit-vector> length ] unit-test\r
-\r
-: do-it\r
- 1234 swap [ >r even? r> push ] curry each ;\r
-\r
-[ t ] [\r
- 3 <bit-vector> dup do-it\r
- 3 <vector> dup do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ ?V{ } bit-vector? ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable bit-arrays ;\r
-IN: bit-vectors\r
-\r
-<PRIVATE\r
-\r
-: bit-array>vector ( bit-array length -- bit-vector )\r
- bit-vector construct-boa ; inline\r
-\r
-PRIVATE>\r
-\r
-: <bit-vector> ( n -- bit-vector )\r
- <bit-array> 0 bit-array>vector ; inline\r
-\r
-: >bit-vector ( seq -- bit-vector ) ?V{ } clone-like ;\r
-\r
-M: bit-vector like\r
- drop dup bit-vector? [\r
- dup bit-array?\r
- [ dup length bit-array>vector ] [ >bit-vector ] if\r
- ] unless ;\r
-\r
-M: bit-vector new\r
- drop [ <bit-array> ] keep >fixnum bit-array>vector ;\r
-\r
-M: bit-vector equal?\r
- over bit-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: bit-array new-resizable drop <bit-vector> ;\r
-\r
-INSTANCE: bit-vector growable\r
! See http://factorcode.org/license.txt for BSD license.
USING: compiler cpu.architecture vocabs.loader system sequences
namespaces parser kernel kernel.private classes classes.private
-arrays hashtables vectors tuples sbufs inference.dataflow
-hashtables.private sequences.private math tuples.private
+arrays hashtables vectors classes.tuple sbufs inference.dataflow
+hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words generator command-line
vocabs io prettyprint libc compiler.units ;
IN: bootstrap.compiler
"alien.remote-control" require
] unless
-"cpu." cpu append require
-
-: enable-compiler ( -- )
- [ optimized-recompile-hook ] recompile-hook set-global ;
-
-: disable-compiler ( -- )
- [ default-recompile-hook ] recompile-hook set-global ;
+"cpu." cpu word-name append require
enable-compiler
nl
-"Compiling some words to speed up bootstrap..." write flush
+"Compiling..." write flush
! Compile a set of words ahead of the full compile.
! This set of words was determined semi-empirically
{
roll -roll declare not
- tuple-class-eq? array? hashtable? vector?
+ array? hashtable? vector?
tuple? sbuf? node? tombstone?
array-capacity array-nth set-array-nth
wrap probe
- delegate
-
underlying
find-pair-next namestack*
"." write flush
{
- new nth push pop peek
+ new-sequence nth push pop peek
} compile
"." write flush
"." write flush
{
- malloc free memcpy
+ malloc calloc free memcpy
} compile
+vocabs [ words [ compiled? not ] subset compile "." write flush ] each
+
" done" print flush
hashtables assocs hashtables.private io kernel kernel.private
math namespaces parser prettyprint sequences sequences.private
strings sbufs vectors words quotations assocs system layouts
-splitting growable classes tuples words.private
-io.binary io.files vocabs vocabs.loader source-files
-definitions debugger float-arrays quotations.private
-sequences.private combinators io.encodings.binary ;
+splitting growable classes classes.builtin classes.tuple
+classes.tuple.private words.private io.binary io.files vocabs
+vocabs.loader source-files definitions debugger float-arrays
+quotations.private sequences.private combinators
+io.encodings.binary ;
IN: bootstrap.image
: my-arch ( -- arch )
- cpu dup "ppc" = [ os "-" rot 3append ] when ;
+ cpu word-name
+ dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
: boot-image-name ( arch -- string )
"boot." swap ".image" 3append ;
: quot-xt@ 3 bootstrap-cells object tag-number - ;
: jit-define ( quot rc rt offset name -- )
- >r >r >r >r { } make r> r> r> 4array r> set ;
+ >r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ;
! The image being constructed; a vector of word-size integers
SYMBOL: image
: here ( -- size ) heap-size data-base + ;
-: here-as ( tag -- pointer ) here swap bitor ;
+: here-as ( tag -- pointer ) here bitor ;
: align-here ( -- )
- here 8 mod 4 = [ heap-size drop 0 emit ] when ;
+ here 8 mod 4 = [ 0 emit ] when ;
: emit-fixnum ( n -- ) tag-fixnum emit ;
userenv-size [ f ' emit ] times ;
: emit-userenv ( symbol -- )
- dup get ' swap userenv-offset fixup ;
+ [ get ' ] [ userenv-offset ] bi fixup ;
! Bignums
: bignum>seq ( n -- seq )
#! n is positive or zero.
[ dup 0 > ]
- [ dup bignum-bits neg shift swap bignum-radix bitand ]
+ [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
[ ] unfold nip ;
-USE: continuations
: emit-bignum ( n -- )
- dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
- dup length 1+ emit-fixnum
- swap emit emit-seq ;
+ dup dup 0 < [ neg ] when bignum>seq
+ [ nip length 1+ emit-fixnum ]
+ [ drop 0 < 1 0 ? emit ]
+ [ nip emit-seq ]
+ 2tri ;
M: bignum '
bignum tag-number dup [ emit-bignum ] emit-object ;
! Words
: emit-word ( word -- )
- dup subwords [ emit-word ] each
[
- dup hashcode ' ,
- dup word-name ' ,
- dup word-vocabulary ' ,
- dup word-def ' ,
- dup word-props ' ,
- f ' ,
- 0 , ! count
- 0 , ! xt
- 0 , ! code
- 0 , ! profiling
- ] { } make
- \ word type-number object tag-number
- [ emit-seq ] emit-object
- swap objects get set-at ;
+ [ subwords [ emit-word ] each ]
+ [
+ [
+ {
+ [ hashcode , ]
+ [ word-name , ]
+ [ word-vocabulary , ]
+ [ word-def , ]
+ [ word-props , ]
+ } cleave
+ f ,
+ 0 , ! count
+ 0 , ! xt
+ 0 , ! code
+ 0 , ! profiling
+ ] { } make [ ' ] map
+ ] bi
+ \ word type-number object tag-number
+ [ emit-seq ] emit-object
+ ] keep objects get set-at ;
: word-error ( word msg -- * )
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
: transfer-word ( word -- word )
- dup target-word swap or ;
+ [ target-word ] keep or ;
: fixup-word ( word -- offset )
transfer-word dup objects get at
length 0 assert= ;
: emit-dummy-array ( obj type -- ptr )
- swap assert-empty
- type-number object tag-number
- [ 0 emit-fixnum ] emit-object ;
+ [ assert-empty ] [
+ type-number object tag-number
+ [ 0 emit-fixnum ] emit-object
+ ] bi* ;
M: byte-array ' byte-array emit-dummy-array ;
M: float-array ' float-array emit-dummy-array ;
-! Arrays
-: emit-array ( list type tag -- pointer )
- >r >r [ ' ] map r> r> [
- dup length emit-fixnum
- emit-seq
- ] emit-object ;
+! Tuples
+: (emit-tuple) ( tuple -- pointer )
+ [ tuple>array 1 tail-slice ]
+ [ class transfer-word tuple-layout ] bi prefix [ ' ] map
+ tuple type-number dup [ emit-seq ] emit-object ;
-: emit-tuple ( obj -- pointer )
- [
- [ tuple>array unclip transfer-word , % ] { } make
- tuple type-number dup emit-array
- ]
- ! Hack
- over class word-name "tombstone" =
- [ objects get swap cache ] [ call ] if ;
+: emit-tuple ( tuple -- pointer )
+ dup class word-name "tombstone" =
+ [ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
M: tuple ' emit-tuple ;
+M: tuple-layout '
+ objects get [
+ [
+ {
+ [ layout-hashcode , ]
+ [ layout-class , ]
+ [ layout-size , ]
+ [ layout-superclasses , ]
+ [ layout-echelon , ]
+ } cleave
+ ] { } make [ ' ] map
+ \ tuple-layout type-number
+ object tag-number [ emit-seq ] emit-object
+ ] cache ;
+
M: tombstone '
delegate
"((tombstone))" "((empty))" ? "hashtables.private" lookup
word-def first objects get [ emit-tuple ] cache ;
+! Arrays
M: array '
- array type-number object tag-number emit-array ;
+ [ ' ] map array type-number object tag-number
+ [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
! Quotations
] emit-object
] cache ;
-! Curries
-
-M: curry '
- dup curry-quot ' swap curry-obj '
- \ curry type-number object tag-number
- [ emit emit ] emit-object ;
-
! End of the image
: emit-words ( -- )
: emit-global ( -- )
[
{
- dictionary source-files
- typemap builtins class<map update-map
+ dictionary source-files builtins
+ update-map class<-cache class-not-cache
+ classes-intersect-cache class-and-cache
+ class-or-cache
} [ dup get swap bootstrap-word set ] each
] H{ } make-assoc
bootstrap-global set
: write-image ( image -- )
"Writing image to " write
architecture get boot-image-name resource-path
- dup write "..." print flush
- binary <file-writer> [ (write-image) ] with-stream ;
+ [ write "..." print flush ]
+ [ binary <file-writer> [ (write-image) ] with-stream ] bi ;
PRIVATE>
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays bit-arrays
-float-arrays quotations assocs layouts tuples ;
+float-arrays quotations assocs layouts classes.tuple.private
+kernel.private ;
BIN: 111 tag-mask set
8 num-tags set
3 tag-bits set
-19 num-types set
+20 num-types set
H{
{ fixnum BIN: 000 }
{ bignum BIN: 001 }
{ tuple BIN: 010 }
{ object BIN: 011 }
+ { hi-tag BIN: 011 }
{ ratio BIN: 100 }
{ float BIN: 101 }
{ complex BIN: 110 }
{ alien 16 }
{ word 17 }
{ byte-array 18 }
-} union type-numbers set
+ { tuple-layout 19 }
+} assoc-union type-numbers set
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: bootstrap.primitives
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math namespaces parser sequences
-strings vectors words quotations assocs layouts classes tuples
+strings vectors words quotations assocs layouts classes
+classes.builtin classes.tuple classes.tuple.private
kernel.private vocabs vocabs.loader source-files definitions
-slots classes.union compiler.units bootstrap.image.private
-io.files ;
+slots.deprecated classes.union compiler.units
+bootstrap.image.private io.files accessors combinators ;
+IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
-H{ } clone changed-words set
+H{ } clone changed-definitions set
+H{ } clone forgotten-definitions set
+H{ } clone root-cache set
+H{ } clone source-files set
+H{ } clone update-map set
+init-caches
+
+! Vocabulary for slot accessors
+"accessors" create-vocab drop
! Trivial recompile hook. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
call
call
+! After we execute bootstrap/layouts
+num-types get f <array> builtins set
+
! Create some empty vocabs where the below primitives and
! classes will go
{
"alien.accessors"
"arrays"
"bit-arrays"
- "bit-vectors"
"byte-arrays"
- "byte-vectors"
"classes.private"
+ "classes.tuple"
+ "classes.tuple.private"
"compiler.units"
"continuations.private"
"float-arrays"
- "float-vectors"
"generator"
"growable"
"hashtables"
"system.private"
"threads.private"
"tools.profiler.private"
- "tuples"
- "tuples.private"
"words"
"words.private"
"vectors"
"vectors.private"
} [ create-vocab drop ] each
-H{ } clone source-files set
-H{ } clone class<map set
-H{ } clone update-map set
-
! Builtin classes
-: builtin-predicate-quot ( class -- quot )
+: lo-tag-eq-quot ( n -- quot )
+ [ \ tag , , \ eq? , ] [ ] make ;
+
+: hi-tag-eq-quot ( n -- quot )
[
- "type" word-prop dup
- \ tag-mask get < \ tag \ type ? , , \ eq? ,
+ [ dup tag ] % \ hi-tag tag-number , \ eq? ,
+ [ [ hi-tag ] % , \ eq? , ] [ ] make ,
+ [ drop f ] ,
+ \ if ,
] [ ] make ;
+: builtin-predicate-quot ( class -- quot )
+ "type" word-prop
+ dup tag-mask get <
+ [ lo-tag-eq-quot ] [ hi-tag-eq-quot ] if ;
+
: define-builtin-predicate ( class -- )
- dup
- dup builtin-predicate-quot define-predicate
- predicate-word make-inline ;
+ dup builtin-predicate-quot define-predicate ;
: lookup-type-number ( word -- n )
global [ target-word ] bind type-number ;
: register-builtin ( class -- )
- dup
- dup lookup-type-number "type" set-word-prop
- dup "type" word-prop builtins get set-nth ;
+ [ dup lookup-type-number "type" set-word-prop ]
+ [ dup "type" word-prop builtins get set-nth ]
+ [ f f builtin-class define-class ]
+ tri ;
: define-builtin-slots ( symbol slotspec -- )
- dupd 1 simple-slots
- 2dup "slots" set-word-prop
- define-slots ;
+ [ drop ] [ 1 simple-slots ] 2bi
+ [ "slots" set-word-prop ] [ define-slots ] 2bi ;
: define-builtin ( symbol slotspec -- )
- >r
- dup register-builtin
- dup f f builtin-class define-class
- dup define-builtin-predicate
+ >r [ define-builtin-predicate ] keep
r> define-builtin-slots ;
-H{ } clone typemap set
-num-types get f <array> builtins set
+"fixnum" "math" create register-builtin
+"bignum" "math" create register-builtin
+"tuple" "kernel" create register-builtin
+"ratio" "math" create register-builtin
+"float" "math" create register-builtin
+"complex" "math" create register-builtin
+"f" "syntax" lookup register-builtin
+"array" "arrays" create register-builtin
+"wrapper" "kernel" create register-builtin
+"float-array" "float-arrays" create register-builtin
+"callstack" "kernel" create register-builtin
+"string" "strings" create register-builtin
+"bit-array" "bit-arrays" create register-builtin
+"quotation" "quotations" create register-builtin
+"dll" "alien" create register-builtin
+"alien" "alien" create register-builtin
+"word" "words" create register-builtin
+"byte-array" "byte-arrays" create register-builtin
+"tuple-layout" "classes.tuple.private" create register-builtin
+
+! Catch-all class for providing a default method.
+"object" "kernel" create
+[ f builtins get [ ] subset union-class define-class ]
+[ [ drop t ] "predicate" set-word-prop ]
+bi
-! Forward definitions
-"object" "kernel" create t "class" set-word-prop
-"object" "kernel" create union-class "metaclass" set-word-prop
+"object?" "kernel" vocab-words delete-at
-"null" "kernel" create drop
+! Class of objects with object tag
+"hi-tag" "kernel.private" create
+builtins get num-tags get tail define-union-class
+
+! Empty class with no instances
+"null" "kernel" create
+[ f { } union-class define-class ]
+[ [ drop f ] "predicate" set-word-prop ]
+bi
+
+"null?" "kernel" vocab-words delete-at
"fixnum" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
"bignum" "math" create { } define-builtin
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
-"tuple" "kernel" create { } define-builtin
-
"ratio" "math" create {
{
{ "integer" "math" }
"f" "syntax" lookup { } define-builtin
-! do not word...
-
"array" "arrays" create { } define-builtin
"wrapper" "kernel" create {
"callstack" "kernel" create { } define-builtin
-! Define general-t type, which is any object that is not f.
-"general-t" "kernel" create
-"f" "syntax" lookup builtins get remove [ ] subset f union-class
-define-class
-
-"f" "syntax" create [ not ] "predicate" set-word-prop
-"f?" "syntax" create "syntax" vocab-words delete-at
-
-"general-t" "kernel" create [ ] "predicate" set-word-prop
-"general-t?" "kernel" create "syntax" vocab-words delete-at
-
-! Catch-all class for providing a default method.
-"object" "kernel" create [ drop t ] "predicate" set-word-prop
-"object" "kernel" create
-builtins get [ ] subset f union-class define-class
+"tuple-layout" "classes.tuple.private" create {
+ {
+ { "fixnum" "math" }
+ "hashcode"
+ { "layout-hashcode" "classes.tuple.private" }
+ f
+ }
+ {
+ { "word" "words" }
+ "class"
+ { "layout-class" "classes.tuple.private" }
+ f
+ }
+ {
+ { "fixnum" "math" }
+ "size"
+ { "layout-size" "classes.tuple.private" }
+ f
+ }
+ {
+ { "array" "arrays" }
+ "superclasses"
+ { "layout-superclasses" "classes.tuple.private" }
+ f
+ }
+ {
+ { "fixnum" "math" }
+ "echelon"
+ { "layout-echelon" "classes.tuple.private" }
+ f
+ }
+} define-builtin
-! Class of objects with object tag
-"hi-tag" "classes.private" create
-builtins get num-tags get tail f union-class define-class
+"tuple" "kernel" create {
+ [ { } define-builtin ]
+ [ { "delegate" } "slot-names" set-word-prop ]
+ [ define-tuple-layout ]
+ [
+ {
+ {
+ { "object" "kernel" }
+ "delegate"
+ { "delegate" "kernel" }
+ { "set-delegate" "kernel" }
+ }
+ }
+ [ drop ] [ generate-tuple-slots ] 2bi
+ [ "slots" set-word-prop ]
+ [ define-slots ]
+ 2bi
+ ]
+} cleave
-! Null class with no instances.
-"null" "kernel" create [ drop f ] "predicate" set-word-prop
-"null" "kernel" create { } f union-class define-class
+"f" "syntax" create [ not ] "predicate" set-word-prop
+"f?" "syntax" vocab-words delete-at
! Create special tombstone values
-"tombstone" "hashtables.private" create { } define-tuple-class
+"tombstone" "hashtables.private" create
+tuple
+{ } define-tuple-class
"((empty))" "hashtables.private" create
"tombstone" "hashtables.private" lookup f
! Some tuple classes
"hashtable" "hashtables" create
+tuple
{
{
{ "array-capacity" "sequences.private" }
} define-tuple-class
"sbuf" "sbufs" create
+tuple
{
{
{ "string" "strings" }
} define-tuple-class
"vector" "vectors" create
+tuple
{
{
{ "array" "arrays" }
}
} define-tuple-class
-"byte-vector" "byte-vectors" create
-{
- {
- { "byte-array" "byte-arrays" }
- "underlying"
- { "underlying" "growable" }
- { "set-underlying" "growable" }
- } {
- { "array-capacity" "sequences.private" }
- "fill"
- { "length" "sequences" }
- { "set-fill" "growable" }
- }
-} define-tuple-class
-
-"bit-vector" "bit-vectors" create
-{
- {
- { "bit-array" "bit-arrays" }
- "underlying"
- { "underlying" "growable" }
- { "set-underlying" "growable" }
- } {
- { "array-capacity" "sequences.private" }
- "fill"
- { "length" "sequences" }
- { "set-fill" "growable" }
- }
-} define-tuple-class
-
-"float-vector" "float-vectors" create
-{
- {
- { "float-array" "float-arrays" }
- "underlying"
- { "underlying" "growable" }
- { "set-underlying" "growable" }
- } {
- { "array-capacity" "sequences.private" }
- "fill"
- { "length" "sequences" }
- { "set-fill" "growable" }
- }
-} define-tuple-class
-
"curry" "kernel" create
+tuple
{
{
{ "object" "kernel" }
}
} define-tuple-class
+"curry" "kernel" lookup
+[ f "inline" set-word-prop ]
+[ ]
+[ tuple-layout [ <tuple-boa> ] curry ] tri define
+
"compose" "kernel" create
+tuple
{
{
{ "object" "kernel" }
}
} define-tuple-class
+"compose" "kernel" lookup
+[ f "inline" set-word-prop ]
+[ ]
+[ tuple-layout [ <tuple-boa> ] curry ] tri define
+
! Primitive words
: make-primitive ( word vocab n -- )
>r create dup reset-word r>
{ "eq?" "kernel" }
{ "getenv" "kernel.private" }
{ "setenv" "kernel.private" }
- { "(stat)" "io.files.private" }
+ { "(exists?)" "io.files.private" }
{ "(directory)" "io.files.private" }
- { "data-gc" "memory" }
- { "code-gc" "memory" }
+ { "gc" "memory" }
{ "gc-time" "memory" }
{ "save-image" "memory" }
{ "save-image-and-exit" "memory" }
{ "code-room" "memory" }
{ "os-env" "system" }
{ "millis" "system" }
- { "type" "kernel.private" }
{ "tag" "kernel.private" }
{ "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" }
{ "set-alien-double" "alien.accessors" }
{ "alien-cell" "alien.accessors" }
{ "set-alien-cell" "alien.accessors" }
- { "alien>char-string" "alien" }
- { "string>char-alien" "alien" }
- { "alien>u16-string" "alien" }
- { "string>u16-alien" "alien" }
{ "(throw)" "kernel.private" }
{ "alien-address" "alien" }
{ "slot" "slots.private" }
{ "<wrapper>" "kernel" }
{ "(clone)" "kernel" }
{ "<string>" "strings" }
- { "(>tuple)" "tuples.private" }
{ "array>quotation" "quotations.private" }
{ "quotation-xt" "quotations" }
- { "<tuple>" "tuples.private" }
- { "tuple>array" "tuples" }
+ { "<tuple>" "classes.tuple.private" }
+ { "<tuple-layout>" "classes.tuple.private" }
{ "profiling" "tools.profiler.private" }
{ "become" "kernel.private" }
{ "(sleep)" "threads.private" }
{ "<float-array>" "float-arrays" }
- { "<tuple-boa>" "tuples.private" }
- { "class-hash" "kernel.private" }
+ { "<tuple-boa>" "classes.tuple.private" }
{ "callstack>array" "kernel" }
{ "innermost-frame-quot" "kernel.private" }
{ "innermost-frame-scan" "kernel.private" }
{ "set-innermost-frame-quot" "kernel.private" }
{ "call-clear" "kernel" }
{ "(os-envs)" "system.private" }
+ { "set-os-env" "system" }
+ { "unset-os-env" "system" }
{ "(set-os-envs)" "system.private" }
{ "resize-byte-array" "byte-arrays" }
{ "resize-bit-array" "bit-arrays" }
{ "resize-float-array" "float-arrays" }
{ "dll-valid?" "alien" }
+ { "unimplemented" "kernel.private" }
}
dup length [ >r first2 r> make-primitive ] 2each
! Rehash hashtables, since bootstrap.image creates them
! using the host image's hashing algorithms
[ hashtable? ] instances [ rehash ] each
-
boot
] %
[
"resource:core/bootstrap/stage2.factor"
- dup resource-exists? [
+ dup exists? [
[ run-file ]
[
:c
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units
-math.parser generic ;
+math.parser generic sets ;
IN: bootstrap.stage2
SYMBOL: bootstrap-time
: default-image-name ( -- string )
- vm file-name windows? [ "." split1 drop ] when
- ".image" append ;
+ vm file-name os windows? [ "." split1 drop ] when
+ ".image" append resource-path ;
: do-crossref ( -- )
"Cross-referencing..." print flush
: load-components ( -- )
"exclude" "include"
- [ get-global " " split [ empty? not ] subset ] 2apply
- seq-diff
- [ "bootstrap." swap append require ] each ;
-
-: compile-remaining ( -- )
- "Compiling remaining words..." print flush
- vocabs [ words [ compiled? not ] subset compile ] each ;
+ [ get-global " " split [ empty? not ] subset ] bi@
+ diff
+ [ "bootstrap." prepend require ] each ;
: count-words ( pred -- )
all-words swap subset length number>string write ;
default-image-name "output-image" set-global
-"math help handbook compiler tools ui ui.tools io" "include" set-global
+"math compiler help random tools ui ui.tools io handbook" "include" set-global
"" "exclude" set-global
parse-command-line
"-no-crossref" cli-args member? [ do-crossref ] unless
! Set dll paths
-wince? [ "windows.ce" require ] when
-winnt? [ "windows.nt" require ] when
+os wince? [ "windows.ce" require ] when
+os winnt? [ "windows.nt" require ] when
"deploy-vocab" get [
"stage2: deployment mode" print
load-components
run-bootstrap-init
-
- "bootstrap.compiler" vocab [
- compile-remaining
- ] when
] with-compiler-errors
:errors
millis r> - dup bootstrap-time set-global
print-report
- "output-image" get resource-path save-image-and-exit
+ "output-image" get save-image-and-exit
] if
";"
"<PRIVATE"
"?{"
- "?V{"
"BIN:"
"B{"
- "BV{"
"C:"
"CHAR:"
"DEFER:"
+ "ERROR:"
"F{"
- "FV{"
"FORGET:"
"GENERIC#"
"GENERIC:"
"PRIMITIVE:"
"PRIVATE>"
"SBUF\""
+ "SINGLETON:"
"SYMBOL:"
"TUPLE:"
"T{"
"CS{"
"<<"
">>"
+ "call-next-method"
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol
\r
TUPLE: box value full? ;\r
\r
-: <box> ( -- box ) box construct-empty ;\r
+: <box> ( -- box ) box new ;\r
\r
: >box ( value box -- )\r
dup box-full? [ "Box already has a value" throw ] when\r
M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ;
: >byte-array ( seq -- byte-array ) B{ } clone-like ; inline
M: byte-array like drop dup byte-array? [ >byte-array ] unless ;
-M: byte-array new drop <byte-array> ;
+M: byte-array new-sequence drop <byte-array> ;
M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ;
+++ /dev/null
-USING: arrays byte-arrays help.markup help.syntax kernel\r
-byte-vectors.private combinators ;\r
-IN: byte-vectors\r
-\r
-ARTICLE: "byte-vectors" "Byte vectors"\r
-"A byte vector is a resizable mutable sequence of unsigned bytes. The literal syntax is covered in " { $link "syntax-byte-vectors" } ". Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."\r
-$nl\r
-"Byte vectors form a class:"\r
-{ $subsection byte-vector }\r
-{ $subsection byte-vector? }\r
-"Creating byte vectors:"\r
-{ $subsection >byte-vector }\r
-{ $subsection <byte-vector> }\r
-"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
-{ $code "BV{ } clone" } ;\r
-\r
-ABOUT: "byte-vectors"\r
-\r
-HELP: byte-vector\r
-{ $description "The class of resizable byte vectors. See " { $link "syntax-byte-vectors" } " for syntax and " { $link "byte-vectors" } " for general information." } ;\r
-\r
-HELP: <byte-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
-\r
-HELP: >byte-vector\r
-{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
-{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
-{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
-\r
-HELP: byte-array>vector\r
-{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }\r
-{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;\r
+++ /dev/null
-IN: byte-vectors.tests\r
-USING: tools.test byte-vectors vectors sequences kernel ;\r
-\r
-[ 0 ] [ 123 <byte-vector> length ] unit-test\r
-\r
-: do-it\r
- 123 [ over push ] each ;\r
-\r
-[ t ] [\r
- 3 <byte-vector> do-it\r
- 3 <vector> do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ BV{ } byte-vector? ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable byte-arrays ;\r
-IN: byte-vectors\r
-\r
-<PRIVATE\r
-\r
-: byte-array>vector ( byte-array length -- byte-vector )\r
- byte-vector construct-boa ; inline\r
-\r
-PRIVATE>\r
-\r
-: <byte-vector> ( n -- byte-vector )\r
- <byte-array> 0 byte-array>vector ; inline\r
-\r
-: >byte-vector ( seq -- byte-vector ) BV{ } clone-like ;\r
-\r
-M: byte-vector like\r
- drop dup byte-vector? [\r
- dup byte-array?\r
- [ dup length byte-array>vector ] [ >byte-vector ] if\r
- ] unless ;\r
-\r
-M: byte-vector new\r
- drop [ <byte-array> ] keep >fixnum byte-array>vector ;\r
-\r
-M: byte-vector equal?\r
- over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: byte-array new-resizable drop <byte-vector> ;\r
-\r
-INSTANCE: byte-vector growable\r
--- /dev/null
+USING: help.markup help.syntax kernel classes ;\r
+IN: classes.algebra\r
+\r
+ARTICLE: "class-operations" "Class operations"\r
+"Set-theoretic operations on classes:"\r
+{ $subsection class< }\r
+{ $subsection class-and }\r
+{ $subsection class-or }\r
+{ $subsection classes-intersect? }\r
+"Topological sort:"\r
+{ $subsection sort-classes }\r
+{ $subsection min-class }\r
+"Low-level implementation detail:"\r
+{ $subsection class-types }\r
+{ $subsection flatten-class }\r
+{ $subsection flatten-builtin-class }\r
+{ $subsection class-types }\r
+{ $subsection class-tags } ;\r
+\r
+HELP: flatten-builtin-class\r
+{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }\r
+{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;\r
+\r
+HELP: flatten-class\r
+{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }\r
+{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;\r
+\r
+HELP: class-types\r
+{ $values { "class" class } { "seq" "an increasing sequence of integers" } }\r
+{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;\r
+\r
+HELP: class<\r
+{ $values { "first" "a class" } { "second" "a class" } { "?" "a boolean" } }\r
+{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }\r
+{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;\r
+\r
+HELP: sort-classes\r
+{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }\r
+{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;\r
+\r
+HELP: class-or\r
+{ $values { "first" class } { "second" class } { "class" class } }\r
+{ $description "Outputs the smallest anonymous class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;\r
+\r
+HELP: class-and\r
+{ $values { "first" class } { "second" class } { "class" class } }\r
+{ $description "Outputs the largest anonymous class contained in both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;\r
+\r
+HELP: classes-intersect?\r
+{ $values { "first" class } { "second" class } { "?" "a boolean" } }\r
+{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;\r
+\r
+HELP: min-class\r
+{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }\r
+{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;\r
--- /dev/null
+IN: classes.algebra.tests\r
+USING: alien arrays definitions generic assocs hashtables io\r
+kernel math namespaces parser prettyprint sequences strings\r
+tools.test vectors words quotations classes classes.algebra\r
+classes.private classes.union classes.mixin classes.predicate\r
+vectors definitions source-files compiler.units growable\r
+random inference effects kernel.private sbufs ;\r
+\r
+: class= [ class< ] 2keep swap class< and ;\r
+\r
+: class-and* >r class-and r> class= ;\r
+\r
+: class-or* >r class-or r> class= ;\r
+\r
+[ t ] [ object object object class-and* ] unit-test\r
+[ t ] [ fixnum object fixnum class-and* ] unit-test\r
+[ t ] [ object fixnum fixnum class-and* ] unit-test\r
+[ t ] [ fixnum fixnum fixnum class-and* ] unit-test\r
+[ t ] [ fixnum integer fixnum class-and* ] unit-test\r
+[ t ] [ integer fixnum fixnum class-and* ] unit-test\r
+\r
+[ t ] [ vector fixnum null class-and* ] unit-test\r
+[ t ] [ number object number class-and* ] unit-test\r
+[ t ] [ object number number class-and* ] unit-test\r
+[ t ] [ slice reversed null class-and* ] unit-test\r
+[ t ] [ \ f class-not \ f null class-and* ] unit-test\r
+[ t ] [ \ f class-not \ f object class-or* ] unit-test\r
+\r
+TUPLE: first-one ;\r
+TUPLE: second-one ;\r
+UNION: both first-one union-class ;\r
+\r
+[ t ] [ both tuple classes-intersect? ] unit-test\r
+[ t ] [ vector virtual-sequence null class-and* ] unit-test\r
+[ f ] [ vector virtual-sequence classes-intersect? ] unit-test\r
+\r
+[ t ] [ number vector class-or sequence classes-intersect? ] unit-test\r
+\r
+[ f ] [ number vector class-and sequence classes-intersect? ] unit-test\r
+\r
+[ t ] [ \ fixnum \ integer class< ] unit-test\r
+[ t ] [ \ fixnum \ fixnum class< ] unit-test\r
+[ f ] [ \ integer \ fixnum class< ] unit-test\r
+[ t ] [ \ integer \ object class< ] unit-test\r
+[ f ] [ \ integer \ null class< ] unit-test\r
+[ t ] [ \ null \ object class< ] unit-test\r
+\r
+[ t ] [ \ generic \ word class< ] unit-test\r
+[ f ] [ \ word \ generic class< ] unit-test\r
+\r
+[ f ] [ \ reversed \ slice class< ] unit-test\r
+[ f ] [ \ slice \ reversed class< ] unit-test\r
+\r
+PREDICATE: no-docs < word "documentation" word-prop not ;\r
+\r
+UNION: no-docs-union no-docs integer ;\r
+\r
+[ t ] [ no-docs no-docs-union class< ] unit-test\r
+[ f ] [ no-docs-union no-docs class< ] unit-test\r
+\r
+TUPLE: a ;\r
+TUPLE: b ;\r
+UNION: c a b ;\r
+\r
+[ t ] [ \ c \ tuple class< ] unit-test\r
+[ f ] [ \ tuple \ c class< ] unit-test\r
+\r
+[ t ] [ \ tuple-class \ class class< ] unit-test\r
+[ f ] [ \ class \ tuple-class class< ] unit-test\r
+\r
+TUPLE: tuple-example ;\r
+\r
+[ t ] [ \ null \ tuple-example class< ] unit-test\r
+[ f ] [ \ object \ tuple-example class< ] unit-test\r
+[ f ] [ \ object \ tuple-example class< ] unit-test\r
+[ t ] [ \ tuple-example \ tuple class< ] unit-test\r
+[ f ] [ \ tuple \ tuple-example class< ] unit-test\r
+\r
+TUPLE: a1 ;\r
+TUPLE: b1 ;\r
+TUPLE: c1 ;\r
+\r
+UNION: x1 a1 b1 ;\r
+UNION: y1 a1 c1 ;\r
+UNION: z1 b1 c1 ;\r
+\r
+[ f ] [ z1 x1 y1 class-and class< ] unit-test\r
+\r
+[ t ] [ x1 y1 class-and a1 class< ] unit-test\r
+\r
+[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test\r
+\r
+[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class< ] unit-test\r
+\r
+[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class< ] unit-test\r
+\r
+[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
+\r
+[ f ] [ growable \ hi-tag classes-intersect? ] unit-test\r
+\r
+[ t ] [\r
+ growable tuple sequence class-and class<\r
+] unit-test\r
+\r
+[ t ] [\r
+ growable assoc class-and tuple class<\r
+] unit-test\r
+\r
+[ t ] [ object \ f \ f class-not class-or class< ] unit-test\r
+\r
+[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test\r
+\r
+[ f ] [ integer integer class-not classes-intersect? ] unit-test\r
+\r
+[ t ] [ array number class-not class< ] unit-test\r
+\r
+[ f ] [ bignum number class-not class< ] unit-test\r
+\r
+[ vector ] [ vector class-not class-not ] unit-test\r
+\r
+[ t ] [ fixnum fixnum bignum class-or class< ] unit-test\r
+\r
+[ f ] [ fixnum class-not integer class-and array class< ] unit-test\r
+\r
+[ f ] [ fixnum class-not integer class< ] unit-test\r
+\r
+[ f ] [ number class-not array class< ] unit-test\r
+\r
+[ f ] [ fixnum class-not array class< ] unit-test\r
+\r
+[ t ] [ number class-not integer class-not class< ] unit-test\r
+\r
+[ t ] [ vector array class-not class-and vector class= ] unit-test\r
+\r
+[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test\r
+\r
+[ f ] [ fixnum class-not integer class< ] unit-test\r
+\r
+[ t ] [ null class-not object class= ] unit-test\r
+\r
+[ t ] [ object class-not null class= ] unit-test\r
+\r
+[ f ] [ object class-not object class= ] unit-test\r
+\r
+[ f ] [ null class-not null class= ] unit-test\r
+\r
+[ t ] [\r
+ fixnum class-not\r
+ fixnum fixnum class-not class-or\r
+ class<\r
+] unit-test\r
+\r
+! Test method inlining\r
+[ f ] [ fixnum { } min-class ] unit-test\r
+\r
+[ string ] [\r
+ \ string\r
+ [ integer string array reversed sbuf\r
+ slice vector quotation ]\r
+ sort-classes min-class\r
+] unit-test\r
+\r
+[ fixnum ] [\r
+ \ fixnum\r
+ [ fixnum integer object ]\r
+ sort-classes min-class\r
+] unit-test\r
+\r
+[ integer ] [\r
+ \ fixnum\r
+ [ integer float object ]\r
+ sort-classes min-class\r
+] unit-test\r
+\r
+[ object ] [\r
+ \ word\r
+ [ integer float object ]\r
+ sort-classes min-class\r
+] unit-test\r
+\r
+[ reversed ] [\r
+ \ reversed\r
+ [ integer reversed slice ]\r
+ sort-classes min-class\r
+] unit-test\r
+\r
+[ f ] [ null { number fixnum null } min-class ] unit-test\r
+\r
+! Test for hangs?\r
+: random-class classes random ;\r
+\r
+: random-op\r
+ {\r
+ class-and\r
+ class-or\r
+ class-not\r
+ } random ;\r
+\r
+10 [\r
+ [ ] [\r
+ 20 [ drop random-op ] map >quotation\r
+ [ infer effect-in [ random-class ] times ] keep\r
+ call\r
+ drop\r
+ ] unit-test\r
+] times\r
+\r
+: random-boolean\r
+ { t f } random ;\r
+\r
+: boolean>class\r
+ object null ? ;\r
+\r
+: random-boolean-op\r
+ {\r
+ and\r
+ or\r
+ not\r
+ xor\r
+ } random ;\r
+\r
+: class-xor [ class-or ] 2keep class-and class-not class-and ;\r
+\r
+: boolean-op>class-op\r
+ {\r
+ { and class-and }\r
+ { or class-or }\r
+ { not class-not }\r
+ { xor class-xor }\r
+ } at ;\r
+\r
+20 [\r
+ [ t ] [\r
+ 20 [ drop random-boolean-op ] [ ] map-as dup .\r
+ [ infer effect-in [ drop random-boolean ] map dup . ] keep\r
+ \r
+ [ >r [ ] each r> call ] 2keep\r
+ \r
+ >r [ boolean>class ] each r> [ boolean-op>class-op ] map call object class=\r
+ \r
+ =\r
+ ] unit-test\r
+] times\r
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: kernel classes classes.builtin combinators accessors\r
+sequences arrays vectors assocs namespaces words sorting layouts\r
+math hashtables kernel.private sets ;\r
+IN: classes.algebra\r
+\r
+: 2cache ( key1 key2 assoc quot -- value )\r
+ >r >r 2array r> [ first2 ] r> compose cache ; inline\r
+\r
+DEFER: (class<)\r
+\r
+: class< ( first second -- ? )\r
+ class<-cache get [ (class<) ] 2cache ;\r
+\r
+DEFER: (class-not)\r
+\r
+: class-not ( class -- complement )\r
+ class-not-cache get [ (class-not) ] cache ;\r
+\r
+DEFER: (classes-intersect?) ( first second -- ? )\r
+\r
+: classes-intersect? ( first second -- ? )\r
+ classes-intersect-cache get [ (classes-intersect?) ] 2cache ;\r
+\r
+DEFER: (class-and)\r
+\r
+: class-and ( first second -- class )\r
+ class-and-cache get [ (class-and) ] 2cache ;\r
+\r
+DEFER: (class-or)\r
+\r
+: class-or ( first second -- class )\r
+ class-or-cache get [ (class-or) ] 2cache ;\r
+\r
+TUPLE: anonymous-union members ;\r
+\r
+C: <anonymous-union> anonymous-union\r
+\r
+TUPLE: anonymous-intersection members ;\r
+\r
+C: <anonymous-intersection> anonymous-intersection\r
+\r
+TUPLE: anonymous-complement class ;\r
+\r
+C: <anonymous-complement> anonymous-complement\r
+\r
+: superclass< ( first second -- ? )\r
+ >r superclass r> class< ;\r
+\r
+: left-union-class< ( first second -- ? )\r
+ >r members r> [ class< ] curry all? ;\r
+\r
+: right-union-class< ( first second -- ? )\r
+ members [ class< ] with contains? ;\r
+\r
+: left-anonymous-union< ( first second -- ? )\r
+ >r members>> r> [ class< ] curry all? ;\r
+\r
+: right-anonymous-union< ( first second -- ? )\r
+ members>> [ class< ] with contains? ;\r
+\r
+: left-anonymous-intersection< ( first second -- ? )\r
+ >r members>> r> [ class< ] curry contains? ;\r
+\r
+: right-anonymous-intersection< ( first second -- ? )\r
+ members>> [ class< ] with all? ;\r
+\r
+: anonymous-complement< ( first second -- ? )\r
+ [ class>> ] bi@ swap class< ;\r
+\r
+: (class<) ( first second -- -1/0/1 ) \r
+ {\r
+ { [ 2dup eq? ] [ 2drop t ] }\r
+ { [ dup object eq? ] [ 2drop t ] }\r
+ { [ over null eq? ] [ 2drop t ] }\r
+ { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement< ] }\r
+ { [ over anonymous-union? ] [ left-anonymous-union< ] }\r
+ { [ over anonymous-intersection? ] [ left-anonymous-intersection< ] }\r
+ { [ over members ] [ left-union-class< ] }\r
+ { [ dup anonymous-union? ] [ right-anonymous-union< ] }\r
+ { [ dup anonymous-intersection? ] [ right-anonymous-intersection< ] }\r
+ { [ over anonymous-complement? ] [ 2drop f ] }\r
+ { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }\r
+ { [ dup members ] [ right-union-class< ] }\r
+ { [ over superclass ] [ superclass< ] }\r
+ [ 2drop f ]\r
+ } cond ;\r
+\r
+: anonymous-union-intersect? ( first second -- ? )\r
+ members>> [ classes-intersect? ] with contains? ;\r
+\r
+: anonymous-intersection-intersect? ( first second -- ? )\r
+ members>> [ classes-intersect? ] with all? ;\r
+\r
+: anonymous-complement-intersect? ( first second -- ? )\r
+ class>> class< not ;\r
+\r
+: union-class-intersect? ( first second -- ? )\r
+ members [ classes-intersect? ] with contains? ;\r
+\r
+: tuple-class-intersect? ( first second -- ? )\r
+ {\r
+ { [ over tuple eq? ] [ 2drop t ] }\r
+ { [ over builtin-class? ] [ 2drop f ] }\r
+ { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] }\r
+ [ swap classes-intersect? ]\r
+ } cond ;\r
+\r
+: builtin-class-intersect? ( first second -- ? )\r
+ {\r
+ { [ 2dup eq? ] [ 2drop t ] }\r
+ { [ over builtin-class? ] [ 2drop f ] }\r
+ [ swap classes-intersect? ]\r
+ } cond ;\r
+\r
+: (classes-intersect?) ( first second -- ? )\r
+ {\r
+ { [ dup anonymous-union? ] [ anonymous-union-intersect? ] }\r
+ { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }\r
+ { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }\r
+ { [ dup tuple-class? ] [ tuple-class-intersect? ] }\r
+ { [ dup builtin-class? ] [ builtin-class-intersect? ] }\r
+ { [ dup superclass ] [ superclass classes-intersect? ] }\r
+ { [ dup members ] [ union-class-intersect? ] }\r
+ } cond ;\r
+\r
+: left-union-and ( first second -- class )\r
+ >r members r> [ class-and ] curry map <anonymous-union> ;\r
+\r
+: right-union-and ( first second -- class )\r
+ members [ class-and ] with map <anonymous-union> ;\r
+\r
+: left-anonymous-union-and ( first second -- class )\r
+ >r members>> r> [ class-and ] curry map <anonymous-union> ;\r
+\r
+: right-anonymous-union-and ( first second -- class )\r
+ members>> [ class-and ] with map <anonymous-union> ;\r
+\r
+: left-anonymous-intersection-and ( first second -- class )\r
+ >r members>> r> suffix <anonymous-intersection> ;\r
+\r
+: right-anonymous-intersection-and ( first second -- class )\r
+ members>> swap suffix <anonymous-intersection> ;\r
+\r
+: (class-and) ( first second -- class )\r
+ {\r
+ { [ 2dup class< ] [ drop ] }\r
+ { [ 2dup swap class< ] [ nip ] }\r
+ { [ 2dup classes-intersect? not ] [ 2drop null ] }\r
+ { [ dup members ] [ right-union-and ] }\r
+ { [ dup anonymous-union? ] [ right-anonymous-union-and ] }\r
+ { [ dup anonymous-intersection? ] [ right-anonymous-intersection-and ] }\r
+ { [ over members ] [ left-union-and ] }\r
+ { [ over anonymous-union? ] [ left-anonymous-union-and ] }\r
+ { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] }\r
+ [ 2array <anonymous-intersection> ]\r
+ } cond ;\r
+\r
+: left-anonymous-union-or ( first second -- class )\r
+ >r members>> r> suffix <anonymous-union> ;\r
+\r
+: right-anonymous-union-or ( first second -- class )\r
+ members>> swap suffix <anonymous-union> ;\r
+\r
+: (class-or) ( first second -- class )\r
+ {\r
+ { [ 2dup class< ] [ nip ] }\r
+ { [ 2dup swap class< ] [ drop ] }\r
+ { [ dup anonymous-union? ] [ right-anonymous-union-or ] }\r
+ { [ over anonymous-union? ] [ left-anonymous-union-or ] }\r
+ [ 2array <anonymous-union> ]\r
+ } cond ;\r
+\r
+: (class-not) ( class -- complement )\r
+ {\r
+ { [ dup anonymous-complement? ] [ class>> ] }\r
+ { [ dup object eq? ] [ drop null ] }\r
+ { [ dup null eq? ] [ drop object ] }\r
+ [ <anonymous-complement> ]\r
+ } cond ;\r
+\r
+: largest-class ( seq -- n elt )\r
+ dup [\r
+ [ 2dup class< >r swap class< not r> and ]\r
+ with subset empty?\r
+ ] curry find [ "Topological sort failed" throw ] unless* ;\r
+\r
+: sort-classes ( seq -- newseq )\r
+ >vector\r
+ [ dup empty? not ]\r
+ [ dup largest-class >r over delete-nth r> ]\r
+ [ ] unfold nip ;\r
+\r
+: min-class ( class seq -- class/f )\r
+ over [ classes-intersect? ] curry subset\r
+ dup empty? [ 2drop f ] [\r
+ tuck [ class< ] with all? [ peek ] [ drop f ] if\r
+ ] if ;\r
+\r
+: (flatten-class) ( class -- )\r
+ {\r
+ { [ dup tuple-class? ] [ dup set ] }\r
+ { [ dup builtin-class? ] [ dup set ] }\r
+ { [ dup members ] [ members [ (flatten-class) ] each ] }\r
+ { [ dup superclass ] [ superclass (flatten-class) ] }\r
+ [ drop ]\r
+ } cond ;\r
+\r
+: flatten-class ( class -- assoc )\r
+ [ (flatten-class) ] H{ } make-assoc ;\r
+\r
+: flatten-builtin-class ( class -- assoc )\r
+ flatten-class [\r
+ dup tuple class< [ 2drop tuple tuple ] when\r
+ ] assoc-map ;\r
+\r
+: class-types ( class -- seq )\r
+ flatten-builtin-class keys\r
+ [ "type" word-prop ] map natural-sort ;\r
+\r
+: class-tags ( class -- tag/f )\r
+ class-types [\r
+ dup num-tags get >=\r
+ [ drop \ hi-tag tag-number ] when\r
+ ] map prune ;\r
--- /dev/null
+USING: help.syntax help.markup classes layouts ;
+IN: classes.builtin
+
+ARTICLE: "builtin-classes" "Built-in classes"
+"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
+$nl
+"The set of built-in classes is a class:"
+{ $subsection builtin-class }
+{ $subsection builtin-class? }
+"See " { $link "type-index" } " for a list of built-in classes." ;
+
+HELP: builtin-class
+{ $class-description "The class of built-in classes." }
+{ $examples
+ "The class of arrays is a built-in class:"
+ { $example "USING: arrays classes.builtin prettyprint ;" "array builtin-class? ." "t" }
+ "However, an instance of the array class is not a built-in class; it is not even a class:"
+ { $example "USING: classes.builtin prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
+} ;
+
+HELP: builtins
+{ $var-description "Vector mapping type numbers to builtin class words." } ;
+
+HELP: type>class
+{ $values { "n" "a non-negative integer" } { "class" class } }
+{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
+{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
+
--- /dev/null
+! Copyright (C) 2004, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes words kernel kernel.private namespaces
+sequences ;
+IN: classes.builtin
+
+SYMBOL: builtins
+
+PREDICATE: builtin-class < class
+ "metaclass" word-prop builtin-class eq? ;
+
+: type>class ( n -- class ) builtins get-global nth ;
+
+: bootstrap-type>class ( n -- class ) builtins get nth ;
+
+M: hi-tag class hi-tag type>class ;
+
+M: object class tag type>class ;
classes.predicate quotations ;
IN: classes
-ARTICLE: "builtin-classes" "Built-in classes"
-"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
-$nl
-"The set of built-in classes is a class:"
-{ $subsection builtin-class }
-{ $subsection builtin-class? }
-"See " { $link "type-index" } " for a list of built-in classes." ;
-
-ARTICLE: "class-operations" "Class operations"
-"Set-theoretic operations on classes:"
-{ $subsection class< }
-{ $subsection class-and }
-{ $subsection class-or }
-{ $subsection classes-intersect? }
-"Topological sort:"
-{ $subsection sort-classes }
-{ $subsection min-class }
-"Low-level implementation detail:"
-{ $subsection types }
-{ $subsection flatten-class }
-{ $subsection flatten-builtin-class }
-{ $subsection flatten-union-class } ;
-
ARTICLE: "class-predicates" "Class predicate words"
"With a handful of exceptions, each class has a membership predicate word, named " { $snippet { $emphasis "class" } "?" } " . A quotation calling this predicate is stored in the " { $snippet "\"predicate\"" } " word property."
$nl
{ { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } }
{ { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } }
{ { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } }
- { { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } }
}
"The set of class predicate words is a class:"
{ $subsection predicate }
{ $subsection class? }
"You can ask an object for its class:"
{ $subsection class }
+"Testing if an object is an instance of a class:"
+{ $subsection instance? }
"There is a universal class which all objects are an instance of, and an empty class with no instances:"
{ $subsection object }
{ $subsection null }
"Obtaining a list of all defined classes:"
{ $subsection classes }
-"Other sorts of classes:"
+"There are several sorts of classes:"
{ $subsection "builtin-classes" }
{ $subsection "unions" }
{ $subsection "mixins" }
{ $subsection "predicates" }
+{ $subsection "singletons" }
+{ $link "tuples" } " are documented in their own section."
+$nl
"Classes can be inspected and operated upon:"
{ $subsection "class-operations" }
{ $see-also "class-index" } ;
HELP: class
{ $values { "object" object } { "class" class } }
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
-{ $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." }
+{ $class-description "The class of all class words." }
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
-HELP: builtin-class
-{ $class-description "The class of built-in classes." }
-{ $examples
- "The class of arrays is a built-in class:"
- { $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" }
- "However, an instance of the array class is not a built-in class; it is not even a class:"
- { $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
-} ;
-
HELP: tuple-class
{ $class-description "The class of tuple class words." }
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
-HELP: typemap
-{ $var-description "Hashtable mapping unions to class words, used to implement " { $link class-and } " and " { $link class-or } "." } ;
-
-HELP: builtins
-{ $var-description "Vector mapping type numbers to builtin class words." } ;
-
-HELP: class<map
-{ $var-description "Hashtable mapping each class to a set of classes which are contained in that class under the " { $link (class<) } " relation. The " { $link class< } " word uses this hashtable to avoid frequent expensive calls to " { $link (class<) } "." } ;
-
HELP: update-map
{ $var-description "Hashtable mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
-HELP: type>class
-{ $values { "n" "a non-negative integer" } { "class" class } }
-{ $description "Outputs a builtin class whose instances are precisely those having a given pointer tag." }
-{ $notes "The parameter " { $snippet "n" } " must be between 0 and the return value of " { $link num-types } "." } ;
-
HELP: predicate-word
{ $values { "word" "a word" } { "predicate" "a predicate word" } }
{ $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ;
HELP: superclass
{ $values { "class" class } { "super" class } }
-{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." }
-{ $notes "If " { $link class< } " yields that one class is a subtype of another, it does not imply that a superclass relation is involved. The superclass relation is a technical implementation detail of predicate and tuple classes." } ;
+{ $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } ;
HELP: members
{ $values { "class" class } { "seq" "a sequence of union members, or " { $link f } } }
{ $description "If " { $snippet "class" } " is a union class, outputs a sequence of its member classes, otherwise outputs " { $link f } "." } ;
-HELP: flatten-union-class
-{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
-{ $description "Outputs the set of classes whose union is equal to " { $snippet "class" } ". Unions are expanded recursively so the output assoc does not contain any union classes. However, it may contain predicate classes whose superclasses are unions." } ;
-
-HELP: flatten-builtin-class
-{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
-{ $description "Outputs a set of tuple classes whose union is the smallest cover of " { $snippet "class" } " intersected with " { $link tuple } "." } ;
-
-HELP: flatten-class
-{ $values { "class" class } { "assoc" "an assoc whose keys are classes" } }
-{ $description "Outputs a set of builtin and tuple classes whose union is the smallest cover of " { $snippet "class" } "." } ;
-
-HELP: types
-{ $values { "class" class } { "seq" "an increasing sequence of integers" } }
-{ $description "Outputs a sequence of builtin type numbers whose instances can possibly be instances of the given class." } ;
-
-HELP: class-empty?
-{ $values { "class" "a class" } { "?" "a boolean" } }
-{ $description "Tests if a class is a union class with no members." }
-{ $examples { $example "USING: classes kernel prettyprint ;" "null class-empty? ." "t" } } ;
-
-HELP: (class<)
-{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
-{ $description "Performs the calculation for " { $link class< } ". There is never any reason to call this word from user code since " { $link class< } " outputs identical values and caches results for better performance." } ;
-
-HELP: class<
-{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
-{ $description "Tests if all instances of " { $snippet "class1" } " are also instances of " { $snippet "class2" } "." }
-{ $notes "Classes are partially ordered. This means that if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class1" } ", then " { $snippet "class1 = class2" } ". Also, if " { $snippet "class1 <= class2" } " and " { $snippet "class2 <= class3" } ", then " { $snippet "class1 <= class3" } "." } ;
-
-HELP: sort-classes
-{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
-{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
-
-HELP: lookup-union
-{ $values { "classes" "a hashtable mapping class words to themselves" } { "class" class } }
-{ $description "Given a set of classes represented as a hashtable with equal keys and values, looks up a previously-defined union class having those members. If no union is defined, outputs " { $link object } "." } ;
-
-{ class-and class-or lookup-union } related-words
-
-HELP: class-or
-{ $values { "class1" class } { "class2" class } { "class" class } }
-{ $description "Outputs the smallest known class containing both " { $snippet "class1" } " and " { $snippet "class2" } "." } ;
-
-HELP: class-and
-{ $values { "class1" class } { "class2" class } { "class" class } }
-{ $description "Outputs the largest known class contained in both " { $snippet "class1" } " and " { $snippet "class2" } ". If the intersection is non-empty but no union class with those exact members is defined, outputs " { $link object } ". If the intersection is empty, outputs " { $link null } "." } ;
-
-HELP: classes-intersect?
-{ $values { "class1" class } { "class2" class } { "?" "a boolean" } }
-{ $description "Tests if two classes have a non-empty intersection. If the intersection is empty, no object can be an instance of both classes at once." } ;
-
-HELP: min-class
-{ $values { "class" class } { "seq" "a sequence of class words" } { "class/f" "a class word or " { $link f } } }
-{ $description "If all classes in " { $snippet "seq" } " that intersect " { $snippet "class" } " are subtypes of " { $snippet "class" } ", outputs the last such element of " { $snippet "seq" } ". If any conditions fail to hold, outputs " { $link f } "." } ;
-
HELP: define-class
{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
-{ $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link typemap } " and " { $link class<map } "." }
+{ $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link update-map } "." }
$low-level-note ;
USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings
-tools.test vectors words quotations classes io.streams.string
+tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
-vectors definitions source-files compiler.units ;
+classes.algebra vectors definitions source-files
+compiler.units kernel.private ;
IN: classes.tests
-H{ } "s" set
-
-[ ] [ 1 2 "s" get push-at ] unit-test
-[ 1 ] [ 2 "s" get at first ] unit-test
-[ ] [ 1 2 "s" get pop-at ] unit-test
-[ t ] [ 2 "s" get at empty? ] unit-test
-
-[ object ] [ object object class-and ] unit-test
-[ fixnum ] [ fixnum object class-and ] unit-test
-[ fixnum ] [ object fixnum class-and ] unit-test
-[ fixnum ] [ fixnum fixnum class-and ] unit-test
-[ fixnum ] [ fixnum integer class-and ] unit-test
-[ fixnum ] [ integer fixnum class-and ] unit-test
-[ null ] [ vector fixnum class-and ] unit-test
-[ number ] [ number object class-and ] unit-test
-[ number ] [ object number class-and ] unit-test
-[ null ] [ slice reversed class-and ] unit-test
-
-TUPLE: first-one ;
-TUPLE: second-one ;
-UNION: both first-one union-class ;
-
-[ t ] [ both tuple classes-intersect? ] unit-test
-[ null ] [ vector virtual-sequence class-and ] unit-test
-[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
-
-[ t ] [ \ fixnum \ integer class< ] unit-test
-[ t ] [ \ fixnum \ fixnum class< ] unit-test
-[ f ] [ \ integer \ fixnum class< ] unit-test
-[ t ] [ \ integer \ object class< ] unit-test
-[ f ] [ \ integer \ null class< ] unit-test
-[ t ] [ \ null \ object class< ] unit-test
-
-[ t ] [ \ generic \ word class< ] unit-test
-[ f ] [ \ word \ generic class< ] unit-test
-
-[ f ] [ \ reversed \ slice class< ] unit-test
-[ f ] [ \ slice \ reversed class< ] unit-test
-
-PREDICATE: word no-docs "documentation" word-prop not ;
-
-UNION: no-docs-union no-docs integer ;
-
-[ t ] [ no-docs no-docs-union class< ] unit-test
-[ f ] [ no-docs-union no-docs class< ] unit-test
-
-TUPLE: a ;
-TUPLE: b ;
-UNION: c a b ;
-
-[ t ] [ \ c \ tuple class< ] unit-test
-[ f ] [ \ tuple \ c class< ] unit-test
-
! DEFER: bah
! FORGET: bah
UNION: bah fixnum alien ;
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
-! Test generic see and parsing
-[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
-[ [ \ bah see ] with-string-writer ] unit-test
-
! Test redefinition of classes
UNION: union-1 fixnum float ;
[ t ] [ union-1 number class< ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
-[ union-1 ] [ fixnum float class-or ] unit-test
-
"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
[ t ] [ bignum union-1 class< ] unit-test
[ f ] [ union-1 number class< ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
-[ object ] [ fixnum float class-or ] unit-test
-
-"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
+"IN: classes.tests USE: math PREDICATE: union-1 < integer even? ;" eval
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
[ 2 ] [ H{ { 1 2 } { 2 3 } } collection-size ] unit-test
! Test mixing in of new classes after the fact
+DEFER: mx1
+FORGET: mx1
+
MIXIN: mx1
INSTANCE: integer mx1
[ t ] [ array mx1 class< ] unit-test
[ f ] [ mx1 number class< ] unit-test
-[ mx1 ] [ array integer class-or ] unit-test
-
[ \ mx1 forget ] with-compilation-unit
-[ f ] [ array integer class-or mx1 = ] unit-test
-
! Empty unions were causing problems
GENERIC: empty-union-test
[ t ] [ fixnum redefine-bug-2 class< ] unit-test
[ t ] [ quotation redefine-bug-2 class< ] unit-test
-[ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
[ t ] [ bignum redefine-bug-1 class< ] unit-test
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
[ t ] [ bignum redefine-bug-2 class< ] unit-test
-[ f ] [ fixnum quotation class-or redefine-bug-2 eq? ] unit-test
-[ redefine-bug-2 ] [ bignum quotation class-or ] unit-test
-
-! Another issue similar to the above
-UNION: forget-class-bug-1 integer ;
-UNION: forget-class-bug-2 forget-class-bug-1 dll ;
-[
- \ forget-class-bug-1 forget
- \ forget-class-bug-2 forget
-] with-compilation-unit
-
-[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test
-
-[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test
+USE: io.streams.string
2 [
[ "mixin-forget-test" forget-source ] with-compilation-unit
TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2
[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test
+
+! Test generic see and parsing
+[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
+[ [ \ bah see ] with-string-writer ] unit-test
+
+[ t ] [ 3 object instance? ] unit-test
+[ t ] [ 3 fixnum instance? ] unit-test
+[ f ] [ 3 float instance? ] unit-test
+[ t ] [ 3 number instance? ] unit-test
+[ f ] [ 3 null instance? ] unit-test
+[ t ] [ "hi" \ hi-tag instance? ] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: arrays definitions assocs kernel kernel.private
+slots.private namespaces sequences strings words vectors math
+quotations combinators sorting effects graphs vocabs ;
IN: classes
-USING: arrays definitions assocs kernel
-kernel.private slots.private namespaces sequences strings words
-vectors math quotations combinators sorting effects graphs ;
-PREDICATE: word class ( obj -- ? ) "class" word-prop ;
+SYMBOL: class<-cache
+SYMBOL: class-not-cache
+SYMBOL: classes-intersect-cache
+SYMBOL: class-and-cache
+SYMBOL: class-or-cache
+
+: init-caches ( -- )
+ H{ } clone class<-cache set
+ H{ } clone class-not-cache set
+ H{ } clone classes-intersect-cache set
+ H{ } clone class-and-cache set
+ H{ } clone class-or-cache set ;
+
+: reset-caches ( -- )
+ class<-cache get clear-assoc
+ class-not-cache get clear-assoc
+ classes-intersect-cache get clear-assoc
+ class-and-cache get clear-assoc
+ class-or-cache get clear-assoc ;
-SYMBOL: typemap
-SYMBOL: class<map
SYMBOL: update-map
-SYMBOL: builtins
-PREDICATE: word builtin-class
- "metaclass" word-prop builtin-class eq? ;
+PREDICATE: class < word
+ "class" word-prop ;
-PREDICATE: class tuple-class
+PREDICATE: tuple-class < class
"metaclass" word-prop tuple-class eq? ;
-: classes ( -- seq ) class<map get keys ;
-
-: type>class ( n -- class ) builtins get-global nth ;
-
-: bootstrap-type>class ( n -- class ) builtins get nth ;
+: classes ( -- seq ) all-words [ class? ] subset ;
: predicate-word ( word -- predicate )
[ word-name "?" append ] keep word-vocabulary create ;
: predicate-effect 1 { "?" } <effect> ;
-PREDICATE: word predicate "predicating" word-prop >boolean ;
+PREDICATE: predicate < word "predicating" word-prop >boolean ;
: define-predicate ( class quot -- )
>r "predicate" word-prop first
r> predicate-effect define-declared ;
: superclass ( class -- super )
- "superclass" word-prop ;
-
-: members ( class -- seq ) "members" word-prop ;
-
-: class-empty? ( class -- ? ) members dup [ empty? ] when ;
-
-: (flatten-union-class) ( class -- )
- dup members [
- [ (flatten-union-class) ] each
- ] [
- dup set
- ] ?if ;
-
-: flatten-union-class ( class -- assoc )
- [ (flatten-union-class) ] H{ } make-assoc ;
-
-: (flatten-class) ( class -- )
- {
- { [ dup tuple-class? ] [ dup set ] }
- { [ dup builtin-class? ] [ dup set ] }
- { [ dup members ] [ members [ (flatten-class) ] each ] }
- { [ dup superclass ] [ superclass (flatten-class) ] }
- } cond ;
-
-: flatten-class ( class -- assoc )
- [ (flatten-class) ] H{ } make-assoc ;
-
-: class-hashes ( class -- seq )
- flatten-class keys [
- dup builtin-class?
- [ "type" word-prop ] [ hashcode ] if
- ] map ;
-
-: (flatten-builtin-class) ( class -- )
- {
- { [ dup members ] [ members [ (flatten-builtin-class) ] each ] }
- { [ dup superclass ] [ superclass (flatten-builtin-class) ] }
- { [ t ] [ dup set ] }
- } cond ;
-
-: flatten-builtin-class ( class -- assoc )
- [ (flatten-builtin-class) ] H{ } make-assoc ;
-
-: types ( class -- seq )
- flatten-builtin-class keys
- [ "type" word-prop ] map natural-sort ;
-
-: class< ( class1 class2 -- ? ) swap class<map get at key? ;
-
-<PRIVATE
-
-DEFER: (class<)
-
-: superclass< ( cls1 cls2 -- ? )
- >r superclass r> 2dup and [ (class<) ] [ 2drop f ] if ;
-
-: union-class< ( cls1 cls2 -- ? )
- [ flatten-union-class ] 2apply keys
- [ nip [ (class<) ] with contains? ] curry assoc-all? ;
-
-: (class<) ( class1 class2 -- ? )
- {
- { [ 2dup eq? ] [ 2drop t ] }
- { [ over class-empty? ] [ 2drop t ] }
- { [ 2dup superclass< ] [ 2drop t ] }
- { [ 2dup [ members not ] both? ] [ 2drop f ] }
- { [ t ] [ union-class< ] }
- } cond ;
-
-: lookup-union ( classes -- class )
- typemap get at dup empty? [ drop object ] [ first ] if ;
-
-: (class-or) ( class class -- class )
- [ flatten-builtin-class ] 2apply union lookup-union ;
-
-: (class-and) ( class class -- class )
- [ flatten-builtin-class ] 2apply intersect lookup-union ;
-
-: tuple-class-and ( class1 class2 -- class )
- dupd eq? [ drop null ] unless ;
-
-: largest-class ( seq -- n elt )
- dup [
- [ 2dup class< >r swap class< not r> and ]
- with subset empty?
- ] curry find [ "Topological sort failed" throw ] unless* ;
-
-PRIVATE>
-
-: sort-classes ( seq -- newseq )
- >vector
- [ dup empty? not ]
- [ dup largest-class >r over delete-nth r> ]
- [ ] unfold nip ;
-
-: class-or ( class1 class2 -- class )
- {
- { [ 2dup class< ] [ nip ] }
- { [ 2dup swap class< ] [ drop ] }
- { [ t ] [ (class-or) ] }
- } cond ;
+ #! Output f for non-classes to work with algebra code
+ dup class? [ "superclass" word-prop ] [ drop f ] if ;
-: class-and ( class1 class2 -- class )
- {
- { [ 2dup class< ] [ drop ] }
- { [ 2dup swap class< ] [ nip ] }
- { [ 2dup [ tuple-class? ] both? ] [ tuple-class-and ] }
- { [ t ] [ (class-and) ] }
- } cond ;
+: superclasses ( class -- supers )
+ [ superclass ] follow reverse ;
-: classes-intersect? ( class1 class2 -- ? )
- class-and class-empty? not ;
-
-: min-class ( class seq -- class/f )
- [ dupd classes-intersect? ] subset dup empty? [
- 2drop f
- ] [
- tuck [ class< ] with all? [ peek ] [ drop f ] if
- ] if ;
+: members ( class -- seq )
+ #! Output f for non-classes to work with algebra code
+ dup class? [ "members" word-prop ] [ drop f ] if ;
GENERIC: reset-class ( class -- )
<PRIVATE
-! class<map
-: bigger-classes ( class -- seq )
- classes [ (class<) ] with subset ;
-
-: bigger-classes+ ( class -- )
- [ bigger-classes [ dup ] H{ } map>assoc ] keep
- class<map get set-at ;
-
-: bigger-classes- ( class -- )
- class<map get delete-at ;
-
-: smaller-classes ( class -- seq )
- classes swap [ (class<) ] curry subset ;
-
-: smaller-classes+ ( class -- )
- dup smaller-classes class<map get add-vertex ;
-
-: smaller-classes- ( class -- )
- dup smaller-classes class<map get remove-vertex ;
-
-: class<map+ ( class -- )
- H{ } clone over class<map get set-at
- dup smaller-classes+ bigger-classes+ ;
-
-: class<map- ( class -- )
- dup smaller-classes- bigger-classes- ;
-
! update-map
: class-uses ( class -- seq )
- [ dup members % superclass [ , ] when* ] { } make ;
+ [ members ] [ superclass ] bi [ suffix ] when* ;
: class-usages ( class -- assoc )
[ update-map get at ] closure ;
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
-! typemap
-: push-at ( value key assoc -- )
- 2dup at* [
- 2nip push
- ] [
- drop >r >r 1vector r> r> set-at
- ] if ;
-
-: typemap+ ( class -- )
- dup flatten-builtin-class typemap get push-at ;
-
-: pop-at ( value key assoc -- )
- at* [ delete ] [ 2drop ] if ;
-
-: typemap- ( class -- )
- dup flatten-builtin-class typemap get pop-at ;
-
-! Class definition
-: cache-class ( class -- )
- dup typemap+ dup class<map+ update-map+ ;
-
-: cache-classes ( assoc -- )
- [ drop cache-class ] assoc-each ;
-
-GENERIC: uncache-class ( class -- )
-
-M: class uncache-class
- dup update-map- dup class<map- typemap- ;
-
-M: word uncache-class drop ;
-
-: uncache-classes ( assoc -- )
- [ drop uncache-class ] assoc-each ;
-
-PRIVATE>
-
-: define-class-props ( members superclass metaclass -- assoc )
+: make-class-props ( superclass members metaclass -- assoc )
[
- "metaclass" set
- dup [ bootstrap-word ] when "superclass" set
- [ bootstrap-word ] map "members" set
+ [ dup [ bootstrap-word ] when "superclass" set ]
+ [ [ bootstrap-word ] map "members" set ]
+ [ "metaclass" set ]
+ tri*
] H{ } make-assoc ;
: (define-class) ( word props -- )
- over reset-class
- over deferred? [ over define-symbol ] when
- >r dup word-props r> union over set-word-props
- dup predicate-word 2dup 1quotation "predicate" set-word-prop
- over "predicating" set-word-prop
- t "class" set-word-prop ;
+ >r
+ dup reset-class
+ dup deferred? [ dup define-symbol ] when
+ dup word-props
+ r> assoc-union over set-word-props
+ dup predicate-word
+ [ 1quotation "predicate" set-word-prop ]
+ [ swap "predicating" set-word-prop ]
+ [ drop t "class" set-word-prop ]
+ 2tri ;
-GENERIC: update-predicate ( class -- )
+PRIVATE>
-M: class update-predicate drop ;
+GENERIC: update-class ( class -- )
-: update-predicates ( assoc -- )
- [ drop update-predicate ] assoc-each ;
+M: class update-class drop ;
GENERIC: update-methods ( assoc -- )
-: define-class ( word members superclass metaclass -- )
- #! If it was already a class, update methods after.
- define-class-props
- over class? >r
- over class-usages [
- uncache-classes
- dupd (define-class)
- ] keep cache-classes r>
- [ class-usages dup update-predicates update-methods ]
- [ drop ] if ;
-
-GENERIC: class ( object -- class ) inline
-
-M: object class type type>class ;
+: update-classes ( class -- )
+ class-usages
+ [ [ drop update-class ] assoc-each ]
+ [ update-methods ]
+ bi ;
-<PRIVATE
+: define-class ( word superclass members metaclass -- )
+ #! If it was already a class, update methods after.
+ reset-caches
+ make-class-props
+ [ drop update-map- ]
+ [ (define-class) ]
+ [ drop update-map+ ]
+ 2tri ;
-: class-of-tuple ( obj -- class )
- 2 slot { word } declare ; inline
+GENERIC: class ( object -- class )
-PRIVATE>
+: instance? ( obj class -- ? )
+ "predicate" word-prop call ;
USING: help.markup help.syntax help words compiler.units
-classes ;
+classes sequences ;
IN: classes.mixin
ARTICLE: "mixins" "Mixin classes"
-"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, new classes can be made into instances of a mixin class after the original definition of the mixin."
+"An object is an instance of a union class if it is an instance of one of its members. In this respect, mixin classes are identical to union classes. However, mixin classes have the additional property that they are " { $emphasis "open" } "; new classes can be added to the mixin after the original definition of the mixin."
{ $subsection POSTPONE: MIXIN: }
{ $subsection POSTPONE: INSTANCE: }
{ $subsection define-mixin-class }
{ $subsection add-mixin-instance }
"The set of mixin classes is a class:"
{ $subsection mixin-class }
-{ $subsection mixin-class? } ;
+{ $subsection mixin-class? }
+"Mixins are used to defines suites of behavior which are generally useful and can be applied to user-defined classes. For example, the " { $link immutable-sequence } " mixin can be used with user-defined sequences to make them immutable."
+{ $see-also "unions" "tuple-subclassing" } ;
HELP: mixin-class
{ $class-description "The class of mixin classes." } ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.union words kernel sequences
-definitions combinators arrays ;
+definitions combinators arrays accessors ;
IN: classes.mixin
-PREDICATE: union-class mixin-class "mixin" word-prop ;
+PREDICATE: mixin-class < union-class "mixin" word-prop ;
M: mixin-class reset-class
- { "metaclass" "members" "mixin" } reset-props ;
+ { "class" "metaclass" "members" "mixin" } reset-props ;
: redefine-mixin-class ( class members -- )
dupd define-union-class
: check-mixin-class ( mixin -- mixin )
dup mixin-class? [
- \ check-mixin-class construct-boa throw
+ \ check-mixin-class boa throw
] unless ;
: if-mixin-member? ( class mixin true false -- )
swap redefine-mixin-class ; inline
: add-mixin-instance ( class mixin -- )
- [ 2drop ] [ [ add ] change-mixin-class ] if-mixin-member? ;
+ [ 2drop ] [ [ suffix ] change-mixin-class ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
[ [ swap remove ] change-mixin-class ] [ 2drop ] if-mixin-member? ;
M: mixin-instance equal?
{
{ [ over mixin-instance? not ] [ f ] }
- { [ 2dup [ mixin-instance-class ] 2apply = not ] [ f ] }
- { [ 2dup [ mixin-instance-mixin ] 2apply = not ] [ f ] }
- { [ t ] [ t ] }
+ { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
+ { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
+ [ t ]
} cond 2nip ;
M: mixin-instance hashcode*
- { mixin-instance-class mixin-instance-mixin } get-slots
- 2array hashcode* ;
+ [ class>> ] [ mixin>> ] bi 2array hashcode* ;
: <mixin-instance> ( class mixin -- definition )
{ set-mixin-instance-class set-mixin-instance-mixin }
ABOUT: "predicates"
HELP: define-predicate-class
-{ $values { "superclass" class } { "class" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
+{ $values { "class" class } { "superclass" class } { "definition" "a quotation with stack effect " { $snippet "( superclass -- ? )" } } }
{ $description "Defines a predicate class. This is the run time equivalent of " { $link POSTPONE: PREDICATE: } "." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
{ $side-effects "class" } ;
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel namespaces words ;
IN: classes.predicate
-PREDICATE: class predicate-class
+PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
: predicate-quot ( class -- quot )
"predicate-definition" word-prop , [ drop f ] , \ if ,
] [ ] make ;
-: define-predicate-class ( superclass class definition -- )
- >r dup f roll predicate-class define-class r>
- dupd "predicate-definition" set-word-prop
- dup predicate-quot define-predicate ;
+: define-predicate-class ( class superclass definition -- )
+ [ drop f predicate-class define-class ]
+ [ nip "predicate-definition" set-word-prop ]
+ [
+ 2drop
+ [ dup predicate-quot define-predicate ]
+ [ update-classes ]
+ bi
+ ] 3tri ;
M: predicate-class reset-class
{
- "metaclass" "predicate-definition" "superclass"
+ "class"
+ "metaclass"
+ "predicate-definition"
+ "superclass"
} reset-props ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax kernel words ;
+IN: classes.singleton
+
+ARTICLE: "singletons" "Singleton classes"
+"A singleton is a class with only one instance and with no state."
+{ $subsection POSTPONE: SINGLETON: }
+{ $subsection define-singleton-class }
+"The set of all singleton classes is itself a class:"
+{ $subsection singleton-class? }
+{ $subsection singleton-class } ;
+
+HELP: SINGLETON:
+{ $syntax "SINGLETON: class" }
+{ $values
+ { "class" "a new singleton to define" }
+}
+{ $description
+ "Defines a new singleton class. The class word itself is the sole instance of the singleton class."
+}
+{ $examples
+ { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
+} ;
+
+HELP: define-singleton-class
+{ $values { "word" "a new word" } }
+{ $description
+ "Defines a singleton class. This is the run-time equivalent of " { $link POSTPONE: SINGLETON: } "." } ;
+
+{ POSTPONE: SINGLETON: define-singleton-class } related-words
+
+HELP: singleton-class
+{ $class-description "The class of singleton classes." } ;
+
+ABOUT: "singletons"
--- /dev/null
+USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
+IN: classes.singleton.tests
+
+[ ] [ SINGLETON: bzzt ] unit-test
+[ t ] [ bzzt bzzt? ] unit-test
+[ t ] [ bzzt bzzt eq? ] unit-test
+GENERIC: zammo ( obj -- str )
+[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
+[ "yes!" ] [ bzzt zammo ] unit-test
+[ ] [ SINGLETON: omg ] unit-test
+[ t ] [ omg singleton-class? ] unit-test
+[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.predicate kernel sequences words ;
+IN: classes.singleton
+
+PREDICATE: singleton-class < predicate-class
+ [ "predicate-definition" word-prop ]
+ [ [ eq? ] curry ] bi sequence= ;
+
+: define-singleton-class ( word -- )
+ \ word over [ eq? ] curry define-predicate-class ;
--- /dev/null
+Slava Pestov
--- /dev/null
+Object system implementation
--- /dev/null
+USING: generic help.markup help.syntax kernel
+classes.tuple.private classes slots quotations words arrays
+generic.standard sequences definitions compiler.units ;
+IN: classes.tuple
+
+ARTICLE: "parametrized-constructors" "Parameterized constructors"
+"A " { $emphasis "parametrized constructor" } " is a word which directly or indirectly calls " { $link new } " or " { $link boa } ", but instead of passing a literal class symbol, it takes the class symbol as an input from the stack."
+$nl
+"Parametrized constructors are useful in many situations, in particular with subclassing. For example, consider the following code:"
+{ $code
+ "TUPLE: vehicle max-speed occupants ;"
+ ""
+ ": add-occupant ( person vehicle -- ) occupants>> push ;"
+ ""
+ "TUPLE: car < vehicle engine ;"
+ ": <car> ( max-speed engine -- car )"
+ " car new"
+ " V{ } clone >>occupants"
+ " swap >>engine"
+ " swap >>max-speed ;"
+ ""
+ "TUPLE: aeroplane < vehicle max-altitude ;"
+ ": <aeroplane> ( max-speed max-altitude -- aeroplane )"
+ " aeroplane new"
+ " V{ } clone >>occupants"
+ " swap >>max-altitude"
+ " swap >>max-speed ;"
+}
+"The two constructors depend on the implementation of " { $snippet "vehicle" } " because they are responsible for initializing the " { $snippet "occupants" } " slot to an empty vector. If this slot is changed to contain a hashtable instead, there will be two places instead of one. A better approach is to use a parametrized constructor for vehicles:"
+{ $code
+ "TUPLE: vehicle max-speed occupants ;"
+ ""
+ ": add-occupant ( person vehicle -- ) occupants>> push ;"
+ ""
+ ": new-vehicle ( class -- vehicle )"
+ " new"
+ " V{ } clone >>occupants ;"
+ ""
+ "TUPLE: car < vehicle engine ;"
+ ": <car> ( max-speed engine -- car )"
+ " car new-vehicle"
+ " swap >>engine"
+ " swap >>max-speed ;"
+ ""
+ "TUPLE: aeroplane < vehicle max-altitude ;"
+ ": <aeroplane> ( max-speed max-altitude -- aeroplane )"
+ " aeroplane new-vehicle"
+ " swap >>max-altitude"
+ " swap >>max-speed ;"
+}
+"The naming convention for parametrized constructors is " { $snippet "new-" { $emphasis "class" } } "." ;
+
+ARTICLE: "tuple-constructors" "Tuple constructors"
+"Tuples are created by calling one of two constructor primitives:"
+{ $subsection new }
+{ $subsection boa }
+"A shortcut for defining BOA constructors:"
+{ $subsection POSTPONE: C: }
+"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
+$nl
+"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
+$nl
+"Examples of constructors:"
+{ $code
+ "TUPLE: color red green blue alpha ;"
+ ""
+ "! The following two are equivalent"
+ "C: <rgba> rgba"
+ ": <rgba> color boa ;"
+ ""
+ "! We can define constructors which call other constructors"
+ ": <rgb> f <rgba> ;"
+ ""
+ "! The following two are equivalent"
+ ": <color> color new ;"
+ ": <color> f f f f <rgba> ;"
+}
+{ $subsection "parametrized-constructors" } ;
+
+ARTICLE: "tuple-inheritance-example" "Tuple subclassing example"
+"Rectangles, parallelograms and circles are all shapes. We support two operations on shapes:"
+{ $list
+ "Computing the area"
+ "Computing the perimiter"
+}
+"Rectangles and parallelograms use the same algorithm for computing the area, whereas they use different algorithms for computing perimiter. Also, rectangles and parallelograms both have " { $snippet "width" } " and " { $snippet "height" } " slots. We can exploit this with subclassing:"
+{ $code
+ "GENERIC: area ( shape -- n )"
+ "GENERIC: perimiter ( shape -- n )"
+ ""
+ "TUPLE: shape ;"
+ ""
+ "TUPLE: circle < shape radius ;"
+ "M: area circle radius>> sq pi * ;"
+ "M: perimiter circle radius>> 2 * pi * ;"
+ ""
+ "TUPLE: quad < shape width height"
+ "M: area quad [ width>> ] [ height>> ] bi * ;"
+ ""
+ "TUPLE: rectangle < quad ;"
+ "M: rectangle perimiter [ width>> 2 * ] [ height>> 2 * ] bi + ;"
+ ""
+ ": hypot ( a b -- c ) [ sq ] bi@ + sqrt ;"
+ ""
+ "TUPLE: parallelogram < quad skew ;"
+ "M: parallelogram perimiter"
+ " [ width>> 2 * ] [ [ height>> ] [ skew>> ] bi hypot 2 * ] bi + ;"
+} ;
+
+ARTICLE: "tuple-inheritance-anti-example" "When not to use tuple subclassing"
+"Tuple subclassing should only be used for " { $emphasis "is-a" } " relationships; for example, a car " { $emphasis "is a" } " vehicle, and a circle " { $emphasis "is a" } " shape."
+{ $heading "Anti-pattern #1: subclassing for has-a" }
+"Subclassing should not be used for " { $emphasis "has-a" } " relationships. For example, if a shape " { $emphasis "has a" } " color, then " { $snippet "shape" } " should not subclass " { $snippet "color" } ". Using tuple subclassing in inappropriate situations leads to code which is more brittle and less flexible than it should be."
+$nl
+"For example, suppose that " { $snippet "shape" } " inherits from " { $snippet "color" } ":"
+{ $code
+ "TUPLE: color r g b ;"
+ "TUPLE: shape < color ... ;"
+}
+"Now, the implementation of " { $snippet "shape" } " depends on a specific representation of colors as RGB colors. If a new generic color protocol is devised which also allows HSB and YUV colors to be used, the shape class will not be able to take advantage of them without changes. A better approach is to store the color in a slot:"
+{ $code
+ "TUPLE: rgb-color r g b ;"
+ "TUPLE: hsv-color h s v ;"
+ "..."
+ "TUPLE: shape color ... ;"
+}
+"The " { $vocab-link "delegate" } " library provides a language abstraction for expressing has-a relationships."
+{ $heading "Anti-pattern #2: subclassing for implementation sharing only" }
+"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this properly does not hold, then subclassing should not be used."
+$nl
+"There are two alternatives which are preferred to subclassing in this case. The first is " { $link "mixins" } "."
+$nl
+"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
+{ $heading "Anti-pattern #3: subclassing to override a method definition" }
+"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of ``monkey patching'' methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
+{ $see-also "parametrized-constructors" } ;
+
+ARTICLE: "tuple-subclassing" "Tuple subclassing"
+"Tuple subclassing can be used to express natural relationships between classes at the language level. For example, every car " { $emphasis "is a" } " vehicle, so if the " { $snippet "car" } " class subclasses the " { $snippet "vehicle" } " class, it can " { $emphasis "inherit" } " the slots and methods of " { $snippet "vehicle" } "."
+$nl
+"To define one tuple class as a subclass of another, use the optional superclass parameter to " { $link POSTPONE: TUPLE: } ":"
+{ $code
+ "TUPLE: subclass < superclass ... ;"
+}
+{ $subsection "tuple-inheritance-example" }
+{ $subsection "tuple-inheritance-anti-example" }
+{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ;
+
+ARTICLE: "tuple-introspection" "Tuple introspection"
+"In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way."
+{ $subsection >tuple }
+{ $subsection tuple>array }
+{ $subsection tuple-slots }
+"Tuple classes can also be defined at run time:"
+{ $subsection define-tuple-class }
+{ $see-also "slots" "mirrors" } ;
+
+ARTICLE: "tuple-examples" "Tuple examples"
+"An example:"
+{ $code "TUPLE: employee name salary position ;" }
+"This defines a class word named " { $snippet "employee" } ", a predicate " { $snippet "employee?" } ", and the following slot accessors:"
+{ $table
+ { "Reader" "Writer" "Setter" "Changer" }
+ { { $snippet "name>>" } { $snippet "(>>name)" } { $snippet ">>name" } { $snippet "change-name" } }
+ { { $snippet "salary>>" } { $snippet "(>>salary)" } { $snippet ">>salary" } { $snippet "change-salary" } }
+ { { $snippet "position>>" } { $snippet "(>>position)" } { $snippet ">>position" } { $snippet "change-position" } }
+}
+"We can define a constructor which makes an empty employee:"
+{ $code ": <employee> ( -- employee )"
+ " employee new ;" }
+"Or we may wish the default constructor to always give employees a starting salary:"
+{ $code
+ ": <employee> ( -- employee )"
+ " employee new"
+ " 40000 >>salary ;"
+}
+"We can define more refined constructors:"
+{ $code
+ ": <manager> ( -- manager )"
+ " <employee> \"project manager\" >>position ;" }
+"An alternative strategy is to define the most general BOA constructor first:"
+{ $code
+ ": <employee> ( name position -- person )"
+ " 40000 employee boa ;"
+}
+"Now we can define more specific constructors:"
+{ $code
+ ": <manager> ( name -- person )"
+ " \"manager\" <person> ;" }
+"An example using reader words:"
+{ $code
+ "TUPLE: check to amount number ;"
+ ""
+ "SYMBOL: checks"
+ ""
+ ": <check> ( to amount -- check )"
+ " checks counter check boa ;"
+ ""
+ ": biweekly-paycheck ( employee -- check )"
+ " dup name>> swap salary>> 26 / <check> ;"
+}
+"An example of using a changer:"
+{ $code
+ ": positions"
+ " {"
+ " \"junior programmer\""
+ " \"senior programmer\""
+ " \"project manager\""
+ " \"department manager\""
+ " \"executive\""
+ " \"CTO\""
+ " \"CEO\""
+ " \"enterprise Java world dictator\""
+ " } ;"
+ ""
+ ": next-position ( role -- newrole )"
+ " positions [ index 1+ ] keep nth ;"
+ ""
+ ": promote ( person -- person )"
+ " [ 1.2 * ] change-salary"
+ " [ next-position ] change-position ;"
+}
+"An example using subclassing can be found in " { $link "tuple-inheritance-example" } "." ;
+
+ARTICLE: "tuple-redefinition" "Tuple redefinition"
+"In the following, the " { $emphasis "direct slots" } " of a tuple class refers to the slot names specified in the " { $link POSTPONE: TUPLE: } " form defining the tuple class, and the " { $emphasis "effective slots" } " refers to the concatenation of the direct slots together with slots defined on superclasses."
+$nl
+"When a tuple class is redefined, all instances of the class, including subclasses, are updated. For each instance, the list of effective slots is compared with the previous list. If any slots were removed, the values are removed from the instance and are lost forever. If any slots were added, the instance gains these slots with an initial value of " { $link f } "."
+$nl
+"There are three ways to change the list of effective slots of a class:"
+{ $list
+ "Adding or removing direct slots of the class"
+ "Adding or removing direct slots of a superclass of the class"
+ "Changing the inheritance hierarchy by redefining a class to have a different superclass"
+}
+"In all cases, the new effective slots are compared with the old effective slots, and each instance is updated as follows:"
+{ $list
+ "If any slots were removed, the values are removed from the instance and are lost forever."
+ { "If any slots were added, the instance gains these slots with an initial value of " { $link f } "." }
+ "If any slots are permuted, their values in instances do not change; only the layout of the instance changes in memory."
+ "If the number or order of effective slots changes, any BOA constructors are recompiled."
+}
+"Note that if a slot is moved from a class to its superclass (or vice versa) in the same compilation unit, the value of the slot is preserved in existing instances, because tuple instance update always runs at the end of a compilation unit. However, if it is removed in one compilation unit and added in another, the value in existing instances is lost." ;
+
+ARTICLE: "tuples" "Tuples"
+"Tuples are user-defined classes composed of named slots."
+{ $subsection "tuple-examples" }
+"A parsing word defines tuple classes:"
+{ $subsection POSTPONE: TUPLE: }
+"For each tuple class, several words are defined. First, there is the class word, a class predicate, and accessor words for each slot."
+$nl
+"The class word is used for defining methods on the tuple class; it has the same name as the tuple class. The predicate is named " { $snippet { $emphasis "name" } "?" } ". Tuple slots are accessed via accessor words:"
+{ $subsection "accessors" }
+"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
+{ $subsection "tuple-constructors" }
+"Expressing relationships through the object system:"
+{ $subsection "tuple-subclassing" }
+"Introspection:"
+{ $subsection "tuple-introspection" }
+"Tuple classes can be redefined; this updates existing instances:"
+{ $subsection "tuple-redefinition" }
+"Tuple literal syntax is documented in " { $link "syntax-tuples" } "." ;
+
+ABOUT: "tuples"
+
+HELP: tuple=
+{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
+{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
+{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
+
+HELP: tuple
+{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
+$nl
+"Tuple classes have additional word properties:"
+{ $list
+ { { $snippet "\"constructor\"" } " - a word for creating instances of this tuple class" }
+ { { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
+ { { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
+ { { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" }
+ { { $snippet "\"tuple-size\"" } " - the number of slots" }
+} } ;
+
+HELP: define-tuple-predicate
+{ $values { "class" tuple-class } }
+{ $description "Defines a predicate word that tests if the top of the stack is an instance of " { $snippet "class" } ". This will only work if " { $snippet "class" } " is a tuple class." }
+$low-level-note ;
+
+HELP: redefine-tuple-class
+{ $values { "class" class } { "superclass" class } { "slots" "a sequence of strings" } }
+{ $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed."
+$nl
+"If the class is not a tuple class word, this word does nothing." }
+$low-level-note ;
+
+HELP: tuple-slots
+{ $values { "tuple" tuple } { "seq" sequence } }
+{ $description "Pushes a sequence of tuple slot values, not including the tuple class word." } ;
+
+{ tuple-slots tuple>array } related-words
+
+HELP: define-tuple-slots
+{ $values { "class" tuple-class } }
+{ $description "Defines slot accessor and mutator words for the tuple." }
+$low-level-note ;
+
+HELP: check-tuple
+{ $values { "class" class } }
+{ $description "Throws a " { $link check-tuple } " error if " { $snippet "word" } " is not a tuple class word." }
+{ $error-description "Thrown if " { $link POSTPONE: C: } " is called with a word which does not name a tuple class." } ;
+
+HELP: define-tuple-class
+{ $values { "class" word } { "superclass" class } { "slots" "a sequence of strings" } }
+{ $description "Defines a tuple class inheriting from " { $snippet "superclass" } " with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
+{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
+{ $side-effects "class" } ;
+
+{ tuple-class define-tuple-class POSTPONE: TUPLE: } related-words
+
+HELP: >tuple
+{ $values { "seq" sequence } { "tuple" tuple } }
+{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word and the remainder the declared slots."
+$nl
+"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
+{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
+
+HELP: tuple>array ( tuple -- array )
+{ $values { "tuple" tuple } { "array" array } }
+{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and remainder are declared slots." } ;
+
+HELP: <tuple> ( layout -- tuple )
+{ $values { "layout" tuple-layout } { "tuple" tuple } }
+{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link new } "." } ;
+
+HELP: <tuple-boa> ( ... layout -- tuple )
+{ $values { "..." "values" } { "layout" tuple-layout } { "tuple" tuple } }
+{ $description "Low-level tuple constructor. User code should never call this directly, and instead use " { $link boa } "." } ;
+
+HELP: new
+{ $values { "class" tuple-class } { "tuple" tuple } }
+{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
+{ $examples
+ { $example
+ "USING: kernel prettyprint ;"
+ "TUPLE: employee number name department ;"
+ "employee new ."
+ "T{ employee f f f f }"
+ }
+} ;
+
+HELP: construct
+{ $values { "..." "slot values" } { "slots" "a sequence of setter words" } { "class" tuple-class } { "tuple" tuple } }
+{ $description "Creates a new instance of " { $snippet "class" } ", storing consecutive stack values into the slots of the new tuple using setter words in " { $snippet "slots" } ". The top-most stack element is stored in the right-most slot." }
+{ $examples
+ "We can define a class:"
+ { $code "TUPLE: color red green blue alpha ;" }
+ "Together with two constructors:"
+ { $code
+ ": <rgb> ( r g b -- color )"
+ " { set-color-red set-color-green set-color-blue }"
+ " color construct ;"
+ ""
+ ": <rgba> ( r g b a -- color )"
+ " { set-color-red set-color-green set-color-blue set-color-alpha }"
+ " color construct ;"
+ }
+ "The last definition is actually equivalent to the following:"
+ { $code ": <rgba> ( r g b a -- color ) rgba boa ;" }
+ "Which can be abbreviated further:"
+ { $code "C: <rgba> color" }
+} ;
+
+HELP: boa
+{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
+{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
+{ $notes "The name " { $snippet "boa" } " is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
--- /dev/null
+USING: definitions generic kernel kernel.private math
+math.constants parser sequences tools.test words assocs
+namespaces quotations sequences.private classes continuations
+generic.standard effects classes.tuple classes.tuple.private
+arrays vectors strings compiler.units accessors classes.algebra
+calendar prettyprint io.streams.string splitting inspector
+columns ;
+IN: classes.tuple.tests
+
+TUPLE: rect x y w h ;
+: <rect> rect boa ;
+
+: move ( x rect -- rect )
+ [ + ] change-x ;
+
+[ f ] [ 10 20 30 40 <rect> dup clone 5 swap move = ] unit-test
+
+[ t ] [ 10 20 30 40 <rect> dup clone 0 swap move = ] unit-test
+
+! Make sure we handle tuple class redefinition
+TUPLE: redefinition-test ;
+
+C: <redefinition-test> redefinition-test
+
+<redefinition-test> "redefinition-test" set
+
+[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
+
+"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval
+
+[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
+
+! Make sure we handle changing shapes!
+TUPLE: point x y ;
+
+C: <point> point
+
+[ ] [ 100 200 <point> "p" set ] unit-test
+
+! Use eval to sequence parsing explicitly
+[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval ] unit-test
+
+[ 100 ] [ "p" get x>> ] unit-test
+[ 200 ] [ "p" get y>> ] unit-test
+[ f ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
+
+[ ] [ "p" get 300 ">>z" "accessors" lookup execute drop ] unit-test
+
+[ 4 ] [ "p" get tuple-size ] unit-test
+
+[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
+
+[ 3 ] [ "p" get tuple-size ] unit-test
+
+[ "p" get x>> ] must-fail
+[ 200 ] [ "p" get y>> ] unit-test
+[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
+
+TUPLE: predicate-test ;
+
+C: <predicate-test> predicate-test
+
+: predicate-test drop f ;
+
+[ t ] [ <predicate-test> predicate-test? ] unit-test
+
+PREDICATE: silly-pred < tuple
+ class \ rect = ;
+
+GENERIC: area
+M: silly-pred area dup w>> swap h>> * ;
+
+TUPLE: circle radius ;
+M: circle area radius>> sq pi * ;
+
+[ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
+
+! Hashcode breakage
+TUPLE: empty ;
+
+C: <empty> empty
+
+[ t ] [ <empty> hashcode fixnum? ] unit-test
+
+! Compiler regression
+[ t length ] [ object>> t eq? ] must-fail-with
+
+[ "<constructor-test>" ]
+[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
+
+TUPLE: size-test a b c d ;
+
+[ t ] [
+ T{ size-test } tuple-size
+ size-test tuple-size =
+] unit-test
+
+GENERIC: <yo-momma>
+
+TUPLE: yo-momma ;
+
+"IN: classes.tuple.tests C: <yo-momma> yo-momma" eval
+
+[ f ] [ \ <yo-momma> generic? ] unit-test
+
+! Test forget
+[
+ [ t ] [ \ yo-momma class? ] unit-test
+ [ ] [ \ yo-momma forget ] unit-test
+ [ f ] [ \ yo-momma update-map get values memq? ] unit-test
+
+ [ f ] [ \ yo-momma crossref get at ] unit-test
+] with-compilation-unit
+
+TUPLE: loc-recording ;
+
+[ f ] [ \ loc-recording where not ] unit-test
+
+! 'forget' wasn't robust enough
+
+TUPLE: forget-robustness ;
+
+GENERIC: forget-robustness-generic
+
+M: forget-robustness forget-robustness-generic ;
+
+M: integer forget-robustness-generic ;
+
+[
+ [ ] [ \ forget-robustness-generic forget ] unit-test
+ [ ] [ \ forget-robustness forget ] unit-test
+ [ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test
+] with-compilation-unit
+
+! rapido found this one
+GENERIC# m1 0 ( s n -- n )
+GENERIC# m2 1 ( s n -- v )
+
+TUPLE: t1 ;
+
+M: t1 m1 drop ;
+M: t1 m2 nip ;
+
+TUPLE: t2 ;
+
+M: t2 m1 drop ;
+M: t2 m2 nip ;
+
+TUPLE: t3 ;
+
+M: t3 m1 drop ;
+M: t3 m2 nip ;
+
+TUPLE: t4 ;
+
+M: t4 m1 drop ;
+M: t4 m2 nip ;
+
+C: <t4> t4
+
+[ 1 ] [ 1 <t4> m1 ] unit-test
+[ 1 ] [ <t4> 1 m2 ] unit-test
+
+! another combination issue
+GENERIC: silly
+
+UNION: my-union slice repetition column array vector reversed ;
+
+M: my-union silly "x" ;
+
+M: array silly "y" ;
+
+M: column silly "fdsfds" ;
+
+M: repetition silly "zzz" ;
+
+M: reversed silly "zz" ;
+
+M: slice silly "tt" ;
+
+M: string silly "t" ;
+
+M: vector silly "z" ;
+
+[ "zz" ] [ 123 <reversed> silly nip ] unit-test
+
+! Typo
+SYMBOL: not-a-tuple-class
+
+[
+ "IN: classes.tuple.tests C: <not-a-tuple-class> not-a-tuple-class"
+ eval
+] must-fail
+
+[ t ] [
+ "not-a-tuple-class" "classes.tuple.tests" lookup symbol?
+] unit-test
+
+! Missing check
+[ not-a-tuple-class boa ] must-fail
+[ not-a-tuple-class new ] must-fail
+
+TUPLE: erg's-reshape-problem a b c d ;
+
+C: <erg's-reshape-problem> erg's-reshape-problem
+
+! We want to make sure constructors are recompiled when
+! tuples are reshaped
+: cons-test-1 \ erg's-reshape-problem new ;
+: cons-test-2 \ erg's-reshape-problem boa ;
+
+"IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
+
+[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
+
+[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
+
+[
+ "IN: classes.tuple.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
+] [ error>> no-tuple-class? ] must-fail-with
+
+! Inheritance
+TUPLE: computer cpu ram ;
+C: <computer> computer
+
+[ "TUPLE: computer cpu ram ;" ] [
+ [ \ computer see ] with-string-writer string-lines second
+] unit-test
+
+TUPLE: laptop < computer battery ;
+C: <laptop> laptop
+
+[ t ] [ laptop tuple-class? ] unit-test
+[ t ] [ laptop tuple class< ] unit-test
+[ t ] [ laptop computer class< ] unit-test
+[ t ] [ laptop computer classes-intersect? ] unit-test
+
+[ ] [ "Pentium" 128 3 hours <laptop> "laptop" set ] unit-test
+[ t ] [ "laptop" get laptop? ] unit-test
+[ t ] [ "laptop" get computer? ] unit-test
+[ t ] [ "laptop" get tuple? ] unit-test
+
+: test-laptop-slot-values
+ [ laptop ] [ "laptop" get class ] unit-test
+ [ "Pentium" ] [ "laptop" get cpu>> ] unit-test
+ [ 128 ] [ "laptop" get ram>> ] unit-test
+ [ t ] [ "laptop" get battery>> 3 hours = ] unit-test ;
+
+test-laptop-slot-values
+
+[ laptop ] [
+ "laptop" get tuple-layout
+ dup layout-echelon swap
+ layout-superclasses nth
+] unit-test
+
+[ "TUPLE: laptop < computer battery ;" ] [
+ [ \ laptop see ] with-string-writer string-lines second
+] unit-test
+
+[ { tuple computer laptop } ] [ laptop superclasses ] unit-test
+
+TUPLE: server < computer rackmount ;
+C: <server> server
+
+[ t ] [ server tuple-class? ] unit-test
+[ t ] [ server tuple class< ] unit-test
+[ t ] [ server computer class< ] unit-test
+[ t ] [ server computer classes-intersect? ] unit-test
+
+[ ] [ "PowerPC" 64 "1U" <server> "server" set ] unit-test
+[ t ] [ "server" get server? ] unit-test
+[ t ] [ "server" get computer? ] unit-test
+[ t ] [ "server" get tuple? ] unit-test
+
+: test-server-slot-values
+ [ server ] [ "server" get class ] unit-test
+ [ "PowerPC" ] [ "server" get cpu>> ] unit-test
+ [ 64 ] [ "server" get ram>> ] unit-test
+ [ "1U" ] [ "server" get rackmount>> ] unit-test ;
+
+test-server-slot-values
+
+[ f ] [ "server" get laptop? ] unit-test
+[ f ] [ "laptop" get server? ] unit-test
+
+[ f ] [ server laptop class< ] unit-test
+[ f ] [ laptop server class< ] unit-test
+[ f ] [ laptop server classes-intersect? ] unit-test
+
+[ f ] [ 1 2 <computer> laptop? ] unit-test
+[ f ] [ \ + server? ] unit-test
+
+[ "TUPLE: server < computer rackmount ;" ] [
+ [ \ server see ] with-string-writer string-lines second
+] unit-test
+
+[
+ "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
+] must-fail
+
+! Dynamically changing inheritance hierarchy
+TUPLE: electronic-device ;
+
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
+
+[ f ] [ electronic-device laptop class< ] unit-test
+[ t ] [ server electronic-device class< ] unit-test
+[ t ] [ laptop server class-or electronic-device class< ] unit-test
+
+[ t ] [ "laptop" get electronic-device? ] unit-test
+[ t ] [ "laptop" get computer? ] unit-test
+[ t ] [ "laptop" get laptop? ] unit-test
+[ f ] [ "laptop" get server? ] unit-test
+
+[ t ] [ "server" get electronic-device? ] unit-test
+[ t ] [ "server" get computer? ] unit-test
+[ f ] [ "server" get laptop? ] unit-test
+[ t ] [ "server" get server? ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test
+
+[ f ] [ "laptop" get electronic-device? ] unit-test
+[ t ] [ "laptop" get computer? ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+TUPLE: make-me-some-accessors voltage grounded? ;
+
+[ f ] [ "laptop" get voltage>> ] unit-test
+[ f ] [ "server" get voltage>> ] unit-test
+
+[ ] [ "laptop" get 220 >>voltage drop ] unit-test
+[ ] [ "server" get 110 >>voltage drop ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+! Reshaping superclass and subclass simultaneously
+"IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval
+
+test-laptop-slot-values
+test-server-slot-values
+
+[ 220 ] [ "laptop" get voltage>> ] unit-test
+[ 110 ] [ "server" get voltage>> ] unit-test
+
+! Reshape crash
+TUPLE: test1 a ; TUPLE: test2 < test1 b ;
+
+C: <test2> test2
+
+"a" "b" <test2> "test" set
+
+: test-a/b
+ [ "a" ] [ "test" get a>> ] unit-test
+ [ "b" ] [ "test" get b>> ] unit-test ;
+
+test-a/b
+
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test
+
+test-a/b
+
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test
+
+test-a/b
+
+! Twice in the same compilation unit
+[
+ test1 tuple { "a" "x" "y" } define-tuple-class
+ test1 tuple { "a" "y" } define-tuple-class
+] with-compilation-unit
+
+test-a/b
+
+! Moving slots up and down
+TUPLE: move-up-1 a b ;
+TUPLE: move-up-2 < move-up-1 c ;
+
+T{ move-up-2 f "a" "b" "c" } "move-up" set
+
+: test-move-up
+ [ "a" ] [ "move-up" get a>> ] unit-test
+ [ "b" ] [ "move-up" get b>> ] unit-test
+ [ "c" ] [ "move-up" get c>> ] unit-test ;
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test
+
+test-move-up
+
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test
+
+! Constructors must be recompiled when changing superclass
+TUPLE: constructor-update-1 xxx ;
+
+TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
+
+C: <constructor-update-2> constructor-update-2
+
+{ 3 1 } [ <constructor-update-2> ] must-infer-as
+
+[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test
+
+{ 5 1 } [ <constructor-update-2> ] must-infer-as
+
+[ { f 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
+
+! Redefinition problem
+TUPLE: redefinition-problem ;
+
+UNION: redefinition-problem' redefinition-problem integer ;
+
+[ t ] [ 3 redefinition-problem'? ] unit-test
+
+TUPLE: redefinition-problem-2 ;
+
+"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval
+
+[ t ] [ 3 redefinition-problem'? ] unit-test
+
+! Hardcore unit tests
+USE: threads
+
+\ thread slot-names "slot-names" set
+
+[ ] [
+ [
+ \ thread tuple { "xxx" } "slot-names" get append
+ define-tuple-class
+ ] with-compilation-unit
+
+ [ 1337 sleep ] "Test" spawn drop
+
+ [
+ \ thread tuple "slot-names" get
+ define-tuple-class
+ ] with-compilation-unit
+] unit-test
+
+USE: vocabs
+
+\ vocab slot-names "slot-names" set
+
+[ ] [
+ [
+ \ vocab tuple { "xxx" } "slot-names" get append
+ define-tuple-class
+ ] with-compilation-unit
+
+ all-words drop
+
+ [
+ \ vocab tuple "slot-names" get
+ define-tuple-class
+ ] with-compilation-unit
+] unit-test
+
+[ "USE: words T{ word }" eval ] [ error>> no-method? ] must-fail-with
+
+! Accessors not being forgotten...
+[ [ ] ] [
+ "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;"
+ <string-reader>
+ "forget-accessors-test" parse-stream
+] unit-test
+
+[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
+
+: accessor-exists? ( class name -- ? )
+ >r "forget-accessors-test" "classes.tuple.tests" lookup r>
+ ">>" append "accessors" lookup method >boolean ;
+
+[ t ] [ "x" accessor-exists? ] unit-test
+[ t ] [ "y" accessor-exists? ] unit-test
+[ t ] [ "z" accessor-exists? ] unit-test
+
+[ [ ] ] [
+ "IN: classes.tuple.tests GENERIC: forget-accessors-test"
+ <string-reader>
+ "forget-accessors-test" parse-stream
+] unit-test
+
+[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
+
+[ f ] [ "x" accessor-exists? ] unit-test
+[ f ] [ "y" accessor-exists? ] unit-test
+[ f ] [ "z" accessor-exists? ] unit-test
+
+TUPLE: another-forget-accessors-test ;
+
+
+[ [ ] ] [
+ "IN: classes.tuple.tests GENERIC: another-forget-accessors-test"
+ <string-reader>
+ "another-forget-accessors-test" parse-stream
+] unit-test
+
+[ t ] [ \ another-forget-accessors-test class? ] unit-test
+
+! Shadowing test
+[ f ] [
+ t parser-notes? [
+ [
+ "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
+ ] with-string-writer empty?
+ ] with-variable
+] unit-test
+
+! Missing error check
+[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays definitions hashtables kernel
+kernel.private math namespaces sequences sequences.private
+strings vectors words quotations memory combinators generic
+classes classes.private slots.deprecated slots.private slots
+compiler.units math.private accessors assocs ;
+IN: classes.tuple
+
+M: tuple class 1 slot 2 slot { word } declare ;
+
+ERROR: no-tuple-class class ;
+
+<PRIVATE
+
+GENERIC: tuple-layout ( object -- layout )
+
+M: tuple-class tuple-layout "layout" word-prop ;
+
+M: tuple tuple-layout 1 slot ;
+
+M: tuple-layout tuple-layout ;
+
+: tuple-size tuple-layout layout-size ; inline
+
+: prepare-tuple>array ( tuple -- n tuple layout )
+ [ tuple-size ] [ ] [ tuple-layout ] tri ;
+
+: copy-tuple-slots ( n tuple -- array )
+ [ array-nth ] curry map ;
+
+PRIVATE>
+
+: check-tuple ( class -- )
+ dup tuple-class?
+ [ drop ] [ no-tuple-class ] if ;
+
+: tuple>array ( tuple -- array )
+ prepare-tuple>array
+ >r copy-tuple-slots r>
+ layout-class prefix ;
+
+: tuple-slots ( tuple -- seq )
+ prepare-tuple>array drop copy-tuple-slots ;
+
+: slots>tuple ( tuple class -- array )
+ tuple-layout <tuple> [
+ [ tuple-size ] [ [ set-array-nth ] curry ] bi 2each
+ ] keep ;
+
+: >tuple ( tuple -- seq )
+ unclip slots>tuple ;
+
+: slot-names ( class -- seq )
+ "slot-names" word-prop
+ [ dup array? [ second ] when ] map ;
+
+: all-slot-names ( class -- slots )
+ superclasses [ slot-names ] map concat \ class prefix ;
+
+ERROR: bad-superclass class ;
+
+<PRIVATE
+
+: tuple= ( tuple1 tuple2 -- ? )
+ 2dup [ tuple-layout ] bi@ eq? [
+ [ drop tuple-size ]
+ [ [ [ drop array-nth ] [ nip array-nth ] 3bi = ] 2curry ]
+ 2bi all-integers?
+ ] [
+ 2drop f
+ ] if ;
+
+! Predicate generation. We optimize at the expense of simplicity
+
+: (tuple-predicate-quot) ( class -- quot )
+ #! 4 slot == layout-superclasses
+ #! 5 slot == layout-echelon
+ [
+ [ 1 slot dup 5 slot ] %
+ dup tuple-layout layout-echelon ,
+ [ fixnum>= ] %
+ [
+ dup tuple-layout layout-echelon ,
+ [ swap 4 slot array-nth ] %
+ literalize ,
+ [ eq? ] %
+ ] [ ] make ,
+ [ drop f ] ,
+ \ if ,
+ ] [ ] make ;
+
+: tuple-predicate-quot ( class -- quot )
+ [
+ [ dup tuple? ] %
+ (tuple-predicate-quot) ,
+ [ drop f ] ,
+ \ if ,
+ ] [ ] make ;
+
+: define-tuple-predicate ( class -- )
+ dup tuple-predicate-quot define-predicate ;
+
+: superclass-size ( class -- n )
+ superclasses 1 head-slice*
+ [ slot-names length ] map sum ;
+
+: generate-tuple-slots ( class slots -- slot-specs )
+ over superclass-size 2 + simple-slots ;
+
+: define-tuple-slots ( class -- )
+ dup dup "slot-names" word-prop generate-tuple-slots
+ [ "slots" set-word-prop ]
+ [ define-accessors ] ! new
+ [ define-slots ] ! old
+ 2tri ;
+
+: make-tuple-layout ( class -- layout )
+ [ ]
+ [ [ superclass-size ] [ slot-names length ] bi + ]
+ [ superclasses dup length 1- ] tri
+ <tuple-layout> ;
+
+: define-tuple-layout ( class -- )
+ dup make-tuple-layout "layout" set-word-prop ;
+
+: compute-slot-permutation ( class old-slot-names -- permutation )
+ >r all-slot-names r> [ index ] curry map ;
+
+: apply-slot-permutation ( old-values permutation -- new-values )
+ [ [ swap ?nth ] [ drop f ] if* ] with map ;
+
+: permute-slots ( old-values -- new-values )
+ dup first dup outdated-tuples get at
+ compute-slot-permutation
+ apply-slot-permutation ;
+
+: change-tuple ( tuple quot -- newtuple )
+ >r tuple>array r> call >tuple ; inline
+
+: update-tuple ( tuple -- newtuple )
+ [ permute-slots ] change-tuple ;
+
+: update-tuples ( -- )
+ outdated-tuples get
+ dup assoc-empty? [ drop ] [
+ [ >r class r> key? ] curry instances
+ dup [ update-tuple ] map become
+ ] if ;
+
+[ update-tuples ] update-tuples-hook set-global
+
+: update-tuples-after ( class -- )
+ outdated-tuples get [ all-slot-names ] cache drop ;
+
+M: tuple-class update-class
+ [ define-tuple-layout ]
+ [ define-tuple-slots ]
+ [ define-tuple-predicate ]
+ tri ;
+
+: define-new-tuple-class ( class superclass slots -- )
+ [ drop f tuple-class define-class ]
+ [ nip "slot-names" set-word-prop ]
+ [ 2drop update-classes ]
+ 3tri ;
+
+: subclasses ( class -- classes )
+ class-usages keys [ tuple-class? ] subset ;
+
+: each-subclass ( class quot -- )
+ >r subclasses r> each ; inline
+
+: redefine-tuple-class ( class superclass slots -- )
+ [
+ 2drop
+ [
+ [ update-tuples-after ]
+ [ changed-definition ]
+ [ redefined ]
+ tri
+ ] each-subclass
+ ]
+ [ define-new-tuple-class ]
+ 3bi ;
+
+: tuple-class-unchanged? ( class superclass slots -- ? )
+ rot tuck [ superclass = ] [ slot-names = ] 2bi* and ;
+
+: valid-superclass? ( class -- ? )
+ [ tuple-class? ] [ tuple eq? ] bi or ;
+
+: check-superclass ( superclass -- )
+ dup valid-superclass? [ bad-superclass ] unless drop ;
+
+PRIVATE>
+
+GENERIC# define-tuple-class 2 ( class superclass slots -- )
+
+M: word define-tuple-class
+ over check-superclass
+ define-new-tuple-class ;
+
+M: tuple-class define-tuple-class
+ 3dup tuple-class-unchanged?
+ [ over check-superclass 3dup redefine-tuple-class ] unless
+ 3drop ;
+
+: define-error-class ( class superclass slots -- )
+ [ define-tuple-class ] [ 2drop ] 3bi
+ dup [ boa throw ] curry define ;
+
+M: tuple-class reset-class
+ [
+ dup "slot-names" word-prop [
+ [ reader-word method forget ]
+ [ writer-word method forget ] 2bi
+ ] with each
+ ] [
+ {
+ "class"
+ "metaclass"
+ "superclass"
+ "layout"
+ "slots"
+ } reset-props
+ ] bi ;
+
+M: tuple clone
+ (clone) dup delegate clone over set-delegate ;
+
+M: tuple equal?
+ over tuple? [ tuple= ] [ 2drop f ] if ;
+
+M: tuple hashcode*
+ [
+ [ class hashcode ] [ tuple-size ] [ ] tri
+ >r rot r> [
+ swapd array-nth hashcode* sequence-hashcode-step
+ ] 2curry each
+ ] recursive-hashcode ;
+
+! Deprecated
+M: object get-slots ( obj slots -- ... )
+ [ execute ] with each ;
+
+M: object set-slots ( ... obj slots -- )
+ <reversed> get-slots ;
+
+: delegates ( obj -- seq ) [ delegate ] follow ;
+
+: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
{ $subsection members }
"The set of union classes is a class:"
{ $subsection union-class }
-{ $subsection union-class? } ;
+{ $subsection union-class? }
+"Unions are used to define behavior shared between a fixed set of classes."
+{ $see-also "mixins" "tuple-subclassing" } ;
ABOUT: "unions"
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-generic.standard namespaces arrays math quotations ;
+namespaces arrays math quotations ;
IN: classes.union
-PREDICATE: class union-class
+PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes.
-: small-union-predicate-quot ( members -- quot )
+: union-predicate-quot ( members -- quot )
dup empty? [
drop [ drop f ]
] [
- unclip first "predicate" word-prop swap
- [ >r "predicate" word-prop [ dup ] swap append r> ]
- assoc-map alist>quot
- ] if ;
-
-: big-union-predicate-quot ( members -- quot )
- [ small-union-predicate-quot ] [ dup ]
- class-hash-dispatch-quot ;
-
-: union-predicate-quot ( members -- quot )
- [ [ drop t ] ] { } map>assoc
- dup length 4 <= [
- small-union-predicate-quot
- ] [
- flatten-methods
- big-union-predicate-quot
+ unclip "predicate" word-prop swap [
+ "predicate" word-prop [ dup ] prepend
+ [ drop t ]
+ ] { } map>assoc alist>quot
] if ;
: define-union-predicate ( class -- )
dup members union-predicate-quot define-predicate ;
-M: union-class update-predicate define-union-predicate ;
+M: union-class update-class define-union-predicate ;
: define-union-class ( class members -- )
- dupd f union-class define-class define-union-predicate ;
+ [ f swap union-class define-class ]
+ [ drop update-classes ]
+ 2bi ;
M: union-class reset-class
- { "metaclass" "members" } reset-props ;
+ { "class" "metaclass" "members" } reset-props ;
{ $subsection alist>quot } ;
ARTICLE: "combinators" "Additional combinators"
-"The " { $vocab-link "combinators" } " vocabulary is usually used because it provides two combinators which abstract out nested chains of " { $link if } ":"
+"The " { $vocab-link "combinators" } " vocabulary provides generalizations of certain combinators from the " { $vocab-link "kernel" } " vocabulary."
+$nl
+"Generalization of " { $link bi } " and " { $link tri } ":"
+{ $subsection cleave }
+"Generalization of " { $link bi* } " and " { $link tri* } ":"
+{ $subsection spread }
+"Two combinators which abstract out nested chains of " { $link if } ":"
{ $subsection cond }
{ $subsection case }
+"The " { $vocab-link "combinators" } " also provides some less frequently-used features."
+$nl
"A combinator which can help with implementing methods on " { $link hashcode* } ":"
{ $subsection recursive-hashcode }
"An oddball combinator:"
{ $subsection with-datastack }
{ $subsection "combinators-quot" }
-{ $see-also "quotations" "basic-combinators" } ;
+{ $see-also "quotations" "dataflow" } ;
ABOUT: "combinators"
+HELP: cleave
+{ $values { "x" object } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } }
+{ $description "Applies each quotation to the object in turn." }
+{ $examples
+ "The " { $link bi } " combinator takes one value and two quotations; the " { $link tri } " combinator takes one value and three quotations. The " { $link cleave } " combinator takes one value and any number of quotations, and is essentially equivalent to a chain of " { $link keep } " forms:"
+ { $code
+ "! Equivalent"
+ "{ [ p ] [ q ] [ r ] [ s ] } cleave"
+ "[ p ] keep [ q ] keep [ r ] keep s"
+ }
+} ;
+
+{ bi tri cleave } related-words
+
+HELP: spread
+{ $values { "objs..." "objects" } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } }
+{ $description "Applies each quotation to the object in turn." }
+{ $examples
+ "The " { $link bi* } " combinator takes two values and two quotations; the " { $link tri* } " combinator takes three values and three quotations. The " { $link spread } " combinator takes " { $snippet "n" } " values and " { $snippet "n" } " quotations, where " { $snippet "n" } " is the length of the input sequence, and is essentially equivalent to series of retain stack manipulations:"
+ { $code
+ "! Equivalent"
+ "{ [ p ] [ q ] [ r ] [ s ] } spread"
+ ">r >r >r p r> q r> r r> s"
+ }
+} ;
+
+{ bi* tri* spread } related-words
+
HELP: alist>quot
{ $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } }
{ $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." }
{ $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ;
HELP: cond
-{ $values { "assoc" "a sequence of quotation pairs" } }
+{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } }
{ $description
- "Calls the second quotation in the first pair whose first quotation yields a true value."
+ "Calls the second quotation in the first pair whose first quotation yields a true value. A single quotation will always yield a true value."
$nl
"The following two phrases are equivalent:"
{ $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" }
"{"
" { [ dup 0 > ] [ \"positive\" ] }"
" { [ dup 0 < ] [ \"negative\" ] }"
- " { [ dup zero? ] [ \"zero\" ] }"
+ " [ \"zero\" ]"
"} cond"
}
} ;
{ $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ;
HELP: case
-{ $values { "obj" object } { "assoc" "a sequence of object/quotation pairs, with an optional quotation at the end" } }
+{ $values { "obj" object } { "assoc" "a sequence of object/word,quotation pairs, with an optional quotation at the end" } }
{ $description
- "Compares " { $snippet "obj" } " against the first element of every pair. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
+ "Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation."
$nl
"If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
$nl
-IN: combinators.tests
USING: alien strings kernel math tools.test io prettyprint
-namespaces combinators words ;
+namespaces combinators words classes sequences ;
+IN: combinators.tests
+
+! Compiled
+: cond-test-1 ( obj -- str )
+ {
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ } cond ;
+
+\ cond-test-1 must-infer
+
+[ "even" ] [ 2 cond-test-1 ] unit-test
+[ "odd" ] [ 3 cond-test-1 ] unit-test
+
+: cond-test-2 ( obj -- str )
+ {
+ { [ dup t = ] [ drop "true" ] }
+ { [ dup f = ] [ drop "false" ] }
+ [ drop "something else" ]
+ } cond ;
+
+\ cond-test-2 must-infer
+
+[ "true" ] [ t cond-test-2 ] unit-test
+[ "false" ] [ f cond-test-2 ] unit-test
+[ "something else" ] [ "ohio" cond-test-2 ] unit-test
+
+: cond-test-3 ( obj -- str )
+ {
+ [ drop "something else" ]
+ { [ dup t = ] [ drop "true" ] }
+ { [ dup f = ] [ drop "false" ] }
+ } cond ;
+
+\ cond-test-3 must-infer
+
+[ "something else" ] [ t cond-test-3 ] unit-test
+[ "something else" ] [ f cond-test-3 ] unit-test
+[ "something else" ] [ "ohio" cond-test-3 ] unit-test
+
+: cond-test-4 ( -- )
+ {
+ } cond ;
+
+\ cond-test-4 must-infer
+
+[ cond-test-4 ] [ class \ no-cond = ] must-fail-with
+! Interpreted
[ "even" ] [
2 {
{ [ dup 2 mod 0 = ] [ drop "even" ] }
{ [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] }
- { [ t ] [ drop "neither" ] }
+ [ drop "neither" ]
+ } cond
+] unit-test
+
+[ "neither" ] [
+ 3 {
+ { [ dup string? ] [ drop "string" ] }
+ { [ dup float? ] [ drop "float" ] }
+ { [ dup alien? ] [ drop "alien" ] }
+ [ drop "neither" ]
+ } cond
+] unit-test
+
+[ "neither" ] [
+ 3 {
+ { [ dup string? ] [ drop "string" ] }
+ { [ dup float? ] [ drop "float" ] }
+ { [ dup alien? ] [ drop "alien" ] }
+ [ drop "neither" ]
+ } cond
+] unit-test
+
+[ "early" ] [
+ 2 {
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ [ drop "early" ]
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
} cond
] unit-test
-: case-test-1
+[ "really early" ] [
+ 2 {
+ [ drop "really early" ]
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ } cond
+] unit-test
+
+[ { } cond ] [ class \ no-cond = ] must-fail-with
+
+[ "early" ] [
+ 2 {
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ [ drop "early" ]
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ } cond
+] unit-test
+
+[ "really early" ] [
+ 2 {
+ [ drop "really early" ]
+ { [ dup 2 mod 1 = ] [ drop "odd" ] }
+ { [ dup 2 mod 0 = ] [ drop "even" ] }
+ } cond
+] unit-test
+
+[ { } cond ] [ class \ no-cond = ] must-fail-with
+
+! Compiled
+: case-test-1 ( obj -- obj' )
{
{ 1 [ "one" ] }
{ 2 [ "two" ] }
{ 4 [ "four" ] }
} case ;
+\ case-test-1 must-infer
+
[ "two" ] [ 2 case-test-1 ] unit-test
! Interpreted
[ "x" case-test-1 ] must-fail
-: case-test-2
+: case-test-2 ( obj -- obj' )
{
{ 1 [ "one" ] }
{ 2 [ "two" ] }
[ sq ]
} case ;
+\ case-test-2 must-infer
+
[ 25 ] [ 5 case-test-2 ] unit-test
! Interpreted
[ 25 ] [ 5 \ case-test-2 word-def call ] unit-test
-: case-test-3
+: case-test-3 ( obj -- obj' )
{
{ 1 [ "one" ] }
{ 2 [ "two" ] }
[ sq ]
} case ;
+\ case-test-3 must-infer
+
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
+: case-const-1 1 ;
+: case-const-2 2 ; inline
+
+! Compiled
+: case-test-4 ( obj -- str )
+ {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case ;
+
+\ case-test-4 must-infer
+
+[ "uno" ] [ 1 case-test-4 ] unit-test
+[ "dos" ] [ 2 case-test-4 ] unit-test
+[ "tres" ] [ 3 case-test-4 ] unit-test
+[ "demasiado" ] [ 100 case-test-4 ] unit-test
+
+: case-test-5 ( obj -- )
+ {
+ { case-const-1 [ "uno" print ] }
+ { case-const-2 [ "dos" print ] }
+ { 3 [ "tres" print ] }
+ { 4 [ "cuatro" print ] }
+ { 5 [ "cinco" print ] }
+ [ drop "demasiado" print ]
+ } case ;
+
+\ case-test-5 must-infer
+
+[ ] [ 1 case-test-5 ] unit-test
+
+! Interpreted
+[ "uno" ] [
+ 1 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+[ "dos" ] [
+ 2 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+[ "tres" ] [
+ 3 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+[ "demasiado" ] [
+ 100 {
+ { case-const-1 [ "uno" ] }
+ { case-const-2 [ "dos" ] }
+ { 3 [ "tres" ] }
+ { 4 [ "cuatro" ] }
+ { 5 [ "cinco" ] }
+ [ drop "demasiado" ]
+ } case
+] unit-test
+
+: do-not-call "do not call" throw ;
+
+: test-case-6
+ {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case ;
+
+[ "three" ] [ 3 test-case-6 ] unit-test
+[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
+
+[ "three" ] [
+ 3 {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case
+] unit-test
+
+[ "do-not-call" ] [
+ [ do-not-call ] first {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case
+] unit-test
+
+[ "do-not-call" ] [
+ \ do-not-call {
+ { \ do-not-call [ "do-not-call" ] }
+ { 3 [ "three" ] }
+ } case
+] unit-test
+
! Interpreted
[ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test
IN: combinators
USING: arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
-hashtables sorting ;
+hashtables sorting words sets ;
-TUPLE: no-cond ;
+: cleave ( x seq -- )
+ [ call ] with each ;
-: no-cond ( -- * ) \ no-cond construct-empty throw ;
+: cleave>quot ( seq -- quot )
+ [ [ keep ] curry ] map concat [ drop ] append [ ] like ;
-: cond ( assoc -- )
- [ first call ] find nip dup [ second call ] [ no-cond ] if ;
+: 2cleave ( x seq -- )
+ [ 2keep ] each 2drop ;
+
+: 2cleave>quot ( seq -- quot )
+ [ [ 2keep ] curry ] map concat [ 2drop ] append [ ] like ;
+
+: 3cleave ( x seq -- )
+ [ 3keep ] each 3drop ;
+
+: 3cleave>quot ( seq -- quot )
+ [ [ 3keep ] curry ] map concat [ 3drop ] append [ ] like ;
+
+: spread>quot ( seq -- quot )
+ [ length [ >r ] <repetition> concat ]
+ [ [ [ r> ] prepend ] map concat ] bi
+ append [ ] like ;
+
+: spread ( objs... seq -- )
+ spread>quot call ;
+
+ERROR: no-cond ;
-TUPLE: no-case ;
+: cond ( assoc -- )
+ [ dup callable? [ drop t ] [ first call ] if ] find nip
+ [ dup callable? [ call ] [ second call ] if ]
+ [ no-cond ] if* ;
-: no-case ( -- * ) \ no-case construct-empty throw ;
+ERROR: no-case ;
+: case-find ( obj assoc -- obj' )
+ [
+ dup array? [
+ dupd first dup word? [
+ execute
+ ] [
+ dup wrapper? [ wrapped ] when
+ ] if =
+ ] [ quotation? ] if
+ ] find nip ;
: case ( obj assoc -- )
- [ dup array? [ dupd first = ] [ quotation? ] if ] find nip
- {
+ case-find {
{ [ dup array? ] [ nip second call ] }
{ [ dup quotation? ] [ call ] }
{ [ dup not ] [ no-case ] }
: with-datastack ( stack quot -- newstack )
datastack >r
>r >array set-datastack r> call
- datastack r> swap add set-datastack 2nip ; inline
+ datastack r> swap suffix set-datastack 2nip ; inline
: recursive-hashcode ( n obj quot -- code )
pick 0 <= [ 3drop 0 ] [ rot 1- -rot call ] if ; inline
M: sequence hashcode*
[ sequence-hashcode ] recursive-hashcode ;
+M: reversed hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
+M: slice hashcode* [ sequence-hashcode ] recursive-hashcode ;
+
M: hashtable hashcode*
[
dup assoc-size 1 number=
[ rot \ if 3array append [ ] like ] assoc-each ;
: cond>quot ( assoc -- quot )
+ [ dup callable? [ [ t ] swap 2array ] when ] map
reverse [ no-cond ] swap alist>quot ;
: linear-case-quot ( default assoc -- quot )
- [ >r [ dupd = ] curry r> \ drop add* ] assoc-map
- alist>quot ;
+ [
+ [ 1quotation \ dup prefix \ = suffix ]
+ [ \ drop prefix ] bi*
+ ] assoc-map alist>quot ;
: (distribute-buckets) ( buckets pair keys -- )
dup t eq? [
: hash-case-quot ( default assoc -- quot )
hash-case-table hash-dispatch-quot
- [ dup hashcode >fixnum ] swap append ;
+ [ dup hashcode >fixnum ] prepend ;
: contiguous-range? ( keys -- from to ? )
dup [ fixnum? ] all? [
dup empty? [
drop
] [
- dup length 4 <= [
+ dup length 4 <=
+ over keys [ [ word? ] [ wrapper? ] bi or ] contains? or
+ [
linear-case-quot
] [
dup keys contiguous-range? [
{ { $snippet "-i=" { $emphasis "image" } } { "Specifies the image file to use; see " { $link "images" } } }
{ { $snippet "-datastack=" { $emphasis "n" } } "Data stack size, kilobytes" }
{ { $snippet "-retainstack=" { $emphasis "n" } } "Retain stack size, kilobytes" }
- { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must be >= 2" }
- { { $snippet "-young=" { $emphasis "n" } } { "Size of " { $snippet { $emphasis "n" } "-1" } " youngest generations, megabytes" } }
- { { $snippet "-aging=" { $emphasis "n" } } "Size of tenured and semi-spaces, megabytes" }
+ { { $snippet "-generations=" { $emphasis "n" } } "Number of generations, must equal 1, 2 or 3" }
+ { { $snippet "-young=" { $emphasis "n" } } { "Size of youngest generation (0), megabytes" } }
+ { { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
+ { { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
}
: run-bootstrap-init ( -- )
"user-init" get [
- home ".factor-boot-rc" path+ ?run-file
+ home ".factor-boot-rc" append-path ?run-file
] when ;
: run-user-init ( -- )
"user-init" get [
- home ".factor-rc" path+ ?run-file
+ home ".factor-rc" append-path ?run-file
] when ;
: cli-var-param ( name value -- ) swap set-global ;
] bind ;
: ignore-cli-args? ( -- ? )
- macosx? "run" get "ui" = and ;
+ os macosx? "run" get "ui" = and ;
: script-mode ( -- )
t "quiet" set-global
assocs words.private sequences compiler.units ;
IN: compiler
+HELP: enable-compiler
+{ $description "Enables the optimizing compiler." } ;
+
+HELP: disable-compiler
+{ $description "Enables the optimizing compiler." } ;
+
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
-"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
-$nl
-"The main entry point to the optimizing compiler:"
+"Normally, new word definitions are recompiled automatically. This can be changed:"
+{ $subsection disable-compiler }
+{ $subsection enable-compiler }
+"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:"
{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
-{ $subsection decompile } ;
+{ $subsection decompile }
+"Higher-level words can be found in " { $link "compilation-units" } "." ;
ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:"
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces arrays sequences io inference.backend
-inference.state generator debugger math.parser prettyprint words
-compiler.units continuations vocabs assocs alien.compiler dlists
-optimizer definitions math compiler.errors threads graphs
-generic inference ;
+inference.state generator debugger words compiler.units
+continuations vocabs assocs alien.compiler dlists optimizer
+definitions math compiler.errors threads graphs generic
+inference ;
IN: compiler
: ripple-up ( word -- )
: finish-compile ( word effect dependencies -- )
>r dupd save-effect r>
over compiled-unxref
- over crossref? [ compiled-xref ] [ 2drop ] if ;
+ over compiled-crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[
compiled get >alist
] with-scope ;
+: enable-compiler ( -- )
+ [ optimized-recompile-hook ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+ [ default-recompile-hook ] recompile-hook set-global ;
+
: recompile-all ( -- )
forget-errors all-words compile ;
: byte-array-offset 2 bootstrap-cells object tag-number - ;
: alien-offset 3 bootstrap-cells object tag-number - ;
: underlying-alien-offset bootstrap-cell object tag-number - ;
-: tuple-class-offset 2 bootstrap-cells tuple tag-number - ;
+: tuple-class-offset bootstrap-cell tuple tag-number - ;
: class-hash-offset bootstrap-cell object tag-number - ;
: word-xt-offset 8 bootstrap-cells object tag-number - ;
: word-code-offset 9 bootstrap-cells object tag-number - ;
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-call ] unit-test
-[ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-call ] unit-test
+[ -10 -20 ] [ 10 20 -1 [ [ * ] curry bi@ ] compile-call ] unit-test
[ [ 5 2 - ] ] [ 5 [ [ 2 - ] curry ] compile-call >quotation ] unit-test
[ [ 5 2 - ] ] [ [ 5 [ 2 - ] curry ] compile-call >quotation ] unit-test
USING: compiler.units kernel kernel.private memory math
math.private tools.test math.floats.private ;
-[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test
+[ 5.0 ] [ [ 5.0 ] compile-call gc gc gc ] unit-test
[ 2.0 3.0 ] [ 3.0 [ 2.0 swap ] compile-call ] unit-test
[ 1 2 3 4.0 ] [ [ 1 2 3 4.0 ] compile-call ] unit-test
continuations sequences.private hashtables.private byte-arrays
strings.private system random layouts vectors.private
sbufs.private strings.private slots.private alien
-alien.accessors alien.c-types alien.syntax namespaces libc
-sequences.private ;
+alien.accessors alien.c-types alien.syntax alien.strings
+namespaces libc sequences.private io.encodings.ascii ;
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test
[ -6 ] [ 2 [ -3 fixnum* ] compile-call ] unit-test
[ -6 ] [ [ 2 -3 fixnum* ] compile-call ] unit-test
-[ t ] [ 3 type 3 [ type ] compile-call eq? ] unit-test
-[ t ] [ 3 >bignum type 3 >bignum [ type ] compile-call eq? ] unit-test
-[ t ] [ "hey" type "hey" [ type ] compile-call eq? ] unit-test
-[ t ] [ f type f [ type ] compile-call eq? ] unit-test
-
[ 5 ] [ 1 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 2 2 [ eq? [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ 3 ] [ 1 2 [ fixnum< [ 3 ] [ 5 ] if ] compile-call ] unit-test
[ t ] [ f [ f eq? ] compile-call ] unit-test
-! regression
-[ t ] [ { 1 2 3 } { 1 2 3 } [ over type over type eq? ] compile-call 2nip ] unit-test
-
! regression
[ 3 ] [
100001 f <array> 3 100000 pick set-nth
: compiled-fixnum* fixnum* ;
: test-fixnum*
- (random) >fixnum (random) >fixnum
+ 32 random-bits >fixnum 32 random-bits >fixnum
2dup
[ fixnum* ] 2keep compiled-fixnum* =
[ 2drop ] [ "Oops" throw ] if ;
: compiled-fixnum>bignum fixnum>bignum ;
: test-fixnum>bignum
- (random) >fixnum
+ 32 random-bits >fixnum
dup [ fixnum>bignum ] keep compiled-fixnum>bignum =
[ drop ] [ "Oops" throw ] if ;
: compiled-bignum>fixnum bignum>fixnum ;
: test-bignum>fixnum
- 5 random [ drop (random) ] map product >bignum
+ 5 random [ drop 32 random-bits ] map product >bignum
dup [ bignum>fixnum ] keep compiled-bignum>fixnum =
[ drop ] [ "Oops" throw ] if ;
[ ] [ "b" get free ] unit-test
] when
-[ ] [ "hello world" malloc-char-string "s" set ] unit-test
+[ ] [ "hello world" ascii malloc-string "s" set ] unit-test
"s" get [
- [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call alien>char-string ] unit-test
- [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call alien>char-string ] unit-test
+ [ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-call ascii alien>string ] unit-test
+ [ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-call ascii alien>string ] unit-test
[ ] [ "s" get free ] unit-test
] when
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-call ] unit-test
[ -4 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-signed-1 ] compile-call ] unit-test
-: xword-def word-def [ { fixnum } declare ] swap append ;
+: xword-def word-def [ { fixnum } declare ] prepend ;
[ -100 ] [ -100 <char> [ { byte-array } declare *char ] compile-call ] unit-test
[ 156 ] [ -100 <uchar> [ { byte-array } declare *uchar ] compile-call ] unit-test
USING: compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings
-alien arrays memory ;
+alien arrays memory vocabs parser ;
IN: compiler.tests
! Test empty word
[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test
-[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test
+[ 2 3 ] [ 1 [ { [ gc 1 ] [ gc 2 ] } dispatch 3 ] compile-call ] unit-test
! Labels
{ [ dup string? ] [ drop "string" ] }
{ [ dup float? ] [ drop "float" ] }
{ [ dup alien? ] [ drop "alien" ] }
- { [ t ] [ drop "neither" ] }
+ [ drop "neither" ]
} cond
] compile-call
] unit-test
[
3 {
{ [ dup fixnum? ] [ ] }
- { [ t ] [ drop t ] }
+ [ drop t ]
} cond
] compile-call
] unit-test
! Regression
[ 100 ] [ [ 100 [ [ ] times ] keep ] compile-call ] unit-test
+
+! Regression
+10 [
+ [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
+ [ t ] [
+ "USING: prettyprint words ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline : recursive ( -- ) (recursive) ; \\ (recursive) compiled?" eval
+ ] unit-test
+] times
IN: compiler.tests
USING: compiler generator generator.registers
generator.registers.private tools.test namespaces sequences
-words kernel math effects definitions compiler.units ;
+words kernel math effects definitions compiler.units accessors
+cpu.architecture ;
-: <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
+: <int-vreg> ( n -- vreg ) int-regs <vreg> ;
[
[ ] [ init-templates ] unit-test
[ ] [ compute-free-vregs ] unit-test
- [ f ] [ 0 <int-vreg> T{ int-regs } free-vregs member? ] unit-test
+ [ f ] [ 0 <int-vreg> int-regs free-vregs member? ] unit-test
[ f ] [
[
copy-templates
1 <int-vreg> phantom-push
compute-free-vregs
- 1 <int-vreg> T{ int-regs } free-vregs member?
+ 1 <int-vreg> int-regs free-vregs member?
] with-scope
] unit-test
- [ t ] [ 1 <int-vreg> T{ int-regs } free-vregs member? ] unit-test
+ [ t ] [ 1 <int-vreg> int-regs free-vregs member? ] unit-test
] with-scope
[
] unit-test
[ ] [
- 2 phantom-d get phantom-input
+ 2 phantom-datastack get phantom-input
[ { { f "a" } { f "b" } } lazy-load ] { } make drop
] unit-test
[ t ] [
- phantom-d get [ cached? ] all?
+ phantom-datastack get stack>> [ cached? ] all?
] unit-test
! >r
hashtables.private math.private namespaces sequences
sequences.private tools.test namespaces.private slots.private
sequences.private byte-arrays alien alien.accessors layouts
-words definitions compiler.units io combinators ;
+words definitions compiler.units io combinators vectors ;
IN: compiler.tests
! Oops!
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test
-[ { 1 2 3 } { 1 4 3 } 8 8 ]
-[ { 1 2 3 } { 1 4 3 } [ over type over type ] compile-call ]
-unit-test
-
! Test literals in either side of a shuffle
[ 4 1 ] [ 1 [ [ 3 fixnum+ ] keep ] compile-call ] unit-test
] unit-test
[ 12 13 ] [
- -12 -13 [ [ 0 swap fixnum-fast ] 2apply ] compile-call
+ -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
] unit-test
[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
[ 12 13 ] [
- -12 -13 [ [ 0 swap fixnum- ] 2apply ] compile-call
+ -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
] unit-test
-[ 2 ] [
- SBUF" " [ 2 slot 2 [ slot ] keep ] compile-call nip
+[ 1 ] [
+ SBUF" " [ 1 slot 1 [ slot ] keep ] compile-call nip
] unit-test
! Test slow shuffles
[ 1 t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
- [ 0 alien-unsigned-1 ] keep type
+ [ 0 alien-unsigned-1 ] keep hi-tag
] compile-call byte-array type-number =
] unit-test
[ t ] [
B{ 1 2 3 4 } [
{ c-ptr } declare
- 0 alien-cell type
+ 0 alien-cell hi-tag
] compile-call alien type-number =
] unit-test
] [ 2drop no-case ] if
] compile-call
] unit-test
+
+: float-spill-bug
+ {
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ [ dup float+ ]
+ } cleave ;
+
+[ t ] [ \ float-spill-bug compiled? ] unit-test
+
+! Regression
+: dispatch-alignment-regression ( -- c )
+ { tuple vector } 3 slot { word } declare
+ dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
+
+[ t ] [ \ dispatch-alignment-regression compiled? ] unit-test
+
+[ vector ] [ dispatch-alignment-regression ] unit-test
TUPLE: color red green blue ;
[ T{ color f 1 2 3 } ]
-[ 1 2 3 [ color construct-boa ] compile-call ] unit-test
+[ 1 2 3 [ color boa ] compile-call ] unit-test
[ 1 3 ] [
- 1 2 3 color construct-boa
+ 1 2 3 color boa
[ { color-red color-blue } get-slots ] compile-call
] unit-test
[ T{ color f 10 2 20 } ] [
10 20
- 1 2 3 color construct-boa [
+ 1 2 3 color boa [
[
{ set-color-red set-color-blue } set-slots
] compile-call
] unit-test
[ T{ color f f f f } ]
-[ [ color construct-empty ] compile-call ] unit-test
-
-[ T{ color "a" f "b" f } ] [
- "a" "b"
- [ { set-delegate set-color-green } color construct ]
- compile-call
-] unit-test
-
-[ T{ color f f f f } ] [ [ { } color construct ] compile-call ] unit-test
+[ [ color new ] compile-call ] unit-test
$nl
"The parser groups all definitions in a source file into one compilation unit, and parsing words do not need to concern themselves with compilation units. However, if definitions are being created at run time, a compilation unit must be created explicitly:"
{ $subsection with-compilation-unit }
-"Words called to associate a definition with a source file location:"
+"Compiling a set of words:"
+{ $subsection compile }
+"Words called to associate a definition with a compilation unit and a source file location:"
{ $subsection remember-definition }
{ $subsection remember-class }
"Forward reference checking (see " { $link "definition-checking" } "):"
TUPLE: redefine-error def ;
: redefine-error ( definition -- )
- \ redefine-error construct-boa
+ \ redefine-error boa
{ { "Continue" t } } throw-restarts drop ;
: add-once ( key assoc -- )
[ drop word? ] assoc-subset
[ drop word-vocabulary dup [ vocab ] when dup ] assoc-map ;
-: changed-definitions ( -- assoc )
+: updated-definitions ( -- assoc )
H{ } clone
dup forgotten-definitions get update
dup new-definitions get first update
dup new-definitions get second update
- dup changed-words get update
+ dup changed-definitions get update
dup dup changed-vocabs update ;
: compile ( words -- )
recompile-hook get call
- dup [ drop crossref? ] assoc-contains?
+ dup [ drop compiled-crossref? ] assoc-contains?
modify-code-heap ;
-SYMBOL: post-compile-tasks
-
-: after-compilation ( quot -- )
- post-compile-tasks get push ;
+SYMBOL: outdated-tuples
+SYMBOL: update-tuples-hook
: call-recompile-hook ( -- )
- changed-words get keys
+ changed-definitions get keys [ word? ] subset
compiled-usages recompile-hook get call ;
-: call-post-compile-tasks ( -- )
- post-compile-tasks get [ call ] each ;
+: call-update-tuples-hook ( -- )
+ update-tuples-hook get call ;
: finish-compilation-unit ( -- )
call-recompile-hook
- call-post-compile-tasks
- dup [ drop crossref? ] assoc-contains? modify-code-heap
- changed-definitions notify-definition-observers ;
+ call-update-tuples-hook
+ dup [ drop compiled-crossref? ] assoc-contains? modify-code-heap
+ updated-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- )
[
- H{ } clone changed-words set
+ H{ } clone changed-definitions set
H{ } clone forgotten-definitions set
- V{ } clone post-compile-tasks set
+ H{ } clone outdated-tuples set
<definitions> new-definitions set
<definitions> old-definitions set
[ finish-compilation-unit ]
USING: help.markup help.syntax kernel kernel.private
continuations.private parser vectors arrays namespaces
-assocs words quotations ;
+assocs words quotations io ;
IN: continuations
ARTICLE: "errors-restartable" "Restartable errors"
{ $subsection error-continuation }
"Developer tools for inspecting these values are found in " { $link "debugger" } "." ;
+ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
+"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."
+{ $heading "Anti-pattern #1: Ignoring errors" }
+"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."
+{ $heading "Anti-pattern #2: Catching errors too early" }
+"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."
+$nl
+"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
+{ $heading "Anti-pattern #3: Dropping and rethrowing" }
+"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
+{ $heading "Anti-pattern #4: Logging and rethrowing" }
+"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information."
+{ $heading "Anti-pattern #5: Leaking external resources" }
+"Words which create objects corresponding to external resources should always be used with " { $link with-disposal } ". The following code is wrong:"
+{ $code
+ "<external-resource> ... do stuff ... dispose"
+}
+"The reason being that if " { $snippet "do stuff" } " throws an error, the resource will not be disposed of. The most important case where this can occur is with I/O streams, and the correct solution is to always use " { $link with-stream } "; see " { $link "stdio" } " for details." ;
+
ARTICLE: "errors" "Error handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
$nl
{ $subsection cleanup }
{ $subsection recover }
{ $subsection ignore-errors }
+"Syntax sugar for defining errors:"
+{ $subsection POSTPONE: ERROR: }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsection "errors-restartable" }
+{ $subsection "debugger" }
{ $subsection "errors-post-mortem" }
+{ $subsection "errors-anti-examples" }
"When Factor encouters a critical error, it calls the following word:"
{ $subsection die } ;
"Another two words resume continuations:"
{ $subsection continue }
{ $subsection continue-with }
-"Continuations serve as the building block for a number of higher-level abstractions."
-{ $subsection "errors" }
+"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
ABOUT: "continuations"
HELP: dispose
{ $values { "object" "a disposable object" } }
-{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
+{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
+$nl
+"No further operations can be performed on a disposable object after this call."
+$nl
+"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." }
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
HELP: with-disposal
! Weird PowerPC bug.
[ ] [
[ "4" throw ] ignore-errors
- data-gc
- data-gc
+ gc
+ gc
] unit-test
[ f ] [ { } kernel-error? ] unit-test
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences
-namespaces math splitting sorting quotations assocs ;
+namespaces math splitting sorting quotations assocs
+combinators accessors ;
IN: continuations
SYMBOL: error
: >continuation< ( continuation -- data call retain name catch )
{
- continuation-data
- continuation-call
- continuation-retain
- continuation-name
- continuation-catch
- } get-slots ;
+ [ data>> ]
+ [ call>> ]
+ [ retain>> ]
+ [ name>> ]
+ [ catch>> ]
+ } cleave ;
: ifcc ( capture restore -- )
#! After continuation is being captured, the stacks looks
: with-disposal ( object quot -- )
over [ dispose ] curry [ ] cleanup ; inline
-TUPLE: condition restarts continuation ;
+TUPLE: condition error restarts continuation ;
-: <condition> ( error restarts cc -- condition )
- {
- set-delegate
- set-condition-restarts
- set-condition-continuation
- } condition construct ;
+C: <condition> condition ( error restarts cc -- condition )
: throw-restarts ( error restarts -- restart )
[ <condition> throw ] callcc1 2nip ;
C: <restart> restart
: restart ( restart -- )
- dup restart-obj swap restart-continuation continue-with ;
+ [ obj>> ] [ continuation>> ] bi continue-with ;
M: object compute-restarts drop { } ;
-M: tuple compute-restarts delegate compute-restarts ;
-
M: condition compute-restarts
- [ delegate compute-restarts ] keep
- [ condition-restarts ] keep
- condition-continuation
- [ <restart> ] curry { } assoc>map
- append ;
+ [ error>> compute-restarts ]
+ [
+ [ restarts>> ]
+ [ condition-continuation [ <restart> ] curry ] bi
+ { } assoc>map
+ ] bi append ;
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel kernel.private math memory
namespaces sequences layouts system hashtables classes alien
-byte-arrays bit-arrays float-arrays combinators words ;
+byte-arrays bit-arrays float-arrays combinators words sets ;
IN: cpu.architecture
-SYMBOL: compiler-backend
+! Register classes
+SINGLETON: int-regs
+SINGLETON: single-float-regs
+SINGLETON: double-float-regs
+UNION: float-regs single-float-regs double-float-regs ;
+UNION: reg-class int-regs float-regs ;
! A pseudo-register class for parameters spilled on the stack
-TUPLE: stack-params ;
+SINGLETON: stack-params
! Return values of this class go here
GENERIC: return-reg ( register-class -- reg )
! Load a literal (immediate or indirect)
GENERIC# load-literal 1 ( obj vreg -- )
-HOOK: load-indirect compiler-backend ( obj reg -- )
+HOOK: load-indirect cpu ( obj reg -- )
-HOOK: stack-frame compiler-backend ( frame-size -- n )
+HOOK: stack-frame cpu ( frame-size -- n )
: stack-frame* ( -- n )
\ stack-frame get stack-frame ;
! Set up caller stack frame
-HOOK: %prologue compiler-backend ( n -- )
+HOOK: %prologue cpu ( n -- )
: %prologue-later \ %prologue-later , ;
! Tear down stack frame
-HOOK: %epilogue compiler-backend ( n -- )
+HOOK: %epilogue cpu ( n -- )
: %epilogue-later \ %epilogue-later , ;
! Store word XT in stack frame
-HOOK: %save-word-xt compiler-backend ( -- )
+HOOK: %save-word-xt cpu ( -- )
! Store dispatch branch XT in stack frame
-HOOK: %save-dispatch-xt compiler-backend ( -- )
+HOOK: %save-dispatch-xt cpu ( -- )
M: object %save-dispatch-xt %save-word-xt ;
! Call another word
-HOOK: %call compiler-backend ( word -- )
+HOOK: %call cpu ( word -- )
! Local jump for branches
-HOOK: %jump-label compiler-backend ( label -- )
+HOOK: %jump-label cpu ( label -- )
! Test if vreg is 'f' or not
-HOOK: %jump-t compiler-backend ( label -- )
+HOOK: %jump-f cpu ( label -- )
-HOOK: %dispatch compiler-backend ( -- )
+HOOK: %dispatch cpu ( -- )
-HOOK: %dispatch-label compiler-backend ( word -- )
+HOOK: %dispatch-label cpu ( word -- )
! Return to caller
-HOOK: %return compiler-backend ( -- )
+HOOK: %return cpu ( -- )
! Change datastack height
-HOOK: %inc-d compiler-backend ( n -- )
+HOOK: %inc-d cpu ( n -- )
! Change callstack height
-HOOK: %inc-r compiler-backend ( n -- )
+HOOK: %inc-r cpu ( n -- )
! Load stack into vreg
-HOOK: %peek compiler-backend ( vreg loc -- )
+HOOK: %peek cpu ( vreg loc -- )
! Store vreg to stack
-HOOK: %replace compiler-backend ( vreg loc -- )
+HOOK: %replace cpu ( vreg loc -- )
! Box and unbox floats
-HOOK: %unbox-float compiler-backend ( dst src -- )
-HOOK: %box-float compiler-backend ( dst src -- )
+HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-float cpu ( dst src -- )
! FFI stuff
! Is this integer small enough to appear in value template
! slots?
-HOOK: small-enough? compiler-backend ( n -- ? )
+HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? compiler-backend ( size -- ? )
+HOOK: struct-small-enough? cpu ( size -- ? )
! Do we pass explode value structs?
-HOOK: value-structs? compiler-backend ( -- ? )
+HOOK: value-structs? cpu ( -- ? )
! If t, fp parameters are shadowed by dummy int parameters
-HOOK: fp-shadows-int? compiler-backend ( -- ? )
+HOOK: fp-shadows-int? cpu ( -- ? )
-HOOK: %prepare-unbox compiler-backend ( -- )
+HOOK: %prepare-unbox cpu ( -- )
-HOOK: %unbox compiler-backend ( n reg-class func -- )
+HOOK: %unbox cpu ( n reg-class func -- )
-HOOK: %unbox-long-long compiler-backend ( n func -- )
+HOOK: %unbox-long-long cpu ( n func -- )
-HOOK: %unbox-small-struct compiler-backend ( size -- )
+HOOK: %unbox-small-struct cpu ( size -- )
-HOOK: %unbox-large-struct compiler-backend ( n size -- )
+HOOK: %unbox-large-struct cpu ( n size -- )
-HOOK: %box compiler-backend ( n reg-class func -- )
+HOOK: %box cpu ( n reg-class func -- )
-HOOK: %box-long-long compiler-backend ( n func -- )
+HOOK: %box-long-long cpu ( n func -- )
-HOOK: %prepare-box-struct compiler-backend ( size -- )
+HOOK: %prepare-box-struct cpu ( size -- )
-HOOK: %box-small-struct compiler-backend ( size -- )
+HOOK: %box-small-struct cpu ( size -- )
-HOOK: %box-large-struct compiler-backend ( n size -- )
+HOOK: %box-large-struct cpu ( n size -- )
GENERIC: %save-param-reg ( stack reg reg-class -- )
GENERIC: %load-param-reg ( stack reg reg-class -- )
-HOOK: %prepare-alien-invoke compiler-backend ( -- )
+HOOK: %prepare-alien-invoke cpu ( -- )
-HOOK: %prepare-var-args compiler-backend ( -- )
+HOOK: %prepare-var-args cpu ( -- )
M: object %prepare-var-args ;
-HOOK: %alien-invoke compiler-backend ( function library -- )
+HOOK: %alien-invoke cpu ( function library -- )
-HOOK: %cleanup compiler-backend ( alien-node -- )
+HOOK: %cleanup cpu ( alien-node -- )
-HOOK: %alien-callback compiler-backend ( quot -- )
+HOOK: %alien-callback cpu ( quot -- )
-HOOK: %callback-value compiler-backend ( ctype -- )
+HOOK: %callback-value cpu ( ctype -- )
! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind compiler-backend ( n -- )
+HOOK: %unwind cpu ( n -- )
-HOOK: %prepare-alien-indirect compiler-backend ( -- )
+HOOK: %prepare-alien-indirect cpu ( -- )
-HOOK: %alien-indirect compiler-backend ( -- )
+HOOK: %alien-indirect cpu ( -- )
M: stack-params param-reg drop ;
M: object load-literal v>operand load-indirect ;
-PREDICATE: integer small-slot cells small-enough? ;
+PREDICATE: small-slot < integer cells small-enough? ;
-PREDICATE: integer small-tagged v>operand small-enough? ;
+PREDICATE: small-tagged < integer v>operand small-enough? ;
-PREDICATE: integer inline-array 32 < ;
+PREDICATE: inline-array < integer 32 < ;
: if-small-struct ( n size true false -- ? )
>r >r over not over struct-small-enough? and
] if-small-struct ;
! Alien accessors
-HOOK: %unbox-byte-array compiler-backend ( dst src -- )
+HOOK: %unbox-byte-array cpu ( dst src -- )
-HOOK: %unbox-alien compiler-backend ( dst src -- )
+HOOK: %unbox-alien cpu ( dst src -- )
-HOOK: %unbox-f compiler-backend ( dst src -- )
+HOOK: %unbox-f cpu ( dst src -- )
-HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
-HOOK: %box-alien compiler-backend ( dst src -- )
+HOOK: %box-alien cpu ( dst src -- )
+
+! GC check
+HOOK: %gc cpu
: operand ( var -- op ) get v>operand ; inline
M: immediate load-literal
over v>operand small-enough? [
- [ v>operand ] 2apply swap MOV
+ [ v>operand ] bi@ swap MOV
] [
v>operand load-indirect
] if ;
! Alien intrinsics
M: arm-backend %unbox-byte-array ( dst src -- )
- [ v>operand ] 2apply byte-array-offset ADD ;
+ [ v>operand ] bi@ byte-array-offset ADD ;
M: arm-backend %unbox-alien ( dst src -- )
- [ v>operand ] 2apply alien-offset <+> LDR ;
+ [ v>operand ] bi@ alien-offset <+> LDR ;
M: arm-backend %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
{ R0 R1 R2 R3 R4 R5 R6 R7 R8 R9 R10 R11 R12 R13 R14 R15 }
define-registers
-PREDICATE: word register register >boolean ;
+PREDICATE: register < word register >boolean ;
GENERIC: register ( register -- n )
M: word register "register" word-prop ;
math.private namespaces sequences words
quotations byte-arrays hashtables.private hashtables generator
generator.registers generator.fixup sequences.private sbufs
-sbufs.private vectors vectors.private system tuples.private
-layouts strings.private slots.private ;
+sbufs.private vectors vectors.private system
+classes.tuple.private layouts strings.private slots.private ;
IN: cpu.arm.intrinsics
: %slot-literal-known-tag
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.ppc.architecture cpu.ppc.assembler
kernel.private namespaces math sequences generic arrays
IN: cpu.ppc.allot
: load-zone-ptr ( reg -- )
- "nursery" f pick %load-dlsym dup 0 LWZ ;
+ >r "nursery" f r> %load-dlsym ;
: %allot ( header size -- )
#! Store a pointer to 'size' bytes allocated from the
: %store-tagged ( reg tag -- )
>r dup fresh-object v>operand 11 r> tag-number ORI ;
+M: ppc %gc
+ "end" define-label
+ 12 load-zone-ptr
+ 11 12 cell LWZ ! nursery.here -> r11
+ 12 12 3 cells LWZ ! nursery.end -> r12
+ 11 11 1024 ADDI ! add ALLOT_BUFFER_ZONE to here
+ 11 0 12 CMP ! is here >= end?
+ "end" get BLE
+ 0 frame-required
+ %prepare-alien-invoke
+ "minor_gc" f %alien-invoke
+ "end" resolve-label ;
+
: %allot-float ( reg -- )
#! exits with tagged ptr to object in r12, untagged in r11
float 16 %allot
12 11 float tag-number ORI
f fresh-object ;
-M: ppc-backend %box-float ( dst src -- )
- [ v>operand ] 2apply %allot-float 12 MR ;
+M: ppc %box-float ( dst src -- )
+ [ v>operand ] bi@ %allot-float 12 MR ;
: %allot-bignum ( #digits -- )
#! 1 cell header, 1 cell length, 1 cell sign, + digits
"end" resolve-label
] with-scope ;
-M: ppc-backend %box-alien ( dst src -- )
+M: ppc %box-alien ( dst src -- )
{ "end" "f" } [ define-label ] each
0 over v>operand 0 CMPI
"f" get BEQ
compiler.constants ;
IN: cpu.ppc.architecture
-TUPLE: ppc-backend ;
-
! PowerPC register assignments
! r3-r10, r16-r31: integer vregs
! f0-f13: float vregs
: reserved-area-size
os {
- { "linux" [ 2 ] }
- { "macosx" [ 6 ] }
+ { linux [ 2 ] }
+ { macosx [ 6 ] }
} case cells ; foldable
: lr-save
os {
- { "linux" [ 1 ] }
- { "macosx" [ 2 ] }
+ { linux [ 1 ] }
+ { macosx [ 2 ] }
} case cells ; foldable
: param@ ( n -- x ) reserved-area-size + ; inline
: xt-save ( n -- i ) 2 cells - ;
-M: ppc-backend stack-frame ( n -- i )
+M: ppc stack-frame ( n -- i )
local@ factor-area-size + 4 cells align ;
M: temp-reg v>operand drop 11 ;
M: float-regs return-reg drop 1 ;
M: float-regs param-regs
drop os H{
- { "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
- { "linux" { 1 2 3 4 5 6 7 8 } }
+ { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
+ { linux { 1 2 3 4 5 6 7 8 } }
} at ;
M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
M: immediate load-literal
- [ v>operand ] 2apply LOAD ;
+ [ v>operand ] bi@ LOAD ;
-M: ppc-backend load-indirect ( obj reg -- )
+M: ppc load-indirect ( obj reg -- )
[ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
dup 0 LWZ ;
-M: ppc-backend %save-word-xt ( -- )
+M: ppc %save-word-xt ( -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
-M: ppc-backend %prologue ( n -- )
+M: ppc %prologue ( n -- )
0 MFLR
1 1 pick neg ADDI
11 1 pick xt-save STW
11 1 pick next-save STW
0 1 rot lr-save + STW ;
-M: ppc-backend %epilogue ( n -- )
+M: ppc %epilogue ( n -- )
#! At the end of each word that calls a subroutine, we store
#! the previous link register value in r0 by popping it off
#! the stack, set the link register to the contents of r0,
: %load-dlsym ( symbol dll register -- )
0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
-M: ppc-backend %call ( label -- ) BL ;
+M: ppc %call ( label -- ) BL ;
-M: ppc-backend %jump-label ( label -- ) B ;
+M: ppc %jump-label ( label -- ) B ;
-M: ppc-backend %jump-t ( label -- )
- 0 "flag" operand f v>operand CMPI BNE ;
+M: ppc %jump-f ( label -- )
+ 0 "flag" operand f v>operand CMPI BEQ ;
-M: ppc-backend %dispatch ( -- )
+M: ppc %dispatch ( -- )
[
%epilogue-later
0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
{ +scratch+ { { f "offset" } } }
} with-template ;
-M: ppc-backend %dispatch-label ( word -- )
+M: ppc %dispatch-label ( word -- )
0 , rc-absolute-cell rel-word ;
-M: ppc-backend %return ( -- ) %epilogue-later BLR ;
+M: ppc %return ( -- ) %epilogue-later BLR ;
-M: ppc-backend %unwind drop %return ;
+M: ppc %unwind drop %return ;
-M: ppc-backend %peek ( vreg loc -- )
+M: ppc %peek ( vreg loc -- )
>r v>operand r> loc>operand LWZ ;
-M: ppc-backend %replace
+M: ppc %replace
>r v>operand r> loc>operand STW ;
-M: ppc-backend %unbox-float ( dst src -- )
- [ v>operand ] 2apply float-offset LFD ;
+M: ppc %unbox-float ( dst src -- )
+ [ v>operand ] bi@ float-offset LFD ;
-M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
+M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
-M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
+M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
M: int-regs %save-param-reg drop 1 rot local@ STW ;
M: int-regs %load-param-reg drop 1 rot local@ LWZ ;
-: STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
+GENERIC: STF ( src dst off reg-class -- )
+
+M: single-float-regs STF drop STFS ;
+
+M: double-float-regs STF drop STFD ;
M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
-: LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
+GENERIC: LF ( dst src off reg-class -- )
+
+M: single-float-regs LF drop LFS ;
+
+M: double-float-regs LF drop LFD ;
M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
0 1 rot param@ stack-frame* + LWZ
0 1 rot local@ STW ;
-M: ppc-backend %prepare-unbox ( -- )
+M: ppc %prepare-unbox ( -- )
! First parameter is top of stack
3 ds-reg 0 LWZ
ds-reg dup cell SUBI ;
-M: ppc-backend %unbox ( n reg-class func -- )
+M: ppc %unbox ( n reg-class func -- )
! Value must be in r3
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-M: ppc-backend %unbox-long-long ( n func -- )
+M: ppc %unbox-long-long ( n func -- )
! Value must be in r3:r4
! Call the unboxer
f %alien-invoke
4 1 rot cell + local@ STW
] when* ;
-M: ppc-backend %unbox-large-struct ( n size -- )
+M: ppc %unbox-large-struct ( n size -- )
! Value must be in r3
! Compute destination address
4 1 roll local@ ADDI
! Call the function
"to_value_struct" f %alien-invoke ;
-M: ppc-backend %box ( n reg-class func -- )
+M: ppc %box ( n reg-class func -- )
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
r> f %alien-invoke ;
-M: ppc-backend %box-long-long ( n func -- )
+M: ppc %box-long-long ( n func -- )
>r [
3 1 pick local@ LWZ
4 1 rot cell + local@ LWZ
: struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
-M: ppc-backend %prepare-box-struct ( size -- )
+M: ppc %prepare-box-struct ( size -- )
#! Compute target address for value struct return
3 1 rot f struct-return@ ADDI
3 1 0 local@ STW ;
-M: ppc-backend %box-large-struct ( n size -- )
+M: ppc %box-large-struct ( n size -- )
#! If n = f, then we're boxing a returned struct
[ swap struct-return@ ] keep
! Compute destination address
! Call the function
"box_value_struct" f %alien-invoke ;
-M: ppc-backend %prepare-alien-invoke
+M: ppc %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
ds-reg 11 8 STW
rs-reg 11 12 STW ;
-M: ppc-backend %alien-invoke ( symbol dll -- )
+M: ppc %alien-invoke ( symbol dll -- )
11 %load-dlsym (%call) ;
-M: ppc-backend %alien-callback ( quot -- )
+M: ppc %alien-callback ( quot -- )
3 load-indirect "c_to_factor" f %alien-invoke ;
-M: ppc-backend %prepare-alien-indirect ( -- )
+M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
3 1 cell temp@ STW ;
-M: ppc-backend %alien-indirect ( -- )
+M: ppc %alien-indirect ( -- )
11 1 cell temp@ LWZ (%call) ;
-M: ppc-backend %callback-value ( ctype -- )
+M: ppc %callback-value ( ctype -- )
! Save top of data stack
3 ds-reg 0 LWZ
3 1 0 local@ STW
! Unbox former top of data stack to return registers
unbox-return ;
-M: ppc-backend %cleanup ( alien-node -- ) drop ;
+M: ppc %cleanup ( alien-node -- ) drop ;
: %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
: %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
-M: ppc-backend value-structs?
+M: ppc value-structs?
#! On Linux/PPC, value structs are passed in the same way
#! as reference structs, we just have to make a copy first.
- linux? not ;
+ os linux? not ;
-M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ;
+M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
-M: ppc-backend small-enough? ( n -- ? ) -32768 32767 between? ;
+M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
-M: ppc-backend struct-small-enough? ( size -- ? ) drop f ;
+M: ppc struct-small-enough? ( size -- ? ) drop f ;
-M: ppc-backend %box-small-struct
+M: ppc %box-small-struct
drop "No small structs" throw ;
-M: ppc-backend %unbox-small-struct
+M: ppc %unbox-small-struct
drop "No small structs" throw ;
! Alien intrinsics
-M: ppc-backend %unbox-byte-array ( dst src -- )
- [ v>operand ] 2apply byte-array-offset ADDI ;
+M: ppc %unbox-byte-array ( dst src -- )
+ [ v>operand ] bi@ byte-array-offset ADDI ;
-M: ppc-backend %unbox-alien ( dst src -- )
- [ v>operand ] 2apply alien-offset LWZ ;
+M: ppc %unbox-alien ( dst src -- )
+ [ v>operand ] bi@ alien-offset LWZ ;
-M: ppc-backend %unbox-f ( dst src -- )
+M: ppc %unbox-f ( dst src -- )
drop 0 swap v>operand LI ;
-M: ppc-backend %unbox-any-c-ptr ( dst src -- )
+M: ppc %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in R12
0 12 LI
generic quotations byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private
sbufs vectors system layouts math.floats.private
-classes tuples tuples.private sbufs.private vectors.private
-strings.private slots.private combinators bit-arrays
-float-arrays compiler.constants ;
+classes classes.tuple classes.tuple.private sbufs.private
+vectors.private strings.private slots.private combinators
+bit-arrays float-arrays compiler.constants ;
IN: cpu.ppc.intrinsics
: %slot-literal-known-tag
} define-intrinsics
: fixnum-register-op ( op -- pair )
- [ "out" operand "y" operand "x" operand ] swap add H{
+ [ "out" operand "y" operand "x" operand ] swap suffix H{
{ +input+ { { f "x" } { f "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} 2array ;
: fixnum-value-op ( op -- pair )
- [ "out" operand "x" operand "y" operand ] swap add H{
+ [ "out" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { f "x" } { [ small-tagged? ] "y" } } }
{ +scratch+ { { f "out" } } }
{ +output+ { "out" } }
} define-intrinsic
: fixnum-register-jump ( op -- pair )
- [ "x" operand 0 "y" operand CMP ] swap add
+ [ "x" operand 0 "y" operand CMP ] swap suffix
{ { f "x" } { f "y" } } 2array ;
: fixnum-value-jump ( op -- pair )
- [ 0 "x" operand "y" operand CMPI ] swap add
+ [ 0 "x" operand "y" operand CMPI ] swap suffix
{ { f "x" } { [ small-tagged? ] "y" } } 2array ;
: define-fixnum-jump ( word op -- )
2array define-if-intrinsics ;
{
- { fixnum< BLT }
- { fixnum<= BLE }
- { fixnum> BGT }
- { fixnum>= BGE }
- { eq? BEQ }
+ { fixnum< BGE }
+ { fixnum<= BGT }
+ { fixnum> BLE }
+ { fixnum>= BLT }
+ { eq? BNE }
} [
first2 define-fixnum-jump
] each
} define-intrinsic
: define-float-op ( word op -- )
- [ "z" operand "x" operand "y" operand ] swap add H{
+ [ "z" operand "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +scratch+ { { float "z" } } }
{ +output+ { "z" } }
] each
: define-float-jump ( word op -- )
- [ "x" operand 0 "y" operand FCMPU ] swap add
+ [ "x" operand 0 "y" operand FCMPU ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
- { float< BLT }
- { float<= BLE }
- { float> BGT }
- { float>= BGE }
- { float= BEQ }
+ { float< BGE }
+ { float<= BGT }
+ { float> BLE }
+ { float>= BLT }
+ { float= BNE }
} [
first2 define-float-jump
] each
{ +output+ { "out" } }
} define-intrinsic
-\ type [
- "end" define-label
- ! Get the tag
- "y" operand "obj" operand tag-mask get ANDI
- ! Tag the tag
- "y" operand "x" operand %tag-fixnum
- ! Compare with object tag number (3).
- 0 "y" operand object tag-number CMPI
- ! Jump if the object doesn't store type info in its header
- "end" get BNE
- ! It does store type info in its header
- "x" operand "obj" operand header-offset LWZ
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } { f "y" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-\ class-hash [
- "end" define-label
- "tuple" define-label
- "object" define-label
- ! Get the tag
- "y" operand "obj" operand tag-mask get ANDI
- ! Compare with tuple tag number (2).
- 0 "y" operand tuple tag-number CMPI
- "tuple" get BEQ
- ! Compare with object tag number (3).
- 0 "y" operand object tag-number CMPI
- "object" get BEQ
- ! Tag the tag
- "y" operand "x" operand %tag-fixnum
- "end" get B
- "object" get resolve-label
- ! Load header type
- "x" operand "obj" operand header-offset LWZ
- "end" get B
- "tuple" get resolve-label
- ! Load class hash
- "x" operand "obj" operand tuple-class-offset LWZ
- "x" operand dup class-hash-offset LWZ
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } { f "y" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
: userenv ( reg -- )
#! Load the userenv pointer in a register.
"userenv" f rot %load-dlsym ;
} define-intrinsic
\ <tuple> [
- tuple "n" get 2 + cells %allot
- ! Store length
- "n" operand 12 LI
+ tuple "layout" get layout-size 2 + cells %allot
+ ! Store layout
+ "layout" get 12 load-indirect
12 11 cell STW
- ! Store class
- "class" operand 11 2 cells STW
! Zero out the rest of the tuple
f v>operand 12 LI
- "n" get 1- [ 12 11 rot 3 + cells STW ] each
+ "layout" get layout-size [ 12 11 rot 2 + cells STW ] each
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] H{
- { +input+ { { f "class" } { [ inline-array? ] "n" } } }
+ { +input+ { { [ tuple-layout? ] "layout" } } }
{ +scratch+ { { f "tuple" } } }
{ +output+ { "tuple" } }
} define-intrinsic
namespaces alien.c-types kernel system combinators ;
{
- { [ macosx? ] [
+ { [ os macosx? ] [
4 "longlong" c-type set-c-type-align
4 "ulonglong" c-type set-c-type-align
+ 4 "double" c-type set-c-type-align
] }
- { [ linux? ] [
+ { [ os linux? ] [
t "longlong" c-type set-c-type-stack-align?
t "ulonglong" c-type set-c-type-stack-align?
] }
} cond
-
-T{ ppc-backend } compiler-backend set-global
-
-macosx? [
- 4 "double" c-type set-c-type-align
-] when
cpu.architecture kernel kernel.private math namespaces sequences
generator.registers generator.fixup generator system layouts
alien.compiler combinators command-line
-compiler compiler.units io vocabs.loader ;
+compiler compiler.units io vocabs.loader accessors ;
IN: cpu.x86.32
-PREDICATE: x86-backend x86-32-backend
- x86-backend-cell 4 = ;
-
! We implement the FFI for Linux, OS X and Windows all at once.
! OS X requires that the stack be 16-byte aligned, and we do
! this on all platforms, sacrificing some stack space for
! code simplicity.
-M: x86-32-backend ds-reg ESI ;
-M: x86-32-backend rs-reg EDI ;
-M: x86-32-backend stack-reg ESP ;
-M: x86-32-backend xt-reg ECX ;
-M: x86-32-backend stack-save-reg EDX ;
+M: x86.32 ds-reg ESI ;
+M: x86.32 rs-reg EDI ;
+M: x86.32 stack-reg ESP ;
+M: x86.32 stack-save-reg EDX ;
+M: x86.32 temp-reg-1 EAX ;
+M: x86.32 temp-reg-2 ECX ;
M: temp-reg v>operand drop EBX ;
-M: x86-32-backend %alien-invoke ( symbol dll -- )
+M: x86.32 %alien-invoke ( symbol dll -- )
(CALL) rel-dlsym ;
! On x86, parameters are never passed in registers.
! On x86, we can always use an address as an operand
! directly.
-M: x86-32-backend address-operand ;
+M: x86.32 address-operand ;
-M: x86-32-backend fixnum>slot@ 1 SHR ;
+M: x86.32 fixnum>slot@ 1 SHR ;
-M: x86-32-backend prepare-division CDQ ;
+M: x86.32 prepare-division CDQ ;
-M: x86-32-backend load-indirect
+M: x86.32 load-indirect
0 [] MOV rc-absolute-cell rel-literal ;
M: object %load-param-reg 3drop ;
M: object %save-param-reg 3drop ;
-M: x86-32-backend %prepare-unbox ( -- )
+M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX.
EAX ESI [] MOV
ESI 4 SUB ;
f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %unbox ( n reg-class func -- )
+M: x86.32 %unbox ( n reg-class func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
-M: x86-32-backend %unbox-long-long ( n func -- )
+M: x86.32 %unbox-long-long ( n func -- )
(%unbox)
! Store the return value on the C stack
[
cell + stack@ EDX MOV
] when* ;
-M: x86-32-backend %unbox-struct-2
+M: x86.32 %unbox-struct-2
#! Alien must be in EAX.
4 [
EAX PUSH
EAX EAX [] MOV
] with-aligned-stack ;
-M: x86-32-backend %unbox-large-struct ( n size -- )
+M: x86.32 %unbox-large-struct ( n size -- )
#! Alien must be in EAX.
! Compute destination address
ECX ESP roll [+] LEA
over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
push-return-reg ;
-M: x86-32-backend %box ( n reg-class func -- )
+M: x86.32 %box ( n reg-class func -- )
over reg-size [
>r (%box) r> f %alien-invoke
] with-aligned-stack ;
#! integer, push [ESP+n]:[ESP+n+4] on the stack; we are
#! boxing a parameter being passed to a callback from C.
[
- T{ int-regs } box@
+ int-regs box@
EDX over stack@ MOV
EAX swap cell - stack@ MOV
] when*
EDX PUSH
EAX PUSH ;
-M: x86-32-backend %box-long-long ( n func -- )
+M: x86.32 %box-long-long ( n func -- )
8 [
>r (%box-long-long) r> f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %box-large-struct ( n size -- )
+M: x86.32 %box-large-struct ( n size -- )
! Compute destination address
[ swap struct-return@ ] keep
ECX ESP roll [+] LEA
"box_value_struct" f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %prepare-box-struct ( size -- )
+M: x86.32 %prepare-box-struct ( size -- )
! Compute target address for value struct return
EAX ESP rot f struct-return@ [+] LEA
! Store it as the first parameter
ESP [] EAX MOV ;
-M: x86-32-backend %unbox-struct-1
+M: x86.32 %unbox-struct-1
#! Alien must be in EAX.
4 [
EAX PUSH
EAX EAX [] MOV
] with-aligned-stack ;
-M: x86-32-backend %box-small-struct ( size -- )
+M: x86.32 %box-small-struct ( size -- )
#! Box a <= 8-byte struct returned in EAX:DX. OS X only.
12 [
PUSH
"box_small_struct" f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %prepare-alien-indirect ( -- )
+M: x86.32 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ EAX MOV ;
-M: x86-32-backend %alien-indirect ( -- )
+M: x86.32 %alien-indirect ( -- )
cell temp@ CALL ;
-M: x86-32-backend %alien-callback ( quot -- )
+M: x86.32 %alien-callback ( quot -- )
4 [
EAX load-indirect
EAX PUSH
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
-M: x86-32-backend %callback-value ( ctype -- )
+M: x86.32 %callback-value ( ctype -- )
! Align C stack
ESP 12 SUB
! Save top of data stack
! Unbox EAX
unbox-return ;
-M: x86-32-backend %cleanup ( alien-node -- )
+M: x86.32 %cleanup ( alien-node -- )
#! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue.
#! have to fix ESP.
{
{
- [ dup alien-node-abi "stdcall" = ]
+ [ dup abi>> "stdcall" = ]
[ alien-stack-frame ESP swap SUB ]
} {
- [ dup alien-node-return large-struct? ]
+ [ dup return>> large-struct? ]
[ drop EAX PUSH ]
- } {
- [ t ] [ drop ]
}
+ [ drop ]
} cond ;
-M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ;
+M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
-windows? [
+os windows? [
cell "longlong" c-type set-c-type-align
cell "ulonglong" c-type set-c-type-align
-] unless
-
-windows? [
4 "double" c-type set-c-type-align
] unless
-T{ x86-backend f 4 } compiler-backend set-global
-
: sse2? "Intrinsic" throw ;
\ sse2? [
EDX 26 SHR
EDX 1 AND
{ EAX EBX ECX EDX } [ POP ] each
- JNE
+ JE
] { } define-if-intrinsic
"-no-sse2" cli-args member? [
splitting assocs ;
IN: cpu.x86.64
-PREDICATE: x86-backend amd64-backend
- x86-backend-cell 8 = ;
-
-M: amd64-backend ds-reg R14 ;
-M: amd64-backend rs-reg R15 ;
-M: amd64-backend stack-reg RSP ;
-M: amd64-backend xt-reg RCX ;
-M: amd64-backend stack-save-reg RSI ;
+M: x86.64 ds-reg R14 ;
+M: x86.64 rs-reg R15 ;
+M: x86.64 stack-reg RSP ;
+M: x86.64 stack-save-reg RSI ;
+M: x86.64 temp-reg-1 RAX ;
+M: x86.64 temp-reg-2 RCX ;
M: temp-reg v>operand drop RBX ;
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-M: amd64-backend address-operand ( address -- operand )
+M: x86.64 address-operand ( address -- operand )
#! On AMD64, we have to load 64-bit addresses into a
#! scratch register first. The usage of R11 here is a hack.
#! This word can only be called right before a subroutine
#! call, where all vregs have been flushed anyway.
temp-reg v>operand [ swap MOV ] keep ;
-M: amd64-backend fixnum>slot@ drop ;
+M: x86.64 fixnum>slot@ drop ;
-M: amd64-backend prepare-division CQO ;
+M: x86.64 prepare-division CQO ;
-M: amd64-backend load-indirect ( literal reg -- )
+M: x86.64 load-indirect ( literal reg -- )
0 [] MOV rc-relative rel-literal ;
M: stack-params %load-param-reg
M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-param-reg ;
-M: amd64-backend %prepare-unbox ( -- )
+M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack
RDI R14 [] MOV
R14 cell SUB ;
-M: amd64-backend %unbox ( n reg-class func -- )
+M: x86.64 %unbox ( n reg-class func -- )
! Call the unboxer
f %alien-invoke
! Store the return value on the C stack
over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
-M: amd64-backend %unbox-long-long ( n func -- )
- T{ int-regs } swap %unbox ;
+M: x86.64 %unbox-long-long ( n func -- )
+ int-regs swap %unbox ;
-M: amd64-backend %unbox-struct-1 ( -- )
+M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load first cell
RAX RAX [] MOV ;
-M: amd64-backend %unbox-struct-2 ( -- )
+M: x86.64 %unbox-struct-2 ( -- )
#! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load second cell
! Load first cell
RAX RAX [] MOV ;
-M: amd64-backend %unbox-large-struct ( n size -- )
+M: x86.64 %unbox-large-struct ( n size -- )
! Source is in RDI
! Load destination address
RSI RSP roll [+] LEA
0 over param-reg swap return-reg
2dup eq? [ 2drop ] [ MOV ] if ;
-M: amd64-backend %box ( n reg-class func -- )
+M: x86.64 %box ( n reg-class func -- )
rot [
rot [ 0 swap param-reg ] keep %load-param-reg
] [
] if*
f %alien-invoke ;
-M: amd64-backend %box-long-long ( n func -- )
- T{ int-regs } swap %box ;
+M: x86.64 %box-long-long ( n func -- )
+ int-regs swap %box ;
-M: amd64-backend struct-small-enough? ( size -- ? ) 2 cells <= ;
+M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
-M: amd64-backend %box-small-struct ( size -- )
+M: x86.64 %box-small-struct ( size -- )
#! Box a <= 16-byte struct returned in RAX:RDX.
RDI RAX MOV
RSI RDX MOV
RDX swap MOV
"box_small_struct" f %alien-invoke ;
-M: amd64-backend %box-large-struct ( n size -- )
+M: x86.64 %box-large-struct ( n size -- )
! Struct size is parameter 2
RSI over MOV
! Compute destination address
! Copy the struct from the C stack
"box_value_struct" f %alien-invoke ;
-M: amd64-backend %prepare-box-struct ( size -- )
+M: x86.64 %prepare-box-struct ( size -- )
! Compute target address for value struct return
RAX RSP rot f struct-return@ [+] LEA
RSP 0 [+] RAX MOV ;
-M: amd64-backend %prepare-var-args RAX RAX XOR ;
+M: x86.64 %prepare-var-args RAX RAX XOR ;
-M: amd64-backend %alien-invoke ( symbol dll -- )
+M: x86.64 %alien-invoke ( symbol dll -- )
0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
-M: amd64-backend %prepare-alien-indirect ( -- )
+M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
cell temp@ RAX MOV ;
-M: amd64-backend %alien-indirect ( -- )
+M: x86.64 %alien-indirect ( -- )
cell temp@ CALL ;
-M: amd64-backend %alien-callback ( quot -- )
+M: x86.64 %alien-callback ( quot -- )
RDI load-indirect "c_to_factor" f %alien-invoke ;
-M: amd64-backend %callback-value ( ctype -- )
+M: x86.64 %callback-value ( ctype -- )
! Save top of data stack
%prepare-unbox
! Put former top of data stack in RDI
! Unbox former top of data stack to return registers
unbox-return ;
-M: amd64-backend %cleanup ( alien-node -- ) drop ;
+M: x86.64 %cleanup ( alien-node -- ) drop ;
-M: amd64-backend %unwind ( n -- ) drop %epilogue-later 0 RET ;
+M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
USE: cpu.x86.intrinsics
\ alien-signed-4 small-reg-32 define-signed-getter
\ set-alien-signed-4 small-reg-32 define-setter
-T{ x86-backend f 8 } compiler-backend set-global
-
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
-T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>
+stack-params "__stack_value" c-type set-c-type-reg-class >>
: struct-types&offset ( struct-type -- pairs )
struct-type-fields [
] [
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
- T{ int-regs } swap member?
+ int-regs swap member?
"void*" "double" ? c-type ,
] each
] if ;
: object@ ( n -- operand ) cells (object@) ;
-: load-zone-ptr ( -- )
+: load-zone-ptr ( reg -- )
#! Load pointer to start of zone array
- "nursery" f allot-reg %alien-global ;
+ 0 MOV "nursery" f rc-absolute-cell rel-dlsym ;
: load-allot-ptr ( -- )
- load-zone-ptr
+ allot-reg load-zone-ptr
allot-reg PUSH
allot-reg dup cell [+] MOV ;
allot-reg POP
allot-reg cell [+] swap 8 align ADD ;
+M: x86 %gc ( -- )
+ "end" define-label
+ temp-reg-1 load-zone-ptr
+ temp-reg-2 temp-reg-1 cell [+] MOV
+ temp-reg-2 1024 ADD
+ temp-reg-1 temp-reg-1 3 cells [+] MOV
+ temp-reg-2 temp-reg-1 CMP
+ "end" get JLE
+ 0 frame-required
+ %prepare-alien-invoke
+ "minor_gc" f %alien-invoke
+ "end" resolve-label ;
+
: store-header ( header -- )
0 object@ swap type-number tag-fixnum MOV ;
allot-reg swap tag-number OR
allot-reg MOV ;
-M: x86-backend %box-float ( dst src -- )
+M: x86 %box-float ( dst src -- )
#! Only called by pentium4 backend, uses SSE2 instruction
#! dest is a loc or a vreg
float 16 [
"end" resolve-label
] with-scope ;
-M: x86-backend %box-alien ( dst src -- )
+M: x86 %box-alien ( dst src -- )
[
{ "end" "f" } [ define-label ] each
dup v>operand 0 CMP
] %allot
"end" get JMP
"f" resolve-label
- f [ v>operand ] 2apply MOV
+ f [ v>operand ] bi@ MOV
"end" resolve-label
] with-scope ;
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.compiler arrays
cpu.x86.assembler cpu.architecture kernel kernel.private math
generator.fixup system layouts combinators compiler.constants ;
IN: cpu.x86.architecture
-TUPLE: x86-backend cell ;
-
-HOOK: ds-reg compiler-backend
-HOOK: rs-reg compiler-backend
-HOOK: stack-reg compiler-backend
-HOOK: xt-reg compiler-backend
-HOOK: stack-save-reg compiler-backend
+HOOK: ds-reg cpu
+HOOK: rs-reg cpu
+HOOK: stack-reg cpu
+HOOK: stack-save-reg cpu
: stack@ stack-reg swap [+] ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ;
-: MOVSS/D float-regs-size 4 = [ MOVSS ] [ MOVSD ] if ;
+GENERIC: MOVSS/D ( dst src reg-class -- )
+
+M: single-float-regs MOVSS/D drop MOVSS ;
+
+M: double-float-regs MOVSS/D drop MOVSD ;
M: float-regs %save-param-reg >r >r stack@ r> r> MOVSS/D ;
M: float-regs %load-param-reg >r swap stack@ r> MOVSS/D ;
GENERIC: load-return-reg ( stack@ reg-class -- )
GENERIC: store-return-reg ( stack@ reg-class -- )
-HOOK: address-operand compiler-backend ( address -- operand )
+! Only used by inline allocation
+HOOK: temp-reg-1 cpu
+HOOK: temp-reg-2 cpu
+
+HOOK: address-operand cpu ( address -- operand )
-HOOK: fixnum>slot@ compiler-backend
+HOOK: fixnum>slot@ cpu
-HOOK: prepare-division compiler-backend
+HOOK: prepare-division cpu
M: immediate load-literal v>operand swap v>operand MOV ;
-M: x86-backend stack-frame ( n -- i )
+M: x86 stack-frame ( n -- i )
3 cells + 16 align cell - ;
-M: x86-backend %save-word-xt ( -- )
- xt-reg 0 MOV rc-absolute-cell rel-this ;
+M: x86 %save-word-xt ( -- )
+ temp-reg v>operand 0 MOV rc-absolute-cell rel-this ;
: factor-area-size 4 cells ;
-M: x86-backend %prologue ( n -- )
+M: x86 %prologue ( n -- )
dup cell + PUSH
- xt-reg PUSH
+ temp-reg v>operand PUSH
stack-reg swap 2 cells - SUB ;
-M: x86-backend %epilogue ( n -- )
+M: x86 %epilogue ( n -- )
stack-reg swap ADD ;
: %alien-global ( symbol dll register -- )
[ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
-M: x86-backend %prepare-alien-invoke
+M: x86 %prepare-alien-invoke
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
temp-reg v>operand 2 cells [+] ds-reg MOV
temp-reg v>operand 3 cells [+] rs-reg MOV ;
-M: x86-backend %call ( label -- ) CALL ;
+M: x86 %call ( label -- ) CALL ;
-M: x86-backend %jump-label ( label -- ) JMP ;
+M: x86 %jump-label ( label -- ) JMP ;
-M: x86-backend %jump-t ( label -- )
- "flag" operand f v>operand CMP JNE ;
+M: x86 %jump-f ( label -- )
+ "flag" operand f v>operand CMP JE ;
: code-alignment ( -- n )
building get length dup cell align swap - ;
: align-code ( n -- )
0 <repetition> % ;
-M: x86-backend %dispatch ( -- )
+M: x86 %dispatch ( -- )
[
%epilogue-later
! Load jump table base. We use a temporary register
{ +clobber+ { "n" } }
} with-template ;
-M: x86-backend %dispatch-label ( word -- )
+M: x86 %dispatch-label ( word -- )
0 cell, rc-absolute-cell rel-word ;
-M: x86-backend %unbox-float ( dst src -- )
- [ v>operand ] 2apply float-offset [+] MOVSD ;
+M: x86 %unbox-float ( dst src -- )
+ [ v>operand ] bi@ float-offset [+] MOVSD ;
-M: x86-backend %peek [ v>operand ] 2apply MOV ;
+M: x86 %peek [ v>operand ] bi@ MOV ;
-M: x86-backend %replace swap %peek ;
+M: x86 %replace swap %peek ;
: (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
-M: x86-backend %inc-d ( n -- ) ds-reg (%inc) ;
+M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
-M: x86-backend %inc-r ( n -- ) rs-reg (%inc) ;
+M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
-M: x86-backend fp-shadows-int? ( -- ? ) f ;
+M: x86 fp-shadows-int? ( -- ? ) f ;
-M: x86-backend value-structs? t ;
+M: x86 value-structs? t ;
-M: x86-backend small-enough? ( n -- ? )
+M: x86 small-enough? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;
: %untag ( reg -- ) tag-mask get bitnot AND ;
\ stack-frame get swap -
] ?if ;
-HOOK: %unbox-struct-1 compiler-backend ( -- )
+HOOK: %unbox-struct-1 cpu ( -- )
-HOOK: %unbox-struct-2 compiler-backend ( -- )
+HOOK: %unbox-struct-2 cpu ( -- )
-M: x86-backend %unbox-small-struct ( size -- )
+M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
} case ;
-M: x86-backend struct-small-enough? ( size -- ? )
+M: x86 struct-small-enough? ( size -- ? )
{ 1 2 4 8 } member?
- os { "linux" "solaris" } member? not and ;
+ os { linux netbsd solaris } member? not and ;
-M: x86-backend %return ( -- ) 0 %unwind ;
+M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics
-M: x86-backend %unbox-byte-array ( dst src -- )
- [ v>operand ] 2apply byte-array-offset [+] LEA ;
+M: x86 %unbox-byte-array ( dst src -- )
+ [ v>operand ] bi@ byte-array-offset [+] LEA ;
-M: x86-backend %unbox-alien ( dst src -- )
- [ v>operand ] 2apply alien-offset [+] MOV ;
+M: x86 %unbox-alien ( dst src -- )
+ [ v>operand ] bi@ alien-offset [+] MOV ;
-M: x86-backend %unbox-f ( dst src -- )
+M: x86 %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
-M: x86-backend %unbox-any-c-ptr ( dst src -- )
+M: x86 %unbox-any-c-ptr ( dst src -- )
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in ds-reg
ds-reg PUSH
M: object extended? drop f ;
-PREDICATE: word register "register" word-prop ;
+PREDICATE: register < word
+ "register" word-prop ;
-PREDICATE: register register-8 "register-size" word-prop 8 = ;
-PREDICATE: register register-16 "register-size" word-prop 16 = ;
-PREDICATE: register register-32 "register-size" word-prop 32 = ;
-PREDICATE: register register-64 "register-size" word-prop 64 = ;
-PREDICATE: register register-128 "register-size" word-prop 128 = ;
+PREDICATE: register-8 < register
+ "register-size" word-prop 8 = ;
+
+PREDICATE: register-16 < register
+ "register-size" word-prop 16 = ;
+
+PREDICATE: register-32 < register
+ "register-size" word-prop 32 = ;
+
+PREDICATE: register-64 < register
+ "register-size" word-prop 64 = ;
+
+PREDICATE: register-128 < register
+ "register-size" word-prop 128 = ;
M: register extended? "register" word-prop 7 > ;
canonicalize-ESP ;
: <indirect> ( base index scale displacement -- indirect )
- indirect construct-boa dup canonicalize ;
+ indirect boa dup canonicalize ;
: reg-code "register" word-prop 7 bitand ;
{
{ [ dup register-128? ] [ drop operand-64? ] }
{ [ dup not ] [ drop operand-64? ] }
- { [ t ] [ nip operand-64? ] }
+ [ nip operand-64? ]
} cond and ;
: rex.r
: opcode-or ( opcode mask -- opcode' )
swap dup array?
- [ 1 cut* first rot bitor add ] [ bitor ] if ;
+ [ 1 cut* first rot bitor suffix ] [ bitor ] if ;
: 1-operand ( op reg rex.w opcode -- )
#! The 'reg' is not really a register, but a value for the
M: register (MOV-I) t HEX: b8 short-operand cell, ;
M: operand (MOV-I) BIN: 000 t HEX: c7 1-operand 4, ;
-PREDICATE: word callable register? not ;
+PREDICATE: callable < word register? not ;
GENERIC: MOV ( dst src -- )
M: integer MOV swap (MOV-I) ;
words generic byte-arrays hashtables hashtables.private
generator generator.registers generator.fixup sequences.private
sbufs sbufs.private vectors vectors.private layouts system
-tuples.private strings.private slots.private compiler.constants
-;
+classes.tuple.private strings.private slots.private
+compiler.constants ;
IN: cpu.x86.intrinsics
! Type checks
{ +output+ { "in" } }
} define-intrinsic
-\ type [
- "end" define-label
- ! Make a copy
- "x" operand "obj" operand MOV
- ! Get the tag
- "x" operand tag-mask get AND
- ! Tag the tag
- "x" operand %tag-fixnum
- ! Compare with object tag number (3).
- "x" operand object tag-number tag-fixnum CMP
- "end" get JNE
- ! If we have equality, load type from header
- "x" operand "obj" operand -3 [+] MOV
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
-\ class-hash [
- "end" define-label
- "tuple" define-label
- "object" define-label
- ! Make a copy
- "x" operand "obj" operand MOV
- ! Get the tag
- "x" operand tag-mask get AND
- ! Tag the tag
- "x" operand %tag-fixnum
- ! Compare with tuple tag number (2).
- "x" operand tuple tag-number tag-fixnum CMP
- "tuple" get JE
- ! Compare with object tag number (3).
- "x" operand object tag-number tag-fixnum CMP
- "object" get JE
- "end" get JMP
- "object" get resolve-label
- ! Load header type
- "x" operand "obj" operand header-offset [+] MOV
- "end" get JMP
- "tuple" get resolve-label
- ! Load class hash
- "x" operand "obj" operand tuple-class-offset [+] MOV
- "x" operand dup class-hash-offset [+] MOV
- "end" resolve-label
-] H{
- { +input+ { { f "obj" } } }
- { +scratch+ { { f "x" } } }
- { +output+ { "x" } }
-} define-intrinsic
-
! Slots
: %slot-literal-known-tag
"obj" operand
! Fixnums
: fixnum-op ( op hash -- pair )
- >r [ "x" operand "y" operand ] swap add r> 2array ;
+ >r [ "x" operand "y" operand ] swap suffix r> 2array ;
: fixnum-value-op ( op -- pair )
H{
\ fixnum- \ SUB overflow-template
: fixnum-jump ( op inputs -- pair )
- >r [ "x" operand "y" operand CMP ] swap add r> 2array ;
+ >r [ "x" operand "y" operand CMP ] swap suffix r> 2array ;
: fixnum-value-jump ( op -- pair )
{ { f "x" } { [ small-tagged? ] "y" } } fixnum-jump ;
2array define-if-intrinsics ;
{
- { fixnum< JL }
- { fixnum<= JLE }
- { fixnum> JG }
- { fixnum>= JGE }
- { eq? JE }
+ { fixnum< JGE }
+ { fixnum<= JG }
+ { fixnum> JLE }
+ { fixnum>= JL }
+ { eq? JNE }
} [
first2 define-fixnum-jump
] each
} define-intrinsic
\ <tuple> [
- tuple "n" get 2 + cells [
- ! Store length
- 1 object@ "n" operand MOV
- ! Store class
- 2 object@ "class" operand MOV
+ tuple "layout" get layout-size 2 + cells [
+ ! Store layout
+ "layout" get "scratch" get load-literal
+ 1 object@ "scratch" operand MOV
! Zero out the rest of the tuple
- "n" operand 1- [ 3 + object@ f v>operand MOV ] each
+ "layout" get layout-size [
+ 2 + object@ f v>operand MOV
+ ] each
! Store tagged ptr in reg
"tuple" get tuple %store-tagged
] %allot
] H{
- { +input+ { { f "class" } { [ inline-array? ] "n" } } }
- { +scratch+ { { f "tuple" } } }
+ { +input+ { { [ tuple-layout? ] "layout" } } }
+ { +scratch+ { { f "tuple" } { f "scratch" } } }
{ +output+ { "tuple" } }
} define-intrinsic
IN: cpu.x86.sse2
: define-float-op ( word op -- )
- [ "x" operand "y" operand ] swap add H{
+ [ "x" operand "y" operand ] swap suffix H{
{ +input+ { { float "x" } { float "y" } } }
{ +output+ { "x" } }
} define-intrinsic ;
] each
: define-float-jump ( word op -- )
- [ "x" operand "y" operand UCOMISD ] swap add
+ [ "x" operand "y" operand UCOMISD ] swap suffix
{ { float "x" } { float "y" } } define-if-intrinsic ;
{
- { float< JB }
- { float<= JBE }
- { float> JA }
- { float>= JAE }
- { float= JE }
+ { float< JAE }
+ { float<= JA }
+ { float> JBE }
+ { float>= JB }
+ { float= JNE }
} [
first2 define-float-jump
] each
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations system debugger.private ;
+help generic.standard continuations system debugger.private
+io.files.private ;
IN: debugger
ARTICLE: "errors-assert" "Assertions"
HELP: try
{ $values { "quot" "a quotation" } }
-{ $description "Calls the quotation. If it throws an error, calls " { $link error-hook } " with the error and restores the data stack." } ;
+{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
+{ $examples
+ "The following example prints an error and keeps going:"
+ { $code
+ "[ \"error\" throw ] try"
+ "\"still running...\" print"
+ }
+ { $link "listener" } " uses " { $link try } " to recover from user errors."
+} ;
HELP: expired-error.
{ $error-description "Thrown by " { $link alien-address } " and " { $link alien-invoke } " if an " { $link alien } " object passed in as a parameter has expired. Alien objects expire if they are saved an image which is subsequently loaded; this prevents a certain class of programming errors, usually attempts to use uninitialized objects, since holding a C address is meaningless between sessions." }
USING: arrays definitions generic hashtables inspector io kernel
math namespaces prettyprint sequences assocs sequences.private
strings io.styles vectors words system splitting math.parser
-tuples continuations continuations.private combinators
-generic.math io.streams.duplex classes compiler.units
-generic.standard vocabs threads threads.private init
-kernel.private libc ;
+classes.tuple continuations continuations.private combinators
+generic.math io.streams.duplex classes.builtin classes
+compiler.units generic.standard vocabs threads threads.private
+init kernel.private libc io.encodings mirrors accessors ;
IN: debugger
GENERIC: error. ( error -- )
: try ( quot -- )
[ error-hook get call ] recover ;
-TUPLE: assert got expect ;
-
-: assert ( got expect -- * ) \ assert construct-boa throw ;
+ERROR: assert got expect ;
: assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
: depth ( -- n ) datastack length ;
: trim-datastacks ( seq1 seq2 -- seq1' seq2' )
- 2dup [ length ] 2apply min tuck tail >r tail r> ;
-
-TUPLE: relative-underflow stack ;
+ 2dup [ length ] bi@ min tuck tail >r tail r> ;
-: relative-underflow ( before after -- * )
- trim-datastacks nip \ relative-underflow construct-boa throw ;
+ERROR: relative-underflow stack ;
M: relative-underflow summary
drop "Too many items removed from data stack" ;
-TUPLE: relative-overflow stack ;
+ERROR: relative-overflow stack ;
M: relative-overflow summary
drop "Superfluous items pushed to data stack" ;
-: relative-overflow ( before after -- * )
- trim-datastacks drop \ relative-overflow construct-boa throw ;
-
: assert-depth ( quot -- )
>r datastack r> swap slip >r datastack r>
2dup [ length ] compare sgn {
- { -1 [ relative-underflow ] }
+ { -1 [ trim-datastacks nip relative-underflow ] }
{ 0 [ 2drop ] }
- { 1 [ relative-overflow ] }
+ { 1 [ trim-datastacks drop relative-overflow ] }
} case ; inline
: expired-error. ( obj -- )
: primitive-error.
"Unimplemented primitive" print drop ;
-PREDICATE: array kernel-error ( obj -- ? )
+PREDICATE: kernel-error < array
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
- { [ t ] [ second 0 15 between? ] }
+ [ second 0 15 between? ]
} cond ;
: kernel-errors
M: no-math-method summary
drop "No suitable arithmetic method" ;
-M: check-closed summary
+M: no-next-method summary
+ drop "Executing call-next-method from least-specific method" ;
+
+M: inconsistent-next-method summary
+ drop "Executing call-next-method with inconsistent parameters" ;
+
+M: stream-closed-twice summary
drop "Attempt to perform I/O on closed stream" ;
M: check-method summary
drop "Invalid parameters for create-method" ;
-M: check-tuple summary
- drop "Invalid class for define-constructor" ;
+M: no-tuple-class summary
+ drop "BOA constructors can only be defined for tuple classes" ;
+
+M: bad-superclass summary
+ drop "Tuple classes can only inherit from other tuple classes" ;
M: no-cond summary
drop "Fall-through in cond" ;
M: bounds-error summary drop "Sequence index out of bounds" ;
-M: condition error. delegate error. ;
+M: condition error. error>> error. ;
-M: condition error-help drop f ;
+M: condition summary error>> summary ;
+
+M: condition error-help error>> error-help ;
M: assert summary drop "Assertion failed" ;
M: no-vocab summary
drop "Vocabulary does not exist" ;
-M: check-ptr summary
+M: bad-ptr summary
drop "Memory allocation failed" ;
M: double-free summary
] bind
] if ;
+M: encode-error summary drop "Character encoding error" ;
+
+M: decode-error summary drop "Character decoding error" ;
+
+M: no-such-slot summary drop "No such slot" ;
+
+M: immutable-slot summary drop "Slot is immutable" ;
+
<PRIVATE
: init-debugger ( -- )
{ $subsection forget }
"Definitions can answer a sequence of definitions they directly depend on:"
{ $subsection uses }
-"When a definition is changed, all definitions which depend on it are notified via a hook:"
-{ $subsection redefined* }
"Definitions must implement a few operations used for printing them in source form:"
{ $subsection synopsis* }
{ $subsection definer }
{ $description "Outputs a sequence of definitions that directly call the given definition." }
{ $notes "The sequence might include the definition itself, if it is a recursive word." } ;
-HELP: redefined*
-{ $values { "defspec" "a definition specifier" } }
-{ $contract "Updates the definition to cope with a callee being redefined." }
-$low-level-note ;
-
HELP: unxref
{ $values { "defspec" "a definition specifier" } }
{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." }
USING: tools.test generic kernel definitions sequences
compiler.units words ;
-TUPLE: combination-1 ;
-
-M: combination-1 perform-combination 2drop [ ] ;
-
-M: combination-1 make-default-method 2drop [ "No method" throw ] ;
-
-SYMBOL: generic-1
-
-[
- generic-1 T{ combination-1 } define-generic
-
- object \ generic-1 create-method [ ] define
-] with-compilation-unit
-
-[ ] [
- [
- { combination-1 { object generic-1 } } forget-all
- ] with-compilation-unit
-] unit-test
-
GENERIC: some-generic ( a -- b )
USE: arrays
IN: definitions
USING: kernel sequences namespaces assocs graphs ;
-TUPLE: no-compilation-unit definition ;
+ERROR: no-compilation-unit definition ;
-: no-compilation-unit ( definition -- * )
- \ no-compilation-unit construct-boa throw ;
+SYMBOL: changed-definitions
+
+: changed-definition ( defspec -- )
+ dup changed-definitions get
+ [ no-compilation-unit ] unless*
+ set-at ;
GENERIC: where ( defspec -- loc )
: usage ( defspec -- seq ) \ f or crossref get at keys ;
-GENERIC: redefined* ( defspec -- )
-
-M: object redefined* drop ;
-
-: redefined ( defspec -- )
- [ crossref get at ] closure [ drop redefined* ] assoc-each ;
-
: unxref ( defspec -- )
dup uses crossref get remove-vertex ;
{ $see-also push-front push-back pop-front pop-front* pop-back } ;
HELP: dlist-find
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." }
{ $notes "Returns a boolean to allow dlists to store " { $link f } "."
$nl
} ;
HELP: dlist-contains?
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
{ $notes "This operation is O(n)." } ;
HELP: delete-node-if*
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } }
{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." }
{ $notes "This operation is O(n)." } ;
HELP: delete-node-if
-{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "obj/f" "an object or " { $link f } } }
{ $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." }
{ $notes "This operation is O(n)." } ;
HELP: dlist-each
-{ $values { "quot" quotation } { "dlist" { $link dlist } } }
+{ $values { "dlist" { $link dlist } } { "quot" quotation } }
{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ;
USING: dlists dlists.private kernel tools.test random assocs
-hashtables sequences namespaces sorting debugger io prettyprint
+sets sequences namespaces sorting debugger io prettyprint
math ;
IN: dlists.tests
dlist-front dlist-node-next dlist-node-next
] unit-test
-[ f f ] [ <dlist> [ 1 = ] swap dlist-find ] unit-test
-[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-find ] unit-test
-[ f f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-find ] unit-test
-[ f ] [ <dlist> 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test
-
-[ 1 ] [ <dlist> 1 over push-back [ 1 = ] swap delete-node-if ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
-[ t ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test
-[ 0 ] [ <dlist> 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
-[ 1 ] [ <dlist> 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test
-[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test
+[ f f ] [ <dlist> [ 1 = ] dlist-find ] unit-test
+[ 1 t ] [ <dlist> 1 over push-back [ 1 = ] dlist-find ] unit-test
+[ f f ] [ <dlist> 1 over push-back [ 2 = ] dlist-find ] unit-test
+[ f ] [ <dlist> 1 over push-back [ 2 = ] dlist-contains? ] unit-test
+[ t ] [ <dlist> 1 over push-back [ 1 = ] dlist-contains? ] unit-test
+
+[ 1 ] [ <dlist> 1 over push-back [ 1 = ] delete-node-if ] unit-test
+[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
+[ t ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-empty? ] unit-test
+[ 0 ] [ <dlist> 1 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
+[ 1 ] [ <dlist> 1 over push-back 2 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 1 = ] delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 2 = ] delete-node-if drop dlist-length ] unit-test
+[ 2 ] [ <dlist> 1 over push-back 2 over push-back 3 over push-back dup [ 3 = ] delete-node-if drop dlist-length ] unit-test
[ 0 ] [ <dlist> dlist-length ] unit-test
[ 1 ] [ <dlist> 1 over push-front dlist-length ] unit-test
[ 0 ] [ <dlist> 1 over push-front dup pop-front* dlist-length ] unit-test
: assert-same-elements
- [ prune natural-sort ] 2apply assert= ;
+ [ prune natural-sort ] bi@ assert= ;
: dlist-push-all [ push-front ] curry each ;
[ dlist-push-all ] keep
[ dlist-delete-all ] keep
dlist>array
- ] 2keep seq-diff assert-same-elements
+ ] 2keep diff assert-same-elements
] unit-test
[ ] [
-! Copyright (C) 2007 Mackenzie Straight, Doug Coleman.
+! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
+! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math sequences ;
+USING: combinators kernel math sequences accessors ;
IN: dlists
TUPLE: dlist front back length ;
: <dlist> ( -- obj )
- dlist construct-empty
- 0 over set-dlist-length ;
+ dlist new
+ 0 >>length ;
-: dlist-empty? ( dlist -- ? ) dlist-front not ;
+: dlist-empty? ( dlist -- ? ) front>> not ;
<PRIVATE
+
TUPLE: dlist-node obj prev next ;
+
C: <dlist-node> dlist-node
: inc-length ( dlist -- )
- [ dlist-length 1+ ] keep set-dlist-length ; inline
+ [ 1+ ] change-length drop ; inline
: dec-length ( dlist -- )
- [ dlist-length 1- ] keep set-dlist-length ; inline
+ [ 1- ] change-length drop ; inline
: set-prev-when ( dlist-node dlist-node/f -- )
- [ set-dlist-node-prev ] [ drop ] if* ;
+ [ (>>prev) ] [ drop ] if* ;
: set-next-when ( dlist-node dlist-node/f -- )
- [ set-dlist-node-next ] [ drop ] if* ;
+ [ (>>next) ] [ drop ] if* ;
: set-next-prev ( dlist-node -- )
- dup dlist-node-next set-prev-when ;
+ dup next>> set-prev-when ;
: normalize-front ( dlist -- )
- dup dlist-back [ drop ] [ f swap set-dlist-front ] if ;
+ dup back>> [ f >>front ] unless drop ;
: normalize-back ( dlist -- )
- dup dlist-front [ drop ] [ f swap set-dlist-back ] if ;
+ dup front>> [ f >>back ] unless drop ;
: set-back-to-front ( dlist -- )
- dup dlist-back
- [ drop ] [ dup dlist-front swap set-dlist-back ] if ;
+ dup back>> [ dup front>> >>back ] unless drop ;
: set-front-to-back ( dlist -- )
- dup dlist-front
- [ drop ] [ dup dlist-back swap set-dlist-front ] if ;
+ dup front>> [ dup back>> >>front ] unless drop ;
-: (dlist-find-node) ( quot dlist-node -- node/f ? )
- dup dlist-node-obj pick dupd call [
- drop nip t
- ] [
- drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if*
- ] if ; inline
+: (dlist-find-node) ( dlist-node quot -- node/f ? )
+ over [
+ [ >r obj>> r> call ] 2keep rot
+ [ drop t ] [ >r next>> r> (dlist-find-node) ] if
+ ] [ 2drop f f ] if ; inline
-: dlist-find-node ( quot dlist -- node/f ? )
- dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; inline
+: dlist-find-node ( dlist quot -- node/f ? )
+ >r front>> r> (dlist-find-node) ; inline
-: (dlist-each-node) ( quot dlist -- )
- over
- [ 2dup call >r dlist-node-next r> (dlist-each-node) ]
- [ 2drop ] if ; inline
+: dlist-each-node ( dlist quot -- )
+ [ t ] compose dlist-find-node 2drop ; inline
-: dlist-each-node ( quot dlist -- )
- >r dlist-front r> (dlist-each-node) ; inline
PRIVATE>
: push-front* ( obj dlist -- dlist-node )
- [ dlist-front f swap <dlist-node> dup dup set-next-prev ] keep
- [ set-dlist-front ] keep
+ [ front>> f swap <dlist-node> dup dup set-next-prev ] keep
+ [ (>>front) ] keep
[ set-back-to-front ] keep
inc-length ;
[ push-front ] curry each ;
: push-back* ( obj dlist -- dlist-node )
- [ dlist-back f <dlist-node> ] keep
- [ dlist-back set-next-when ] 2keep
- [ set-dlist-back ] 2keep
+ [ back>> f <dlist-node> ] keep
+ [ back>> set-next-when ] 2keep
+ [ (>>back) ] 2keep
[ set-front-to-back ] keep
inc-length ;
[ push-back ] curry each ;
: peek-front ( dlist -- obj )
- dlist-front dlist-node-obj ;
+ front>> obj>> ;
: pop-front ( dlist -- obj )
- dup dlist-front [
- dup dlist-node-next
- f rot set-dlist-node-next
+ dup front>> [
+ dup next>>
+ f rot (>>next)
f over set-prev-when
- swap set-dlist-front
- ] 2keep dlist-node-obj
+ swap (>>front)
+ ] 2keep obj>>
swap [ normalize-back ] keep dec-length ;
: pop-front* ( dlist -- ) pop-front drop ;
: peek-back ( dlist -- obj )
- dlist-back dlist-node-obj ;
+ back>> obj>> ;
: pop-back ( dlist -- obj )
- dup dlist-back [
- dup dlist-node-prev
- f rot set-dlist-node-prev
+ dup back>> [
+ dup prev>>
+ f rot (>>prev)
f over set-next-when
- swap set-dlist-back
- ] 2keep dlist-node-obj
+ swap (>>back)
+ ] 2keep obj>>
swap [ normalize-front ] keep dec-length ;
: pop-back* ( dlist -- ) pop-back drop ;
-: dlist-find ( quot dlist -- obj/f ? )
- dlist-find-node dup [ >r dlist-node-obj r> ] when ; inline
+: dlist-find ( dlist quot -- obj/f ? )
+ dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
-: dlist-contains? ( quot dlist -- ? )
+: dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline
: unlink-node ( dlist-node -- )
- dup dlist-node-prev over dlist-node-next set-prev-when
- dup dlist-node-next swap dlist-node-prev set-next-when ;
+ dup prev>> over next>> set-prev-when
+ dup next>> swap prev>> set-next-when ;
: delete-node ( dlist dlist-node -- )
{
- { [ over dlist-front over eq? ] [ drop pop-front* ] }
- { [ over dlist-back over eq? ] [ drop pop-back* ] }
- { [ t ] [ unlink-node dec-length ] }
+ { [ over front>> over eq? ] [ drop pop-front* ] }
+ { [ over back>> over eq? ] [ drop pop-back* ] }
+ [ unlink-node dec-length ]
} cond ;
-: delete-node-if* ( quot dlist -- obj/f ? )
- tuck dlist-find-node [
- [ delete-node ] keep [ dlist-node-obj t ] [ f f ] if*
+: delete-node-if* ( dlist quot -- obj/f ? )
+ dupd dlist-find-node [
+ dup [
+ [ delete-node ] keep obj>> t
+ ] [
+ 2drop f f
+ ] if
] [
2drop f f
] if ; inline
-: delete-node-if ( quot dlist -- obj/f )
+: delete-node-if ( dlist quot -- obj/f )
delete-node-if* drop ; inline
: dlist-delete ( obj dlist -- obj/f )
- >r [ eq? ] curry r> delete-node-if ;
+ swap [ eq? ] curry delete-node-if ;
: dlist-delete-all ( dlist -- )
- f over set-dlist-front
- f over set-dlist-back
- 0 swap set-dlist-length ;
+ f >>front
+ f >>back
+ 0 >>length
+ drop ;
: dlist-each ( dlist quot -- )
- [ dlist-node-obj ] swap compose dlist-each-node ; inline
+ [ obj>> ] swap compose dlist-each-node ; inline
: dlist-slurp ( dlist quot -- )
over dlist-empty?
inline
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
-
: <effect> ( in out -- effect )
dup { "*" } sequence= [ drop { } t ] [ f ] if
- effect construct-boa ;
+ effect boa ;
: effect-height ( effect -- n )
dup effect-out length swap effect-in length - ;
{ [ dup not ] [ t ] }
{ [ over effect-terminated? ] [ t ] }
{ [ dup effect-terminated? ] [ f ] }
- { [ 2dup [ effect-in length ] 2apply > ] [ f ] }
- { [ 2dup [ effect-height ] 2apply = not ] [ f ] }
- { [ t ] [ t ] }
+ { [ 2dup [ effect-in length ] bi@ > ] [ f ] }
+ { [ 2dup [ effect-height ] bi@ = not ] [ f ] }
+ [ t ]
} cond 2nip ;
GENERIC: (stack-picture) ( obj -- str )
M: float-array like
drop dup float-array? [ >float-array ] unless ;
-M: float-array new drop 0.0 <float-array> ;
+M: float-array new-sequence drop 0.0 <float-array> ;
M: float-array equal?
over float-array? [ sequence= ] [ 2drop f ] if ;
+++ /dev/null
-USING: arrays float-arrays help.markup help.syntax kernel\r
-float-vectors.private combinators ;\r
-IN: float-vectors\r
-\r
-ARTICLE: "float-vectors" "Float vectors"\r
-"A float vector is a resizable mutable sequence of unsigned floats. The literal syntax is covered in " { $link "syntax-float-vectors" } ". Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."\r
-$nl\r
-"Float vectors form a class:"\r
-{ $subsection float-vector }\r
-{ $subsection float-vector? }\r
-"Creating float vectors:"\r
-{ $subsection >float-vector }\r
-{ $subsection <float-vector> }\r
-"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"\r
-{ $code "FV{ } clone" } ;\r
-\r
-ABOUT: "float-vectors"\r
-\r
-HELP: float-vector\r
-{ $description "The class of resizable float vectors. See " { $link "syntax-float-vectors" } " for syntax and " { $link "float-vectors" } " for general information." } ;\r
-\r
-HELP: <float-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }\r
-{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ;\r
-\r
-HELP: >float-vector\r
-{ $values { "seq" "a sequence" } { "float-vector" float-vector } }\r
-{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." }\r
-{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;\r
-\r
-HELP: float-array>vector\r
-{ $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } }\r
-{ $description "Creates a new float vector using the array for underlying storage with the specified initial length." }\r
-{ $warning "This word is in the " { $vocab-link "float-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >float-vector } " instead." } ;\r
+++ /dev/null
-IN: float-vectors.tests\r
-USING: tools.test float-vectors vectors sequences kernel ;\r
-\r
-[ 0 ] [ 123 <float-vector> length ] unit-test\r
-\r
-: do-it\r
- 12345 [ over push ] each ;\r
-\r
-[ t ] [\r
- 3 <float-vector> do-it\r
- 3 <vector> do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ FV{ } float-vector? ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable float-arrays ;\r
-IN: float-vectors\r
-\r
-<PRIVATE\r
-\r
-: float-array>vector ( float-array length -- float-vector )\r
- float-vector construct-boa ; inline\r
-\r
-PRIVATE>\r
-\r
-: <float-vector> ( n -- float-vector )\r
- 0.0 <float-array> 0 float-array>vector ; inline\r
-\r
-: >float-vector ( seq -- float-vector ) FV{ } clone-like ;\r
-\r
-M: float-vector like\r
- drop dup float-vector? [\r
- dup float-array?\r
- [ dup length float-array>vector ] [ >float-vector ] if\r
- ] unless ;\r
-\r
-M: float-vector new\r
- drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;\r
-\r
-M: float-vector equal?\r
- over float-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: float-array new-resizable drop <float-vector> ;\r
-\r
-INSTANCE: float-vector growable\r
{ $values { "obj" object } { "n" integer } }
{ $description "Adds a literal to the " { $link literal-table } ", if it is not already there, and outputs the index of the literal in the table. This literal can then be used as an argument for a " { $link rt-literal } " relocation with " { $link rel-fixup } "." } ;
-HELP: string>symbol
-{ $values { "str" string } { "alien" alien } }
-{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
-$nl
-"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
-
HELP: rel-dlsym
{ $values { "name" string } { "dll" "a " { $link dll } " or " { $link f } } { "class" "a relocation class" } }
{ $description "Records that the most recently assembled instruction contains a reference to the " { $snippet "name" } " symbol from " { $snippet "dll" } ". The correct " { $snippet "class" } " to use depends on instruction formats."
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables
kernel kernel.private math namespaces sequences words
-quotations strings alien layouts system combinators
+quotations strings alien.strings layouts system combinators
math.bitfields words.private cpu.architecture ;
IN: generator.fixup
TUPLE: frame-required n ;
-: frame-required ( n -- ) \ frame-required construct-boa , ;
+: frame-required ( n -- ) \ frame-required boa , ;
: stack-frame-size ( code -- n )
no-stack-frame [
TUPLE: label offset ;
-: <label> ( -- label ) label construct-empty ;
+: <label> ( -- label ) label new ;
M: label fixup*
compiled-offset swap set-label-offset ;
M: word fixup*
{
- { %prologue-later [ dup [ %prologue ] if-stack-frame ] }
- { %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
+ { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] }
+ { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] }
} case ;
SYMBOL: relocation-table
TUPLE: label-fixup label class ;
-: label-fixup ( label class -- ) \ label-fixup construct-boa , ;
+: label-fixup ( label class -- ) \ label-fixup boa , ;
M: label-fixup fixup*
dup label-fixup-class rc-absolute?
TUPLE: rel-fixup arg class type ;
-: rel-fixup ( arg class type -- ) \ rel-fixup construct-boa , ;
+: rel-fixup ( arg class type -- ) \ rel-fixup boa , ;
: (rel-fixup) ( arg class type offset -- pair )
pick rc-absolute-cell = cell 4 ? -
: add-literal ( obj -- n ) literal-table get push-new* ;
-: string>symbol ( str -- alien )
- [ wince? [ string>u16-alien ] [ string>char-alien ] if ]
- over string? [ call ] [ map ] if ;
-
: add-dlsym-literals ( symbol dll -- )
>r string>symbol r> 2array literal-table get push-all ;
{ [ dup compiled get key? ] [ drop ] }
{ [ dup inlined-block? ] [ drop ] }
{ [ dup primitive? ] [ drop ] }
- { [ t ] [ dup compile-queue get set-at ] }
+ [ dup compile-queue get set-at ]
} cond ;
: maybe-compile ( word -- )
compiled-stack-traces?
compiling-word get f ?
1vector literal-table set
- f compiling-word get compiled get set-at ;
+ f compiling-label get compiled get set-at ;
-: finish-compiling ( literals relocation labels code -- )
+: save-machine-code ( literals relocation labels code -- )
4array compiling-label get compiled get set-at ;
: with-generator ( node word label quot -- )
[
>r begin-compiling r>
{ } make fixup
- finish-compiling
+ save-machine-code
] with-scope ; inline
GENERIC: generate-node ( node -- next )
: word-dataflow ( word -- effect dataflow )
[
dup "no-effect" word-prop [ no-effect ] when
+ dup "no-compile" word-prop [ no-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] with-infer ;
: generate-if ( node label -- next )
<label> [
- >r >r node-children first2 generate-branch
+ >r >r node-children first2 swap generate-branch
r> r> end-false-branch resolve-label
generate-branch
init-templates
] keep resolve-label iterate-next ;
M: #if generate-node
- [ <label> dup %jump-t ]
+ [ <label> dup %jump-f ]
H{ { +input+ { { f "flag" } } } }
with-template
generate-if ;
"if-intrinsics" set-word-prop ;
: if>boolean-intrinsic ( quot -- )
- "true" define-label
+ "false" define-label
"end" define-label
- "true" get swap call
- f "if-scratch" get load-literal
- "end" get %jump-label
- "true" resolve-label
+ "false" get swap call
t "if-scratch" get load-literal
+ "end" get %jump-label
+ "false" resolve-label
+ f "if-scratch" get load-literal
"end" resolve-label
"if-scratch" get phantom-push ; inline
: define-if>boolean-intrinsics ( word intrinsics -- )
[
>r [ if>boolean-intrinsic ] curry r>
- { { f "if-scratch" } } +scratch+ associate union
+ { { f "if-scratch" } } +scratch+ associate assoc-union
] assoc-map "intrinsics" set-word-prop ;
: define-if-intrinsics ( word intrinsics -- )
! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs classes classes.private combinators
-cpu.architecture generator.fixup hashtables kernel layouts math
-namespaces quotations sequences system vectors words effects
-alien byte-arrays bit-arrays float-arrays ;
+USING: arrays assocs classes classes.private classes.algebra
+combinators cpu.architecture generator.fixup hashtables kernel
+layouts math namespaces quotations sequences system vectors
+words effects alien byte-arrays bit-arrays float-arrays
+accessors sets ;
IN: generator.registers
SYMBOL: +input+
SYMBOL: +clobber+
SYMBOL: known-tag
-! Register classes
-TUPLE: int-regs ;
-
-TUPLE: float-regs size ;
-
<PRIVATE
! Value protocol
M: value lazy-store 2drop ;
! A scratch register for computations
-TUPLE: vreg n ;
+TUPLE: vreg n reg-class ;
-: <vreg> ( n reg-class -- vreg )
- { set-vreg-n set-delegate } vreg construct ;
+C: <vreg> vreg ( n reg-class -- vreg )
-M: vreg v>operand dup vreg-n swap vregs nth ;
+M: vreg v>operand [ n>> ] [ reg-class>> ] bi vregs nth ;
M: vreg live-vregs* , ;
+M: vreg move-spec reg-class>> move-spec ;
INSTANCE: vreg value
M: float-regs operand-class* drop float ;
! Temporary register for stack shuffling
-TUPLE: temp-reg ;
-
-: temp-reg T{ temp-reg T{ int-regs } } ;
+SINGLETON: temp-reg
M: temp-reg move-spec drop f ;
! A data stack location.
TUPLE: ds-loc n class ;
-: <ds-loc> { set-ds-loc-n } ds-loc construct ;
+: <ds-loc> f ds-loc boa ;
M: ds-loc minimal-ds-loc* ds-loc-n min ;
M: ds-loc operand-class* ds-loc-class ;
M: ds-loc set-operand-class set-ds-loc-class ;
M: ds-loc live-loc?
- over ds-loc? [ [ ds-loc-n ] 2apply = not ] [ 2drop t ] if ;
+ over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
! A retain stack location.
TUPLE: rs-loc n class ;
-: <rs-loc> { set-rs-loc-n } rs-loc construct ;
-
+: <rs-loc> f rs-loc boa ;
M: rs-loc operand-class* rs-loc-class ;
M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
- over rs-loc? [ [ rs-loc-n ] 2apply = not ] [ 2drop t ] if ;
+ over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
UNION: loc ds-loc rs-loc ;
TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
- { set-tagged-vreg } tagged construct ;
+ f tagged boa ;
M: tagged v>operand tagged-vreg v>operand ;
M: tagged set-operand-class set-tagged-class ;
{ [ dup byte-array class< ] [ drop %unbox-byte-array ] }
{ [ dup bit-array class< ] [ drop %unbox-byte-array ] }
{ [ dup float-array class< ] [ drop %unbox-byte-array ] }
- { [ t ] [ drop %unbox-any-c-ptr ] }
+ [ drop %unbox-any-c-ptr ]
} cond ; inline
: %move-via-temp ( dst src -- )
%move ;
: %move ( dst src -- )
- 2dup [ move-spec ] 2apply 2array {
+ 2dup [ move-spec ] bi@ 2array {
{ { f f } [ %move-bug ] }
{ { f unboxed-c-ptr } [ %move-bug ] }
{ { f unboxed-byte-array } [ %move-bug ] }
} case ;
! A compile-time stack
-TUPLE: phantom-stack height ;
+TUPLE: phantom-stack height stack ;
-GENERIC: finalize-height ( stack -- )
+M: phantom-stack clone
+ call-next-method [ clone ] change-stack ;
-SYMBOL: phantom-d
-SYMBOL: phantom-r
+GENERIC: finalize-height ( stack -- )
-: <phantom-stack> ( class -- stack )
- >r
- V{ } clone 0
- { set-delegate set-phantom-stack-height }
- phantom-stack construct
- r> construct-delegate ;
+: new-phantom-stack ( class -- stack )
+ >r 0 V{ } clone r> boa ; inline
: (loc)
#! Utility for methods on <loc>
- phantom-stack-height - ;
+ height>> - ;
: (finalize-height) ( stack word -- )
#! We consolidate multiple stack height changes until the
#! last moment, and we emit the final height changing
#! instruction here.
- swap [
- phantom-stack-height
- dup zero? [ 2drop ] [ swap execute ] if
- 0
- ] keep set-phantom-stack-height ; inline
+ [
+ over zero? [ 2drop ] [ execute ] if 0
+ ] curry change-height drop ; inline
GENERIC: <loc> ( n stack -- loc )
-TUPLE: phantom-datastack ;
+TUPLE: phantom-datastack < phantom-stack ;
-: <phantom-datastack> phantom-datastack <phantom-stack> ;
+: <phantom-datastack> ( -- stack )
+ phantom-datastack new-phantom-stack ;
M: phantom-datastack <loc> (loc) <ds-loc> ;
M: phantom-datastack finalize-height
\ %inc-d (finalize-height) ;
-TUPLE: phantom-retainstack ;
+TUPLE: phantom-retainstack < phantom-stack ;
-: <phantom-retainstack> phantom-retainstack <phantom-stack> ;
+: <phantom-retainstack> ( -- stack )
+ phantom-retainstack new-phantom-stack ;
M: phantom-retainstack <loc> (loc) <rs-loc> ;
>r <reversed> r> [ <loc> ] curry map ;
: phantom-locs* ( phantom -- locs )
- dup length swap phantom-locs ;
+ [ stack>> length ] keep phantom-locs ;
+
+: phantoms ( -- phantom phantom )
+ phantom-datastack get phantom-retainstack get ;
: (each-loc) ( phantom quot -- )
- >r dup phantom-locs* swap r> 2each ; inline
+ >r [ phantom-locs* ] [ stack>> ] bi r> 2each ; inline
: each-loc ( quot -- )
- >r phantom-d get r> phantom-r get over
- >r >r (each-loc) r> r> (each-loc) ; inline
+ phantoms 2array swap [ (each-loc) ] curry each ; inline
: adjust-phantom ( n phantom -- )
- [ phantom-stack-height + ] keep set-phantom-stack-height ;
+ swap [ + ] curry change-height drop ;
-GENERIC: cut-phantom ( n phantom -- seq )
-
-M: phantom-stack cut-phantom
- [ delegate swap cut* swap ] keep set-delegate ;
+: cut-phantom ( n phantom -- seq )
+ swap [ cut* swap ] curry change-stack drop ;
: phantom-append ( seq stack -- )
- over length over adjust-phantom push-all ;
+ over length over adjust-phantom stack>> push-all ;
: add-locs ( n phantom -- )
- 2dup length <= [
+ 2dup stack>> length <= [
2drop
] [
[ phantom-locs ] keep
- [ length head-slice* ] keep
- [ append >vector ] keep
- delegate set-delegate
+ [ stack>> length head-slice* ] keep
+ [ append >vector ] change-stack drop
] if ;
: phantom-input ( n phantom -- seq )
2dup cut-phantom
>r >r neg r> adjust-phantom r> ;
-: phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
-
-: each-phantom ( quot -- ) phantoms rot 2apply ; inline
+: each-phantom ( quot -- ) phantoms rot bi@ ; inline
: finalize-heights ( -- ) [ finalize-height ] each-phantom ;
: live-vregs ( -- seq )
- [ [ [ live-vregs* ] each ] each-phantom ] { } make ;
+ [ [ stack>> [ live-vregs* ] each ] each-phantom ] { } make ;
: (live-locs) ( phantom -- seq )
#! Discard locs which haven't moved
- dup phantom-locs* swap 2array flip
+ [ phantom-locs* ] [ stack>> ] bi zip
[ live-loc? ] assoc-subset
values ;
! Computing free registers and initializing allocator
: reg-spec>class ( spec -- class )
- float eq?
- T{ float-regs f 8 } T{ int-regs } ? ;
+ float eq? double-float-regs int-regs ? ;
: free-vregs ( reg-class -- seq )
#! Free vregs in a given register class
\ free-vregs get at ;
: alloc-vreg ( spec -- reg )
- dup reg-spec>class free-vregs pop swap {
+ [ reg-spec>class free-vregs pop ] keep {
{ f [ <tagged> ] }
{ unboxed-alien [ <unboxed-alien> ] }
{ unboxed-byte-array [ <unboxed-byte-array> ] }
{ [ dup unboxed-c-ptr eq? ] [
over { unboxed-byte-array unboxed-alien } member?
] }
- { [ t ] [ f ] }
+ [ f ]
} cond 2nip ;
: allocation ( value spec -- reg-class )
{
{ [ dup quotation? ] [ 2drop f ] }
{ [ 2dup compatible? ] [ 2drop f ] }
- { [ t ] [ nip reg-spec>class ] }
+ [ nip reg-spec>class ]
} cond ;
: alloc-vreg-for ( value spec -- vreg )
- swap operand-class swap alloc-vreg
- dup tagged? [ tuck set-tagged-class ] [ nip ] if ;
+ alloc-vreg swap operand-class
+ over tagged? [ >>class ] [ drop ] if ;
M: value (lazy-load)
2dup allocation [
: (compute-free-vregs) ( used class -- vector )
#! Find all vregs in 'class' which are not in 'used'.
[ vregs length reverse ] keep
- [ <vreg> ] curry map seq-diff
+ [ <vreg> ] curry map diff
>vector ;
: compute-free-vregs ( -- )
#! Create a new hashtable for thee free-vregs variable.
live-vregs
- { T{ int-regs } T{ float-regs f 8 } }
+ { int-regs double-float-regs }
[ 2dup (compute-free-vregs) ] H{ } map>assoc
\ free-vregs set
drop ;
#! When shuffling more values than can fit in registers, we
#! need to find an area on the data stack which isn't in
#! use.
- dup phantom-stack-height neg [ minimal-ds-loc* ] reduce ;
+ [ stack>> ] [ height>> neg ] bi [ minimal-ds-loc* ] reduce ;
: find-tmp-loc ( -- n )
#! Find an area of the data stack which is not referenced
: slow-shuffle-mapping ( locs tmp -- pairs )
>r dup length r>
- [ swap - <ds-loc> ] curry map 2array flip ;
+ [ swap - <ds-loc> ] curry map zip ;
: slow-shuffle ( locs -- )
#! We don't have enough free registers to load all shuffle
: fast-shuffle? ( live-locs -- ? )
#! Test if we have enough free registers to load all
#! shuffle inputs at once.
- T{ int-regs } free-vregs [ length ] 2apply <= ;
+ int-regs free-vregs [ length ] bi@ <= ;
: finalize-locs ( -- )
#! Perform any deferred stack shuffling.
#! Kill register assignments but preserve constants and
#! class information.
dup phantom-locs*
- over [
+ over stack>> [
dup constant? [ nip ] [
operand-class over set-operand-class
] if
] 2map
- over delete-all
- swap push-all ;
+ over stack>> delete-all
+ swap stack>> push-all ;
: reset-phantoms ( -- )
[ reset-phantom ] each-phantom ;
: finalize-contents ( -- )
finalize-locs finalize-vregs reset-phantoms ;
-: %gc ( -- )
- 0 frame-required
- %prepare-alien-invoke
- "simple_gc" f %alien-invoke ;
-
! Loading stacks to vregs
: free-vregs? ( int# float# -- ? )
- T{ float-regs f 8 } free-vregs length <=
- >r T{ int-regs } free-vregs length <= r> and ;
+ double-float-regs free-vregs length <=
+ >r int-regs free-vregs length <= r> and ;
: phantom&spec ( phantom spec -- phantom' spec' )
+ >r stack>> r>
[ length f pad-left ] keep
- [ <reversed> ] 2apply ; inline
+ [ <reversed> ] bi@ ; inline
: phantom&spec-agree? ( phantom spec quot -- ? )
>r phantom&spec r> 2all? ; inline
: substitute-vregs ( values vregs -- )
[ vreg-substitution ] 2map
[ substitute-vreg? ] assoc-subset >hashtable
- [ substitute-here ] curry each-phantom ;
+ [ >r stack>> r> substitute-here ] curry each-phantom ;
: set-operand ( value var -- )
>r dup constant? [ constant-value ] when r> set ;
substitute-vregs ;
: load-inputs ( -- )
- +input+ get dup length phantom-d get phantom-input
- swap lazy-load ;
+ +input+ get
+ [ length phantom-datastack get phantom-input ] keep
+ lazy-load ;
: output-vregs ( -- seq seq )
- +output+ +clobber+ [ get [ get ] map ] 2apply ;
+ +output+ +clobber+ [ get [ get ] map ] bi@ ;
: clash? ( seq -- ? )
- phantoms append [
+ phantoms [ stack>> ] bi@ append [
dup cached? [ cached-vreg ] when swap member?
] with contains? ;
: count-input-vregs ( phantom spec -- )
phantom&spec [
- >r dup cached? [ cached-vreg ] when r> allocation
+ >r dup cached? [ cached-vreg ] when r> first allocation
] 2map count-vregs ;
: count-scratch-regs ( spec -- )
[ first reg-spec>class ] map count-vregs ;
: guess-vregs ( dinput rinput scratch -- int# float# )
- H{
- { T{ int-regs } 0 }
- { T{ float-regs 8 } 0 }
- } clone [
+ [
+ 0 int-regs set
+ 0 double-float-regs set
count-scratch-regs
- phantom-r get swap count-input-vregs
- phantom-d get swap count-input-vregs
- T{ int-regs } get T{ float-regs 8 } get
- ] bind ;
+ phantom-retainstack get swap count-input-vregs
+ phantom-datastack get swap count-input-vregs
+ int-regs get double-float-regs get
+ ] with-scope ;
: alloc-scratch ( -- )
+scratch+ get [ >r alloc-vreg r> set ] assoc-each ;
outputs-clash? [ finalize-contents ] when ;
: template-outputs ( -- )
- +output+ get [ get ] map phantom-d get phantom-append ;
+ +output+ get [ get ] map phantom-datastack get phantom-append ;
: value-matches? ( value spec -- ? )
#! If the spec is a quotation and the value is a literal
] if ;
: class-tag ( class -- tag/f )
- dup hi-tag class< [
- drop object tag-number
- ] [
- flatten-builtin-class keys
- dup length 1 = [ first tag-number ] [ drop f ] if
- ] if ;
+ class-tags dup length 1 = [ first ] [ drop f ] if ;
: class-matches? ( actual expected -- ? )
{
>r >r operand-class 2 r> ?nth class-matches? r> and ;
: template-matches? ( spec -- ? )
- phantom-d get +input+ rot at
+ phantom-datastack get +input+ rot at
[ spec-matches? ] phantom&spec-agree? ;
: ensure-template-vregs ( -- )
] unless ;
: clear-phantoms ( -- )
- [ delete-all ] each-phantom ;
+ [ stack>> delete-all ] each-phantom ;
PRIVATE>
: set-operand-classes ( classes -- )
- phantom-d get
+ phantom-datastack get
over length over add-locs
- [ set-operand-class ] 2reverse-each ;
+ stack>> [ set-operand-class ] 2reverse-each ;
: end-basic-block ( -- )
#! Commit all deferred stacking shuffling, and ensure the
finalize-contents
clear-phantoms
finalize-heights
- fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
+ fresh-objects get [ empty? [ %gc ] unless ] [ delete-all ] bi ;
: with-template ( quot hash -- )
clone [
: init-templates ( -- )
#! Initialize register allocator.
V{ } clone fresh-objects set
- <phantom-datastack> phantom-d set
- <phantom-retainstack> phantom-r set
+ <phantom-datastack> phantom-datastack set
+ <phantom-retainstack> phantom-retainstack set
compute-free-vregs ;
: copy-templates ( -- )
#! Copies register allocator state, used when compiling
#! branches.
fresh-objects [ clone ] change
- phantom-d [ clone ] change
- phantom-r [ clone ] change
+ phantom-datastack [ clone ] change
+ phantom-retainstack [ clone ] change
compute-free-vregs ;
: find-template ( templates -- pair/f )
operand-class immediate class< ;
: phantom-push ( obj -- )
- 1 phantom-d get adjust-phantom
- phantom-d get push ;
+ 1 phantom-datastack get adjust-phantom
+ phantom-datastack get stack>> push ;
: phantom-shuffle ( shuffle -- )
- [ effect-in length phantom-d get phantom-input ] keep
- shuffle* phantom-d get phantom-append ;
+ [ effect-in length phantom-datastack get phantom-input ] keep
+ shuffle* phantom-datastack get phantom-append ;
: phantom->r ( n -- )
- phantom-d get phantom-input
- phantom-r get phantom-append ;
+ phantom-datastack get phantom-input
+ phantom-retainstack get phantom-append ;
: phantom-r> ( n -- )
- phantom-r get phantom-input
- phantom-d get phantom-append ;
+ phantom-retainstack get phantom-input
+ phantom-datastack get phantom-append ;
-USING: help.markup help.syntax words classes definitions kernel
-alien sequences math quotations generic.standard generic.math
-combinators ;
+USING: help.markup help.syntax words classes classes.algebra
+definitions kernel alien sequences math quotations
+generic.standard generic.math combinators ;
IN: generic
ARTICLE: "method-order" "Method precedence"
{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
-{ $subsection methods }
+"Finding the most specific method for an object:"
+{ $subsection effective-method }
"A generic word contains methods; the list of methods specializing on a class can also be obtained:"
{ $subsection implementors }
"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
"Developing a custom method combination requires that a parsing word calling " { $link define-generic } " be defined; additionally, it is a good idea to implement the definition protocol words " { $link definer } " and " { $link synopsis* } " on the class of words having this method combination, to properly support developer tools."
$nl
"The combination quotation passed to " { $link define-generic } " has stack effect " { $snippet "( word -- quot )" } ". It's job is to call various introspection words, including at least obtaining the set of methods defined on the generic word, then combining these methods in some way to produce a quotation."
-$nl
-"Method combination utilities:"
-{ $subsection single-combination }
-{ $subsection class-predicates }
-{ $subsection simplify-alist }
-{ $subsection math-upgrade }
-{ $subsection object-method }
-{ $subsection error-method }
-"More quotation construction utilities can be found in " { $link "quotations" } " and " { $link "combinators-quot" } "."
{ $see-also "generic-introspection" } ;
+ARTICLE: "call-next-method" "Calling less-specific methods"
+"If a generic word is called with an object and multiple methods specialize on classes that this object is an instance of, usually the most specific method is called (" { $link "method-order" } ")."
+$nl
+"Less-specific methods can be called directly:"
+{ $subsection POSTPONE: call-next-method }
+"A lower-level word which the above expands into:"
+{ $subsection (call-next-method) }
+"To look up the next applicable method reflectively:"
+{ $subsection next-method }
+"Errors thrown by improper calls to " { $link POSTPONE: call-next-method } ":"
+{ $subsection inconsistent-next-method }
+{ $subsection no-next-method } ;
+
ARTICLE: "generic" "Generic words and methods"
"A " { $emphasis "generic word" } " is composed of zero or more " { $emphasis "methods" } " together with a " { $emphasis "method combination" } ". A method " { $emphasis "specializes" } " on a class; when a generic word executed, the method combination chooses the most appropriate method and calls its definition."
$nl
{ $subsection POSTPONE: M: }
"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "."
{ $subsection "method-order" }
+{ $subsection "call-next-method" }
{ $subsection "generic-introspection" }
{ $subsection "method-combination" }
"Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ;
{ method create-method POSTPONE: M: } related-words
HELP: <method>
-{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
+{ $values { "class" class } { "generic" generic } { "method" "a new method definition" } }
{ $description "Creates a new method." } ;
-HELP: methods
-{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
-{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
-
HELP: order
{ $values { "generic" generic } { "seq" "a sequence of classes" } }
{ $description "Outputs a sequence of classes for which methods have been defined on this generic word. The sequence is sorted in method dispatch order." } ;
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods
-{ $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
+{ $values { "generic" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;
{ $values { "class" class } }
{ $description "Remove all method definitions which specialize on the class." } ;
-{ sort-classes methods order } related-words
+{ sort-classes order } related-words
+
+HELP: (call-next-method)
+{ $values { "class" class } { "generic" generic } }
+{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
+{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
USING: alien arrays definitions generic generic.standard
generic.math assocs hashtables io kernel math namespaces parser
prettyprint sequences strings tools.test vectors words
-quotations classes continuations layouts classes.union sorting
-compiler.units ;
+quotations classes classes.algebra continuations layouts
+classes.union sorting compiler.units ;
IN: generic.tests
GENERIC: foobar ( x -- y )
[ "Hello world" ] [ 4 foobar foobar ] unit-test
[ "Goodbye cruel world" ] [ 4 foobar ] unit-test
-GENERIC: bool>str ( x -- y )
-M: general-t bool>str drop "true" ;
-M: f bool>str drop "false" ;
-
-: str>bool
- H{
- { "true" t }
- { "false" f }
- } at ;
-
-[ t ] [ t bool>str str>bool ] unit-test
-[ f ] [ f bool>str str>bool ] unit-test
-
! Testing unions
UNION: funnies quotation float complex ;
[ 2 ] [ [ { } ] funny ] unit-test
[ 0 ] [ { } funny ] unit-test
-PREDICATE: funnies very-funny number? ;
+PREDICATE: very-funny < funnies number? ;
GENERIC: gooey ( x -- y )
M: very-funny gooey sq ;
[ 0.25 ] [ 0.5 gooey ] unit-test
-DEFER: complement-test
-FORGET: complement-test
-GENERIC: complement-test ( x -- y )
-
-M: f complement-test drop "f" ;
-M: general-t complement-test drop "general-t" ;
-
-[ "general-t" ] [ 5 complement-test ] unit-test
-[ "f" ] [ f complement-test ] unit-test
-
GENERIC: empty-method-test ( x -- y )
M: object empty-method-test ;
TUPLE: for-arguments-sake ;
[ 3 ] [ T{ first-one } wii ] unit-test
-! Hooks
-SYMBOL: my-var
-HOOK: my-hook my-var ( -- x )
-
-M: integer my-hook "an integer" ;
-M: string my-hook "a string" ;
-
-[ "an integer" ] [ 3 my-var set my-hook ] unit-test
-[ "a string" ] [ my-hook my-var set my-hook ] unit-test
-[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
-
GENERIC: tag-and-f ( x -- x x )
M: fixnum tag-and-f 1 ;
[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
-! define-class hashing issue
-TUPLE: debug-combination ;
-
-M: debug-combination make-default-method
- 2drop [ "Oops" throw ] ;
-
-M: debug-combination perform-combination
- drop
- order [ dup class-hashes ] { } map>assoc sort-keys
- 1quotation ;
-
-SYMBOL: redefinition-test-generic
-
-[
- redefinition-test-generic
- T{ debug-combination }
- define-generic
-] with-compilation-unit
-
-TUPLE: redefinition-test-tuple ;
-
-"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
-
-[ t ] [
- [
- redefinition-test-generic ,
- "IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
- redefinition-test-generic ,
- ] { } make all-equal?
-] unit-test
-
! Issues with forget
GENERIC: generic-forget-test-1
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private
-quotations arrays vocabs effects ;
+classes.algebra quotations arrays vocabs effects ;
IN: generic
! Method combination protocol
-GENERIC: perform-combination ( word combination -- quot )
-
-M: object perform-combination
- #! We delay the invalid method combination error for a
- #! reason. If we call forget-vocab on a vocabulary which
- #! defines a method combination, a generic using this
- #! method combination, and a method on the generic, and the
- #! method combination is forgotten first, then forgetting
- #! the method will throw an error. We don't want that.
- nip [ "Invalid method combination" throw ] curry [ ] like ;
+GENERIC: perform-combination ( word combination -- )
GENERIC: make-default-method ( generic combination -- method )
-PREDICATE: word generic "combination" word-prop >boolean ;
+PREDICATE: generic < word
+ "combination" word-prop >boolean ;
M: generic definition drop f ;
: make-generic ( word -- )
- dup { "unannotated-def" } reset-props
- dup dup "combination" word-prop perform-combination define ;
+ [ { "unannotated-def" } reset-props ]
+ [ dup "combination" word-prop perform-combination ]
+ bi ;
: method ( class generic -- method/f )
"methods" word-prop at ;
-PREDICATE: pair method-spec
+PREDICATE: method-spec < pair
first2 generic? swap class? and ;
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
-: methods ( word -- assoc )
- "methods" word-prop
- [ keys sort-classes ] keep
- [ dupd at ] curry { } map>assoc ;
+: specific-method ( class word -- class )
+ order min-class ;
+
+GENERIC: effective-method ( ... generic -- method )
+
+: next-method-class ( class generic -- class/f )
+ order [ class< ] with subset reverse dup length 1 =
+ [ drop f ] [ second ] if ;
+
+: next-method ( class generic -- class/f )
+ [ next-method-class ] keep method ;
+
+GENERIC: next-method-quot* ( class generic -- quot )
+
+: next-method-quot ( class generic -- quot )
+ dup "combination" word-prop next-method-quot* ;
+
+: (call-next-method) ( class generic -- )
+ next-method-quot call ;
TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
over class? over generic? and [
- \ check-method construct-boa throw
+ \ check-method boa throw
] unless ; inline
: with-methods ( generic quot -- )
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
-PREDICATE: word method-body
+PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
+M: method-body crossref?
+ drop t ;
+
: method-word-props ( class generic -- assoc )
[
"method-generic" set
M: method-spec definition
first2 method definition ;
-: forget-method ( class generic -- )
- dup generic? [
- [ delete-at* ] with-methods
- [ forget-word ] [ drop ] if
- ] [
- 2drop
- ] if ;
-
M: method-spec forget*
first2 method forget* ;
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
- dup "method-class" word-prop
- over "method-generic" word-prop forget-method
- t "forgotten" set-word-prop
+ [
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] bi
+ dup generic? [
+ [ delete-at* ] with-methods
+ [ call-next-method ] [ drop ] if
+ ] [ 2drop ] if
+ ]
+ [ t "forgotten" set-word-prop ] bi
] if ;
: implementors* ( classes -- words )
dup associate implementors* ;
: forget-methods ( class -- )
- [ implementors ] keep [ swap 2array ] curry map forget-all ;
+ [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
M: class forget* ( class -- )
- dup forget-methods
- dup uncache-class
- forget-word ;
+ [ forget-methods ]
+ [ update-map- ]
+ [ call-next-method ]
+ tri ;
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
] if ;
M: generic subwords
- dup "methods" word-prop values
- swap "default-method" word-prop add ;
-
-M: generic forget-word
- dup subwords [ forget ] each (forget-word) ;
+ [
+ [ "default-method" word-prop , ]
+ [ "methods" word-prop values % ]
+ [ "engines" word-prop % ]
+ tri
+ ] { } make ;
+
+M: generic forget*
+ [ subwords forget-all ] [ call-next-method ] bi ;
: xref-generics ( -- )
all-words [ subwords [ xref ] each ] each ;
HELP: math-method
{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
-{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ;
+{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip +/float ]" } } ;
HELP: math-class
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private
math namespaces sequences words quotations layouts combinators
-sequences.private classes definitions ;
+sequences.private classes classes.builtin classes.algebra
+definitions ;
IN: generic.math
-PREDICATE: class math-class ( object -- ? )
+PREDICATE: math-class < class
dup null bootstrap-word eq? [
drop f
] [
number bootstrap-word class<
] if ;
-: last/first ( seq -- pair ) dup peek swap first 2array ;
+: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
-: math-precedence ( class -- n )
+: math-precedence ( class -- pair )
{
- { [ dup class-empty? ] [ drop { -1 -1 } ] }
- { [ dup math-class? ] [ types last/first ] }
- { [ t ] [ drop { 100 100 } ] }
+ { [ dup null class< ] [ drop { -1 -1 } ] }
+ { [ dup math-class? ] [ class-types last/first ] }
+ [ drop { 100 100 } ]
} cond ;
: math-class-max ( class class -- class )
dup empty? [ [ dip ] curry [ ] like ] unless
r> append ;
-TUPLE: no-math-method left right generic ;
-
-: no-math-method ( left right generic -- * )
- \ no-math-method construct-boa throw ;
+ERROR: no-math-method left right generic ;
: default-math-method ( generic -- quot )
[ no-math-method ] curry [ ] like ;
2dup and [
2dup math-upgrade >r
math-class-max over order min-class applicable-method
- r> swap append
+ r> prepend
] [
2drop object-method
] if ;
M: math-combination perform-combination
drop
+ dup
\ over [
dup math-class? [
\ dup [ >r 2dup r> math-method ] math-vtable
] [
over object-method
] if nip
- ] math-vtable nip ;
+ ] math-vtable nip
+ define ;
-PREDICATE: generic math-generic ( word -- ? )
+PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;
M: math-generic definer drop \ MATH: f ;
--- /dev/null
+USING: assocs kernel namespaces quotations generic math
+sequences combinators words classes.algebra ;
+IN: generic.standard.engines
+
+SYMBOL: default
+SYMBOL: assumed
+
+GENERIC: engine>quot ( engine -- quot )
+
+M: quotation engine>quot ;
+
+M: method-body engine>quot 1quotation ;
+
+: engines>quots ( assoc -- assoc' )
+ [ engine>quot ] assoc-map ;
+
+: engines>quots* ( assoc -- assoc' )
+ [ over assumed [ engine>quot ] with-variable ] assoc-map ;
+
+: if-small? ( assoc true false -- )
+ >r >r dup assoc-size 4 <= r> r> if ; inline
+
+: linear-dispatch-quot ( alist -- quot )
+ default get [ drop ] prepend swap
+ [ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map
+ alist>quot ;
+
+: split-methods ( assoc class -- first second )
+ [ [ nip class< not ] curry assoc-subset ]
+ [ [ nip class< ] curry assoc-subset ] 2bi ;
+
+: convert-methods ( assoc class word -- assoc' )
+ over >r >r split-methods dup assoc-empty? [
+ r> r> 3drop
+ ] [
+ r> execute r> pick set-at
+ ] if ; inline
+
+SYMBOL: (dispatch#)
+
+: (picker) ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
+ } case ;
+
+: picker ( -- quot ) \ (dispatch#) get (picker) ;
+
+GENERIC: extra-values ( generic -- n )
--- /dev/null
+USING: generic.standard.engines generic namespaces kernel
+sequences classes.algebra accessors words combinators
+assocs ;
+IN: generic.standard.engines.predicate
+
+TUPLE: predicate-dispatch-engine methods ;
+
+C: <predicate-dispatch-engine> predicate-dispatch-engine
+
+: class-predicates ( assoc -- assoc )
+ [ >r "predicate" word-prop picker prepend r> ] assoc-map ;
+
+: keep-going? ( assoc -- ? )
+ assumed get swap second first class< ;
+
+: prune-redundant-predicates ( assoc -- default assoc' )
+ {
+ { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+ { [ dup length 1 = ] [ first second { } ] }
+ { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] }
+ [ [ first second ] [ 1 tail-slice ] bi ]
+ } cond ;
+
+: sort-methods ( assoc -- assoc' )
+ [ keys sort-classes ]
+ [ [ dupd at ] curry ] bi { } map>assoc ;
+
+M: predicate-dispatch-engine engine>quot
+ methods>> clone
+ default get object bootstrap-word pick set-at engines>quots
+ sort-methods prune-redundant-predicates
+ class-predicates alist>quot ;
--- /dev/null
+USING: classes.private generic.standard.engines namespaces
+arrays assocs sequences.private quotations kernel.private
+math slots.private math.private kernel accessors words
+layouts ;
+IN: generic.standard.engines.tag
+
+TUPLE: lo-tag-dispatch-engine methods ;
+
+C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
+
+: direct-dispatch-quot ( alist n -- quot )
+ default get <array>
+ [ <enum> swap update ] keep
+ [ dispatch ] curry >quotation ;
+
+: lo-tag-number ( class -- n )
+ dup \ hi-tag bootstrap-word eq? [
+ drop \ hi-tag tag-number
+ ] [
+ "type" word-prop
+ ] if ;
+
+M: lo-tag-dispatch-engine engine>quot
+ methods>> engines>quots* [ >r lo-tag-number r> ] assoc-map
+ [
+ picker % [ tag ] % [
+ linear-dispatch-quot
+ ] [
+ num-tags get direct-dispatch-quot
+ ] if-small? %
+ ] [ ] make ;
+
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+ \ hi-tag bootstrap-word
+ \ <hi-tag-dispatch-engine> convert-methods ;
+
+: num-hi-tags num-types get num-tags get - ;
+
+: hi-tag-number ( class -- n )
+ "type" word-prop num-tags get - ;
+
+: hi-tag-quot ( -- quot )
+ [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ;
+
+M: hi-tag-dispatch-engine engine>quot
+ methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map
+ [
+ picker % hi-tag-quot % [
+ linear-dispatch-quot
+ ] [
+ num-hi-tags direct-dispatch-quot
+ ] if-small? %
+ ] [ ] make ;
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel classes.tuple.private hashtables assocs sorting
+accessors combinators sequences slots.private math.parser words
+effects namespaces generic generic.standard.engines
+classes.algebra math math.private kernel.private
+quotations arrays ;
+IN: generic.standard.engines.tuple
+
+TUPLE: echelon-dispatch-engine n methods ;
+
+C: <echelon-dispatch-engine> echelon-dispatch-engine
+
+TUPLE: trivial-tuple-dispatch-engine methods ;
+
+C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
+
+TUPLE: tuple-dispatch-engine echelons ;
+
+: push-echelon ( class method assoc -- )
+ >r swap dup "layout" word-prop layout-echelon r>
+ [ ?set-at ] change-at ;
+
+: echelon-sort ( assoc -- assoc' )
+ V{ } clone [
+ [
+ push-echelon
+ ] curry assoc-each
+ ] keep sort-keys ;
+
+: <tuple-dispatch-engine> ( methods -- engine )
+ echelon-sort
+ [ dupd <echelon-dispatch-engine> ] assoc-map
+ \ tuple-dispatch-engine boa ;
+
+: convert-tuple-methods ( assoc -- assoc' )
+ tuple bootstrap-word
+ \ <tuple-dispatch-engine> convert-methods ;
+
+M: trivial-tuple-dispatch-engine engine>quot
+ methods>> engines>quots* linear-dispatch-quot ;
+
+: hash-methods ( methods -- buckets )
+ >alist V{ } clone [ hashcode 1array ] distribute-buckets
+ [ <trivial-tuple-dispatch-engine> ] map ;
+
+: word-hashcode% [ 1 slot ] % ;
+
+: class-hash-dispatch-quot ( methods -- quot )
+ [
+ \ dup ,
+ word-hashcode%
+ hash-methods [ engine>quot ] map hash-dispatch-quot %
+ ] [ ] make ;
+
+: engine-word-name ( -- string )
+ generic get word-name "/tuple-dispatch-engine" append ;
+
+PREDICATE: engine-word < word
+ "tuple-dispatch-generic" word-prop generic? ;
+
+M: engine-word stack-effect
+ "tuple-dispatch-generic" word-prop
+ [ extra-values ] [ stack-effect ] bi
+ dup [ clone [ length + ] change-in ] [ 2drop f ] if ;
+
+M: engine-word compiled-crossref?
+ drop t ;
+
+: remember-engine ( word -- )
+ generic get "engines" word-prop push ;
+
+: <engine-word> ( -- word )
+ engine-word-name f <word>
+ dup generic get "tuple-dispatch-generic" set-word-prop ;
+
+: define-engine-word ( quot -- word )
+ >r <engine-word> dup r> define ;
+
+: array-nth% 2 + , [ slot { word } declare ] % ;
+
+: tuple-layout-superclasses ( obj -- array )
+ { tuple } declare
+ 1 slot { tuple-layout } declare
+ 4 slot { array } declare ; inline
+
+: tuple-dispatch-engine-body ( engine -- quot )
+ [
+ picker %
+ [ tuple-layout-superclasses ] %
+ [ n>> array-nth% ]
+ [
+ methods>> [
+ <trivial-tuple-dispatch-engine> engine>quot
+ ] [
+ class-hash-dispatch-quot
+ ] if-small? %
+ ] bi
+ ] [ ] make ;
+
+M: echelon-dispatch-engine engine>quot
+ dup n>> zero? [
+ methods>> dup assoc-empty?
+ [ drop default get ] [ values first engine>quot ] if
+ ] [
+ [
+ picker %
+ [ tuple-layout-superclasses ] %
+ [ n>> array-nth% ]
+ [
+ methods>> [
+ <trivial-tuple-dispatch-engine> engine>quot
+ ] [
+ class-hash-dispatch-quot
+ ] if-small? %
+ ] bi
+ ] [ ] make
+ ] if ;
+
+: >=-case-quot ( alist -- quot )
+ default get [ drop ] prepend swap
+ [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map
+ alist>quot ;
+
+: tuple-layout-echelon ( obj -- array )
+ { tuple } declare
+ 1 slot { tuple-layout } declare
+ 5 slot ; inline
+
+: unclip-last [ 1 head* ] [ peek ] bi ;
+
+M: tuple-dispatch-engine engine>quot
+ [
+ picker %
+ [ tuple-layout-echelon ] %
+ [
+ tuple assumed set
+ echelons>> dup empty? [
+ unclip-last
+ [
+ [
+ engine>quot define-engine-word
+ [ remember-engine ] [ 1quotation ] bi
+ dup default set
+ ] assoc-map
+ ]
+ [ first2 engine>quot 2array ] bi*
+ suffix
+ ] unless
+ ] with-scope
+ >=-case-quot %
+ ] [ ] make ;
-USING: generic help.markup help.syntax sequences ;
+USING: generic help.markup help.syntax sequences math
+math.parser ;
IN: generic.standard
HELP: no-method
{ $class-description
"Performs standard method combination."
$nl
- "Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. If no suitable method is defined on the class of the dispatch object, the generic word is called on the dispatch object's delegate. If the delegate is " { $link f } ", an exception is thrown."
+ "Generic words using the standard method combination dispatch on the class of the object at the given stack position, where 0 is the top of the stack, 1 is the object underneath, and 2 is the next one under that. A " { $link no-method } " error is thrown if no suitable method is defined on the class."
}
{ $examples
"A generic word for append strings and characters to a sequence, dispatching on the object underneath the top of the stack:"
{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
{ standard-combination hook-combination } related-words
+
+HELP: no-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
+{ $examples
+ "The following code throws this error:"
+ { $code
+ "GENERIC: error-test ( object -- )"
+ ""
+ "M: number error-test 3 + call-next-method ;"
+ ""
+ "M: integer error-test recip call-next-method ;"
+ ""
+ "123 error-test"
+ }
+ "This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
+} ;
+
+HELP: inconsistent-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
+{ $examples
+ "The following code throws this error:"
+ { $code
+ "GENERIC: error-test ( object -- )"
+ ""
+ "M: string error-test print ;"
+ ""
+ "M: integer error-test number>string call-next-method ;"
+ ""
+ "123 error-test"
+ }
+ "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
+ $nl
+ "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
+ { $code "M: integer error-test number>string error-test ;" }
+} ;
--- /dev/null
+IN: generic.standard.tests
+USING: tools.test math math.functions math.constants
+generic.standard strings sequences arrays kernel accessors
+words float-arrays byte-arrays bit-arrays parser namespaces
+quotations inference vectors growable hashtables sbufs
+prettyprint byte-vectors bit-vectors float-vectors ;
+
+GENERIC: lo-tag-test
+
+M: integer lo-tag-test 3 + ;
+
+M: float lo-tag-test 4 - ;
+
+M: rational lo-tag-test 2 - ;
+
+M: complex lo-tag-test sq ;
+
+[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
+[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
+[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
+[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
+
+GENERIC: hi-tag-test
+
+M: string hi-tag-test ", in bed" append ;
+
+M: integer hi-tag-test 3 + ;
+
+M: array hi-tag-test [ hi-tag-test ] map ;
+
+M: sequence hi-tag-test reverse ;
+
+[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
+
+[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
+
+[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
+
+TUPLE: shape ;
+
+TUPLE: abstract-rectangle < shape width height ;
+
+TUPLE: rectangle < abstract-rectangle ;
+
+C: <rectangle> rectangle
+
+TUPLE: parallelogram < abstract-rectangle skew ;
+
+C: <parallelogram> parallelogram
+
+TUPLE: circle < shape radius ;
+
+C: <circle> circle
+
+GENERIC: area
+
+M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
+
+M: circle area radius>> sq pi * ;
+
+[ 12 ] [ 4 3 <rectangle> area ] unit-test
+[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
+[ t ] [ 2 <circle> area 4 pi * = ] unit-test
+
+GENERIC: perimiter
+
+: rectangle-perimiter + 2 * ;
+
+M: rectangle perimiter
+ [ width>> ] [ height>> ] bi
+ rectangle-perimiter ;
+
+: hypotenuse [ sq ] bi@ + sqrt ;
+
+M: parallelogram perimiter
+ [ width>> ]
+ [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
+ rectangle-perimiter ;
+
+M: circle perimiter 2 * pi * ;
+
+[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
+[ 30 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
+
+GENERIC: big-mix-test
+
+M: object big-mix-test drop "object" ;
+
+M: tuple big-mix-test drop "tuple" ;
+
+M: integer big-mix-test drop "integer" ;
+
+M: float big-mix-test drop "float" ;
+
+M: complex big-mix-test drop "complex" ;
+
+M: string big-mix-test drop "string" ;
+
+M: array big-mix-test drop "array" ;
+
+M: sequence big-mix-test drop "sequence" ;
+
+M: rectangle big-mix-test drop "rectangle" ;
+
+M: parallelogram big-mix-test drop "parallelogram" ;
+
+M: circle big-mix-test drop "circle" ;
+
+[ "integer" ] [ 3 big-mix-test ] unit-test
+[ "float" ] [ 5.0 big-mix-test ] unit-test
+[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
+[ "sequence" ] [ F{ 1.0 2.0 3.0 } big-mix-test ] unit-test
+[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
+[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
+[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
+[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
+[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
+[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
+[ "sequence" ] [ FV{ -0.3 4.6 } big-mix-test ] unit-test
+[ "string" ] [ "hello" big-mix-test ] unit-test
+[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
+[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
+[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
+[ "tuple" ] [ H{ } big-mix-test ] unit-test
+[ "object" ] [ \ + big-mix-test ] unit-test
+
+GENERIC: small-lo-tag
+
+M: fixnum small-lo-tag drop "fixnum" ;
+
+M: string small-lo-tag drop "string" ;
+
+M: array small-lo-tag drop "array" ;
+
+M: float-array small-lo-tag drop "float-array" ;
+
+M: byte-array small-lo-tag drop "byte-array" ;
+
+[ "fixnum" ] [ 3 small-lo-tag ] unit-test
+
+[ "float-array" ] [ F{ 1.0 } small-lo-tag ] unit-test
+
+! Testing next-method
+TUPLE: person ;
+
+TUPLE: intern < person ;
+
+TUPLE: employee < person ;
+
+TUPLE: tape-monkey < employee ;
+
+TUPLE: manager < employee ;
+
+TUPLE: junior-manager < manager ;
+
+TUPLE: middle-manager < manager ;
+
+TUPLE: senior-manager < manager ;
+
+TUPLE: executive < senior-manager ;
+
+TUPLE: ceo < executive ;
+
+GENERIC: salary ( person -- n )
+
+M: intern salary
+ #! Intentional mistake.
+ call-next-method ;
+
+M: employee salary drop 24000 ;
+
+M: manager salary call-next-method 12000 + ;
+
+M: middle-manager salary call-next-method 5000 + ;
+
+M: senior-manager salary call-next-method 15000 + ;
+
+M: executive salary call-next-method 2 * ;
+
+M: ceo salary
+ #! Intentional error.
+ drop 5 call-next-method 3 * ;
+
+[ salary ] must-infer
+
+[ 24000 ] [ employee boa salary ] unit-test
+
+[ 24000 ] [ tape-monkey boa salary ] unit-test
+
+[ 36000 ] [ junior-manager boa salary ] unit-test
+
+[ 41000 ] [ middle-manager boa salary ] unit-test
+
+[ 51000 ] [ senior-manager boa salary ] unit-test
+
+[ 102000 ] [ executive boa salary ] unit-test
+
+[ ceo boa salary ]
+[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
+
+[ intern boa salary ]
+[ T{ no-next-method f intern salary } = ] must-fail-with
+
+! Weird shit
+TUPLE: a ;
+TUPLE: b ;
+TUPLE: c ;
+
+UNION: x a b ;
+UNION: y a c ;
+
+UNION: z x y ;
+
+GENERIC: funky* ( obj -- )
+
+M: z funky* "z" , drop ;
+
+M: x funky* "x" , call-next-method ;
+
+M: y funky* "y" , call-next-method ;
+
+M: a funky* "a" , call-next-method ;
+
+M: b funky* "b" , call-next-method ;
+
+M: c funky* "c" , call-next-method ;
+
+: funky [ funky* ] { } make ;
+
+[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
+
+[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
+
+[ t ] [
+ T{ a } funky
+ { { "a" "x" "z" } { "a" "y" "z" } } member?
+] unit-test
+
+! Hooks
+SYMBOL: my-var
+HOOK: my-hook my-var ( -- x )
+
+M: integer my-hook "an integer" ;
+M: string my-hook "a string" ;
+
+[ "an integer" ] [ 3 my-var set my-hook ] unit-test
+[ "a string" ] [ my-hook my-var set my-hook ] unit-test
+[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
+
+HOOK: my-tuple-hook my-var ( -- x )
+
+M: sequence my-tuple-hook my-hook ;
+
+TUPLE: m-t-h-a ;
+
+M: m-t-h-a my-tuple-hook "foo" ;
+
+TUPLE: m-t-h-b < m-t-h-a ;
+
+M: m-t-h-b my-tuple-hook "bar" ;
+
+[ f ] [
+ \ my-tuple-hook [ "engines" word-prop ] keep prefix
+ [ 1quotation infer ] map all-equal?
+] unit-test
+
+HOOK: call-next-hooker my-var ( -- x )
+
+M: sequence call-next-hooker "sequence" ;
+
+M: array call-next-hooker call-next-method "array " prepend ;
+
+M: vector call-next-hooker call-next-method "vector " prepend ;
+
+M: growable call-next-hooker call-next-method "growable " prepend ;
+
+[ "vector growable sequence" ] [
+ V{ } my-var [ call-next-hooker ] with-variable
+] unit-test
+
+GENERIC: no-stack-effect-decl
+
+M: hashtable no-stack-effect-decl ;
+M: vector no-stack-effect-decl ;
+M: sbuf no-stack-effect-decl ;
+
+[ ] [ \ no-stack-effect-decl see ] unit-test
+
+[ ] [ \ no-stack-effect-decl word-def . ] unit-test
USING: arrays assocs kernel kernel.private slots.private math
namespaces sequences vectors words quotations definitions
hashtables layouts combinators sequences.private generic
-classes classes.private ;
+classes classes.algebra classes.private generic.standard.engines
+generic.standard.engines.tag generic.standard.engines.predicate
+generic.standard.engines.tuple accessors ;
IN: generic.standard
-TUPLE: standard-combination # ;
-
-C: <standard-combination> standard-combination
+GENERIC: dispatch# ( word -- n )
-SYMBOL: (dispatch#)
+M: word dispatch# "combination" word-prop dispatch# ;
-: (picker) ( n -- quot )
+: unpickers
{
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1- (picker) [ >r ] swap [ r> swap ] 3append ]
- } case ;
-
-: picker ( -- quot ) \ (dispatch#) get (picker) ;
-
-: unpickers { [ nip ] [ >r nip r> swap ] [ >r >r nip r> r> -rot ] } ; inline
+ [ nip ]
+ [ >r nip r> swap ]
+ [ >r >r nip r> r> -rot ]
+ } ; inline
: unpicker ( -- quot ) \ (dispatch#) get unpickers nth ;
-TUPLE: no-method object generic ;
-
-: no-method ( object generic -- * )
- \ no-method construct-boa throw ;
+ERROR: no-method object generic ;
-: error-method ( word -- quot )
+: error-method ( word -- quot )
picker swap [ no-method ] curry append ;
: empty-method ( word -- quot )
[
picker % [ delegate dup ] %
- unpicker over add ,
- error-method \ drop add* , \ if ,
+ unpicker over suffix ,
+ error-method \ drop prefix , \ if ,
] [ ] make ;
-: class-predicates ( assoc -- assoc )
- [
- >r >r picker r> "predicate" word-prop append r>
- ] assoc-map ;
-
-: (simplify-alist) ( class i assoc -- default assoc )
- 2dup length 1- = [
- nth second { } rot drop
- ] [
- 3dup >r 1+ r> nth first class< [
- >r 1+ r> (simplify-alist)
- ] [
- [ nth second ] 2keep swap 1+ tail rot drop
- ] if
- ] if ;
-
-: simplify-alist ( class assoc -- default assoc )
- dup empty? [
- 2drop [ "Unreachable" throw ] { }
- ] [
- 0 swap (simplify-alist)
- ] if ;
-
: default-method ( word -- pair )
"default-method" word-prop
object bootstrap-word swap 2array ;
-: method-alist>quot ( alist base-class -- quot )
- bootstrap-word swap simplify-alist
- class-predicates alist>quot ;
-
-: small-generic ( methods -- def )
- object method-alist>quot ;
-
-: hash-methods ( methods -- buckets )
- V{ } clone [
- tuple bootstrap-word over class< [
- drop t
- ] [
- class-hashes
- ] if
- ] distribute-buckets ;
-
-: class-hash-dispatch-quot ( methods quot picker -- quot )
- >r >r hash-methods r> map
- hash-dispatch-quot r> [ class-hash ] rot 3append ; inline
-
-: big-generic ( methods -- quot )
- [ small-generic ] picker class-hash-dispatch-quot ;
-
-: vtable-class ( n -- class )
- bootstrap-type>class [ hi-tag bootstrap-word ] unless* ;
-
-: group-methods ( assoc -- vtable )
- #! Input is a predicate -> method association.
- #! n is vtable size (either num-types or num-tags).
- num-tags get [
- vtable-class
- [ swap first classes-intersect? ] curry subset
- ] with map ;
-
-: build-type-vtable ( alist-seq -- alist-seq )
- dup length [
- vtable-class
- swap simplify-alist
- class-predicates alist>quot
- ] 2map ;
-
-: tag-generic ( methods -- quot )
+: push-method ( method specializer atomic assoc -- )
+ [
+ [ H{ } clone <predicate-dispatch-engine> ] unless*
+ [ methods>> set-at ] keep
+ ] change-at ;
+
+: flatten-method ( class method assoc -- )
+ >r >r dup flatten-class keys swap r> r> [
+ >r spin r> push-method
+ ] 3curry each ;
+
+: flatten-methods ( assoc -- assoc' )
+ H{ } clone [
+ [
+ flatten-method
+ ] curry assoc-each
+ ] keep ;
+
+: <big-dispatch-engine> ( assoc -- engine )
+ flatten-methods
+ convert-tuple-methods
+ convert-hi-tag-methods
+ <lo-tag-dispatch-engine> ;
+
+: find-default ( methods -- quot )
+ #! Side-effects methods.
+ object bootstrap-word swap delete-at* [
+ drop generic get "default-method" word-prop 1quotation
+ ] unless ;
+
+: mangle-method ( method generic -- quot )
+ [ 1quotation ] [ extra-values \ drop <repetition> ] bi*
+ prepend [ ] like ;
+
+: single-combination ( word -- quot )
+ [
+ object bootstrap-word assumed set {
+ [ generic set ]
+ [ "engines" word-prop forget-all ]
+ [ V{ } clone "engines" set-word-prop ]
+ [
+ "methods" word-prop
+ [ generic get mangle-method ] assoc-map
+ [ find-default default set ]
+ [
+ generic get "inline" word-prop [
+ <predicate-dispatch-engine>
+ ] [
+ <big-dispatch-engine>
+ ] if
+ ] bi
+ engine>quot
+ ]
+ } cleave
+ ] with-scope ;
+
+ERROR: inconsistent-next-method class generic ;
+
+ERROR: no-next-method class generic ;
+
+: single-next-method-quot ( class generic -- quot )
[
- picker %
- \ tag ,
- group-methods build-type-vtable ,
- \ dispatch ,
+ [ drop [ instance? ] curry % ]
+ [
+ 2dup next-method
+ [ 2nip 1quotation ]
+ [ [ no-next-method ] 2curry ] if* ,
+ ]
+ [ [ inconsistent-next-method ] 2curry , ]
+ 2tri
+ \ if ,
] [ ] make ;
-: flatten-method ( class body -- )
- over members pick object bootstrap-word eq? not and [
- >r members r> [ flatten-method ] curry each
- ] [
- swap set
- ] if ;
+: single-effective-method ( obj word -- method )
+ [ order [ instance? ] with find-last nip ] keep method ;
-: flatten-methods ( methods -- newmethods )
- [ [ flatten-method ] assoc-each ] V{ } make-assoc ;
+TUPLE: standard-combination # ;
+
+C: <standard-combination> standard-combination
-: dispatched-types ( methods -- seq )
- keys object bootstrap-word swap remove prune ;
+PREDICATE: standard-generic < generic
+ "combination" word-prop standard-combination? ;
-: single-combination ( methods -- quot )
- dup length 4 <= [
- small-generic
- ] [
- flatten-methods
- dup dispatched-types [ number class< ] all?
- [ tag-generic ] [ big-generic ] if
- ] if ;
+PREDICATE: simple-generic < standard-generic
+ "combination" word-prop #>> zero? ;
-: standard-methods ( word -- alist )
- dup methods swap default-method add*
- [ 1quotation ] assoc-map ;
+: define-simple-generic ( word -- )
+ T{ standard-combination f 0 } define-generic ;
+
+: with-standard ( combination quot -- quot' )
+ >r #>> (dispatch#) r> with-variable ; inline
+
+M: standard-generic extra-values drop 0 ;
M: standard-combination make-default-method
- standard-combination-# (dispatch#)
- [ empty-method ] with-variable ;
+ [ empty-method ] with-standard ;
M: standard-combination perform-combination
- standard-combination-# (dispatch#) [
- [ standard-methods ] keep "inline" word-prop
- [ small-generic ] [ single-combination ] if
- ] with-variable ;
+ [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
+
+M: standard-combination dispatch# #>> ;
+
+M: standard-combination next-method-quot*
+ [
+ single-next-method-quot picker prepend
+ ] with-standard ;
+
+M: standard-generic effective-method
+ [ dispatch# (picker) call ] keep single-effective-method ;
TUPLE: hook-combination var ;
C: <hook-combination> hook-combination
+PREDICATE: hook-generic < generic
+ "combination" word-prop hook-combination? ;
+
: with-hook ( combination quot -- quot' )
0 (dispatch#) [
- swap slip
- hook-combination-var [ get ] curry
- swap append
+ dip var>> [ get ] curry prepend
] with-variable ; inline
-M: hook-combination make-default-method
- [ error-method ] with-hook ;
-
-M: hook-combination perform-combination
- [
- standard-methods
- [ [ drop ] swap append ] assoc-map
- single-combination
- ] with-hook ;
-
-: define-simple-generic ( word -- )
- T{ standard-combination f 0 } define-generic ;
-
-PREDICATE: generic standard-generic
- "combination" word-prop standard-combination? ;
-
-PREDICATE: standard-generic simple-generic
- "combination" word-prop standard-combination-# zero? ;
+M: hook-combination dispatch# drop 0 ;
-PREDICATE: generic hook-generic
- "combination" word-prop hook-combination? ;
+M: hook-generic extra-values drop 1 ;
-GENERIC: dispatch# ( word -- n )
+M: hook-generic effective-method
+ [ "combination" word-prop var>> get ] keep
+ single-effective-method ;
-M: word dispatch# "combination" word-prop dispatch# ;
+M: hook-combination make-default-method
+ [ error-method ] with-hook ;
-M: standard-combination dispatch# standard-combination-# ;
+M: hook-combination perform-combination
+ [ drop ] [ [ single-combination ] with-hook ] 2bi define ;
-M: hook-combination dispatch# drop 0 ;
+M: hook-combination next-method-quot*
+ [ single-next-method-quot ] with-hook ;
M: simple-generic definer drop \ GENERIC: f ;
HELP: add-vertex
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
-{ $description "Adds a vertex to a directed graph, using the " { $snippet "edges" } " quotation to generate a sequence of edges leaving the vertex." }
+{ $description "Adds a vertex to a directed graph, with " { $snippet "edges" } " as the outward edges from the vertex." }
{ $side-effects "graph" } ;
HELP: remove-vertex
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
-{ $description "Removes a vertex from a graph, using the quotation to generate a sequence of edges leaving the vertex." }
+{ $description "Removes a vertex from a graph, using the given edges sequence." }
{ $notes "The " { $snippet "edges" } " sequence must equal the value passed to " { $link add-vertex } ", otherwise some vertices of the graph may continue to refer to the removed vertex." }
{ $side-effects "graph" } ;
{ $code "H{ } clone" }
"To convert an assoc to a hashtable:"
{ $subsection >hashtable }
+"Further topics:"
+{ $subsection "hashtables.keys" }
+{ $subsection "hashtables.utilities" }
+{ $subsection "hashtables.private" } ;
+
+ARTICLE: "hashtables.keys" "Hashtable keys"
+"Hashtables rely on the " { $link hashcode } " word to rapidly locate values associated with keys. The objects used as keys in a hashtable must obey certain restrictions."
+$nl
+"The " { $link hashcode } " of a key is a function of the its slot values, and if the hashcode changes then the hashtable will be left in an inconsistent state. The easiest way to avoid this problem is to never mutate objects used as hashtable keys."
+$nl
+"In certain advanced applications, this cannot be avoided and the best design involves mutating hashtable keys. In this case, a custom " { $link hashcode* } " method must be defined which only depends on immutable slots."
+$nl
+"In addition, the " { $link equal? } " and " { $link hashcode* } " methods must be congruent, and if one is defined the other should be defined also. This is documented in detail in the documentation for these respective words." ;
+
+ARTICLE: "hashtables.utilities" "Hashtable utilities"
"Utility words to create a new hashtable from a single key/value pair:"
{ $subsection associate }
-{ $subsection ?set-at }
-"The final two words pertain to sequences but use a hashtable internally. Removing duplicate elements from a sequence in linear time, using a hashtable:"
-{ $subsection prune }
-"Test if a sequence contains duplicates in linear time:"
-{ $subsection all-unique? }
-{ $subsection "hashtables.private" } ;
+{ $subsection ?set-at } ;
ABOUT: "hashtables"
{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
{ $description "Constructs a hashtable from any assoc." } ;
-HELP: prune
-{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
-{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
-{ $examples
- { $example "USING: hashtables prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
-} ;
-
-HELP: all-unique?
-{ $values { "seq" sequence } { "?" "a boolean" } }
-{ $description "Tests whether a sequence contains any repeated elements." }
-{ $example
- "USING: hashtables prettyprint ;"
- "{ 0 1 1 2 3 5 } all-unique? ."
- "f"
-} ;
-
HELP: rehash
{ $values { "hash" hashtable } }
{ $description "Rebuild the hashtable. This word should be called if the hashcodes of the hashtable's keys have changed, or if the hashing algorithms themselves have changed, neither of which should occur during normal operation." } ;
[ { "one" "two" 3 } ] [
{ 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
] unit-test
-
-[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
-[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
: (key@) ( key keys i -- array n ? )
3dup swap array-nth
dup ((empty)) eq?
- [ 3drop nip f f ]
- [
- =
- [ rot drop t ]
- [ probe (key@) ]
- if
- ]
- if ; inline
+ [ 3drop nip f f ] [
+ = [ rot drop t ] [ probe (key@) ] if
+ ] if ; inline
: key@ ( key hash -- array n ? )
hash-array 2dup hash@ (key@) ; inline
] if
] if ; inline
-: find-pair ( array quot -- key value ? ) 0 rot (find-pair) ; inline
+: find-pair ( array quot -- key value ? )
+ 0 rot (find-pair) ; inline
: (rehash) ( hash array -- )
[ swap pick (set-hash) drop f ] find-pair 2drop 2drop ;
: hash-large? ( hash -- ? )
- dup hash-count 3 fixnum*fast
- swap hash-array array-capacity > ;
+ [ hash-count 3 fixnum*fast ]
+ [ hash-array array-capacity ] bi > ;
: hash-stale? ( hash -- ? )
- dup hash-deleted 10 fixnum*fast swap hash-count fixnum> ;
+ [ hash-deleted 10 fixnum*fast ] [ hash-count ] bi fixnum> ;
: grow-hash ( hash -- )
[ dup hash-array swap assoc-size 1+ ] keep
PRIVATE>
: <hashtable> ( n -- hash )
- hashtable construct-empty [ reset-hash ] keep ;
+ hashtable new [ reset-hash ] keep ;
M: hashtable at* ( key hash -- value ? )
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
M: hashtable equal?
over hashtable? [
- 2dup [ assoc-size ] 2apply number=
+ 2dup [ assoc-size ] bi@ number=
[ assoc= ] [ 2drop f ] if
] [ 2drop f ] if ;
: ?set-at ( value key assoc/f -- assoc )
[ [ set-at ] keep ] [ associate ] if* ;
-: (prune) ( hash vec elt -- )
- rot 2dup key?
- [ 3drop ] [ dupd dupd set-at swap push ] if ; inline
-
-: prune ( seq -- newseq )
- dup length <hashtable> over length <vector>
- rot [ >r 2dup r> (prune) ] each nip ;
-
-: all-unique? ( seq -- ? )
- dup prune [ length ] 2apply = ;
-
INSTANCE: hashtable assoc
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces tools.test
-heaps heaps.private math.parser random assocs sequences sorting ;
+heaps heaps.private math.parser random assocs sequences sorting
+accessors ;
IN: heaps.tests
[ <min-heap> heap-pop ] must-fail
: random-alist ( n -- alist )
[
[
- (random) dup number>string swap set
+ 32 random-bits dup number>string swap set
] times
] H{ } make-assoc ;
: test-entry-indices ( n -- ? )
random-alist
<min-heap> [ heap-push-all ] keep
- heap-data dup length swap [ entry-index ] map sequence= ;
+ data>> dup length swap [ entry-index ] map sequence= ;
14 [
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
[
random-alist
<min-heap> [ heap-push-all ] keep
- dup heap-data clone swap
+ dup data>> clone swap
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
- heap-data
- [ [ entry-key ] map ] 2apply
- [ natural-sort ] 2apply ;
+ data>>
+ [ [ entry-key ] map ] bi@
+ [ natural-sort ] bi@ ;
11 [
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs sequences.private
-growable ;
+growable accessors ;
IN: heaps
MIXIN: priority-queue
<PRIVATE
-: heap-data delegate ; inline
+TUPLE: heap data ;
: <heap> ( class -- heap )
- >r V{ } clone r> construct-delegate ; inline
+ >r V{ } clone r> boa ; inline
TUPLE: entry value key heap index ;
-: <entry> ( value key heap -- entry ) f entry construct-boa ;
+: <entry> ( value key heap -- entry ) f entry boa ;
PRIVATE>
-TUPLE: min-heap ;
+TUPLE: min-heap < heap ;
: <min-heap> ( -- min-heap ) min-heap <heap> ;
-TUPLE: max-heap ;
+TUPLE: max-heap < heap ;
: <max-heap> ( -- max-heap ) max-heap <heap> ;
INSTANCE: max-heap priority-queue
M: priority-queue heap-empty? ( heap -- ? )
- heap-data empty? ;
+ data>> empty? ;
M: priority-queue heap-size ( heap -- n )
- heap-data length ;
+ data>> length ;
<PRIVATE
: up ( n -- m ) 1- 2/ ; inline
: data-nth ( n heap -- entry )
- heap-data nth-unsafe ; inline
+ data>> nth-unsafe ; inline
: up-value ( n heap -- entry )
>r up r> data-nth ; inline
: data-set-nth ( entry n heap -- )
>r [ swap set-entry-index ] 2keep r>
- heap-data set-nth-unsafe ;
+ data>> set-nth-unsafe ;
: data-push ( entry heap -- n )
dup heap-size [
- swap 2dup heap-data ensure 2drop data-set-nth
+ swap 2dup data>> ensure 2drop data-set-nth
] keep ; inline
: data-pop ( heap -- entry )
- heap-data pop ; inline
+ data>> pop ; inline
: data-pop* ( heap -- )
- heap-data pop* ; inline
+ data>> pop* ; inline
: data-peek ( heap -- entry )
- heap-data peek ; inline
+ data>> peek ; inline
: data-first ( heap -- entry )
- heap-data first ; inline
+ data>> first ; inline
: data-exchange ( m n heap -- )
[ tuck data-nth >r data-nth r> ] 3keep
[ swapd heap-push ] curry assoc-each ;
: >entry< ( entry -- key value )
- { entry-value entry-key } get-slots ;
+ [ value>> ] [ key>> ] bi ;
M: priority-queue heap-peek ( heap -- value key )
data-first >entry< ;
--- /dev/null
+collections
USING: help.syntax help.markup words effects inference.dataflow
-inference.state inference.backend kernel sequences
+inference.state kernel sequences
kernel.private combinators sequences.private ;
+IN: inference.backend
HELP: literal-expected
{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
-{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
+{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ;
HELP: too-many->r
{ $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." }
{ $description "Throws a " { $link no-effect } " error." }
{ $error-description "Thrown when inference encounters a call to a word which is already known not to have a static stack effect, due to a prior inference attempt failing." } ;
-HELP: collect-recursion
-{ $values { "#label" "a " { $link #label } " node" } { "seq" "a new sequence" } }
-{ $description "Collect the input stacks of all child " { $link #call-label } " nodes that call the given label." } ;
-
HELP: inline-word
{ $values { "word" word } }
{ $description "Called during inference to infer stack effects of inline words."
USING: inference.dataflow inference.state arrays generic io
io.streams.string kernel math namespaces parser prettyprint
sequences strings vectors words quotations effects classes
-continuations debugger assocs combinators compiler.errors ;
+continuations debugger assocs combinators compiler.errors
+generic.standard.engines.tuple accessors ;
IN: inference.backend
: recursive-label ( word -- label/f )
recursive-state get at ;
-: inline? ( word -- ? )
- dup "method-generic" word-prop swap or "inline" word-prop ;
+GENERIC: inline? ( word -- ? )
+
+M: method-body inline?
+ "method-generic" word-prop inline? ;
+
+M: engine-word inline?
+ "tuple-dispatch-generic" word-prop inline? ;
+
+M: word inline?
+ "inline" word-prop ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys
: recursive-quotation? ( quot -- ? )
local-recursive-state [ first eq? ] with contains? ;
-TUPLE: inference-error rstate type ;
+TUPLE: inference-error error type rstate ;
+
+M: inference-error compiler-error-type type>> ;
-M: inference-error compiler-error-type
- inference-error-type ;
+M: inference-error error-help error>> error-help ;
: (inference-error) ( ... class type -- * )
- >r construct-boa r>
- recursive-state get {
- set-delegate
- set-inference-error-type
- set-inference-error-rstate
- } \ inference-error construct throw ; inline
+ >r boa r>
+ recursive-state get
+ \ inference-error boa throw ; inline
: inference-error ( ... class -- * )
+error+ (inference-error) ; inline
r> recursive-state set ;
: infer-quot-recursive ( quot word label -- )
- recursive-state get -rot 2array add* infer-quot ;
+ recursive-state get -rot 2array prefix infer-quot ;
: time-bomb ( error -- )
[ throw ] curry recursive-state get infer-quot ;
dup value-literal callable? [
dup value-literal
over value-recursion
- rot f 2array add* infer-quot
+ rot f 2array prefix infer-quot
] [
drop bad-call
] if
TUPLE: too-many-r> ;
-: check-r> ( -- )
- meta-r get empty?
+: check-r> ( n -- )
+ meta-r get length >
[ \ too-many-r> inference-error ] when ;
-: infer->r ( -- )
- 1 ensure-values
+: infer->r ( n -- )
+ dup ensure-values
#>r
- 1 0 pick node-inputs
- pop-d push-r
- 0 1 pick node-outputs
- node, ;
+ over 0 pick node-inputs
+ over [ drop pop-d ] map reverse [ push-r ] each
+ 0 pick pick node-outputs
+ node,
+ drop ;
-: infer-r> ( -- )
- check-r>
+: infer-r> ( n -- )
+ dup check-r>
#r>
- 0 1 pick node-inputs
- pop-r push-d
- 1 0 pick node-outputs
- node, ;
+ 0 pick pick node-inputs
+ over [ drop pop-r ] map reverse [ push-d ] each
+ over 0 pick node-outputs
+ node,
+ drop ;
: undo-infer ( -- )
recorded get [ f "inferred-effect" set-word-prop ] each ;
dup infer-uncurry
constructor [
peek-d reify-curry
- infer->r
+ 1 infer->r
peek-d reify-curry
- infer-r>
+ 1 infer-r>
2 1 <effect> swap #call consume/produce
] when* ;
: reify-curries ( n -- )
meta-d get reverse [
dup special? [
- over [ infer->r ] times
+ over infer->r
dup reify-curry
- over [ infer-r> ] times
+ over infer-r>
] when 2drop
] 2each ;
{ [ dup [ curried? ] all? ] [ unify-curries ] }
{ [ dup [ composed? ] all? ] [ unify-composed ] }
{ [ dup [ special? ] contains? ] [ cannot-unify-specials ] }
- { [ t ] [ drop <computed> ] }
+ [ drop <computed> ]
} cond ;
: unify-stacks ( seq -- stack )
\ effect-error inference-error ;
: check-effect ( word effect -- )
- dup pick "declared-effect" word-prop effect<=
+ dup pick stack-effect effect<=
[ 2drop ] [ effect-error ] if ;
: finish-word ( word -- )
{ [ dup "infer" word-prop ] [ custom-infer ] }
{ [ dup "no-effect" word-prop ] [ no-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
- { [ t ] [ dup infer-word make-call-node ] }
+ [ dup infer-word make-call-node ]
} cond ;
TUPLE: recursive-declare-error word ;
\ recursive-declare-error inference-error
] if* ;
+GENERIC: collect-label-info* ( label node -- )
+
+M: node collect-label-info* 2drop ;
+
+: (collect-label-info) ( label node vector -- )
+ >r tuck [ param>> ] bi@ eq? r> [ push ] curry [ drop ] if ;
+ inline
+
+M: #call-label collect-label-info*
+ over calls>> (collect-label-info) ;
+
+M: #return collect-label-info*
+ over returns>> (collect-label-info) ;
+
+: collect-label-info ( #label -- )
+ V{ } clone >>calls
+ V{ } clone >>returns
+ dup [ collect-label-info* ] with each-node ;
+
: nest-node ( -- ) #entry node, ;
: unnest-node ( new-node -- new-node )
: <inlined-block> gensym dup t "inlined-block" set-word-prop ;
-: inline-block ( word -- node-block data )
+: inline-block ( word -- #label data )
[
copy-inference nest-node
dup word-def swap <inlined-block>
[ infer-quot-recursive ] 2keep
#label unnest-node
+ dup collect-label-info
] H{ } make-assoc ;
-GENERIC: collect-recursion* ( label node -- )
-
-M: node collect-recursion* 2drop ;
-
-M: #call-label collect-recursion*
- tuck node-param eq? [ , ] [ drop ] if ;
-
-: collect-recursion ( #label -- seq )
- dup node-param
- [ [ swap collect-recursion* ] curry each-node ] { } make ;
-
-: join-values ( node -- )
- collect-recursion [ node-in-d ] map meta-d get add
+: join-values ( #label -- )
+ calls>> [ node-in-d ] map meta-d get suffix
unify-lengths unify-stacks
meta-d [ length tail* ] change ;
drop join-values inline-block apply-infer
r> over set-node-in-d
dup node,
- collect-recursion [
+ calls>> [
[ flatten-curries ] modify-values
] each
] [
sequences words inference.class quotations alien
alien.c-types strings sbufs sequences.private
slots.private combinators definitions compiler.units
-system layouts vectors ;
+system layouts vectors optimizer.math.partial accessors
+optimizer.inlining ;
+
+[ t ] [ T{ literal-constraint f 1 2 } T{ literal-constraint f 1 2 } equal? ] unit-test
+
+[ f ] [ T{ literal-constraint f 1 3 } T{ literal-constraint f 1 2 } equal? ] unit-test
! Make sure these compile even though this is invalid code
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
! Ensure type inference works as it is supposed to by checking
! if various methods get inlined
-: inlined? ( quot word -- ? )
+: inlined? ( quot seq/word -- ? )
+ dup word? [ 1array ] when
swap dataflow optimize
- [ node-param eq? ] with node-exists? not ;
+ [ node-param swap member? ] with node-exists? not ;
+
+[ f ] [
+ [ { integer } declare >fixnum ]
+ \ >fixnum inlined?
+] unit-test
GENERIC: mynot ( x -- y )
M: f mynot drop t ;
-M: general-t mynot drop f ;
+M: object mynot drop f ;
GENERIC: detect-f ( x -- y )
[ { fixnum } declare [ ] times ] \ fixnum+ inlined?
] unit-test
-[ f ] [
+[ t ] [
[ { integer fixnum } declare dupd < [ 1 + ] when ]
\ + inlined?
] unit-test
-[ f ] [ [ dup 0 < [ neg ] when ] \ neg inlined? ] unit-test
+[ f ] [
+ [ { integer fixnum } declare dupd < [ 1 + ] when ]
+ \ +-integer-fixnum inlined?
+] unit-test
+
+[ f ] [ [ dup 0 < [ neg ] when ] \ - inlined? ] unit-test
[ f ] [
[
[ no-cond ] 1
[ 1array dup quotation? [ >quotation ] unless ] times
- ] \ type inlined?
+ ] \ quotation? inlined?
] unit-test
[ f ] [ [ <reversed> length ] \ slot inlined? ] unit-test
DEFER: blah
-[ t ] [
+[ ] [
[
\ blah
[ dup V{ } eq? [ foo ] when ] dup second dup push define
] with-compilation-unit
- \ blah compiled?
+ \ blah word-def dataflow optimize drop
] unit-test
GENERIC: detect-fx ( n -- n )
] \ detect-fx inlined?
] unit-test
+[ t ] [
+ [
+ 1000000000000000000000000000000000 [ ] times
+ ] \ + inlined?
+] unit-test
[ f ] [
[
1000000000000000000000000000000000 [ ] times
- ] \ 1+ inlined?
+ ] \ +-integer-fixnum inlined?
] unit-test
[ f ] [
- [ { bignum } declare [ ] times ] \ 1+ inlined?
+ [ { bignum } declare [ ] times ]
+ \ +-integer-fixnum inlined?
] unit-test
\ >float inlined?
] unit-test
+GENERIC: detect-float ( a -- b )
+
+M: float detect-float ;
+
[ t ] [
- [ 3 + = ] \ equal? inlined?
+ [ { real float } declare + detect-float ]
+ \ detect-float inlined?
+] unit-test
+
+[ t ] [
+ [ { float real } declare + detect-float ]
+ \ detect-float inlined?
] unit-test
[ t ] [
+ [ 3 + = ] \ equal? inlined?
+] unit-test
+
+[ f ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
- \ shift inlined?
+ \ fixnum-shift-fast inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 7 bitand neg shift ]
- \ fixnum-shift inlined?
+ { shift fixnum-shift } inlined?
] unit-test
[ t ] [
[ { fixnum fixnum } declare 1 swap 7 bitand shift ]
- \ fixnum-shift inlined?
+ { shift fixnum-shift } inlined?
+] unit-test
+
+[ f ] [
+ [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
+ { fixnum-shift-fast } inlined?
] unit-test
cell-bits 32 = [
] unit-test
] when
+[ f ] [
+ [ { integer } declare -63 shift 4095 bitand ]
+ \ shift inlined?
+] unit-test
+
[ t ] [
[ B{ 1 0 } *short 0 number= ]
\ number= inlined?
[ t ] [
[ { vector } declare nth-unsafe ] \ nth-unsafe inlined?
] unit-test
+
+[ t ] [
+ [
+ dup integer? [
+ dup fixnum? [
+ 1 +
+ ] [
+ 2 +
+ ] if
+ ] when
+ ] \ + inlined?
+] unit-test
+
+[ f ] [
+ [
+ 256 mod
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ f ] [
+ [
+ dup 0 >= [ 256 mod ] when
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare dup 0 >= [ 256 mod ] when
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare 256 rem
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare [ 256 rem ] map
+ ] { mod fixnum-mod rem } inlined?
+] unit-test
+
+[ t ] [
+ [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
+] unit-test
+
+: rec ( a -- b )
+ dup 0 > [ 1 - rec ] when ; inline
+
+[ t ] [
+ [ { fixnum } declare rec 1 + ]
+ { > - + } inlined?
+] unit-test
+
+: fib ( m -- n )
+ dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; inline
+
+[ t ] [
+ [ 27.0 fib ] { < - + } inlined?
+] unit-test
+
+[ f ] [
+ [ 27.0 fib ] { +-integer-integer } inlined?
+] unit-test
+
+[ t ] [
+ [ 27 fib ] { < - + } inlined?
+] unit-test
+
+[ t ] [
+ [ 27 >bignum fib ] { < - + } inlined?
+] unit-test
+
+[ f ] [
+ [ 27/2 fib ] { < - } inlined?
+] unit-test
+
+: hang-regression ( m n -- x )
+ over 0 number= [
+ nip
+ ] [
+ dup [
+ drop 1 hang-regression
+ ] [
+ dupd hang-regression hang-regression
+ ] if
+ ] if ; inline
+
+[ t ] [
+ [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if
+] { } inlined? ] unit-test
+
+: detect-null ( a -- b ) dup drop ;
+
+\ detect-null {
+ { [ dup dup in-d>> first node-class null eq? ] [ [ ] f splice-quot ] }
+} define-optimizers
+
+[ t ] [
+ [ { null } declare detect-null ] \ detect-null inlined?
+] unit-test
+
+[ t ] [
+ [ { null null } declare + detect-null ] \ detect-null inlined?
+] unit-test
+
+[ f ] [
+ [ { null fixnum } declare + detect-null ] \ detect-null inlined?
+] unit-test
+
+GENERIC: detect-integer ( a -- b )
+
+M: integer detect-integer ;
+
+[ t ] [
+ [ { null fixnum } declare + detect-integer ] \ detect-integer inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
+] unit-test
+
+[ f ] [
+ [ { integer } declare 10 [ -1 shift ] times ] \ shift inlined?
+] unit-test
+
+[ f ] [
+ [ { fixnum } declare 1048575 fixnum-bitand 524288 fixnum- ]
+ \ fixnum-bitand inlined?
+] unit-test
+
+[ t ] [
+ [ { integer } declare 127 bitand 3 + ]
+ { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined?
+] unit-test
+
+[ f ] [
+ [ { integer } declare 127 bitand 3 + ]
+ { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum } declare [ drop ] each-integer ]
+ { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum } declare length [ drop ] each-integer ]
+ { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum } declare [ drop ] each ]
+ { < <-integer-fixnum +-integer-fixnum + } inlined?
+] unit-test
+
+[ t ] [
+ [ { fixnum } declare 0 [ + ] reduce ]
+ { < <-integer-fixnum } inlined?
+] unit-test
+
+[ f ] [
+ [ { fixnum } declare 0 [ + ] reduce ]
+ \ +-integer-fixnum inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare
+ dup 0 >= [
+ 615949 * 797807 + 20 2^ mod dup 19 2^ -
+ ] [ dup ] if
+ ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { fixnum } declare
+ 615949 * 797807 + 20 2^ mod dup 19 2^ -
+ ] { >fixnum } inlined?
+] unit-test
+
+[ f ] [
+ [
+ { integer } declare [ ] map
+ ] \ >fixnum inlined?
+] unit-test
+
+[ f ] [
+ [
+ { integer } declare { } set-nth-unsafe
+ ] \ >fixnum inlined?
+] unit-test
+
+[ f ] [
+ [
+ { integer } declare 1 + { } set-nth-unsafe
+ ] \ >fixnum inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare 0 swap
+ [
+ drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+ ] map
+ ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { fixnum } declare 0 swap
+ [
+ drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+ ] map
+ ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { integer } declare bitnot detect-integer ]
+ \ detect-integer inlined?
+] unit-test
+
+! Later
+
+! [ t ] [
+! [
+! { integer } declare [ 256 mod ] map
+! ] { mod fixnum-mod } inlined?
+! ] unit-test
+!
+! [ t ] [
+! [
+! { integer } declare [ 0 >= ] map
+! ] { >= fixnum>= } inlined?
+! ] unit-test
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs hashtables inference kernel
math namespaces sequences words parser math.intervals
-effects classes inference.dataflow inference.backend
-combinators ;
+effects classes classes.algebra inference.dataflow
+inference.backend combinators accessors ;
IN: inference.class
! Class inference
M: literal-constraint equal?
over literal-constraint? [
- 2dup
- [ literal-constraint-literal ] 2apply eql? >r
- [ literal-constraint-value ] 2apply = r> and
- ] [
- 2drop f
- ] if ;
+ [ [ literal>> ] bi@ eql? ]
+ [ [ value>> ] bi@ = ]
+ 2bi and
+ ] [ 2drop f ] if ;
TUPLE: class-constraint class value ;
GENERIC: apply-constraint ( constraint -- )
GENERIC: constraint-satisfied? ( constraint -- ? )
-: `input node get node-in-d nth ;
-: `output node get node-out-d nth ;
+: `input node get in-d>> nth ;
+: `output node get out-d>> nth ;
: class, <class-constraint> , ;
: literal, <literal-constraint> , ;
: interval, <interval-constraint> , ;
set-value-interval* ;
M: interval-constraint apply-constraint
- dup interval-constraint-interval
- swap interval-constraint-value intersect-value-interval ;
+ [ interval>> ] [ value>> ] bi intersect-value-interval ;
: set-class-interval ( class value -- )
- >r "interval" word-prop dup
- [ r> set-value-interval* ] [ r> 2drop ] if ;
+ over class? [
+ >r "interval" word-prop r> over
+ [ set-value-interval* ] [ 2drop ] if
+ ] [ 2drop ] if ;
: value-class* ( value -- class )
value-classes get at object or ;
[ value-class* class-and ] keep set-value-class* ;
M: class-constraint apply-constraint
- dup class-constraint-class
- swap class-constraint-value intersect-value-class ;
+ [ class>> ] [ value>> ] bi intersect-value-class ;
+
+: literal-interval ( value -- interval/f )
+ dup real? [ [a,a] ] [ drop f ] if ;
: set-value-literal* ( literal value -- )
- over class over set-value-class*
- over real? [ over [a,a] over set-value-interval* ] when
- 2dup <literal-constraint> assume
- value-literals get set-at ;
+ {
+ [ >r class r> set-value-class* ]
+ [ >r literal-interval r> set-value-interval* ]
+ [ <literal-constraint> assume ]
+ [ value-literals get set-at ]
+ } 2cleave ;
M: literal-constraint apply-constraint
- dup literal-constraint-literal
- swap literal-constraint-value set-value-literal* ;
+ [ literal>> ] [ value>> ] bi set-value-literal* ;
! For conditionals, an assoc of child node # --> constraint
GENERIC: child-constraints ( node -- seq )
M: node infer-classes-before drop ;
M: node child-constraints
- node-children length
+ children>> length
dup zero? [ drop f ] [ f <repetition> ] if ;
: value-literal* ( value -- obj ? )
value-literals get at* ;
M: literal-constraint constraint-satisfied?
- dup literal-constraint-value value-literal*
- [ swap literal-constraint-literal eql? ] [ 2drop f ] if ;
+ dup value>> value-literal*
+ [ swap literal>> eql? ] [ 2drop f ] if ;
M: class-constraint constraint-satisfied?
- dup class-constraint-value value-class*
- swap class-constraint-class class< ;
+ [ value>> value-class* ] [ class>> ] bi class< ;
M: pair apply-constraint
first2 2dup constraints get set-at
M: pair constraint-satisfied?
first constraint-satisfied? ;
-: extract-keys ( assoc seq -- newassoc )
- dup length <hashtable> swap [
- dup >r pick at* [ r> pick set-at ] [ r> 2drop ] if
- ] each nip f assoc-like ;
+: extract-keys ( seq assoc -- newassoc )
+ [ dupd at ] curry H{ } map>assoc [ nip ] assoc-subset f assoc-like ;
: annotate-node ( node -- )
#! Annotate the node with the currently-inferred set of
#! value classes.
- dup node-values
- value-intervals get over extract-keys pick set-node-intervals
- value-classes get over extract-keys pick set-node-classes
- value-literals get over extract-keys pick set-node-literals
- 2drop ;
+ dup node-values {
+ [ value-intervals get extract-keys >>intervals ]
+ [ value-classes get extract-keys >>classes ]
+ [ value-literals get extract-keys >>literals ]
+ [ 2drop ]
+ } cleave ;
: intersect-classes ( classes values -- )
[ intersect-value-class ] 2each ;
: predicate-constraints ( class #call -- )
[
- 0 `input class,
- general-t 0 `output class,
- ] set-constraints ;
+ ! If word outputs true, input is an instance of class
+ [
+ 0 `input class,
+ \ f class-not 0 `output class,
+ ] set-constraints
+ ] [
+ ! If word outputs false, input is not an instance of class
+ [
+ class-not 0 `input class,
+ \ f 0 `output class,
+ ] set-constraints
+ ] 2bi ;
: compute-constraints ( #call -- )
- dup node-param "constraints" word-prop [
+ dup param>> "constraints" word-prop [
call
] [
- dup node-param "predicating" word-prop dup
+ dup param>> "predicating" word-prop dup
[ swap predicate-constraints ] [ 2drop ] if
] if* ;
: compute-output-classes ( node word -- classes intervals )
- dup node-param "output-classes" word-prop
+ dup param>> "output-classes" word-prop
dup [ call ] [ 2drop f f ] if ;
: output-classes ( node -- classes intervals )
dup compute-output-classes >r
- [ ] [ node-param "default-output-classes" word-prop ] ?if
+ [ ] [ param>> "default-output-classes" word-prop ] ?if
r> ;
M: #call infer-classes-before
- dup compute-constraints
- dup node-out-d swap output-classes
- >r over intersect-classes
- r> swap intersect-intervals ;
+ [ compute-constraints ] keep
+ [ output-classes ] [ out-d>> ] bi
+ tuck [ intersect-classes ] [ intersect-intervals ] 2bi* ;
M: #push infer-classes-before
- node-out-d
- [ [ value-literal ] keep set-value-literal* ] each ;
+ out-d>> [ [ value-literal ] keep set-value-literal* ] each ;
M: #if child-constraints
[
- general-t 0 `input class,
+ \ f class-not 0 `input class,
f 0 `input literal,
] make-constraints ;
M: #dispatch child-constraints
dup [
- node-children length [
- 0 `input literal,
- ] each
+ children>> length [ 0 `input literal, ] each
] make-constraints ;
M: #declare infer-classes-before
- dup node-param swap node-in-d
+ [ param>> ] [ in-d>> ] bi
[ intersect-value-class ] 2each ;
DEFER: (infer-classes)
: infer-children ( node -- )
- dup node-children swap child-constraints [
+ [ children>> ] [ child-constraints ] bi [
[
value-classes [ clone ] change
value-literals [ clone ] change
>r dup [ length ] map supremum r> [ pad-left ] 2curry map ;
: (merge-classes) ( nodes -- seq )
- [ node-input-classes ] map
- null pad-all flip [ null [ class-or ] reduce ] map ;
+ dup length 1 = [
+ first node-input-classes
+ ] [
+ [ node-input-classes ] map null pad-all flip
+ [ null [ class-or ] reduce ] map
+ ] if ;
: set-classes ( seq node -- )
- node-out-d [ set-value-class* ] 2reverse-each ;
+ out-d>> [ set-value-class* ] 2reverse-each ;
: merge-classes ( nodes node -- )
>r (merge-classes) r> set-classes ;
-: (merge-intervals) ( nodes quot -- seq )
- >r
- [ node-input-intervals ] map
- f pad-all flip
- r> map ; inline
-
: set-intervals ( seq node -- )
- node-out-d [ set-value-interval* ] 2reverse-each ;
+ out-d>> [ set-value-interval* ] 2reverse-each ;
: merge-intervals ( nodes node -- )
- >r [ dup first [ interval-union ] reduce ]
- (merge-intervals) r> set-intervals ;
+ >r
+ [ node-input-intervals ] map f pad-all flip
+ [ dup first [ interval-union ] reduce ] map
+ r> set-intervals ;
: annotate-merge ( nodes #merge/#entry -- )
- 2dup merge-classes merge-intervals ;
+ [ merge-classes ] [ merge-intervals ] 2bi ;
: merge-children ( node -- )
dup node-successor dup #merge? [
swap active-children dup empty?
[ 2drop ] [ swap annotate-merge ] if
- ] [
- 2drop
- ] if ;
+ ] [ 2drop ] if ;
+
+: classes= ( inferred current -- ? )
+ 2dup min-length [ tail* ] curry bi@ sequence= ;
+
+SYMBOL: fixed-point?
+
+SYMBOL: nested-labels
: annotate-entry ( nodes #label -- )
- node-child merge-classes ;
+ >r (merge-classes) r> node-child
+ 2dup node-output-classes classes=
+ [ 2drop ] [ set-classes fixed-point? off ] if ;
+
+: init-recursive-calls ( #label -- )
+ #! We set recursive calls to output the empty type, then
+ #! repeat inference until a fixed point is reached.
+ #! Hopefully, our type functions are monotonic so this
+ #! will always converge.
+ returns>> [ dup in-d>> [ null ] { } map>assoc >>classes drop ] each ;
M: #label infer-classes-before ( #label -- )
- #! First, infer types under the hypothesis which hold on
- #! entry to the recursive label.
- dup 1array swap annotate-entry ;
+ [ init-recursive-calls ]
+ [ [ 1array ] keep annotate-entry ] bi ;
+
+: infer-label-loop ( #label -- )
+ fixed-point? on
+ dup node-child (infer-classes)
+ dup [ calls>> ] [ suffix ] [ annotate-entry ] tri
+ fixed-point? get [ drop ] [ infer-label-loop ] if ;
M: #label infer-classes-around ( #label -- )
#! Now merge the types at every recursion point with the
#! entry types.
- dup annotate-node
- dup infer-classes-before
- dup infer-children
- dup collect-recursion over add
- pick annotate-entry
- node-child (infer-classes) ;
+ [
+ {
+ [ nested-labels get push ]
+ [ annotate-node ]
+ [ infer-classes-before ]
+ [ infer-label-loop ]
+ [ drop nested-labels get pop* ]
+ } cleave
+ ] with-scope ;
+
+: find-label ( param -- #label )
+ param>> nested-labels get [ param>> eq? ] with find nip ;
+
+M: #call-label infer-classes-before ( #call-label -- )
+ [ find-label returns>> (merge-classes) ] [ out-d>> ] bi
+ [ set-value-class* ] 2each ;
+
+M: #return infer-classes-around
+ nested-labels get length 0 > [
+ dup param>> nested-labels get peek param>> eq? [
+ [ ] [ node-input-classes ] [ in-d>> [ value-class* ] map ] tri
+ classes= not [
+ fixed-point? off
+ [ in-d>> value-classes get extract-keys ] keep
+ set-node-classes
+ ] [ drop ] if
+ ] [ call-next-method ] if
+ ] [ call-next-method ] if ;
M: object infer-classes-around
- dup infer-classes-before
- dup annotate-node
- dup infer-children
- merge-children ;
+ {
+ [ infer-classes-before ]
+ [ annotate-node ]
+ [ infer-children ]
+ [ merge-children ]
+ } cleave ;
: (infer-classes) ( node -- )
[
- dup infer-classes-around
- node-successor (infer-classes)
+ [ infer-classes-around ]
+ [ node-successor ] bi
+ (infer-classes)
] when* ;
: infer-classes-with ( node classes literals intervals -- )
[
+ V{ } clone nested-labels set
H{ } assoc-like value-intervals set
H{ } assoc-like value-literals set
H{ } assoc-like value-classes set
(infer-classes)
] with-scope ;
-: infer-classes ( node -- )
- f f f infer-classes-with ;
+: infer-classes ( node -- node )
+ dup f f f infer-classes-with ;
: infer-classes/node ( node existing -- )
#! Infer classes, using the existing node's class info as a
#! starting point.
- dup node-classes
- over node-literals
- rot node-intervals
+ [ classes>> ] [ literals>> ] [ intervals>> ] tri
infer-classes-with ;
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
-inference.state ;
+inference.state accessors combinators ;
IN: inference.dataflow
! Computed value
: <computed> \ <computed> counter ;
! Literal value
-TUPLE: value literal uid recursion ;
+TUPLE: value < identity-tuple literal uid recursion ;
: <value> ( obj -- value )
- <computed> recursive-state get value construct-boa ;
+ <computed> recursive-state get value boa ;
M: value hashcode* nip value-uid ;
-M: value equal? 2drop f ;
-
! Result of curry
TUPLE: curried obj quot ;
UNION: special curried composed ;
-TUPLE: node param
+TUPLE: node < identity-tuple
+param
in-d out-d in-r out-r
classes literals intervals
history successor children ;
-M: node equal? 2drop f ;
-
M: node hashcode* drop node hashcode* ;
GENERIC: flatten-curry ( value -- )
M: curried flatten-curry
- dup curried-obj flatten-curry
- curried-quot flatten-curry ;
+ [ obj>> flatten-curry ]
+ [ quot>> flatten-curry ] bi ;
M: composed flatten-curry
- dup composed-quot1 flatten-curry
- composed-quot2 flatten-curry ;
+ [ quot1>> flatten-curry ]
+ [ quot2>> flatten-curry ] bi ;
M: object flatten-curry , ;
meta-d get clone flatten-curries ;
: modify-values ( node quot -- )
- [ swap [ node-in-d swap call ] keep set-node-in-d ] 2keep
- [ swap [ node-in-r swap call ] keep set-node-in-r ] 2keep
- [ swap [ node-out-d swap call ] keep set-node-out-d ] 2keep
- swap [ node-out-r swap call ] keep set-node-out-r ; inline
+ {
+ [ change-in-d ]
+ [ change-in-r ]
+ [ change-out-d ]
+ [ change-out-r ]
+ } cleave drop ; inline
: node-shuffle ( node -- shuffle )
- dup node-in-d swap node-out-d <effect> ;
-
-: make-node ( slots class -- node )
- >r node construct r> construct-delegate ; inline
-
-: empty-node ( class -- node )
- { } swap make-node ; inline
+ [ in-d>> ] [ out-d>> ] bi <effect> ;
: param-node ( param class -- node )
- { set-node-param } swap make-node ; inline
+ new swap >>param ; inline
: in-node ( seq class -- node )
- { set-node-in-d } swap make-node ; inline
+ new swap >>in-d ; inline
: all-in-node ( class -- node )
flatten-meta-d swap in-node ; inline
: out-node ( seq class -- node )
- { set-node-out-d } swap make-node ; inline
+ new swap >>out-d ; inline
: all-out-node ( class -- node )
flatten-meta-d swap out-node ; inline
: node-child node-children first ;
-TUPLE: #label word loop? ;
+TUPLE: #label < node word loop? returns calls ;
: #label ( word label -- node )
- \ #label param-node [ set-#label-word ] keep ;
+ \ #label param-node swap >>word ;
-PREDICATE: #label #loop #label-loop? ;
+PREDICATE: #loop < #label #label-loop? ;
-TUPLE: #entry ;
+TUPLE: #entry < node ;
: #entry ( -- node ) \ #entry all-out-node ;
-TUPLE: #call ;
+TUPLE: #call < node ;
: #call ( word -- node ) \ #call param-node ;
-TUPLE: #call-label ;
+TUPLE: #call-label < node ;
: #call-label ( label -- node ) \ #call-label param-node ;
-TUPLE: #push ;
+TUPLE: #push < node ;
-: #push ( -- node ) \ #push empty-node ;
+: #push ( -- node ) \ #push new ;
-TUPLE: #shuffle ;
+TUPLE: #shuffle < node ;
-: #shuffle ( -- node ) \ #shuffle empty-node ;
+: #shuffle ( -- node ) \ #shuffle new ;
-TUPLE: #>r ;
+TUPLE: #>r < node ;
-: #>r ( -- node ) \ #>r empty-node ;
+: #>r ( -- node ) \ #>r new ;
-TUPLE: #r> ;
+TUPLE: #r> < node ;
-: #r> ( -- node ) \ #r> empty-node ;
+: #r> ( -- node ) \ #r> new ;
-TUPLE: #values ;
+TUPLE: #values < node ;
: #values ( -- node ) \ #values all-in-node ;
-TUPLE: #return ;
+TUPLE: #return < node ;
: #return ( label -- node )
- \ #return all-in-node [ set-node-param ] keep ;
+ \ #return all-in-node swap >>param ;
+
+TUPLE: #branch < node ;
-TUPLE: #if ;
+TUPLE: #if < #branch ;
: #if ( -- node ) peek-d 1array \ #if in-node ;
-TUPLE: #dispatch ;
+TUPLE: #dispatch < #branch ;
: #dispatch ( -- node ) peek-d 1array \ #dispatch in-node ;
-TUPLE: #merge ;
+TUPLE: #merge < node ;
: #merge ( -- node ) \ #merge all-out-node ;
-TUPLE: #terminate ;
+TUPLE: #terminate < node ;
-: #terminate ( -- node ) \ #terminate empty-node ;
+: #terminate ( -- node ) \ #terminate new ;
-TUPLE: #declare ;
+TUPLE: #declare < node ;
: #declare ( classes -- node ) \ #declare param-node ;
-UNION: #branch #if #dispatch ;
-
: node-inputs ( d-count r-count node -- )
tuck
- >r r-tail flatten-curries r> set-node-in-r
- >r d-tail flatten-curries r> set-node-in-d ;
+ [ swap d-tail flatten-curries >>in-d drop ]
+ [ swap r-tail flatten-curries >>in-r drop ] 2bi* ;
: node-outputs ( d-count r-count node -- )
tuck
- >r r-tail flatten-curries r> set-node-out-r
- >r d-tail flatten-curries r> set-node-out-d ;
+ [ swap d-tail flatten-curries >>out-d drop ]
+ [ swap r-tail flatten-curries >>out-r drop ] 2bi* ;
: node, ( node -- )
dataflow-graph get [
] if ;
: node-values ( node -- values )
- dup node-in-d
- over node-out-d
- pick node-in-r
- roll node-out-r 4array concat ;
+ { [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
+ 4array concat ;
: last-node ( node -- last )
- dup node-successor [ last-node ] [ ] ?if ;
+ dup successor>> [ last-node ] [ ] ?if ;
: penultimate-node ( node -- penultimate )
- dup node-successor dup [
- dup node-successor
+ dup successor>> dup [
+ dup successor>>
[ nip penultimate-node ] [ drop ] if
] [
2drop f
2dup 2slip rot [
2drop t
] [
- >r dup node-children swap node-successor add r>
+ >r [ children>> ] [ successor>> ] bi suffix r>
[ node-exists? ] curry contains?
] if
] [
M: node calls-label* 2drop f ;
-M: #call-label calls-label* node-param eq? ;
+M: #call-label calls-label* param>> eq? ;
: calls-label? ( label node -- ? )
[ calls-label* ] with node-exists? ;
: recursive-label? ( node -- ? )
- dup node-param swap calls-label? ;
+ [ param>> ] keep calls-label? ;
SYMBOL: node-stack
: node> node-stack get pop ;
: node@ node-stack get peek ;
-: iterate-next ( -- node ) node@ node-successor ;
+: iterate-next ( -- node ) node@ successor>> ;
: iterate-nodes ( node quot -- )
over [
] iterate-nodes drop
] with-node-iterator ; inline
-: change-children ( node quot -- )
+: map-children ( node quot -- )
over [
- >r dup node-children dup r>
- [ map swap set-node-children ] curry
- [ 2drop ] if
+ over children>> [
+ [ map ] curry change-children drop
+ ] [
+ 2drop
+ ] if
] [
2drop
] if ; inline
: (transform-nodes) ( prev node quot -- )
dup >r call dup [
- dup rot set-node-successor
- dup node-successor r> (transform-nodes)
+ >>successor
+ successor>> dup successor>>
+ r> (transform-nodes)
] [
- r> drop f swap set-node-successor drop
+ r> 2drop f >>successor drop
] if ; inline
: transform-nodes ( node quot -- new-node )
over [
- [ call dup dup node-successor ] keep (transform-nodes)
+ [ call dup dup successor>> ] keep (transform-nodes)
] [ drop ] if ; inline
: node-literal? ( node value -- ? )
- dup value? >r swap node-literals key? r> or ;
+ dup value? >r swap literals>> key? r> or ;
: node-literal ( node value -- obj )
dup value?
- [ nip value-literal ] [ swap node-literals at ] if ;
+ [ nip value-literal ] [ swap literals>> at ] if ;
: node-interval ( node value -- interval )
- swap node-intervals at ;
+ swap intervals>> at ;
: node-class ( node value -- class )
- swap node-classes at object or ;
+ swap classes>> at object or ;
: node-input-classes ( node -- seq )
- dup node-in-d [ node-class ] with map ;
+ dup in-d>> [ node-class ] with map ;
+
+: node-output-classes ( node -- seq )
+ dup out-d>> [ node-class ] with map ;
: node-input-intervals ( node -- seq )
- dup node-in-d [ node-interval ] with map ;
+ dup in-d>> [ node-interval ] with map ;
: node-class-first ( node -- class )
- dup node-in-d first node-class ;
+ dup in-d>> first node-class ;
: active-children ( node -- seq )
- node-children
- [ last-node ] map
- [ #terminate? not ] subset ;
+ children>> [ last-node ] map [ #terminate? not ] subset ;
DEFER: #tail?
-PREDICATE: #merge #tail-merge node-successor #tail? ;
+PREDICATE: #tail-merge < #merge node-successor #tail? ;
-PREDICATE: #values #tail-values node-successor #tail? ;
+PREDICATE: #tail-values < #values node-successor #tail? ;
UNION: #tail
POSTPONE: f #return #tail-values #tail-merge #terminate ;
#! We don't consider calls which do non-local exits to be
#! tail calls, because this gives better error traces.
node-stack get [
- node-successor dup #tail? swap #terminate? not and
+ successor>> [ #tail? ] [ #terminate? not ] bi and
] all? ;
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: inference.errors
USING: inference.backend inference.dataflow kernel generic
sequences prettyprint io words arrays inspector effects debugger
-assocs ;
+assocs accessors ;
M: inference-error error.
- dup inference-error-rstate
+ dup rstate>>
keys [ dup value? [ value-literal ] when ] map
dup empty? [ "Word: " write dup peek . ] unless
- swap delegate error. "Nesting: " write . ;
+ swap error>> error. "Nesting: " write . ;
M: inference-error error-help drop f ;
"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form."
$nl ;
+ARTICLE: "inference-errors" "Inference errors"
+"Main wrapper for all inference errors:"
+{ $subsection inference-error }
+"Specific inference errors:"
+{ $subsection no-effect }
+{ $subsection literal-expected }
+{ $subsection too-many->r }
+{ $subsection too-many-r> }
+{ $subsection unbalanced-branches-error }
+{ $subsection effect-error }
+{ $subsection recursive-declare-error } ;
+
ARTICLE: "inference" "Stack effect inference"
"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile."
$nl
{ $subsection "inference-combinators" }
{ $subsection "inference-branches" }
{ $subsection "inference-recursive" }
-{ $subsection "inference-limitations" }
+{ $subsection "inference-limitations" }
+{ $subsection "inference-errors" }
{ $subsection "dataflow-graphs" }
{ $subsection "compiler-transforms" } ;
{ $error-description
"Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred."
$nl
- "This error always delegates to one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:"
- { $list
- { $link no-effect }
- { $link literal-expected }
- { $link too-many->r }
- { $link too-many-r> }
- { $link unbalanced-branches-error }
- { $link effect-error }
- { $link recursive-declare-error }
- }
+ "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
} ;
math.parser math.private namespaces namespaces.private parser
sequences strings vectors words quotations effects tools.test
continuations generic.standard sorting assocs definitions
-prettyprint io inspector tuples classes.union classes.predicate
-debugger threads.private io.streams.string io.timeouts
-io.thread sequences.private ;
+prettyprint io inspector classes.tuple classes.union
+classes.predicate debugger threads.private io.streams.string
+io.timeouts io.thread sequences.private ;
IN: inference.tests
+[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
+[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
+
{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as
MATH: xyz
M: fixnum xyz 2array ;
M: float xyz
- [ 3 ] 2apply swapd >r 2array swap r> 2array swap ;
+ [ 3 ] bi@ swapd >r 2array swap r> 2array swap ;
[ [ xyz ] infer ] [ inference-error? ] must-fail-with
{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as
-TUPLE: custom-error ;
+ERROR: custom-error ;
[ T{ effect f 0 0 t } ] [
- [ custom-error construct-boa throw ] infer
+ [ custom-error ] infer
] unit-test
: funny-throw throw ; inline
: missing->r-check >r ;
[ [ missing->r-check ] infer ] must-fail
+
+{ 1 0 } [ [ ] map-children ] must-infer-as
namespaces.private parser prettyprint quotations
quotations.private sbufs sbufs.private sequences
sequences.private slots.private strings strings.private system
-threads.private tuples tuples.private vectors vectors.private
-words words.private assocs inspector compiler.units
-system.private ;
+threads.private classes.tuple classes.tuple.private vectors
+vectors.private words words.private assocs inspector
+compiler.units system.private ;
IN: inference.known-words
! Shuffle words
{ swap T{ effect f 2 { 1 0 } } }
} [ define-shuffle ] assoc-each
-\ >r [ infer->r ] "infer" set-word-prop
+\ >r [ 1 infer->r ] "infer" set-word-prop
-\ r> [ infer-r> ] "infer" set-word-prop
+\ r> [ 1 infer-r> ] "infer" set-word-prop
\ declare [
1 ensure-values
M: composed infer-call
infer-uncurry
- infer->r peek-d infer-call
- terminated? get [ infer-r> peek-d infer-call ] unless ;
+ 1 infer->r peek-d infer-call
+ terminated? get [ 1 infer-r> peek-d infer-call ] unless ;
M: object infer-call
\ literal-expected inference-warning ;
peek-d infer-call
] "infer" set-word-prop
+\ call t "no-compile" set-word-prop
+
\ execute [
1 ensure-values
pop-literal nip
! Variadic tuple constructor
\ <tuple-boa> [
\ <tuple-boa>
- peek-d value-literal { tuple } <effect>
+ peek-d value-literal layout-size { tuple } <effect>
make-call-node
] "infer" set-word-prop
\ setenv { object fixnum } { } <effect> set-primitive-effect
-\ (stat) { string } { object object object object } <effect> set-primitive-effect
+\ exists? { string } { object } <effect> set-primitive-effect
\ (directory) { string } { array } <effect> set-primitive-effect
-\ data-gc { } { } <effect> set-primitive-effect
-
-\ code-gc { } { } <effect> set-primitive-effect
+\ gc { } { } <effect> set-primitive-effect
\ gc-time { } { integer } <effect> set-primitive-effect
\ data-room { } { integer array } <effect> set-primitive-effect
\ data-room make-flushable
-\ code-room { } { integer integer } <effect> set-primitive-effect
+\ code-room { } { integer integer integer integer } <effect> set-primitive-effect
\ code-room make-flushable
\ os-env { string } { object } <effect> set-primitive-effect
\ millis { } { integer } <effect> set-primitive-effect
\ millis make-flushable
-\ type { object } { fixnum } <effect> set-primitive-effect
-\ type make-foldable
-
\ tag { object } { fixnum } <effect> set-primitive-effect
\ tag make-foldable
-\ class-hash { object } { fixnum } <effect> set-primitive-effect
-\ class-hash make-foldable
-
\ cwd { } { string } <effect> set-primitive-effect
\ cd { string } { } <effect> set-primitive-effect
\ set-alien-cell { c-ptr c-ptr integer } { } <effect> set-primitive-effect
-\ alien>char-string { c-ptr } { string } <effect> set-primitive-effect
-\ alien>char-string make-flushable
-
-\ string>char-alien { string } { byte-array } <effect> set-primitive-effect
-\ string>char-alien make-flushable
-
-\ alien>u16-string { c-ptr } { string } <effect> set-primitive-effect
-\ alien>u16-string make-flushable
-
-\ string>u16-alien { string } { byte-array } <effect> set-primitive-effect
-\ string>u16-alien make-flushable
-
\ alien-address { alien } { integer } <effect> set-primitive-effect
\ alien-address make-flushable
\ quotation-xt { quotation } { integer } <effect> set-primitive-effect
\ quotation-xt make-flushable
-\ <tuple> { word integer } { quotation } <effect> set-primitive-effect
+\ <tuple> { tuple-layout } { tuple } <effect> set-primitive-effect
\ <tuple> make-flushable
-\ (>tuple) { array } { tuple } <effect> set-primitive-effect
-\ (>tuple) make-flushable
-
-\ tuple>array { tuple } { array } <effect> set-primitive-effect
-\ tuple>array make-flushable
+\ <tuple-layout> { word fixnum array fixnum } { tuple-layout } <effect> set-primitive-effect
+\ <tuple-layout> make-foldable
\ datastack { } { array } <effect> set-primitive-effect
\ datastack make-flushable
\ (os-envs) { } { array } <effect> set-primitive-effect
+\ set-os-env { string string } { } <effect> set-primitive-effect
+
+\ unset-os-env { string } { } <effect> set-primitive-effect
+
\ (set-os-envs) { array } { } <effect> set-primitive-effect
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
\ dll-valid? { object } { object } <effect> set-primitive-effect
\ modify-code-heap { array object } { } <effect> set-primitive-effect
+
+\ unimplemented { } { } <effect> set-primitive-effect
IN: inference.transforms.tests
USING: sequences inference.transforms tools.test math kernel
-quotations inference ;
+quotations inference accessors combinators words arrays
+classes ;
: compose-n-quot <repetition> >quotation ;
: compose-n compose-n-quot call ;
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test
-\ construct-empty must-infer
+\ new must-infer
TUPLE: a-tuple x y z ;
{ set-a-tuple-x set-a-tuple-x } set-slots ;
[ [ set-slots-test-2 ] infer ] must-fail
+
+TUPLE: color r g b ;
+
+C: <color> color
+
+: cleave-test { [ r>> ] [ g>> ] [ b>> ] } cleave ;
+
+{ 1 3 } [ cleave-test ] must-infer-as
+
+[ 1 2 3 ] [ 1 2 3 <color> cleave-test ] unit-test
+
+[ 1 2 3 ] [ 1 2 3 <color> \ cleave-test word-def call ] unit-test
+
+: 2cleave-test { [ 2array ] [ + ] [ - ] } 2cleave ;
+
+[ { 1 2 } 3 -1 ] [ 1 2 2cleave-test ] unit-test
+
+[ { 1 2 } 3 -1 ] [ 1 2 \ 2cleave-test word-def call ] unit-test
+
+: spread-test { [ sq ] [ neg ] [ recip ] } spread ;
+
+[ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test
+
+[ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test
+
+[ fixnum instance? ] must-infer
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel words sequences generic math namespaces
quotations assocs combinators math.bitfields inference.backend
-inference.dataflow inference.state tuples.private effects
-inspector hashtables ;
+inference.dataflow inference.state classes.tuple.private effects
+inspector hashtables classes generic sets ;
IN: inference.transforms
: pop-literals ( n -- rstate seq )
] if
] 1 define-transform
+\ cleave [ cleave>quot ] 1 define-transform
+
+\ 2cleave [ 2cleave>quot ] 1 define-transform
+
+\ 3cleave [ 3cleave>quot ] 1 define-transform
+
+\ spread [ spread>quot ] 1 define-transform
+
! Bitfields
GENERIC: (bitfield-quot) ( spec -- quot )
[ shift bitor ] append 2curry ;
: bitfield-quot ( spec -- quot )
- [ (bitfield-quot) ] map [ 0 ] add* concat ;
+ [ (bitfield-quot) ] map [ 0 ] prefix concat ;
\ bitfield [ bitfield-quot ] 1 define-transform
\ get-slots [ [get-slots] ] 1 define-transform
-TUPLE: duplicated-slots-error names ;
+ERROR: duplicated-slots-error names ;
M: duplicated-slots-error summary
drop "Calling set-slots with duplicate slot setters" ;
-: duplicated-slots-error ( names -- * )
- \ duplicated-slots-error construct-boa throw ;
-
\ set-slots [
dup all-unique?
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if
] 1 define-transform
-\ construct-boa [
+\ boa [
dup +inlined+ depends-on
- dup tuple-size [ <tuple-boa> ] 2curry
+ tuple-layout [ <tuple-boa> ] curry
] 1 define-transform
-\ construct-empty [
+\ new [
1 ensure-values
peek-d value? [
pop-literal
dup +inlined+ depends-on
- dup tuple-size [ <tuple> ] 2curry
+ tuple-layout [ <tuple> ] curry
swap infer-quot
] [
- \ construct-empty 1 1 <effect> make-call-node
+ \ new 1 1 <effect> make-call-node
] if
] "infer" set-word-prop
+
+\ instance? [
+ [ +inlined+ depends-on ] [ "predicate" word-prop ] bi
+] 1 define-transform
+
+\ (call-next-method) [
+ [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
+] 2 define-transform
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables io kernel assocs math
namespaces prettyprint sequences strings io.styles vectors words
-quotations mirrors splitting math.parser classes vocabs refs ;
+quotations mirrors splitting math.parser classes vocabs refs
+sets ;
IN: inspector
GENERIC: summary ( object -- string )
-IN: io.backend.tests\r
-USING: tools.test io.backend kernel ;\r
-\r
-[ ] [ "a" normalize-pathname drop ] unit-test\r
+IN: io.backend.tests
+USING: tools.test io.backend kernel ;
+
+[ ] [ "a" normalize-path drop ] unit-test
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: init kernel system namespaces io io.encodings io.encodings.utf8 ;
+USING: init kernel system namespaces io io.encodings
+io.encodings.utf8 init assocs splitting ;
IN: io.backend
SYMBOL: io-backend
HOOK: normalize-directory io-backend ( str -- newstr )
-M: object normalize-directory ;
+HOOK: normalize-path io-backend ( str -- newstr )
-HOOK: normalize-pathname io-backend ( str -- newstr )
-
-M: object normalize-pathname ;
+M: object normalize-directory normalize-path ;
: set-io-backend ( io-backend -- )
- io-backend set-global init-io init-stdio ;
+ io-backend set-global init-io init-stdio
+ "io.files" init-hooks get at call ;
[ init-io embedded? [ init-stdio ] unless ]
"io.backend" add-init-hook
IN: io.encodings.binary
HELP: binary
-{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." } ;
+{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." }
+{ $see-also "encodings-introduction" } ;
+
+ABOUT: binary
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.encodings.binary SYMBOL: binary
+USING: io.encodings kernel ;
+IN: io.encodings.binary
+
+TUPLE: binary ;
+M: binary <encoder> drop ;
+M: binary <decoder> drop ;
USING: help.markup help.syntax ;
IN: io.encodings
-ABOUT: "encodings"
+ABOUT: "io.encodings"
ARTICLE: "io.encodings" "I/O encodings"
-"Many streams deal with bytes, rather than Unicode code points, at some level. The translation between these two things is specified by an encoding. To abstract this away from the programmer, Factor provides a system where these streams are associated with an encoding which is always used when the stream is read from or written to. For most purposes, an encoding descriptor consisting of a symbol is all that is needed when initializing a stream."
+"Bytes can't be understood in isolation as text. They must be interpreted under a certain encoding. Factor provides utilities for dealing with encoded text by declaring that a stream has a particular encoding, and utilities to encode and decode strings."
{ $subsection "encodings-constructors" }
{ $subsection "encodings-descriptors" }
{ $subsection "encodings-protocol" } ;
-ARTICLE: "encodings-constructors" "Constructing an encoded stream"
+ARTICLE: "encodings-constructors" "Manually constructing an encoded stream"
+"The following words can be used to construct encoded streams. Note that they are usually not used directly, but rather by the stream constructors themselves. Most stream constructors take an encoding descriptor as a parameter and internally call these constructors."
{ $subsection <encoder> }
{ $subsection <decoder> }
{ $subsection <encoder-duplex> } ;
-HELP: <encoder> ( stream encoding -- newstream )
+HELP: <encoder>
{ $values { "stream" "an output stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
-{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
+{ $description "Wraps the given stream in a new stream using the given encoding for all output. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
+$low-level-note ;
-HELP: <decoder> ( stream encoding -- newstream )
+HELP: <decoder>
{ $values { "stream" "an input stream" }
{ "encoding" "an encoding descriptor" }
{ "newstream" "an encoded output stream" } }
-{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." } ;
+{ $description "Wraps the given stream in a new stream using the given encoding for all input. The encoding descriptor can either be a class or an instance of something conforming to the " { $link "encodings-protocol" } "." }
+$low-level-note ;
-HELP: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
+HELP: <encoder-duplex>
{ $values { "stream-in" "an input stream" }
{ "stream-out" "an output stream" }
{ "encoding" "an encoding descriptor" }
{ "duplex" "an encoded duplex stream" } }
-{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." } ;
+{ $description "Wraps the given streams in an encoder or decoder stream, and puts them together in a duplex stream for input and output. If either input stream is already encoded, that encoding is stripped off before it is reencoded. The encoding descriptor must conform to the " { $link "encodings-protocol" } "." }
+$low-level-note ;
{ <encoder> <decoder> <encoder-duplex> } related-words
ARTICLE: "encodings-descriptors" "Encoding descriptors"
"An encoding descriptor is something which can be used for input or output streams to encode or decode files. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
-$nl { $vocab-link "io.encodings.utf8" }
-$nl { $vocab-link "io.encodings.ascii" }
-$nl { $vocab-link "io.encodings.binary" }
-$nl { $vocab-link "io.encodings.utf16" } ;
+{ $subsection "io.encodings.binary" }
+{ $subsection "io.encodings.utf8" }
+{ $subsection "io.encodings.utf16" }
+{ $vocab-subsection "Strict encodings" "io.encodings.strict" }
+"Legacy encodings:"
+{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
+{ $vocab-subsection "ASCII" "io.encodings.ascii" }
+{ $see-also "encodings-introduction" } ;
ARTICLE: "encodings-protocol" "Encoding protocol"
-"An encoding descriptor must implement the following methods. The methods are implemented on tuple classes by instantiating the class and calling the method again."
-{ $subsection decode-step }
-{ $subsection init-decoder }
-{ $subsection stream-write-encoded } ;
+"There are two parts to implementing a new encoding. First, methods for creating an encoded or decoded stream must be provided. These have defaults, however, which wrap a stream in an encoder or decoder wrapper with the given encoding descriptor."
+{ $subsection <encoder> }
+{ $subsection <decoder> }
+"If an encoding might be contained in the code slot of an encoder or decoder tuple, then the following methods must be implemented to read or write one code point from a stream:"
+{ $subsection decode-char }
+{ $subsection encode-char }
+{ $see-also "encodings-introduction" } ;
-HELP: decode-step ( buf char encoding -- )
-{ $values { "buf" "A string buffer which characters can be pushed to" }
- { "char" "An octet which is read from a stream" }
- { "encoding" "An encoding descriptor tuple" } }
-{ $description "A single step in the decoding process must be defined for the decoding descriptor. When each octet is read, this word is called, and depending on the decoder's internal state, something may be pushed to the buffer or the state may change. This should not be used directly." } ;
+HELP: decode-char
+{ $values { "stream" "an underlying input stream" }
+ { "encoding" "An encoding descriptor tuple" } { "char/f" "a code point or " { $link f } } }
+{ $contract "Reads a single code point from the underlying stream, interpreting it by the encoding." }
+$low-level-note ;
-HELP: stream-write-encoded ( string stream encoding -- )
-{ $values { "string" "a string" }
- { "stream" "an output stream" }
- { "encoding" "an encoding descriptor" } }
-{ $description "Encodes the string with the given encoding descriptor, outputing the result to the given stream. This should not be used directly." } ;
-
-HELP: init-decoder ( stream encoding -- encoding )
-{ $values { "stream" "an input stream" }
+HELP: encode-char
+{ $values { "char" "a character" }
+ { "stream" "an underlying output stream" }
{ "encoding" "an encoding descriptor" } }
-{ $description "Initializes the decoder tuple's state. The stream is exposed so that it can be read, eg for a BOM. This should not be used directly." } ;
+{ $contract "Writes the code point in the encoding to the underlying stream given." }
+$low-level-note ;
-{ init-decoder decode-step stream-write-encoded } related-words
+{ encode-char decode-char } related-words
resource-path ascii <file-reader> ;
[ { } ]
-[ "/core/io/test/empty-file.txt" <resource-reader> lines ]
+[ "core/io/test/empty-file.txt" <resource-reader> lines ]
unit-test
: lines-test ( stream -- line1 line2 )
"This is a line."
"This is another line."
] [
- "/core/io/test/windows-eol.txt" <resource-reader> lines-test
+ "core/io/test/windows-eol.txt" <resource-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
- "/core/io/test/mac-os-eol.txt" <resource-reader> lines-test
+ "core/io/test/mac-os-eol.txt" <resource-reader> lines-test
] unit-test
[
"This is a line."
"This is another line."
] [
- "/core/io/test/unix-eol.txt" <resource-reader> lines-test
+ "core/io/test/unix-eol.txt" <resource-reader> lines-test
] unit-test
[
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel sequences sbufs vectors namespaces
-growable strings io classes continuations combinators
-io.styles io.streams.plain io.encodings.binary splitting
-io.streams.duplex byte-arrays ;
+USING: math kernel sequences sbufs vectors namespaces growable
+strings io classes continuations combinators io.styles
+io.streams.plain splitting io.streams.duplex byte-arrays
+sequences.private accessors ;
IN: io.encodings
! The encoding descriptor protocol
-GENERIC: decode-step ( buf char encoding -- )
-M: object decode-step drop swap push ;
+GENERIC: decode-char ( stream encoding -- char/f )
-GENERIC: init-decoder ( stream encoding -- encoding )
-M: tuple-class init-decoder construct-empty init-decoder ;
-M: object init-decoder nip ;
+GENERIC: encode-char ( char stream encoding -- )
-GENERIC: stream-write-encoded ( string stream encoding -- byte-array )
-M: object stream-write-encoded drop stream-write ;
+GENERIC: <decoder> ( stream encoding -- newstream )
-! Decoding
-
-TUPLE: decode-error ;
-
-: decode-error ( -- * ) \ decode-error construct-empty throw ;
+: replacement-char HEX: fffd ;
-SYMBOL: begin
+TUPLE: decoder stream code cr ;
-: push-decoded ( buf ch -- buf ch state )
- over push 0 begin ;
+ERROR: decode-error ;
-: push-replacement ( buf -- buf ch state )
- ! This is the replacement character
- HEX: fffd push-decoded ;
+GENERIC: <encoder> ( stream encoding -- newstream )
-: space ( resizable -- room-left )
- dup underlying swap [ length ] 2apply - ;
+TUPLE: encoder stream code ;
-: full? ( resizable -- ? ) space zero? ;
+ERROR: encode-error ;
-: end-read-loop ( buf ch state stream quot -- string/f )
- 2drop 2drop >string f like ;
+! Decoding
-: decode-read-loop ( buf stream encoding -- string/f )
- pick full? [ 2drop >string ] [
- over stream-read1 [
- -rot tuck >r >r >r dupd r> decode-step r> r>
- decode-read-loop
- ] [ 2drop >string f like ] if*
- ] if ;
+<PRIVATE
-: decode-read ( length stream encoding -- string )
- rot <sbuf> -rot decode-read-loop ;
+M: tuple-class <decoder> new <decoder> ;
+M: tuple <decoder> f decoder boa ;
-TUPLE: decoder code cr ;
-: <decoder> ( stream encoding -- newstream )
- dup binary eq? [ drop ] [
- dupd init-decoder { set-delegate set-decoder-code }
- decoder construct
- ] if ;
+: >decoder< ( decoder -- stream encoding )
+ [ stream>> ] [ code>> ] bi ;
: cr+ t swap set-decoder-cr ; inline
over decoder-cr [
over cr-
"\n" ?head [
- swap stream-read1 [ add ] when*
- ] [ nip ] if
- ] [ nip ] if ;
+ over stream-read1 [ suffix ] when*
+ ] when
+ ] when nip ;
+
+: read-loop ( n stream -- string )
+ SBUF" " clone [
+ [
+ >r nip stream-read1 dup
+ [ r> push f ] [ r> 2drop t ] if
+ ] 2curry find-integer drop
+ ] keep "" like f like ;
M: decoder stream-read
- tuck { delegate decoder-code } get-slots decode-read fix-read ;
+ tuck read-loop fix-read ;
M: decoder stream-read-partial stream-read ;
-: decoder-read-until ( stream delim -- ch )
- ! Copied from { c-reader stream-read-until }!!!
- over stream-read1 dup [
- dup pick memq? [ 2nip ] [ , decoder-read-until ] if
- ] [
- 2nip
- ] if ;
+: (read-until) ( buf quot -- string/f sep/f )
+ ! quot: -- char stop?
+ dup call
+ [ >r drop "" like r> ]
+ [ pick push (read-until) ] if ; inline
M: decoder stream-read-until
- ! Copied from { c-reader stream-read-until }!!!
- [ swap decoder-read-until ] "" make
- swap over empty? over not and [ 2drop f f ] when ;
+ SBUF" " clone -rot >decoder<
+ [ decode-char [ dup rot memq? ] [ drop f t ] if* ] 3curry
+ (read-until) ;
: fix-read1 ( stream char -- char )
over decoder-cr [
over cr-
dup CHAR: \n = [
- drop stream-read1
- ] [ nip ] if
- ] [ nip ] if ;
+ drop dup stream-read1
+ ] when
+ ] when nip ;
M: decoder stream-read1
- 1 swap stream-read f like [ first ] [ f ] if* ;
+ dup >decoder< decode-char fix-read1 ;
M: decoder stream-readln ( stream -- str )
"\r\n" over stream-read-until handle-readln ;
-! Encoding
+M: decoder dispose decoder-stream dispose ;
-TUPLE: encode-error ;
-
-: encode-error ( -- * ) \ encode-error construct-empty throw ;
+! Encoding
+M: tuple-class <encoder> new <encoder> ;
+M: tuple <encoder> encoder boa ;
-TUPLE: encoder code ;
-: <encoder> ( stream encoding -- newstream )
- dup binary eq? [ drop ] [
- construct-empty { set-delegate set-encoder-code }
- encoder construct
- ] if ;
+: >encoder< ( encoder -- stream encoding )
+ [ stream>> ] [ code>> ] bi ;
M: encoder stream-write1
- >r 1string r> stream-write ;
+ >encoder< encode-char ;
M: encoder stream-write
- { delegate encoder-code } get-slots stream-write-encoded ;
+ >encoder< [ encode-char ] 2curry each ;
-M: encoder dispose delegate dispose ;
+M: encoder dispose encoder-stream dispose ;
+
+M: encoder stream-flush encoder-stream stream-flush ;
INSTANCE: encoder plain-writer
! Rebinding duplex streams which have not read anything yet
: reencode ( stream encoding -- newstream )
- over encoder? [ >r delegate r> ] when <encoder> ;
+ over encoder? [ >r encoder-stream r> ] when <encoder> ;
: redecode ( stream encoding -- newstream )
- over decoder? [ >r delegate r> ] when <decoder> ;
+ over decoder? [ >r decoder-stream r> ] when <decoder> ;
+
+PRIVATE>
: <encoder-duplex> ( stream-in stream-out encoding -- duplex )
tuck reencode >r redecode r> <duplex-stream> ;
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+UTF16 encoding/decoding
--- /dev/null
+USING: help.markup help.syntax io.encodings strings ;
+IN: io.encodings.utf16
+
+ARTICLE: "io.encodings.utf16" "UTF-16"
+"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
+{ $subsection utf16 }
+{ $subsection utf16le }
+{ $subsection utf16be } ;
+
+ABOUT: "io.encodings.utf16"
+
+HELP: utf16le
+{ $class-description "The encoding descriptor for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: utf16be
+{ $class-description "The encoding descriptor for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: utf16
+{ $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+{ utf16 utf16le utf16be } related-words
--- /dev/null
+USING: kernel tools.test io.encodings.utf16 arrays sbufs
+io.streams.byte-array sequences io.encodings io unicode
+io.encodings.string alien.c-types alien.strings accessors classes ;
+IN: io.encodings.utf16.tests
+
+[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test
+[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
+
+[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test
+
+[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test
+[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
+[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
+
+[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test
+
+[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
+[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
+
+[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
+
+: correct-endian
+ code>> class little-endian? [ utf16le = ] [ utf16be = ] if ;
+
+[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
+[ t ] [ utf16n <byte-writer> correct-endian ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math kernel sequences sbufs vectors namespaces io.binary
+io.encodings combinators splitting io byte-arrays inspector ;
+IN: io.encodings.utf16
+
+TUPLE: utf16be ;
+
+TUPLE: utf16le ;
+
+TUPLE: utf16 ;
+
+<PRIVATE
+
+! UTF-16BE decoding
+
+: append-nums ( byte ch -- ch )
+ over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
+
+: double-be ( stream byte -- stream char )
+ over stream-read1 swap append-nums ;
+
+: quad-be ( stream byte -- stream char )
+ double-be over stream-read1 [
+ dup -2 shift BIN: 110111 number= [
+ >r 2 shift r> BIN: 11 bitand bitor
+ over stream-read1 swap append-nums HEX: 10000 +
+ ] [ 2drop dup stream-read1 drop replacement-char ] if
+ ] when* ;
+
+: ignore ( stream -- stream char )
+ dup stream-read1 drop replacement-char ;
+
+: begin-utf16be ( stream byte -- stream char )
+ dup -3 shift BIN: 11011 number= [
+ dup BIN: 00000100 bitand zero?
+ [ BIN: 11 bitand quad-be ]
+ [ drop ignore ] if
+ ] [ double-be ] if ;
+
+M: utf16be decode-char
+ drop dup stream-read1 dup [ begin-utf16be ] when nip ;
+
+! UTF-16LE decoding
+
+: quad-le ( stream ch -- stream char )
+ over stream-read1 swap 10 shift bitor
+ over stream-read1 dup -2 shift BIN: 110111 = [
+ BIN: 11 bitand append-nums HEX: 10000 +
+ ] [ 2drop replacement-char ] if ;
+
+: double-le ( stream byte1 byte2 -- stream char )
+ dup -3 shift BIN: 11011 = [
+ dup BIN: 100 bitand 0 number=
+ [ BIN: 11 bitand 8 shift bitor quad-le ]
+ [ 2drop replacement-char ] if
+ ] [ append-nums ] if ;
+
+: begin-utf16le ( stream byte -- stream char )
+ over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
+
+M: utf16le decode-char
+ drop dup stream-read1 dup [ begin-utf16le ] when nip ;
+
+! UTF-16LE/BE encoding
+
+: encode-first ( char -- byte1 byte2 )
+ -10 shift
+ dup -8 shift BIN: 11011000 bitor
+ swap HEX: FF bitand ;
+
+: encode-second ( char -- byte3 byte4 )
+ BIN: 1111111111 bitand
+ dup -8 shift BIN: 11011100 bitor
+ swap BIN: 11111111 bitand ;
+
+: stream-write2 ( stream char1 char2 -- )
+ rot [ stream-write1 ] curry bi@ ;
+
+: char>utf16be ( stream char -- )
+ dup HEX: FFFF > [
+ HEX: 10000 -
+ 2dup encode-first stream-write2
+ encode-second stream-write2
+ ] [ h>b/b swap stream-write2 ] if ;
+
+M: utf16be encode-char ( char stream encoding -- )
+ drop swap char>utf16be ;
+
+: char>utf16le ( char stream -- )
+ dup HEX: FFFF > [
+ HEX: 10000 -
+ 2dup encode-first swap stream-write2
+ encode-second swap stream-write2
+ ] [ h>b/b stream-write2 ] if ;
+
+M: utf16le encode-char ( char stream encoding -- )
+ drop swap char>utf16le ;
+
+! UTF-16
+
+: bom-le B{ HEX: ff HEX: fe } ; inline
+
+: bom-be B{ HEX: fe HEX: ff } ; inline
+
+: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
+
+: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
+
+TUPLE: missing-bom ;
+M: missing-bom summary drop "The BOM for a UTF-16 stream was missing" ;
+
+: bom>le/be ( bom -- le/be )
+ dup bom-le sequence= [ drop utf16le ] [
+ bom-be sequence= [ utf16be ] [ missing-bom ] if
+ ] if ;
+
+M: utf16 <decoder> ( stream utf16 -- decoder )
+ drop 2 over stream-read bom>le/be <decoder> ;
+
+M: utf16 <encoder> ( stream utf16 -- encoder )
+ drop bom-le over stream-write utf16le <encoder> ;
+
+PRIVATE>
-USING: help.markup help.syntax io.encodings strings io.files ;
+USING: help.markup help.syntax ;
IN: io.encodings.utf8
-ARTICLE: "io.encodings.utf8" "Working with UTF8-encoded data"
-"The UTF8 encoding is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences. The encoding descriptor for UTF-8:"
-{ $subsection utf8 } ;
-
HELP: utf8
-{ $class-description "This is the class of encoding tuples which denote a UTF-8 encoding. This conforms to the " { $link "encodings-protocol" } "." } ;
+{ $class-description "This is the encoding descriptor for a UTF-8 encoding. UTF-8 is a variable-width encoding. 7-bit ASCII characters are encoded as single bytes, and other Unicode code points are encoded as 2 to 4 byte sequences." }
+{ $see-also "encodings-introduction" } ;
-ABOUT: "io.encodings.utf8"
+ABOUT: utf8
! Decoding UTF-8
-TUPLE: utf8 ch state ;
+TUPLE: utf8 ;
-SYMBOL: double
-SYMBOL: triple
-SYMBOL: triple2
-SYMBOL: quad
-SYMBOL: quad2
-SYMBOL: quad3
+<PRIVATE
: starts-2? ( char -- ? )
- -6 shift BIN: 10 number= ;
+ dup [ -6 shift BIN: 10 number= ] when ;
-: append-nums ( buf bottom top state-out -- buf num state )
- >r over starts-2?
- [ 6 shift swap BIN: 111111 bitand bitor r> ]
- [ r> 3drop push-replacement ] if ;
+: append-nums ( stream byte -- stream char )
+ over stream-read1 dup starts-2?
+ [ swap 6 shift swap BIN: 111111 bitand bitor ]
+ [ 2drop replacement-char ] if ;
-: begin-utf8 ( buf byte -- buf ch state )
- {
- { [ dup -7 shift zero? ] [ push-decoded ] }
- { [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] }
- { [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] }
- { [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] }
- { [ t ] [ drop push-replacement ] }
- } cond ;
+: double ( stream byte -- stream char )
+ BIN: 11111 bitand append-nums ;
-: end-multibyte ( buf byte ch -- buf ch state )
- f append-nums [ push-decoded ] unless* ;
-
-: decode-utf8-step ( buf byte ch state -- buf ch state )
- {
- { begin [ drop begin-utf8 ] }
- { double [ end-multibyte ] }
- { triple [ triple2 append-nums ] }
- { triple2 [ end-multibyte ] }
- { quad [ quad2 append-nums ] }
- { quad2 [ quad3 append-nums ] }
- { quad3 [ end-multibyte ] }
- } case ;
+: triple ( stream byte -- stream char )
+ BIN: 1111 bitand append-nums append-nums ;
-: unpack-state ( encoding -- ch state )
- { utf8-ch utf8-state } get-slots ;
+: quad ( stream byte -- stream char )
+ BIN: 111 bitand append-nums append-nums append-nums ;
-: pack-state ( ch state encoding -- )
- { set-utf8-ch set-utf8-state } set-slots ;
+: begin-utf8 ( stream byte -- stream char )
+ {
+ { [ dup -7 shift zero? ] [ ] }
+ { [ dup -5 shift BIN: 110 number= ] [ double ] }
+ { [ dup -4 shift BIN: 1110 number= ] [ triple ] }
+ { [ dup -3 shift BIN: 11110 number= ] [ quad ] }
+ [ drop replacement-char ]
+ } cond ;
-M: utf8 decode-step ( buf char encoding -- )
- [ unpack-state decode-utf8-step ] keep pack-state drop ;
+: decode-utf8 ( stream -- char/f )
+ dup stream-read1 dup [ begin-utf8 ] when nip ;
-M: utf8 init-decoder nip begin over set-utf8-state ;
+M: utf8 decode-char
+ drop decode-utf8 ;
! Encoding UTF-8
-: encoded ( char -- )
- BIN: 111111 bitand BIN: 10000000 bitor write1 ;
+: encoded ( stream char -- )
+ BIN: 111111 bitand BIN: 10000000 bitor swap stream-write1 ;
-: char>utf8 ( char -- )
+: char>utf8 ( stream char -- )
{
- { [ dup -7 shift zero? ] [ write1 ] }
+ { [ dup -7 shift zero? ] [ swap stream-write1 ] }
{ [ dup -11 shift zero? ] [
- dup -6 shift BIN: 11000000 bitor write1
+ 2dup -6 shift BIN: 11000000 bitor swap stream-write1
encoded
] }
{ [ dup -16 shift zero? ] [
- dup -12 shift BIN: 11100000 bitor write1
- dup -6 shift encoded
+ 2dup -12 shift BIN: 11100000 bitor swap stream-write1
+ 2dup -6 shift encoded
encoded
] }
- { [ t ] [
- dup -18 shift BIN: 11110000 bitor write1
- dup -12 shift encoded
- dup -6 shift encoded
+ [
+ 2dup -18 shift BIN: 11110000 bitor swap stream-write1
+ 2dup -12 shift encoded
+ 2dup -6 shift encoded
encoded
- ] }
+ ]
} cond ;
-M: utf8 stream-write-encoded
- ! For efficiency, this should be modified to avoid variable reads
- drop [ [ char>utf8 ] each ] with-stream* ;
+M: utf8 encode-char
+ drop swap char>utf8 ;
+
+PRIVATE>
{ $subsection <file-reader> }
{ $subsection <file-writer> }
{ $subsection <file-appender> }
+"Reading and writing the entire contents of a file; this is only recommended for smaller files:"
+{ $subsection file-contents }
+{ $subsection set-file-contents }
+{ $subsection file-lines }
+{ $subsection set-file-lines }
"Utility combinators:"
{ $subsection with-file-reader }
{ $subsection with-file-writer }
-{ $subsection with-file-appender }
-{ $subsection file-contents }
-{ $subsection file-lines } ;
+{ $subsection with-file-appender } ;
ARTICLE: "pathnames" "Pathname manipulation"
"Pathname manipulation:"
{ $subsection parent-directory }
{ $subsection file-name }
{ $subsection last-path-separator }
-{ $subsection path+ }
-"Pathnames relative to Factor's install directory:"
-{ $subsection resource-path }
-{ $subsection ?resource-path }
+{ $subsection append-path }
"Pathnames relative to Factor's temporary files directory:"
{ $subsection temp-directory }
{ $subsection temp-file }
{ $subsection pathname }
{ $subsection <pathname> } ;
-ARTICLE: "directories" "Directories"
-"Current and home directories:"
-{ $subsection cwd }
-{ $subsection cd }
+ARTICLE: "symbolic-links" "Symbolic links"
+"Reading and creating links:"
+{ $subsection read-link }
+{ $subsection make-link }
+"Copying links:"
+{ $subsection copy-link }
+"Not all operating systems support symbolic links."
+{ $see-also link-info } ;
+
+ARTICLE: "current-directory" "Current working directory"
+"File system I/O operations use the value of a variable to resolve relative pathnames:"
+{ $subsection current-directory }
+"This variable can be changed with a pair of words:"
+{ $subsection set-current-directory }
{ $subsection with-directory }
+"This variable is independent of the operating system notion of ``current working directory''. While all Factor I/O operations use the variable and not the operating system's value, care must be taken when making FFI calls which expect a pathname. The first option is to resolve relative paths:"
+{ $subsection (normalize-path) }
+"The second is to change the working directory of the current process:"
+{ $subsection cd }
+{ $subsection cwd } ;
+
+ARTICLE: "directories" "Directories"
+"Home directory:"
{ $subsection home }
"Directory listing:"
{ $subsection directory }
{ $subsection directory* }
"Creating directories:"
{ $subsection make-directory }
-{ $subsection make-directories } ;
-
-! ARTICLE: "file-types" "File Types"
-
-! { $table { +directory+ "" } }
-
-! ;
-
-ARTICLE: "fs-meta" "File meta-data"
-
+{ $subsection make-directories }
+{ $subsection "current-directory" } ;
+
+ARTICLE: "file-types" "File Types"
+"Platform-independent types:"
+{ $subsection +regular-file+ }
+{ $subsection +directory+ }
+"Platform-specific types:"
+{ $subsection +character-device+ }
+{ $subsection +block-device+ }
+{ $subsection +fifo+ }
+{ $subsection +symbolic-link+ }
+{ $subsection +socket+ }
+{ $subsection +unknown+ } ;
+
+ARTICLE: "fs-meta" "File metadata"
+"Querying file-system metadata:"
{ $subsection file-info }
{ $subsection link-info }
{ $subsection exists? }
{ $subsection directory? }
-! { $subsection file-modified }
-{ $subsection stat } ;
+"File types:"
+{ $subsection "file-types" } ;
ARTICLE: "delete-move-copy" "Deleting, moving, copying files"
"Operations for deleting and copying files come in two forms:"
{ $subsection "file-streams" }
{ $subsection "fs-meta" }
{ $subsection "directories" }
-{ $subsection "delete-move-copy" }
-{ $see-also "os" } ;
+{ $subsection "delete-move-copy" } ;
ABOUT: "io.files"
! need a $class-description file-info
HELP: file-info
+{ $values { "path" "a pathname string" } { "info" file-info } }
+{ $description "Queries the file system for metadata. If " { $snippet "path" } " refers to a symbolic link, it is followed. See the article " { $link "file-types" } " for a list of metadata symbols." }
+{ $errors "Throws an error if the file does not exist." } ;
- { $values { "path" "a pathname string" }
- { "info" file-info } }
- { $description "Queries the file system for meta data. "
- "If path refers to a symbolic link, it is followed."
- "If the file does not exist, an exception is thrown." }
+HELP: link-info
+{ $values { "path" "a pathname string" } { "info" "a file-info tuple" } }
+{ $description "Queries the file system for metadata. If path refers to a symbolic link, information about the symbolic link itself is returned. If the file does not exist, an exception is thrown." } ;
- { $class-description "File meta data" }
+{ file-info link-info } related-words
- { $table
- { "type" { "One of the following:"
- { $list { $link +regular-file+ }
- { $link +directory+ }
- { $link +symbolic-link+ } } } }
+HELP: +regular-file+
+{ $description "A regular file. This type exists on all platforms. See " { $link "file-streams" } " for words operating on files." } ;
- { "size" "Size of the file in bytes" }
- { "modified" "Last modification timestamp." } }
+HELP: +directory+
+{ $description "A directory. This type exists on all platforms. See " { $link "directories" } " for words operating on directories." } ;
- ;
+HELP: +symbolic-link+
+{ $description "A symbolic link file. This type is currently implemented on Unix platforms only. See " { $link "symbolic-links" } " for words operating on symbolic links." } ;
-! need a see also to link-info
+HELP: +character-device+
+{ $description "A Unix character device file. This type exists on unix platforms only." } ;
-HELP: link-info
- { $values { "path" "a pathname string" }
- { "info" "a file-info tuple" } }
- { $description "Queries the file system for meta data. "
- "If path refers to a symbolic link, information about "
- "the symbolic link itself is returned."
- "If the file does not exist, an exception is thrown." } ;
-! need a see also to file-info
+HELP: +block-device+
+{ $description "A Unix block device file. This type exists on unix platforms only." } ;
-{ file-info link-info } related-words
+HELP: +fifo+
+{ $description "A Unix fifo file. This type exists on unix platforms only." } ;
+
+HELP: +socket+
+{ $description "A Unix socket file. This type exists on unix platforms only." } ;
+
+HELP: +unknown+
+{ $description "A unknown file type." } ;
HELP: <file-reader>
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" { "stream" "an input stream" } }
{ $description "Opens a file for appending using the given encoding and calls the quotation using " { $link with-stream } "." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
+HELP: set-file-lines
+{ $values { "seq" "an array of strings" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
+{ $description "Sets the contents of a file to the strings with the given encoding." }
+{ $errors "Throws an error if the file cannot be opened for writing." } ;
+
HELP: file-lines
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "seq" "an array of strings" } }
{ $description "Opens the file at the given path using the given encoding, and returns a list of the lines in that file." }
+{ $errors "Throws an error if the file cannot be opened for reading." } ;
+
+HELP: set-file-contents
+{ $values { "str" "a string" } { "path" "a pathname string" } { "encoding" "an encoding descriptor" } }
+{ $description "Sets the contents of a file to a string with the given encoding." }
{ $errors "Throws an error if the file cannot be opened for writing." } ;
HELP: file-contents
{ $values { "path" "a pathname string" } { "encoding" "an encoding descriptor" } { "str" "a string" } }
{ $description "Opens the file at the given path using the given encoding, and the contents of that file as a string." }
-{ $errors "Throws an error if the file cannot be opened for writing." } ;
+{ $errors "Throws an error if the file cannot be opened for reading." } ;
+
+{ set-file-lines file-lines set-file-contents file-contents } related-words
HELP: cwd
{ $values { "path" "a pathname string" } }
{ $description "Outputs the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
+{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
HELP: cd
{ $values { "path" "a pathname string" } }
{ $description "Changes the current working directory of the Factor process." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
+{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." }
+{ $notes "User code should use " { $link with-directory } " or " { $link set-current-directory } " instead." } ;
-{ cd cwd with-directory } related-words
+{ cd cwd current-directory set-current-directory with-directory } related-words
+
+HELP: current-directory
+{ $description "A variable holding the current directory as an absolute path. Words that use the filesystem do so in relation to this variable."
+$nl
+"This variable should never be set directly; instead, use " { $link set-current-directory } " or " { $link with-directory } ". This preserves the invariant that the value of this variable is an absolute path." } ;
+
+HELP: set-current-directory
+{ $values { "path" "a pathname string" } }
+{ $description "Changes the " { $link current-directory } " variable."
+$nl
+"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
HELP: with-directory
{ $values { "path" "a pathname string" } { "quot" quotation } }
-{ $description "Changes the current working directory for the duration of a quotation's execution." }
-{ $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ;
-
-HELP: stat ( path -- directory? permissions length modified )
-{ $values { "path" "a pathname string" } { "directory?" "boolean indicating if the file is a directory" } { "permissions" "a Unix permission bitmap (0 on Windows)" } { "length" "the length in bytes as an integer" } { "modified" "the last modification time, as milliseconds since midnight, January 1st 1970 GMT" } }
-{ $description
- "Queries the file system for file meta data. If the file does not exist, outputs " { $link f } " for all four values."
-} ;
+{ $description "Calls the quotation in a new dynamic scope with the " { $link current-directory } " variable rebound."
+$nl
+"If " { $snippet "path" } " is relative, it is first resolved relative to the current directory. If " { $snippet "path" } " is absolute, it becomes the new current directory." } ;
-{ stat exists? directory? } related-words
+HELP: append-path
+{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
+{ $description "Concatenates two pathnames." } ;
-HELP: path+
+HELP: prepend-path
{ $values { "str1" "a string" } { "str2" "a string" } { "str" "a string" } }
{ $description "Concatenates two pathnames." } ;
+{ append-path prepend-path } related-words
+
+HELP: absolute-path?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is absolute. Examples of absolute pathnames are " { $snippet "/foo/bar" } " on Unix and " { $snippet "c:\\foo\\bar" } " on Windows." } ;
+
+HELP: windows-absolute-path?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is absolute on Windows. Examples of absolute pathnames on Windows are " { $snippet "c:\\foo\\bar" } " and " { $snippet "\\\\?\\c:\\foo\\bar" } " for absolute Unicode pathnames." } ;
+
+HELP: root-directory?
+{ $values { "path" "a pathname string" } { "?" "a boolean" } }
+{ $description "Tests if a pathname is a root directory. Examples of root directory pathnames are " { $snippet "/" } " on Unix and " { $snippet "c:\\" } " on Windows." } ;
+
+{ absolute-path? windows-absolute-path? root-directory? } related-words
+
HELP: exists?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if the file named by " { $snippet "path" } " exists." } ;
HELP: resource-path
{ $values { "path" "a pathname string" } { "newpath" "a pathname string" } }
-{ $description "Resolve a path relative to the Factor source code location. This first checks if the " { $link resource-path } " variable is set to a path, and if not, uses the parent directory of the current image." } ;
-
-HELP: ?resource-path
-{ $values { "path" "a pathname string" } { "newpath" "a string" } }
-{ $description "If the path is prefixed with " { $snippet "\"resource:\"" } ", prepends the resource path." } ;
-
-{ resource-path ?resource-path } related-words
+{ $description "Resolve a path relative to the Factor source code location." } ;
HELP: pathname
{ $class-description "Class of pathname presentations. Path name presentations can be created by calling " { $link <pathname> } ". Instances can be passed to " { $link write-object } " to output a clickable pathname." } ;
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
{ $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
-HELP: normalize-pathname
+HELP: normalize-path
{ $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
-{ $description "Called by the " { $link stat } " word, and possibly " { $link <file-reader> } " and " { $link <file-writer> } ", to prepare a pathname before passing it to underlying code." } ;
+{ $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
HELP: <pathname> ( str -- pathname )
{ $values { "str" "a pathname string" } { "pathname" pathname } }
{ $description "Creates a new " { $link pathname } "." } ;
+HELP: make-link
+{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
+{ $description "Creates a symbolic link." } ;
+
+HELP: read-link
+{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
+{ $description "Reads the symbolic link and returns its target path." } ;
+
+HELP: copy-link
+{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } }
+{ $description "Copies a symbolic link without following the link." } ;
+
+{ make-link read-link copy-link } related-words
+
HELP: home
{ $values { "dir" string } }
{ $description "Outputs the user's home directory." } ;
IN: io.files.tests
-USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
+USING: tools.test io.files io.files.private io threads kernel
+continuations io.encodings.ascii io.files.unique sequences
+strings accessors io.encodings.utf8 ;
[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
[ ] [ "blahblah" temp-file make-directory ] unit-test
[ t ] [ "blahblah" temp-file directory? ] unit-test
+[ t ] [
+ [ temp-directory "loldir" append-path delete-directory ] ignore-errors
+ temp-directory [
+ "loldir" make-directory
+ ] with-directory
+ temp-directory "loldir" append-path exists?
+] unit-test
+
+[ ] [
+ [ temp-directory "loldir" append-path delete-directory ] ignore-errors
+ temp-directory [
+ "loldir" make-directory
+ "loldir" delete-directory
+ ] with-directory
+] unit-test
+
+[ "file1 contents" ] [
+ [ temp-directory "loldir" append-path delete-directory ] ignore-errors
+ temp-directory [
+ "file1 contents" "file1" utf8 set-file-contents
+ "file1" "file2" copy-file
+ "file2" utf8 file-contents
+ ] with-directory
+ "file1" temp-file delete-file
+ "file2" temp-file delete-file
+] unit-test
+
+[ "file3 contents" ] [
+ temp-directory [
+ "file3 contents" "file3" utf8 set-file-contents
+ "file3" "file4" move-file
+ "file4" utf8 file-contents
+ ] with-directory
+ "file4" temp-file delete-file
+] unit-test
+
+[ ] [
+ temp-directory [
+ "file5" touch-file
+ "file5" delete-file
+ ] with-directory
+] unit-test
+
+[ ] [
+ temp-directory [
+ "file6" touch-file
+ "file6" link-info drop
+ ] with-directory
+] unit-test
+
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
+[ "" ] [ "" file-name ] unit-test
[ ] [
{ "Hello world." }
[ ] [ "test-quux.txt" temp-file ascii [ [ yield "Hi" write ] "Test" spawn drop ] with-file-writer ] unit-test
-[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] 2apply move-file ] unit-test
+[ ] [ "test-quux.txt" "quux-test.txt" [ temp-file ] bi@ move-file ] unit-test
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
"delete-tree-test" temp-file delete-tree
] unit-test
+[ { { "kernel" t } } ] [
+ "core" resource-path [
+ "." directory [ first "kernel" = ] subset
+ ] with-directory
+] unit-test
+
+[ { { "kernel" t } } ] [
+ "resource:core" [
+ "." directory [ first "kernel" = ] subset
+ ] with-directory
+] unit-test
+
[ ] [
"copy-tree-test/a/b/c" temp-file make-directories
] unit-test
[ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
+[ t ] [
+ temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory
+ temp-directory "test41" append-path utf8 file-contents "hi41" =
+] unit-test
+
+[ t ] [
+ temp-directory [ "test41" file-info size>> ] with-directory 4 =
+] unit-test
+
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
-[ ] [ "append-test" ascii <file-appender> dispose ] unit-test
+[ ] [ "append-test" temp-file ascii <file-appender> dispose ] unit-test
+
+
+
+[ 123 ] [
+ "core" ".test" [
+ [
+ ascii [
+ 123 CHAR: a <repetition> >string write
+ ] with-file-writer
+ ] keep file-info size>>
+ ] with-unique-file
+] unit-test
+
+[ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
+[ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
+[ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
+[ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
+[ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
+[ "/lib/" ] [ "/usr" "../lib/" append-path ] unit-test
+
+[ "" ] [ "" "." append-path ] unit-test
+[ "" ".." append-path ] must-fail
+
+[ "/" ] [ "/" "./." append-path ] unit-test
+[ "/" ] [ "/" "././" append-path ] unit-test
+[ "/a/b/lib" ] [ "/a/b/c/d/e/f/" "../../../../lib" append-path ] unit-test
+[ "/a/b/lib/" ] [ "/a/b/c/d/e/f/" "../../../../lib/" append-path ] unit-test
+
+[ "" "../lib/" append-path ] must-fail
+[ "lib" ] [ "" "lib" append-path ] unit-test
+[ "lib" ] [ "" "./lib" append-path ] unit-test
+
+[ "foo/bar/." parent-directory ] must-fail
+[ "foo/bar/./" parent-directory ] must-fail
+[ "foo/bar/baz/.." parent-directory ] must-fail
+[ "foo/bar/baz/../" parent-directory ] must-fail
+
+[ "." parent-directory ] must-fail
+[ "./" parent-directory ] must-fail
+[ ".." parent-directory ] must-fail
+[ "../" parent-directory ] must-fail
+[ "../../" parent-directory ] must-fail
+[ "foo/.." parent-directory ] must-fail
+[ "foo/../" parent-directory ] must-fail
+[ "" parent-directory ] must-fail
+[ "." ] [ "boot.x86.64.image" parent-directory ] unit-test
+
+[ "bar/foo" ] [ "bar/baz" "..///foo" append-path ] unit-test
+[ "bar/baz/foo" ] [ "bar/baz" ".///foo" append-path ] unit-test
+[ "bar/foo" ] [ "bar/baz" "./..//foo" append-path ] unit-test
+[ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
+
+[ t ] [ "resource:core" absolute-path? ] unit-test
+[ f ] [ "" absolute-path? ] unit-test
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings assocs arrays definitions
system combinators splitting sbufs continuations io.encodings
-io.encodings.binary ;
+io.encodings.binary init accessors ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
HOOK: (file-appender) io-backend ( path -- stream )
: <file-reader> ( path encoding -- stream )
- swap (file-reader) swap <decoder> ;
+ swap normalize-path (file-reader) swap <decoder> ;
: <file-writer> ( path encoding -- stream )
- swap (file-writer) swap <encoder> ;
+ swap normalize-path (file-writer) swap <encoder> ;
: <file-appender> ( path encoding -- stream )
- swap (file-appender) swap <encoder> ;
+ swap normalize-path (file-appender) swap <encoder> ;
-HOOK: rename-file io-backend ( from to -- )
+: file-lines ( path encoding -- seq )
+ <file-reader> lines ;
+
+: with-file-reader ( path encoding quot -- )
+ >r <file-reader> r> with-stream ; inline
+
+: file-contents ( path encoding -- str )
+ <file-reader> contents ;
+
+: with-file-writer ( path encoding quot -- )
+ >r <file-writer> r> with-stream ; inline
+
+: set-file-lines ( seq path encoding -- )
+ [ [ print ] each ] with-file-writer ;
+
+: set-file-contents ( str path encoding -- )
+ [ write ] with-file-writer ;
+
+: with-file-appender ( path encoding quot -- )
+ >r <file-appender> r> with-stream ; inline
! Pathnames
-: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
+: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
+
+: path-separator ( -- string ) os windows? "\\" "/" ? ;
: right-trim-separators ( str -- newstr )
[ path-separator? ] right-trim ;
: left-trim-separators ( str -- newstr )
[ path-separator? ] left-trim ;
-: path+ ( str1 str2 -- str )
- >r right-trim-separators "/" r>
- left-trim-separators 3append ;
-
: last-path-separator ( path -- n ? )
[ length 1- ] keep [ path-separator? ] find-last* ;
HOOK: root-directory? io-backend ( path -- ? )
-M: object root-directory? ( path -- ? ) path-separator? ;
+M: object root-directory? ( path -- ? )
+ dup empty? [ drop f ] [ [ path-separator? ] all? ] if ;
+
+ERROR: no-parent-directory path ;
+
+: parent-directory ( path -- parent )
+ dup root-directory? [
+ right-trim-separators
+ dup last-path-separator [
+ 1+ cut
+ ] [
+ drop "." swap
+ ] if
+ { "" "." ".." } member? [
+ no-parent-directory
+ ] when
+ ] unless ;
+
+<PRIVATE
+
+: head-path-separator? ( path1 ? -- ?' )
+ [
+ dup empty? [ drop t ] [ first path-separator? ] if
+ ] [
+ drop f
+ ] if ;
+
+: head.? ( path -- ? ) "." ?head head-path-separator? ;
-: special-directory? ( name -- ? ) { "." ".." } member? ;
+: head..? ( path -- ? ) ".." ?head head-path-separator? ;
-TUPLE: no-parent-directory path ;
+: append-path-empty ( path1 path2 -- path' )
+ {
+ { [ dup head.? ] [
+ 1 tail left-trim-separators append-path-empty
+ ] }
+ { [ dup head..? ] [ drop no-parent-directory ] }
+ [ nip ]
+ } cond ;
-: no-parent-directory ( path -- * )
- \ no-parent-directory construct-boa throw ;
+PRIVATE>
-: parent-directory ( path -- parent )
- right-trim-separators {
- { [ dup empty? ] [ drop "/" ] }
- { [ dup root-directory? ] [ ] }
- { [ dup [ path-separator? ] contains? not ] [ drop "." ] }
- { [ t ] [
- dup last-path-separator drop 1+ cut
- special-directory? [ no-parent-directory ] when
+: windows-absolute-path? ( path -- path ? )
+ {
+ { [ dup "\\\\?\\" head? ] [ t ] }
+ { [ dup length 2 < ] [ f ] }
+ { [ dup second CHAR: : = ] [ t ] }
+ [ f ]
+ } cond ;
+
+: absolute-path? ( path -- ? )
+ {
+ { [ dup empty? ] [ f ] }
+ { [ dup "resource:" head? ] [ t ] }
+ { [ os windows? ] [ windows-absolute-path? ] }
+ { [ dup first path-separator? ] [ t ] }
+ [ f ]
+ } cond nip ;
+
+: append-path ( str1 str2 -- str )
+ {
+ { [ over empty? ] [ append-path-empty ] }
+ { [ dup empty? ] [ drop ] }
+ { [ dup absolute-path? ] [ nip ] }
+ { [ dup head.? ] [ 1 tail left-trim-separators append-path ] }
+ { [ dup head..? ] [
+ 2 tail left-trim-separators
+ >r parent-directory r> append-path
] }
+ { [ over absolute-path? over first path-separator? and ] [
+ >r 2 head r> append
+ ] }
+ [
+ >r right-trim-separators "/" r>
+ left-trim-separators 3append
+ ]
} cond ;
+: prepend-path ( str1 str2 -- str )
+ swap append-path ; inline
+
: file-name ( path -- string )
- right-trim-separators {
- { [ dup empty? ] [ drop "/" ] }
- { [ dup last-path-separator ] [ 1+ tail ] }
- { [ t ] [ drop ] }
- } cond ;
+ dup root-directory? [
+ right-trim-separators
+ dup last-path-separator [ 1+ tail ] [ drop ] if
+ ] unless ;
+! File info
TUPLE: file-info type size permissions modified ;
HOOK: file-info io-backend ( path -- info )
+
+! Symlinks
HOOK: link-info io-backend ( path -- info )
+HOOK: make-link io-backend ( target symlink -- )
+
+HOOK: read-link io-backend ( symlink -- path )
+
+: copy-link ( target symlink -- )
+ >r read-link r> make-link ;
+
SYMBOL: +regular-file+
SYMBOL: +directory+
+SYMBOL: +symbolic-link+
SYMBOL: +character-device+
SYMBOL: +block-device+
SYMBOL: +fifo+
-SYMBOL: +symbolic-link+
SYMBOL: +socket+
SYMBOL: +unknown+
! File metadata
-: stat ( path -- directory? permissions length modified )
- normalize-pathname (stat) ;
+: exists? ( path -- ? )
+ normalize-path (exists?) ;
-: file-modified ( path -- n ) stat >r 3drop r> ;
+: directory? ( path -- ? )
+ file-info file-info-type +directory+ = ;
-: exists? ( path -- ? ) file-modified >boolean ;
+<PRIVATE
-: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
-
-! Current working directory
HOOK: cd io-backend ( path -- )
HOOK: cwd io-backend ( -- path )
+M: object cwd ( -- path ) "." ;
+
+PRIVATE>
+
+SYMBOL: current-directory
+
+[ cwd current-directory set-global ] "io.files" add-init-hook
+
+: resource-path ( path -- newpath )
+ "resource-path" get [ image parent-directory ] unless*
+ prepend-path ;
+
+: (normalize-path) ( path -- path' )
+ "resource:" ?head [
+ left-trim-separators resource-path
+ (normalize-path)
+ ] [
+ current-directory get prepend-path
+ ] if ;
+
+M: object normalize-path ( path -- path' )
+ (normalize-path) ;
+
+: set-current-directory ( path -- )
+ (normalize-path) current-directory set ;
+
: with-directory ( path quot -- )
- cwd [ cd ] curry rot cd [ ] cleanup ; inline
+ >r (normalize-path) current-directory r> with-variable ; inline
! Creating directories
HOOK: make-directory io-backend ( path -- )
: make-directories ( path -- )
- normalize-pathname right-trim-separators {
+ normalize-path right-trim-separators {
{ [ dup "." = ] [ ] }
{ [ dup root-directory? ] [ ] }
{ [ dup empty? ] [ ] }
{ [ dup exists? ] [ ] }
- { [ t ] [
+ [
dup parent-directory make-directories
dup make-directory
- ] }
+ ]
} cond drop ;
! Directory listings
: fixup-directory ( path seq -- newseq )
[
dup string?
- [ tuck path+ directory? 2array ] [ nip ] if
+ [ tuck append-path directory? 2array ] [ nip ] if
] with map
- [ first special-directory? not ] subset ;
+ [ first { "." ".." } member? not ] subset ;
: directory ( path -- seq )
normalize-directory dup (directory) fixup-directory ;
: directory* ( path -- seq )
- dup directory [ first2 >r path+ r> 2array ] with map ;
+ dup directory [ first2 >r append-path r> 2array ] with map ;
! Touching files
HOOK: touch-file io-backend ( path -- )
HOOK: delete-directory io-backend ( path -- )
-: (delete-tree) ( path dir? -- )
- [
- dup directory* [ (delete-tree) ] assoc-each
- delete-directory
- ] [ delete-file ] if ;
-
: delete-tree ( path -- )
- dup directory? (delete-tree) ;
+ dup link-info type>> +directory+ = [
+ dup directory over [
+ [ first delete-tree ] each
+ ] with-directory delete-directory
+ ] [
+ delete-file
+ ] if ;
-: to-directory over file-name path+ ;
+: to-directory over file-name append-path ;
! Moving and renaming files
HOOK: move-file io-backend ( from to -- )
DEFER: copy-tree-into
: copy-tree ( from to -- )
- over directory? [
- >r dup directory swap r> [
- >r swap first path+ r> copy-tree-into
- ] 2curry each
- ] [
- copy-file
- ] if ;
+ normalize-path
+ over link-info type>>
+ {
+ { +symbolic-link+ [ copy-link ] }
+ { +directory+ [
+ >r dup directory r> rot [
+ [ >r first r> copy-tree-into ] curry each
+ ] with-directory
+ ] }
+ [ drop copy-file ]
+ } case ;
: copy-tree-into ( from to -- )
to-directory copy-tree ;
[ copy-tree-into ] curry each ;
! Special paths
-: resource-path ( path -- newpath )
- \ resource-path get [ image parent-directory ] unless*
- swap path+ ;
-: ?resource-path ( path -- newpath )
- "resource:" ?head [ resource-path ] when ;
+: temp-directory ( -- path )
+ "temp" resource-path dup make-directories ;
-: resource-exists? ( path -- ? )
- ?resource-path exists? ;
+: temp-file ( name -- path )
+ temp-directory prepend-path ;
! Pathname presentations
TUPLE: pathname string ;
M: pathname <=> [ pathname-string ] compare ;
-: file-lines ( path encoding -- seq )
- <file-reader> lines ;
-
-: with-file-reader ( path encoding quot -- )
- >r <file-reader> r> with-stream ; inline
-
-: file-contents ( path encoding -- str )
- <file-reader> contents ;
-
-: with-file-writer ( path encoding quot -- )
- >r <file-writer> r> with-stream ; inline
-
-: set-file-lines ( seq path encoding -- )
- [ [ print ] each ] with-file-writer ;
-
-: set-file-contents ( str path encoding -- )
- [ write ] with-file-writer ;
-
-: with-file-appender ( path encoding quot -- )
- >r <file-appender> r> with-stream ; inline
+! Home directory
+HOOK: home os ( -- dir )
-: temp-directory ( -- path )
- "temp" resource-path
- dup exists? not
- [ dup make-directory ]
- when ;
+M: winnt home "USERPROFILE" os-env ;
-: temp-file ( name -- path ) temp-directory swap path+ ;
+M: wince home "" resource-path ;
-! Home directory
-: home ( -- dir )
- {
- { [ winnt? ] [ "USERPROFILE" os-env ] }
- { [ wince? ] [ "" resource-path ] }
- { [ unix? ] [ "HOME" os-env ] }
- } cond ;
+M: unix home "HOME" os-env ;
USING: arrays io io.files kernel math parser strings system
-tools.test words namespaces io.encodings.latin1
+tools.test words namespaces io.encodings.8-bit
io.encodings.binary ;
IN: io.tests
[ f ] [
- "resource:/core/io/test/no-trailing-eol.factor" run-file
+ "resource:core/io/test/no-trailing-eol.factor" run-file
"foo" "io.tests" lookup
] unit-test
[
"This is a line.\rThis is another line.\r"
] [
- "/core/io/test/mac-os-eol.txt" <resource-reader>
+ "core/io/test/mac-os-eol.txt" <resource-reader>
[ 500 read ] with-stream
] unit-test
[
255
] [
- "/core/io/test/binary.txt" <resource-reader>
+ "core/io/test/binary.txt" <resource-reader>
[ read1 ] with-stream >fixnum
] unit-test
! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test
-[ "" ] [ 0 read ] unit-test
-
-! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
-
-[
- "/core/io/test/binary.txt" <resource-reader>
- [ 0.2 read ] with-stream
-] must-fail
-
[
{
{ "It seems " CHAR: J }
}
] [
[
- "/core/io/test/separator-test.txt" <resource-reader> [
+ "core/io/test/separator-test.txt" <resource-reader> [
"J" read-until 2array ,
"i" read-until 2array ,
"X" read-until 2array ,
10 [ 65536 read drop ] times
] with-file-reader
] unit-test
+
+! [ "" ] [ 0 read ] unit-test
+
+! [ ] [ "123" write 9000 CHAR: x <string> write flush ] unit-test
+
+! [
+! "/core/io/test/binary.txt" <resource-reader>
+! [ 0.2 read ] with-stream
+! ] must-fail
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
-sequences io namespaces ;
+sequences io namespaces io.encodings.private ;
IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream )
: with-byte-writer ( encoding quot -- byte-array )
>r <byte-writer> r> [ stdio get ] compose with-stream*
- >byte-array ; inline
+ dup encoder? [ encoder-stream ] when >byte-array ; inline
: <byte-reader> ( byte-array encoding -- stream )
>r >byte-vector dup reverse-here r> <decoder> ;
ARTICLE: "io.streams.duplex" "Duplex streams"
"Duplex streams combine an input stream and an output stream into a bidirectional stream."
{ $subsection duplex-stream }
-{ $subsection <duplex-stream> }
-{ $subsection check-closed } ;
+{ $subsection <duplex-stream> } ;
ABOUT: "io.streams.duplex"
HELP: duplex-stream
-{ $class-description "A bidirectional stream delegating to a pair of streams, sending input to one delegate and output to another." } ;
+{ $class-description "A bidirectional stream wrapping an input and output stream." } ;
HELP: <duplex-stream>
{ $values { "in" "an input stream" } { "out" "an output stream" } { "stream" " a duplex stream" } }
{ $description "Creates a duplex stream. Writing to a duplex stream will write to " { $snippet "out" } ", and reading from a duplex stream will read from " { $snippet "in" } ". Closing a duplex stream closes both the input and output streams." } ;
-HELP: check-closed
-{ $values { "stream" "a duplex stream" } }
-{ $description "Throws a " { $link check-closed } " error if the stream has already been closed." }
+HELP: stream-closed-twice
{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ;
! Test duplex stream close behavior
TUPLE: closing-stream closed? ;
-: <closing-stream> closing-stream construct-empty ;
+: <closing-stream> closing-stream new ;
M: closing-stream dispose
dup closing-stream-closed? [
TUPLE: unclosable-stream ;
-: <unclosable-stream> unclosable-stream construct-empty ;
+: <unclosable-stream> unclosable-stream new ;
M: unclosable-stream dispose
"Can't close me!" throw ;
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel continuations io accessors ;
IN: io.streams.duplex
-USING: kernel continuations io ;
! We ensure that the stream can only be closed once, to preserve
! integrity of duplex I/O ports.
-TUPLE: duplex-stream in out closed? ;
+TUPLE: duplex-stream in out closed ;
: <duplex-stream> ( in out -- stream )
- f duplex-stream construct-boa ;
+ f duplex-stream boa ;
-TUPLE: check-closed ;
+ERROR: stream-closed-twice ;
-: check-closed ( stream -- )
- duplex-stream-closed?
- [ \ check-closed construct-boa throw ] when ;
+<PRIVATE
-: duplex-stream-in+ ( duplex -- stream )
- dup check-closed duplex-stream-in ;
+: check-closed ( stream -- stream )
+ dup closed>> [ stream-closed-twice ] when ; inline
-: duplex-stream-out+ ( duplex -- stream )
- dup check-closed duplex-stream-out ;
+: in ( duplex -- stream ) check-closed in>> ;
+
+: out ( duplex -- stream ) check-closed out>> ;
+
+PRIVATE>
M: duplex-stream stream-flush
- duplex-stream-out+ stream-flush ;
+ out stream-flush ;
M: duplex-stream stream-readln
- duplex-stream-in+ stream-readln ;
+ in stream-readln ;
M: duplex-stream stream-read1
- duplex-stream-in+ stream-read1 ;
+ in stream-read1 ;
M: duplex-stream stream-read-until
- duplex-stream-in+ stream-read-until ;
+ in stream-read-until ;
M: duplex-stream stream-read-partial
- duplex-stream-in+ stream-read-partial ;
+ in stream-read-partial ;
M: duplex-stream stream-read
- duplex-stream-in+ stream-read ;
+ in stream-read ;
M: duplex-stream stream-write1
- duplex-stream-out+ stream-write1 ;
+ out stream-write1 ;
M: duplex-stream stream-write
- duplex-stream-out+ stream-write ;
+ out stream-write ;
M: duplex-stream stream-nl
- duplex-stream-out+ stream-nl ;
+ out stream-nl ;
M: duplex-stream stream-format
- duplex-stream-out+ stream-format ;
+ out stream-format ;
M: duplex-stream make-span-stream
- duplex-stream-out+ make-span-stream ;
+ out make-span-stream ;
M: duplex-stream make-block-stream
- duplex-stream-out+ make-block-stream ;
+ out make-block-stream ;
M: duplex-stream make-cell-stream
- duplex-stream-out+ make-cell-stream ;
+ out make-cell-stream ;
M: duplex-stream stream-write-table
- duplex-stream-out+ stream-write-table ;
+ out stream-write-table ;
M: duplex-stream dispose
#! The output stream is closed first, in case both streams
#! are attached to the same file descriptor, the output
#! buffer needs to be flushed before we close the fd.
- dup duplex-stream-closed? [
- t over set-duplex-stream-closed?
- [ dup duplex-stream-out dispose ]
- [ dup duplex-stream-in dispose ] [ ] cleanup
+ dup closed>> [
+ t >>closed
+ [ dup out>> dispose ]
+ [ dup in>> dispose ] [ ] cleanup
] unless drop ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors alien.accessors math io ;
+IN: io.streams.memory
+
+TUPLE: memory-stream alien index ;
+
+: <memory-stream> ( alien -- stream )
+ 0 memory-stream boa ;
+
+M: memory-stream stream-read1
+ [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
+ [ [ 1+ ] change-index drop ] bi ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.streams.nested
USING: arrays generic assocs kernel namespaces strings
-quotations io continuations ;
+quotations io continuations accessors sequences ;
+IN: io.streams.nested
+
+TUPLE: filter-writer stream ;
+
+M: filter-writer stream-format
+ stream>> stream-format ;
+
+M: filter-writer stream-write
+ stream>> stream-write ;
+
+M: filter-writer stream-write1
+ stream>> stream-write1 ;
+
+M: filter-writer make-span-stream
+ stream>> make-span-stream ;
+
+M: filter-writer make-block-stream
+ stream>> make-block-stream ;
-TUPLE: ignore-close-stream ;
+M: filter-writer make-cell-stream
+ stream>> make-cell-stream ;
-: <ignore-close-stream> ignore-close-stream construct-delegate ;
+M: filter-writer stream-flush
+ stream>> stream-flush ;
+
+M: filter-writer stream-nl
+ stream>> stream-nl ;
+
+M: filter-writer stream-write-table
+ stream>> stream-write-table ;
+
+M: filter-writer dispose
+ stream>> dispose ;
+
+TUPLE: ignore-close-stream < filter-writer ;
M: ignore-close-stream dispose drop ;
-TUPLE: style-stream style ;
+C: <ignore-close-stream> ignore-close-stream
-: do-nested-style ( style stream -- style delegate )
- [ style-stream-style swap union ] keep
- delegate ; inline
+TUPLE: style-stream < filter-writer style ;
-: <style-stream> ( style delegate -- stream )
- { set-style-stream-style set-delegate }
- style-stream construct ;
+: do-nested-style ( style style-stream -- style stream )
+ [ style>> swap assoc-union ] [ stream>> ] bi ; inline
+
+C: <style-stream> style-stream
M: style-stream stream-format
do-nested-style stream-format ;
M: style-stream stream-write
- dup style-stream-style swap delegate stream-format ;
+ [ style>> ] [ stream>> ] bi stream-format ;
M: style-stream stream-write1
>r 1string r> stream-write ;
do-nested-style make-span-stream ;
M: style-stream make-block-stream
- [ do-nested-style make-block-stream ] keep
- style-stream-style swap <style-stream> ;
+ [ do-nested-style make-block-stream ] [ style>> ] bi
+ <style-stream> ;
M: style-stream make-cell-stream
- [ do-nested-style make-cell-stream ] keep
- style-stream-style swap <style-stream> ;
-
-TUPLE: block-stream ;
-
-: <block-stream> block-stream construct-delegate ;
+ [ do-nested-style make-cell-stream ] [ style>> ] bi
+ <style-stream> ;
-M: block-stream dispose drop ;
+M: style-stream stream-write-table
+ [ [ [ stream>> ] map ] map ] [ ] [ stream>> ] tri*
+ stream-write-table ;
nip stream-write ;
M: plain-writer make-span-stream
- <style-stream> <ignore-close-stream> ;
+ swap <style-stream> <ignore-close-stream> ;
M: plain-writer make-block-stream
nip <ignore-close-stream> ;
HELP: <string-writer>
{ $values { "stream" "an output stream" } }
-{ $description "Creates an output stream that collects text into a delegate string buffer. The contents of the buffer can be recovered by executing " { $link >string } ", and indeed all other sequence operations are permitted by virtue of the delegation." } ;
+{ $description "Creates an output stream that collects text into a string buffer. The contents of the buffer can be obtained by executing " { $link >string } "." } ;
HELP: with-string-writer
{ $values { "quot" quotation } { "str" string } }
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: io.streams.string
USING: io kernel math namespaces sequences sbufs strings
generic splitting growable continuations io.streams.plain
-io.encodings ;
+io.encodings io.encodings.private ;
+IN: io.streams.string
M: growable dispose drop ;
M: growable stream-read-partial
stream-read ;
+TUPLE: null ;
+M: null decode-char drop stream-read1 ;
+
: <string-reader> ( str -- stream )
- >sbuf dup reverse-here f <decoder> ;
+ >sbuf dup reverse-here null <decoder> ;
: with-string-reader ( str quot -- )
>r <string-reader> r> with-stream ; inline
ARTICLE: "shuffle-words" "Shuffle words"
"Shuffle words rearrange items at the top of the data stack. They control the flow of data between words that perform actions."
$nl
+"The " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " are closely related to shuffle words and should be used instead where possible because they can result in clearer code; also, see the advice in " { $link "cookbook-philosophy" } "."
+$nl
"Removing stack elements:"
{ $subsection drop }
{ $subsection 2drop }
{ $code
": foo ( m ? n -- m+n/n )"
" >r [ r> + ] [ drop r> ] if ; ! This is OK"
+} ;
+
+ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
+"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
+$nl
+"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
+{ $code
+ ": keep [ ] bi ;"
+ ": 2keep [ ] 2bi ;"
+ ": 3keep [ ] 3bi ;"
+ ""
+ ": dup [ ] [ ] bi ;"
+ ": 2dup [ ] [ ] 2bi ;"
+ ": 3dup [ ] [ ] 3bi ;"
+ ""
+ ": tuck [ nip ] [ ] 2bi ;"
+ ": swap [ nip ] [ drop ] 2bi ;"
+ ""
+ ": over [ ] [ drop ] 2bi ;"
+ ": pick [ ] [ 2drop ] 3bi ;"
+ ": 2over [ ] [ drop ] 3bi ;"
+} ;
+
+ARTICLE: "cleave-combinators" "Cleave combinators"
+"The cleave combinators apply multiple quotations to a single value."
+$nl
+"Two quotations:"
+{ $subsection bi }
+{ $subsection 2bi }
+{ $subsection 3bi }
+"Three quotations:"
+{ $subsection tri }
+{ $subsection 2tri }
+{ $subsection 3tri }
+"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
+{ $code
+ "! First alternative; uses keep"
+ "[ 1 + ] keep"
+ "[ 1 - ] keep"
+ "2 *"
+ "! Second alternative: uses tri"
+ "[ 1 + ]"
+ "[ 1 - ]"
+ "[ 2 * ] tri"
}
-"An alternative to using " { $link >r } " and " { $link r> } " is the following:"
-{ $subsection dip } ;
+"The latter is more aesthetically pleasing than the former."
+$nl
+"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+{ $subsection "cleave-shuffle-equivalence" } ;
-ARTICLE: "basic-combinators" "Basic combinators"
-"The following pair of words invoke words and quotations reflectively:"
-{ $subsection call }
-{ $subsection execute }
-"These words are used to implement " { $emphasis "combinators" } ", which are words that take code from the stack. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
+ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
+"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", and " { $link tri* } "."
+$nl
+"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
{ $code
- ": keep ( x quot -- x )"
- " over >r call r> ; inline"
+ ": dip [ ] bi* ;"
+ ""
+ ": slip [ call ] [ ] bi* ;"
+ ": 2slip [ call ] [ ] [ ] tri* ;"
+ ""
+ ": nip [ drop ] [ ] bi* ;"
+ ": 2nip [ drop ] [ drop ] [ ] tri* ;"
+ ""
+ ": rot"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " 3tri ;"
+ ""
+ ": -rot"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " 3tri ;"
+ ""
+ ": spin"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " 3tri ;"
+} ;
+
+ARTICLE: "spread-combinators" "Spread combinators"
+"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
+$nl
+"Two quotations:"
+{ $subsection bi* }
+{ $subsection 2bi* }
+"Three quotations:"
+{ $subsection tri* }
+"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
+{ $code
+ "! First alternative; uses retain stack explicitly"
+ ">r >r 1 +"
+ "r> 1 -"
+ "r> 2 *"
+ "! Second alternative: uses tri*"
+ "[ 1 + ]"
+ "[ 1 - ]"
+ "[ 2 * ] tri*"
}
-"Word inlining is documented in " { $link "declarations" } "."
+
$nl
-"There are some words that combine shuffle words with " { $link call } ". They are useful for implementing higher-level combinators."
+"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+{ $subsection "spread-shuffle-equivalence" } ;
+
+ARTICLE: "apply-combinators" "Apply combinators"
+"The apply combinators apply multiple quotations to multiple values. The " { $snippet "@" } " suffix signifies application."
+$nl
+"Two quotations:"
+{ $subsection bi@ }
+{ $subsection 2bi@ }
+"Three quotations:"
+{ $subsection tri@ }
+"A pair of utility words built from " { $link bi@ } ":"
+{ $subsection both? }
+{ $subsection either? } ;
+
+ARTICLE: "slip-keep-combinators" "The slip and keep combinators"
+"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
{ $subsection slip }
{ $subsection 2slip }
+{ $subsection 3slip }
+"The dip combinator invokes the quotation at the top of the stack, hiding the value underneath:"
+{ $subsection dip }
+"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
{ $subsection keep }
{ $subsection 2keep }
-{ $subsection 3keep }
-{ $subsection 2apply }
-"A pair of utility words built from " { $link 2apply } ":"
-{ $subsection both? }
-{ $subsection either? }
-"A looping combinator:"
-{ $subsection while }
+{ $subsection 3keep } ;
+
+ARTICLE: "compositional-combinators" "Compositional combinators"
"Quotations can be composed using efficient quotation-specific operations:"
{ $subsection curry }
{ $subsection 2curry }
{ $subsection with }
{ $subsection compose }
{ $subsection 3compose }
-"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "."
-{ $see-also "combinators" } ;
+"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } "." ;
+
+ARTICLE: "implementing-combinators" "Implementing combinators"
+"The following pair of words invoke words and quotations reflectively:"
+{ $subsection call }
+{ $subsection execute }
+"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
+{ $code
+ ": keep ( x quot -- x )"
+ " over >r call r> ; inline"
+}
+"Word inlining is documented in " { $link "declarations" } "."
+$nl
+"A looping combinator:"
+{ $subsection while } ;
ARTICLE: "booleans" "Booleans"
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
{ $example "\\ f class ." "word" }
"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
{ $example "t \\ t eq? ." "t" }
-"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "."
-$nl
-"A tuple cannot delegate to " { $link f } " at all, since a delegate of " { $link f } " actually denotes that no delegate is set. See " { $link set-delegate } "." ;
+"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
ARTICLE: "conditionals" "Conditionals and logic"
"The basic conditionals:"
{ $subsection ?if }
"Sometimes instead of branching, you just need to pick one of two values:"
{ $subsection ? }
-"Forms which abstract away common patterns involving multiple nested branches:"
-{ $subsection cond }
-{ $subsection case }
"There are some logical operations on booleans:"
{ $subsection >boolean }
{ $subsection not }
{ $subsection and }
{ $subsection or }
{ $subsection xor }
+"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
ARTICLE: "equality" "Equality and comparison testing"
{ $subsection eq? }
"Value comparison:"
{ $subsection = }
-"Generic words for custom value comparison methods:"
+"Custom value comparison methods:"
{ $subsection equal? }
+{ $subsection identity-tuple }
"Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":"
{ $subsection <=> }
{ $subsection compare }
"An object can be cloned; the clone has distinct identity but equal value:"
{ $subsection clone } ;
-! Defined in handbook.factor
+ARTICLE: "dataflow" "Data and control flow"
+{ $subsection "evaluator" }
+{ $subsection "words" }
+{ $subsection "effects" }
+{ $subsection "booleans" }
+{ $subsection "shuffle-words" }
+"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
+{ $subsection "cleave-combinators" }
+{ $subsection "spread-combinators" }
+{ $subsection "apply-combinators" }
+{ $subsection "slip-keep-combinators" }
+{ $subsection "conditionals" }
+{ $subsection "compositional-combinators" }
+{ $subsection "combinators" }
+"Advanced topics:"
+{ $subsection "implementing-combinators" }
+{ $subsection "errors" }
+{ $subsection "continuations" } ;
+
ABOUT: "dataflow"
HELP: eq? ( obj1 obj2 -- ? )
HELP: clear
{ $description "Clears the data stack." } ;
+HELP: build
+{ $description "The current build number. Factor increments this number whenever a new boot image is created." } ;
+
HELP: hashcode*
{ $values { "depth" integer } { "obj" object } { "code" fixnum } }
{ $contract "Outputs the hashcode of an object. The hashcode operation must satisfy the following properties:"
{ $list
- { "if two objects are equal under " { $link = } ", they must have equal hashcodes" }
- { "if the hashcode of an object depends on the values of its slots, the hashcode of the slots must be computed recursively by calling " { $link hashcode* } " with a " { $snippet "level" } " parameter decremented by one. This avoids excessive work while still computing well-distributed hashcodes. The " { $link recursive-hashcode } " combinator can help with implementing this logic" }
- { "the hashcode should be a " { $link fixnum } ", however returning a " { $link bignum } " will not cause any problems other than potential performance degradation."
- "the hashcode is only permitted to change between two invocations if the object was mutated in some way" }
+ { "If two objects are equal under " { $link = } ", they must have equal hashcodes." }
+ { "If the hashcode of an object depends on the values of its slots, the hashcode of the slots must be computed recursively by calling " { $link hashcode* } " with a " { $snippet "level" } " parameter decremented by one. This avoids excessive work while still computing well-distributed hashcodes. The " { $link recursive-hashcode } " combinator can help with implementing this logic," }
+ { "The hashcode should be a " { $link fixnum } ", however returning a " { $link bignum } " will not cause any problems other than potential performance degradation." }
+ { "The hashcode is only permitted to change between two invocations if the object or one of its slot values was mutated." }
}
-"If mutable objects are used as hashtable keys, they must not be mutated in such a way that their hashcode changes. Doing so will violate bucket sorting invariants and result in undefined behavior." } ;
+"If mutable objects are used as hashtable keys, they must not be mutated in such a way that their hashcode changes. Doing so will violate bucket sorting invariants and result in undefined behavior. See " { $link "hashtables.keys" } " for details." } ;
HELP: hashcode
{ $values { "obj" object } { "code" fixnum } }
{ { $snippet "a = b" } " implies " { $snippet "b = a" } }
{ { $snippet "a = b" } " and " { $snippet "b = c" } " implies " { $snippet "a = c" } }
}
-}
+ $nl
+ "If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word."
+} ;
+
+HELP: identity-tuple
+{ $class-description "A class defining an " { $link equal? } " method which always returns f." }
{ $examples
- "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
- { $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" }
+ "To define a tuple class such that two instances are only equal if they are both the same instance, inherit from the " { $link identity-tuple } " class. This class defines a method on " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:"
+ { $code "TUPLE: foo < identity-tuple ;" }
"By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:"
{ $unchecked-example "T{ foo } dup = ." "t" }
{ $unchecked-example "T{ foo } dup clone = ." "f" }
HELP: <=>
{ $values { "obj1" object } { "obj2" object } { "n" real } }
{ $contract
- "Compares two objects using an intrinsic partial order, for example, the natural order for real numbers and lexicographic order for strings."
+ "Compares two objects using an intrinsic total order, for example, the natural order for real numbers and lexicographic order for strings."
$nl
"The output value is one of the following:"
{ $list
{ $values { "obj" object } { "cloned" "a new object" } }
{ $contract "Outputs a new object equal to the given object. This is not guaranteed to actually copy the object; it does nothing with immutable objects, and does not copy words either. However, sequences and tuples can be cloned to obtain a shallow copy of the original." } ;
-HELP: type ( object -- n )
-{ $values { "object" object } { "n" "a type number" } }
-{ $description "Outputs an object's type number, between zero and one less than " { $link num-types } ". This is implementation detail and user code should call " { $link class } " instead." } ;
-
-{ type tag type>class } related-words
-
HELP: ? ( ? true false -- true/false )
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
{ $values { "quot" "a quotation with stack effect " { $snippet "( x y z -- )" } } { "x" object } { "y" object } { "z" object } }
{ $description "Call a quotation with three values on the stack, restoring the values when the quotation returns." } ;
-HELP: 2apply
-{ $values { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } { "x" object } { "y" object } }
-{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." } ;
+HELP: bi
+{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } "." }
+{ $examples
+ "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] bi"
+ "dup p q"
+ }
+ "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x -- y )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] bi"
+ "dup p swap q"
+ }
+ "In general, the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] bi"
+ "[ p ] keep q"
+ }
+
+} ;
+
+HELP: 2bi
+{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." }
+{ $examples
+ "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] 2bi"
+ "2dup p q"
+ }
+ "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y -- z )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] 2bi"
+ "2dup p -rot q"
+ }
+ "In general, the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] 2bi"
+ "[ p ] 2keep q"
+ }
+} ;
+
+HELP: 3bi
+{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values." }
+{ $examples
+ "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] 3bi"
+ "3dup p q"
+ }
+ "If " { $snippet "[ p ]" } " and " { $snippet "[ q ]" } " have stack effect " { $snippet "( x y z -- w )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] 3bi"
+ "3dup p -roll q"
+ }
+ "In general, the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] 3bi"
+ "[ p ] 3keep q"
+ }
+} ;
+
+HELP: tri
+{ $values { "x" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "x" } ", and finally applies " { $snippet "r" } " to " { $snippet "x" } "." }
+{ $examples
+ "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x -- )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] tri"
+ "dup p dup q r"
+ }
+ "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x -- y )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] tri"
+ "dup p over q rot r"
+ }
+ "In general, the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] tri"
+ "[ p ] keep [ q ] keep r"
+ }
+} ;
+
+HELP: 2tri
+{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to the two input values, then applies " { $snippet "q" } " to the two input values, and finally applies " { $snippet "r" } " to the two input values." }
+{ $examples
+ "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y -- )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] 2tri"
+ "2dup p 2dup q r"
+ }
+ "In general, the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] 2tri"
+ "[ p ] 2keep [ q ] 2keep r"
+ }
+} ;
+
+HELP: 3tri
+{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( x y z -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to the three input values, then applies " { $snippet "q" } " to the three input values, and finally applies " { $snippet "r" } " to the three input values." }
+{ $examples
+ "If " { $snippet "[ p ]" } ", " { $snippet "[ q ]" } " and " { $snippet "[ r ]" } " have stack effect " { $snippet "( x y z -- )" } ", then the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] 3tri"
+ "3dup p 3dup q r"
+ }
+ "In general, the following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] 3tri"
+ "[ p ] 3keep [ q ] 3keep r"
+ }
+} ;
+
+
+HELP: bi*
+{ $values { "x" object } { "y" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } "." }
+{ $examples
+ "The following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] bi*"
+ ">r p r> q"
+ }
+} ;
+
+HELP: 2bi*
+{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( w x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y z -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to " { $snippet "w" } " and " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } " and " { $snippet "z" } "." }
+{ $examples
+ "The following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] 2bi*"
+ ">r >r q r> r> q"
+ }
+} ;
+
+HELP: tri*
+{ $values { "x" object } { "y" object } { "z" object } { "p" "a quotation with stack effect " { $snippet "( x -- ... )" } } { "q" "a quotation with stack effect " { $snippet "( y -- ... )" } } { "r" "a quotation with stack effect " { $snippet "( z -- ... )" } } }
+{ $description "Applies " { $snippet "p" } " to " { $snippet "x" } ", then applies " { $snippet "q" } " to " { $snippet "y" } ", and finally applies " { $snippet "r" } " to " { $snippet "z" } "." }
+{ $examples
+ "The following two lines are equivalent:"
+ { $code
+ "[ p ] [ q ] [ r ] tri*"
+ ">r >r q r> q r> r"
+ }
+} ;
+
+HELP: bi@
+{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } "." }
+{ $examples
+ "The following two lines are equivalent:"
+ { $code
+ "[ p ] bi@"
+ ">r p r> p"
+ }
+ "The following two lines are also equivalent:"
+ { $code
+ "[ p ] bi@"
+ "[ p ] [ p ] bi*"
+ }
+} ;
+
+HELP: 2bi@
+{ $values { "w" object } { "x" object } { "y" object } { "z" object } { "quot" "a quotation with stack effect " { $snippet "( obj1 obj2 -- )" } } }
+{ $description "Applies the quotation to " { $snippet "w" } " and " { $snippet "x" } ", then to " { $snippet "y" } " and " { $snippet "z" } "." }
+{ $examples
+ "The following two lines are equivalent:"
+ { $code
+ "[ p ] 2bi@"
+ ">r >r p r> r> p"
+ }
+ "The following two lines are also equivalent:"
+ { $code
+ "[ p ] 2bi@"
+ "[ p ] [ p ] 2bi*"
+ }
+} ;
+
+HELP: tri@
+{ $values { "x" object } { "y" object } { "z" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } }
+{ $description "Applies the quotation to " { $snippet "x" } ", then to " { $snippet "y" } ", and finally to " { $snippet "z" } "." }
+{ $examples
+ "The following two lines are equivalent:"
+ { $code
+ "[ p ] tri@"
+ ">r >r p r> p r> p"
+ }
+ "The following two lines are also equivalent:"
+ { $code
+ "[ p ] tri@"
+ "[ p ] [ p ] [ p ] tri*"
+ }
+} ;
HELP: if ( cond true false -- )
{ $values { "cond" "a generalized boolean" } { "true" quotation } { "false" quotation } }
"The canonical empty class with no instances."
} ;
-HELP: general-t
-{ $class-description
- "The class of all objects not equal to " { $link f } "."
-}
-{ $examples
- "Here is an implementation of " { $link if } " using generic words:"
- { $code
- "GENERIC# my-if 2 ( ? true false -- )"
- "M: f my-if 2nip call ;"
- "M: general-t my-if drop nip call ;"
- }
-} ;
-
HELP: most
{ $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } }
{ $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ;
{ $example "USING: kernel math prettyprint sequences ;" "2 { 1 2 3 } [ - ] with map ." "{ 1 0 -1 }" }
} ;
-HELP: compose
-{ $values { "quot1" callable } { "quot2" callable } { "curry" curry } }
+HELP: compose ( quot1 quot2 -- compose )
+{ $values { "quot1" callable } { "quot2" callable } { "compose" compose } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } " followed by " { $snippet "quot2" } "." }
{ $notes
- "The following two lines are equivalent:"
+ "The two quotations must leave the retain stack in the same state on exit as it was on entry, so the following code is not allowed:"
+ { $code
+ "[ 3 >r ] [ r> . ] compose"
+ }
+ "Except for this restriction, the following two lines are equivalent:"
{ $code
"compose call"
"append call"
{ $values { "quot1" callable } { "quot2" callable } { "quot3" callable } { "curry" curry } }
{ $description "Quotation composition. Outputs a " { $link callable } " which calls " { $snippet "quot1" } ", " { $snippet "quot2" } " and then " { $snippet "quot3" } "." }
{ $notes
- "The following two lines are equivalent:"
+ "The three quotations must leave the retain stack in the same state on exit as it was on entry, so for example, the following code is not allowed:"
+ { $code
+ "[ >r ] swap [ r> ] 3compose"
+ }
+ "The correct way to achieve the effect of the above is the following:"
+ { $code
+ "[ dip ] curry"
+ }
+ "Excepting the retain stack restriction, the following two lines are equivalent:"
{ $code
"3compose call"
"3append call"
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
[ loop ] must-fail
+
+! Discovered on Windows
+: total-failure-1 "" [ ] map unimplemented ;
+
+[ total-failure-1 ] must-fail
+
+: total-failure-2 [ ] (call) unimplemented ;
+
+[ total-failure-2 ] must-fail
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel.private ;
+USING: kernel.private slots.private classes.tuple.private ;
IN: kernel
! Stack stuff
: if ( ? true false -- ) ? call ;
-: if* ( cond true false -- )
- pick [ drop call ] [ 2nip call ] if ; inline
-
-: ?if ( default cond true false -- )
- pick [ roll 2drop call ] [ 2nip call ] if ; inline
-
+! Single branch
: unless ( cond false -- )
swap [ drop ] [ call ] if ; inline
-: unless* ( cond false -- )
- over [ drop ] [ nip call ] if ; inline
-
: when ( cond true -- )
swap [ call ] [ drop ] if ; inline
+! Anaphoric
+: if* ( cond true false -- )
+ pick [ drop call ] [ 2nip call ] if ; inline
+
: when* ( cond true -- )
over [ call ] [ 2drop ] if ; inline
+: unless* ( cond false -- )
+ over [ drop ] [ nip call ] if ; inline
+
+! Default
+: ?if ( default cond true false -- )
+ pick [ roll 2drop call ] [ 2nip call ] if ; inline
+
+! Slippers
: slip ( quot x -- x ) >r call r> ; inline
: 2slip ( quot x y -- x y ) >r >r call r> r> ; inline
: dip ( obj quot -- obj ) swap slip ; inline
+! Keepers
: keep ( x quot -- x ) over slip ; inline
: 2keep ( x y quot -- x y ) 2over 2slip ; inline
: 3keep ( x y z quot -- x y z )
>r 3dup r> -roll 3slip ; inline
-: 2apply ( x y quot -- ) tuck 2slip call ; inline
+! Cleavers
+: bi ( x p q -- )
+ >r keep r> call ; inline
-: while ( pred body tail -- )
- >r >r dup slip r> r> roll
- [ >r tuck 2slip r> while ]
- [ 2nip call ] if ; inline
+: tri ( x p q r -- )
+ >r pick >r bi r> r> call ; inline
-! Quotation building
-USE: tuples.private
+! Double cleavers
+: 2bi ( x y p q -- )
+ >r 2keep r> call ; inline
-: curry ( obj quot -- curry )
- \ curry 4 <tuple-boa> ;
+: 2tri ( x y p q r -- )
+ >r >r 2keep r> 2keep r> call ; inline
-: 2curry ( obj1 obj2 quot -- curry )
- curry curry ; inline
+! Triple cleavers
+: 3bi ( x y z p q -- )
+ >r 3keep r> call ; inline
-: 3curry ( obj1 obj2 obj3 quot -- curry )
- curry curry curry ; inline
+: 3tri ( x y z p q r -- )
+ >r >r 3keep r> 3keep r> call ; inline
-: with ( param obj quot -- obj curry )
- swapd [ swapd call ] 2curry ; inline
+! Spreaders
+: bi* ( x y p q -- )
+ >r swap slip r> call ; inline
-: compose ( quot1 quot2 -- curry )
- \ compose 4 <tuple-boa> ;
+: tri* ( x y z p q r -- )
+ >r rot >r bi* r> r> call ; inline
-: 3compose ( quot1 quot2 quot3 -- curry )
- compose compose ; inline
+! Double spreaders
+: 2bi* ( w x y z p q -- )
+ >r -rot 2slip r> call ; inline
-! Object protocol
+! Appliers
+: bi@ ( x y quot -- )
+ dup bi* ; inline
-GENERIC: delegate ( obj -- delegate )
+: tri@ ( x y z quot -- )
+ dup dup tri* ; inline
-M: object delegate drop f ;
+! Double appliers
+: 2bi@ ( w x y z quot -- )
+ dup 2bi* ; inline
-GENERIC: set-delegate ( delegate tuple -- )
+: while ( pred body tail -- )
+ >r >r dup slip r> r> roll
+ [ >r tuck 2slip r> while ]
+ [ 2nip call ] if ; inline
+! Object protocol
GENERIC: hashcode* ( depth obj -- code )
M: object hashcode* 2drop 0 ;
+M: f hashcode* 2drop 31337 ;
+
: hashcode ( obj -- code ) 3 swap hashcode* ; inline
GENERIC: equal? ( obj1 obj2 -- ? )
M: object equal? 2drop f ;
+TUPLE: identity-tuple ;
+
+M: identity-tuple equal? 2drop f ;
+
: = ( obj1 obj2 -- ? )
2dup eq? [ 2drop t ] [ equal? ] if ; inline
M: callstack clone (clone) ;
! Tuple construction
+: new ( class -- tuple )
+ tuple-layout <tuple> ;
-GENERIC# get-slots 1 ( tuple slots -- ... )
+: boa ( ... class -- tuple )
+ tuple-layout <tuple-boa> ;
-GENERIC# set-slots 1 ( ... tuple slots -- )
-
-GENERIC: construct-empty ( class -- tuple )
+! Quotation building
+: 2curry ( obj1 obj2 quot -- curry )
+ curry curry ; inline
-GENERIC: construct ( ... slots class -- tuple ) inline
+: 3curry ( obj1 obj2 obj3 quot -- curry )
+ curry curry curry ; inline
-GENERIC: construct-boa ( ... class -- tuple )
+: with ( param obj quot -- obj curry )
+ swapd [ swapd call ] 2curry ; inline
-: construct-delegate ( delegate class -- tuple )
- >r { set-delegate } r> construct ; inline
+: 3compose ( quot1 quot2 quot3 -- curry )
+ compose compose ; inline
! Booleans
-
: not ( obj -- ? ) f eq? ; inline
: >boolean ( obj -- ? ) t f ? ; inline
: xor ( obj1 obj2 -- ? ) dup not swap ? ; inline
-: both? ( x y quot -- ? ) 2apply and ; inline
+: both? ( x y quot -- ? ) bi@ and ; inline
-: either? ( x y quot -- ? ) 2apply or ; inline
+: either? ( x y quot -- ? ) bi@ or ; inline
-: compare ( obj1 obj2 quot -- n ) 2apply <=> ; inline
+: compare ( obj1 obj2 quot -- n ) bi@ <=> ; inline
: most ( x y quot -- z )
>r 2dup r> call [ drop ] [ nip ] if ; inline
<PRIVATE
+: hi-tag ( obj -- n ) 0 slot ; inline
+
: declare ( spec -- ) drop ;
: do-primitive ( number -- ) "Improper primitive call" throw ;
PRIVATE>
+
+! Deprecated
+M: object delegate drop f ;
+
+GENERIC# get-slots 1 ( tuple slots -- ... )
+
+GENERIC# set-slots 1 ( ... tuple slots -- )
+
+: construct ( ... slots class -- tuple )
+ new [ swap set-slots ] keep ; inline
+
+: construct-delegate ( delegate class -- tuple )
+ >r { set-delegate } r> construct ; inline
USING: generic help.markup help.syntax kernel math
memory namespaces sequences kernel.private classes
-sequences.private ;
+classes.builtin sequences.private ;
IN: layouts
HELP: tag-bits
{ $var-description "Taking the bitwise and of a tagged pointer with this mask leaves the tag." } ;
HELP: num-types
-{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link type } " primitive." } ;
+{ $var-description "Number of distinct built-in types. This is one more than the maximum value from the " { $link hi-tag } " primitive." } ;
HELP: tag-number
{ $values { "class" class } { "n" "an integer or " { $link f } } }
ARTICLE: "layouts-types" "Type numbers"
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
-{ $subsection type }
+{ $subsection hi-tag }
"Built-in type numbers can be converted to classes, and vice versa:"
{ $subsection type>class }
{ $subsection type-number }
PRIVATE>
-TUPLE: check-ptr ;
+ERROR: bad-ptr ;
: check-ptr ( c-ptr -- c-ptr )
- [ \ check-ptr construct-boa throw ] unless* ;
+ [ bad-ptr ] unless* ;
-TUPLE: double-free ;
+ERROR: double-free ;
-: double-free ( -- * )
- \ double-free construct-empty throw ;
-
-TUPLE: realloc-error ptr size ;
-
-: realloc-error ( alien size -- * )
- \ realloc-error construct-boa throw ;
+ERROR: realloc-error ptr size ;
<PRIVATE
USING: arrays hashtables io kernel math math.parser memory
namespaces parser sequences strings io.styles
io.streams.duplex vectors words generic system combinators
-tuples continuations debugger definitions compiler.units ;
+continuations debugger definitions compiler.units accessors ;
IN: listener
SYMBOL: quit-flag
: read-quot-step ( lines -- quot/f )
[ parse-lines-interactive ] [
- dup delegate unexpected-eof?
+ dup error>> unexpected-eof?
[ 2drop f ] [ rethrow ] if
] recover ;
[ HEX: 988a259c3433f237 ] [
B{ HEX: 37 HEX: f2 HEX: 33 HEX: 34 HEX: 9c HEX: 25 HEX: 8a HEX: 98 } byte-array>bignum
] unit-test
+
+[ t ] [ 256 power-of-2? ] unit-test
+[ f ] [ 123 power-of-2? ] unit-test
+
+[ f ] [ -128 power-of-2? ] unit-test
+[ f ] [ 0 power-of-2? ] unit-test
+[ t ] [ 1 power-of-2? ] unit-test
: random-interval ( -- interval )
1000 random dup 2 1000 random + +
- 1 random zero? [ [ neg ] 2apply swap ] when
+ 1 random zero? [ [ neg ] bi@ swap ] when
4 random {
{ 0 [ [a,b] ] }
{ 1 [ [a,b) ] }
{ max interval-max }
}
"math.ratios.private" vocab [
- { / interval/ } add
+ { / interval/ } suffix
] when
random ;
0 pick interval-contains? over first { / /i } member? and [
3drop t
] [
- [ >r [ random-element ] 2apply ! 2dup . .
+ [ >r [ random-element ] bi@ ! 2dup . .
r> first execute ] 3keep
second execute interval-contains?
] if ;
: comparison-test
random-interval random-interval random-comparison
- [ >r [ random-element ] 2apply r> first execute ] 3keep
+ [ >r [ random-element ] bi@ r> first execute ] 3keep
second execute dup incomparable eq? [
2drop t
] [
: (interval-op) ( p1 p2 quot -- p3 )
2over >r >r
- >r [ first ] 2apply r> call
+ >r [ first ] bi@ r> call
r> r> [ second ] both? 2array ; inline
: interval-op ( i1 i2 quot -- i3 )
: interval-bitnot ( i1 -- i2 ) interval-neg interval-1- ;
+: interval-sq ( i1 -- i2 ) dup interval* ;
+
: make-interval ( from to -- int )
over first over first {
{ [ 2dup > ] [ 2drop 2drop f ] }
2drop over second over second and
[ <interval> ] [ 2drop f ] if
] }
- { [ t ] [ 2drop <interval> ] }
+ [ 2drop <interval> ]
} cond ;
: interval-intersect ( i1 i2 -- i3 )
2dup and [
- [ interval>points ] 2apply swapd
+ [ interval>points ] bi@ swapd
[ swap endpoint> ] most
>r [ swap endpoint< ] most r>
make-interval
: interval-union ( i1 i2 -- i3 )
2dup and [
- [ interval>points 2array ] 2apply append points>interval
+ [ interval>points 2array ] bi@ append points>interval
] [
2drop f
] if ;
: interval-singleton? ( int -- ? )
interval>points
- 2dup [ second ] 2apply and
- [ [ first ] 2apply = ]
+ 2dup [ second ] bi@ and
+ [ [ first ] bi@ = ]
[ 2drop f ] if ;
: interval-length ( int -- n )
dup
- [ interval>points [ first ] 2apply swap - ]
+ [ interval>points [ first ] bi@ swap - ]
[ drop 0 ] if ;
: interval-closure ( i1 -- i2 )
- dup [ interval>points [ first ] 2apply [a,b] ] when ;
+ dup [ interval>points [ first ] bi@ [a,b] ] when ;
: interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
[ min ] interval-op interval-closure ;
: interval-interior ( i1 -- i2 )
- interval>points [ first ] 2apply (a,b) ;
+ interval>points [ first ] bi@ (a,b) ;
: interval-division-op ( i1 i2 quot -- i3 )
>r 0 over interval-closure interval-contains?
: left-endpoint-< ( i1 i2 -- ? )
[ swap interval-subset? ] 2keep
[ nip interval-singleton? ] 2keep
- [ interval-from ] 2apply =
+ [ interval-from ] bi@ =
and and ;
: right-endpoint-< ( i1 i2 -- ? )
[ interval-subset? ] 2keep
[ drop interval-singleton? ] 2keep
- [ interval-to ] 2apply =
+ [ interval-to ] bi@ =
and and ;
: (interval<) over interval-from over interval-from endpoint< ;
{ [ 2dup interval-intersect not ] [ (interval<) ] }
{ [ 2dup left-endpoint-< ] [ f ] }
{ [ 2dup right-endpoint-< ] [ f ] }
- { [ t ] [ incomparable ] }
+ [ incomparable ]
} cond 2nip ;
: left-endpoint-<= ( i1 i2 -- ? )
{
{ [ 2dup interval-intersect not ] [ (interval<) ] }
{ [ 2dup right-endpoint-<= ] [ t ] }
- { [ t ] [ incomparable ] }
+ [ incomparable ]
} cond 2nip ;
: interval> ( i1 i2 -- ? )
USING: help.markup help.syntax kernel sequences quotations
-math.private math.functions ;
+math.private ;
IN: math
ARTICLE: "division-by-zero" "Division by zero"
{ $subsection < }
{ $subsection <= }
{ $subsection > }
-{ $subsection >= }
-"Inexact comparison:"
-{ $subsection ~ } ;
+{ $subsection >= } ;
ARTICLE: "modular-arithmetic" "Modular arithmetic"
{ $subsection mod }
{ $subsection rem }
{ $subsection /mod }
{ $subsection /i }
-{ $subsection mod-inv }
-{ $subsection ^mod }
{ $see-also "integer-functions" } ;
ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
{ $values { "x" real } { "y" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
+HELP: before?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: after?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: before=?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+HELP: after=?
+{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
+{ $notes "Implemented using " { $link <=> } "." } ;
+
+{ before? after? before=? after=? } related-words
+
+
HELP: +
{ $values { "x" number } { "y" number } { "z" number } }
{ $description
{ $values { "m" "a non-negative integer" } { "n" "an integer" } }
{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;
+HELP: power-of-2?
+{ $values { "n" integer } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
+
HELP: each-integer
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- )" } } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } "." }
M: object zero? drop f ;
-: 1+ ( x -- y ) 1 + ; foldable
-: 1- ( x -- y ) 1 - ; foldable
-: 2/ ( x -- y ) -1 shift ; foldable
-: sq ( x -- y ) dup * ; foldable
-: neg ( x -- -x ) 0 swap - ; foldable
-: recip ( x -- y ) 1 swap / ; foldable
+: 1+ ( x -- y ) 1 + ; inline
+: 1- ( x -- y ) 1 - ; inline
+: 2/ ( x -- y ) -1 shift ; inline
+: sq ( x -- y ) dup * ; inline
+: neg ( x -- -x ) 0 swap - ; inline
+: recip ( x -- y ) 1 swap / ; inline
+
+: ?1+ [ 1+ ] [ 0 ] if* ; inline
: /f ( x y -- z ) >r >float r> >float float/f ; inline
-: max ( x y -- z ) [ > ] most ; foldable
-: min ( x y -- z ) [ < ] most ; foldable
+: max ( x y -- z ) [ > ] most ; inline
+: min ( x y -- z ) [ < ] most ; inline
: between? ( x y z -- ? )
pick >= [ >= ] [ 2drop f ] if ; inline
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
-: sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
+: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
: [-] ( x y -- z ) - 0 max ; inline
: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
-: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
+: power-of-2? ( n -- ? )
+ dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
+
+: align ( m w -- n )
+ 1- [ + ] keep bitnot bitand ; inline
<PRIVATE
{
{ [ dup empty? ] [ drop f ] }
{ [ f over memq? ] [ drop f ] }
- { [ t ] [ radix get [ < ] curry all? ] }
+ [ radix get [ < ] curry all? ]
} cond ;
: string>integer ( str -- n/f )
{
{ [ CHAR: / over member? ] [ string>ratio ] }
{ [ CHAR: . over member? ] [ string>float ] }
- { [ t ] [ string>integer ] }
+ [ string>integer ]
} cond
r> [ dup [ neg ] when ] when
] with-radix ;
} {
[ CHAR: . over member? ]
[ ]
- } {
- [ t ]
- [ ".0" append ]
}
+ [ ".0" append ]
} cond ;
M: float >base
{ [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
{ [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
{ [ dup fp-nan? ] [ drop "0.0/0.0" ] }
- { [ t ] [ float>string fix-float ] }
+ [ float>string fix-float ]
} cond ;
: number>string ( n -- str ) 10 >base ;
{ $description "Outputs a sequence of all objects in the heap which satisfy the quotation." }
{ $notes "This word relies on " { $link each-object } ", so in particular the garbage collector is switched off while it runs and the given quotation must not allocate too much memory." } ;
-HELP: data-gc ( -- )
+HELP: gc ( -- )
{ $description "Performs a full garbage collection." } ;
-HELP: code-gc ( -- )
-{ $description "Collects all generations up to and including tenured space, and also collects the code heap." } ;
-
HELP: gc-time ( -- n )
{ $values { "n" "a timestamp in milliseconds" } }
{ $description "Outputs the total time spent in garbage collection during this Factor session." } ;
USING: generic kernel kernel.private math memory prettyprint
-sequences tools.test words namespaces layouts classes ;
+sequences tools.test words namespaces layouts classes
+classes.builtin arrays quotations ;
IN: memory.tests
+! Code GC wasn't kicking in when needed
+: leak-step 800000 f <array> 1quotation call drop ;
+
+: leak-loop 100 [ leak-step ] times ;
+
+[ ] [ leak-loop ] unit-test
+
TUPLE: testing x y z ;
[ save-image-and-exit ] must-fail
IN: mirrors
ARTICLE: "mirrors" "Mirrors"
-"A reflective view of an object's slots and their values:"
+"The " { $vocab-link "mirrors" } " vocabulary defines data types which present an object's slots and slot values as an associative structure. This enables idioms such as iteration over all slots in a tuple, or editing of tuples, sequences and assocs in a generic fashion. This functionality is used by developer tools and meta-programming utilities."
+$nl
+"A mirror provides such a view of a tuple:"
{ $subsection mirror }
{ $subsection <mirror> }
-"A view of a sequence as an associative structure:"
-{ $subsection enum }
-{ $subsection <enum> }
"Utility word used by developer tools which inspect objects:"
-{ $subsection make-mirror } ;
+{ $subsection make-mirror }
+{ $see-also "slots" } ;
ABOUT: "mirrors"
"TUPLE: circle center radius ;"
"C: <circle> circle"
"{ 100 50 } 15 <circle> <mirror> >alist ."
- "{ { \"center\" { 100 50 } } { \"radius\" 15 } }"
+ "{ { \"delegate\" f } { \"center\" { 100 50 } } { \"radius\" 15 } }"
}
} ;
-HELP: >mirror<
-{ $values { "mirror" mirror } { "obj" object } { "slots" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Pushes the object being viewed in the mirror together with its slots." } ;
-
-HELP: enum
-{ $class-description "An associative structure which wraps a sequence and maps integers to the corresponding elements of the sequence."
-$nl
-"Enumerations are mutable; note that deleting a key calls " { $link delete-nth } ", which results in all subsequent elements being shifted down." } ;
-
HELP: make-mirror
{ $values { "obj" object } { "assoc" assoc } }
{ $description "Creates an assoc which reflects the internal structure of the object." } ;
-USING: mirrors tools.test assocs kernel arrays ;
+USING: mirrors tools.test assocs kernel arrays accessors ;
IN: mirrors.tests
TUPLE: foo bar baz ;
C: <foo> foo
-[ { "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
+[ { "delegate" "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
[ 1 t ] [ "bar" 1 2 <foo> <mirror> at* ] unit-test
[ 3 ] [
3 "baz" 1 2 <foo> [ <mirror> set-at ] keep foo-baz
] unit-test
+
+[ 3 "hi" 1 2 <foo> <mirror> set-at ] [
+ [ no-such-slot? ]
+ [ name>> "hi" = ]
+ [ object>> foo? ] tri and and
+] must-fail-with
+
+[ 3 "numerator" 1/2 <mirror> set-at ] [
+ [ immutable-slot? ]
+ [ name>> "numerator" = ]
+ [ object>> 1/2 = ] tri and and
+] must-fail-with
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences generic words
-arrays classes slots slots.private tuples math vectors
-quotations sorting prettyprint ;
+arrays classes slots slots.private classes.tuple math vectors
+quotations sorting prettyprint accessors ;
IN: mirrors
-GENERIC: object-slots ( obj -- seq )
+: all-slots ( class -- slots )
+ superclasses [ "slots" word-prop ] map concat ;
-M: object object-slots class "slots" word-prop ;
-
-M: tuple object-slots
- dup class "slots" word-prop
- swap delegate [ 1 tail-slice ] unless ;
+: object-slots ( obj -- seq )
+ class all-slots ;
TUPLE: mirror object slots ;
: <mirror> ( object -- mirror )
- dup object-slots mirror construct-boa ;
+ dup object-slots mirror boa ;
-: >mirror< ( mirror -- obj slots )
- dup mirror-object swap mirror-slots ;
+ERROR: no-such-slot object name ;
-: mirror@ ( slot-name mirror -- obj slot-spec )
- >mirror< swapd slot-named ;
+ERROR: immutable-slot object name ;
M: mirror at*
- mirror@ dup [ slot-spec-offset slot t ] [ 2drop f f ] if ;
+ [ nip object>> ] [ slots>> slot-named ] 2bi
+ dup [ offset>> slot t ] [ 2drop f f ] if ;
M: mirror set-at ( val key mirror -- )
- mirror@ dup [
- dup slot-spec-writer [
- slot-spec-offset set-slot
+ [ nip object>> ] [ drop ] [ slots>> slot-named ] 2tri dup [
+ dup writer>> [
+ nip offset>> set-slot
] [
- "Immutable slot" throw
+ drop immutable-slot
] if
] [
- "No such slot" throw
+ drop no-such-slot
] if ;
M: mirror delete-at ( key mirror -- )
f -rot set-at ;
M: mirror >alist ( mirror -- alist )
- >mirror<
- [ [ slot-spec-offset slot ] with map ] keep
- [ slot-spec-name ] map swap 2array flip ;
+ [ slots>> [ name>> ] map ]
+ [ [ object>> ] [ slots>> ] bi [ offset>> slot ] with map ] bi
+ zip ;
M: mirror assoc-size mirror-slots length ;
INSTANCE: mirror assoc
-TUPLE: enum seq ;
-
-C: <enum> enum
-
-M: enum at*
- enum-seq 2dup bounds-check?
- [ nth t ] [ 2drop f f ] if ;
-
-M: enum set-at enum-seq set-nth ;
-
-M: enum delete-at enum-seq delete-nth ;
-
-M: enum >alist ( enum -- alist )
- enum-seq dup length swap 2array flip ;
-
-M: enum assoc-size enum-seq length ;
-
-M: enum clear-assoc enum-seq delete-all ;
-
-INSTANCE: enum assoc
-
: sort-assoc ( assoc -- alist )
>alist
- [ dup first unparse-short swap ] { } map>assoc
+ [ [ first unparse-short ] keep ] { } map>assoc
sort-keys values ;
GENERIC: make-mirror ( obj -- assoc )
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
-combinators classes optimizer.def-use ;
+combinators classes optimizer.def-use accessors ;
IN: optimizer.backend
SYMBOL: class-substitutions
GENERIC: optimize-node* ( node -- node/t changed? )
-: ?union ( assoc/f assoc -- hash )
- over [ union ] [ nip ] if ;
+: ?union ( assoc assoc/f -- assoc' )
+ dup assoc-empty? [ drop ] [ swap assoc-union ] if ;
-: add-node-literals ( assoc node -- )
- over assoc-empty? [
- 2drop
- ] [
- [ node-literals ?union ] keep set-node-literals
- ] if ;
+: add-node-literals ( node assoc -- )
+ [ ?union ] curry change-literals drop ;
-: add-node-classes ( assoc node -- )
- over assoc-empty? [
- 2drop
- ] [
- [ node-classes ?union ] keep set-node-classes
- ] if ;
+: add-node-classes ( node assoc -- )
+ [ ?union ] curry change-classes drop ;
-: substitute-values ( assoc node -- )
- over assoc-empty? [
+: substitute-values ( node assoc -- )
+ dup assoc-empty? [
2drop
] [
- 2dup node-in-d swap substitute-here
- 2dup node-in-r swap substitute-here
- 2dup node-out-d swap substitute-here
- node-out-r swap substitute-here
+ {
+ [ >r in-d>> r> substitute-here ]
+ [ >r in-r>> r> substitute-here ]
+ [ >r out-d>> r> substitute-here ]
+ [ >r out-r>> r> substitute-here ]
+ } 2cleave
] if ;
: perform-substitutions ( node -- )
- class-substitutions get over add-node-classes
- literal-substitutions get over add-node-literals
- value-substitutions get swap substitute-values ;
+ [ class-substitutions get add-node-classes ]
+ [ literal-substitutions get add-node-literals ]
+ [ value-substitutions get substitute-values ]
+ tri ;
DEFER: optimize-nodes
: optimize-children ( node -- )
- [ optimize-nodes ] change-children ;
+ [ optimize-nodes ] map-children ;
: optimize-node ( node -- node )
dup [
2dup at* [ swap follow nip ] [ 2drop ] if ;
: union* ( assoc1 assoc2 -- assoc )
- union [ keys ] keep
+ assoc-union [ keys ] keep
[ dupd follow ] curry
H{ } map>assoc ;
#! Not very efficient.
dupd union* update ;
-: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
- node-out-d swap node-in-d 2array unify-lengths flip
+: compute-value-substitutions ( #call/#merge #return/#values -- assoc )
+ [ out-d>> ] [ in-d>> ] bi* 2array unify-lengths flip
[ = not ] assoc-subset >hashtable ;
: cleanup-inlining ( #return/#values -- newnode changed? )
- dup node-successor dup [
- class-substitutions get pick node-classes update
- literal-substitutions get pick node-literals update
- tuck compute-value-substitutions value-substitutions get swap update*
- node-successor t
+ dup node-successor [
+ [ node-successor ] keep
+ {
+ [ nip classes>> class-substitutions get swap update ]
+ [ nip literals>> literal-substitutions get swap update ]
+ [ compute-value-substitutions value-substitutions get swap update* ]
+ [ drop node-successor ]
+ } 2cleave t
] [
- 2drop t f
+ drop t f
] if ;
! #return
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: inference.dataflow inference.backend kernel ;
+IN: optimizer
+
+: collect-label-infos ( node -- node )
+ dup [
+ dup #label? [ collect-label-info ] [ drop ] if
+ ] each-node ;
+
{ [ over #label? not ] [ 2drop f ] }
{ [ over #label-word over eq? not ] [ 2drop f ] }
{ [ over #label-loop? not ] [ 2drop f ] }
- { [ t ] [ 2drop t ] }
+ [ 2drop t ]
} cond
] curry node-exists? ;
: label-is-not-loop? ( node word -- ? )
[
{
- { [ over #label? not ] [ 2drop f ] }
- { [ over #label-word over eq? not ] [ 2drop f ] }
- { [ over #label-loop? ] [ 2drop f ] }
- { [ t ] [ 2drop t ] }
- } cond
+ { [ over #label? not ] [ f ] }
+ { [ over #label-word over eq? not ] [ f ] }
+ { [ over #label-loop? ] [ f ] }
+ [ t ]
+ } cond 2nip
] curry node-exists? ;
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline
-
+
[ t ] [
- [ loop-test-1 ] dataflow dup detect-loops
+ [ loop-test-1 ] dataflow detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
- [ loop-test-1 1 2 3 ] dataflow dup detect-loops
+ [ loop-test-1 1 2 3 ] dataflow detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
- [ [ loop-test-1 ] each ] dataflow dup detect-loops
+ [ [ loop-test-1 ] each ] dataflow detect-loops
\ loop-test-1 label-is-loop?
] unit-test
[ t ] [
- [ [ loop-test-1 ] each ] dataflow dup detect-loops
+ [ [ loop-test-1 ] each ] dataflow detect-loops
\ (each-integer) label-is-loop?
] unit-test
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline
[ t ] [
- [ loop-test-2 ] dataflow dup detect-loops
+ [ loop-test-2 ] dataflow detect-loops
\ loop-test-2 label-is-not-loop?
] unit-test
dup [ [ loop-test-3 ] each ] [ drop ] if ; inline
[ t ] [
- [ loop-test-3 ] dataflow dup detect-loops
+ [ loop-test-3 ] dataflow detect-loops
\ loop-test-3 label-is-not-loop?
] unit-test
dup #label? [ node-successor find-label ] unless ;
: test-loop-exits
- dataflow dup detect-loops find-label
+ dataflow detect-loops find-label
dup node-param swap
[ node-child find-tail find-loop-exits [ class ] map ] keep
#label-loop? ;
] unit-test
[ f ] [
- [ [ [ ] map ] map ] dataflow dup detect-loops
+ [ [ [ ] map ] map ] dataflow detect-loops
[ dup #label? swap #loop? not and ] node-exists?
] unit-test
blah [ b ] [ a ] if ; inline
[ t ] [
- [ a ] dataflow dup detect-loops
+ [ a ] dataflow detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
- [ a ] dataflow dup detect-loops
+ [ a ] dataflow detect-loops
\ b label-is-loop?
] unit-test
[ t ] [
- [ b ] dataflow dup detect-loops
+ [ b ] dataflow detect-loops
\ a label-is-loop?
] unit-test
[ t ] [
- [ a ] dataflow dup detect-loops
+ [ a ] dataflow detect-loops
\ b label-is-loop?
] unit-test
blah [ b' ] [ a' ] if ; inline
[ f ] [
- [ a' ] dataflow dup detect-loops
+ [ a' ] dataflow detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
- [ b' ] dataflow dup detect-loops
+ [ b' ] dataflow detect-loops
\ b' label-is-loop?
] unit-test
! a standard iterative dataflow problem after all -- so I'm
! tempted to believe the computer here
[ t ] [
- [ b' ] dataflow dup detect-loops
+ [ b' ] dataflow detect-loops
\ a' label-is-loop?
] unit-test
[ f ] [
- [ a' ] dataflow dup detect-loops
+ [ a' ] dataflow detect-loops
\ b' label-is-loop?
] unit-test
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
-combinators classes generic.math continuations optimizer.def-use
-optimizer.backend generic.standard ;
+combinators classes classes.algebra generic.math continuations
+optimizer.def-use optimizer.backend generic.standard ;
IN: optimizer.control
! ! ! Rudimentary CFA
] [ 2drop ] if
] assoc-each [ remove-non-loop-calls ] when ;
-: detect-loops ( nodes -- )
+: detect-loops ( node -- node )
[
+ dup
collect-label-info
remove-non-tail-calls
remove-non-loop-calls
] [
node-class {
{ [ dup null class< ] [ drop f f ] }
- { [ dup general-t class< ] [ drop t t ] }
+ { [ dup \ f class-not class< ] [ drop t t ] }
{ [ dup \ f class< ] [ drop f t ] }
- { [ t ] [ drop f f ] }
+ [ drop f f ]
} cond
] if ;
namespaces assocs kernel sequences math tools.test words ;
[ 3 { 1 1 1 } ] [
- [ 1 2 3 ] dataflow compute-def-use
+ [ 1 2 3 ] dataflow compute-def-use drop
def-use get values dup length swap [ length ] map
] unit-test
: kill-set ( quot -- seq )
- dataflow compute-def-use compute-dead-literals keys
+ dataflow compute-def-use drop compute-dead-literals keys
[ value-literal ] map ;
: subset? [ member? ] curry all? ;
] unit-test
: regression-2 ( x y -- x.y )
- [ p1 ] 2apply [
+ [ p1 ] bi@ [
[
rot
[ 2swap [ swapd * -rot p2 +@ ] 2keep ]
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: optimizer.def-use
USING: namespaces assocs sequences inference.dataflow
-inference.backend kernel generic assocs classes vectors ;
+inference.backend kernel generic assocs classes vectors
+accessors combinators ;
+IN: optimizer.def-use
SYMBOL: def-use
GENERIC: node-def-use ( node -- )
-: compute-def-use ( node -- )
- H{ } clone def-use set [ node-def-use ] each-node ;
+: compute-def-use ( node -- node )
+ H{ } clone def-use set
+ dup [ node-def-use ] each-node ;
: nest-def-use ( node -- def-use )
- [ compute-def-use def-use get ] with-scope ;
+ [ compute-def-use drop def-use get ] with-scope ;
: (node-def-use) ( node -- )
- dup dup node-in-d uses-values
- dup dup node-in-r uses-values
- dup node-out-d defs-values
- node-out-r defs-values ;
+ {
+ [ dup in-d>> uses-values ]
+ [ dup in-r>> uses-values ]
+ [ out-d>> defs-values ]
+ [ out-r>> defs-values ]
+ } cleave ;
M: object node-def-use (node-def-use) ;
M: #return node-def-use
#! Values returned by local labels can be killed.
- dup node-param [ drop ] [ (node-def-use) ] if ;
+ dup param>> [ drop ] [ (node-def-use) ] if ;
! nodes that don't use their values directly
UNION: #killable
M: #label node-def-use
[
- dup node-in-d ,
- dup node-child node-out-d ,
- dup collect-recursion [ node-in-d , ] each
+ dup in-d>> ,
+ dup node-child out-d>> ,
+ dup calls>> [ in-d>> , ] each
] { } make purge-invariants uses-values ;
: branch-def-use ( #branch -- )
- active-children [ node-in-d ] map
+ active-children [ in-d>> ] map
purge-invariants t swap uses-values ;
M: #branch node-def-use
inline
M: #shuffle kill-node*
- [
- dup node-in-d empty? swap node-out-d empty? and
- ] prune-if ;
+ [ [ in-d>> empty? ] [ out-d>> empty? ] bi and ] prune-if ;
M: #push kill-node*
- [ node-out-d empty? ] prune-if ;
+ [ out-d>> empty? ] prune-if ;
-M: #>r kill-node* [ node-in-d empty? ] prune-if ;
+M: #>r kill-node*
+ [ in-d>> empty? ] prune-if ;
-M: #r> kill-node* [ node-in-r empty? ] prune-if ;
+M: #r> kill-node*
+ [ in-r>> empty? ] prune-if ;
: kill-node ( node -- node )
dup [
dup [ dead-literals get swap remove-all ] modify-values
dup kill-node* dup t eq? [
- drop dup [ kill-nodes ] change-children
+ drop dup [ kill-nodes ] map-children
] [
nip kill-node
] if
] if ;
: sole-consumer ( #call -- node/f )
- node-out-d first used-by
+ out-d>> first used-by
dup length 1 = [ first ] [ drop f ] if ;
: splice-def-use ( node -- )
#! degree of accuracy; the new values should be marked as
#! having _some_ usage, so that flushing doesn't erronously
#! flush them away.
- [ compute-def-use def-use get keys ] with-scope
+ nest-def-use keys
def-use get [ [ t swap ?push ] change-at ] curry each ;
--- /dev/null
+IN: optimizer.inlining.tests
+USING: tools.test optimizer.inlining ;
+
+\ word-flat-length must-infer
+
+\ inlining-math-method must-infer
+
+\ optimistic-inline? must-infer
+
+\ find-identity must-infer
USING: arrays generic assocs inference inference.class
inference.dataflow inference.backend inference.state io kernel
math namespaces sequences vectors words quotations hashtables
-combinators classes generic.math continuations optimizer.def-use
+combinators classes classes.algebra generic.math
+optimizer.math.partial continuations optimizer.def-use
optimizer.backend generic.standard optimizer.specializers
optimizer.def-use optimizer.pattern-match generic.standard
optimizer.control kernel.private ;
! not inline
{ [ dup inline? not ] [ drop 1 ] }
! inline
- { [ t ] [ dup dup set word-def (flat-length) ] }
+ [ dup dup set word-def (flat-length) ]
} cond ;
: (flat-length) ( seq -- n )
{ [ dup quotation? ] [ (flat-length) 1+ ] }
{ [ dup array? ] [ (flat-length) ] }
{ [ dup word? ] [ word-flat-length ] }
- { [ t ] [ drop 1 ] }
+ [ drop 1 ]
} cond
] map sum ;
[ word-def (flat-length) ] with-scope ;
! Single dispatch method inlining optimization
-: specific-method ( class word -- class ) order min-class ;
-
: node-class# ( node n -- class )
over node-in-d <reversed> ?nth node-class ;
] if ;
! Partial dispatch of math-generic words
-: math-both-known? ( word left right -- ? )
- math-class-max swap specific-method ;
-
-: inline-math-method ( #call word -- node )
- over node-input-classes first2 3dup math-both-known?
- [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
+: normalize-math-class ( class -- class' )
+ {
+ null
+ fixnum bignum integer
+ ratio rational
+ float real
+ complex number
+ object
+ } [ class< ] with find nip ;
+
+: inlining-math-method ( #call word -- quot/f )
+ swap node-input-classes
+ [ first normalize-math-class ]
+ [ second normalize-math-class ] bi
+ 3dup math-both-known? [ math-method* ] [ 3drop f ] if ;
+
+: inline-math-method ( #call word -- node/t )
+ [ drop ] [ inlining-math-method ] 2bi
+ dup [ f splice-quot ] [ 2drop t ] if ;
+
+: inline-math-partial ( #call word -- node/t )
+ [ drop ]
+ [
+ "derived-from" word-prop first
+ inlining-math-method dup
+ ]
+ [ nip 1quotation ] 2tri
+ [ = not ] [ drop ] 2bi and
+ [ f splice-quot ] [ 2drop t ] if ;
: inline-method ( #call -- node )
dup node-param {
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
- { [ t ] [ 2drop t ] }
+ { [ dup math-partial? ] [ inline-math-partial ] }
+ [ 2drop t ]
} cond ;
! Resolve type checks at compile time where possible
nip dup [ second ] when ;
: apply-identities ( node -- node/f )
- dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
+ dup find-identity f splice-quot ;
: optimistic-inline? ( #call -- ? )
dup node-param "specializer" word-prop dup [
>r node-input-classes r> specialized-length tail*
- [ types length 1 = ] all?
+ [ class-types length 1 = ] all?
] [
2drop f
] if ;
{ [ dup optimize-predicate? ] [ optimize-predicate ] }
{ [ dup optimistic-inline? ] [ optimistic-inline ] }
{ [ dup method-body-inline? ] [ optimistic-inline ] }
- { [ t ] [ inline-method ] }
+ [ inline-method ]
} cond dup not ;
sequences words parser vectors strings sbufs io namespaces
assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals
-math.floats.private tuples tuples.private classes
-optimizer.def-use optimizer.backend optimizer.pattern-match
-optimizer.inlining float-arrays sequences.private combinators ;
+math.floats.private classes.tuple classes.tuple.private classes
+classes.algebra optimizer.def-use optimizer.backend
+optimizer.pattern-match optimizer.inlining float-arrays
+sequences.private combinators ;
-! the output of <tuple> and <tuple-boa> has the class which is
-! its second-to-last input
{ <tuple> <tuple-boa> } [
[
- dup node-in-d dup length 2 - swap nth node-literal
- dup class? [ drop tuple ] unless 1array f
+ dup node-in-d peek node-literal
+ dup tuple-layout? [ layout-class ] [ drop tuple ] if
+ 1array f
] "output-classes" set-word-prop
] each
-\ construct-empty [
+\ new [
dup node-in-d peek node-literal
dup class? [ drop tuple ] unless 1array f
] "output-classes" set-word-prop
[ value-literal sequence? ] [ drop f ] if ;
: member-quot ( seq -- newquot )
- [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
+ [ literalize [ t ] ] { } map>assoc
+ [ drop f ] suffix [ nip case ] curry ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot f splice-quot ;
dup node-in-d second dup value? [
swap [
value-literal 0 `input literal,
- general-t 0 `output class,
+ \ f class-not 0 `output class,
] set-constraints
] [
2drop
] "constraints" set-word-prop
! eq? on the same object is always t
-{ eq? bignum= float= number= = } {
+{ eq? = } {
{ { @ @ } [ 2drop t ] }
} define-identities
-! type applied to an object of a known type can be folded
-: known-type? ( node -- ? )
- node-class-first types length 1 number= ;
-
-: fold-known-type ( node -- node )
- dup node-class-first types inline-literals ;
-
-\ type [
- { [ dup known-type? ] [ fold-known-type ] }
-] define-optimizers
-
-! if the result of type is n, then the object has type n
-{ tag type } [
- [
- num-types get swap [
- [
- [ type>class object or 0 `input class, ] keep
- 0 `output literal,
- ] set-constraints
- ] curry each
- ] "constraints" set-word-prop
-] each
-
! Specializers
-{ 1+ 1- sq neg recip sgn } [
- { number } "specializer" set-word-prop
-] each
-
-\ 2/ { fixnum } "specializer" set-word-prop
-
-{ min max } [
- { number number } "specializer" set-word-prop
-] each
-
{ first first2 first3 first4 }
[ { array } "specializer" set-word-prop ] each
assocs math math.private kernel.private sequences words parser
inference.class inference.dataflow vectors strings sbufs io
namespaces assocs quotations math.intervals sequences.private
-combinators splitting layouts math.parser classes generic.math
-optimizer.pattern-match optimizer.backend optimizer.def-use
-optimizer.inlining generic.standard system ;
+combinators splitting layouts math.parser classes
+classes.algebra generic.math optimizer.pattern-match
+optimizer.backend optimizer.def-use optimizer.inlining
+optimizer.math.partial generic.standard system accessors ;
-{ + bignum+ float+ fixnum+fast } {
- { { number 0 } [ drop ] }
- { { 0 number } [ nip ] }
-} define-identities
+: define-math-identities ( word identities -- )
+ >r all-derived-ops r> define-identities ;
+
+\ number= {
+ { { @ @ } [ 2drop t ] }
+} define-math-identities
-{ fixnum+ } {
+\ + {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
-} define-identities
+} define-math-identities
-{ - fixnum- bignum- float- fixnum-fast } {
+\ - {
{ { number 0 } [ drop ] }
{ { @ @ } [ 2drop 0 ] }
-} define-identities
+} define-math-identities
-{ < fixnum< bignum< float< } {
+\ < {
{ { @ @ } [ 2drop f ] }
-} define-identities
+} define-math-identities
-{ <= fixnum<= bignum<= float<= } {
+\ <= {
{ { @ @ } [ 2drop t ] }
-} define-identities
+} define-math-identities
-{ > fixnum> bignum> float>= } {
+\ > {
{ { @ @ } [ 2drop f ] }
-} define-identities
+} define-math-identities
-{ >= fixnum>= bignum>= float>= } {
+\ >= {
{ { @ @ } [ 2drop t ] }
-} define-identities
+} define-math-identities
-{ * fixnum* bignum* float* } {
+\ * {
{ { number 1 } [ drop ] }
{ { 1 number } [ nip ] }
{ { number 0 } [ nip ] }
{ { 0 number } [ drop ] }
{ { number -1 } [ drop 0 swap - ] }
{ { -1 number } [ nip 0 swap - ] }
-} define-identities
+} define-math-identities
-{ / fixnum/i bignum/i float/f } {
+\ / {
{ { number 1 } [ drop ] }
{ { number -1 } [ drop 0 swap - ] }
-} define-identities
+} define-math-identities
-{ fixnum-mod bignum-mod } {
- { { number 1 } [ 2drop 0 ] }
-} define-identities
+\ mod {
+ { { integer 1 } [ 2drop 0 ] }
+} define-math-identities
-{ bitand fixnum-bitand bignum-bitand } {
+\ rem {
+ { { integer 1 } [ 2drop 0 ] }
+} define-math-identities
+
+\ bitand {
{ { number -1 } [ drop ] }
{ { -1 number } [ nip ] }
{ { @ @ } [ drop ] }
{ { number 0 } [ nip ] }
{ { 0 number } [ drop ] }
-} define-identities
+} define-math-identities
-{ bitor fixnum-bitor bignum-bitor } {
+\ bitor {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
{ { @ @ } [ drop ] }
{ { number -1 } [ nip ] }
{ { -1 number } [ drop ] }
-} define-identities
+} define-math-identities
-{ bitxor fixnum-bitxor bignum-bitxor } {
+\ bitxor {
{ { number 0 } [ drop ] }
{ { 0 number } [ nip ] }
{ { number -1 } [ drop bitnot ] }
{ { -1 number } [ nip bitnot ] }
{ { @ @ } [ 2drop 0 ] }
-} define-identities
+} define-math-identities
-{ shift fixnum-shift fixnum-shift-fast bignum-shift } {
+\ shift {
{ { 0 number } [ drop ] }
{ { number 0 } [ drop ] }
-} define-identities
+} define-math-identities
: math-closure ( class -- newclass )
- { fixnum integer rational real }
+ { null fixnum bignum integer rational float real number }
[ class< ] with find nip number or ;
: fits? ( interval class -- ? )
"interval" word-prop dup
[ interval-subset? ] [ 2drop t ] if ;
-: math-output-class ( node min -- newclass )
- #! if min is f, it means we just want to use the declared
- #! output class from the "infer-effect".
- dup [
- swap node-in-d
- [ value-class* math-closure math-class-max ] each
- ] [
- 2drop f
- ] if ;
+: math-output-class ( node upgrades -- newclass )
+ >r
+ in-d>> null [ value-class* math-closure math-class-max ] reduce
+ dup r> at swap or ;
: won't-overflow? ( interval node -- ? )
node-in-d [ value-class* fixnum class< ] all?
: post-process ( class interval node -- classes intervals )
dupd won't-overflow?
[ >r dup { f integer } member? [ drop fixnum ] when r> ] when
- [ dup [ 1array ] when ] 2apply ;
+ [ dup [ 1array ] when ] bi@ ;
: math-output-interval-1 ( node word -- interval )
dup [
2drop f
] if ; inline
-: math-output-class/interval-1 ( node min word -- classes intervals )
- pick >r
- >r over r>
- math-output-interval-1
- >r math-output-class r>
- r> post-process ; inline
+: math-output-class/interval-1 ( node word -- classes intervals )
+ [ drop { } math-output-class 1array ]
+ [ math-output-interval-1 1array ] 2bi ;
{
- { 1+ integer interval-1+ }
- { 1- integer interval-1- }
- { neg integer interval-neg }
- { shift integer interval-recip }
- { bitnot fixnum interval-bitnot }
- { fixnum-bitnot f interval-bitnot }
- { bignum-bitnot f interval-bitnot }
- { 2/ fixnum interval-2/ }
- { sq integer f }
+ { bitnot interval-bitnot }
+ { fixnum-bitnot interval-bitnot }
+ { bignum-bitnot interval-bitnot }
} [
- first3 [
- math-output-class/interval-1
- ] 2curry "output-classes" set-word-prop
-] each
+ [ math-output-class/interval-1 ] curry
+ "output-classes" set-word-prop
+] assoc-each
: intervals ( node -- i1 i2 )
- node-in-d first2 [ value-interval* ] 2apply ;
+ node-in-d first2 [ value-interval* ] bi@ ;
: math-output-interval-2 ( node word -- interval )
dup [
2drop f
] if ; inline
-: math-output-class/interval-2 ( node min word -- classes intervals )
+: math-output-class/interval-2 ( node upgrades word -- classes intervals )
pick >r
>r over r>
math-output-interval-2
r> post-process ; inline
{
- { + integer interval+ }
- { - integer interval- }
- { * integer interval* }
- { / rational interval/ }
- { /i integer interval/i }
-
- { fixnum+ f interval+ }
- { fixnum+fast f interval+ }
- { fixnum- f interval- }
- { fixnum-fast f interval- }
- { fixnum* f interval* }
- { fixnum*fast f interval* }
- { fixnum/i f interval/i }
-
- { bignum+ f interval+ }
- { bignum- f interval- }
- { bignum* f interval* }
- { bignum/i f interval/i }
- { bignum-shift f interval-shift-safe }
-
- { float+ f interval+ }
- { float- f interval- }
- { float* f interval* }
- { float/f f interval/ }
-
- { min fixnum interval-min }
- { max fixnum interval-max }
+ { + { { fixnum integer } } interval+ }
+ { - { { fixnum integer } } interval- }
+ { * { { fixnum integer } } interval* }
+ { / { { fixnum rational } { integer rational } } interval/ }
+ { /i { { fixnum integer } } interval/i }
+ { shift { { fixnum integer } } interval-shift-safe }
} [
first3 [
- math-output-class/interval-2
- ] 2curry "output-classes" set-word-prop
-] each
-
-{ fixnum-shift fixnum-shift-fast shift } [
- [
- dup
- node-in-d second value-interval*
- -1./0. 0 [a,b] interval-subset? fixnum integer ?
- \ interval-shift-safe
- math-output-class/interval-2
- ] "output-classes" set-word-prop
+ [
+ math-output-class/interval-2
+ ] 2curry "output-classes" set-word-prop
+ ] 2curry each-derived-op
] each
: real-value? ( value -- n ? )
r> post-process ; inline
{
- { mod fixnum mod-range }
- { fixnum-mod f mod-range }
- { bignum-mod f mod-range }
- { float-mod f mod-range }
-
- { rem integer rem-range }
+ { mod { } mod-range }
+ { rem { { fixnum integer } } rem-range }
- { bitand fixnum bitand-range }
- { fixnum-bitand f bitand-range }
-
- { bitor fixnum f }
- { bitxor fixnum f }
+ { bitand { } bitand-range }
+ { bitor { } f }
+ { bitxor { } f }
} [
first3 [
- math-output-class/interval-special
- ] 2curry "output-classes" set-word-prop
+ [
+ math-output-class/interval-special
+ ] 2curry "output-classes" set-word-prop
+ ] 2curry each-derived-op
] each
: twiddle-interval ( i1 -- i2 )
: comparison-constraints ( node true false -- )
>r >r dup node set intervals dup [
2dup
- r> general-t (comparison-constraints)
+ r> \ f class-not (comparison-constraints)
r> \ f (comparison-constraints)
] [
r> r> 2drop 2drop
{ <= assume<= assume> }
{ > assume> assume<= }
{ >= assume>= assume< }
-
- { fixnum< assume< assume>= }
- { fixnum<= assume<= assume> }
- { fixnum> assume> assume<= }
- { fixnum>= assume>= assume< }
-
- { bignum< assume< assume>= }
- { bignum<= assume<= assume> }
- { bignum> assume> assume<= }
- { bignum>= assume>= assume< }
-
- { float< assume< assume>= }
- { float<= assume<= assume> }
- { float> assume> assume<= }
- { float>= assume>= assume< }
} [
- first3
- [
- [ comparison-constraints ] with-scope
- ] 2curry "constraints" set-word-prop
+ first3 [
+ [
+ [ comparison-constraints ] with-scope
+ ] 2curry "constraints" set-word-prop
+ ] 2curry each-derived-op
] each
{
! Removing overflow checks
: remove-overflow-check? ( #call -- ? )
- dup node-out-d first node-class fixnum class< ;
+ dup out-d>> first node-class
+ [ fixnum class< ] [ null eq? not ] bi and ;
{
{ + [ fixnum+fast ] }
+ { +-integer-fixnum [ fixnum+fast ] }
{ - [ fixnum-fast ] }
{ * [ fixnum*fast ] }
+ { *-integer-fixnum [ fixnum*fast ] }
+ { shift [ fixnum-shift-fast ] }
{ fixnum+ [ fixnum+fast ] }
{ fixnum- [ fixnum-fast ] }
{ fixnum* [ fixnum*fast ] }
- ! these are here as an optimization. if they weren't given
- ! explicitly, the same would be inferred after an extra
- ! optimization step (see optimistic-inline?)
- { 1+ [ 1 fixnum+fast ] }
- { 1- [ 1 fixnum-fast ] }
- { 2/ [ -1 fixnum-shift ] }
- { neg [ 0 swap fixnum-fast ] }
+ { fixnum-shift [ fixnum-shift-fast ] }
} [
[
[ dup remove-overflow-check? ] ,
{ <= interval<= }
{ > interval> }
{ >= interval>= }
-
- { fixnum< interval< }
- { fixnum<= interval<= }
- { fixnum> interval> }
- { fixnum>= interval>= }
-
- { bignum< interval< }
- { bignum<= interval<= }
- { bignum> interval> }
- { bignum>= interval>= }
-
- { float< interval< }
- { float<= interval<= }
- { float> interval> }
- { float>= interval>= }
} [
[
- dup [ dupd foldable-comparison? ] curry ,
- [ fold-comparison ] curry ,
- ] { } make 1array define-optimizers
+ [
+ dup [ dupd foldable-comparison? ] curry ,
+ [ fold-comparison ] curry ,
+ ] { } make 1array define-optimizers
+ ] curry each-derived-op
] assoc-each
! The following words are handled in a similar way except if
swap sole-consumer
dup #call? [ node-param eq? ] [ 2drop f ] if ;
-: coereced-to-fixnum? ( #call -- ? )
- \ >fixnum consumed-by? ;
+: coerced-to-fixnum? ( #call -- ? )
+ dup dup node-in-d [ node-class integer class< ] with all?
+ [ \ >fixnum consumed-by? ] [ drop f ] if ;
{
- { fixnum+ [ fixnum+fast ] }
- { fixnum- [ fixnum-fast ] }
- { fixnum* [ fixnum*fast ] }
+ { + [ [ >fixnum ] bi@ fixnum+fast ] }
+ { - [ [ >fixnum ] bi@ fixnum-fast ] }
+ { * [ [ >fixnum ] bi@ fixnum*fast ] }
} [
- [
+ >r derived-ops r> [
[
- dup remove-overflow-check?
- over coereced-to-fixnum? or
- ] ,
- [ f splice-quot ] curry ,
- ] { } make 1array define-optimizers
+ [
+ dup remove-overflow-check?
+ over coerced-to-fixnum? or
+ ] ,
+ [ f splice-quot ] curry ,
+ ] { } make 1array define-optimizers
+ ] curry each
] assoc-each
-: fixnum-shift-fast-pos? ( node -- ? )
- #! Shifting 1 to the left won't overflow if the shift
- #! count is small enough
- dup dup node-in-d first node-literal 1 = [
- dup node-in-d second node-interval
- 0 cell-bits tag-bits get - 2 - [a,b] interval-subset?
- ] [ drop f ] if ;
-
-: fixnum-shift-fast-neg? ( node -- ? )
- #! Shifting any number to the right won't overflow if the
- #! shift count is small enough
- dup node-in-d second node-interval
- cell-bits 1- neg 0 [a,b] interval-subset? ;
-
-: fixnum-shift-fast? ( node -- ? )
- dup fixnum-shift-fast-pos?
- [ drop t ] [ fixnum-shift-fast-neg? ] if ;
-
-\ fixnum-shift {
+: convert-rem-to-and? ( #call -- ? )
+ dup node-in-d {
+ { [ 2dup first node-class integer class< not ] [ f ] }
+ { [ 2dup second node-literal integer? not ] [ f ] }
+ { [ 2dup second node-literal power-of-2? not ] [ f ] }
+ [ t ]
+ } cond 2nip ;
+
+: convert-mod-to-and? ( #call -- ? )
+ dup dup node-in-d first node-interval 0 [a,inf] interval-subset?
+ [ convert-rem-to-and? ] [ drop f ] if ;
+
+: convert-mod-to-and ( #call -- node )
+ dup
+ dup node-in-d second node-literal 1-
+ [ nip bitand ] curry f splice-quot ;
+
+\ mod [
+ {
+ {
+ [ dup convert-mod-to-and? ]
+ [ convert-mod-to-and ]
+ }
+ } define-optimizers
+] each-derived-op
+
+\ rem {
+ {
+ [ dup convert-rem-to-and? ]
+ [ convert-mod-to-and ]
+ }
+} define-optimizers
+
+: fixnumify-bitand? ( #call -- ? )
+ dup node-in-d second node-interval fixnum fits? ;
+
+: fixnumify-bitand ( #call -- node )
+ [ [ >fixnum ] bi@ fixnum-bitand ] f splice-quot ;
+
+\ bitand {
{
- [ dup fixnum-shift-fast? ]
- [ [ fixnum-shift-fast ] f splice-quot ]
+ [ dup fixnumify-bitand? ]
+ [ fixnumify-bitand ]
}
} define-optimizers
--- /dev/null
+IN: optimizer.math.partial.tests
+USING: optimizer.math.partial tools.test math kernel
+sequences ;
+
+[ t ] [ \ + integer fixnum math-both-known? ] unit-test
+[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
+[ t ] [ \ + integer bignum math-both-known? ] unit-test
+[ t ] [ \ + float fixnum math-both-known? ] unit-test
+[ f ] [ \ + real fixnum math-both-known? ] unit-test
+[ f ] [ \ + object number math-both-known? ] unit-test
+[ f ] [ \ number= fixnum object math-both-known? ] unit-test
+[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
+[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel kernel.private math math.private words
+sequences parser namespaces assocs quotations arrays
+generic generic.math hashtables effects ;
+IN: optimizer.math.partial
+
+! Partial dispatch.
+
+! This code will be overhauled and generalized when
+! multi-methods go into the core.
+PREDICATE: math-partial < word
+ "derived-from" word-prop >boolean ;
+
+: fixnum-integer-op ( a b fix-word big-word -- c )
+ pick tag 0 eq? [
+ drop execute
+ ] [
+ >r drop >r fixnum>bignum r> r> execute
+ ] if ; inline
+
+: integer-fixnum-op ( a b fix-word big-word -- c )
+ >r pick tag 0 eq? [
+ r> drop execute
+ ] [
+ drop fixnum>bignum r> execute
+ ] if ; inline
+
+: integer-integer-op ( a b fix-word big-word -- c )
+ pick tag 0 eq? [
+ integer-fixnum-op
+ ] [
+ >r drop over tag 0 eq? [
+ >r fixnum>bignum r> r> execute
+ ] [
+ r> execute
+ ] if
+ ] if ; inline
+
+<<
+: integer-op-combinator ( triple -- word )
+ [
+ [ second word-name % "-" % ]
+ [ third word-name % "-op" % ]
+ bi
+ ] "" make in get lookup ;
+
+: integer-op-word ( triple fix-word big-word -- word )
+ [
+ drop
+ word-name "fast" tail? >r
+ [ "-" % ] [ word-name % ] interleave
+ r> [ "-fast" % ] when
+ ] "" make in get create ;
+
+: integer-op-quot ( word fix-word big-word -- quot )
+ rot integer-op-combinator 1quotation 2curry ;
+
+: define-integer-op-word ( word fix-word big-word -- )
+ [
+ [ integer-op-word ] [ integer-op-quot ] 3bi
+ 2 1 <effect> define-declared
+ ]
+ [
+ [ integer-op-word ] [ 2drop ] 3bi
+ "derived-from" set-word-prop
+ ] 3bi ;
+
+: define-integer-op-words ( words fix-word big-word -- )
+ [ define-integer-op-word ] 2curry each ;
+
+: integer-op-triples ( word -- triples )
+ {
+ { fixnum integer }
+ { integer fixnum }
+ { integer integer }
+ } swap [ prefix ] curry map ;
+
+: define-integer-ops ( word fix-word big-word -- )
+ >r >r integer-op-triples r> r>
+ [ define-integer-op-words ]
+ [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
+ 3bi ;
+
+: define-math-ops ( op -- )
+ { fixnum bignum float }
+ [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
+ [ nip ] assoc-subset
+ [ word-def peek ] assoc-map % ;
+
+SYMBOL: math-ops
+
+[
+ \ + define-math-ops
+ \ - define-math-ops
+ \ * define-math-ops
+ \ shift define-math-ops
+ \ mod define-math-ops
+ \ /i define-math-ops
+
+ \ bitand define-math-ops
+ \ bitor define-math-ops
+ \ bitxor define-math-ops
+
+ \ < define-math-ops
+ \ <= define-math-ops
+ \ > define-math-ops
+ \ >= define-math-ops
+ \ number= define-math-ops
+
+ \ + \ fixnum+ \ bignum+ define-integer-ops
+ \ - \ fixnum- \ bignum- define-integer-ops
+ \ * \ fixnum* \ bignum* define-integer-ops
+ \ shift \ fixnum-shift \ bignum-shift define-integer-ops
+ \ mod \ fixnum-mod \ bignum-mod define-integer-ops
+ \ /i \ fixnum/i \ bignum/i define-integer-ops
+
+ \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
+ \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
+ \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
+
+ \ < \ fixnum< \ bignum< define-integer-ops
+ \ <= \ fixnum<= \ bignum<= define-integer-ops
+ \ > \ fixnum> \ bignum> define-integer-ops
+ \ >= \ fixnum>= \ bignum>= define-integer-ops
+ \ number= \ eq? \ bignum= define-integer-ops
+] { } make >hashtable math-ops set-global
+
+SYMBOL: fast-math-ops
+
+[
+ { { + fixnum fixnum } fixnum+fast } ,
+ { { - fixnum fixnum } fixnum-fast } ,
+ { { * fixnum fixnum } fixnum*fast } ,
+ { { shift fixnum fixnum } fixnum-shift-fast } ,
+
+ \ + \ fixnum+fast \ bignum+ define-integer-ops
+ \ - \ fixnum-fast \ bignum- define-integer-ops
+ \ * \ fixnum*fast \ bignum* define-integer-ops
+ \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
+] { } make >hashtable fast-math-ops set-global
+
+>>
+
+: math-op ( word left right -- word' ? )
+ 3array math-ops get at* ;
+
+: math-method* ( word left right -- quot )
+ 3dup math-op
+ [ >r 3drop r> 1quotation ] [ drop math-method ] if ;
+
+: math-both-known? ( word left right -- ? )
+ 3dup math-op
+ [ 2drop 2drop t ]
+ [ drop math-class-max swap specific-method >boolean ] if ;
+
+: (derived-ops) ( word assoc -- words )
+ swap [ rot first eq? nip ] curry assoc-subset values ;
+
+: derived-ops ( word -- words )
+ [ 1array ]
+ [ math-ops get (derived-ops) ]
+ bi append ;
+
+: fast-derived-ops ( word -- words )
+ fast-math-ops get (derived-ops) ;
+
+: all-derived-ops ( word -- words )
+ [ derived-ops ] [ fast-derived-ops ] bi append ;
+
+: each-derived-op ( word quot -- )
+ >r derived-ops r> each ; inline
USING: arrays compiler.units generic hashtables inference kernel
-kernel.private math optimizer prettyprint sequences sbufs
-strings tools.test vectors words sequences.private quotations
-optimizer.backend classes inference.dataflow tuples.private
-continuations growable optimizer.inlining namespaces hints ;
+kernel.private math optimizer generator prettyprint sequences
+sbufs strings tools.test vectors words sequences.private
+quotations optimizer.backend classes classes.algebra
+inference.dataflow classes.tuple.private continuations growable
+optimizer.inlining namespaces hints ;
IN: optimizer.tests
[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union*
] unit-test
-! Test method inlining
-[ f ] [ fixnum { } min-class ] unit-test
-
-[ string ] [
- \ string
- [ integer string array reversed sbuf
- slice vector quotation ]
- sort-classes min-class
-] unit-test
-
-[ fixnum ] [
- \ fixnum
- [ fixnum integer object ]
- sort-classes min-class
-] unit-test
-
-[ integer ] [
- \ fixnum
- [ integer float object ]
- sort-classes min-class
-] unit-test
-
-[ object ] [
- \ word
- [ integer float object ]
- sort-classes min-class
-] unit-test
-
-[ reversed ] [
- \ reversed
- [ integer reversed slice ]
- sort-classes min-class
-] unit-test
-
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
[ breakage ] must-fail
! regression
-: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline
-: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline
-: test-2 ( -- ) 5 test-1 ;
-
-[ f ] [ f test-2 ] unit-test
-
: branch-fold-regression-0 ( m -- n )
t [ ] [ 1+ branch-fold-regression-0 ] if ; inline
[ t ] [ \ node-successor-f-bug compiled? ] unit-test
-[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test
+[ ] [ [ new ] dataflow optimize drop ] unit-test
[ ] [ [ <tuple> ] dataflow optimize drop ] unit-test
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
-! Make sure we don't lose
GENERIC: generic-inline-test ( x -- y )
M: integer generic-inline-test ;
generic-inline-test
generic-inline-test ;
+! Inlining all of the above should only take two passes
[ { t f } ] [
\ generic-inline-test-1 word-def dataflow
[ optimize-1 , optimize-1 , drop ] { } make
HINTS: recursive-inline-hang-3 array ;
+! Regression
+USE: sequences.private
+
+[ ] [ { (3append) } compile ] unit-test
+
+! Wow
+: counter-example ( a b c d -- a' b' c' d' )
+ dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline
+
+: counter-example' ( -- a' b' c' d' )
+ 1 2 3.0 3 counter-example ;
+
+[ 2 4 6.0 0 ] [ counter-example' ] unit-test
+
+: member-test { + - * / /i } member? ;
+\ member-test must-infer
+[ ] [ \ member-test word-dataflow optimize 2drop ] unit-test
+[ t ] [ \ + member-test ] unit-test
+[ f ] [ \ append member-test ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces optimizer.backend optimizer.def-use
optimizer.known-words optimizer.math optimizer.control
-optimizer.inlining inference.class ;
+optimizer.collect optimizer.inlining inference.class ;
IN: optimizer
: optimize-1 ( node -- newnode ? )
H{ } clone class-substitutions set
H{ } clone literal-substitutions set
H{ } clone value-substitutions set
- dup compute-def-use
+
+ collect-label-infos
+ compute-def-use
kill-values
- dup detect-loops
- dup infer-classes
+ detect-loops
+ infer-classes
+
optimizer-changed off
optimize-nodes
optimizer-changed get
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer.pattern-match
USING: kernel sequences inference namespaces generic
-combinators classes inference.dataflow ;
+combinators classes classes.algebra inference.dataflow ;
! Funny pattern matching
SYMBOL: @
{ [ dup @ eq? ] [ drop match-@ ] }
{ [ dup class? ] [ match-class ] }
{ [ over value? not ] [ 2drop f ] }
- { [ t ] [ swap value-literal = ] }
+ [ swap value-literal = ]
} cond ;
: node-match? ( node values pattern -- ? )
! See http://factorcode.org/license.txt for BSD license.\r
USING: arrays generic hashtables kernel kernel.private math\r
namespaces sequences vectors words strings layouts combinators\r
-sequences.private classes generic.standard assocs ;\r
+sequences.private classes generic.standard\r
+generic.standard.engines assocs ;\r
IN: optimizer.specializers\r
\r
: (make-specializer) ( class picker -- quot )\r
\r
: method-declaration ( method -- quot )\r
dup "method-generic" word-prop dispatch# object <array>\r
- swap "method-class" word-prop add* ;\r
+ swap "method-class" word-prop prefix ;\r
\r
: specialize-method ( quot method -- quot' )\r
- method-declaration [ declare ] curry swap append ;\r
+ method-declaration [ declare ] curry prepend ;\r
\r
: specialize-quot ( quot specializer -- quot' )\r
dup { number } = [\r
[ dup "specializer" word-prop ]\r
[ "specializer" word-prop specialize-quot ]\r
}\r
- { [ t ] [ drop ] }\r
+ [ drop ]\r
} cond ;\r
\r
: specialized-length ( specializer -- n )\r
USING: help.markup help.syntax kernel sequences words
math strings vectors quotations generic effects classes
vocabs.loader definitions io vocabs source-files
-quotations namespaces compiler.units ;
+quotations namespaces compiler.units assocs ;
IN: parser
ARTICLE: "vocabulary-search-shadow" "Shadowing word names"
{ $subsection parse-file }
{ $subsection bootstrap-file }
"The parser cross-references source files and definitions. This allows it to keep track of removed definitions, and prevent forward references and accidental redefinitions."
+$nl
+"While the above words are useful for one-off experiments, real programs should be written to use the vocabulary system instead; see " { $link "vocabs.loader" } "."
{ $see-also "source-files" } ;
ARTICLE: "parser-usage" "Reflective parser usage"
"The parser can also parse from a stream:"
{ $subsection parse-stream } ;
+ARTICLE: "top-level-forms" "Top level forms"
+"Any code outside of a definition is known as a " { $emphasis "top-level form" } "; top-level forms are run after the entire source file has been parsed, regardless of their position in the file."
+$nl
+"Top-level forms do not have access to the " { $link in } " and " { $link use } " variables that were set at parse time, nor do they run inside " { $link with-compilation-unit } "; so meta-programming might require extra work in a top-level form compared with a parsing word."
+$nl
+"Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ;
+
ARTICLE: "parser" "The parser"
"This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies."
$nl
{ $subsection "vocabulary-search" }
{ $subsection "parser-files" }
{ $subsection "parser-usage" }
+{ $subsection "top-level-forms" }
"The parser can be extended."
{ $subsection "parsing-words" }
{ $subsection "parser-lexer" }
{ $values { "i" "a starting index" } { "seq" sequence } { "?" "a boolean" } { "n" integer } }
{ $description "Skips to the first space character (if " { $snippet "boolean" } " is " { $link f } ") or the first non-space character (otherwise)." } ;
-HELP: change-column
+HELP: change-lexer-column
{ $values { "lexer" lexer } { "quot" "a quotation with stack effect " { $snippet "( col line -- newcol )" } } }
{ $description "Applies a quotation to the current column and line text to produce a new column, and moves the lexer position." } ;
HELP: in
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
-HELP: shadow-warnings
-{ $values { "vocab" "an assoc mapping strings to words" } { "vocabs" "a sequence of assocs" } }
-{ $description "Tests if any keys in " { $snippet "vocab" } " shadow keys in the elements of " { $snippet "vocabs" } ", and if so, prints a warning message. These warning messages can be disabled by setting " { $link parser-notes } " to " { $link f } "." } ;
-
HELP: (use+)
{ $values { "vocab" "an assoc mapping strings to words" } }
{ $description "Adds an assoc at the front of the search path." }
{ $errors "Throws an error if the end of the line is reached." }
$parsing-note ;
-HELP: no-word
-{ $values { "name" string } { "newword" word } }
-{ $description "Throws a " { $link no-word } " error." }
+HELP: no-word-error
{ $error-description "Thrown if the parser encounters a token which does not name a word in the current vocabulary search path. If any words with this name exist in vocabularies not part of the search path, a number of restarts will offer to add those vocabularies to the search path and use the chosen word." }
{ $notes "Apart from a missing " { $link POSTPONE: USE: } ", this error can also indicate an ordering issue. In Factor, words must be defined before they can be called. Mutual recursion can be implemented via " { $link POSTPONE: DEFER: } "." } ;
+HELP: no-word
+{ $values { "name" string } { "newword" word } }
+{ $description "Throws a " { $link no-word-error } "." } ;
+
HELP: search
{ $values { "str" string } { "word/f" "a word or " { $link f } } }
{ $description "Searches for a word by name in the current vocabulary search path. If no such word could be found, outputs " { $link f } "." }
{ $errors "Throws an error if the token does not name a word, and does not parse as a number." }
$parsing-note ;
+HELP: invalid-slot-name
+{ $values { "name" string } }
+{ $description "Throws an " { $link invalid-slot-name } " error." }
+{ $error-description "Thrown by " { $link POSTPONE: TUPLE: } " and " { $link POSTPONE: ERROR: } " if a suspect token appears as a slot name." }
+{ $notes "The suspect tokens are chosen so that the following code raises this parse error, instead of silently greating a tuple with garbage slots:"
+ { $code
+ "TUPLE: my-mistaken-tuple slot-a slot-b"
+ ""
+ ": some-word ( a b c -- ) ... ;"
+ }
+} ;
+
HELP: unexpected
{ $values { "want" "a " { $link word } " or " { $link f } } { "got" word } }
{ $description "Throws an " { $link unexpected } " error." }
{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
-HELP: outside-usages
-{ $values { "seq" "a sequence of definitions" } { "usages" "an association list mapping definitions to sequences of definitions" } }
-{ $description "Outputs an association list mapping elements of " { $snippet "seq" } " to lists of usages which exclude the definitions in " { $snippet "seq" } " themselves." } ;
-
HELP: filter-moved
-{ $values { "assoc" "an assoc where the keys are definitions" } { "newassoc" "an assoc where the keys are definitions" } }
-{ $description "Removes all definitions from the assoc which are no longer present in the current " { $link file } "." } ;
-
-HELP: smudged-usage
-{ $values { "usages" "a sequence of definitions which reference removed definitions" } { "referenced" "a sequence of definitions removed from this source file which are still referenced elsewhere" } { "removed" "a sequence of definitions removed from this source file" } }
-{ $description "Collects information about changed word definitioins after parsing." } ;
+{ $values { "assoc1" assoc } { "assoc2" assoc } { "seq" "an seqence of definitions" } }
+{ $description "Removes all definitions from " { $snippet "assoc2" } " which are in " { $snippet "assoc1" } " or are are no longer present in the current " { $link file } "." } ;
HELP: forget-smudged
{ $description "Forgets removed definitions and prints a warning message if any of them are still referenced from other source files." } ;
USING: arrays math parser tools.test kernel generic words
io.streams.string namespaces classes effects source-files
assocs sequences strings io.files definitions continuations
-sorting tuples compiler.units debugger vocabs.loader ;
+sorting classes.tuple compiler.units debugger vocabs
+vocabs.loader accessors ;
IN: parser.tests
[
[
"IN: parser.tests TUPLE: another-pred-test ; GENERIC: another-pred-test?"
<string-reader> "removing-the-predicate" parse-stream
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[
"IN: parser.tests TUPLE: class-redef-test ; TUPLE: class-redef-test ;"
<string-reader> "redefining-a-class-1" parse-stream
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test"
[
"IN: parser.tests TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ;"
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ no-word? ] is? ] must-fail-with
+ ] [ error>> error>> no-word-error? ] must-fail-with
[ ] [
"IN: parser.tests TUPLE: class-fwd-test ; SYMBOL: class-fwd-test"
[
"IN: parser.tests \\ class-fwd-test"
<string-reader> "redefining-a-class-3" parse-stream drop
- ] [ [ no-word? ] is? ] must-fail-with
+ ] [ error>> error>> no-word-error? ] must-fail-with
[
"IN: parser.tests : foo ; TUPLE: foo ;"
<string-reader> "redefining-a-class-4" parse-stream drop
- ] [ [ redefine-error? ] is? ] must-fail-with
+ ] [ error>> error>> redefine-error? ] must-fail-with
[ ] [
"IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
] must-fail
] with-file-vocabs
-[
- << file get parsed >> file set
-
- : ~a ;
-
- DEFER: ~b
-
- "IN: parser.tests : ~b ~a ;" <string-reader>
- "smudgy" parse-stream drop
-
- : ~c ;
- : ~d ;
-
- { H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set
-
- { H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set
-
- [ V{ ~b } { ~a } { ~a ~c } ] [
- smudged-usage
- natural-sort
- ] unit-test
-] with-scope
-
-[
- << file get parsed >> file set
-
- GENERIC: ~e
-
- : ~f ~e ;
-
- : ~g ;
-
- { H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set
-
- { H{ { ~g ~g } } H{ } } new-definitions set
-
- [ V{ } { } { ~e ~f } ]
- [ smudged-usage natural-sort ]
- unit-test
-] with-scope
-
[ ] [
- "IN: parser.tests USE: kernel PREDICATE: object foo ( x -- y ) ;" eval
+ "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
] unit-test
[ t ] [
] times
[ ] [ "parser" reload ] unit-test
+
+[ ] [
+ [ "this-better-not-exist" forget-vocab ] with-compilation-unit
+] unit-test
+
+[
+ "USE: this-better-not-exist" eval
+] must-fail
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions generic assocs kernel math
-namespaces prettyprint sequences strings vectors words
-quotations inspector io.styles io combinators sorting
-splitting math.parser effects continuations debugger
-io.files io.streams.string vocabs io.encodings.utf8
-source-files classes hashtables compiler.errors compiler.units ;
+USING: arrays definitions generic assocs kernel math namespaces
+prettyprint sequences strings vectors words quotations inspector
+io.styles io combinators sorting splitting math.parser effects
+continuations debugger io.files io.streams.string vocabs
+io.encodings.utf8 source-files classes classes.tuple hashtables
+compiler.errors compiler.units accessors sets ;
IN: parser
TUPLE: lexer text line line-text line-length column ;
: next-line ( lexer -- )
- 0 over set-lexer-column
- dup lexer-line over lexer-text ?nth over set-lexer-line-text
- dup lexer-line-text length over set-lexer-line-length
- dup lexer-line 1+ swap set-lexer-line ;
+ dup [ line>> ] [ text>> ] bi ?nth >>line-text
+ dup line-text>> length >>line-length
+ [ 1+ ] change-line
+ 0 >>column
+ drop ;
+
+: new-lexer ( text class -- lexer )
+ new
+ 0 >>line
+ swap >>text
+ dup next-line ; inline
: <lexer> ( text -- lexer )
- 0 { set-lexer-text set-lexer-line } lexer construct
- dup next-line ;
+ lexer new-lexer ;
: location ( -- loc )
file get lexer get lexer-line 2dup and
[ swap CHAR: \s eq? xor ] curry find* drop
[ r> drop ] [ r> length ] if* ;
-: change-column ( lexer quot -- )
+: change-lexer-column ( lexer quot -- )
swap
[ dup lexer-column swap lexer-line-text rot call ] keep
set-lexer-column ; inline
GENERIC: skip-blank ( lexer -- )
M: lexer skip-blank ( lexer -- )
- [ t skip ] change-column ;
+ [ t skip ] change-lexer-column ;
GENERIC: skip-word ( lexer -- )
M: lexer skip-word ( lexer -- )
[
2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
- ] change-column ;
+ ] change-lexer-column ;
: still-parsing? ( lexer -- ? )
dup lexer-line swap lexer-text length <= ;
: scan ( -- str/f ) lexer get parse-token ;
-TUPLE: bad-escape ;
-
-: bad-escape ( -- * )
- \ bad-escape construct-empty throw ;
+ERROR: bad-escape ;
M: bad-escape summary drop "Bad escape code" ;
: parse-string ( -- str )
lexer get [
[ swap tail-slice (parse-string) ] "" make swap
- ] change-column ;
+ ] change-lexer-column ;
-TUPLE: parse-error file line col text ;
+TUPLE: parse-error file line column line-text error ;
: <parse-error> ( msg -- error )
- file get
- lexer get
- { lexer-line lexer-column lexer-line-text } get-slots
- parse-error construct-boa
- [ set-delegate ] keep ;
+ \ parse-error new
+ file get >>file
+ lexer get line>> >>line
+ lexer get column>> >>column
+ lexer get line-text>> >>line-text
+ swap >>error ;
: parse-dump ( error -- )
- dup parse-error-file file.
- dup parse-error-line number>string print
- dup parse-error-text dup string? [ print ] [ drop ] if
- parse-error-col 0 or CHAR: \s <string> write
+ {
+ [ file>> file. ]
+ [ line>> number>string print ]
+ [ line-text>> dup string? [ print ] [ drop ] if ]
+ [ column>> 0 or CHAR: \s <string> write ]
+ } cleave
"^" print ;
M: parse-error error.
- dup parse-dump delegate error. ;
+ [ parse-dump ] [ error>> error. ] bi ;
+
+M: parse-error summary
+ error>> summary ;
+
+M: parse-error compute-restarts
+ error>> compute-restarts ;
+
+M: parse-error error-help
+ error>> error-help ;
SYMBOL: use
SYMBOL: in
: word/vocab% ( word -- )
"(" % dup word-vocabulary % " " % word-name % ")" % ;
-: shadow-warning ( new old -- )
- 2dup eq? [
- 2drop
- ] [
- [ word/vocab% " shadowed by " % word/vocab% ] "" make
- note.
- ] if ;
-
-: shadow-warnings ( vocab vocabs -- )
- [
- swapd assoc-stack dup
- [ shadow-warning ] [ 2drop ] if
- ] curry assoc-each ;
-
: (use+) ( vocab -- )
- vocab-words use get 2dup shadow-warnings push ;
+ vocab-words use get push ;
: use+ ( vocab -- )
load-vocab (use+) ;
: set-in ( name -- )
check-vocab-string dup in set create-vocab (use+) ;
-TUPLE: unexpected want got ;
-
-: unexpected ( want got -- * )
- \ unexpected construct-boa throw ;
+ERROR: unexpected want got ;
-PREDICATE: unexpected unexpected-eof
+PREDICATE: unexpected-eof < unexpected
unexpected-got not ;
: unexpected-eof ( word -- * ) f unexpected ;
[ "Use the word " swap summary append ] keep
] { } map>assoc ;
-TUPLE: no-word name ;
+TUPLE: no-word-error name ;
-M: no-word summary
+M: no-word-error summary
drop "Word not found in current vocabulary search path" ;
: no-word ( name -- newword )
- dup \ no-word construct-boa
+ dup no-word-error boa
swap words-named [ forward-reference? not ] subset
word-restarts throw-restarts
dup word-vocabulary (use+) ;
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
-TUPLE: staging-violation word ;
+: shadowed-slots ( superclass slots -- shadowed )
+ >r all-slot-names r> intersect ;
+
+: check-slot-shadowing ( class superclass slots -- )
+ shadowed-slots [
+ [
+ "Definition of slot ``" %
+ %
+ "'' in class ``" %
+ word-name %
+ "'' shadows a superclass slot" %
+ ] "" make note.
+ ] with each ;
+
+ERROR: invalid-slot-name name ;
-: staging-violation ( word -- * )
- \ staging-violation construct-boa throw ;
+M: invalid-slot-name summary
+ drop
+ "Invalid slot name" ;
+
+: (parse-tuple-slots) ( -- )
+ #! This isn't meant to enforce any kind of policy, just
+ #! to check for mistakes of this form:
+ #!
+ #! TUPLE: blahblah foo bing
+ #!
+ #! : ...
+ scan {
+ { [ dup not ] [ unexpected-eof ] }
+ { [ dup { ":" "(" "<" } member? ] [ invalid-slot-name ] }
+ { [ dup ";" = ] [ drop ] }
+ [ , (parse-tuple-slots) ]
+ } cond ;
+
+: parse-tuple-slots ( -- seq )
+ [ (parse-tuple-slots) ] { } make ;
+
+: parse-tuple-definition ( -- class superclass slots )
+ CREATE-CLASS
+ scan {
+ { ";" [ tuple f ] }
+ { "<" [ scan-word parse-tuple-slots ] }
+ [ >r tuple parse-tuple-slots r> prefix ]
+ } case 3dup check-slot-shadowing ;
+
+ERROR: staging-violation word ;
M: staging-violation summary
drop
{ [ dup not ] [ drop unexpected-eof t ] }
{ [ dup delimiter? ] [ unexpected t ] }
{ [ dup parsing? ] [ nip execute-parsing t ] }
- { [ t ] [ pick push drop t ] }
+ [ pick push drop t ]
} cond ;
: (parse-until) ( accum end -- accum )
] if
] if ;
-TUPLE: bad-number ;
-
-: bad-number ( -- * ) \ bad-number construct-boa throw ;
+ERROR: bad-number ;
: parse-base ( parsed base -- parsed )
scan swap base> [ bad-number ] unless* parsed ;
: (:) CREATE-WORD parse-definition ;
-: (M:) CREATE-METHOD parse-definition ;
+SYMBOL: current-class
+SYMBOL: current-generic
+
+: (M:)
+ CREATE-METHOD
+ [
+ [ "method-class" word-prop current-class set ]
+ [ "method-generic" word-prop current-generic set ]
+ [ ] tri
+ parse-definition
+ ] with-scope ;
+
+: scan-object ( -- object )
+ scan-word dup parsing?
+ [ V{ } clone swap execute first ] when ;
GENERIC: expected>string ( obj -- str )
SYMBOL: interactive-vocabs
{
+ "accessors"
"arrays"
"assocs"
"combinators"
"Loading " write <pathname> . flush
] if ;
-: smudged-usage-warning ( usages removed -- )
- parser-notes? [
- "Warning: the following definitions were removed from sources," print
- "but are still referenced from other definitions:" print
- nl
- dup sorted-definitions.
- nl
- "The following definitions need to be updated:" print
- nl
- over sorted-definitions.
- nl
- ] when 2drop ;
-
-: filter-moved ( assoc -- newassoc )
- [
+: filter-moved ( assoc1 assoc2 -- seq )
+ assoc-diff [
drop where dup [ first ] when
file get source-file-path =
- ] assoc-subset ;
+ ] assoc-subset keys ;
-: removed-definitions ( -- definitions )
+: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions
- [ get first2 union ] 2apply diff ;
+ [ get first2 assoc-union ] bi@ ;
-: smudged-usage ( -- usages referenced removed )
- removed-definitions filter-moved keys [
- outside-usages
- [
- empty? [ drop f ] [
- {
- { [ dup pathname? ] [ f ] }
- { [ dup method-body? ] [ f ] }
- { [ t ] [ t ] }
- } cond nip
- ] if
- ] assoc-subset
- dup values concat prune swap keys
- ] keep ;
+: removed-classes ( -- assoc1 assoc2 )
+ new-definitions old-definitions
+ [ get second ] bi@ ;
+
+: forget-removed-definitions ( -- )
+ removed-definitions filter-moved forget-all ;
+
+: reset-removed-classes ( -- )
+ removed-classes
+ filter-moved [ class? ] subset [ reset-class ] each ;
: fix-class-words ( -- )
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
- new-definitions get first2 diff
- [ nip dup reset-generic define-symbol ] assoc-each ;
+ new-definitions get first2
+ filter-moved [ [ reset-generic ] [ define-symbol ] bi ] each ;
: forget-smudged ( -- )
- smudged-usage forget-all
- over empty? [ 2dup smudged-usage-warning ] unless 2drop
+ forget-removed-definitions
+ reset-removed-classes
fix-class-words ;
: finish-parsing ( lines quot -- )
file get
- [ record-form ] keep
- [ record-definitions ] keep
- record-checksum ;
+ [ record-form ]
+ [ record-definitions ]
+ [ record-checksum ]
+ tri ;
: parse-stream ( stream name -- quot )
[
[
[
[ parsing-file ] keep
- [ ?resource-path utf8 <file-reader> ] keep
+ [ utf8 <file-reader> ] keep
parse-stream
] with-compiler-errors
] [
[ dup parse-file call ] assert-depth drop ;
: ?run-file ( path -- )
- dup resource-exists? [ run-file ] [ drop ] if ;
+ dup exists? [ run-file ] [ drop ] if ;
: bootstrap-file ( path -- )
[ parse-file % ] [ run-file ] if-bootstrapping ;
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors
-generic hashtables io assocs kernel math namespaces sequences
-strings sbufs io.styles vectors words prettyprint.config
-prettyprint.sections quotations io io.files math.parser effects
-tuples classes float-arrays float-vectors ;
+USING: arrays byte-arrays bit-arrays generic hashtables io
+assocs kernel math namespaces sequences strings sbufs io.styles
+vectors words prettyprint.config prettyprint.sections quotations
+io io.files math.parser effects classes.tuple
+classes.tuple.private classes float-arrays ;
IN: prettyprint.backend
GENERIC: pprint* ( obj -- )
M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
-M: byte-vector pprint-delims drop \ BV{ \ } ;
M: bit-array pprint-delims drop \ ?{ \ } ;
-M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: float-array pprint-delims drop \ F{ \ } ;
-M: float-vector pprint-delims drop \ FV{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
M: tuple pprint-delims drop \ T{ \ } ;
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
-M: bit-vector >pprint-sequence ;
-M: byte-vector >pprint-sequence ;
-M: float-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
] [
pprint-object
] if ;
+
+M: tuple-layout pprint*
+ "( tuple layout )" swap present-text ;
ABOUT: "prettyprint-variables"
-HELP: indent
-{ $var-description "The prettyprinter's current indent level." } ;
-
-HELP: pprinter-stack
-{ $var-description "A stack of " { $link block } " objects currently being constructed by the prettyprinter." } ;
-
HELP: tab-size
{ $var-description "Prettyprinter tab size. Indent nesting is always a multiple of the tab size." } ;
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: prettyprint.config
-USING: alien arrays generic assocs io kernel math
+USING: arrays generic assocs io kernel math
namespaces sequences strings io.styles vectors words
continuations ;
"On a final note, the " { $link short. } " and " { $link pprint-short } " words restrict the length and nesting of printed sequences, their output will very likely not be valid syntax. They are only intended for interactive use." ;
ARTICLE: "prettyprint-section-protocol" "Prettyprinter section protocol"
-"Prettyprinter sections must delegate to an instance of " { $link section } ", and they must also obey a protocol."
+"Prettyprinter sections must subclass " { $link section } ", and they must also obey a protocol."
$nl
"Layout queries:"
{ $subsection section-fits? }
{ $subsection short-section }
{ $subsection long-section }
"Utilities to use when implementing sections:"
-{ $subsection <section> }
-{ $subsection delegate>block }
+{ $subsection new-section }
+{ $subsection new-block }
{ $subsection add-section } ;
ARTICLE: "prettyprint-sections" "Prettyprinter sections"
[ ] [ \ integer see ] unit-test
-[ ] [ \ general-t see ] unit-test
-
[ ] [ \ generic see ] unit-test
[ ] [ \ duplex-stream see ] unit-test
"IN: prettyprint.tests"
": another-soft-break-layout ( node -- quot )"
" parse-error-file"
- " [ <reversed> \"hello world foo\" add ] [ ] make ;"
+ " [ <reversed> \"hello world foo\" suffix ] [ ] make ;"
} ;
[ t ] [
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
[ \ f \ generic-see-test-with-f method see ] with-string-writer
] unit-test
+
+PREDICATE: predicate-see-test < integer even? ;
+
+[ "USING: math ;\nIN: prettyprint.tests\nPREDICATE: predicate-see-test < integer even? ;\n" ] [
+ [ \ predicate-see-test see ] with-string-writer
+] unit-test
+
+[ ] [ \ compose see ] unit-test
+[ ] [ \ curry see ] unit-test
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: prettyprint
-USING: alien arrays generic generic.standard assocs io kernel
+USING: arrays generic generic.standard assocs io kernel
math namespaces sequences strings io.styles io.streams.string
vectors words prettyprint.backend prettyprint.sections
prettyprint.config sorting splitting math.parser vocabs
-definitions effects tuples io.files classes continuations
-hashtables classes.mixin classes.union classes.predicate
-combinators quotations ;
+definitions effects classes.builtin classes.tuple io.files
+classes continuations hashtables classes.mixin classes.union
+classes.predicate classes.singleton combinators quotations
+sets ;
: make-pprint ( obj quot -- block in use )
[
{ [ dup word? not ] [ , ] }
{ [ dup "break?" word-prop ] [ drop ] }
{ [ dup "step-into?" word-prop ] [ remove-step-into ] }
- { [ t ] [ , ] }
+ [ , ]
} cond
] each
] [ ] make ;
: remove-breakpoints ( quot pos -- quot' )
over quotation? [
- 1+ cut [ (remove-breakpoints) ] 2apply
+ 1+ cut [ (remove-breakpoints) ] bi@
[ -> ] swap 3append
] [
drop
M: predicate-class see-class*
<colon \ PREDICATE: pprint-word
- dup superclass pprint-word
dup pprint-word
+ "<" text
+ dup superclass pprint-word
<block
"predicate-definition" word-prop pprint-elements
pprint-; block> block> ;
+M: singleton-class see-class* ( class -- )
+ \ SINGLETON: pprint-word pprint-word ;
+
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
- "slot-names" word-prop [ text ] each
+ dup superclass tuple eq? [
+ "<" text dup superclass pprint-word
+ ] unless
+ slot-names [ text ] each
pprint-; block> ;
M: word see-class* drop ;
USING: prettyprint io kernel help.markup help.syntax
-prettyprint.sections prettyprint.config words hashtables math
+prettyprint.config words hashtables math
strings definitions ;
+IN: prettyprint.sections
HELP: position
{ $var-description "The prettyprinter's current character position." } ;
-HELP: last-newline
-{ $var-description "The character position of the last newline output by the prettyprinter." } ;
-
HELP: recursion-check
{ $var-description "The current nesting of collections being output by the prettyprinter, used to detect circularity and prevent infinite recursion." } ;
-HELP: line-count
-{ $var-description "The number of lines output by the prettyprinter so far, used for line limiting (see " { $link line-limit } ")." } ;
-
-HELP: end-printing
-{ $var-description "A continuation captured by " { $link do-pprint } " that breaks out of the printer." } ;
-
HELP: line-limit?
{ $values { "?" "a boolean" } }
{ $description "Tests if the line number limit has been reached, and thus if prettyprinting should stop." } ;
{ $contract "Tests if a section should be output as a " { $link short-section } ". The default implementation calls " { $link section-fits? } " but this behavior can be cutomized." } ;
HELP: section
-{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various classes which delegate to this class:"
+{ $class-description "A piece of prettyprinter output. Instances of this class are not used directly, instead one instantiates various subclasses of this class:"
{ $list
{ $link text }
{ $link line-break }
}
"Instances of this class have the following slots:"
{ $list
- { { $link section-start } " - the start of the section, measured in characters from the beginning of the prettyprinted output" }
- { { $link section-end } " - the end of the section, measured in characters from the beginning of the prettyprinted output" }
- { { $link section-start-group? } " - see " { $link start-group } }
- { { $link section-end } " - see " { $link end-group } }
- { { $link section-style } " - character and/or paragraph styles to use when outputting this section. See " { $link "styles" } }
- { { $link section-overhang } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
+ { { $snippet "start" } " - the start of the section, measured in characters from the beginning of the prettyprinted output" }
+ { { $snippet "end" } " - the end of the section, measured in characters from the beginning of the prettyprinted output" }
+ { { $snippet "start-group?" } " - see " { $link start-group } }
+ { { $snippet "end-group?" } " - see " { $link end-group } }
+ { { $snippet "style" } " - character and/or paragraph styles to use when outputting this section. See " { $link "styles" } }
+ { { $snippet "overhang" } " - number of columns which must be left blank before the wrap margin for the prettyprinter to consider emitting this section as a " { $link short-section } ". Avoids lone hanging closing brackets" }
} } ;
-HELP: <section>
-{ $values { "style" hashtable } { "length" integer } { "section" section } }
+HELP: new-section
+{ $values { "length" integer } { "class" "a subclass of " { $link section } } { "section" section } }
{ $description "Creates a new section with the given length starting from " { $link position } ", advancing " { $link position } "." } ;
-HELP: change-indent
-{ $values { "section" section } { "n" integer } }
-{ $description "If the section requests indentation, adds " { $snippet "n" } " to the indent level, otherwise does nothing." } ;
-
HELP: <indent
{ $values { "section" section } }
{ $description "Increases indentation by the " { $link tab-size } " if requested by the section." } ;
-! Copyright (C) 2003, 2007 Slava Pestov.
+! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays generic hashtables io kernel math assocs
+USING: arrays generic hashtables io kernel math assocs
namespaces sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
-io.streams.nested ;
+io.streams.nested accessors ;
IN: prettyprint.sections
! State
SYMBOL: recursion-check
SYMBOL: pprinter-stack
-SYMBOL: last-newline
-SYMBOL: line-count
-SYMBOL: end-printing
-SYMBOL: indent
-
! We record vocabs of all words
SYMBOL: pprinter-in
SYMBOL: pprinter-use
+TUPLE: pprinter last-newline line-count end-printing indent ;
+
+: <pprinter> ( -- pprinter ) 0 1 f 0 pprinter boa ;
+
: record-vocab ( word -- )
word-vocabulary [ dup pprinter-use get set-at ] when* ;
! Utility words
: line-limit? ( -- ? )
- line-limit get dup [ line-count get <= ] when ;
+ line-limit get dup [ pprinter get line-count>> <= ] when ;
-: do-indent ( -- ) indent get CHAR: \s <string> write ;
+: do-indent ( -- ) pprinter get indent>> CHAR: \s <string> write ;
: fresh-line ( n -- )
- dup last-newline get = [
+ dup pprinter get last-newline>> = [
drop
] [
- last-newline set
- line-limit? [ "..." write end-printing get continue ] when
- line-count inc
+ pprinter get (>>last-newline)
+ line-limit? [
+ "..." write pprinter get end-printing>> continue
+ ] when
+ pprinter get [ 1+ ] change-line-count drop
nl do-indent
] if ;
: text-fits? ( len -- ? )
margin get dup zero?
- [ 2drop t ] [ >r indent get + r> <= ] if ;
+ [ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ;
! break only if position margin 2 / >
SYMBOL: soft
start-group? end-group?
style overhang ;
-: <section> ( style length -- section )
- position [ dup rot + dup ] change 0 {
- set-section-style
- set-section-start
- set-section-end
- set-section-overhang
- } section construct ;
+: new-section ( length class -- section )
+ new
+ position get >>start
+ swap position [ + ] change
+ position get >>end
+ 0 >>overhang ; inline
M: section section-fits? ( section -- ? )
- dup section-end last-newline get -
- swap section-overhang + text-fits? ;
+ [ end>> pprinter get last-newline>> - ]
+ [ overhang>> ] bi
+ + text-fits? ;
M: section indent-section? drop f ;
M: object short-section? section-fits? ;
-: change-indent ( section n -- )
- swap indent-section? [ indent +@ ] [ drop ] if ;
+: indent+ ( section n -- )
+ swap indent-section? [
+ pprinter get [ + ] change-indent drop
+ ] [ drop ] if ;
-: <indent ( section -- ) tab-size get change-indent ;
+: <indent ( section -- ) tab-size get indent+ ;
-: indent> ( section -- ) tab-size get neg change-indent ;
+: indent> ( section -- ) tab-size get neg indent+ ;
: <fresh-line ( section -- )
- section-start fresh-line ;
+ start>> fresh-line ;
: fresh-line> ( section -- )
- dup newline-after? [ section-end fresh-line ] [ drop ] if ;
+ dup newline-after? [ end>> fresh-line ] [ drop ] if ;
: <long-section ( section -- )
dup unindent-first-line?
: long-section> ( section -- )
dup indent> fresh-line> ;
-: with-style* ( style quot -- )
- swap stdio [ <style-stream> ] change
- call stdio [ delegate ] change ; inline
-
: pprint-section ( section -- )
dup short-section? [
- dup section-style [ short-section ] with-style*
+ dup section-style [ short-section ] with-style
] [
- dup <long-section
- dup section-style [ dup long-section ] with-style*
- long-section>
+ [ <long-section ]
+ [ dup section-style [ long-section ] with-style ]
+ [ long-section> ]
+ tri
] if ;
! Break section
-TUPLE: line-break type ;
+TUPLE: line-break < section type ;
: <line-break> ( type -- section )
- H{ } 0 <section>
- { set-line-break-type set-delegate }
- \ line-break construct ;
+ 0 \ line-break new-section
+ swap >>type ;
M: line-break short-section drop ;
M: line-break long-section drop ;
! Block sections
-TUPLE: block sections ;
+TUPLE: block < section sections ;
-: <block> ( style -- block )
- 0 <section> V{ } clone
- { set-delegate set-block-sections } block construct ;
+: new-block ( style class -- block )
+ 0 swap new-section
+ V{ } clone >>sections
+ swap >>style ; inline
-: delegate>block ( obj -- ) H{ } <block> swap set-delegate ;
+: <block> ( style -- block )
+ block new-block ;
: pprinter-block ( -- block ) pprinter-stack get peek ;
: add-section ( section -- )
- pprinter-block block-sections push ;
+ pprinter-block sections>> push ;
: last-section ( -- section )
- pprinter-block block-sections
+ pprinter-block sections>>
[ line-break? not ] find-last nip ;
: start-group ( -- )
- t last-section set-section-start-group? ;
+ last-section t >>start-group? drop ;
: end-group ( -- )
- t last-section set-section-end-group? ;
+ last-section t >>end-group? drop ;
: advance ( section -- )
- dup section-start last-newline get = not
- swap short-section? and
- [ bl ] when ;
+ [ start>> pprinter get last-newline>> = not ]
+ [ short-section? ] bi
+ and [ bl ] when ;
: line-break ( type -- ) [ <line-break> add-section ] when* ;
M: block section-fits? ( section -- ? )
- line-limit? [ drop t ] [ delegate section-fits? ] if ;
+ line-limit? [ drop t ] [ call-next-method ] if ;
: pprint-sections ( block advancer -- )
- swap block-sections [ line-break? not ] subset
+ swap sections>> [ line-break? not ] subset
unclip pprint-section [
dup rot call pprint-section
] with each ; inline
[ advance ] pprint-sections ;
: do-break ( break -- )
- dup line-break-type hard eq?
- over section-end last-newline get - margin get 2/ > or
- [ <fresh-line ] [ drop ] if ;
+ [ ]
+ [ type>> hard eq? ]
+ [ end>> pprinter get last-newline>> - margin get 2/ > ] tri
+ or [ <fresh-line ] [ drop ] if ;
-: empty-block? ( block -- ? ) block-sections empty? ;
+: empty-block? ( block -- ? ) sections>> empty? ;
: if-nonempty ( block quot -- )
>r dup empty-block? [ drop ] r> if ; inline
: (<block) pprinter-stack get push ;
-: <block H{ } <block> (<block) ;
+: <block f <block> (<block) ;
: <object ( obj -- ) presented associate <block> (<block) ;
! Text section
-TUPLE: text string ;
+TUPLE: text < section string ;
: <text> ( string style -- text )
- over length 1+ <section>
- { set-text-string set-delegate }
- \ text construct ;
+ over length 1+ \ text new-section
+ swap >>style
+ swap >>string ;
M: text short-section text-string write ;
: text ( string -- ) H{ } styled-text ;
! Inset section
-TUPLE: inset narrow? ;
+TUPLE: inset < block narrow? ;
: <inset> ( narrow? -- block )
- 2 H{ } <block>
- { set-inset-narrow? set-section-overhang set-delegate }
- inset construct ;
+ H{ } inset new-block
+ 2 >>overhang
+ swap >>narrow? ;
M: inset long-section
- dup inset-narrow? [
+ dup narrow?>> [
[ <fresh-line ] pprint-sections
] [
- delegate long-section
+ call-next-method
] if ;
M: inset indent-section? drop t ;
: <inset ( narrow? -- ) <inset> (<block) ;
! Flow section
-TUPLE: flow ;
+TUPLE: flow < block ;
: <flow> ( -- block )
- H{ } <block> flow construct-delegate ;
+ H{ } flow new-block ;
M: flow short-section? ( section -- ? )
#! If we can make room for this entire block by inserting
#! a newline, do it; otherwise, don't bother, print it as
#! a short section
- dup section-fits?
- over section-end rot section-start - text-fits? not or ;
+ [ section-fits? ]
+ [ [ end>> ] [ start>> ] bi - text-fits? not ] bi
+ or ;
: <flow ( -- ) <flow> (<block) ;
! Colon definition section
-TUPLE: colon ;
+TUPLE: colon < block ;
: <colon> ( -- block )
- H{ } <block> colon construct-delegate ;
+ H{ } colon new-block ;
M: colon long-section short-section ;
: <colon ( -- ) <colon> (<block) ;
: save-end-position ( block -- )
- position get swap set-section-end ;
+ position get >>end drop ;
: block> ( -- )
pprinter-stack get pop
- [ dup save-end-position add-section ] if-nonempty ;
-
-: with-section-state ( quot -- )
- [
- 0 indent set
- 0 last-newline set
- 1 line-count set
- call
- ] with-scope ; inline
+ [ [ save-end-position ] [ add-section ] bi ] if-nonempty ;
: do-pprint ( block -- )
- [
+ <pprinter> pprinter [
[
- dup section-style [
- [ end-printing set dup short-section ] callcc0
- ] with-nesting drop
+ dup style>> [
+ [
+ >r pprinter get (>>end-printing) r>
+ short-section
+ ] curry callcc0
+ ] with-nesting
] if-nonempty
- ] with-section-state ;
+ ] with-variable ;
! Long section layout algorithm
: chop-break ( seq -- seq )
M: f section-end-group? drop f ;
: split-before ( section -- )
- dup section-start-group? prev get section-end-group? and
- swap flow? prev get flow? not and
- or split-groups ;
+ [ section-start-group? prev get section-end-group? and ]
+ [ flow? prev get flow? not and ]
+ bi or split-groups ;
: split-after ( section -- )
section-end-group? split-groups ;
] { } make { t } split [ empty? not ] subset ;
: break-group? ( seq -- ? )
- dup first section-fits? swap peek section-fits? not and ;
+ [ first section-fits? ] [ peek section-fits? not ] bi and ;
: ?break-group ( seq -- )
dup break-group? [ first <fresh-line ] [ drop ] if ;
M: block long-section ( block -- )
[
- block-sections chop-break group-flow [
+ sections>> chop-break group-flow [
dup ?break-group [
dup line-break? [
do-break
] [
- dup advance pprint-section
+ [ advance ] [ pprint-section ] bi
] if
] each
] each
] unit-test
[ [ 1 2 3 4 ] ] [ [ 1 2 ] [ 3 4 ] append ] unit-test
-[ [ 1 2 3 ] ] [ [ 1 2 ] 3 add ] unit-test
-[ [ 3 1 2 ] ] [ [ 1 2 ] 3 add* ] unit-test
+[ [ 1 2 3 ] ] [ [ 1 2 ] 3 suffix ] unit-test
+[ [ 3 1 2 ] ] [ [ 1 2 ] 3 prefix ] unit-test
[ [ "hi" ] ] [ "hi" 1quotation ] unit-test
M: quotation call (call) ;
-M: curry call dup 4 slot swap 5 slot call ;
+M: curry call dup 3 slot swap 4 slot call ;
-M: compose call dup 4 slot swap 5 slot slip call ;
+M: compose call dup 3 slot swap 4 slot slip call ;
M: wrapper equal?
- over wrapper? [ [ wrapped ] 2apply = ] [ 2drop f ] if ;
+ over wrapper? [ [ wrapped ] bi@ = ] [ 2drop f ] if ;
UNION: callable quotation curry compose ;
--- /dev/null
+USING: refs tools.test kernel ;
+
+[ 3 ] [
+ H{ { "a" 3 } } "a" <value-ref> get-ref
+] unit-test
+
+[ 4 ] [
+ 4 H{ { "a" 3 } } clone "a" <value-ref>
+ [ set-ref ] keep
+ get-ref
+] unit-test
+
+[ "a" ] [
+ H{ { "a" 3 } } "a" <key-ref> get-ref
+] unit-test
+
+[ H{ { "b" 3 } } ] [
+ "b" H{ { "a" 3 } } clone [
+ "a" <key-ref>
+ set-ref
+ ] keep
+] unit-test
-! Copyright (C) 2007 Slava Pestov
+! Copyright (C) 2007, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: tuples kernel assocs ;
+USING: classes.tuple kernel assocs accessors ;
IN: refs
TUPLE: ref assoc key ;
-: <ref> ( assoc key class -- tuple )
- >r ref construct-boa r> construct-delegate ; inline
-
-: >ref< ( ref -- key assoc ) dup ref-key swap ref-assoc ;
+: >ref< [ key>> ] [ assoc>> ] bi ; inline
: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )
GENERIC: set-ref ( obj ref -- )
-TUPLE: key-ref ;
-: <key-ref> ( assoc key -- ref ) key-ref <ref> ;
-M: key-ref get-ref ref-key ;
+TUPLE: key-ref < ref ;
+C: <key-ref> key-ref ( assoc key -- ref )
+M: key-ref get-ref key>> ;
M: key-ref set-ref >ref< rename-at ;
-TUPLE: value-ref ;
-: <value-ref> ( assoc key -- ref ) value-ref <ref> ;
+TUPLE: value-ref < ref ;
+C: <value-ref> value-ref ( assoc key -- ref )
M: value-ref get-ref >ref< at ;
M: value-ref set-ref >ref< set-at ;
[ SBUF" x" ] [ 1 <sbuf> CHAR: x >bignum over push ] unit-test
-[ fixnum ] [ 1 >bignum SBUF" " new length class ] unit-test
+[ fixnum ] [ 1 >bignum SBUF" " new-sequence length class ] unit-test
[ fixnum ] [ 1 >bignum [ ] SBUF" " map-as length class ] unit-test
<PRIVATE
: string>sbuf ( string length -- sbuf )
- sbuf construct-boa ; inline
+ sbuf boa ; inline
PRIVATE>
M: sbuf set-nth-unsafe
underlying >r >r >fixnum r> >fixnum r> set-string-nth ;
-M: sbuf new drop [ 0 <string> ] keep >fixnum string>sbuf ;
+M: sbuf new-sequence drop [ 0 <string> ] keep >fixnum string>sbuf ;
: >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline
"An optional generic word for creating sequences of the same class as a given sequence:"
{ $subsection like }
"Optional generic words for optimization purposes:"
-{ $subsection new }
+{ $subsection new-sequence }
{ $subsection new-resizable }
{ $see-also "sequences-unsafe" } ;
ARTICLE: "sequences-add-remove" "Adding and removing sequence elements"
"Adding elements:"
-{ $subsection add }
-{ $subsection add* }
+{ $subsection prefix }
+{ $subsection suffix }
"Removing elements:"
-{ $subsection remove }
-{ $subsection seq-diff } ;
+{ $subsection remove } ;
ARTICLE: "sequences-reshape" "Reshaping sequences"
"A " { $emphasis "repetition" } " is a virtual sequence consisting of a single element repeated multiple times:"
{ $subsection reversed }
{ $subsection <reversed> }
"Transposing a matrix:"
-{ $subsection flip }
-"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
-{ $subsection column }
-{ $subsection <column> } ;
+{ $subsection flip } ;
ARTICLE: "sequences-appending" "Appending sequences"
{ $subsection append }
{ $subsection "sequences-split" }
{ $subsection "sequences-destructive" }
{ $subsection "sequences-stacks" }
+{ $subsection "sequences-sorting" }
+{ $subsection "sets" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
{ $description "Throws an " { $link immutable } " error." }
{ $error-description "Thrown if an attempt is made to modify an immutable sequence." } ;
-HELP: new
+HELP: new-sequence
{ $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } }
{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ;
HELP: all?
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." }
-{ $notes
- "The implementation makes use of a well-known logical identity:"
- $nl
- { $snippet "P[x] for all x <==> not ((not P[x]) for some x)" }
-} ;
+{ $description "Tests if all elements in the sequence satisfy the predicate by checking each element in turn. Given an empty sequence, vacuously outputs " { $link t } "." } ;
HELP: push-if
{ $values { "elt" object } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "accum" "a resizable mutable sequence" } }
}
{ $side-effects "seq" } ;
-{ push push-new add add* } related-words
+{ push push-new prefix suffix } related-words
-HELP: add
+HELP: suffix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the end of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples
- { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 add ." "{ 1 2 3 4 }" }
+ { $example "USING: prettyprint sequences ;" "{ 1 2 3 } 4 suffix ." "{ 1 2 3 4 }" }
} ;
-HELP: add*
+HELP: prefix
{ $values { "seq" sequence } { "elt" object } { "newseq" sequence } }
{ $description "Outputs a new sequence obtained by adding " { $snippet "elt" } " at the beginning of " { $snippet "seq" } "." }
{ $errors "Throws an error if the type of " { $snippet "elt" } " is not permitted in sequences of the same class as " { $snippet "seq1" } "." }
{ $examples
-{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 add* ." "{ 0 1 2 3 }" }
+{ $example "USING: prettyprint sequences ;" "{ 1 2 3 } 0 prefix ." "{ 0 1 2 3 }" }
} ;
-HELP: seq-diff
-{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
-{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality." } ;
-
HELP: sum-lengths
{ $values { "seq" "a sequence of sequences" } { "n" integer } }
{ $description "Outputs the sum of the lengths of all sequences in " { $snippet "seq" } "." } ;
{ <slice> subseq } related-words
-HELP: column
-{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
-
-HELP: <column> ( seq n -- column )
-{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
-{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
-{ $examples
- { $example
- "USING: arrays prettyprint sequences ;"
- "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
- "{ 1 4 7 }"
- }
-}
-{ $notes
- "In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "."
-} ;
-
HELP: repetition
{ $class-description "A virtual sequence consisting of " { $link repetition-elt } " repeated " { $link repetition-len } " times. Repetitions are created by calling " { $link <repetition> } "." } ;
{ $values { "seq" sequence } { "rest" sequence } { "first" object } }
{ $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first." }
{ $examples
- { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip add ." "{ 2 3 1 }" }
+ { $example "USING: prettyprint sequences ;" "{ 1 2 3 } unclip suffix ." "{ 2 3 1 }" }
} ;
HELP: unclip-slice
USING: arrays kernel math namespaces sequences kernel.private
sequences.private strings sbufs tools.test vectors bit-arrays
-generic ;
+generic vocabs.loader ;
IN: sequences.tests
[ V{ 1 2 3 4 } ] [ 1 5 dup <slice> >vector ] unit-test
[ [ ] ] [ [ 1 2 3 ] 3 tail ] unit-test
[ [ 3 ] ] [ [ 1 2 3 ] 2 tail ] unit-test
+[ "blah" ] [ "blahxx" 2 head* ] unit-test
+
+[ "xx" ] [ "blahxx" 2 tail* ] unit-test
+
+[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice = ] unit-test
+[ t ] [ "xxfoo" 2 head-slice "xxbar" 2 head-slice [ hashcode ] bi@ = ] unit-test
+
+[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* = ] unit-test
+[ t ] [ "xxfoo" 2 head-slice SBUF" barxx" 2 tail-slice* [ hashcode ] bi@ = ] unit-test
+
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] sequence= ] unit-test
[ t ] [ [ 1 2 3 ] { 1 2 3 } sequence= ] unit-test
[ t ] [ { 1 2 3 } [ 1 2 3 ] sequence= ] unit-test
[ f ] [ { "a" "b" "c" } { "a" "b" "c" } mismatch ] unit-test
-[ V{ } V{ } ] [ { "a" "b" } { "a" "b" } drop-prefix [ >vector ] 2apply ] unit-test
+[ V{ } V{ } ] [ { "a" "b" } { "a" "b" } drop-prefix [ >vector ] bi@ ] unit-test
-[ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test
+[ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] bi@ ] unit-test
[ -1 1 "abc" <slice> ] must-fail
-[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test
+[ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test
[ -1 ] [ "ab" "abc" <=> ] unit-test
[ 1 ] [ "abc" "ab" <=> ] unit-test
! Pathological case
[ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
+
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> = ] unit-test
+
+[ t ] [ "hi" <reversed> SBUF" hi" <reversed> [ hashcode ] bi@ = ] unit-test
+
[ -10 "hi" "bye" copy ] must-fail
[ 10 "hi" "bye" copy ] must-fail
[ V{ 1 2 3 } ]
[ 3 V{ 1 3 2 } clone [ push-new ] keep ] unit-test
-! Columns
-{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
-
-[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
-[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
-[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
-
! erg's random tester found this one
[ SBUF" 12341234" ] [
9 <sbuf> dup "1234" swap push-all dup dup swap push-all
[ ?{ f t } ] [ 0 2 ?{ f t f } subseq ] unit-test
-[ V{ f f f } ] [ 3 V{ } new ] unit-test
-[ SBUF" \0\0\0" ] [ 3 SBUF" " new ] unit-test
+[ V{ f f f } ] [ 3 V{ } new-sequence ] unit-test
+[ SBUF" \0\0\0" ] [ 3 SBUF" " new-sequence ] unit-test
[ 0 ] [ f length ] unit-test
[ f first ] must-fail
[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test
[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test
+! Hardcore
+[ ] [ "sequences" reload ] unit-test
GENERIC: set-length ( n seq -- )
GENERIC: nth ( n seq -- elt ) flushable
GENERIC: set-nth ( elt n seq -- )
-GENERIC: new ( len seq -- newseq ) flushable
+GENERIC: new-sequence ( len seq -- newseq ) flushable
GENERIC: new-resizable ( len seq -- newseq ) flushable
GENERIC: like ( seq exemplar -- newseq ) flushable
GENERIC: clone-like ( seq exemplar -- newseq ) flushable
: new-like ( len exemplar quot -- seq )
- over >r >r new r> call r> like ; inline
+ over >r >r new-sequence r> call r> like ; inline
M: sequence like drop ;
: bounds-check? ( n seq -- ? )
length 1- 0 swap between? ; inline
-TUPLE: bounds-error index seq ;
-
-: bounds-error ( n seq -- * )
- \ bounds-error construct-boa throw ;
+ERROR: bounds-error index seq ;
: bounds-check ( n seq -- n seq )
2dup bounds-check? [ bounds-error ] unless ; inline
MIXIN: immutable-sequence
-TUPLE: immutable seq ;
-
-: immutable ( seq -- * ) \ immutable construct-boa throw ;
+ERROR: immutable seq ;
M: immutable-sequence set-nth immutable ;
#! A bit of a pain; can't call cell-bits here
7 getenv 8 * 5 - 2^ 1- ; foldable
-PREDICATE: fixnum array-capacity
+PREDICATE: array-capacity < fixnum
0 max-array-capacity between? ;
: array-capacity ( array -- n )
M: virtual-sequence nth-unsafe virtual@ nth-unsafe ;
M: virtual-sequence set-nth-unsafe virtual@ set-nth-unsafe ;
M: virtual-sequence like virtual-seq like ;
-M: virtual-sequence new virtual-seq new ;
+M: virtual-sequence new-sequence virtual-seq new-sequence ;
INSTANCE: virtual-sequence sequence
C: <reversed> reversed
M: reversed virtual-seq reversed-seq ;
+
M: reversed virtual@ reversed-seq [ length swap - 1- ] keep ;
+
M: reversed length reversed-seq length ;
INSTANCE: reversed virtual-sequence
: collapse-slice ( m n slice -- m' n' seq )
dup slice-from swap slice-seq >r tuck + >r + r> r> ; inline
-TUPLE: slice-error reason ;
-: slice-error ( str -- * ) \ slice-error construct-boa throw ;
+ERROR: slice-error reason ;
: check-slice ( from to seq -- from to seq )
pick 0 < [ "start < 0" slice-error ] when
: <slice> ( from to seq -- slice )
dup slice? [ collapse-slice ] when
check-slice
- slice construct-boa ; inline
+ slice boa ; inline
M: slice virtual-seq slice-seq ;
+
M: slice virtual@ [ slice-from + ] keep slice-seq ;
+
M: slice length dup slice-to swap slice-from - ;
: head-slice ( seq n -- slice ) (head) <slice> ;
INSTANCE: slice virtual-sequence
-! A column of a matrix
-TUPLE: column seq col ;
-
-C: <column> column
-
-M: column virtual-seq column-seq ;
-M: column virtual@
- dup column-col -rot column-seq nth bounds-check ;
-M: column length column-seq length ;
-
-INSTANCE: column virtual-sequence
-
! One element repeated many times
TUPLE: repetition len elt ;
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ; inline
: prepare-subseq ( from to seq -- dst i src j n )
- [ >r swap - r> new dup 0 ] 3keep
+ [ >r swap - r> new-sequence dup 0 ] 3keep
-rot drop roll length ; inline
: check-copy ( src n dst -- )
(copy) drop ; inline
M: sequence clone-like
- >r dup length r> new [ 0 swap copy ] keep ;
+ >r dup length r> new-sequence [ 0 swap copy ] keep ;
M: immutable-sequence clone-like like ;
: append ( seq1 seq2 -- newseq ) over (append) ;
+: prepend ( seq1 seq2 -- newseq ) swap append ; inline
+
: 3append ( seq1 seq2 seq3 -- newseq ) pick (3append) ;
: change-nth ( i seq quot -- )
[ >r nth r> call ] 3keep drop set-nth ; inline
-: min-length ( seq1 seq2 -- n ) [ length ] 2apply min ; inline
+: min-length ( seq1 seq2 -- n ) [ length ] bi@ min ; inline
-: max-length ( seq1 seq2 -- n ) [ length ] 2apply max ; inline
+: max-length ( seq1 seq2 -- n ) [ length ] bi@ max ; inline
<PRIVATE
(2each) each-integer ; inline
: 2reverse-each ( seq1 seq2 quot -- )
- >r [ <reversed> ] 2apply r> 2each ; inline
+ >r [ <reversed> ] bi@ r> 2each ; inline
: 2reduce ( seq1 seq2 identity quot -- result )
>r -rot r> 2each ; inline
swap >r [ push ] curry compose r> while
] keep { } like ; inline
+: follow ( obj quot -- seq )
+ >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline
+
: index ( obj seq -- n )
[ = ] with find drop ;
: memq? ( obj seq -- ? )
[ eq? ] with contains? ;
-: seq-intersect ( seq1 seq2 -- seq1/\seq2 )
- swap [ member? ] curry subset ;
-
: remove ( obj seq -- newseq )
[ = not ] with subset ;
[ -rot 2nth-unsafe <=> ] [ [ length ] compare ] if* ;
: sequence= ( seq1 seq2 -- ? )
- 2dup [ length ] 2apply number=
+ 2dup [ length ] bi@ number=
[ mismatch not ] [ 2drop f ] if ; inline
+: sequence-hashcode-step ( oldhash newpart -- newhash )
+ swap [
+ dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
+ fixnum+fast fixnum+fast
+ ] keep fixnum-bitxor ; inline
+
+: sequence-hashcode ( n seq -- x )
+ 0 -rot [
+ hashcode* >fixnum sequence-hashcode-step
+ ] with each ; inline
+
+M: reversed equal? over reversed? [ sequence= ] [ 2drop f ] if ;
+
+M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
+
: move ( to from seq -- )
2over number=
[ 3drop ] [ [ nth swap ] keep set-nth ] if ; inline
: push-new ( elt seq -- ) [ delete ] 2keep push ;
-: add ( seq elt -- newseq )
- over >r over length 1+ r> [
- [ >r over length r> set-nth-unsafe ] keep
- [ 0 swap copy ] keep
- ] new-like ;
-
-: add* ( seq elt -- newseq )
+: prefix ( seq elt -- newseq )
over >r over length 1+ r> [
[ 0 swap set-nth-unsafe ] keep
[ 1 swap copy ] keep
] new-like ;
-: seq-diff ( seq1 seq2 -- newseq )
- swap [ member? not ] curry subset ;
+: suffix ( seq elt -- newseq )
+ over >r over length 1+ r> [
+ [ >r over length r> set-nth-unsafe ] keep
+ [ 0 swap copy ] keep
+ ] new-like ;
: peek ( seq -- elt ) dup length 1- swap nth ;
[ drop nip ]
[ 2drop first ]
[ >r drop first2 r> call ]
- [ >r drop first3 r> 2apply ]
+ [ >r drop first3 r> bi@ ]
} dispatch
] [
drop
>r >r halves r> r>
- [ [ binary-reduce ] 2curry 2apply ] keep
+ [ [ binary-reduce ] 2curry bi@ ] keep
call
] if ; inline
: flip ( matrix -- newmatrix )
dup empty? [
dup [ length ] map infimum
- [ <column> dup like ] with map
+ swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
] unless ;
-
-: sequence-hashcode-step ( oldhash newpart -- newhash )
- swap [
- dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast
- fixnum+fast fixnum+fast
- ] keep fixnum-bitxor ; inline
-
-: sequence-hashcode ( n seq -- x )
- 0 -rot [
- hashcode* >fixnum sequence-hashcode-step
- ] with each ; inline
--- /dev/null
+Slava Pestov
+Doug Coleman
--- /dev/null
+USING: kernel help.markup help.syntax sequences ;
+IN: sets
+
+ARTICLE: "sets" "Set-theoretic operations on sequences"
+"Set-theoretic operations on sequences are defined on the " { $vocab-link "sets" } " vocabulary. These operations use hashtables internally to achieve linear running time."
+$nl
+"Remove duplicates:"
+{ $subsection prune }
+"Test for duplicates:"
+{ $subsection all-unique? }
+"Set operations on sequences:"
+{ $subsection diff }
+{ $subsection intersect }
+{ $subsection union }
+{ $see-also member? memq? contains? all? "assocs-sets" } ;
+
+HELP: unique
+{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
+{ $description "Outputs a new assoc where the keys and values are equal." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" }
+} ;
+
+HELP: prune
+{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
+{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
+} ;
+
+HELP: all-unique?
+{ $values { "seq" sequence } { "?" "a boolean" } }
+{ $description "Tests whether a sequence contains any repeated elements." }
+{ $example
+ "USING: sets prettyprint ;"
+ "{ 0 1 1 2 3 5 } all-unique? ."
+ "f"
+} ;
+
+HELP: diff
+{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
+{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq2" } " but not " { $snippet "seq1" } ", comparing elements for equality."
+} { $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } diff ." "{ 4 }" }
+} ;
+
+HELP: intersect
+{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
+{ $description "Outputs a sequence consisting of elements present in both " { $snippet "seq1" } " and " { $snippet "seq2" } "." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } intersect ." "{ 2 3 }" }
+} ;
+
+HELP: union
+{ $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
+{ $description "Outputs a sequence consisting of elements present in " { $snippet "seq1" } " and " { $snippet "seq2" } " which does not contain duplicate values." }
+{ $examples
+ { $example "USING: sets prettyprint ;" "{ 1 2 3 } { 2 3 4 } union ." "V{ 1 2 3 4 }" }
+} ;
+
+{ diff intersect union } related-words
--- /dev/null
+USING: kernel sets tools.test ;
+IN: sets.tests
+
+[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
+[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
+
+[ V{ 1 2 3 } ] [ { 1 2 2 3 3 } prune ] unit-test
+[ V{ 3 2 1 } ] [ { 3 3 2 2 1 } prune ] unit-test
+
+[ { } ] [ { } { } intersect ] unit-test
+[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
+
+[ { } ] [ { } { } diff ] unit-test
+[ { 4 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
+
+[ V{ } ] [ { } { } union ] unit-test
+[ V{ 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs hashtables kernel sequences vectors ;
+IN: sets
+
+: (prune) ( elt hash vec -- )
+ 3dup drop key?
+ [ [ drop dupd set-at ] [ nip push ] [ ] 3tri ] unless
+ 3drop ; inline
+
+: prune ( seq -- newseq )
+ [ ] [ length <hashtable> ] [ length <vector> ] tri
+ [ [ (prune) ] 2curry each ] keep ;
+
+: unique ( seq -- assoc )
+ [ dup ] H{ } map>assoc ;
+
+: (all-unique?) ( elt hash -- ? )
+ 2dup key? [ 2drop f ] [ dupd set-at t ] if ;
+
+: all-unique? ( seq -- ? )
+ dup length <hashtable> [ (all-unique?) ] curry all? ;
+
+: intersect ( seq1 seq2 -- newseq )
+ unique [ key? ] curry subset ;
+
+: diff ( seq1 seq2 -- newseq )
+ swap unique [ key? not ] curry subset ;
+
+: union ( seq1 seq2 -- newseq )
+ append prune ;
--- /dev/null
+Set-theoretic operations on sequences
--- /dev/null
+collections
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays kernel kernel.private math namespaces\r
+sequences strings words effects generic generic.standard\r
+classes slots.private combinators slots ;\r
+IN: slots.deprecated\r
+\r
+: reader-effect ( class spec -- effect )\r
+ >r ?word-name 1array r> slot-spec-name 1array <effect> ;\r
+\r
+PREDICATE: slot-reader < word "reading" word-prop >boolean ;\r
+\r
+: set-reader-props ( class spec -- )\r
+ 2dup reader-effect\r
+ over slot-spec-reader\r
+ swap "declared-effect" set-word-prop\r
+ slot-spec-reader swap "reading" set-word-prop ;\r
+\r
+: define-reader ( class spec -- )\r
+ dup slot-spec-reader [\r
+ [ set-reader-props ] 2keep\r
+ dup slot-spec-offset\r
+ over slot-spec-reader\r
+ rot slot-spec-type reader-quot\r
+ define-slot-word\r
+ ] [\r
+ 2drop\r
+ ] if ;\r
+\r
+: writer-effect ( class spec -- effect )\r
+ slot-spec-name swap ?word-name 2array 0 <effect> ;\r
+\r
+PREDICATE: slot-writer < word "writing" word-prop >boolean ;\r
+\r
+: set-writer-props ( class spec -- )\r
+ 2dup writer-effect\r
+ over slot-spec-writer\r
+ swap "declared-effect" set-word-prop\r
+ slot-spec-writer swap "writing" set-word-prop ;\r
+\r
+: define-writer ( class spec -- )\r
+ dup slot-spec-writer [\r
+ [ set-writer-props ] 2keep\r
+ dup slot-spec-offset\r
+ swap slot-spec-writer\r
+ [ set-slot ]\r
+ define-slot-word\r
+ ] [\r
+ 2drop\r
+ ] if ;\r
+\r
+: define-slot ( class spec -- )\r
+ 2dup define-reader define-writer ;\r
+\r
+: define-slots ( class specs -- )\r
+ [ define-slot ] with each ;\r
+\r
+: reader-word ( class name vocab -- word )\r
+ >r >r "-" r> 3append r> create ;\r
+\r
+: writer-word ( class name vocab -- word )\r
+ >r [ swap "set-" % % "-" % % ] "" make r> create ;\r
+\r
+: (simple-slot-word) ( class name -- class name vocab )\r
+ over word-vocabulary >r >r word-name r> r> ;\r
+\r
+: simple-reader-word ( class name -- word )\r
+ (simple-slot-word) reader-word ;\r
+\r
+: simple-writer-word ( class name -- word )\r
+ (simple-slot-word) writer-word ;\r
+\r
+: short-slot ( class name # -- spec )\r
+ >r object bootstrap-word over r> f f <slot-spec>\r
+ 2over simple-reader-word over set-slot-spec-reader\r
+ -rot simple-writer-word over set-slot-spec-writer ;\r
+\r
+: long-slot ( spec # -- spec )\r
+ >r [ dup array? [ first2 create ] when ] map first4 r>\r
+ -rot <slot-spec> ;\r
+\r
+: simple-slots ( class slots base -- specs )\r
+ over length [ + ] with map [\r
+ {\r
+ { [ over not ] [ 2drop f ] }\r
+ { [ over string? ] [ >r dupd r> short-slot ] }\r
+ { [ over array? ] [ long-slot ] }\r
+ } cond\r
+ ] 2map [ ] subset nip ;\r
+\r
+: slot-of-reader ( reader specs -- spec/f )\r
+ [ slot-spec-reader eq? ] with find nip ;\r
+\r
+: slot-of-writer ( writer specs -- spec/f )\r
+ [ slot-spec-writer eq? ] with find nip ;\r
USING: help.markup help.syntax generic kernel.private parser
words kernel quotations namespaces sequences words arrays
-effects generic.standard tuples slots.private classes
-strings math ;
+effects generic.standard classes.tuple classes.builtin
+slots.private classes strings math ;
IN: slots
+ARTICLE: "accessors" "Slot accessors"
+"For each tuple slot, methods are defined on two accessor words in the " { $vocab-link "accessors" } " vocabulary:"
+{ $list
+ { "The " { $emphasis "reader" } " is named " { $snippet { $emphasis "slot" } ">>" } " and pushes the value of a slot on the stack." }
+ { "The " { $emphasis "writer" } " is named " { $snippet "(>>" { $emphasis "slot" } ")" } " and stores a value into a slot. It has stack effect " { $snippet "( value object -- )" } "." }
+}
+"In addition, two utility words are defined for each distinct slot name used in the system:"
+{ $list
+ { "The " { $emphasis "setter" } " is named " { $snippet ">>" { $emphasis "slot" } } " and stores a value into a slot. It has stack effect " { $snippet "( object value -- object )" } "." }
+ { "The " { $emphasis "changer" } " is named " { $snippet "change-" { $emphasis "slot" } } ". It applies a quotation to the current slot value and stores the result back in the slot; it has stack effect " { $snippet "( object quot -- object )" } "." }
+}
+"Since the reader and writer are generic, words can be written which do not depend on the specific class of tuple passed in, but instead work on any tuple that defines slots with certain names."
+$nl
+"In most cases, using the setter is preferred over the writer because the stack effect is better suited to the common case where the tuple is needed again, and where the new slot value was just computed and so is at the top of the stack. For example, consider the case where you want to create a tuple and fill in the slots with literals. The following version uses setters:"
+{ $code
+ "<email>"
+ " \"Happy birthday\" >>subject"
+ " { \"bob@bigcorp.com\" } >>to"
+ " \"alice@bigcorp.com\" >>from"
+ "send-email"
+}
+"The following uses writers, and requires some stack shuffling:"
+{ $code
+ "<email>"
+ " \"Happy birthday\" over (>>subject)"
+ " { \"bob@bigcorp.com\" } over (>>to)"
+ " \"alice@bigcorp.com\" over (>>from)"
+ "send-email"
+}
+"Even if some of the slot values come from the stack underneath the tuple being constructed, setters win:"
+{ $code
+ "<email>"
+ " swap >>subject"
+ " swap >>to"
+ " \"alice@bigcorp.com\" >>from"
+ "send-email"
+}
+"This is because " { $link swap } " is easier to understand than " { $link tuck } ":"
+{ $code
+ "<email>"
+ " tuck (>>subject)"
+ " tuck (>>to)"
+ " \"alice@bigcorp.com\" over (>>from)"
+ "send-email"
+}
+"The changer word abstracts a common pattern where a slot value is read then stored again; so the following is not idiomatic code:"
+{ $code
+ "find-manager"
+ " salary>> 0.75 * >>salary"
+}
+"The following version is preferred:"
+{ $code
+ "find-manager"
+ " [ 0.75 * ] change-salary"
+}
+{ $see-also "slots" "mirrors" } ;
+
ARTICLE: "slots" "Slots"
-"A " { $emphasis "slot" } " is a component of an object which can store a value. The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object."
+"A " { $emphasis "slot" } " is a component of an object which can store a value."
$nl
{ $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data."
+"The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object."
$nl
"The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance."
{ $subsection slot-spec }
-"Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not."
-{ $subsection slot-spec-reader }
-{ $subsection slot-spec-writer }
-"Given a reader or writer word and a class, it is possible to find the slot specifier corresponding to this word:"
-{ $subsection slot-of-reader }
-{ $subsection slot-of-writer }
-"Reader and writer words form classes:"
-{ $subsection slot-reader }
-{ $subsection slot-writer }
-"Slot readers and writers type check, then call unsafe primitives:"
-{ $subsection slot }
-{ $subsection set-slot } ;
+"The four words associated with a slot can be looked up in the " { $vocab-link "accessors" } " vocabulary:"
+{ $subsection reader-word }
+{ $subsection writer-word }
+{ $subsection setter-word }
+{ $subsection changer-word }
+"Looking up a slot by name:"
+{ $subsection slot-named }
+"Defining slots dynamically:"
+{ $subsection define-reader }
+{ $subsection define-writer }
+{ $subsection define-setter }
+{ $subsection define-changer }
+{ $subsection define-slot-methods }
+{ $subsection define-accessors }
+{ $see-also "accessors" "mirrors" } ;
ABOUT: "slots"
HELP: reader-effect
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
-{ $description "The stack effect of slot reader words is " { $snippet "( obj -- value )" } "." } ;
-
-HELP: reader-quot
-{ $values { "decl" class } { "quot" "a quotation with stack effect " { $snippet "( obj n -- value )" } } }
-{ $description "Outputs a quotation which reads the " { $snippet "n" } "th slot of an object and declares it as an instance of a class." } ;
-
-HELP: slot-reader
-{ $class-description "The class of slot reader words." }
-{ $examples
- { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ circle-center slot-reader? ." "t" }
-} ;
+{ $description "The stack effect of slot reader words is " { $snippet "( object -- value )" } "." } ;
HELP: define-reader
-{ $values { "class" class } { "spec" slot-spec } }
-{ $description "Defines a generic word " { $snippet "reader" } " to read a slot from instances of " { $snippet "class" } "." }
+{ $values { "class" class } { "name" string } { "slot" integer } }
+{ $description "Defines a reader word to read a slot from instances of " { $snippet "class" } "." }
$low-level-note ;
HELP: writer-effect
{ $values { "class" class } { "spec" slot-spec } { "effect" "an instance of " { $link effect } } }
{ $description "The stack effect of slot writer words is " { $snippet "( value obj -- )" } "." } ;
-HELP: slot-writer
-{ $class-description "The class of slot writer words." }
-{ $examples
- { $example "USING: classes prettyprint slots ;" "TUPLE: circle center radius ;" "\\ set-circle-center slot-writer? ." "t" }
-} ;
-
HELP: define-writer
-{ $values { "class" class } { "spec" slot-spec } }
+{ $values { "class" class } { "name" string } { "slot" integer } }
{ $description "Defines a generic word " { $snippet "writer" } " to write a new value to a slot in instances of " { $snippet "class" } "." }
$low-level-note ;
-HELP: define-slot
-{ $values { "class" class } { "spec" slot-spec } }
-{ $description "Defines a pair of generic words for reading and writing a slot value in instances of " { $snippet "class" } "." }
+HELP: define-slot-methods
+{ $values { "class" class } { "name" string } { "slot" integer } }
+{ $description "Defines a reader, writer, setter and changer for a slot in instances of " { $snippet "class" } "." }
$low-level-note ;
-HELP: define-slots
+HELP: define-accessors
{ $values { "class" class } { "specs" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Defines a set of slot reader/writer words." }
+{ $description "Defines slot methods." }
$low-level-note ;
-HELP: simple-slots
-{ $values { "class" class } { "slots" "a sequence of strings" } { "base" "a slot number" } { "specs" "a sequence of " { $link slot-spec } " instances" } }
-{ $description "Constructs a slot specification for " { $link define-slots } " where each slot is named by an element of " { $snippet "slots" } " prefixed by the name of the class. Slots are numbered consecutively starting from " { $snippet "base" } ". Reader and writer words are defined in the current vocabulary, with the reader word having the same name as the slot, and the writer word name prefixed by " { $snippet "\"set-\"" } "." }
-{ $notes "This word is used by " { $link define-tuple-class } " and " { $link POSTPONE: TUPLE: } "." } ;
-
HELP: slot ( obj m -- value )
{ $values { "obj" object } { "m" "a non-negative fixnum" } { "value" object } }
{ $description "Reads the object stored at the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
{ $description "Writes " { $snippet "value" } " to the " { $snippet "n" } "th slot of " { $snippet "obj" } "." }
{ $warning "This word is in the " { $vocab-link "slots.private" } " vocabulary because it does not perform type or bounds checks, and slot numbers are implementation detail." } ;
-HELP: slot-of-reader
-{ $values { "reader" slot-reader } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
-{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-reader } " is equal to " { $snippet "reader" } "." } ;
-
-HELP: slot-of-writer
-{ $values { "writer" slot-writer } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
-{ $description "Outputs the " { $link slot-spec } " whose " { $link slot-spec-writer } " is equal to " { $snippet "writer" } "." } ;
-
-HELP: reader-word
-{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
-{ $description "Creates a word named " { $snippet { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;
-
-HELP: writer-word
-{ $values { "class" string } { "name" string } { "vocab" string } { "word" word } }
-{ $description "Creates a word named " { $snippet "set-" { $emphasis "class" } "-" { $emphasis "name" } } " in the " { $snippet "vocab" } " vocabulary." } ;
+HELP: slot-named
+{ $values { "name" string } { "specs" "a sequence of " { $link slot-spec } " instances" } { "spec/f" "a " { $link slot-spec } " or " { $link f } } }
+{ $description "Outputs the " { $link slot-spec } " with the given name." } ;
>r create-method r> define ;
: define-slot-word ( class slot word quot -- )
- rot >fixnum add* define-typecheck ;
-
-: reader-effect ( class spec -- effect )
- >r ?word-name 1array r> slot-spec-name 1array <effect> ;
+ rot >fixnum prefix define-typecheck ;
: reader-quot ( decl -- quot )
[
[ drop ] [ 1array , \ declare , ] if
] [ ] make ;
-PREDICATE: word slot-reader "reading" word-prop >boolean ;
-
-: set-reader-props ( class spec -- )
- 2dup reader-effect
- over slot-spec-reader
- swap "declared-effect" set-word-prop
- slot-spec-reader swap "reading" set-word-prop ;
-
-: define-reader ( class spec -- )
- dup slot-spec-reader [
- [ set-reader-props ] 2keep
- dup slot-spec-offset
- over slot-spec-reader
- rot slot-spec-type reader-quot
- define-slot-word
- ] [
- 2drop
- ] if ;
-
-: writer-effect ( class spec -- effect )
- slot-spec-name swap ?word-name 2array 0 <effect> ;
-
-PREDICATE: word slot-writer "writing" word-prop >boolean ;
-
-: set-writer-props ( class spec -- )
- 2dup writer-effect
- over slot-spec-writer
- swap "declared-effect" set-word-prop
- slot-spec-writer swap "writing" set-word-prop ;
-
-: define-writer ( class spec -- )
- dup slot-spec-writer [
- [ set-writer-props ] 2keep
- dup slot-spec-offset
- swap slot-spec-writer
- [ set-slot ]
- define-slot-word
- ] [
- 2drop
- ] if ;
-
-: define-slot ( class spec -- )
- 2dup define-reader define-writer ;
-
-: define-slots ( class specs -- )
- [ define-slot ] with each ;
-
-: reader-word ( class name vocab -- word )
- >r >r "-" r> 3append r> create ;
-
-: writer-word ( class name vocab -- word )
- >r [ swap "set-" % % "-" % % ] "" make r> create ;
-
-: (simple-slot-word) ( class name -- class name vocab )
- over word-vocabulary >r >r word-name r> r> ;
-
-: simple-reader-word ( class name -- word )
- (simple-slot-word) reader-word ;
-
-: simple-writer-word ( class name -- word )
- (simple-slot-word) writer-word ;
-
-: short-slot ( class name # -- spec )
- >r object bootstrap-word over r> f f <slot-spec>
- 2over simple-reader-word over set-slot-spec-reader
- -rot simple-writer-word over set-slot-spec-writer ;
-
-: long-slot ( spec # -- spec )
- >r [ dup array? [ first2 create ] when ] map first4 r>
- -rot <slot-spec> ;
-
-: simple-slots ( class slots base -- specs )
- over length [ + ] with map [
- {
- { [ over not ] [ 2drop f ] }
- { [ over string? ] [ >r dupd r> short-slot ] }
- { [ over array? ] [ long-slot ] }
- } cond
- ] 2map [ ] subset nip ;
-
-: slot-of-reader ( reader specs -- spec/f )
- [ slot-spec-reader eq? ] with find nip ;
-
-: slot-of-writer ( writer specs -- spec/f )
- [ slot-spec-writer eq? ] with find nip ;
-
-: slot-named ( string specs -- spec/f )
+: create-accessor ( name effect -- word )
+ >r "accessors" create dup r>
+ "declared-effect" set-word-prop ;
+
+: reader-effect T{ effect f { "object" } { "value" } } ; inline
+
+: reader-word ( name -- word )
+ ">>" append reader-effect create-accessor ;
+
+: define-reader ( class slot name -- )
+ reader-word object reader-quot define-slot-word ;
+
+: writer-effect T{ effect f { "value" "object" } { } } ; inline
+
+: writer-word ( name -- word )
+ "(>>" swap ")" 3append writer-effect create-accessor ;
+
+: define-writer ( class slot name -- )
+ writer-word [ set-slot ] define-slot-word ;
+
+: setter-effect T{ effect f { "object" "value" } { "object" } } ; inline
+
+: setter-word ( name -- word )
+ ">>" prepend setter-effect create-accessor ;
+
+: define-setter ( name -- )
+ dup setter-word dup deferred? [
+ [ \ over , swap writer-word , ] [ ] make define-inline
+ ] [ 2drop ] if ;
+
+: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
+
+: changer-word ( name -- word )
+ "change-" prepend changer-effect create-accessor ;
+
+: define-changer ( name -- )
+ dup changer-word dup deferred? [
+ [
+ [ over >r >r ] %
+ over reader-word ,
+ [ r> call r> swap ] %
+ swap setter-word ,
+ ] [ ] make define-inline
+ ] [ 2drop ] if ;
+
+: define-slot-methods ( class slot name -- )
+ dup define-changer
+ dup define-setter
+ 3dup define-reader
+ define-writer ;
+
+: define-accessors ( class specs -- )
+ [
+ dup slot-spec-offset swap slot-spec-name
+ define-slot-methods
+ ] with each ;
+
+: slot-named ( name specs -- spec/f )
[ slot-spec-name = ] with find nip ;
] if ; inline
: merge ( sorted1 sorted2 quot -- result )
- >r [ [ <iterator> ] 2apply ] 2keep r>
+ >r [ [ <iterator> ] bi@ ] 2keep r>
rot length rot length + <vector>
[ (merge) ] keep underlying ; inline
prettyprint sequences strings vectors words quotations inspector
io.styles io combinators sorting splitting math.parser effects
continuations debugger io.files io.crc32 vocabs hashtables
-graphs compiler.units io.encodings.utf8 ;
+graphs compiler.units io.encodings.utf8 accessors ;
IN: source-files
SYMBOL: source-files
: reset-checksums ( -- )
source-files get [
- swap ?resource-path dup exists? [
+ swap dup exists? [
utf8 file-lines swap record-checksum
] [ 2drop ] if
] assoc-each ;
M: pathname where pathname-string 1 2array ;
: forget-source ( path -- )
- dup source-file
- dup unxref-source
- source-file-definitions [ keys forget-all ] each
- source-files get delete-at ;
+ [
+ source-file
+ [ unxref-source ]
+ [ definitions>> [ keys forget-all ] each ]
+ bi
+ ]
+ [ source-files get delete-at ]
+ bi ;
M: pathname forget*
pathname-string forget-source ;
: rollback-source-file ( file -- )
- dup source-file-definitions new-definitions get [ union ] 2map
+ dup source-file-definitions new-definitions get [ assoc-union ] 2map
swap set-source-file-definitions ;
SYMBOL: file
source-file-definitions old-definitions set
[ ] [ file get rollback-source-file ] cleanup
] with-scope ; inline
-
-: outside-usages ( seq -- usages )
- dup [
- over usage
- [ dup pathname? not swap where and ] subset seq-diff
- ] curry { } map>assoc ;
-USING: splitting tools.test ;
+USING: splitting tools.test kernel sequences arrays ;
IN: splitting.tests
[ { 1 2 3 } 0 group ] must-fail
[ { "hello" "hi" } ] [ "hello\nhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\rhi" string-lines ] unit-test
[ { "hello" "hi" } ] [ "hello\r\nhi" string-lines ] unit-test
+
+[ { V{ "a" "b" } V{ f f } } ] [
+ V{ "a" "b" } clone 2 <groups>
+ 2 over set-length
+ >array
+] unit-test
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math namespaces strings arrays vectors sequences ;
+USING: kernel math namespaces strings arrays vectors sequences
+sets ;
IN: splitting
TUPLE: groups seq n sliced? ;
: check-groups 0 <= [ "Invalid group count" throw ] when ;
: <groups> ( seq n -- groups )
- dup check-groups f groups construct-boa ; inline
+ dup check-groups f groups boa ; inline
: <sliced-groups> ( seq n -- groups )
<groups> t over set-groups-sliced? ;
dup groups-seq length swap groups-n [ + 1- ] keep /i ;
M: groups set-length
- [ groups-n * ] keep delegate set-length ;
+ [ groups-n * ] keep groups-seq set-length ;
: group@ ( n groups -- from to seq )
[ groups-n [ * dup ] keep + ] keep
] if ;
: last-split1 ( seq subseq -- before after )
- [ <reversed> ] 2apply split1 [ reverse ] 2apply
+ [ <reversed> ] bi@ split1 [ reverse ] bi@
dup [ swap ] when ;
: (split) ( separators n seq -- )
: split ( seq separators -- pieces ) [ split, ] { } make ;
: string-lines ( str -- seq )
- dup "\r\n" seq-intersect empty? [
+ dup "\r\n" intersect empty? [
1array
] [
"\n" split [
1 head-slice* [
"\r" ?tail drop "\r" split
] map
- ] keep peek "\r" split add concat
+ ] keep peek "\r" split suffix concat
] if ;
-USING: continuations kernel math namespaces strings sbufs
-tools.test sequences vectors arrays ;
+USING: continuations kernel math namespaces strings
+strings.private sbufs tools.test sequences vectors arrays memory
+prettyprint io.streams.null ;
IN: strings.tests
[ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test
"\udeadbe" clone
CHAR: \u123456 over clone set-first
] unit-test
+
+! Regressions
+[ ] [
+ [
+ 4 [
+ 100 [ drop "obdurak" clone ] map
+ gc
+ dup [
+ 1234 0 rot set-string-nth
+ ] each
+ 1000 [
+ 1000 f <array> drop
+ ] times
+ .
+ ] times
+ ] with-null-stream
+] unit-test
+
+[ t ] [
+ 10000 [
+ drop
+ 300 100 CHAR: \u123456
+ [ <string> clone resize-string first ] keep =
+ ] all?
+] unit-test
: >string ( seq -- str ) "" clone-like ;
-M: string new drop 0 <string> ;
+M: string new-sequence drop 0 <string> ;
INSTANCE: string sequence
USING: generic help.syntax help.markup kernel math parser words
-effects classes generic.standard tuples generic.math arrays
-io.files vocabs.loader io sequences assocs ;
+effects classes generic.standard classes.tuple generic.math
+generic.standard arrays io.files vocabs.loader io sequences
+assocs ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"
{ $subsection POSTPONE: B{ }
"Byte arrays are documented in " { $link "byte-arrays" } "." ;
-ARTICLE: "syntax-bit-vectors" "Bit vector syntax"
-{ $subsection POSTPONE: ?V{ }
-"Bit vectors are documented in " { $link "bit-vectors" } "." ;
-
-ARTICLE: "syntax-float-vectors" "Float vector syntax"
-{ $subsection POSTPONE: FV{ }
-"Float vectors are documented in " { $link "float-vectors" } "." ;
-
-ARTICLE: "syntax-byte-vectors" "Byte vector syntax"
-{ $subsection POSTPONE: BV{ }
-"Byte vectors are documented in " { $link "byte-vectors" } "." ;
-
ARTICLE: "syntax-pathnames" "Pathname syntax"
{ $subsection POSTPONE: P" }
"Pathnames are documented in " { $link "pathnames" } "." ;
{ $subsection "syntax-float-arrays" }
{ $subsection "syntax-vectors" }
{ $subsection "syntax-sbufs" }
-{ $subsection "syntax-bit-vectors" }
-{ $subsection "syntax-byte-vectors" }
-{ $subsection "syntax-float-vectors" }
{ $subsection "syntax-hashtables" }
{ $subsection "syntax-tuples" }
{ $subsection "syntax-pathnames" } ;
}
"The last restriction ensures that words such as " { $link clone } " do not satisfy the foldable word contract. Indeed, " { $link clone } " will output a mutable object if its input is mutable, and so it is undesirable to evaluate it at compile-time, since doing so would give incorrect semantics for code that clones mutable objects and proceeds to mutate them."
}
+{ $notes
+ "Folding optimizations are not applied if the call site of a word is in the same source file as the word. This is a side-effect of the compilation unit system; see " { $link "compilation-units" } "."
+}
{ $examples "Most operations on numbers are foldable. For example, " { $snippet "2 2 +" } " compiles to a literal 4, since " { $link + } " is declared foldable." } ;
HELP: flushable
HELP: t
{ $syntax "t" }
{ $values { "t" "the canonical truth value" } }
-{ $description "The canonical instance of " { $link general-t } ". It is just a symbol." } ;
+{ $class-description "The canonical truth value, which is an instance of itself." } ;
HELP: f
{ $syntax "f" }
{ $description "Marks the beginning of a literal byte array. Literal byte arrays are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "B{ 1 2 3 }" } } ;
-HELP: BV{
-{ $syntax "BV{ elements... }" }
-{ $values { "elements" "a list of bytes" } }
-{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." }
-{ $examples { $code "BV{ 1 2 3 12 }" } } ;
-
HELP: ?{
{ $syntax "?{ elements... }" }
{ $values { "elements" "a list of booleans" } }
{ $description "Marks the beginning of a literal bit array. Literal bit arrays are terminated by " { $link POSTPONE: } } "." }
{ $examples { $code "?{ t f t }" } } ;
-HELP: ?V{
-{ $syntax "?V{ elements... }" }
-{ $values { "elements" "a list of booleans" } }
-{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." }
-{ $examples { $code "?V{ t f t }" } } ;
-
-HELP: FV{
-{ $syntax "FV{ elements... }" }
-{ $values { "elements" "a list of real numbers" } }
-{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." }
-{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;
-
HELP: F{
{ $syntax "F{ elements... }" }
{ $values { "elements" "a list of real numbers" } }
{ $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ;
HELP: T{
-{ $syntax "T{ class delegate slots... }" }
-{ $values { "class" "a tuple class word" } { "delegate" "a delegate" } { "slots" "list of objects" } }
+{ $syntax "T{ class slots... }" }
+{ $values { "class" "a tuple class word" } { "slots" "list of objects" } }
{ $description "Marks the beginning of a literal tuple. Literal tuples are terminated by " { $link POSTPONE: } } "."
$nl
"The class word must always be specified. If an insufficient number of values is given after the class word, the remaining slots of the tuple are set to " { $link f } ". If too many values are given, they are ignored." } ;
{ $description "Makes " { $snippet "instance" } " an instance of " { $snippet "mixin" } "." } ;
HELP: PREDICATE:
-{ $syntax "PREDICATE: superclass class predicate... ;" }
-{ $values { "superclass" "an existing class word" } { "class" "a new class word to define" } { "predicate" "membership test with stack effect " { $snippet "( superclass -- ? )" } } }
+{ $syntax "PREDICATE: class < superclass predicate... ;" }
+{ $values { "class" "a new class word to define" } { "superclass" "an existing class word" } { "predicate" "membership test with stack effect " { $snippet "( superclass -- ? )" } } }
{ $description
"Defines a predicate class deriving from " { $snippet "superclass" } "."
$nl
} ;
HELP: TUPLE:
-{ $syntax "TUPLE: class slots... ;" }
+{ $syntax "TUPLE: class slots... ;" "TUPLE: class < superclass slots ... ;" }
{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
-{ $description "Defines a new tuple class with membership predicate " { $snippet "name?" } "."
-$nl
-"Tuples are user-defined classes with instances composed of named slots. All tuple classes are subtypes of the built-in " { $link tuple } " type." } ;
+{ $description "Defines a new tuple class. The superclass is optional; if left unspecified, it defaults to " { $link tuple } "." } ;
+
+HELP: ERROR:
+{ $syntax "ERROR: class slots... ;" }
+{ $values { "class" "a new tuple class to define" } { "slots" "a list of slot names" } }
+{ $description "Defines a new tuple class whose class word throws a new instance of the error." }
+{ $notes
+ "The following two snippets are equivalent:"
+ { $code
+ "ERROR: invalid-values x y ;"
+ ""
+ "TUPLE: invalid-values x y ;"
+ ": invalid-values ( x y -- * )"
+ " \\ invalid-values boa throw ;"
+ }
+} ;
HELP: C:
{ $syntax "C: constructor class" }
{ $values { "constructor" "a new word to define" } { "class" tuple-class } }
-{ $description "Define a constructor word for a tuple class which simply performs BOA (by order of arguments) construction using " { $link construct-boa } "." }
+{ $description "Define a constructor word for a tuple class which simply performs BOA (by order of arguments) construction using " { $link boa } "." }
{ $examples
"Suppose the following tuple has been defined:"
{ $code "TUPLE: color red green blue ;" }
"The following two lines are equivalent:"
{ $code
"C: <color> color"
- ": <color> color construct-boa ;"
+ ": <color> color boa ;"
}
"In both cases, a word " { $snippet "<color>" } " is defined, which reads three values from the stack and creates a " { $snippet "color" } " instance having these values in the " { $snippet "red" } ", " { $snippet "green" } " and " { $snippet "blue" } " slots, respectively."
} ;
{ $syntax ">>" }
{ $description "Marks the end of a parse time code block." } ;
+HELP: call-next-method
+{ $description "Calls the next applicable method. Only valid inside a method definition. The values at the top of the stack are passed on to the next method, and they must be compatible with that method's class specializer." }
+{ $notes "This is syntax sugar around " { $link (call-next-method) } ". The following two lines are equivalent:"
+ { $code
+ "M: my-class my-generic ... call-next-method ... ;"
+ "M: my-class my-generic ... \\ my-class \\ my-generic (call-next-method) ... ;"
+ }
+"In most cases, this word should be called with the original input values on the stack. Calling it with other values is usually a sign of poor design." }
+{ $errors
+ "Throws a " { $link no-next-method } " error if this is the least specific method, and throws an " { $link inconsistent-next-method } " error if the values at the top of the stack are not compatible with the current method's specializer."
+} ;
+
+{ POSTPONE: call-next-method (call-next-method) next-method } related-words
+
{ POSTPONE: << POSTPONE: >> } related-words
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays bit-arrays bit-vectors byte-arrays
-byte-vectors definitions generic hashtables kernel math
+USING: alien arrays bit-arrays byte-arrays
+definitions generic hashtables kernel math
namespaces parser sequences strings sbufs vectors words
-quotations io assocs splitting tuples generic.standard
-generic.math classes io.files vocabs float-arrays float-vectors
-classes.union classes.mixin classes.predicate compiler.units
-combinators ;
+quotations io assocs splitting classes.tuple generic.standard
+generic.math classes io.files vocabs float-arrays
+classes.union classes.mixin classes.predicate classes.singleton
+compiler.units combinators debugger ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
"BIN:" [ 2 parse-base ] define-syntax
"f" [ f parsed ] define-syntax
- "t" "syntax" lookup define-symbol
+ "t" "syntax" lookup define-singleton-class
"CHAR:" [
scan {
{ [ dup length 1 = ] [ first ] }
{ [ "\\" ?head ] [ next-escape drop ] }
- { [ t ] [ name>char-hook get call ] }
+ [ name>char-hook get call ]
} cond parsed
] define-syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
- "BV{" [ \ } [ >byte-vector ] parse-literal ] define-syntax
"?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
- "?V{" [ \ } [ >bit-vector ] parse-literal ] define-syntax
"F{" [ \ } [ >float-array ] parse-literal ] define-syntax
- "FV{" [ \ } [ >float-vector ] parse-literal ] define-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
"T{" [ \ } [ >tuple ] parse-literal ] define-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
] define-syntax
"PREDICATE:" [
- scan-word
CREATE-CLASS
+ scan "<" assert=
+ scan-word
parse-definition define-predicate-class
] define-syntax
+ "SINGLETON:" [
+ scan create-class-in
+ dup save-location define-singleton-class
+ ] define-syntax
+
"TUPLE:" [
- CREATE-CLASS ";" parse-tokens define-tuple-class
+ parse-tuple-definition define-tuple-class
] define-syntax
"C:" [
CREATE-WORD
scan-word dup check-tuple
- [ construct-boa ] curry define-inline
+ [ boa ] curry define-inline
+ ] define-syntax
+
+ "ERROR:" [
+ parse-tuple-definition
+ pick save-location
+ define-error-class
] define-syntax
"FORGET:" [
- scan-word
- dup parsing? [ V{ } clone swap execute first ] when
- forget
+ scan-object forget
] define-syntax
"(" [
[ \ >> parse-until >quotation ] with-compilation-unit
call
] define-syntax
+
+ "call-next-method" [
+ current-class get literalize parsed
+ current-generic get literalize parsed
+ \ (call-next-method) parsed
+ ] define-syntax
] with-compilation-unit
USING: generic help.markup help.syntax kernel math memory
-namespaces sequences kernel.private strings ;
+namespaces sequences kernel.private strings classes.singleton ;
IN: system
-ARTICLE: "os" "System interface"
-"Operating system detection:"
-{ $subsection os }
-{ $subsection unix? }
-{ $subsection macosx? }
-{ $subsection solaris? }
-{ $subsection windows? }
-{ $subsection winnt? }
-{ $subsection win32? }
-{ $subsection win64? }
-{ $subsection wince? }
-"Processor detection:"
-{ $subsection cpu }
-"Reading environment variables:"
-{ $subsection os-env }
-{ $subsection os-envs }
+ABOUT: "system"
+
+ARTICLE: "system" "System interface"
+{ $subsection "cpu" }
+{ $subsection "os" }
+{ $subsection "environment-variables" }
"Getting the path to the Factor VM and image:"
{ $subsection vm }
{ $subsection image }
{ $subsection exit }
{ $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ;
-ABOUT: "os"
+ARTICLE: "environment-variables" "Environment variables"
+"Reading environment variables:"
+{ $subsection os-env }
+{ $subsection os-envs }
+"Writing environment variables:"
+{ $subsection set-os-env }
+{ $subsection unset-os-env }
+{ $subsection set-os-envs } ;
+
+ARTICLE: "cpu" "Processor detection"
+"Processor detection:"
+{ $subsection cpu }
+"Supported processors:"
+{ $subsection x86.32 }
+{ $subsection x86.64 }
+{ $subsection ppc }
+{ $subsection arm }
+"Processor families:"
+{ $subsection x86 } ;
+
+ARTICLE: "os" "Operating system detection"
+"Operating system detection:"
+{ $subsection os }
+"Supported operating systems:"
+{ $subsection freebsd }
+{ $subsection linux }
+{ $subsection macosx }
+{ $subsection openbsd }
+{ $subsection netbsd }
+{ $subsection solaris }
+{ $subsection wince }
+{ $subsection winnt }
+"Operating system families:"
+{ $subsection bsd }
+{ $subsection unix }
+{ $subsection windows } ;
+
HELP: cpu
-{ $values { "cpu" string } }
+{ $values { "class" singleton-class } }
{ $description
- "Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:"
- { $code "x86.32" "x86.64" "ppc" "arm" }
+ "Outputs a singleton class with the name of the current CPU architecture."
} ;
HELP: os
-{ $values { "os" string } }
+{ $values { "class" singleton-class } }
{ $description
- "Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:"
- { $code
- "freebsd"
- "linux"
- "macosx"
- "openbsd"
- "netbsd"
- "solaris"
- "wince"
- "winnt"
- }
+ "Outputs a singleton class with the name of the current operating system family."
} ;
HELP: embedded?
{ $values { "?" "a boolean" } }
{ $description "Tests if this Factor instance is embedded in another application." } ;
-HELP: windows?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows." } ;
-
-HELP: winnt?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows XP or Vista." } ;
-
-HELP: wince?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows CE." } ;
-
-HELP: macosx?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Mac OS X." } ;
-
-HELP: linux?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Linux." } ;
-
-HELP: solaris?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Solaris." } ;
-
-HELP: bsd?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on FreeBSD/OpenBSD/NetBSD." } ;
-
HELP: exit ( n -- )
{ $values { "n" "an integer exit code" } }
{ $description "Exits the Factor process." } ;
{ $values { "assoc" "an association mapping strings to strings" } }
{ $description "Replaces the current set of environment variables." }
{ $notes
- "Names and values of environment variables are operating system-specific."
+ "Names and values of environment variables are operating system-specific. Windows NT allows values up to 32766 characters in length."
}
{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-{ os-env os-envs set-os-envs } related-words
+HELP: set-os-env ( value key -- )
+{ $values { "value" string } { "key" string } }
+{ $description "Set an environment variable." }
+{ $notes
+ "Names and values of environment variables are operating system-specific."
+}
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-HELP: win32?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on 32-bit Windows." } ;
+HELP: unset-os-env ( key -- )
+{ $values { "key" string } }
+{ $description "Unset an environment variable." }
+{ $notes
+ "Names and values of environment variables are operating system-specific."
+}
+{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ;
-HELP: win64?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on 64-bit Windows." } ;
+{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words
HELP: image
{ $values { "path" "a pathname string" } }
HELP: vm
{ $values { "path" "a pathname string" } }
{ $description "Outputs the pathname of the currently running Factor VM." } ;
-
-HELP: unix?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ;
-USING: math tools.test system prettyprint namespaces kernel ;
+USING: math tools.test system prettyprint namespaces kernel
+strings sequences ;
IN: system.tests
-wince? [
+os wince? [
[ ] [ os-envs . ] unit-test
] unless
-unix? [
+os unix? [
[ ] [ os-envs "envs" set ] unit-test
[ ] [ { { "A" "B" } } set-os-envs ] unit-test
[ "B" ] [ "A" os-env ] unit-test
[ ] [ "envs" get set-os-envs ] unit-test
[ t ] [ os-envs "envs" get = ] unit-test
] when
+
+[ ] [ "factor-test-key-1" unset-os-env ] unit-test
+[ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test
+[ "ps3" ] [ "factor-test-key-1" os-env ] unit-test
+[ ] [ "factor-test-key-1" unset-os-env ] unit-test
+[ f ] [ "factor-test-key-1" os-env ] unit-test
+
+[ ] [
+ 32766 CHAR: a <string> "factor-test-key-long" set-os-env
+] unit-test
+[ 32766 ] [ "factor-test-key-long" os-env length ] unit-test
+[ ] [ "factor-test-key-long" unset-os-env ] unit-test
! See http://factorcode.org/license.txt for BSD license.
IN: system
USING: kernel kernel.private sequences math namespaces
-splitting assocs system.private layouts ;
+init splitting assocs system.private layouts words ;
-: cpu ( -- cpu ) 8 getenv ; foldable
+SINGLETON: x86.32
+SINGLETON: x86.64
+SINGLETON: arm
+SINGLETON: ppc
-: os ( -- os ) 9 getenv ; foldable
+UNION: x86 x86.32 x86.64 ;
-: image ( -- path ) 13 getenv ;
+: cpu ( -- class ) \ cpu get ;
-: vm ( -- path ) 14 getenv ;
+SINGLETON: winnt
+SINGLETON: wince
-: wince? ( -- ? )
- os "wince" = ; foldable
+UNION: windows winnt wince ;
-: winnt? ( -- ? )
- os "winnt" = ; foldable
+SINGLETON: freebsd
+SINGLETON: netbsd
+SINGLETON: openbsd
+SINGLETON: solaris
+SINGLETON: macosx
+SINGLETON: linux
-: windows? ( -- ? )
- wince? winnt? or ; foldable
+UNION: bsd freebsd netbsd openbsd macosx ;
-: win32? ( -- ? )
- winnt? cell 4 = and ; foldable
+UNION: unix bsd solaris linux ;
-: win64? ( -- ? )
- winnt? cell 8 = and ; foldable
+: os ( -- class ) \ os get ;
-: macosx? ( -- ? ) os "macosx" = ; foldable
+<PRIVATE
-: embedded? ( -- ? ) 15 getenv ;
+: string>cpu ( str -- class )
+ H{
+ { "x86.32" x86.32 }
+ { "x86.64" x86.64 }
+ { "arm" arm }
+ { "ppc" ppc }
+ } at ;
+
+: string>os ( str -- class )
+ H{
+ { "winnt" winnt }
+ { "wince" wince }
+ { "freebsd" freebsd }
+ { "netbsd" netbsd }
+ { "openbsd" openbsd }
+ { "solaris" solaris }
+ { "macosx" macosx }
+ { "linux" linux }
+ } at ;
-: unix? ( -- ? )
- os {
- "freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris"
- } member? ;
+PRIVATE>
-: bsd? ( -- ? )
- os { "freebsd" "openbsd" "netbsd" "macosx" } member? ;
+[
+ 8 getenv string>cpu \ cpu set-global
+ 9 getenv string>os \ os set-global
+] "system" add-init-hook
-: linux? ( -- ? )
- os "linux" = ;
+: image ( -- path ) 13 getenv ;
+
+: vm ( -- path ) 14 getenv ;
-: solaris? ( -- ? )
- os "solaris" = ;
+: embedded? ( -- ? ) 15 getenv ;
: os-envs ( -- assoc )
(os-envs) [ "=" split1 ] H{ } map>assoc ;
{ $subsection resume }
{ $subsection resume-with } ;
-ARTICLE: "thread-state" "Thread-local state"
+ARTICLE: "thread-state" "Thread-local state and variables"
"Threads form a class of objects:"
{ $subsection thread }
"The current thread:"
{ $subsection tget }
{ $subsection tset }
{ $subsection tchange }
+"Each thread has its own independent set of thread-local variables and newly-spawned threads begin with an empty set."
+$nl
"Global hashtable of all threads, keyed by " { $link thread-id } ":"
{ $subsection threads }
"Threads have an identity independent of continuations. If a continuation is refied in one thread and then resumed in another thread, the code running in that continuation will observe a change in the value output by " { $link self } "." ;
-USING: namespaces io tools.test threads kernel ;
+USING: namespaces io tools.test threads kernel
+concurrency.combinators math ;
IN: threads.tests
3 "x" set
] unit-test
[ f ] [ f get-global ] unit-test
+
+{ { 0 3 6 9 12 15 18 21 24 27 } } [
+ 10 [
+ 0 "i" tset
+ [
+ "i" [ yield 3 + ] tchange
+ ] times yield
+ "i" tget
+ ] parallel-map
+] unit-test
IN: threads
USING: arrays hashtables heaps kernel kernel.private math
namespaces sequences vectors continuations continuations.private
-dlists assocs system combinators init boxes ;
+dlists assocs system combinators init boxes accessors ;
SYMBOL: initial-thread
! Thread-local storage
: tnamespace ( -- assoc )
- self dup thread-variables
- [ ] [ H{ } clone dup rot set-thread-variables ] ?if ;
+ self variables>> [ H{ } clone dup self (>>variables) ] unless* ;
: tget ( key -- value )
- self thread-variables at ;
+ self variables>> at ;
: tset ( value key -- )
tnamespace set-at ;
: tchange ( key quot -- )
- tnamespace change-at ; inline
+ tnamespace swap change-at ; inline
: threads 41 getenv ;
: thread ( id -- thread ) threads at ;
: thread-registered? ( thread -- ? )
- thread-id threads key? ;
+ id>> threads key? ;
: check-unregistered
dup thread-registered?
<PRIVATE
: register-thread ( thread -- )
- check-unregistered dup thread-id threads set-at ;
+ check-unregistered dup id>> threads set-at ;
: unregister-thread ( thread -- )
- check-registered thread-id threads delete-at ;
+ check-registered id>> threads delete-at ;
: set-self ( thread -- ) 40 setenv ; inline
PRIVATE>
+: new-thread ( quot name class -- thread )
+ new
+ swap >>name
+ swap >>quot
+ \ thread counter >>id
+ <box> >>continuation
+ [ ] >>exit-handler ; inline
+
: <thread> ( quot name -- thread )
- \ thread counter <box> [ ] {
- set-thread-quot
- set-thread-name
- set-thread-id
- set-thread-continuation
- set-thread-exit-handler
- } \ thread construct ;
+ \ thread new-thread ;
: run-queue 42 getenv ;
: sleep-queue 43 getenv ;
: resume ( thread -- )
- f over set-thread-state
+ f >>state
check-registered run-queue push-front ;
: resume-now ( thread -- )
- f over set-thread-state
+ f >>state
check-registered run-queue push-back ;
: resume-with ( obj thread -- )
- f over set-thread-state
+ f >>state
check-registered 2array run-queue push-front ;
: sleep-time ( -- ms/f )
{
{ [ run-queue dlist-empty? not ] [ 0 ] }
{ [ sleep-queue heap-empty? ] [ f ] }
- { [ t ] [ sleep-queue heap-peek nip millis [-] ] }
+ [ sleep-queue heap-peek nip millis [-] ]
} cond ;
<PRIVATE
: schedule-sleep ( thread ms -- )
>r check-registered dup r> sleep-queue heap-push*
- swap set-thread-sleep-entry ;
+ >>sleep-entry drop ;
: expire-sleep? ( heap -- ? )
dup heap-empty?
[ drop f ] [ heap-peek nip millis <= ] if ;
: expire-sleep ( thread -- )
- f over set-thread-sleep-entry resume ;
+ f >>sleep-entry resume ;
: expire-sleep-loop ( -- )
sleep-queue
] [
pop-back
dup array? [ first2 ] [ f swap ] if dup set-self
- f over set-thread-state
- thread-continuation box>
+ f >>state
+ continuation>> box>
continue-with
] if ;
PRIVATE>
: stop ( -- )
- self dup thread-exit-handler call
+ self dup exit-handler>> call
unregister-thread next ;
: suspend ( quot state -- obj )
[
- self thread-continuation >box
- self set-thread-state
+ self continuation>> >box
+ self (>>state)
self swap call next
] callcc1 2nip ; inline
millis + >integer sleep-until ;
: interrupt ( thread -- )
- dup thread-state [
- dup thread-sleep-entry [ sleep-queue heap-delete ] when*
- f over set-thread-sleep-entry
+ dup state>> [
+ dup sleep-entry>> [ sleep-queue heap-delete ] when*
+ f >>sleep-entry
dup resume
] when drop ;
V{ } set-catchstack
{ } set-retainstack
>r { } set-datastack r>
- thread-quot [ call stop ] call-clear
+ quot>> [ call stop ] call-clear
] 1 (throw)
] "spawn" suspend 2drop ;
<min-heap> 43 setenv
initial-thread global
[ drop f "Initial" <thread> ] cache
- <box> over set-thread-continuation
- f over set-thread-state
+ <box> >>continuation
+ f >>state
dup register-thread
set-self ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Object system implementation
+++ /dev/null
-USING: generic help.markup help.syntax kernel
-tuples.private classes slots quotations words arrays
-generic.standard sequences definitions compiler.units ;
-IN: tuples
-
-ARTICLE: "tuple-constructors" "Constructors and slots"
-"Tuples are created by calling one of a number of words:"
-{ $subsection construct-empty }
-{ $subsection construct-boa }
-{ $subsection construct }
-"By convention, construction logic is encapsulated in a word named after the tuple class surrounded in angle brackets; for example, the constructor word for a " { $snippet "point" } " class might be named " { $snippet "<point>" } "."
-$nl
-"A shortcut for defining BOA constructors:"
-{ $subsection POSTPONE: C: }
-"Examples of constructors:"
-{ $code
- "TUPLE: color red green blue alpha ;"
- ""
- "C: <rgba> rgba"
- ": <rgba> color construct-boa ; ! identical to above"
- ""
- ": <rgb>"
- " { set-color-red set-color-green set-color-blue }"
- " color construct ;"
- ": <rgb> f <rgba> ; ! identical to above"
- ""
- ": <color> construct-empty ;"
- ": <color> { } color construct ; ! identical to above"
- ": <color> f f f f <rgba> ; ! identical to above"
-}
-"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
-
-ARTICLE: "tuple-delegation" "Delegation"
-"If a generic word having the " { $link standard-combination } " method combination is called on a tuple for which it does not have an applicable method, the method call is forwarded to the tuple's " { $emphasis "delegate" } ". If no delegate is set, a " { $link no-method } " error is thrown."
-{ $subsection delegate }
-{ $subsection set-delegate }
-"A tuple's delegate should either be another tuple, or " { $link f } ", indicating no delegate is set. Delegation from a tuple to an object of some other type is not fully supported and should be used with caution."
-$nl
-"Factor uses delegation in place of implementation inheritance, but it is not a direct substitute; in particular, the semantics differ in that a delegated method call receives the delegate on the stack, not the original object."
-$nl
-"A pair of words examine delegation chains:"
-{ $subsection delegates }
-{ $subsection is? }
-"An example:"
-{ $example
- "TUPLE: ellipse center radius ;"
- "TUPLE: colored color ;"
- "{ 0 0 } 10 <ellipse> \"my-ellipse\" set"
- "{ 1 0 0 } <colored> \"my-shape\" set"
- "\"my-ellipse\" get \"my-shape\" get set-delegate"
- "\"my-shape\" get dup colored-color swap ellipse-center .s"
- "{ 0 0 }\n{ 1 0 0 }"
-} ;
-
-ARTICLE: "tuple-introspection" "Tuple introspection"
-"In addition to the slot reader and writer words which " { $link POSTPONE: TUPLE: } " defines for every tuple class, it is possible to construct and take apart entire tuples in a generic way."
-{ $subsection >tuple }
-{ $subsection tuple>array }
-{ $subsection tuple-slots }
-"Tuple classes can also be defined at run time:"
-{ $subsection define-tuple-class } ;
-
-ARTICLE: "tuples" "Tuples"
-"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
-{ $subsection POSTPONE: TUPLE: }
-"An example:"
-{ $code "TUPLE: person name address phone ;" "C: <person> person" }
-"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
-{ $table
- { "Reader" "Writer" }
- { { $snippet "person-name" } { $snippet "set-person-name" } }
- { { $snippet "person-address" } { $snippet "set-person-address" } }
- { { $snippet "person-phone" } { $snippet "set-person-phone" } }
-}
-"Initially, no specific words are defined for constructing new instances of the tuple. Constructors must be defined explicitly:"
-{ $subsection "tuple-constructors" }
-"Further topics:"
-{ $subsection "tuple-delegation" }
-{ $subsection "tuple-introspection" } ;
-
-ABOUT: "tuples"
-
-HELP: delegate
-{ $values { "obj" object } { "delegate" object } }
-{ $description "Returns an object's delegate, or " { $link f } " if no delegate is set." }
-{ $notes "A direct consequence of this behavior is that an object may not have a delegate of " { $link f } "." } ;
-
-HELP: set-delegate
-{ $values { "delegate" object } { "tuple" tuple } }
-{ $description "Sets a tuple's delegate. Method calls not handled by the tuple's class will now be passed on to the delegate." } ;
-
-HELP: tuple=
-{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
-{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
-{ $warning "This word is in the " { $vocab-link "tuples.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
-
-HELP: tuple-class-eq?
-{ $values { "obj" object } { "class" tuple-class } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "obj" } " is an instance of " { $snippet "class" } "." } ;
-
-HELP: permutation
-{ $values { "seq1" sequence } { "seq2" sequence } { "permutation" "a sequence whose elements are integers or " { $link f } } }
-{ $description "Outputs a permutation for taking " { $snippet "seq1" } " to " { $snippet "seq2" } "." } ;
-
-HELP: reshape-tuple
-{ $values { "oldtuple" tuple } { "permutation" "a sequence whose elements are integers or " { $link f } } { "newtuple" tuple } }
-{ $description "Permutes the slots of a tuple. If a tuple class is redefined at runtime, this word is called on every instance to change its shape to conform to the new layout." } ;
-
-HELP: reshape-tuples
-{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } }
-{ $description "Changes the shape of every instance of " { $snippet "class" } " for a new slot layout." } ;
-
-HELP: old-slots
-{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } }
-{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ;
-
-HELP: forget-slots
-{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } }
-{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ;
-
-HELP: tuple
-{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
-$nl
-"Tuple classes have additional word properties:"
-{ $list
- { { $snippet "\"constructor\"" } " - a word for creating instances of this tuple class" }
- { { $snippet "\"predicate\"" } " - a quotation which tests if the top of the stack is an instance of this tuple class" }
- { { $snippet "\"slots\"" } " - a sequence of " { $link slot-spec } " instances" }
- { { $snippet "\"slot-names\"" } " - a sequence of strings naming the tuple's slots" }
- { { $snippet "\"tuple-size\"" } " - the number of slots" }
-} } ;
-
-HELP: define-tuple-predicate
-{ $values { "class" tuple-class } }
-{ $description "Defines a predicate word that tests if the top of the stack is an instance of " { $snippet "class" } ". This will only work if " { $snippet "class" } " is a tuple class." }
-$low-level-note ;
-
-HELP: check-shape
-{ $values { "class" class } { "newslots" "a sequence of strings" } }
-{ $description "If the new slot layout differs from the existing one, updates all existing instances of this tuple class, and forgets any slot accessor words which are no longer needed."
-$nl
-"If the class is not a tuple class word, this word does nothing." }
-$low-level-note ;
-
-HELP: tuple-slots
-{ $values { "tuple" tuple } { "seq" sequence } }
-{ $description "Pushes a sequence of tuple slot values, not including the tuple class word and delegate." } ;
-
-{ tuple-slots tuple>array } related-words
-
-HELP: define-tuple-slots
-{ $values { "class" tuple-class } { "slots" "a sequence of strings" } }
-{ $description "Defines slot accessor and mutator words for the tuple." }
-$low-level-note ;
-
-HELP: check-tuple
-{ $values { "class" class } }
-{ $description "Throws a " { $link check-tuple } " error if " { $snippet "word" } " is not a tuple class word." }
-{ $error-description "Thrown if " { $link POSTPONE: C: } " is called with a word which does not name a tuple class." } ;
-
-HELP: define-tuple-class
-{ $values { "class" word } { "slots" "a sequence of strings" } }
-{ $description "Defines a tuple class with slots named by " { $snippet "slots" } ". This is the run time equivalent of " { $link POSTPONE: TUPLE: } "." }
-{ $notes "This word must be called from inside " { $link with-compilation-unit } "." }
-{ $side-effects "class" } ;
-
-{ tuple-class define-tuple-class POSTPONE: TUPLE: } related-words
-
-HELP: delegates
-{ $values { "obj" object } { "seq" sequence } }
-{ $description "Outputs the delegation chain of an object. The first element of " { $snippet "seq" } " is " { $snippet "obj" } " itself. If " { $snippet "obj" } " is " { $link f } ", an empty sequence is output." } ;
-
-HELP: is?
-{ $values { "obj" object } { "quot" "a quotation with stack effect " { $snippet "( obj -- ? )" } } { "?" "a boolean" } }
-{ $description "Tests if the object or one of its delegates satisfies the predicate quotation."
-$nl
-"Class membership test predicates only test if an object is a direct instance of that class. Sometimes, you need to check delegates, since this gives a clearer picture of what operations the object supports." } ;
-
-HELP: >tuple
-{ $values { "seq" sequence } { "tuple" tuple } }
-{ $description "Creates a tuple with slot values taken from a sequence. The first element of the sequence must be a tuple class word, the second a delegate, and the remainder the declared slots."
-$nl
-"If the sequence has too many elements, they are ignored, and if it has too few, the remaining slots in the tuple are set to " { $link f } "." }
-{ $errors "Throws an error if the first element of the sequence is not a tuple class word." } ;
-
-HELP: tuple>array ( tuple -- array )
-{ $values { "tuple" tuple } { "array" array } }
-{ $description "Outputs an array having the tuple's slots as elements. The first element is the tuple class word and the second is the delegate; the remainder are declared slots." } ;
-
-HELP: <tuple> ( class n -- tuple )
-{ $values { "class" tuple-class } { "n" "a non-negative integer" } { "tuple" tuple } }
-{ $description "Low-level tuple constructor. User code should never call this directly, and instead use the constructor word which is defined for each tuple. See " { $link "tuples" } "." } ;
-
-HELP: construct-empty
-{ $values { "class" tuple-class } { "tuple" tuple } }
-{ $description "Creates a new instance of " { $snippet "class" } " with all slots initially set to " { $link f } "." }
-{ $examples
- { $example
- "USING: kernel prettyprint ;"
- "TUPLE: employee number name department ;"
- "employee construct-empty ."
- "T{ employee f f f f }"
- }
-} ;
-
-HELP: construct
-{ $values { "..." "slot values" } { "slots" "a sequence of setter words" } { "class" tuple-class } { "tuple" tuple } }
-{ $description "Creates a new instance of " { $snippet "class" } ", storing consecutive stack values into the slots of the new tuple using setter words in " { $snippet "slots" } ". The top-most stack element is stored in the right-most slot." }
-{ $examples
- "We can define a class:"
- { $code "TUPLE: color red green blue alpha ;" }
- "Together with two constructors:"
- { $code
- ": <rgb> ( r g b -- color )"
- " { set-color-red set-color-green set-color-blue }"
- " color construct ;"
- ""
- ": <rgba> ( r g b a -- color )"
- " { set-color-red set-color-green set-color-blue set-color-alpha }"
- " color construct ;"
- }
- "The last definition is actually equivalent to the following:"
- { $code ": <rgba> ( r g b a -- color ) rgba construct-boa ;" }
- "Which can be abbreviated further:"
- { $code "C: <rgba> color" }
-} ;
-
-HELP: construct-boa
-{ $values { "..." "slot values" } { "class" tuple-class } { "tuple" tuple } }
-{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
-{ $notes "The " { $snippet "-boa" } " suffix is shorthand for ``by order of arguments'', and ``BOA constructor'' is a pun on ``boa constrictor''." } ;
+++ /dev/null
-USING: definitions generic kernel kernel.private math
-math.constants parser sequences tools.test words assocs
-namespaces quotations sequences.private classes continuations
-generic.standard effects tuples tuples.private arrays vectors
-strings compiler.units ;
-IN: tuples.tests
-
-[ t ] [ \ tuple-class \ class class< ] unit-test
-[ f ] [ \ class \ tuple-class class< ] unit-test
-
-TUPLE: rect x y w h ;
-: <rect> rect construct-boa ;
-
-: move ( x rect -- )
- [ rect-x + ] keep set-rect-x ;
-
-[ f ] [ 10 20 30 40 <rect> dup clone 5 swap [ move ] keep = ] unit-test
-
-[ t ] [ 10 20 30 40 <rect> dup clone 0 swap [ move ] keep = ] unit-test
-
-GENERIC: delegation-test
-M: object delegation-test drop 3 ;
-TUPLE: quux-tuple ;
-: <quux-tuple> quux-tuple construct-empty ;
-M: quux-tuple delegation-test drop 4 ;
-TUPLE: quuux-tuple ;
-: <quuux-tuple> { set-delegate } quuux-tuple construct ;
-
-[ 3 ] [ <quux-tuple> <quuux-tuple> delegation-test ] unit-test
-
-GENERIC: delegation-test-2
-TUPLE: quux-tuple-2 ;
-: <quux-tuple-2> quux-tuple-2 construct-empty ;
-M: quux-tuple-2 delegation-test-2 drop 4 ;
-TUPLE: quuux-tuple-2 ;
-: <quuux-tuple-2> { set-delegate } quuux-tuple-2 construct ;
-
-[ 4 ] [ <quux-tuple-2> <quuux-tuple-2> delegation-test-2 ] unit-test
-
-! Make sure we handle changing shapes!
-TUPLE: point x y ;
-
-C: <point> point
-
-100 200 <point> "p" set
-
-! Use eval to sequence parsing explicitly
-"IN: tuples.tests TUPLE: point x y z ;" eval
-
-[ 100 ] [ "p" get point-x ] unit-test
-[ 200 ] [ "p" get point-y ] unit-test
-[ f ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
-
-300 "p" get "set-point-z" "tuples.tests" lookup execute
-
-"IN: tuples.tests TUPLE: point z y ;" eval
-
-[ "p" get point-x ] must-fail
-[ 200 ] [ "p" get point-y ] unit-test
-[ 300 ] [ "p" get "point-z" "tuples.tests" lookup execute ] unit-test
-
-TUPLE: predicate-test ;
-
-C: <predicate-test> predicate-test
-
-: predicate-test drop f ;
-
-[ t ] [ <predicate-test> predicate-test? ] unit-test
-
-PREDICATE: tuple silly-pred
- class \ rect = ;
-
-GENERIC: area
-M: silly-pred area dup rect-w swap rect-h * ;
-
-TUPLE: circle radius ;
-M: circle area circle-radius sq pi * ;
-
-[ 200 ] [ T{ rect f 0 0 10 20 } area ] unit-test
-
-! Hashcode breakage
-TUPLE: empty ;
-
-C: <empty> empty
-
-[ t ] [ <empty> hashcode fixnum? ] unit-test
-
-TUPLE: delegate-clone ;
-
-[ T{ delegate-clone T{ empty f } } ]
-[ T{ delegate-clone T{ empty f } } clone ] unit-test
-
-[ t ] [ \ null \ delegate-clone class< ] unit-test
-[ f ] [ \ object \ delegate-clone class< ] unit-test
-[ f ] [ \ object \ delegate-clone class< ] unit-test
-[ t ] [ \ delegate-clone \ tuple class< ] unit-test
-[ f ] [ \ tuple \ delegate-clone class< ] unit-test
-
-! Compiler regression
-[ t length ] [ no-method-object t eq? ] must-fail-with
-
-[ "<constructor-test>" ]
-[ "TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word word-name ] unit-test
-
-TUPLE: size-test a b c d ;
-
-[ t ] [
- T{ size-test } array-capacity
- size-test tuple-size =
-] unit-test
-
-GENERIC: <yo-momma>
-
-TUPLE: yo-momma ;
-
-"IN: tuples.tests C: <yo-momma> yo-momma" eval
-
-[ f ] [ \ <yo-momma> generic? ] unit-test
-
-! Test forget
-[
- [ t ] [ \ yo-momma class? ] unit-test
- [ ] [ \ yo-momma forget ] unit-test
- [ f ] [ \ yo-momma typemap get values memq? ] unit-test
-
- [ f ] [ \ yo-momma crossref get at ] unit-test
-] with-compilation-unit
-
-TUPLE: loc-recording ;
-
-[ f ] [ \ loc-recording where not ] unit-test
-
-! 'forget' wasn't robust enough
-
-TUPLE: forget-robustness ;
-
-GENERIC: forget-robustness-generic
-
-M: forget-robustness forget-robustness-generic ;
-
-M: integer forget-robustness-generic ;
-
-[
- [ ] [ \ forget-robustness-generic forget ] unit-test
- [ ] [ \ forget-robustness forget ] unit-test
- [ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test
-] with-compilation-unit
-
-! rapido found this one
-GENERIC# m1 0 ( s n -- n )
-GENERIC# m2 1 ( s n -- v )
-
-TUPLE: t1 ;
-
-M: t1 m1 drop ;
-M: t1 m2 nip ;
-
-TUPLE: t2 ;
-
-M: t2 m1 drop ;
-M: t2 m2 nip ;
-
-TUPLE: t3 ;
-
-M: t3 m1 drop ;
-M: t3 m2 nip ;
-
-TUPLE: t4 ;
-
-M: t4 m1 drop ;
-M: t4 m2 nip ;
-
-C: <t4> t4
-
-[ 1 ] [ 1 <t4> m1 ] unit-test
-[ 1 ] [ <t4> 1 m2 ] unit-test
-
-! another combination issue
-GENERIC: silly
-
-UNION: my-union slice repetition column array vector reversed ;
-
-M: my-union silly "x" ;
-
-M: array silly "y" ;
-
-M: column silly "fdsfds" ;
-
-M: repetition silly "zzz" ;
-
-M: reversed silly "zz" ;
-
-M: slice silly "tt" ;
-
-M: string silly "t" ;
-
-M: vector silly "z" ;
-
-[ "zz" ] [ 123 <reversed> silly nip ] unit-test
-
-! Typo
-SYMBOL: not-a-tuple-class
-
-[
- "IN: tuples.tests C: <not-a-tuple-class> not-a-tuple-class"
- eval
-] must-fail
-
-[ t ] [
- "not-a-tuple-class" "tuples.tests" lookup symbol?
-] unit-test
-
-! Missing check
-[ not-a-tuple-class construct-boa ] must-fail
-[ not-a-tuple-class construct-empty ] must-fail
-
-TUPLE: erg's-reshape-problem a b c d ;
-
-C: <erg's-reshape-problem> erg's-reshape-problem
-
-! We want to make sure constructors are recompiled when
-! tuples are reshaped
-: cons-test-1 \ erg's-reshape-problem construct-empty ;
-: cons-test-2 \ erg's-reshape-problem construct-boa ;
-: cons-test-3
- { set-erg's-reshape-problem-a }
- \ erg's-reshape-problem construct ;
-
-"IN: tuples.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval
-
-[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
-
-[ t ] [ cons-test-1 array-capacity "a" get array-capacity = ] unit-test
-
-[ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test
-
-[
- "IN: tuples.tests SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
-] [ [ check-tuple? ] is? ] must-fail-with
-
-! Hardcore unit tests
-USE: threads
-
-\ thread "slot-names" word-prop "slot-names" set
-
-[ ] [
- [
- \ thread { "xxx" } "slot-names" get append
- define-tuple-class
- ] with-compilation-unit
-
- [ 1337 sleep ] "Test" spawn drop
-
- [
- \ thread "slot-names" get
- define-tuple-class
- ] with-compilation-unit
-] unit-test
-
-USE: vocabs
-
-\ vocab "slot-names" word-prop "slot-names" set
-
-[ ] [
- [
- \ vocab { "xxx" } "slot-names" get append
- define-tuple-class
- ] with-compilation-unit
-
- all-words drop
-
- [
- \ vocab "slot-names" get
- define-tuple-class
- ] with-compilation-unit
-] unit-test
+++ /dev/null
-! Copyright (C) 2005, 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions hashtables kernel
-kernel.private math namespaces sequences sequences.private
-strings vectors words quotations memory combinators generic
-classes classes.private slots slots.private compiler.units ;
-IN: tuples
-
-M: tuple delegate 3 slot ;
-
-M: tuple set-delegate 3 set-slot ;
-
-M: tuple class class-of-tuple ;
-
-<PRIVATE
-
-: tuple= ( tuple1 tuple2 -- ? )
- over array-capacity over array-capacity tuck number= [
- -rot
- [ >r over r> array-nth >r array-nth r> = ] 2curry
- all-integers?
- ] [
- 3drop f
- ] if ;
-
-: tuple-class-eq? ( obj class -- ? )
- over tuple? [ swap 2 slot eq? ] [ 2drop f ] if ; inline
-
-: permutation ( seq1 seq2 -- permutation )
- swap [ index ] curry map ;
-
-: reshape-tuple ( oldtuple permutation -- newtuple )
- >r tuple>array 2 cut r>
- [ [ swap ?nth ] [ drop f ] if* ] with map
- append (>tuple) ;
-
-: reshape-tuples ( class newslots -- )
- >r dup "slot-names" word-prop r> permutation
- [
- >r [ swap class eq? ] curry instances dup r>
- [ reshape-tuple ] curry map
- become
- ] 2curry after-compilation ;
-
-: old-slots ( class newslots -- seq )
- swap "slots" word-prop 1 tail-slice
- [ slot-spec-name swap member? not ] with subset ;
-
-: forget-slots ( class newslots -- )
- dupd old-slots [
- 2dup
- slot-spec-reader 2array forget
- slot-spec-writer 2array forget
- ] with each ;
-
-: check-shape ( class newslots -- )
- over tuple-class? [
- over "slot-names" word-prop over = [
- 2dup forget-slots
- 2dup reshape-tuples
- over changed-word
- over redefined
- ] unless
- ] when 2drop ;
-
-GENERIC: tuple-size ( class -- size )
-
-M: tuple-class tuple-size "slot-names" word-prop length 2 + ;
-
-PRIVATE>
-
-: define-tuple-predicate ( class -- )
- dup [ tuple-class-eq? ] curry define-predicate ;
-
-: delegate-slot-spec
- T{ slot-spec f
- object
- "delegate"
- 3
- delegate
- set-delegate
- } ;
-
-: define-tuple-slots ( class slots -- )
- dupd 4 simple-slots
- 2dup [ slot-spec-name ] map "slot-names" set-word-prop
- 2dup delegate-slot-spec add* "slots" set-word-prop
- define-slots ;
-
-TUPLE: check-tuple class ;
-
-: check-tuple ( class -- )
- dup tuple-class?
- [ drop ] [ \ check-tuple construct-boa throw ] if ;
-
-: define-tuple-class ( class slots -- )
- 2dup check-shape
- over f tuple tuple-class define-class
- over define-tuple-predicate
- define-tuple-slots ;
-
-M: tuple clone
- (clone) dup delegate clone over set-delegate ;
-
-M: tuple equal?
- over tuple? [ tuple= ] [ 2drop f ] if ;
-
-: (delegates) ( obj -- )
- [ dup , delegate (delegates) ] when* ;
-
-: delegates ( obj -- seq )
- [ dup ] [ [ delegate ] keep ] [ ] unfold nip ;
-
-: is? ( obj quot -- ? ) >r delegates r> contains? ; inline
-
-: >tuple ( seq -- tuple )
- >vector dup first tuple-size over set-length
- >array (>tuple) ;
-
-M: tuple hashcode*
- [
- dup array-capacity -rot 0 -rot [
- swapd array-nth hashcode* bitxor
- ] 2curry reduce
- ] recursive-hashcode ;
-
-: tuple-slots ( tuple -- seq ) tuple>array 2 tail ;
-
-! Definition protocol
-M: tuple-class reset-class
- {
- "metaclass" "superclass" "slot-names" "slots"
- } reset-props ;
-
-M: object get-slots ( obj slots -- ... )
- [ execute ] with each ;
-
-M: object set-slots ( ... obj slots -- )
- <reversed> get-slots ;
-
-M: object construct-empty ( class -- tuple )
- dup tuple-size <tuple> ;
-
-M: object construct ( ... slots class -- tuple )
- construct-empty [ swap set-slots ] keep ;
-
-M: object construct-boa ( ... class -- tuple )
- dup tuple-size <tuple-boa> ;
[ f ] [
V{ 1 2 3 4 } dup clone
- [ underlying ] 2apply eq?
+ [ underlying ] bi@ eq?
] unit-test
[ 0 ] [
100 >array dup >vector <reversed> >array >r reverse r> =
] unit-test
-[ fixnum ] [ 1 >bignum V{ } new length class ] unit-test
+[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
<PRIVATE
: array>vector ( array length -- vector )
- vector construct-boa ; inline
+ vector boa ; inline
PRIVATE>
dup array? [ dup length array>vector ] [ >vector ] if
] unless ;
-M: vector new drop [ f <array> ] keep >fixnum array>vector ;
+M: vector new-sequence drop [ f <array> ] keep >fixnum array>vector ;
M: vector equal?
over vector? [ sequence= ] [ 2drop f ] if ;
{ $values { "vocab" "a vocabulary specifier" } { "path/f" "a pathname string" } }
{ $description "Searches for a vocabulary in the vocabulary roots." } ;
-{ vocab-root find-vocab-root } related-words
-
HELP: no-vocab
{ $values { "name" "a vocabulary name" } }
{ $description "Throws a " { $link no-vocab } "." }
IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
-parser source-files words assocs tuples definitions
-debugger compiler.units tools.vocabs ;
+parser source-files words assocs classes.tuple definitions
+debugger compiler.units tools.vocabs accessors ;
! This vocab should not exist, but just in case...
[ ] [
] unit-test
[ T{ vocab-link f "vocabs.loader.test" } ]
-[ "vocabs.loader.test" f >vocab-link ] unit-test
+[ "vocabs.loader.test" >vocab-link ] unit-test
[ t ]
-[ "kernel" f >vocab-link "kernel" vocab = ] unit-test
+[ "kernel" >vocab-link "kernel" vocab = ] unit-test
[ t ] [
"kernel" vocab-files
"kernel" vocab vocab-files
- "kernel" f <vocab-link> vocab-files
+ "kernel" <vocab-link> vocab-files
3array all-equal?
] unit-test
[ { 3 3 3 } ] [
"vocabs.loader.test.2" run
"vocabs.loader.test.2" vocab run
- "vocabs.loader.test.2" f <vocab-link> run
+ "vocabs.loader.test.2" <vocab-link> run
3array
] unit-test
<string-reader>
"resource:core/vocabs/loader/test/a/a.factor"
parse-stream
-] [ [ no-word? ] is? ] must-fail-with
+] [ error>> error>> no-word-error? ] must-fail-with
0 "count-me" set-global
] with-compilation-unit
] unit-test
+[ ] [ "vocabs.loader.test.b" changed-vocab ] unit-test
+
[ ] [ "vocabs.loader.test.b" refresh ] unit-test
[ 3 ] [ "count-me" get-global ] unit-test
[ { "resource:core/kernel/kernel.factor" 1 } ]
-[ "kernel" f <vocab-link> where ] unit-test
+[ "kernel" <vocab-link> where ] unit-test
[ { "resource:core/kernel/kernel.factor" 1 } ]
[ "kernel" vocab where ] unit-test
[
{ "2" "a" "b" "d" "e" "f" }
[
- "vocabs.loader.test." swap append forget-vocab
+ "vocabs.loader.test." prepend forget-vocab
] each
] with-compilation-unit ;
: vocab-dir+ ( vocab str/f -- path )
>r vocab-name "." split r>
- [ >r dup peek r> append add ] when*
+ [ >r dup peek r> append suffix ] when*
"/" join ;
-: vocab-path+ ( vocab path -- newpath )
- swap vocab-root dup [ swap path+ ] [ 2drop f ] if ;
-
-: vocab-source-path ( vocab -- path/f )
- dup ".factor" vocab-dir+ vocab-path+ ;
-
-: vocab-docs-path ( vocab -- path/f )
- dup "-docs.factor" vocab-dir+ vocab-path+ ;
-
: vocab-dir? ( root name -- ? )
over [
- ".factor" vocab-dir+ path+ resource-exists?
+ ".factor" vocab-dir+ append-path exists?
] [
2drop f
] if ;
+SYMBOL: root-cache
+
+H{ } clone root-cache set-global
+
: find-vocab-root ( vocab -- path/f )
- vocab-roots get swap [ vocab-dir? ] curry find nip ;
+ vocab-name root-cache get [
+ vocab-roots get swap [ vocab-dir? ] curry find nip
+ ] cache ;
+
+: vocab-append-path ( vocab path -- newpath )
+ swap find-vocab-root dup [ prepend-path ] [ 2drop f ] if ;
-M: string vocab-root
- vocab dup [ vocab-root ] when ;
+: vocab-source-path ( vocab -- path/f )
+ dup ".factor" vocab-dir+ vocab-append-path ;
-M: vocab-link vocab-root
- vocab-link-root ;
+: vocab-docs-path ( vocab -- path/f )
+ dup "-docs.factor" vocab-dir+ vocab-append-path ;
SYMBOL: load-help?
: load-source ( vocab -- )
[ source-wasn't-loaded ] keep
- [ vocab-source-path bootstrap-file ] keep
+ [ vocab-source-path [ bootstrap-file ] when* ] keep
source-was-loaded ;
: docs-were-loaded t swap set-vocab-docs-loaded? ;
docs-were-loaded
] [ drop ] if ;
-: create-vocab-with-root ( name root -- vocab )
- swap create-vocab [ set-vocab-root ] keep ;
-
-: update-root ( vocab -- )
- dup vocab-root
- [ drop ] [ dup find-vocab-root swap set-vocab-root ] if ;
-
: reload ( name -- )
[
- dup vocab [
- dup update-root dup load-source load-docs
- ] [ no-vocab ] ?if
+ dup vocab [ dup load-source load-docs ] [ no-vocab ] ?if
] with-compiler-errors ;
: require ( vocab -- )
GENERIC: (load-vocab) ( name -- )
M: vocab (load-vocab)
- dup update-root
+ [
+ dup vocab-source-loaded? [ dup load-source ] unless
+ dup vocab-docs-loaded? [ dup load-docs ] unless
+ drop
+ ] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
- dup vocab-root [
- [
- dup vocab-source-loaded? [ dup load-source ] unless
- dup vocab-docs-loaded? [ dup load-docs ] unless
- ] [ [ swap add-to-blacklist ] keep rethrow ] recover
- ] when drop ;
+M: vocab-link (load-vocab)
+ vocab-name create-vocab (load-vocab) ;
M: string (load-vocab)
- ! ".private" ?tail drop
- dup find-vocab-root >vocab-link (load-vocab) ;
-
-M: vocab-link (load-vocab)
- dup vocab-name swap vocab-root dup
- [ create-vocab-with-root (load-vocab) ] [ 2drop ] if ;
+ create-vocab (load-vocab) ;
[
[
rethrow
] [
drop
- [ (load-vocab) ] with-compiler-errors
+ dup find-vocab-root [
+ [ (load-vocab) ] with-compiler-errors
+ ] [
+ dup vocab [ drop ] [ no-vocab ] if
+ ] if
] if
] with-compiler-errors
] load-vocab-hook set-global
{ $subsection vocab }
"Accessors for various vocabulary attributes:"
{ $subsection vocab-name }
-{ $subsection vocab-root }
{ $subsection vocab-main }
{ $subsection vocab-help }
"Looking up existing vocabularies and creating new vocabularies:"
{ $values { "vocab" "a vocabulary specifier" } { "name" string } }
{ $description "Outputs the name of a vocabulary." } ;
-HELP: vocab-root
-{ $values { "vocab" "a vocabulary specifier" } { "root" "a pathname string or " { $link f } } }
-{ $description "Outputs the vocabulary root where the source code for a vocabulary is located, or " { $link f } " if the vocabulary is not defined in source files." } ;
-
HELP: vocab-words
{ $values { "vocab" "a vocabulary specifier" } { "words" "an assoc mapping strings to words" } }
{ $description "Outputs the words defined in a vocabulary." } ;
} ;
HELP: vocab-link
-{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name, and " { $link vocab-root } " is a pathname string identifying the vocabulary root where the sources to this vocabulary are located, or " { $link f } " if the root is not known."
+{ $class-description "Instances of this class identify vocabularies which are potentially not loaded. The " { $link vocab-name } " slot is the vocabulary name."
$nl
"Vocabulary links are created by calling " { $link >vocab-link } "."
} ;
HELP: >vocab-link
-{ $values { "name" string } { "root" "a pathname string or " { $link f } } { "vocab" "a vocabulary specifier" } }
+{ $values { "name" string } { "vocab" "a vocabulary specifier" } }
{ $description "If the vocabulary is loaded, outputs the corresponding " { $link vocab } " instance, otherwise creates a new " { $link vocab-link } "." } ;
SYMBOL: dictionary
-TUPLE: vocab
-name root
-words
+TUPLE: vocab < identity-tuple
+name words
main help
source-loaded? docs-loaded? ;
-M: vocab equal? 2drop f ;
-
: <vocab> ( name -- vocab )
H{ } clone
{ set-vocab-name set-vocab-words }
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
-TUPLE: no-vocab name ;
-
-: no-vocab ( name -- * )
- vocab-name \ no-vocab construct-boa throw ;
+ERROR: no-vocab name ;
SYMBOL: load-vocab-hook ! ( name -- )
: load-vocab ( name -- vocab )
- dup load-vocab-hook get call
- dup vocab [ ] [ no-vocab ] ?if ;
+ dup load-vocab-hook get call vocab ;
: vocabs ( -- seq )
dictionary get keys natural-sort ;
: child-vocab? ( prefix name -- ? )
2dup = pick empty? or
- [ 2drop t ] [ swap CHAR: . add head? ] if ;
+ [ 2drop t ] [ swap CHAR: . suffix head? ] if ;
: child-vocabs ( vocab -- seq )
vocab-name vocabs [ child-vocab? ] with subset ;
-TUPLE: vocab-link name root ;
-
-: <vocab-link> ( name root -- vocab-link )
- [ dup vocab-root ] unless* vocab-link construct-boa ;
+TUPLE: vocab-link name ;
-M: vocab-link equal?
- over vocab-link?
- [ [ vocab-link-name ] 2apply = ] [ 2drop f ] if ;
+: <vocab-link> ( name -- vocab-link )
+ vocab-link boa ;
M: vocab-link hashcode*
vocab-link-name hashcode* ;
M: vocab-link vocab-name vocab-link-name ;
-GENERIC# >vocab-link 1 ( name root -- vocab )
-
-M: vocab >vocab-link drop ;
+UNION: vocab-spec vocab vocab-link ;
-M: vocab-link >vocab-link drop ;
+GENERIC: >vocab-link ( name -- vocab )
-M: string >vocab-link
- over vocab dup [ 2nip ] [ drop <vocab-link> ] if ;
+M: vocab-spec >vocab-link ;
-UNION: vocab-spec vocab vocab-link ;
+M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
: forget-vocab ( vocab -- )
dup words forget-all
HELP: gensym
{ $values { "word" word } }
-{ $description "Creates an uninterned word that is not equal to any other word in the system. Gensyms have an automatically-generated name based on a prefix and an incrementing counter." }
+{ $description "Creates an uninterned word that is not equal to any other word in the system." }
{ $examples { $unchecked-example "gensym ." "G:260561" } }
{ $notes "Gensyms are often used as placeholder values that have no meaning of their own but must be unique. For example, the compiler uses gensyms to label sections of code." } ;
{ $description "Creates a new word, surrounding " { $snippet "name" } " in angle brackets." }
{ $examples { $example "USING: prettyprint words ;" "\"salmon\" \"scratchpad\" constructor-word ." "<salmon>" } } ;
-HELP: forget-word
-{ $values { "word" word } }
-{ $description "Removes a word from its vocabulary. User code should call " { $link forget } " instead, since it also does the right thing when forgetting class words." } ;
-
-{ POSTPONE: FORGET: forget forget-word forget-vocab } related-words
+{ POSTPONE: FORGET: forget forget* forget-vocab } related-words
HELP: target-word
{ $values { "word" word } { "target" word } }
USING: arrays generic assocs kernel math namespaces
sequences tools.test words definitions parser quotations
-vocabs continuations tuples compiler.units io.streams.string ;
+vocabs continuations classes.tuple compiler.units
+io.streams.string accessors ;
IN: words.tests
[ 4 ] [
] when*
[ "IN: words.tests : undef-test ; << undef-test >>" eval ]
-[ [ undefined? ] is? ] must-fail-with
+[ error>> undefined? ] must-fail-with
[ ] [
"IN: words.tests GENERIC: symbol-generic" eval
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions graphs assocs kernel kernel.private
slots.private math namespaces sequences strings vectors sbufs
-quotations assocs hashtables sorting math.parser words.private
-vocabs combinators ;
+quotations assocs hashtables sorting words.private vocabs ;
IN: words
: word ( -- word ) \ word get-global ;
M: word definition word-def ;
-TUPLE: undefined ;
+ERROR: undefined ;
-: undefined ( -- * ) \ undefined construct-empty throw ;
-
-PREDICATE: word deferred ( obj -- ? )
+PREDICATE: deferred < word ( obj -- ? )
word-def [ undefined ] = ;
M: deferred definer drop \ DEFER: f ;
M: deferred definition drop f ;
-PREDICATE: word symbol ( obj -- ? )
+PREDICATE: symbol < word ( obj -- ? )
dup <wrapper> 1array swap word-def sequence= ;
M: symbol definer drop \ SYMBOL: f ;
M: symbol definition drop f ;
-PREDICATE: word primitive ( obj -- ? )
+PREDICATE: primitive < word ( obj -- ? )
word-def [ do-primitive ] tail? ;
M: primitive definer drop \ PRIMITIVE: f ;
M: primitive definition drop f ;
: bootstrap-word ( word -- target )
[ target-word ] [ ] if-bootstrapping ;
-: crossref? ( word -- ? )
- {
- { [ dup "forgotten" word-prop ] [ f ] }
- { [ dup "method-generic" word-prop ] [ t ] }
- { [ dup word-vocabulary ] [ t ] }
- { [ t ] [ f ] }
- } cond nip ;
+GENERIC: crossref? ( word -- ? )
+
+M: word crossref?
+ dup "forgotten" word-prop [
+ drop f
+ ] [
+ word-vocabulary >boolean
+ ] if ;
+
+GENERIC: compiled-crossref? ( word -- ? )
+
+M: word compiled-crossref? crossref? ;
GENERIC# (quot-uses) 1 ( obj assoc -- )
compiled-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies -- )
- [ drop crossref? ] assoc-subset
+ [ drop compiled-crossref? ] assoc-subset
2dup "compiled-uses" set-word-prop
compiled-crossref get add-vertex* ;
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
] with each keys ;
-M: word redefined* ( word -- )
- { "inferred-effect" "no-effect" } reset-props ;
+<PRIVATE
-SYMBOL: changed-words
+SYMBOL: visited
-: changed-word ( word -- )
- dup changed-words get
- [ no-compilation-unit ] unless*
- set-at ;
+: reset-on-redefine { "inferred-effect" "no-effect" } ; inline
+
+: (redefined) ( word -- )
+ dup visited get key? [ drop ] [
+ [ reset-on-redefine reset-props ]
+ [ dup visited get set-at ]
+ [
+ crossref get at keys [ word? ] subset [
+ reset-on-redefine [ word-prop ] with contains?
+ ] subset
+ [ (redefined) ] each
+ ] tri
+ ] if ;
+
+PRIVATE>
+
+: redefined ( word -- )
+ H{ } clone visited [ (redefined) ] with-variable ;
: define ( word def -- )
[ ] like
over unxref
over redefined
over set-word-def
- dup changed-word
+ dup changed-definition
dup crossref? [ dup xref ] when drop ;
: define-declared ( word def effect -- )
M: word subwords drop f ;
: reset-generic ( word -- )
- dup subwords [ forget ] each
+ dup subwords forget-all
dup reset-word
{ "methods" "combination" "default-method" } reset-props ;
: gensym ( -- word )
- "G:" \ gensym counter number>string append f <word> ;
+ "( gensym )" f <word> ;
: define-temp ( quot -- word )
gensym dup rot define ;
[ ] [ no-vocab ] ?if
set-at ;
-TUPLE: check-create name vocab ;
+ERROR: bad-create name vocab ;
: check-create ( name vocab -- name vocab )
- 2dup [ string? ] both? [
- \ check-create construct-boa throw
- ] unless ;
+ 2dup [ string? ] both?
+ [ bad-create ] unless ;
: create ( name vocab -- word )
check-create 2dup lookup
M: word set-where swap "loc" set-word-prop ;
-GENERIC: forget-word ( word -- )
-
-: (forget-word) ( word -- )
+M: word forget*
dup "forgotten" word-prop [
dup delete-xref
dup delete-compiled-xref
dup t "forgotten" set-word-prop
] unless drop ;
-M: word forget-word (forget-word) ;
-
-M: word forget* forget-word ;
-
M: word hashcode*
nip 1 slot { fixnum } declare ;
pick callable? [ "Not a quotation" throw ] unless ; inline
: <alarm> ( quot time frequency -- alarm )
- check-alarm <box> alarm construct-boa ;
+ check-alarm <box> alarm boa ;
: register-alarm ( alarm -- )
dup dup alarm-time alarms get-global heap-push*
--- /dev/null
+Non-core array words
--- /dev/null
+collections
TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
-: <element> element construct-empty ;
+: <element> element new ;
: set-id ( -- boolean )
read1 dup elements get set-element-id ;
GENERIC: >ber ( obj -- byte-array )
M: fixnum >ber ( n -- byte-array )
>128-ber dup length 2 swap 2array
- "cc" pack-native swap append ;
+ "cc" pack-native prepend ;
: >ber-enumerated ( n -- byte-array )
>128-ber >byte-array dup length 10 swap 2array
- "CC" pack-native swap append ;
+ "CC" pack-native prepend ;
: >ber-length-encoding ( n -- byte-array )
dup 127 <= [
1array "C" pack-be
] [
1array "I" pack-be 0 swap remove dup length
- HEX: 80 + 1array "C" pack-be swap append
+ HEX: 80 + 1array "C" pack-be prepend
] if ;
! =========================================================
dup 126 > [
"range error in bignum" throw
] [
- 2 swap 2array "CC" pack-native swap append
+ 2 swap 2array "CC" pack-native prepend
] if ;
! =========================================================
TUPLE: tag value ;
-: <tag> ( -- <tag> ) 4 tag construct-boa ;
+: <tag> ( -- <tag> ) 4 tag boa ;
: with-ber ( quot -- )
[
: insert ( value variable -- ) namespace insert-at ;
-: 2seq>assoc ( keys values exemplar -- assoc )
- >r 2array flip r> assoc-like ;
-
: generate-key ( assoc -- str )
- >r random-256 >hex r>
+ >r 256 random-bits >hex r>
2dup key? [ nip generate-key ] [ drop ] if ;
: set-at-unique ( value assoc -- key )
: pattern>state ( {_a_b_c_} -- state ) rule> at ;
-: cap-line ( line -- 0-line-0 ) { 0 } swap append { 0 } append ;
+: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
: wrap-line ( a-line-z -- za-line-za )
dup peek 1array swap dup first 1array append append ;
USING: kernel parser namespaces quotations arrays vectors strings
- sequences assocs tuples math combinators ;
+ sequences assocs classes.tuple math combinators ;
IN: bake
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time tools.vocabs
arrays assocs io.styles io help.markup prettyprint sequences
-continuations debugger combinators.cleave ;
+continuations debugger ;
IN: benchmark
: run-benchmark ( vocab -- result )
--- /dev/null
+USING: kernel math accessors prettyprint io locals sequences
+math.ranges ;
+IN: benchmark.binary-trees
+
+TUPLE: tree-node item left right ;
+
+C: <tree-node> tree-node
+
+: bottom-up-tree ( item depth -- tree )
+ dup 0 > [
+ 1 -
+ [ drop ]
+ [ >r 2 * 1 - r> bottom-up-tree ]
+ [ >r 2 * r> bottom-up-tree ] 2tri
+ ] [
+ drop f f
+ ] if <tree-node> ;
+
+GENERIC: item-check ( node -- n )
+
+M: tree-node item-check
+ [ item>> ] [ left>> ] [ right>> ] tri [ item-check ] bi@ - + ;
+
+M: f item-check drop 0 ;
+
+: min-depth 4 ; inline
+
+: stretch-tree ( max-depth -- )
+ 1 + 0 over bottom-up-tree item-check
+ [ "stretch tree of depth " write pprint ]
+ [ "\t check: " write . ] bi* ;
+
+:: long-lived-tree ( max-depth -- )
+ 0 max-depth bottom-up-tree
+
+ min-depth max-depth 2 <range> [| depth |
+ max-depth depth - min-depth + 2^ [
+ [1,b] 0 [
+ dup neg
+ [ depth bottom-up-tree item-check + ] bi@
+ ] reduce
+ ]
+ [ 2 * ] bi
+ pprint "\t trees of depth " write depth pprint
+ "\t check: " write .
+ ] each
+
+ "long lived tree of depth " write max-depth pprint
+ "\t check: " write item-check . ;
+
+: binary-trees ( n -- )
+ min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ;
+
+: binary-trees-main ( -- )
+ 16 binary-trees ;
"benchmark.dispatch1" words [ tuple-class? ] subset ;
: a-bunch-of-objects ( -- seq )
- my-classes [ construct-empty ] map ;
+ my-classes [ new ] map ;
: dispatch-benchmark ( -- )
1000000 a-bunch-of-objects
-USING: namespaces math sequences splitting kernel ;
+USING: namespaces math sequences splitting kernel columns ;
IN: benchmark.dispatch2
: sequences
USING: sequences math mirrors splitting kernel namespaces
-assocs alien.syntax ;
+assocs alien.syntax columns ;
IN: benchmark.dispatch3
GENERIC: g ( obj -- str )
"benchmark.dispatch5" words [ tuple-class? ] subset ;\r
\r
: a-bunch-of-objects ( -- seq )\r
- my-classes [ construct-empty ] map ;\r
+ my-classes [ new ] map ;\r
\r
: dispatch-benchmark ( -- )\r
1000000 a-bunch-of-objects\r
: make-cumulative ( freq -- chars floats )
dup keys >byte-array
- swap values >float-array unclip [ + ] accumulate swap add ;
+ swap values >float-array unclip [ + ] accumulate swap suffix ;
:: select-random ( seed chars floats -- seed elt )
floats seed random -rot
pick 1 = [ <sphere> nip ] [ create-group ] if ;
: ss-point ( dx dy -- point )
- [ oversampling /f ] 2apply 0.0 3float-array ;
+ [ oversampling /f ] bi@ 0.0 3float-array ;
: ss-grid ( -- ss-grid )
oversampling [ oversampling [ ss-point ] with map ] map ;
: pixel-grid ( -- grid )
size reverse [
size [
- [ size 0.5 * - ] 2apply swap size
+ [ size 0.5 * - ] bi@ swap size
3float-array
] with map
] map ;
+USING: math kernel hints prettyprint io combinators ;
IN: benchmark.recursive
-USING: math kernel hints prettyprint io ;
: fib ( m -- n )
- dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
+ dup 2 < [ drop 1 ] [ [ 1 - fib ] [ 2 - fib ] bi + ] if ;
+ inline
: ack ( m n -- x )
- over zero? [
- nip 1+
- ] [
- dup zero? [
- drop 1- 1 ack
- ] [
- dupd 1- ack >r 1- r> ack
- ] if
- ] if ;
+ {
+ { [ over zero? ] [ nip 1+ ] }
+ { [ dup zero? ] [ drop 1- 1 ack ] }
+ [ [ drop 1- ] [ 1- ack ] 2bi ack ]
+ } cond ; inline
: tak ( x y z -- t )
- 2over swap < [
- [ rot 1- -rot tak ] 3keep
- [ -rot 1- -rot tak ] 3keep
- 1- -rot tak
- tak
- ] [
+ 2over <= [
2nip
- ] if ;
+ ] [
+ [ rot 1- -rot tak ]
+ [ -rot 1- -rot tak ]
+ [ 1- -rot tak ]
+ 3tri
+ tak
+ ] if ; inline
: recursive ( n -- )
- 3 over ack . flush
- dup 27.0 + fib . flush
- 1-
- dup 3 * over 2 * rot tak . flush
+ [ 3 swap ack . flush ]
+ [ 27.0 + fib . flush ]
+ [ 1- [ 3 * ] [ 2 * ] [ ] tri tak . flush ] tri
3 fib . flush
3.0 2.0 1.0 tak . flush ;
+HINTS: recursive fixnum ;
+
: recursive-main 11 recursive ;
MAIN: recursive-main
[ "c071aa7e007a9770b2fb4304f55a17e5" ] [\r
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt"\r
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"\r
- [ resource-path ] 2apply\r
+ [ resource-path ] bi@\r
reverse-complement\r
\r
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"\r
USING: io io.files io.streams.duplex kernel sequences
sequences.private strings vectors words memoize splitting
-hints unicode.case continuations io.encodings.latin1 ;
+hints unicode.case continuations io.encodings.ascii ;
IN: benchmark.reverse-complement
MEMO: trans-map ( -- str )
readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
: reverse-complement ( infile outfile -- )
- latin1 <file-writer> [
- swap latin1 <file-reader> [
+ ascii <file-writer> [
+ swap ascii <file-reader> [
swap <duplex-stream> [
500000 <vector> (reverse-complement)
] with-stream
! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
USING: float-arrays kernel math math.functions math.vectors
-sequences sequences.private prettyprint words tools.time hints ;
+sequences sequences.private prettyprint words
+hints locals ;
IN: benchmark.spectral-norm
-: fast-truncate >fixnum >float ; inline
+:: inner-loop ( u n quot -- seq )
+ n [| i |
+ n 0.0 [| j |
+ u i j quot call +
+ ] reduce
+ ] F{ } map-as ; inline
: eval-A ( i j -- n )
- [ >float ] 2apply
- dupd + dup 1+ * 2 /f fast-truncate + 1+
- recip ; inline
+ [ >float ] bi@
+ [ drop ] [ + [ ] [ 1 + ] bi * 0.5 * ] 2bi
+ + 1 + recip ; inline
: (eval-A-times-u) ( u i j -- x )
- tuck eval-A >r swap nth-unsafe r> * ; inline
+ tuck [ swap nth-unsafe ] [ eval-A ] 2bi* * ; inline
: eval-A-times-u ( n u -- seq )
- over [
- pick 0.0 [
- swap >r >r 2dup r> (eval-A-times-u) r> +
- ] reduce nip
- ] F{ } map-as 2nip ; inline
+ [ (eval-A-times-u) ] inner-loop ; inline
: (eval-At-times-u) ( u i j -- x )
- tuck swap eval-A >r swap nth-unsafe r> * ; inline
+ tuck [ swap nth-unsafe ] [ swap eval-A ] 2bi* * ; inline
-: eval-At-times-u ( n u -- seq )
- over [
- pick 0.0 [
- swap >r >r 2dup r> (eval-At-times-u) r> +
- ] reduce nip
- ] F{ } map-as 2nip ; inline
+: eval-At-times-u ( u n -- seq )
+ [ (eval-At-times-u) ] inner-loop ; inline
-: eval-AtA-times-u ( n u -- seq )
- dupd eval-A-times-u eval-At-times-u ; inline
+: eval-AtA-times-u ( u n -- seq )
+ [ eval-A-times-u ] [ eval-At-times-u ] bi ; inline
-: u/v ( n -- u v )
- dup 1.0 <float-array> dup
+:: u/v ( n -- u v )
+ n 1.0 <float-array> dup
10 [
drop
- dupd eval-AtA-times-u
- 2dup eval-AtA-times-u
- swap
- ] times
- rot drop ; inline
+ n eval-AtA-times-u
+ [ n eval-AtA-times-u ] keep
+ ] times ; inline
: spectral-norm ( n -- norm )
u/v [ v. ] keep norm-sq /f sqrt ;
HINTS: spectral-norm fixnum ;
: spectral-norm-main ( -- )
- 2000 spectral-norm . ;
+ 5500 spectral-norm . ;
MAIN: spectral-norm-main
: foo 0 100000000 [ over hello-n + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
TUPLE: hello n ;
-: hello-n* dup tuple? [ 4 slot ] [ 3 throw ] if ;
+: hello-n* dup tuple? [ 3 slot ] [ 3 throw ] if ;
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
TUPLE: hello n ;
-: hello-n* dup tag 2 eq? [ 4 slot ] [ 3 throw ] if ;
+: hello-n* dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ;
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
TUPLE: hello n ;
-: hello-n* 4 slot ;
+: hello-n* 3 slot ;
: foo 0 100000000 [ over hello-n* + ] times ;
-: typecheck-main 0 hello construct-boa foo 2drop ;
+: typecheck-main 0 hello boa foo 2drop ;
MAIN: typecheck-main
--- /dev/null
+USING: arrays bit-arrays help.markup help.syntax kernel\r
+bit-vectors.private combinators ;\r
+IN: bit-vectors\r
+\r
+ARTICLE: "bit-vectors" "Bit vectors"\r
+"A bit vector is a resizable mutable sequence of bits. Bit vector words are found in the " { $vocab-link "bit-vectors" } " vocabulary."\r
+$nl\r
+"Bit vectors form a class:"\r
+{ $subsection bit-vector }\r
+{ $subsection bit-vector? }\r
+"Creating bit vectors:"\r
+{ $subsection >bit-vector }\r
+{ $subsection <bit-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: ?V{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new bit vector is to write:"\r
+{ $code "?V{ } clone" } ;\r
+\r
+ABOUT: "bit-vectors"\r
+\r
+HELP: bit-vector\r
+{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;\r
+\r
+HELP: <bit-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }\r
+{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;\r
+\r
+HELP: >bit-vector\r
+{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }\r
+{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;\r
+\r
+HELP: bit-array>vector\r
+{ $values { "bit-array" "an array" } { "length" "a non-negative integer" } { "bit-vector" bit-vector } }\r
+{ $description "Creates a new bit vector using the array for underlying storage with the specified initial length." }\r
+{ $warning "This word is in the " { $vocab-link "bit-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >bit-vector } " instead." } ;\r
+\r
+HELP: ?V{\r
+{ $syntax "?V{ elements... }" }\r
+{ $values { "elements" "a list of booleans" } }\r
+{ $description "Marks the beginning of a literal bit vector. Literal bit vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "?V{ t f t }" } } ;\r
+\r
--- /dev/null
+IN: bit-vectors.tests\r
+USING: tools.test bit-vectors vectors sequences kernel math ;\r
+\r
+[ 0 ] [ 123 <bit-vector> length ] unit-test\r
+\r
+: do-it\r
+ 1234 swap [ >r even? r> push ] curry each ;\r
+\r
+[ t ] [\r
+ 3 <bit-vector> dup do-it\r
+ 3 <vector> dup do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ ?V{ } bit-vector? ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays kernel kernel.private math sequences\r
+sequences.private growable bit-arrays prettyprint.backend\r
+parser accessors ;\r
+IN: bit-vectors\r
+\r
+TUPLE: bit-vector underlying fill ;\r
+\r
+M: bit-vector underlying underlying>> { bit-array } declare ;\r
+\r
+M: bit-vector set-underlying (>>underlying) ;\r
+\r
+M: bit-vector length fill>> { array-capacity } declare ;\r
+\r
+M: bit-vector set-fill (>>fill) ;\r
+\r
+<PRIVATE\r
+\r
+: bit-array>vector ( bit-array length -- bit-vector )\r
+ bit-vector boa ; inline\r
+\r
+PRIVATE>\r
+\r
+: <bit-vector> ( n -- bit-vector )\r
+ <bit-array> 0 bit-array>vector ; inline\r
+\r
+: >bit-vector ( seq -- bit-vector )\r
+ T{ bit-vector f ?{ } 0 } clone-like ;\r
+\r
+M: bit-vector like\r
+ drop dup bit-vector? [\r
+ dup bit-array?\r
+ [ dup length bit-array>vector ] [ >bit-vector ] if\r
+ ] unless ;\r
+\r
+M: bit-vector new-sequence\r
+ drop [ <bit-array> ] keep >fixnum bit-array>vector ;\r
+\r
+M: bit-vector equal?\r
+ over bit-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: bit-array new-resizable drop <bit-vector> ;\r
+\r
+INSTANCE: bit-vector growable\r
+\r
+: ?V{ \ } [ >bit-vector ] parse-literal ; parsing\r
+\r
+M: bit-vector >pprint-sequence ;\r
+\r
+M: bit-vector pprint-delims drop \ ?V{ \ } ;\r
--- /dev/null
+Growable bit arrays
--- /dev/null
+collections
M: check< summary drop "Number exceeds upper bound" ;
: check< ( num cmp -- num )
- 2dup < [ drop ] [ \ check< construct-boa throw ] if ;
+ 2dup < [ drop ] [ \ check< boa throw ] if ;
: ?check ( length -- )
safe-bitfields? get [ 2^ , \ check< , ] [ drop ] if ;
[ range>accessor ] map ;
: clear-range ( range -- num )
- first2 dupd + [ 2^ 1- ] 2apply bitnot bitor ;
+ first2 dupd + [ 2^ 1- ] bi@ bitnot bitor ;
: range>setter ( range -- quot )
[
>r keys r> define-slots ;
: define-setters ( classname slots -- )
- >r "with-" swap append r>
+ >r "with-" prepend r>
dup values [setters]
>r keys r> define-slots ;
math.vectors
math.trig
combinators arrays sequences random vars
- combinators.cleave
combinators.lib ;
IN: boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: relative-position ( self other -- v ) swap [ boid-pos ] 2apply v- ;
+: relative-position ( self other -- v ) swap [ boid-pos ] bi@ v- ;
: relative-angle ( self other -- angle )
over boid-vel -rot relative-position angle-between ;
ui.gadgets.packs
ui.gadgets.grids
ui.gestures
- combinators.cleave
assocs.lib vars rewrite-closures boids ;
IN: boids.ui
: download-image ( arch -- )
boot-image-name dup need-new-image? [
"Downloading " write dup write "..." print
- url swap append download
+ url prepend download
] [
"Boot image up to date" print
drop
"bootstrap.compiler" vocab [
"io." {
{ [ "io-backend" get ] [ "io-backend" get ] }
- { [ unix? ] [ "unix" ] }
- { [ winnt? ] [ "windows.nt" ] }
- { [ wince? ] [ "windows.ce" ] }
+ { [ os unix? ] [ "unix" ] }
+ { [ os winnt? ] [ "windows.nt" ] }
+ { [ os wince? ] [ "windows.ce" ] }
} cond append require
] when
--- /dev/null
+USING: vocabs.loader sequences system
+random random.mersenne-twister combinators init
+namespaces random ;
+
+"random.mersenne-twister" require
+
+{
+ { [ os windows? ] [ "random.windows" require ] }
+ { [ os unix? ] [ "random.unix" require ] }
+} cond
+
+[
+ [ 32 random-bits ] with-system-random
+ <mersenne-twister> random-generator set-global
+] "generator.random" add-init-hook
USING: kernel vocabs vocabs.loader sequences system ;
{ "ui" "help" "tools" }
-[ "bootstrap." swap append vocab ] all? [
+[ "bootstrap." prepend vocab ] all? [
"ui.tools" require
"ui.cocoa" vocab [
"bootstrap.compiler" vocab [
"ui-backend" get [
{
- { [ macosx? ] [ "cocoa" ] }
- { [ windows? ] [ "windows" ] }
- { [ unix? ] [ "x11" ] }
+ { [ os macosx? ] [ "cocoa" ] }
+ { [ os windows? ] [ "windows" ] }
+ { [ os unix? ] [ "x11" ] }
} cond
- ] unless* "ui." swap append require
+ ] unless* "ui." prepend require
"ui.freetype" require
] when
--- /dev/null
+
+USING: help.syntax help.markup ;
+
+USING: bubble-chamber.particle.muon
+ bubble-chamber.particle.quark
+ bubble-chamber.particle.hadron
+ bubble-chamber.particle.axion ;
+
+IN: bubble-chamber
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+HELP: muon
+
+ { $class-description
+ "The muon is a colorful particle with an entangled friend."
+ "It draws both itself and its horizontally symmetric partner."
+ "A high range of speed and almost no speed decay allow the"
+ "muon to reach the extents of the window, often forming rings"
+ "where theta has decayed but speed remains stable. The result"
+ "is color almost everywhere in the general direction of collision,"
+ "stabilized into fuzzy rings." } ;
+
+HELP: quark
+
+ { $class-description
+ "The quark draws as a translucent black. Their large numbers"
+ "create fields of blackness overwritten only by the glowing shadows of "
+ "Hadrons. "
+ "quarks are allowed to accelerate away with speed decay values above 1.0. "
+ "Each quark has an entangled friend. Both particles are drawn identically,"
+ "mirrored along the y-axis." } ;
+
+HELP: hadron
+
+ { $class-description
+ "Hadrons collide from totally random directions. "
+ "Those hadrons that do not exit the drawing area, "
+ "tend to stabilize into perfect circular orbits. "
+ "Each hadron draws with a slight glowing emboss. "
+ "The hadron itself is not drawn." } ;
+
+HELP: axion
+
+ { $class-description
+ "The axion particle draws a bold black path. Axions exist "
+ "in a slightly higher dimension and as such are drawn with "
+ "elevated embossed shadows. Axions are quick to stabilize "
+ "and fall into single pixel orbits axions automatically "
+ "recollide themselves after stabilizing." } ;
+
+{ muon quark hadron axion } related-words
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber" "Bubble Chamber"
+
+ { $subsection "bubble-chamber-introduction" }
+ { $subsection "bubble-chamber-particles" }
+ { $subsection "bubble-chamber-author" }
+ { $subsection "bubble-chamber-running" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-introduction" "Introduction"
+
+"The Bubble Chamber is a generative painting system of imaginary "
+"colliding particles. A single super-massive collision produces a "
+"discrete universe of four particle types. Particles draw their "
+"positions over time as pixel exposures. " ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-particles" "Particles"
+
+"Four types of particles exist. The behavior and graphic appearance of "
+"each particle type is unique."
+
+ { $subsection muon }
+ { $subsection quark }
+ { $subsection hadron }
+ { $subsection axion } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-author" "Author"
+
+ "Bubble Chamber was created by Jared Tarbell. "
+ "It was originally implemented in Processing. "
+ "It was ported to Factor by Eduardo Cavazos. "
+ "The original work is on display here: "
+ { $url
+ "http://www.complexification.net/gallery/machines/bubblechamber/" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ARTICLE: "bubble-chamber-running" "How to use"
+
+ "After you run the vocabulary, a window will appear. Click the "
+ "mouse in a random area to fire 11 particles of each type. "
+ "Another way to fire particles is to press the "
+ "spacebar. This fires all the particles." ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces sequences random math math.constants math.libm vars
+ ui
+ processing
+ processing.gadget
+ bubble-chamber.common
+ bubble-chamber.particle
+ bubble-chamber.particle.muon
+ bubble-chamber.particle.quark
+ bubble-chamber.particle.hadron
+ bubble-chamber.particle.axion ;
+
+IN: bubble-chamber
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VARS: particles muons quarks hadrons axions ;
+
+VAR: boom
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-all ( -- )
+
+ 2 pi * 1random >collision-theta
+
+ particles> [ collide ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: collide-one ( -- )
+
+ dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
+
+ hadrons> random collide
+ quarks> random collide
+ muons> random collide ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse-pressed ( -- )
+ boom on
+ 1 background ! kludge
+ 11 [ drop collide-one ] each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: key-released ( -- )
+ key " " =
+ [
+ boom on
+ 1 background
+ collide-all
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: bubble-chamber ( -- )
+
+ 1000 1000 size*
+
+ [
+ 1 background
+ no-stroke
+
+ 1789 [ drop <muon> ] map >muons
+ 1300 [ drop <quark> ] map >quarks
+ 1000 [ drop <hadron> ] map >hadrons
+ 111 [ drop <axion> ] map >axions
+
+ muons> quarks> hadrons> axions> 3append append >particles
+
+ collide-one
+ ] setup
+
+ [
+ boom>
+ [ particles> [ move ] each ]
+ when
+ ] draw
+
+ [ mouse-pressed ] button-down
+ [ key-released ] key-up ;
+
+: go ( -- ) [ bubble-chamber run ] with-ui ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+
+USING: kernel math accessors combinators.cleave vars ;
+
+IN: bubble-chamber.common
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: collision-theta
+
+: dim ( -- dim ) 1000 ;
+
+: center ( -- point ) dim 2 / dup {2} ; foldable
--- /dev/null
+
+USING: kernel sequences random accessors multi-methods
+ math math.constants math.ranges math.points combinators.cleave
+ processing bubble-chamber.common bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.axion
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: axion < particle ;
+
+: <axion> ( -- axion ) axion new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { axion }
+
+ center >>pos
+ 2 pi * 1random >>theta
+ 1.0 6.0 2random >>speed
+ 0.998 1.000 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
+
+: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ;
+: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
+
+: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
+: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { axion }
+
+ { 0.06 0.59 } stroke
+ dup pos>> point
+
+ 1 4 [a,b] [ axion-white axion-point- ] each
+ 1 4 [a,b] [ axion-black axion-point+ ] each
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
+
+ 1000 random 996 >
+ [
+ dup speed>> neg >>speed
+ dup speed-d>> neg 2 + >>speed-d
+
+ 100 random 30 > [ collide ] [ drop ] if
+ ]
+ [ drop ]
+ if ;
--- /dev/null
+
+USING: kernel random math math.constants math.points accessors multi-methods
+ processing
+ processing.color
+ bubble-chamber.common
+ bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.hadron
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: hadron < particle ;
+
+: <hadron> ( -- hadron ) hadron new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { hadron }
+
+ center >>pos
+ 2 pi * 1random >>theta
+ 0.5 3.5 2random >>speed
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ 0 1 0 <rgb> >>myc
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { hadron }
+
+ { 1 0.11 } stroke
+ dup pos>> 1 v-y point
+
+ { 0 0.11 } stroke
+ dup pos>> 1 v+y point
+
+ dup vel>> move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ 1.0 >>speed-d
+ 0.00001 >>theta-dd
+
+ 100 random 70 > [ dup collide ] when
+ ]
+ when
+
+ out-of-bounds? [ collide ] [ drop ] if ;
--- /dev/null
+
+USING: kernel sequences math math.constants accessors
+ processing
+ processing.color ;
+
+IN: bubble-chamber.particle.muon.colors
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: good-colors ( -- seq )
+ {
+ T{ rgba f 0.23 0.14 0.17 1 }
+ T{ rgba f 0.23 0.14 0.15 1 }
+ T{ rgba f 0.21 0.14 0.15 1 }
+ T{ rgba f 0.51 0.39 0.33 1 }
+ T{ rgba f 0.49 0.33 0.20 1 }
+ T{ rgba f 0.55 0.45 0.32 1 }
+ T{ rgba f 0.69 0.63 0.51 1 }
+ T{ rgba f 0.64 0.39 0.18 1 }
+ T{ rgba f 0.73 0.42 0.20 1 }
+ T{ rgba f 0.71 0.45 0.29 1 }
+ T{ rgba f 0.79 0.45 0.22 1 }
+ T{ rgba f 0.82 0.56 0.34 1 }
+ T{ rgba f 0.88 0.72 0.49 1 }
+ T{ rgba f 0.85 0.69 0.40 1 }
+ T{ rgba f 0.96 0.92 0.75 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.85 0.82 0.69 1 }
+ T{ rgba f 0.99 0.98 0.87 1 }
+ T{ rgba f 0.82 0.82 0.79 1 }
+ T{ rgba f 0.65 0.69 0.67 1 }
+ T{ rgba f 0.53 0.60 0.55 1 }
+ T{ rgba f 0.57 0.53 0.68 1 }
+ T{ rgba f 0.47 0.42 0.56 1 }
+ } ;
+
+: anti-colors ( -- seq ) good-colors <reversed> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
+
+: set-good-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ good-colors at-fraction-of >>myc ]
+ [ drop ]
+ if ;
+
+: set-anti-color ( particle -- particle )
+ color-fraction dup 0 1 between?
+ [ anti-colors at-fraction-of >>mya ]
+ [ drop ]
+ if ;
--- /dev/null
+
+USING: kernel arrays sequences random
+ math
+ math.ranges
+ math.functions
+ math.vectors
+ multi-methods accessors
+ combinators.cleave
+ processing
+ bubble-chamber.common
+ bubble-chamber.particle
+ bubble-chamber.particle.muon.colors ;
+
+IN: bubble-chamber.particle.muon
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: muon < particle ;
+
+: <muon> ( -- muon ) muon new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { muon }
+
+ center >>pos
+ 2 32 [a,b] random >>speed
+ 0.0001 0.001 2random >>speed-d
+
+ collision-theta> -0.1 0.1 2random + >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while
+
+ set-good-color
+ set-anti-color
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { muon }
+
+ dup myc>> 0.16 >>alpha stroke
+ dup pos>> point
+
+ dup mya>> 0.16 >>alpha stroke
+ dup pos>> first2 >r dim swap - r> 2array point
+
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ move-by
+
+ step-theta
+ step-theta-d
+ step-speed-sub
+
+ out-of-bounds? [ collide ] [ drop ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
--- /dev/null
+
+USING: kernel sequences combinators
+ math math.vectors math.functions multi-methods
+ accessors combinators.cleave processing processing.color
+ bubble-chamber.common ;
+
+IN: bubble-chamber.particle
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: collide ( particle -- )
+GENERIC: move ( particle -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: initialize-particle ( particle -- particle )
+
+ 0 0 {2} >>pos
+ 0 0 {2} >>vel
+
+ 0 >>speed
+ 0 >>speed-d
+ 0 >>theta
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ 0 0 0 1 <rgba> >>myc
+ 0 0 0 1 <rgba> >>mya ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
+
+: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: turn ( particle -- particle )
+ dup
+ [ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
+ >>vel ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
+: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
+: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
+: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: x ( particle -- x ) pos>> first ;
+: y ( particle -- x ) pos>> second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: out-of-bounds? ( particle -- particle ? )
+ dup
+ { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
+ or or or ;
--- /dev/null
+
+USING: kernel arrays sequences random math accessors multi-methods
+ processing
+ bubble-chamber.common
+ bubble-chamber.particle ;
+
+IN: bubble-chamber.particle.quark
+
+TUPLE: quark < particle ;
+
+: <quark> ( -- quark ) quark new initialize-particle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: collide { quark }
+
+ center >>pos
+ collision-theta> -0.11 0.11 2random + >>theta
+ 0.5 3.0 2random >>speed
+
+ 0.996 1.001 2random >>speed-d
+ 0 >>theta-d
+ 0 >>theta-dd
+
+ [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while
+
+ drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: move { quark }
+
+ dup myc>> 0.13 >>alpha stroke
+ dup pos>> point
+
+ dup pos>> first2 >r dim swap - r> 2array point
+
+ [ ] [ vel>> ] bi move-by
+
+ turn
+
+ step-theta
+ step-theta-d
+ step-speed-mul
+
+ 1000 random 997 >
+ [
+ dup speed>> neg >>speed
+ 2 over speed-d>> - >>speed-d
+ ]
+ when
+
+ out-of-bounds? [ collide ] [ drop ] if ;
2array ;
: compare-tables ( old new -- table )
- [ passing-benchmarks ] 2apply
+ [ passing-benchmarks ] bi@
[ benchmark-difference ] with map ;
: benchmark-deltas ( -- table )
- "../benchmarks" "benchmarks" [ eval-file ] 2apply
+ "../benchmarks" "benchmarks" [ eval-file ] bi@
compare-tables
sort-values ;
--- /dev/null
+
+USING: io.files io.launcher io.encodings.utf8 prettyprint
+ builder.util builder.common builder.child builder.release
+ builder.report builder.email builder.cleanup ;
+
+IN: builder.build
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: create-build-dir ( -- )
+ datestamp >stamp
+ build-dir make-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: enter-build-dir ( -- ) build-dir set-current-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: clone-builds-factor ( -- )
+ { "git" "clone" builds/factor } to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: record-id ( -- )
+ "factor"
+ [ git-id "../git-id" utf8 [ . ] with-file-writer ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: build ( -- )
+ reset-status
+ create-build-dir
+ enter-build-dir
+ clone-builds-factor
+ record-id
+ build-child
+ release
+ report
+ email-report
+ cleanup ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: build
\ No newline at end of file
-USING: kernel namespaces sequences splitting system combinators continuations
- parser io io.files io.launcher io.sockets prettyprint threads
- bootstrap.image benchmark vars bake smtp builder.util accessors
- io.encodings.utf8
- calendar
- tools.test
+USING: kernel debugger io.files threads calendar
builder.common
- builder.benchmark
- builder.release ;
+ builder.updates
+ builder.build ;
IN: builder
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: prepare-build-machine ( -- )
- builds make-directory
- builds cd
- { "git" "clone" "git://factorcode.org/git/factor.git" } run-process drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-clone ( -- desc ) { "git" "clone" "../factor" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: enter-build-dir ( -- )
- datestamp >stamp
- builds cd
- stamp> make-directory
- stamp> cd ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: git-id ( -- id )
- { "git" "show" } utf8 <process-stream>
- [ readln ] with-stream " " split second ;
-
-: record-git-id ( -- ) git-id "../git-id" utf8 [ . ] with-file-writer ;
-
-: do-make-clean ( -- ) { "make" "clean" } try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: make-vm ( -- desc )
- <process>
- { "make" } >>command
- "../compile-log" >>stdout
- +stdout+ >>stderr ;
-
-: do-make-vm ( -- )
- make-vm [ "vm compile error" print "../compile-log" cat ] run-or-bail ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: copy-image ( -- )
- builds "factor" path+ my-boot-image-name path+ ".." copy-file-into
- builds "factor" path+ my-boot-image-name path+ "." copy-file-into ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bootstrap-cmd ( -- cmd )
- { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
-
-: bootstrap ( -- desc )
- <process>
- bootstrap-cmd >>command
- +closed+ >>stdin
- "../boot-log" >>stdout
- +stdout+ >>stderr
- 20 minutes >>timeout ;
-
-: do-bootstrap ( -- )
- bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail ;
-
-: builder-test-cmd ( -- cmd )
- { "./factor" "-run=builder.test" } to-strings ;
-
-: builder-test ( -- desc )
- <process>
- builder-test-cmd >>command
- +closed+ >>stdin
- "../test-log" >>stdout
- +stdout+ >>stderr
- 45 minutes >>timeout ;
-
-: do-builder-test ( -- )
- builder-test [ "Test error" print "../test-log" 100 cat-n ] run-or-bail ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: build-status
-
-: (build) ( -- )
-
- builds-check
-
- build-status off
-
- enter-build-dir
-
- "report" utf8
- [
- "Build machine: " write host-name print
- "CPU: " write cpu print
- "OS: " write os print
- "Build directory: " write cwd print
-
- git-clone [ "git clone failed" print ] run-or-bail
-
- "factor"
- [
- record-git-id
- do-make-clean
- do-make-vm
- copy-image
- do-bootstrap
- do-builder-test
- ]
- with-directory
-
- "test-log" delete-file
-
- "git id: " write "git-id" eval-file print nl
-
- "Boot time: " write "boot-time" eval-file milli-seconds>time print
- "Load time: " write "load-time" eval-file milli-seconds>time print
- "Test time: " write "test-time" eval-file milli-seconds>time print nl
-
- "Did not pass load-everything: " print "load-everything-vocabs" cat
-
- "Did not pass test-all: " print "test-all-vocabs" cat
- "test-failures" cat
-
-! "test-failures" eval-file test-failures.
-
- "help-lint results:" print "help-lint" cat
-
- "Benchmarks: " print "benchmarks" eval-file benchmarks.
-
- nl
-
- show-benchmark-deltas
-
- "benchmarks" ".." copy-file-into
-
- maybe-release
- ]
- with-file-writer
-
- build-status on ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-SYMBOL: builder-from
-
-SYMBOL: builder-recipients
-
-: tag-subject ( str -- str ) { "builder@" host-name* ": " , } bake to-string ;
-
-: subject ( -- str ) build-status get [ "report" ] [ "error" ] if tag-subject ;
-
-: send-builder-email ( -- )
- <email>
- builder-from get >>from
- builder-recipients get >>to
- subject >>subject
- "./report" file>string >>body
- send-email ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: compress-image ( -- )
- { "bzip2" my-boot-image-name } to-strings run-process drop ;
-
-: build ( -- )
- [ (build) ] failsafe
- builds cd stamp> cd
- [ send-builder-email ] [ drop "not sending mail" . ] recover
- { "rm" "-rf" "factor" } run-process drop
- [ compress-image ] failsafe ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-USE: bootstrap.image.download
-
-: git-pull ( -- desc )
- {
- "git"
- "pull"
- "--no-summary"
- "git://factorcode.org/git/factor.git"
- "master"
- } ;
-
-: updates-available? ( -- ? )
- git-id
- git-pull run-process drop
- git-id
- = not ;
-
-: new-image-available? ( -- ? )
- my-boot-image-name need-new-image?
- [ download-my-image t ]
- [ f ]
- if ;
-
: build-loop ( -- )
builds-check
[
- builds "/factor" append cd
- updates-available? new-image-available? or
- [ build ]
- when
+ builds/factor set-current-directory
+ new-code-available? [ build ] when
]
- failsafe
+ try
5 minutes sleep
build-loop ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
MAIN: build-loop
\ No newline at end of file
--- /dev/null
+
+USING: namespaces debugger io.files io.launcher accessors bootstrap.image
+ calendar builder.util builder.common ;
+
+IN: builder.child
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-clean ( -- ) { gnu-make "clean" } to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-vm ( -- )
+ <process>
+ gnu-make >>command
+ "../compile-log" >>stdout
+ +stdout+ >>stderr
+ try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: builds-factor-image ( -- img ) builds/factor my-boot-image-name append-path ;
+
+: copy-image ( -- )
+ builds-factor-image ".." copy-file-into
+ builds-factor-image "." copy-file-into ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: boot-cmd ( -- cmd )
+ { "./factor" { "-i=" my-boot-image-name } "-no-user-init" } to-strings ;
+
+: boot ( -- )
+ <process>
+ boot-cmd >>command
+ +closed+ >>stdin
+ "../boot-log" >>stdout
+ +stdout+ >>stderr
+ 60 minutes >>timeout
+ try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: test-cmd ( -- cmd ) { "./factor" "-run=builder.test" } ;
+
+: test ( -- )
+ <process>
+ test-cmd >>command
+ +closed+ >>stdin
+ "../test-log" >>stdout
+ +stdout+ >>stderr
+ 240 minutes >>timeout
+ try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (build-child) ( -- )
+ make-clean
+ make-vm status-vm on
+ copy-image
+ boot status-boot on
+ test status-test on
+ status on ;
+
+: build-child ( -- )
+ "factor" set-current-directory
+ [ (build-child) ] try
+ ".." set-current-directory ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces io.files io.launcher bootstrap.image
+ builder.util builder.common ;
+
+IN: builder.cleanup
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-debug
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: compress-image ( -- ) { "bzip2" my-boot-image-name } to-strings try-process ;
+
+: delete-child-factor ( -- )
+ build-dir [ { "rm" "-rf" "factor" } try-process ] with-directory ;
+
+: cleanup ( -- )
+ builder-debug get f =
+ [
+ "test-log" delete-file
+ delete-child-factor
+ compress-image
+ ]
+ when ;
+
-USING: kernel namespaces io.files sequences vars ;
+USING: kernel namespaces sequences splitting
+ io io.files io.launcher io.encodings.utf8 prettyprint
+ vars builder.util ;
IN: builder.common
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SYMBOL: upload-to-factorcode
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
SYMBOL: builds-dir
: builds ( -- path )
VAR: stamp
+: builds/factor ( -- path ) builds "factor" append-path ;
+: build-dir ( -- path ) builds stamp> append-path ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prepare-build-machine ( -- )
+ builds make-directory
+ builds
+ [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: builds-check ( -- ) builds exists? not [ prepare-build-machine ] when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: status-vm
+SYMBOL: status-boot
+SYMBOL: status-test
+SYMBOL: status-build
+SYMBOL: status-release
+SYMBOL: status
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: reset-status ( -- )
+ { status-vm status-boot status-test status-build status-release status }
+ [ off ]
+ each ;
--- /dev/null
+
+USING: kernel namespaces accessors smtp builder.util builder.common ;
+
+IN: builder.email
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: builder-from
+SYMBOL: builder-recipients
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: subject-status ( -- str ) status get [ "report" ] [ "error" ] if ;
+
+: subject ( -- str ) { "builder@" host-name* ": " subject-status } to-string ;
+
+: email-report ( -- )
+ <email>
+ builder-from get >>from
+ builder-recipients get >>to
+ subject >>subject
+ "report" file>string >>body
+ send-email ;
+
--- /dev/null
+
+USING: kernel combinators system sequences io.files io.launcher prettyprint
+ builder.util
+ builder.common ;
+
+IN: builder.release.archive
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: base-name ( -- string )
+ { "factor" [ os unparse ] cpu- stamp> } to-strings "-" join ;
+
+: extension ( -- extension )
+ {
+ { [ os winnt? ] [ ".zip" ] }
+ { [ os macosx? ] [ ".dmg" ] }
+ { [ os unix? ] [ ".tar.gz" ] }
+ }
+ cond ;
+
+: archive-name ( -- string ) base-name extension append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
+
+: macosx-archive-cmd ( -- cmd )
+ { "hdiutil" "create"
+ "-srcfolder" "factor"
+ "-fs" "HFS+"
+ "-volname" "factor"
+ archive-name } ;
+
+: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: archive-cmd ( -- cmd )
+ {
+ { [ os windows? ] [ windows-archive-cmd ] }
+ { [ os macosx? ] [ macosx-archive-cmd ] }
+ { [ os unix? ] [ unix-archive-cmd ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-archive ( -- ) archive-cmd to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: releases ( -- path )
+ builds "releases" append-path
+ dup exists? not
+ [ dup make-directory ]
+ when ;
+
+: save-archive ( -- ) archive-name releases move-file-into ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel system namespaces sequences prettyprint io.files io.launcher
+ bootstrap.image
+ builder.util
+ builder.common ;
+
+IN: builder.release.branch
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: branch-name ( -- string ) "clean-" platform append ;
+
+: refspec ( -- string ) "master:" branch-name append ;
+
+: push-to-clean-branch ( -- )
+ { "git" "push" "factorcode.org:/git/factor.git" refspec }
+ to-strings
+ try-process ;
+
+: upload-clean-image ( -- )
+ {
+ "scp"
+ my-boot-image-name
+ "factorcode.org:/var/www/factorcode.org/newsite/images/clean"
+ }
+ to-strings
+ try-process ;
+
+: (update-clean-branch) ( -- )
+ "factor"
+ [
+ push-to-clean-branch
+ upload-clean-image
+ ]
+ with-directory ;
+
+: update-clean-branch ( -- )
+ upload-to-factorcode get
+ [ (update-clean-branch) ]
+ when ;
-USING: kernel system namespaces sequences splitting combinators
- io.files io.launcher
- bake combinators.cleave builder.common builder.util ;
+USING: kernel debugger system namespaces sequences splitting combinators
+ io io.files io.launcher prettyprint bootstrap.image
+ bake combinators.cleave
+ builder.util
+ builder.common
+ builder.release.branch
+ builder.release.tidy
+ builder.release.archive
+ builder.release.upload ;
IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: releases ( -- path )
- builds "releases" path+
- dup exists? not
- [ dup make-directory ]
- when ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: common-files ( -- seq )
- {
- "boot.x86.32.image"
- "boot.x86.64.image"
- "boot.macosx-ppc.image"
- "vm"
- "temp"
- "logs"
- ".git"
- ".gitignore"
- "Makefile"
- "cp_dir"
- "unmaintained"
- "misc/target"
- "misc/wordsize"
- "misc/wordsize.c"
- "misc/macos-release.sh"
- "misc/source-release.sh"
- "misc/windows-release.sh"
- "misc/version.sh"
- } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cpu- ( -- cpu ) cpu "." split "-" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: extension ( -- extension )
- os
- {
- { "linux" [ ".tar.gz" ] }
- { "winnt" [ ".zip" ] }
- { "macosx" [ ".dmg" ] }
- }
- case ;
-
-: archive-name ( -- string ) base-name extension append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: windows-archive-cmd ( -- cmd ) { "zip" "-r" archive-name "factor" } ;
-
-: macosx-archive-cmd ( -- cmd )
- { "hdiutil" "create"
- "-srcfolder" "factor"
- "-fs" "HFS+"
- "-volname" "factor"
- archive-name } ;
-
-: unix-archive-cmd ( -- cmd ) { "tar" "-cvzf" archive-name "factor" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: archive-cmd ( -- cmd )
- {
- { [ windows? ] [ windows-archive-cmd ] }
- { [ macosx? ] [ macosx-archive-cmd ] }
- { [ unix? ] [ unix-archive-cmd ] }
- }
- cond ;
-
-: make-archive ( -- ) archive-cmd to-strings try-process ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: remove-common-files ( -- )
- { "rm" "-rf" common-files } to-strings try-process ;
-
-: remove-factor-app ( -- )
- macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
-
-: release ( -- )
- "factor"
- [
- remove-factor-app
- remove-common-files
- ]
- with-directory
+: (release) ( -- )
+ update-clean-branch
+ tidy
make-archive
- archive-name releases move-file-into ;
+ upload
+ save-archive
+ status-release on ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: release? ( -- ? )
- {
- "./load-everything-vocabs"
- "./test-all-vocabs"
- }
- [ eval-file empty? ]
- all? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: clean-build? ( -- ? )
+ { "load-everything-vocabs" "test-all-vocabs" } [ eval-file empty? ] all? ;
-: maybe-release ( -- ) release? [ release ] when ;
\ No newline at end of file
+: release ( -- ) [ clean-build? [ (release) ] when ] try ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel system io.files io.launcher builder.util ;
+
+IN: builder.release.tidy
+
+: common-files ( -- seq )
+ {
+ "boot.x86.32.image"
+ "boot.x86.64.image"
+ "boot.macosx-ppc.image"
+ "boot.linux-ppc.image"
+ "vm"
+ "temp"
+ "logs"
+ ".git"
+ ".gitignore"
+ "Makefile"
+ "unmaintained"
+ "build-support"
+ } ;
+
+: remove-common-files ( -- )
+ { "rm" "-rf" common-files } to-strings try-process ;
+
+: remove-factor-app ( -- )
+ os macosx? not [ { "rm" "-rf" "Factor.app" } try-process ] when ;
+
+: tidy ( -- )
+ "factor" [ remove-factor-app remove-common-files ] with-directory ;
--- /dev/null
+
+USING: kernel namespaces io io.files
+ builder.util
+ builder.common
+ builder.release.archive ;
+
+IN: builder.release.upload
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-location ( -- dest )
+ "factorcode.org:/var/www/factorcode.org/newsite/downloads"
+ platform
+ append-path ;
+
+: (upload) ( -- )
+ { "scp" archive-name remote-location } to-strings
+ [ "Error uploading binary to factorcode" print ]
+ run-or-bail ;
+
+: upload ( -- )
+ upload-to-factorcode get
+ [ (upload) ]
+ when ;
--- /dev/null
+
+USING: kernel namespaces debugger system io io.files io.sockets
+ io.encodings.utf8 prettyprint benchmark
+ builder.util builder.common ;
+
+IN: builder.report
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: (report) ( -- )
+
+ "Build machine: " write host-name print
+ "CPU: " write cpu .
+ "OS: " write os .
+ "Build directory: " write build-dir print
+ "git id: " write "git-id" eval-file print nl
+
+ status-vm get f = [ "compile-log" cat "vm compile error" throw ] when
+ status-boot get f = [ "boot-log" cat "Boot error" throw ] when
+ status-test get f = [ "test-log" 100 cat-n "Test error" throw ] when
+
+ "Boot time: " write "boot-time" eval-file milli-seconds>time print
+ "Load time: " write "load-time" eval-file milli-seconds>time print
+ "Test time: " write "test-time" eval-file milli-seconds>time print nl
+
+ "Did not pass load-everything: " print "load-everything-vocabs" cat
+
+ "Did not pass test-all: " print "test-all-vocabs" cat
+ "test-failures" cat
+
+ "help-lint results:" print "help-lint" cat
+
+ "Benchmarks: " print "benchmarks" eval-file benchmarks. ;
+
+: report ( -- ) "report" utf8 [ [ (report) ] try ] with-file-writer ;
\ No newline at end of file
-USING: kernel namespaces sequences assocs builder continuations
- vocabs vocabs.loader
- io
- io.files
- prettyprint
- tools.vocabs
- tools.test
- io.encodings.utf8
- combinators.cleave
+USING: kernel namespaces assocs
+ io.files io.encodings.utf8 prettyprint
help.lint
- bootstrap.stage2 benchmark builder.util ;
+ benchmark
+ bootstrap.stage2
+ tools.test tools.vocabs
+ builder.util ;
IN: builder.test
: do-load ( -- )
try-everything keys "../load-everything-vocabs" utf8 [ . ] with-file-writer ;
-! : do-tests ( -- )
-! run-all-tests keys "../test-all-vocabs" utf8 [ . ] with-file-writer ;
-
: do-tests ( -- )
run-all-tests
[ keys "../test-all-vocabs" utf8 [ . ] with-file-writer ]
[ "../test-failures" utf8 [ test-failures. ] with-file-writer ]
bi ;
-! : do-tests ( -- )
-! run-all-tests
-! "../test-all-vocabs" utf8
-! [
-! [ keys . ]
-! [ test-failures. ]
-! bi
-! ]
-! with-file-writer ;
-
: do-help-lint ( -- )
"" run-help-lint "../help-lint" utf8 [ typos. ] with-file-writer ;
--- /dev/null
+
+USING: kernel io.launcher bootstrap.image bootstrap.image.download
+ builder.util builder.common ;
+
+IN: builder.updates
+
+: git-pull-cmd ( -- cmd )
+ {
+ "git"
+ "pull"
+ "--no-summary"
+ "git://factorcode.org/git/factor.git"
+ "master"
+ } ;
+
+: updates-available? ( -- ? )
+ git-id
+ git-pull-cmd try-process
+ git-id
+ = not ;
+
+: new-image-available? ( -- ? )
+ my-boot-image-name need-new-image?
+ [ download-my-image t ]
+ [ f ]
+ if ;
+
+: new-code-available? ( -- ? )
+ updates-available?
+ new-image-available?
+ or ;
\ No newline at end of file
USING: kernel words namespaces classes parser continuations
io io.files io.launcher io.sockets
math math.parser
+ system
combinators sequences splitting quotations arrays strings tools.time
- sequences.deep new-slots accessors assocs.lib
+ sequences.deep accessors assocs.lib
io.encodings.utf8
combinators.cleave bake calendar calendar.format ;
: to-string ( obj -- str )
dup class
{
- { string [ ] }
- { quotation [ call ] }
- { word [ execute ] }
- { fixnum [ number>string ] }
- { array [ to-strings concat ] }
+ { \ string [ ] }
+ { \ quotation [ call ] }
+ { \ word [ execute ] }
+ { \ fixnum [ number>string ] }
+ { \ array [ to-strings concat ] }
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! TUPLE: process* arguments stdin stdout stderr timeout ;
-
-! : <process*> process* construct-empty ;
-
-! : >desc ( process* -- desc )
-! H{ } clone
-! over arguments>> [ +arguments+ swap put-at ] when*
-! over stdin>> [ +stdin+ swap put-at ] when*
-! over stdout>> [ +stdout+ swap put-at ] when*
-! over stderr>> [ +stderr+ swap put-at ] when*
-! over timeout>> [ +timeout+ swap put-at ] when*
-! nip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: host-name* ( -- name ) host-name "." split first ;
: datestamp ( -- string )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: longer? ( seq seq -- ? ) [ length ] 2apply > ;
+: longer? ( seq seq -- ? ) [ length ] bi@ > ;
: maybe-tail* ( seq n -- seq )
2dup longer?
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: failsafe ( quot -- ) [ drop ] recover ;
+: cpu- ( -- cpu ) cpu unparse "." split "-" join ;
+
+: platform ( -- string ) { [ os unparse ] cpu- } to-strings "-" join ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: gnu-make ( -- string )
+ os { freebsd openbsd netbsd } member? [ "gmake" ] [ "make" ] if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-id ( -- id )
+ { "git" "show" } utf8 <process-stream> [ readln ] with-stream
+ " " split second ;
-USING: alien alien.c-types arrays sequences math
-math.vectors math.matrices math.parser io io.files kernel opengl
-opengl.gl opengl.glu shuffle http.client vectors
-namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting
-combinators tools.time system combinators.lib combinators.cleave
-float-arrays continuations opengl.demo-support multiline
-ui.gestures
-bunny.fixed-pipeline bunny.cel-shaded bunny.outlined bunny.model ;
+USING: alien alien.c-types arrays sequences math math.vectors
+math.matrices math.parser io io.files kernel opengl opengl.gl
+opengl.glu shuffle http.client vectors namespaces ui.gadgets
+ui.gadgets.canvas ui.render ui splitting combinators tools.time
+system combinators.lib float-arrays continuations
+opengl.demo-support multiline ui.gestures bunny.fixed-pipeline
+bunny.cel-shaded bunny.outlined bunny.model ;
IN: bunny
TUPLE: bunny-gadget model geom draw-seq draw-n ;
USING: tools.deploy.config ;
H{
- { deploy-math? t }
- { deploy-reflection 1 }
+ { deploy-word-defs? f }
+ { deploy-random? f }
{ deploy-name "Bunny" }
{ deploy-threads? t }
- { deploy-word-props? f }
- { "stop-after-last-window?" t }
- { deploy-ui? t }
- { deploy-io 3 }
{ deploy-compiler? t }
- { deploy-word-defs? f }
+ { deploy-math? t }
{ deploy-c-types? f }
+ { deploy-io 3 }
+ { deploy-reflection 1 }
+ { deploy-ui? t }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
-USING: alien alien.c-types arrays sequences math math.vectors math.matrices
- math.parser io io.files kernel opengl opengl.gl opengl.glu io.encodings.ascii
- opengl.capabilities shuffle http.client vectors splitting tools.time system
- combinators combinators.cleave float-arrays continuations namespaces
- sequences.lib ;
+USING: alien alien.c-types arrays sequences math math.vectors
+math.matrices math.parser io io.files kernel opengl opengl.gl
+opengl.glu io.encodings.ascii opengl.capabilities shuffle
+http.client vectors splitting tools.time system combinators
+float-arrays continuations namespaces sequences.lib ;
IN: bunny.model
: numbers ( str -- seq )
numbers {
{ [ dup length 5 = ] [ 3 head pick push ] }
{ [ dup first 3 = ] [ 1 tail over push ] }
- { [ t ] [ drop ] }
+ [ drop ]
} cond (parse-model)
] when* ;
: <bunny-dlist> ( model -- geom )
GL_COMPILE [ first3 draw-triangles ] make-dlist
- bunny-dlist construct-boa ;
+ bunny-dlist boa ;
: <bunny-buffers> ( model -- geom )
- [
- [ first concat ] [ second concat ] bi
- append >float-array
- GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
- ] [
- third concat >c-uint-array
- GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
- ]
- [ first length 3 * ] [ third length 3 * ] tetra
- bunny-buffers construct-boa ;
+ {
+ [
+ [ first concat ] [ second concat ] bi
+ append >float-array
+ GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
+ ]
+ [
+ third concat >c-uint-array
+ GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
+ ]
+ [ first length 3 * ]
+ [ third length 3 * ]
+ } cleave bunny-buffers boa ;
GENERIC: bunny-geom ( geom -- )
GENERIC: draw-bunny ( geom draw -- )
-USING: arrays bunny.model bunny.cel-shaded
-combinators.cleave continuations kernel math multiline
-opengl opengl.shaders opengl.framebuffers opengl.gl
-opengl.capabilities sequences ui.gadgets combinators.cleave ;
+USING: arrays bunny.model bunny.cel-shaded continuations kernel
+math multiline opengl opengl.shaders opengl.framebuffers
+opengl.gl opengl.capabilities sequences ui.gadgets combinators ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
--- /dev/null
+USING: arrays byte-arrays help.markup help.syntax kernel\r
+byte-vectors.private combinators ;\r
+IN: byte-vectors\r
+\r
+ARTICLE: "byte-vectors" "Byte vectors"\r
+"A byte vector is a resizable mutable sequence of unsigned bytes. Byte vector words are found in the " { $vocab-link "byte-vectors" } " vocabulary."\r
+$nl\r
+"Byte vectors form a class:"\r
+{ $subsection byte-vector }\r
+{ $subsection byte-vector? }\r
+"Creating byte vectors:"\r
+{ $subsection >byte-vector }\r
+{ $subsection <byte-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: BV{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
+{ $code "BV{ } clone" } ;\r
+\r
+ABOUT: "byte-vectors"\r
+\r
+HELP: byte-vector\r
+{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;\r
+\r
+HELP: <byte-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
+{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
+\r
+HELP: >byte-vector\r
+{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
+{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
+{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
+\r
+HELP: byte-array>vector\r
+{ $values { "byte-array" "an array" } { "length" "a non-negative integer" } { "byte-vector" byte-vector } }\r
+{ $description "Creates a new byte vector using the array for underlying storage with the specified initial length." }\r
+{ $warning "This word is in the " { $vocab-link "byte-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >byte-vector } " instead." } ;\r
+\r
+HELP: BV{\r
+{ $syntax "BV{ elements... }" }\r
+{ $values { "elements" "a list of bytes" } }\r
+{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
--- /dev/null
+IN: byte-vectors.tests\r
+USING: tools.test byte-vectors vectors sequences kernel ;\r
+\r
+[ 0 ] [ 123 <byte-vector> length ] unit-test\r
+\r
+: do-it\r
+ 123 [ over push ] each ;\r
+\r
+[ t ] [\r
+ 3 <byte-vector> do-it\r
+ 3 <vector> do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ BV{ } byte-vector? ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays kernel kernel.private math sequences\r
+sequences.private growable byte-arrays prettyprint.backend\r
+parser accessors ;\r
+IN: byte-vectors\r
+\r
+TUPLE: byte-vector underlying fill ;\r
+\r
+M: byte-vector underlying underlying>> { byte-array } declare ;\r
+\r
+M: byte-vector set-underlying (>>underlying) ;\r
+\r
+M: byte-vector length fill>> { array-capacity } declare ;\r
+\r
+M: byte-vector set-fill (>>fill) ;\r
+\r
+<PRIVATE\r
+\r
+: byte-array>vector ( byte-array length -- byte-vector )\r
+ byte-vector boa ; inline\r
+\r
+PRIVATE>\r
+\r
+: <byte-vector> ( n -- byte-vector )\r
+ <byte-array> 0 byte-array>vector ; inline\r
+\r
+: >byte-vector ( seq -- byte-vector )\r
+ T{ byte-vector f B{ } 0 } clone-like ;\r
+\r
+M: byte-vector like\r
+ drop dup byte-vector? [\r
+ dup byte-array?\r
+ [ dup length byte-array>vector ] [ >byte-vector ] if\r
+ ] unless ;\r
+\r
+M: byte-vector new-sequence\r
+ drop [ <byte-array> ] keep >fixnum byte-array>vector ;\r
+\r
+M: byte-vector equal?\r
+ over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: byte-array new-resizable drop <byte-vector> ;\r
+\r
+INSTANCE: byte-vector growable\r
+\r
+: BV{ \ } [ >byte-vector ] parse-literal ; parsing\r
+\r
+M: byte-vector >pprint-sequence ;\r
+\r
+M: byte-vector pprint-delims drop \ BV{ \ } ;\r
--- /dev/null
+Growable byte arrays
--- /dev/null
+collections
! - most of the matrix stuff
! - most of the query functions
-
USING: alien alien.syntax combinators system ;
-
IN: cairo.ffi
<< "cairo" {
- { [ win32? ] [ "cairo.dll" ] }
- ! { [ macosx? ] [ "libcairo.dylib" ] }
- { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
- { [ unix? ] [ "libcairo.so.2" ] }
+ { [ os winnt? ] [ "libcairo-2.dll" ] }
+ ! { [ os macosx? ] [ "libcairo.dylib" ] }
+ { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
+ { [ os unix? ] [ "libcairo.so.2" ] }
} cond "cdecl" add-library >>
LIBRARY: cairo
CAIRO_HINT_METRICS_ON
;
+FUNCTION: char* cairo_status_to_string ( cairo_status_t status ) ;
+FUNCTION: cairo_status_t cairo_status ( cairo_t* cr ) ;
+
: cairo_create ( cairo_surface_t -- cairo_t )
"cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types cairo.ffi continuations destructors
-kernel libc locals math combinators.cleave shuffle new-slots
-accessors ;
+kernel libc locals math shuffle accessors ;
IN: cairo.lib
TUPLE: cairo-t alien ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.cleave kernel new-slots
-accessors math ui.gadgets ui.render opengl.gl byte-arrays
-namespaces opengl cairo.ffi cairo.lib ;
+USING: arrays kernel accessors math ui.gadgets ui.render
+opengl.gl byte-arrays namespaces opengl cairo.ffi cairo.lib
+inspector sequences combinators io.backend ;
IN: cairo.png
TUPLE: png surface width height cairo-t array ;
TUPLE: png-gadget png ;
+ERROR: cairo-error string ;
+
+: check-zero ( n -- n )
+ dup zero? [
+ "PNG dimension is 0" cairo-error
+ ] when ;
+
+: cairo-png-error ( n -- )
+ {
+ { CAIRO_STATUS_NO_MEMORY [ "Cairo: no memory" cairo-error ] }
+ { CAIRO_STATUS_FILE_NOT_FOUND [ "Cairo: file not found" cairo-error ] }
+ { CAIRO_STATUS_READ_ERROR [ "Cairo: read error" cairo-error ] }
+ [ drop ]
+ } cond ;
+
: <png> ( path -- png )
+ normalize-path
cairo_image_surface_create_from_png
- dup [ cairo_image_surface_get_width ]
- [ cairo_image_surface_get_height ] [ ] tri
- cairo-surface>array png construct-boa ;
+ dup cairo_surface_status cairo-png-error
+ dup [ cairo_image_surface_get_width check-zero ]
+ [ cairo_image_surface_get_height check-zero ] [ ] tri
+ cairo-surface>array png boa ;
: write-png ( png path -- )
>r png-surface r>
png>>
[ width>> ]
[ height>> GL_RGBA GL_UNSIGNED_BYTE ]
+ ! [ height>> GL_BGRA GL_UNSIGNED_BYTE ]
[ array>> ] tri
glDrawPixels
] with-translation ;
M: png-gadget ungraft* ( gadget -- )
png>> surface>> cairo_destroy ;
+
+! "resource:misc/icons/Factor_1x16.png" USE: cairo.png <png-gadget> gadget.
-USING: kernel ;
+USING: kernel system ;
IN: calendar.backend
-SYMBOL: calendar-backend
-HOOK: gmt-offset calendar-backend
+HOOK: gmt-offset os ( -- hours minutes seconds )
continuations system ;
IN: calendar.tests
-[ f ] [ 2004 12 32 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 2 30 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2003 2 29 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 -2 9 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12 0 0 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12 1 24 0 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12 1 23 60 0 0 <timestamp> valid-timestamp? ] unit-test
-[ f ] [ 2004 12 1 23 59 60 0 <timestamp> valid-timestamp? ] unit-test
+\ time+ must-infer
+\ time* must-infer
+\ time- must-infer
+
+[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 -2 9 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 0 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 24 0 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 23 60 0 instant <timestamp> valid-timestamp? ] unit-test
+[ f ] [ 2004 12 1 23 59 60 instant <timestamp> valid-timestamp? ] unit-test
[ t ] [ now valid-timestamp? ] unit-test
[ f ] [ 1900 leap-year? ] unit-test
[ f ] [ 2001 leap-year? ] unit-test
[ f ] [ 2006 leap-year? ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 1 seconds time+
- 2006 10 10 0 0 1 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
- 2006 10 10 0 1 40 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
- 2006 10 9 23 58 20 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
- 2006 10 11 0 0 0 0 <timestamp> = ] unit-test
-
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10 minutes time+
- 2006 10 10 0 10 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
- 2006 10 10 0 10 30 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
- 2006 10 10 0 0 45 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
- 2006 10 9 23 59 15 0 <timestamp> = ] unit-test
-
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> 7200 minutes time+
- 2006 10 15 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
- 2006 10 9 23 50 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
- 2006 10 9 22 20 0 0 <timestamp> = ] unit-test
-
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 hours time+
- 2006 1 1 1 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
- 2006 1 2 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
- 2005 12 31 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
- 2006 1 1 12 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
- 2006 1 4 0 0 0 0 <timestamp> = ] unit-test
-
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 days time+
- 2006 1 2 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
- 2005 12 31 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
- 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
- 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
- 2004 12 31 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
- 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
-
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 11 months time+
- 2006 12 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
- 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
- 2008 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
- 2007 2 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
- 2006 2 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
- 2006 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
- 2005 12 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
- 2005 11 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
- 2004 12 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
- 2004 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
- 2005 3 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
- 2003 3 1 0 0 0 0 <timestamp> = ] unit-test
-
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 years time+
- 2006 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
- 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
- 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
- 1906 1 1 0 0 0 0 <timestamp> = ] unit-test
-! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
-! 2003 2 28 0 0 0 0 <timestamp> = ] unit-test
-
-[ 5 ] [ 2006 7 14 0 0 0 0 <timestamp> day-of-week ] unit-test
-
-[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 <timestamp> ] 3keep 0 0 0 0 <timestamp> = ] unit-test
-
-[ 1 ] [ 2006 1 1 0 0 0 0 <timestamp> day-of-year ] unit-test
-[ 60 ] [ 2004 2 29 0 0 0 0 <timestamp> day-of-year ] unit-test
-[ 61 ] [ 2004 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
-[ 366 ] [ 2004 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
-[ 365 ] [ 2003 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
-[ 60 ] [ 2003 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
-
-[ t ] [ 2004 12 31 0 0 0 0 <timestamp> dup = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
- 2009 1 1 0 0 10 0 <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
- 1998 12 31 23 59 50 0 <timestamp> = ] unit-test
-
-[ t ] [ 2004 1 1 23 0 0 12 <timestamp> 0 convert-timezone
- 2004 1 1 11 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
- 2004 1 1 16 0 0 0 <timestamp> = ] unit-test
-[ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
- 2004 1 1 13 30 0 0 <timestamp> = ] unit-test
-
-[ 0 ] [ 2004 1 1 13 30 0 0 <timestamp>
- 2004 1 1 12 30 0 -1 <timestamp> <=> ] unit-test
-
-[ 1 ] [ 2004 1 1 13 30 0 0 <timestamp>
- 2004 1 1 12 30 0 0 <timestamp> <=> ] unit-test
-
-[ -1 ] [ 2004 1 1 12 30 0 0 <timestamp>
- 2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
-
-[ 1 ] [ 2005 1 1 12 30 0 0 <timestamp>
- 2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 1 seconds time+
+ 2006 10 10 0 0 1 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 100 seconds time+
+ 2006 10 10 0 1 40 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 seconds time+
+ 2006 10 9 23 58 20 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 86400 seconds time+
+ 2006 10 11 0 0 0 instant <timestamp> = ] unit-test
+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10 minutes time+
+ 2006 10 10 0 10 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 10.5 minutes time+
+ 2006 10 10 0 10 30 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 3/4 minutes time+
+ 2006 10 10 0 0 45 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -3/4 minutes time+
+ 2006 10 9 23 59 15 instant <timestamp> = ] unit-test
+
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> 7200 minutes time+
+ 2006 10 15 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -10 minutes time+
+ 2006 10 9 23 50 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 10 10 0 0 0 instant <timestamp> -100 minutes time+
+ 2006 10 9 22 20 0 instant <timestamp> = ] unit-test
+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 hours time+
+ 2006 1 1 1 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 hours time+
+ 2006 1 2 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 hours time+
+ 2005 12 31 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 hours time+
+ 2006 1 1 12 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 72 hours time+
+ 2006 1 4 0 0 0 instant <timestamp> = ] unit-test
+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 days time+
+ 2006 1 2 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 days time+
+ 2005 12 31 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 365 days time+
+ 2007 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -365 days time+
+ 2005 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 365 days time+
+ 2004 12 31 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 366 days time+
+ 2005 1 1 0 0 0 instant <timestamp> = ] unit-test
+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 11 months time+
+ 2006 12 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 12 months time+
+ 2007 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 24 months time+
+ 2008 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 13 months time+
+ 2007 2 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 months time+
+ 2006 2 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 months time+
+ 2006 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 months time+
+ 2005 12 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -2 months time+
+ 2005 11 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -13 months time+
+ 2004 12 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -24 months time+
+ 2004 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 2 29 0 0 0 instant <timestamp> 12 months time+
+ 2005 3 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 2 29 0 0 0 instant <timestamp> -12 months time+
+ 2003 3 1 0 0 0 instant <timestamp> = ] unit-test
+
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 0 years time+
+ 2006 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> 1 years time+
+ 2007 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -1 years time+
+ 2005 1 1 0 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2006 1 1 0 0 0 instant <timestamp> -100 years time+
+ 1906 1 1 0 0 0 instant <timestamp> = ] unit-test
+! [ t ] [ 2004 2 29 0 0 0 instant <timestamp> -1 years time+
+! 2003 2 28 0 0 0 instant <timestamp> = ] unit-test
+
+[ 5 ] [ 2006 7 14 0 0 0 instant <timestamp> day-of-week ] unit-test
+
+[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 instant <timestamp> ] 3keep 0 0 0 instant <timestamp> = ] unit-test
+
+[ 1 ] [ 2006 1 1 0 0 0 instant <timestamp> day-of-year ] unit-test
+[ 60 ] [ 2004 2 29 0 0 0 instant <timestamp> day-of-year ] unit-test
+[ 61 ] [ 2004 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
+[ 366 ] [ 2004 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
+[ 365 ] [ 2003 12 31 0 0 0 instant <timestamp> day-of-year ] unit-test
+[ 60 ] [ 2003 3 1 0 0 0 instant <timestamp> day-of-year ] unit-test
+
+[ t ] [ 2004 12 31 0 0 0 instant <timestamp> dup = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> 10 seconds 5 years time+ time+
+ 2009 1 1 0 0 10 instant <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 0 0 0 instant <timestamp> -10 seconds -5 years time+ time+
+ 1998 12 31 23 59 50 instant <timestamp> = ] unit-test
+
+[ t ] [ 2004 1 1 23 0 0 12 hours <timestamp> >gmt
+ 2004 1 1 11 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 5 0 0 -11 hours <timestamp> >gmt
+ 2004 1 1 16 0 0 instant <timestamp> = ] unit-test
+[ t ] [ 2004 1 1 23 0 0 9+1/2 hours <timestamp> >gmt
+ 2004 1 1 13 30 0 instant <timestamp> = ] unit-test
+
+[ 0 ] [ 2004 1 1 13 30 0 instant <timestamp>
+ 2004 1 1 12 30 0 -1 hours <timestamp> <=> ] unit-test
+
+[ 1 ] [ 2004 1 1 13 30 0 instant <timestamp>
+ 2004 1 1 12 30 0 instant <timestamp> <=> ] unit-test
+
+[ -1 ] [ 2004 1 1 12 30 0 instant <timestamp>
+ 2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
+
+[ 1 ] [ 2005 1 1 12 30 0 instant <timestamp>
+ 2004 1 1 13 30 0 instant <timestamp> <=> ] unit-test
[ t ] [ now timestamp>millis millis - 1000 < ] unit-test
[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions namespaces sequences
-strings tuples system vocabs.loader calendar.backend threads
-new-slots accessors combinators ;
+strings system vocabs.loader calendar.backend threads
+accessors combinators locals classes.tuple ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
C: <timestamp> timestamp
-: <date> ( year month day -- timestamp )
- 0 0 0 gmt-offset <timestamp> ;
-
TUPLE: duration year month day hour minute second ;
C: <duration> duration
+: gmt-offset-duration ( -- duration )
+ 0 0 0 gmt-offset <duration> ;
+
+: <date> ( year month day -- timestamp )
+ 0 0 0 gmt-offset-duration <timestamp> ;
+
: month-names
{
"Not a month" "January" "February" "March" "April" "May" "June"
PRIVATE>
-: julian-day-number ( year month day -- n )
+:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
- [
- 14 pick - 12 /i a set
- pick 4800 + a get - y set
- over 12 a get * + 3 - m set
- 2nip 153 m get * 2 + 5 /i + 365 y get * +
- y get 4 /i + y get 100 /i - y get 400 /i + 32045 -
- ] with-scope ;
-
-: julian-day-number>date ( n -- year month day )
+ [let* | a [ 14 month - 12 /i ]
+ y [ year 4800 + a - ]
+ m [ month 12 a * + 3 - ] |
+ day 153 m * 2 + 5 /i + 365 y * +
+ y 4 /i + y 100 /i - y 400 /i + 32045 -
+ ] ;
+
+:: julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number
- [
- 32044 + a set
- 4 a get * 3 + 146097 /i b set
- a get 146097 b get * 4 /i - c set
- 4 c get * 3 + 1461 /i d set
- c get 1461 d get * 4 /i - e set
- 5 e get * 2 + 153 /i m set
- 100 b get * d get + 4800 -
- m get 10 /i + m get 3 +
- 12 m get 10 /i * -
- e get 153 m get * 2 + 5 /i - 1+
- ] with-scope ;
+ [let* | a [ n 32044 + ]
+ b [ 4 a * 3 + 146097 /i ]
+ c [ a 146097 b * 4 /i - ]
+ d [ 4 c * 3 + 1461 /i ]
+ e [ c 1461 d * 4 /i - ]
+ m [ 5 e * 2 + 153 /i ] |
+ 100 b * d + 4800 -
+ m 10 /i + m 3 +
+ 12 m 10 /i * -
+ e 153 m * 2 + 5 /i - 1+
+ ] ;
: >date< ( timestamp -- year month day )
- { year>> month>> day>> } get-slots ;
+ [ year>> ] [ month>> ] [ day>> ] tri ;
: >time< ( timestamp -- hour minute second )
- { hour>> minute>> second>> } get-slots ;
+ [ hour>> ] [ minute>> ] [ second>> ] tri ;
: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
: years ( n -- dt ) instant swap >>year ;
[ month>> +month ] keep
[ year>> +year ] keep ; inline
-: +slots [ 2apply + ] curry 2keep ; inline
+: +slots [ bi@ + ] curry 2keep ; inline
PRIVATE>
#! Uses average month/year length since dt loses calendar
#! data
0 swap
- [ year>> + ] keep
- [ month>> months-per-year / + ] keep
- [ day>> days-per-year / + ] keep
- [ hour>> hours-per-year / + ] keep
- [ minute>> minutes-per-year / + ] keep
- second>> seconds-per-year / + ;
+ {
+ [ year>> + ]
+ [ month>> months-per-year / + ]
+ [ day>> days-per-year / + ]
+ [ hour>> hours-per-year / + ]
+ [ minute>> minutes-per-year / + ]
+ [ second>> seconds-per-year / + ]
+ } cleave ;
M: duration <=> [ dt>years ] compare ;
: dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ;
-: convert-timezone ( timestamp n -- timestamp )
+GENERIC: time- ( time1 time2 -- time )
+
+: convert-timezone ( timestamp duration -- timestamp )
over gmt-offset>> over = [ drop ] [
- [ over gmt-offset>> - hours time+ ] keep >>gmt-offset
+ [ over gmt-offset>> time- time+ ] keep >>gmt-offset
] if ;
: >local-time ( timestamp -- timestamp )
- gmt-offset convert-timezone ;
+ gmt-offset-duration convert-timezone ;
: >gmt ( timestamp -- timestamp )
- 0 convert-timezone ;
+ instant convert-timezone ;
M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ;
: (time-) ( timestamp timestamp -- n )
- [ >gmt ] 2apply
- [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
- [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
-
-GENERIC: time- ( time1 time2 -- time )
+ [ >gmt ] bi@
+ [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
+ [ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ;
M: timestamp time-
#! Exact calendar-time difference
(time-) seconds ;
+: time* ( obj1 obj2 -- obj3 )
+ dup real? [ swap ] when
+ dup real? [ * ] [
+ {
+ [ year>> * ]
+ [ month>> * ]
+ [ day>> * ]
+ [ hour>> * ]
+ [ minute>> * ]
+ [ second>> * ]
+ } 2cleave <duration>
+ ] if ;
+
: before ( dt -- -dt )
- [ year>> neg ] keep
- [ month>> neg ] keep
- [ day>> neg ] keep
- [ hour>> neg ] keep
- [ minute>> neg ] keep
- second>> neg
- <duration> ;
+ -1 time* ;
M: duration time-
before time+ ;
-: <zero> 0 0 0 0 0 0 0 <timestamp> ;
+: <zero> 0 0 0 0 0 0 instant <timestamp> ;
: valid-timestamp? ( timestamp -- ? )
- clone 0 >>gmt-offset
+ clone instant >>gmt-offset
dup <zero> time- <zero> time+ = ;
: unix-1970 ( -- timestamp )
- 1970 1 1 0 0 0 0 <timestamp> ; foldable
+ 1970 1 1 0 0 0 instant <timestamp> ; foldable
: millis>timestamp ( n -- timestamp )
>r unix-1970 r> milliseconds time+ ;
M: duration sleep from-now sleep-until ;
{
- { [ unix? ] [ "calendar.unix" ] }
- { [ windows? ] [ "calendar.windows" ] }
+ { [ os unix? ] [ "calendar.unix" ] }
+ { [ os windows? ] [ "calendar.windows" ] }
} cond require
+USING: calendar.format calendar kernel math tools.test\r
+io.streams.string accessors io ;\r
IN: calendar.format.tests\r
-USING: calendar.format tools.test io.streams.string ;\r
\r
[ 0 ] [\r
- "Z" [ read-rfc3339-gmt-offset ] with-string-reader\r
+ "Z" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours\r
] unit-test\r
\r
[ 1 ] [\r
- "+01" [ read-rfc3339-gmt-offset ] with-string-reader\r
+ "+01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours\r
] unit-test\r
\r
[ -1 ] [\r
- "-01" [ read-rfc3339-gmt-offset ] with-string-reader\r
+ "-01" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours\r
] unit-test\r
\r
[ -1-1/2 ] [\r
- "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader\r
+ "-01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours\r
] unit-test\r
\r
[ 1+1/2 ] [\r
- "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader\r
+ "+01:30" [ read1 read-rfc3339-gmt-offset ] with-string-reader dt>hours\r
] unit-test\r
+\r
+[ ] [ now timestamp>rfc3339 drop ] unit-test\r
+[ ] [ now timestamp>rfc822 drop ] unit-test\r
+\r
+[ 8/1000 -4 ] [\r
+ "2008-04-19T04:56:00.008-04:00" rfc3339>timestamp\r
+ [ second>> ] [ gmt-offset>> hour>> ] bi\r
+] unit-test\r
+\r
+[ T{ duration f 0 0 0 0 0 0 } ] [\r
+ "GMT" parse-rfc822-gmt-offset\r
+] unit-test\r
+\r
+[ T{ duration f 0 0 0 -5 0 0 } ] [\r
+ "-0500" parse-rfc822-gmt-offset\r
+] unit-test\r
+\r
+[ T{ timestamp f 2008 4 22 14 36 12 T{ duration f 0 0 0 0 0 0 } } ] [\r
+ "Tue, 22 Apr 2008 14:36:12 GMT" rfc822>timestamp\r
+] unit-test\r
+\r
+[ t ] [ now dup timestamp>rfc822 rfc822>timestamp time- 1 seconds before? ] unit-test\r
-IN: calendar.format\r
USING: math math.parser kernel sequences io calendar\r
-accessors arrays io.streams.string combinators accessors ;\r
+accessors arrays io.streams.string splitting\r
+combinators accessors debugger ;\r
+IN: calendar.format\r
\r
GENERIC: day. ( obj -- )\r
\r
: timestamp>string ( timestamp -- str )\r
[ (timestamp>string) ] with-string-writer ;\r
\r
-: (write-gmt-offset) ( ratio -- )\r
- 1 /mod swap write-00 60 * write-00 ;\r
+: (write-gmt-offset) ( duration -- )\r
+ [ hour>> write-00 ] [ minute>> write-00 ] bi ;\r
\r
: write-gmt-offset ( gmt-offset -- )\r
- {\r
- { [ dup zero? ] [ drop "GMT" write ] }\r
- { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] }\r
- { [ dup 0 > ] [ "+" write (write-gmt-offset) ] }\r
- } cond ;\r
+ dup instant <=> sgn {\r
+ { 0 [ drop "GMT" write ] }\r
+ { -1 [ "-" write before (write-gmt-offset) ] }\r
+ { 1 [ "+" write (write-gmt-offset) ] }\r
+ } case ;\r
\r
-: timestamp>rfc822-string ( timestamp -- str )\r
+: timestamp>rfc822 ( timestamp -- str )\r
#! RFC822 timestamp format\r
#! Example: Tue, 15 Nov 1994 08:12:31 +0200\r
[\r
: timestamp>http-string ( timestamp -- str )\r
#! http timestamp format\r
#! Example: Tue, 15 Nov 1994 08:12:31 GMT\r
- >gmt timestamp>rfc822-string ;\r
-\r
-: write-rfc3339-gmt-offset ( n -- )\r
- dup zero? [ drop "Z" write ] [\r
- dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if\r
- 60 * 60 /mod swap write-00 CHAR: : write1 write-00\r
- ] if ;\r
-\r
+ >gmt timestamp>rfc822 ;\r
+\r
+: (write-rfc3339-gmt-offset) ( duration -- )\r
+ [ hour>> write-00 CHAR: : write1 ]\r
+ [ minute>> write-00 ] bi ;\r
+\r
+: write-rfc3339-gmt-offset ( duration -- )\r
+ dup instant <=> sgn {\r
+ { 0 [ drop "Z" write ] }\r
+ { -1 [ CHAR: - write1 before (write-rfc3339-gmt-offset) ] }\r
+ { 1 [ CHAR: + write1 (write-rfc3339-gmt-offset) ] }\r
+ } case ;\r
+ \r
: (timestamp>rfc3339) ( timestamp -- )\r
- dup year>> number>string write CHAR: - write1\r
- dup month>> write-00 CHAR: - write1\r
- dup day>> write-00 CHAR: T write1\r
- dup hour>> write-00 CHAR: : write1\r
- dup minute>> write-00 CHAR: : write1\r
- dup second>> >fixnum write-00\r
- gmt-offset>> write-rfc3339-gmt-offset ;\r
+ {\r
+ [ year>> number>string write CHAR: - write1 ]\r
+ [ month>> write-00 CHAR: - write1 ]\r
+ [ day>> write-00 CHAR: T write1 ]\r
+ [ hour>> write-00 CHAR: : write1 ]\r
+ [ minute>> write-00 CHAR: : write1 ]\r
+ [ second>> >fixnum write-00 ]\r
+ [ gmt-offset>> write-rfc3339-gmt-offset ]\r
+ } cleave ;\r
\r
: timestamp>rfc3339 ( timestamp -- str )\r
[ (timestamp>rfc3339) ] with-string-writer ;\r
\r
: read-00 2 read string>number ;\r
\r
+: read-000 3 read string>number ;\r
+\r
: read-0000 4 read string>number ;\r
\r
-: read-rfc3339-gmt-offset ( -- n )\r
- read1 dup CHAR: Z = [ drop 0 ] [\r
- { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case\r
- read-00\r
- read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case\r
- 60 / + *\r
+: signed-gmt-offset ( dt ch -- dt' )\r
+ { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case time* ;\r
+\r
+: read-rfc3339-gmt-offset ( ch -- dt )\r
+ dup CHAR: Z = [ drop instant ] [\r
+ >r\r
+ read-00 hours\r
+ read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes\r
+ time+\r
+ r> signed-gmt-offset\r
] if ;\r
\r
: read-ymd ( -- y m d )\r
read-ymd\r
"Tt" expect\r
read-hms\r
- read-rfc3339-gmt-offset ! timezone\r
+ read1 { { CHAR: . [ read-000 1000 / + read1 ] } [ ] } case\r
+ read-rfc3339-gmt-offset\r
<timestamp> ;\r
\r
: rfc3339>timestamp ( str -- timestamp )\r
[ (rfc3339>timestamp) ] with-string-reader ;\r
\r
+ERROR: invalid-rfc822-date ;\r
+\r
+: check-rfc822-date ( obj/f -- obj ) [ invalid-rfc822-date ] unless* ;\r
+\r
+: read-token ( seps -- token )\r
+ [ read-until ] keep member? check-rfc822-date drop ;\r
+\r
+: read-sp ( -- token ) " " read-token ;\r
+\r
+: checked-number ( str -- n )\r
+ string>number check-rfc822-date ;\r
+\r
+: parse-rfc822-gmt-offset ( string -- dt )\r
+ dup "GMT" = [ drop instant ] [\r
+ unclip >r\r
+ 2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+\r
+ r> signed-gmt-offset\r
+ ] if ;\r
+\r
+: (rfc822>timestamp) ( -- timestamp )\r
+ timestamp new\r
+ "," read-token day-abbreviations3 member? check-rfc822-date drop\r
+ read1 CHAR: \s assert=\r
+ read-sp checked-number >>day\r
+ read-sp month-abbreviations index check-rfc822-date >>month\r
+ read-sp checked-number >>year\r
+ ":" read-token checked-number >>hour\r
+ ":" read-token checked-number >>minute\r
+ " " read-token checked-number >>second\r
+ readln parse-rfc822-gmt-offset >>gmt-offset ;\r
+\r
+: rfc822>timestamp ( str -- timestamp )\r
+ [ (rfc822>timestamp) ] with-string-reader ;\r
+\r
: (ymdhms>timestamp) ( -- timestamp )\r
- read-ymd " " expect read-hms 0 <timestamp> ;\r
+ read-ymd " " expect read-hms instant <timestamp> ;\r
\r
: ymdhms>timestamp ( str -- timestamp )\r
[ (ymdhms>timestamp) ] with-string-reader ;\r
\r
: (hms>timestamp) ( -- timestamp )\r
- f f f read-hms f <timestamp> ;\r
+ f f f read-hms instant <timestamp> ;\r
\r
: hms>timestamp ( str -- timestamp )\r
[ (hms>timestamp) ] with-string-reader ;\r
\r
: (ymd>timestamp) ( -- timestamp )\r
- read-ymd f f f f <timestamp> ;\r
+ read-ymd f f f instant <timestamp> ;\r
\r
: ymd>timestamp ( str -- timestamp )\r
[ (ymd>timestamp) ] with-string-reader ;\r
[\r
[ month>> month-abbreviations nth write ] keep bl\r
[ day>> number>string 2 32 pad-left write ] keep bl\r
- dup now [ year>> ] 2apply = [\r
+ dup now [ year>> ] bi@ = [\r
[ hour>> write-00 ] keep ":" write\r
minute>> write-00\r
] [\r
-
USING: alien alien.c-types arrays calendar.backend
- kernel structs math unix.time namespaces ;
-
+kernel structs math unix.time namespaces system ;
IN: calendar.unix
-TUPLE: unix-calendar ;
-
-T{ unix-calendar } calendar-backend set-global
-
-: get-time
+: get-time ( -- alien )
f time <uint> localtime ;
-: timezone-name
+: timezone-name ( -- string )
get-time tm-zone ;
-M: unix-calendar gmt-offset
- get-time tm-gmtoff 3600 / ;
+M: unix gmt-offset ( -- hours minutes seconds )
+ get-time tm-gmtoff 3600 /mod 60 /mod ;
-USING: calendar.backend namespaces alien.c-types
-windows windows.kernel32 kernel math ;
+USING: calendar.backend namespaces alien.c-types system
+windows windows.kernel32 kernel math combinators ;
IN: calendar.windows
-TUPLE: windows-calendar ;
-
-T{ windows-calendar } calendar-backend set-global
-
-: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline
-
-M: windows-calendar gmt-offset ( -- float )
+M: windows gmt-offset ( -- hours minutes seconds )
"TIME_ZONE_INFORMATION" <c-object>
- dup GetTimeZoneInformation
- TIME_ZONE_ID_INVALID = [ win32-error ] when
- TIME_ZONE_INFORMATION-Bias 60 / neg ;
+ dup GetTimeZoneInformation {
+ { TIME_ZONE_ID_INVALID [ win32-error-string throw ] }
+ { TIME_ZONE_ID_UNKNOWN [ TIME_ZONE_INFORMATION-Bias ] }
+ { TIME_ZONE_ID_STANDARD [ TIME_ZONE_INFORMATION-Bias ] }
+ { TIME_ZONE_ID_DAYLIGHT [
+ [ TIME_ZONE_INFORMATION-Bias ]
+ [ TIME_ZONE_INFORMATION-DaylightBias ] bi +
+ ] }
+ } case neg 60 /mod 0 ;
+++ /dev/null
-Joe Groff
\ No newline at end of file
+++ /dev/null
-Stanford Bunny rendered with a cel-shading GLSL program
\ No newline at end of file
+++ /dev/null
-demos
-opengl
-glsl
\ No newline at end of file
sequences sequences.lib namespaces.lib splitting
math math.functions math.vectors math.trig
opengl.gl opengl.glu opengl ui ui.gadgets.slate
- combinators.cleave vars
+ vars
random-weighted colors.hsv cfdg.gl ;
IN: cfdg
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi add ;
+: hsva>rgba ( hsva -- rgba ) [ 3 head hsv>rgb ] [ peek ] bi suffix ;
: gl-set-hsba ( hsva -- ) hsva>rgba gl-color ;
TUPLE: channel receivers senders ;
: <channel> ( -- channel )
- V{ } clone V{ } clone channel construct-boa ;
+ V{ } clone V{ } clone channel boa ;
GENERIC: to ( value channel -- )
GENERIC: from ( channel -- value )
PRIVATE>
: publish ( channel -- id )
- random-256 dup >r remote-channels set-at r> ;
+ 256 random-bits dup >r remote-channels set-at r> ;
: get-channel ( id -- channel )
remote-channels at ;
[ CHAR: t ] [ "test" <circular> 0 swap nth ] unit-test
[ "test" ] [ "test" <circular> >string ] unit-test
-[ "test" <circular> 5 swap nth ] must-fail
[ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
[ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
[ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test
[ "fob" ] [ "foo" <circular> CHAR: b 2 pick set-nth >string ] unit-test
-[ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
[ "boo" ] [ "foo" <circular> CHAR: b 3 pick set-nth-unsafe >string ] unit-test
[ "ornact" ] [ "factor" <circular> 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test
[ "bcd" ] [ 3 <circular-string> "abcd" [ over push-circular ] each >string ] unit-test
[ { 0 0 } ] [ { 0 0 } <circular> -1 over change-circular-start >array ] unit-test
+
+! This no longer fails
+! [ "test" <circular> 5 swap nth ] must-fail
+! [ "foo" <circular> CHAR: b 3 rot set-nth ] must-fail
! Copyright (C) 2005, 2006 Alex Chapman, Daniel Ehrenberg
! See http;//factorcode.org/license.txt for BSD license
-USING: kernel sequences math sequences.private strings ;
+USING: kernel sequences math sequences.private strings
+accessors ;
IN: circular
! a circular sequence wraps another sequence, but begins at an
TUPLE: circular seq start ;
: <circular> ( seq -- circular )
- 0 circular construct-boa ;
+ 0 circular boa ;
: circular-wrap ( n circular -- n circular )
- [ circular-start + ] keep
- [ circular-seq length rem ] keep ; inline
+ [ start>> + ] keep
+ [ seq>> length rem ] keep ; inline
-M: circular length circular-seq length ;
+M: circular length seq>> length ;
-M: circular virtual@ circular-wrap circular-seq ;
+M: circular virtual@ circular-wrap seq>> ;
-M: circular nth bounds-check virtual@ nth ;
+M: circular nth virtual@ nth ;
-M: circular set-nth bounds-check virtual@ set-nth ;
+M: circular set-nth virtual@ set-nth ;
+
+M: circular virtual-seq seq>> ;
: change-circular-start ( n circular -- )
#! change start to (start + n) mod length
- circular-wrap set-circular-start ;
+ circular-wrap (>>start) ;
: push-circular ( elt circular -- )
- [ set-first ] keep 1 swap change-circular-start ;
+ [ set-first ] [ 1 swap change-circular-start ] bi ;
: <circular-string> ( n -- circular )
0 <string> <circular> ;
-M: circular virtual-seq circular-seq ;
-
INSTANCE: circular virtual-sequence
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: help.syntax help.markup kernel prettyprint sequences ;
+IN: classes.tuple.lib
+
+HELP: >tuple<
+{ $values { "class" "a tuple class" } }
+{ $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." }
+{ $example
+ "USING: kernel prettyprint classes.tuple.lib ;"
+ "TUPLE: foo a b c ;"
+ "1 2 3 \\ foo boa \\ foo >tuple< .s"
+ "1\n2\n3"
+}
+{ $notes "Words using " { $snippet ">tuple<" } " may be compiled." }
+{ $see-also >tuple*< } ;
+
+HELP: >tuple*<
+{ $values { "class" "a tuple class" } }
+{ $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." }
+{ $example
+ "USING: kernel prettyprint classes.tuple.lib ;"
+ "TUPLE: foo a bb* ccc dddd* ;"
+ "1 2 3 4 \\ foo boa \\ foo >tuple*< .s"
+ "2\n4"
+}
+{ $notes "Words using " { $snippet ">tuple*<" } " may be compiled." }
+{ $see-also >tuple< } ;
+
--- /dev/null
+USING: kernel tools.test classes.tuple.lib ;
+IN: classes.tuple.lib.tests
+
+TUPLE: foo a b* c d* e f* ;
+
+[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple< ] unit-test
+[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple*< ] unit-test
+
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel macros sequences slots words mirrors ;
+IN: classes.tuple.lib
+
+: reader-slots ( seq -- quot )
+ [ slot-spec-reader ] map [ get-slots ] curry ;
+
+MACRO: >tuple< ( class -- )
+ all-slots 1 tail-slice reader-slots ;
+
+MACRO: >tuple*< ( class -- )
+ all-slots
+ [ slot-spec-name "*" tail? ] subset
+ reader-slots ;
+
+
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien io kernel namespaces core-foundation cocoa.messages
-cocoa cocoa.classes cocoa.runtime sequences threads
-debugger init inspector kernel.private ;
+USING: alien io kernel namespaces core-foundation
+core-foundation.run-loop cocoa.messages cocoa cocoa.classes
+cocoa.runtime sequences threads debugger init inspector
+kernel.private ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
: with-cocoa ( quot -- )
[ NSApp drop call ] with-autorelease-pool ;
-: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" <NSString> ;
-
: next-event ( app -- event )
0 f CFRunLoopDefaultMode 1
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;
TUPLE: objc-error alien reason ;
: objc-error ( alien -- * )
- dup -> reason CF>string \ objc-error construct-boa throw ;
+ dup -> reason CF>string \ objc-error boa throw ;
M: objc-error summary ( error -- )
drop "Objective C exception" ;
"foo:"
"void"
{ "id" "SEL" "NSRect" }
- [ data-gc "x" set 2drop ]
+ [ gc "x" set 2drop ]
} ;
: test-foo
"NSArray"
"NSAutoreleasePool"
"NSBundle"
+ "NSDictionary"
"NSError"
"NSEvent"
"NSException"
"NSMenu"
"NSMenuItem"
+ "NSMutableDictionary"
"NSNib"
"NSNotification"
"NSNotificationCenter"
[ -> filenames CF>string-array ] [ drop f ] if ;
: split-path ( path -- dir file )
- "/" last-split1 [ <NSString> ] 2apply ;
+ "/" last-split1 [ <NSString> ] bi@ ;
: save-panel ( path -- paths )
<NSSavePanel> dup
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.compiler
+USING: alien alien.c-types alien.strings alien.compiler
arrays assocs combinators compiler inference.transforms kernel
math namespaces parser prettyprint prettyprint.sections
quotations sequences strings words cocoa.runtime io macros
-memoize debugger ;
+memoize debugger io.encodings.ascii ;
IN: cocoa.messages
: make-sender ( method function -- quot )
TUPLE: selector name object ;
-MEMO: <selector> ( name -- sel ) f \ selector construct-boa ;
+MEMO: <selector> ( name -- sel ) f \ selector boa ;
: selector ( selector -- alien )
dup selector-object expired? [
: lookup-method ( selector -- method )
dup objc-methods get at
- [ ] [ "No such method: " swap append throw ] ?if ;
+ [ ] [ "No such method: " prepend throw ] ?if ;
: make-dip ( quot n -- quot' )
dup
! Runtime introspection
: (objc-class) ( string word -- class )
dupd execute
- [ ] [ "No such class: " swap append throw ] ?if ; inline
+ [ ] [ "No such class: " prepend throw ] ?if ; inline
: objc-class ( string -- class )
\ objc_getClass (objc-class) ;
: method-arg-type ( method i -- type )
f <void*> 0 <int> over
>r method_getArgumentInfo drop
- r> *char* ;
+ r> *void* ascii alien>string ;
SYMBOL: objc>alien-types
{ "NSRect" "{_NSRect=ffff}" }
{ "NSSize" "{_NSSize=ff}" }
{ "NSRange" "{_NSRange=II}" }
-} union alien>objc-types set-global
+} assoc-union alien>objc-types set-global
: objc-struct-type ( i string -- ctype )
2dup CHAR: = -rot index* swap subseq
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
- { [ t ] [ 2nip 1string objc>alien-types get at ] }
+ [ 2nip 1string objc>alien-types get at ]
} cond ;
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: strings arrays hashtables assocs sequences
-xml.writer xml.utilities kernel namespaces ;
+cocoa.messages cocoa.classes cocoa.application cocoa kernel
+namespaces io.backend ;
IN: cocoa.plists
-GENERIC: >plist ( obj -- tag )
+: assoc>NSDictionary ( assoc -- alien )
+ NSMutableDictionary over assoc-size -> dictionaryWithCapacity:
+ [
+ [
+ spin [ <NSString> ] bi@ -> setObject:forKey:
+ ] curry assoc-each
+ ] keep ;
-M: string >plist "string" build-tag ;
-
-M: array >plist
- [ >plist ] map "array" build-tag* ;
-
-M: hashtable >plist
- >alist [ >r "key" build-tag r> >plist ] assoc-map concat
- "dict" build-tag* ;
-
-: build-plist ( obj -- tag )
- >plist 1array "plist" build-tag*
- dup { { "version" "1.0" } } update ;
-
-: plist>string ( obj -- string )
- build-plist build-xml xml>string ;
+: write-plist ( assoc path -- )
+ >r assoc>NSDictionary
+ r> normalize-path <NSString> 0 -> writeToFile:atomically:
+ [ "write-plist failed" throw ] unless ;
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays assocs combinators compiler
-hashtables kernel libc math namespaces parser sequences words
-cocoa.messages cocoa.runtime compiler.units ;
+USING: alien alien.c-types alien.strings arrays assocs
+combinators compiler hashtables kernel libc math namespaces
+parser sequences words cocoa.messages cocoa.runtime
+compiler.units io.encodings.ascii ;
IN: cocoa.subclassing
: init-method ( method alien -- )
>r first3 r>
[ >r execute r> set-objc-method-imp ] keep
- [ >r malloc-char-string r> set-objc-method-types ] keep
+ [ >r ascii malloc-string r> set-objc-method-types ] keep
>r sel_registerName r> set-objc-method-name ;
: <empty-method-list> ( n -- alien )
: <objc-class> ( name info -- class )
"objc-class" malloc-object
[ set-objc-class-info ] keep
- [ >r malloc-char-string r> set-objc-class-name ] keep ;
+ [ >r ascii malloc-string r> set-objc-class-name ] keep ;
: <protocol-list> ( name -- protocol-list )
"objc-protocol-list" malloc-object
r> <method-list> class_addMethods ;
: encode-types ( return types -- encoding )
- swap add* [
+ swap prefix [
alien>objc-types get at "0" append
] map concat ;
: <ViewWindow> ( view rect -- window )
<NSWindow> [ swap -> setContentView: ] keep
dup dup -> contentView -> setInitialFirstResponder:
- dup 1 -> setAcceptsMouseMovedEvents: ;
+ dup 1 -> setAcceptsMouseMovedEvents:
+ dup 0 -> setReleasedWhenClosed: ;
: window-content-rect ( window -- rect )
NSWindow over -> frame rot -> styleMask
swap model-value over set-gadget-interior relayout-1 ;
: <color-model> ( model -- model )
- [ [ 256 /f ] map 1 add <solid> ] <filter> ;
+ [ [ 256 /f ] map 1 suffix <solid> ] <filter> ;
: <color-sliders> ( -- model gadget )
3 [ drop 0 0 0 255 <range> ] map
! Copyright (C) 2007 Eduardo Cavazos
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators arrays sequences math math.functions
- combinators.cleave ;
+USING: kernel combinators arrays sequences math math.functions ;
IN: colors.hsv
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+USING: help.markup help.syntax sequences ;
+IN: columns
+
+ARTICLE: "columns" "Column sequences"
+"A " { $emphasis "column" } " presents a column of a matrix represented as a sequence of rows:"
+{ $subsection column }
+{ $subsection <column> } ;
+
+HELP: column
+{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
+
+HELP: <column> ( seq n -- column )
+{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
+{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
+{ $examples
+ { $example
+ "USING: arrays prettyprint columns ;"
+ "{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } 0 <column> >array ."
+ "{ 1 4 7 }"
+ }
+}
+{ $notes
+ "In the same sense that " { $link <reversed> } " is a virtual variant of " { $link reverse } ", " { $link <column> } " is a virtual variant of " { $snippet "swap [ nth ] curry map" } "."
+} ;
+
+ABOUT: "columns"
--- /dev/null
+IN: columns.tests
+USING: columns sequences kernel namespaces arrays tools.test math ;
+
+! Columns
+{ { 1 2 3 } { 4 5 6 } { 7 8 9 } } [ clone ] map "seq" set
+
+[ { 1 4 7 } ] [ "seq" get 0 <column> >array ] unit-test
+[ ] [ "seq" get 1 <column> [ sq ] change-each ] unit-test
+[ { 4 25 64 } ] [ "seq" get 1 <column> >array ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel accessors ;
+IN: columns
+
+! A column of a matrix
+TUPLE: column seq col ;
+
+C: <column> column
+
+M: column virtual-seq seq>> ;
+M: column virtual@ dup col>> -rot seq>> nth bounds-check ;
+M: column length seq>> length ;
+
+INSTANCE: column virtual-sequence
--- /dev/null
+Virtual sequence view of a matrix column
--- /dev/null
+collections
+++ /dev/null
-
-USING: kernel quotations help.syntax help.markup ;
-
-IN: combinators.cleave
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "cleave-combinators" "Cleave Combinators"
-
-"Basic cleavers:"
-
-{ $subsection bi }
-{ $subsection tri }
-
-"General cleave: "
-{ $subsection cleave }
-
-"Cleave combinators for quotations with arity 2:"
-{ $subsection 2bi }
-{ $subsection 2tri }
-
-{ $notes
- "From the Merriam-Webster Dictionary: "
- $nl
- { $strong "cleave" }
- { $list
- { $emphasis "To divide by or as if by a cutting blow" }
- { $emphasis "To separate into distinct parts and especially into "
- "groups having divergent views" } }
- $nl
- "The Joy programming language has a " { $emphasis "cleave" } " combinator." }
-
-;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-HELP: bi
-
- { $values { "x" object }
- { "p" quotation }
- { "q" quotation }
-
- { "p(x)" "p applied to x" }
- { "q(x)" "q applied to x" } } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-HELP: tri
-
- { $values { "x" object }
- { "p" quotation }
- { "q" quotation }
- { "r" quotation }
-
- { "p(x)" "p applied to x" }
- { "q(x)" "q applied to x" }
- { "r(x)" "r applied to x" } } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-HELP: cleave
-
-{ $code "( obj { q1 q2 ... qN } -- q1(obj) q2(obj) ... qN(obj) )" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-{ bi tri cleave 2bi 2tri } related-words
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-ARTICLE: "spread-combinators" "Spread Combinators"
-
-{ $subsection bi* }
-{ $subsection tri* }
-{ $subsection spread } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-HELP: bi*
-
- { $values { "x" object }
- { "y" object }
- { "p" quotation }
- { "q" quotation }
-
- { "p(x)" "p applied to x" }
- { "q(y)" "q applied to y" } } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-HELP: tri*
-
- { $values { "x" object }
- { "y" object }
- { "z" object }
- { "p" quotation }
- { "q" quotation }
- { "r" quotation }
-
- { "p(x)" "p applied to x" }
- { "q(y)" "q applied to y" }
- { "r(z)" "r applied to z" } } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-HELP: spread
-
-{ $code "( v1 v2 ... vN { q1 q2 ... qN } -- q1(v1) q2(v2) ... qN(vN) )" } ;
\ No newline at end of file
-USING: kernel sequences macros ;
+USING: kernel arrays sequences macros combinators ;
IN: combinators.cleave
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! The cleaver family
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bi ( x p q -- p(x) q(x) ) >r keep r> call ; inline
-: tri ( x p q r -- p(x) q(x) r(x) ) >r pick >r bi r> r> call ; inline
-
-: tetra ( obj quot quot quot quot -- val val val val )
- >r >r pick >r bi r> r> r> bi ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 2bi ( x y p q -- p(x,y) q(x,y) ) >r 2keep r> call ; inline
-
-: 2tri ( x y z p q r -- p(x,y,z) q(x,y,z) r(x,y,z) )
- >r >r 2keep r> 2keep r> call ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! General cleave
-
-MACRO: cleave ( seq -- )
- dup
- [ drop [ dup ] ] map concat
- swap
- dup
- [ drop [ >r ] ] map concat
- swap
- [ [ r> ] append ] map concat
- 3append
- [ drop ]
- append ;
-
-MACRO: 2cleave ( seq -- )
- dup
- [ drop [ 2dup ] ] map concat
- swap
- dup
- [ drop [ >r >r ] ] map concat
- swap
- [ [ r> r> ] append ] map concat
- 3append
- [ 2drop ]
- append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! The spread family
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: bi* ( x y p q -- p(x) q(y) ) >r swap slip r> call ; inline
-
-: tri* ( x y z p q r -- p(x) q(y) r(z) )
- >r rot >r bi* r> r> call ; inline
-
-: tetra* ( obj obj obj obj quot quot quot quot -- val val val val )
- >r roll >r tri* r> r> call ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! General spread
-
-MACRO: spread ( seq -- )
- dup
- [ drop [ >r ] ] map concat
- swap
- [ [ r> ] swap append ] map concat
- append ;
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Cleave into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ >quots ] [ length ] bi
'[ , 2cleave , narray ] ;
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {1} ( x -- {x} ) 1array ; inline
+: {2} ( x y -- {x,y} ) 2array ; inline
+: {3} ( x y z -- {x,y,z} ) 3array ; inline
+
+: {n} narray ;
+
+: {bi} ( x p q -- {p(x),q(x)} ) bi {2} ; inline
+
+: {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Spread into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: <arr*> ( seq -- )
[ >quots ] [ length ] bi
'[ , spread , narray ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {bi*} ( x y p q -- {p(x),q(y)} ) bi* {2} ; inline
+: {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline
[ dup array? ] [ dup vector? ] [ dup float? ]
} || nip
] unit-test
+
+
+{ 1 1 } [
+ [ even? ] [ drop 1 ] [ drop 2 ] ifte
+] must-infer-as
-! Copyright (C) 2007 Slava Pestov, Chris Double, Doug Coleman,
-! Eduardo Cavazos, Daniel Ehrenberg.
+! Copyright (C) 2007, 2008 Slava Pestov, Chris Double,
+! Doug Coleman, Eduardo Cavazos,
+! Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel combinators namespaces quotations hashtables
+USING: kernel combinators fry namespaces quotations hashtables
sequences assocs arrays inference effects math math.ranges
-arrays.lib shuffle macros bake combinators.cleave
-continuations ;
+arrays.lib shuffle macros bake continuations ;
IN: combinators.lib
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: generate ( generator predicate -- obj )
- #! Call 'generator' until the result satisfies 'predicate'.
- [ slip over slip ] 2keep
- roll [ 2drop ] [ rot drop generate ] if ; inline
-
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Generalized versions of core combinators
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: napply ( n -- )
2 [a,b]
- [ [ ] [ 1- ] bi
- [ , ntuck , nslip ]
- bake ]
+ [ [ 1- ] [ ] bi
+ '[ , ntuck , nslip ] ]
map concat >quotation [ call ] append ;
: 3apply ( obj obj obj quot -- ) 3 napply ; inline
[ [ not ] append [ f ] ] t short-circuit ;
MACRO: <-&& ( quots -- )
- [ [ dup ] swap append [ not ] append [ f ] ] t short-circuit
+ [ [ dup ] prepend [ not ] append [ f ] ] t short-circuit
[ nip ] append ;
MACRO: <--&& ( quots -- )
- [ [ 2dup ] swap append [ not ] append [ f ] ] t short-circuit
+ [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit
[ 2nip ] append ;
MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ;
! ifte
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+MACRO: preserving ( predicate -- quot )
+ dup infer effect-in
+ dup 1+
+ '[ , , nkeep , nrot ] ;
+
MACRO: ifte ( quot quot quot -- )
- pick infer effect-in
- dup 1+ swap
- [ >r >r , nkeep , nrot r> r> if ]
- bake ;
+ '[ , preserving , , if ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! switch
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: preserving ( predicate -- quot )
- dup infer effect-in
- dup 1+ spin
- [ , , nkeep , nrot ]
- bake ;
-
MACRO: switch ( quot -- )
- [ [ preserving ] [ ] bi* ] assoc-map
- [ , cond ]
- bake ;
+ [ [ [ preserving ] curry ] dip ] assoc-map
+ [ cond ] curry ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ (make-call-with) ] keep length [ narray ] curry compose ;
: (make-call-with2) ( quots -- quot )
- [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
+ [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
[ 2drop ] append ;
MACRO: map-call-with2 ( quots -- )
[
- [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat
+ [ [ 2dup >r >r ] prepend [ r> r> ] append ] map concat
[ 2drop ] append
] keep length [ narray ] curry append ;
[ 1quotation ] map [ map-call-with ] curry ;
MACRO: construct-slots ( assoc tuple-class -- tuple )
- [ construct-empty ] curry swap [
+ [ new ] curry swap [
[ dip ] curry swap 1quotation [ keep ] curry compose
] { } assoc>map concat compose ;
: retry ( quot n -- )
[ drop ] rot compose attempt-all ; inline
+
+: do-while ( pred body tail -- )
+ >r tuck 2slip r> while ;
+
+: generate ( generator predicate -- obj )
+ [ dup ] swap [ dup [ nip ] unless not ] 3compose
+ swap [ ] do-while ;
IN: concurrency.combinators.tests\r
USING: concurrency.combinators tools.test random kernel math \r
-concurrency.mailboxes threads sequences ;\r
+concurrency.mailboxes threads sequences accessors ;\r
\r
[ [ drop ] parallel-each ] must-infer\r
[ [ ] parallel-map ] must-infer\r
[ { 1 4 9 } ] [ { 1 2 3 } [ 1000 random sleep sq ] parallel-map ] unit-test\r
\r
[ { 1 2 3 } [ dup 2 mod 0 = [ "Even" throw ] when ] parallel-map ]\r
-[ delegate "Even" = ] must-fail-with\r
+[ error>> "Even" = ] must-fail-with\r
\r
[ V{ 0 3 6 9 } ]\r
[ 10 [ 3 mod zero? ] parallel-subset ] unit-test\r
\r
: <count-down> ( n -- count-down )\r
dup 0 < [ "Invalid count for count down" throw ] when\r
- <promise> \ count-down construct-boa\r
+ <promise> \ count-down boa\r
dup count-down-check ;\r
\r
: count-down ( count-down -- )\r
-IN: concurrency.distributed.tests\r
-USING: tools.test concurrency.distributed kernel io.files\r
-arrays io.sockets system combinators threads math sequences\r
-concurrency.messaging ;\r
-\r
-: test-node\r
- {\r
- { [ unix? ] [ "distributed-concurrency-test" temp-file <local> ] }\r
- { [ windows? ] [ "127.0.0.1" 1238 <inet4> ] }\r
- } cond ;\r
-\r
-[ ] [ test-node dup 1array swap (start-node) ] unit-test\r
-\r
-[ ] [ yield ] unit-test\r
-\r
-[ ] [\r
- [\r
- receive first2 >r 3 + r> send\r
- "thread-a" unregister-process\r
- ] "Thread A" spawn\r
- "thread-a" swap register-process\r
-] unit-test\r
-\r
-[ 8 ] [\r
- 5 self 2array\r
- "thread-a" test-node <remote-process> send\r
-\r
- receive\r
-] unit-test\r
-\r
-[ ] [ test-node stop-node ] unit-test\r
+IN: concurrency.distributed.tests
+USING: tools.test concurrency.distributed kernel io.files
+arrays io.sockets system combinators threads math sequences
+concurrency.messaging continuations ;
+
+: test-node
+ {
+ { [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
+ { [ os windows? ] [ "127.0.0.1" 1238 <inet4> ] }
+ } cond ;
+
+[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
+
+[ ] [ test-node dup 1array swap (start-node) ] unit-test
+
+[ ] [ yield ] unit-test
+
+[ ] [
+ [
+ receive first2 >r 3 + r> send
+ "thread-a" unregister-process
+ ] "Thread A" spawn
+ "thread-a" swap register-process
+] unit-test
+
+[ 8 ] [
+ 5 self 2array
+ "thread-a" test-node <remote-process> send
+
+ receive
+] unit-test
+
+[ ] [ test-node stop-node ] unit-test
! Copyright (C) 2005 Chris Double. All Rights Reserved.
! See http://factorcode.org/license.txt for BSD license.
-USING: serialize sequences concurrency.messaging
-threads io io.server qualified arrays
-namespaces kernel io.encodings.binary combinators.cleave
-new-slots accessors ;
+USING: serialize sequences concurrency.messaging threads io
+io.server qualified arrays namespaces kernel io.encodings.binary
+accessors ;
QUALIFIED: io.sockets
IN: concurrency.distributed
TUPLE: exchanger thread object ;\r
\r
: <exchanger> ( -- exchanger )\r
- <box> <box> exchanger construct-boa ;\r
+ <box> <box> exchanger boa ;\r
\r
: exchange ( obj exchanger -- newobj )\r
dup exchanger-thread box-full? [\r
TUPLE: flag value? thread ;
-: <flag> ( -- flag ) f <box> flag construct-boa ;
+: <flag> ( -- flag ) f <box> flag boa ;
: raise-flag ( flag -- )
dup flag-value? [
TUPLE: lock threads owner reentrant? ;\r
\r
: <lock> ( -- lock )\r
- <dlist> f f lock construct-boa ;\r
+ <dlist> f f lock boa ;\r
\r
: <reentrant-lock> ( -- lock )\r
- <dlist> f t lock construct-boa ;\r
+ <dlist> f t lock boa ;\r
\r
<PRIVATE\r
\r
TUPLE: rw-lock readers writers reader# writer ;\r
\r
: <rw-lock> ( -- lock )\r
- <dlist> <dlist> 0 f rw-lock construct-boa ;\r
+ <dlist> <dlist> 0 f rw-lock boa ;\r
\r
<PRIVATE\r
\r
{ $description "Repeatedly call the quotation while there are no items in the mailbox." } ;\r
\r
HELP: mailbox-get?\r
-{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }\r
- { "mailbox" mailbox } \r
+{ $values { "mailbox" mailbox } \r
+ { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }\r
{ "obj" object }\r
}\r
{ $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does." } ;\r
\r
\r
ARTICLE: "concurrency.mailboxes" "Mailboxes"\r
-"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error."\r
+"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."\r
{ $subsection mailbox }\r
{ $subsection <mailbox> }\r
"Removing the first element:"\r
"Testing if a mailbox is empty:"\r
{ $subsection mailbox-empty? }\r
{ $subsection while-mailbox-empty } ;\r
+\r
+ABOUT: "concurrency.mailboxes"\r
IN: concurrency.mailboxes.tests\r
-USING: concurrency.mailboxes vectors sequences threads\r
-tools.test math kernel strings ;\r
+USING: concurrency.mailboxes concurrency.count-downs vectors\r
+sequences threads tools.test math kernel strings namespaces\r
+continuations calendar ;\r
\r
[ V{ 1 2 3 } ] [\r
0 <vector>\r
[ V{ 1 2 3 } ] [\r
0 <vector>\r
<mailbox>\r
- [ [ integer? ] swap mailbox-get? swap push ] in-thread\r
- [ [ integer? ] swap mailbox-get? swap push ] in-thread\r
- [ [ integer? ] swap mailbox-get? swap push ] in-thread\r
+ [ [ integer? ] mailbox-get? swap push ] in-thread\r
+ [ [ integer? ] mailbox-get? swap push ] in-thread\r
+ [ [ integer? ] mailbox-get? swap push ] in-thread\r
1 over mailbox-put\r
2 over mailbox-put\r
3 swap mailbox-put\r
[ V{ 1 "junk" 3 "junk2" } [ 456 ] ] [\r
0 <vector>\r
<mailbox>\r
- [ [ integer? ] swap mailbox-get? swap push ] in-thread\r
- [ [ integer? ] swap mailbox-get? swap push ] in-thread\r
- [ [ string? ] swap mailbox-get? swap push ] in-thread\r
- [ [ string? ] swap mailbox-get? swap push ] in-thread\r
+ [ [ integer? ] mailbox-get? swap push ] in-thread\r
+ [ [ integer? ] mailbox-get? swap push ] in-thread\r
+ [ [ string? ] mailbox-get? swap push ] in-thread\r
+ [ [ string? ] mailbox-get? swap push ] in-thread\r
1 over mailbox-put\r
"junk" over mailbox-put\r
[ 456 ] over mailbox-put\r
"junk2" over mailbox-put\r
mailbox-get\r
] unit-test\r
+\r
+<mailbox> "m" set\r
+\r
+1 <count-down> "c" set\r
+1 <count-down> "d" set\r
+\r
+[\r
+ "c" get await\r
+ [ "m" get mailbox-get drop ]\r
+ [ drop "d" get count-down ] recover\r
+] "Mailbox close test" spawn drop\r
+\r
+[ ] [ "c" get count-down ] unit-test\r
+[ ] [ "m" get dispose ] unit-test\r
+[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
+\r
+[ ] [ "m" get dispose ] unit-test\r
+\r
+<mailbox> "m" set\r
+\r
+1 <count-down> "c" set\r
+1 <count-down> "d" set\r
+\r
+[\r
+ "c" get await\r
+ "m" get wait-for-close\r
+ "d" get count-down\r
+] "Mailbox close test" spawn drop\r
+\r
+[ ] [ "c" get count-down ] unit-test\r
+[ ] [ "m" get dispose ] unit-test\r
+[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
+\r
+[ ] [ "m" get dispose ] unit-test\r
IN: concurrency.mailboxes\r
USING: dlists threads sequences continuations\r
namespaces random math quotations words kernel arrays assocs\r
-init system concurrency.conditions ;\r
+init system concurrency.conditions accessors ;\r
\r
-TUPLE: mailbox threads data ;\r
+TUPLE: mailbox threads data closed ;\r
+\r
+: check-closed ( mailbox -- )\r
+ closed>> [ "Mailbox closed" throw ] when ; inline\r
+\r
+M: mailbox dispose\r
+ t >>closed threads>> notify-all ;\r
\r
: <mailbox> ( -- mailbox )\r
- <dlist> <dlist> mailbox construct-boa ;\r
+ <dlist> <dlist> f mailbox boa ;\r
\r
: mailbox-empty? ( mailbox -- bool )\r
- mailbox-data dlist-empty? ;\r
+ data>> dlist-empty? ;\r
\r
: mailbox-put ( obj mailbox -- )\r
- [ mailbox-data push-front ] keep\r
- mailbox-threads notify-all yield ;\r
+ [ data>> push-front ]\r
+ [ threads>> notify-all ] bi yield ;\r
+\r
+: wait-for-mailbox ( mailbox timeout -- )\r
+ >r threads>> r> "mailbox" wait ;\r
\r
-: block-unless-pred ( pred mailbox timeout -- )\r
- 2over mailbox-data dlist-contains? [\r
+: block-unless-pred ( mailbox timeout pred -- )\r
+ pick check-closed\r
+ pick data>> over dlist-contains? [\r
3drop\r
] [\r
- 2dup >r mailbox-threads r> "mailbox" wait\r
- block-unless-pred\r
+ >r 2dup wait-for-mailbox r> block-unless-pred\r
] if ; inline\r
\r
: block-if-empty ( mailbox timeout -- mailbox )\r
+ over check-closed\r
over mailbox-empty? [\r
- 2dup >r mailbox-threads r> "mailbox" wait\r
- block-if-empty\r
+ 2dup wait-for-mailbox block-if-empty\r
] [\r
drop\r
] if ;\r
\r
: mailbox-peek ( mailbox -- obj )\r
- mailbox-data peek-back ;\r
+ data>> peek-back ;\r
\r
: mailbox-get-timeout ( mailbox timeout -- obj )\r
- block-if-empty mailbox-data pop-back ;\r
+ block-if-empty data>> pop-back ;\r
\r
: mailbox-get ( mailbox -- obj )\r
f mailbox-get-timeout ;\r
: mailbox-get-all-timeout ( mailbox timeout -- array )\r
block-if-empty\r
[ dup mailbox-empty? ]\r
- [ dup mailbox-data pop-back ]\r
+ [ dup data>> pop-back ]\r
[ ] unfold nip ;\r
\r
: mailbox-get-all ( mailbox -- array )\r
2drop\r
] if ; inline\r
\r
-: mailbox-get-timeout? ( pred mailbox timeout -- obj )\r
- [ block-unless-pred ] 3keep drop\r
- mailbox-data delete-node-if ; inline\r
+: mailbox-get-timeout? ( mailbox timeout pred -- obj )\r
+ 3dup block-unless-pred\r
+ nip >r data>> r> delete-node-if ; inline\r
+\r
+: mailbox-get? ( mailbox pred -- obj )\r
+ f swap mailbox-get-timeout? ; inline\r
+\r
+: wait-for-close-timeout ( mailbox timeout -- )\r
+ over closed>>\r
+ [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;\r
\r
-: mailbox-get? ( pred mailbox -- obj )\r
- f mailbox-get-timeout? ; inline\r
+: wait-for-close ( mailbox -- )\r
+ f wait-for-close-timeout ;\r
\r
-TUPLE: linked-error thread ;\r
+TUPLE: linked-error error thread ;\r
\r
-: <linked-error> ( error thread -- linked )\r
- { set-delegate set-linked-error-thread }\r
- linked-error construct ;\r
+C: <linked-error> linked-error\r
\r
: ?linked dup linked-error? [ rethrow ] when ;\r
\r
-TUPLE: linked-thread supervisor ;\r
+TUPLE: linked-thread < thread supervisor ;\r
\r
M: linked-thread error-in-thread\r
- [ <linked-error> ] keep\r
- linked-thread-supervisor mailbox-put ;\r
+ [ <linked-error> ] [ supervisor>> ] bi mailbox-put ;\r
\r
: <linked-thread> ( quot name mailbox -- thread' )\r
- >r <thread> linked-thread construct-delegate r>\r
- over set-linked-thread-supervisor ;\r
+ >r linked-thread new-thread r> >>supervisor ;\r
\r
: spawn-linked-to ( quot name mailbox -- thread )\r
<linked-thread> [ (spawn) ] keep ;\r
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
{ $see-also spawn } ;
-ARTICLE: { "concurrency" "messaging" } "Mailboxes"
+ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued."
$nl
"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is."
{ $subsection receive }
{ $subsection receive-timeout }
{ $subsection receive-if }
-{ $subsection receive-if-timeout } ;
+{ $subsection receive-if-timeout }
+{ $see-also "concurrency.mailboxes" } ;
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
!
USING: kernel threads vectors arrays sequences
namespaces tools.test continuations dlists strings math words
-match quotations concurrency.messaging concurrency.mailboxes ;
+match quotations concurrency.messaging concurrency.mailboxes
+concurrency.count-downs accessors ;
IN: concurrency.messaging.tests
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
"crash" throw
] "Linked test" spawn-linked drop
receive
-] [ delegate "crash" = ] must-fail-with
+] [ error>> "crash" = ] must-fail-with
MATCH-VARS: ?from ?to ?value ;
SYMBOL: increment
[ value , self , ] { } make "counter" get send
receive
exit "counter" get send
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Not yet
+
+! 1 <count-down> "c" set
+
+! [
+! "c" get count-down
+! receive drop
+! ] "Bad synchronous send" spawn "t" set
+
+! [ 3 "t" get send-synchronous ] must-fail
\ No newline at end of file
my-mailbox swap mailbox-get-timeout ?linked ;\r
\r
: receive-if ( pred -- message )\r
- my-mailbox mailbox-get? ?linked ; inline\r
+ my-mailbox swap mailbox-get? ?linked ; inline\r
\r
-: receive-if-timeout ( pred timeout -- message )\r
- my-mailbox swap mailbox-get-timeout? ?linked ; inline\r
+: receive-if-timeout ( timeout pred -- message )\r
+ my-mailbox -rot mailbox-get-timeout? ?linked ; inline\r
\r
: rethrow-linked ( error process supervisor -- )\r
>r <linked-error> r> send ;\r
TUPLE: synchronous data sender tag ;\r
\r
: <synchronous> ( data -- sync )\r
- self random-256 synchronous construct-boa ;\r
+ self 256 random-bits synchronous boa ;\r
\r
TUPLE: reply data tag ;\r
\r
: <reply> ( data synchronous -- reply )\r
- synchronous-tag \ reply construct-boa ;\r
+ synchronous-tag \ reply boa ;\r
\r
: synchronous-reply? ( response synchronous -- ? )\r
over reply?\r
TUPLE: promise mailbox ;\r
\r
: <promise> ( -- promise )\r
- <mailbox> promise construct-boa ;\r
+ <mailbox> promise boa ;\r
\r
: promise-fulfilled? ( promise -- ? )\r
promise-mailbox mailbox-empty? not ;\r
\r
: <semaphore> ( n -- semaphore )\r
dup 0 < [ "Cannot have semaphore with negative count" throw ] when\r
- <dlist> semaphore construct-boa ;\r
+ <dlist> semaphore boa ;\r
\r
: wait-to-acquire ( semaphore timeout -- )\r
>r semaphore-threads r> "semaphore" wait ;\r
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.launcher io.styles io hashtables kernel
-sequences sequences.lib assocs system sorting math.parser ;
+sequences sequences.lib assocs system sorting math.parser
+sets ;
IN: contributors
: changelog ( -- authors )
- image parent-directory cd
- "git-log --pretty=format:%an" <process-stream> lines ;
+ image parent-directory [
+ "git-log --pretty=format:%an" <process-stream> lines
+ ] with-directory ;
: patch-counts ( authors -- assoc )
dup prune
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax kernel math sequences ;
+USING: alien alien.c-types alien.strings alien.syntax kernel
+math sequences io.encodings.utf16 ;
IN: core-foundation
TYPEDEF: void* CFAllocatorRef
TYPEDEF: void* CFStringRef
TYPEDEF: void* CFURLRef
TYPEDEF: void* CFUUIDRef
-TYPEDEF: void* CFRunLoopRef
TYPEDEF: bool Boolean
TYPEDEF: int CFIndex
+TYPEDEF: int SInt32
TYPEDEF: double CFTimeInterval
TYPEDEF: double CFAbsoluteTime
FUNCTION: CFURLRef CFURLCopyFileSystemPath ( CFURLRef url, int pathStyle ) ;
-FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, ushort* cStr, CFIndex numChars ) ;
+FUNCTION: CFStringRef CFStringCreateWithCharacters ( CFAllocatorRef allocator, wchar_t* cStr, CFIndex numChars ) ;
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
: CF>string ( alien -- string )
dup CFStringGetLength 1+ "ushort" <c-array> [
>r 0 over CFStringGetLength r> CFStringGetCharacters
- ] keep alien>u16-string ;
+ ] keep utf16n alien>string ;
: CF>string-array ( alien -- seq )
CF>array [ CF>string ] map ;
dup <CFBundle> [
CFBundleLoadExecutable drop
] [
- "Cannot load bundled named " swap append throw
+ "Cannot load bundled named " prepend throw
] ?if ;
-
-FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax kernel math sequences
-namespaces assocs init continuations core-foundation ;
+USING: alien alien.c-types alien.strings alien.syntax kernel
+math sequences namespaces assocs init accessors continuations
+combinators core-foundation core-foundation.run-loop
+io.encodings.utf8 ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
[
event-stream-callbacks global
- [ [ drop expired? not ] assoc-subset ] change-at
- 1 \ event-stream-counter set-global
+ [ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at
] "core-foundation" add-init-hook
-event-stream-callbacks global [ H{ } assoc-like ] change-at
-
: add-event-source-callback ( quot -- id )
event-stream-counter <alien>
[ event-stream-callbacks get set-at ] keep ;
: >event-triple ( n eventPaths eventFlags eventIds -- triple )
[
>r >r >r dup dup
- r> char*-nth ,
+ r> void*-nth utf8 alien>string ,
r> int-nth ,
r> longlong-nth ,
] { } make ;
}
"cdecl" [
[ >event-triple ] 3curry map
- swap event-stream-callbacks get at call
- drop
+ swap event-stream-callbacks get at
+ dup [ call drop ] [ 3drop ] if
] alien-callback ;
-TUPLE: event-stream info handle ;
+TUPLE: event-stream info handle closed ;
: <event-stream> ( quot paths latency flags -- event-stream )
>r >r >r
>r master-event-source-callback r>
r> r> r> <FSEventStream>
dup enable-event-stream
- event-stream construct-boa ;
+ f event-stream boa ;
M: event-stream dispose
- dup event-stream-info remove-event-source-callback
- event-stream-handle dup disable-event-stream
- FSEventStreamRelease ;
+ dup closed>> [ drop ] [
+ t >>closed
+ {
+ [ info>> remove-event-source-callback ]
+ [ handle>> disable-event-stream ]
+ [ handle>> FSEventStreamInvalidate ]
+ [ handle>> FSEventStreamRelease ]
+ } cleave
+ ] if ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel threads init namespaces alien
+core-foundation ;
+IN: core-foundation.run-loop
+
+: kCFRunLoopRunFinished 1 ; inline
+: kCFRunLoopRunStopped 2 ; inline
+: kCFRunLoopRunTimedOut 3 ; inline
+: kCFRunLoopRunHandledSource 4 ; inline
+
+TYPEDEF: void* CFRunLoopRef
+
+FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
+
+FUNCTION: SInt32 CFRunLoopRunInMode (
+ CFStringRef mode,
+ CFTimeInterval seconds,
+ Boolean returnAfterSourceHandled
+) ;
+
+: CFRunLoopDefaultMode ( -- alien )
+ #! Ugly, but we don't have static NSStrings
+ \ CFRunLoopDefaultMode get-global dup expired? [
+ drop
+ "kCFRunLoopDefaultMode" <CFString>
+ dup \ CFRunLoopDefaultMode set-global
+ ] when ;
+
+: run-loop-thread ( -- )
+ CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
+ kCFRunLoopRunHandledSource = [ 1000 sleep ] unless
+ run-loop-thread ;
+
+: start-run-loop-thread ( -- )
+ [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
+
+[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook
TUPLE: coroutine resumecc exitcc ;
: cocreate ( quot -- co )
- coroutine construct-empty
+ coroutine new
dup current-coro associate
[ swapd , , \ bind ,
"Coroutine has terminated illegally." , \ throw ,
[ HEX: 10 swap set-cpu-last-interrupt ] keep
0 swap set-cpu-cycles ;
-: <cpu> ( -- cpu ) cpu construct-empty dup reset ;
+: <cpu> ( -- cpu ) cpu new dup reset ;
: (load-rom) ( n ram -- )
read1 [ ! n ram ch
SYMBOL: rom-root
: rom-dir ( -- string )
- rom-root get [ home "roms" path+ dup exists? [ drop f ] unless ] unless* ;
+ rom-root get [ home "roms" append-path dup exists? [ drop f ] unless ] unless* ;
: load-rom* ( seq cpu -- )
#! 'seq' is an array of arrays. Each array contains
#! file path shoul dbe relative to the '/roms' resource path.
rom-dir [
cpu-ram [
- swap first2 rom-dir swap path+ binary [
+ swap first2 rom-dir prepend-path binary [
swap (load-rom)
] with-file-reader
] curry each
8-bit-registers sp <&>
"," token <&
8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: ADC-R,(RR)-instruction ( -- parser )
"ADC-R,(RR)" "ADC" complex-instruction
8-bit-registers sp <&>
"," token <&
16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: SBC-R,N-instruction ( -- parser )
"SBC-R,N" "SBC" complex-instruction
8-bit-registers sp <&>
"," token <&
8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: SBC-R,(RR)-instruction ( -- parser )
"SBC-R,(RR)" "SBC" complex-instruction
8-bit-registers sp <&>
"," token <&
16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: SUB-R-instruction ( -- parser )
"SUB-R" "SUB" complex-instruction
8-bit-registers sp <&>
"," token <&
8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: ADD-RR,RR-instruction ( -- parser )
"ADD-RR,RR" "ADD" complex-instruction
16-bit-registers sp <&>
"," token <&
16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: ADD-R,(RR)-instruction ( -- parser )
"ADD-R,(RR)" "ADD" complex-instruction
8-bit-registers sp <&>
"," token <&
16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: LD-RR,NN-instruction
#! LD BC,nn
16-bit-registers indirect sp <&>
"," token <&
8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: LD-R,R-instruction
"LD-R,R" "LD" complex-instruction
8-bit-registers sp <&>
"," token <&
8-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: LD-RR,RR-instruction
"LD-RR,RR" "LD" complex-instruction
16-bit-registers sp <&>
"," token <&
16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: LD-R,(RR)-instruction
"LD-R,(RR)" "LD" complex-instruction
8-bit-registers sp <&>
"," token <&
16-bit-registers indirect <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: LD-(NN),RR-instruction
"LD-(NN),RR" "LD" complex-instruction
16-bit-registers indirect sp <&>
"," token <&
16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: EX-RR,RR-instruction
"EX-RR,RR" "EX" complex-instruction
16-bit-registers sp <&>
"," token <&
16-bit-registers <&>
- just [ first2 swap first2 swap >r swap append r> curry ] <@ ;
+ just [ first2 swap first2 swap >r prepend r> curry ] <@ ;
: 8080-generator-parser
NOP-instruction
: barrett-mu ( n size -- mu )
#! Calculates Barrett's reduction parameter mu
#! size = word size in bits (8, 16, 32, 64, ...)
- over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ;
+ ! over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ;
+ [
+ [ log2 1+ ] [ / 2 * ] bi*
+ ] [
+ 2^ rot ^ swap /i
+ ] 2bi ;
+
+++ /dev/null
-USING: kernel math sequences namespaces crypto math-contrib ;
-IN: crypto-internals
-
-! TODO: take (log log M) bits instead of 1 bit
-! Blum Blum Shub, M = pq
-TUPLE: bbs x n ;
-
-: generate-bbs-primes ( numbits -- p q )
- #! two primes congruent to 3 (mod 4)
- dup [ random-miller-rabin-prime==3(mod4) ] 2apply ;
-
-IN: crypto
-: make-bbs ( numbits -- blum-blum-shub )
- #! returns a Blum-Blum-Shub tuple
- generate-bbs-primes * [ find-relative-prime ] keep <bbs> ;
-
-IN: crypto-internals
-SYMBOL: blum-blum-shub 256 make-bbs blum-blum-shub set-global
-
-: next-bbs-bit ( bbs -- bit )
- #! x = x^2 mod n, return low bit of calculated x
- [ [ bbs-x ] keep 2 swap bbs-n ^mod ] keep
- [ set-bbs-x ] keep bbs-x 1 bitand ;
-
-SYMBOL: temp-bbs
-: (bbs-bits) ( numbits bbs -- n )
- temp-bbs set [ [ temp-bbs get next-bbs-bit ] swap make-bits ] with-scope ;
-
-IN: crypto
-: random-bbs-bits* ( numbits bbs -- n ) (bbs-bits) ;
-: random-bits ( numbits -- n ) blum-blum-shub get (bbs-bits) ;
-: random-bytes ( numbits -- n ) 8 * random-bits ;
-: random ( n -- n )
- ! #! Cryptographically secure random number using Blum-Blum-Shub 256
- [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ;
-
math.private ;
IN: crypto.common
-HELP: >32-bit
-{ $values { "x" integer } { "y" integer } }
-{ $description "Used to implement 32-bit integer overflow." } ;
-
-HELP: >64-bit
-{ $values { "x" integer } { "y" integer } }
-{ $description "Used to implement 64-bit integer overflow." } ;
-
-HELP: bitroll
-{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
-{ $description "Roll n by s bits to the left, wrapping around after w bits." }
-{ $examples
- { $example "USING: crypto.common prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
- { $example "USING: crypto.common prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
-} ;
-
-
HELP: hex-string
{ $values { "seq" "a sequence" } { "str" "a string" } }
{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
USING: arrays kernel io io.binary sbufs splitting strings sequences
-namespaces math math.parser parser hints ;
+namespaces math math.parser parser hints math.bitfields.lib ;
IN: crypto.common
-: >32-bit ( x -- y ) HEX: ffffffff bitand ; inline
-: >64-bit ( x -- y ) HEX: ffffffffffffffff bitand ; inline
-
-: w+ ( int int -- int ) + >32-bit ; inline
+: w+ ( int int -- int ) + 32 bits ; inline
: (nth-int) ( string n -- int )
2 shift dup 4 + rot <slice> ; inline
3 shift 8 rot [ >be ] [ >le ] if %
] "" make 64 group ;
-: shift-mod ( n s w -- n )
- >r shift r> 2^ 1- bitand ; inline
-
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
-: bitroll ( x s w -- y )
- [ 1 - bitand ] keep
- over 0 < [ [ + ] keep ] when
- [ shift-mod ] 3keep
- [ - ] keep shift-mod bitor ; inline
-
-: bitroll-32 ( n s -- n' ) 32 bitroll ;
-
-HINTS: bitroll-32 bignum fixnum ;
-
-: bitroll-64 ( n s -- n' ) 64 bitroll ;
-
-HINTS: bitroll-64 bignum fixnum ;
-
: hex-string ( seq -- str )
[ [ >hex 2 48 pad-left % ] each ] "" make ;
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }
- swap ! error?
[ 2array flip concat ] keep like ;
: mod-nth ( n seq -- elt )
#! 5 "abcd" -> b
- [ length mod ] keep nth ;
+ [ length mod ] [ nth ] bi ;
[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test
[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test
-
: byte-array>sha1-hmac ( K string -- hmac )
binary <byte-reader> stream>sha1-hmac ;
-
: stream>md5-hmac ( K stream -- hmac )
[ init-hmac md5-hmac ] with-stream ;
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting strings
sequences crypto.common byte-arrays locals sequences.private
-io.encodings.binary symbols ;
+io.encodings.binary symbols math.bitfields.lib ;
IN: crypto.md5
<PRIVATE
: F ( X Y Z -- FXYZ )
#! F(X,Y,Z) = XY v not(X) Z
- pick bitnot bitand >r bitand r> bitor ;
+ pick bitnot bitand [ bitand ] [ bitor ] bi* ;
: G ( X Y Z -- GXYZ )
#! G(X,Y,Z) = XZ v Y not(Z)
- dup bitnot rot bitand >r bitand r> bitor ;
+ dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
: H ( X Y Z -- HXYZ )
#! H(X,Y,Z) = X xor Y xor Z
USING: math.miller-rabin kernel math math.functions namespaces
-sequences ;
+sequences accessors ;
IN: crypto.rsa
! The private key is the only secret.
: modulus-phi ( numbits -- n phi )
#! Loop until phi is not divisible by the public key.
dup rsa-primes [ * ] 2keep
- [ 1- ] 2apply *
+ [ 1- ] bi@ *
dup public-key gcd nip 1 = [
rot drop
] [
public-key <rsa> ;
: rsa-encrypt ( message rsa -- encrypted )
- [ rsa-public-key ] keep rsa-modulus ^mod ;
+ [ public-key>> ] [ modulus>> ] bi ^mod ;
: rsa-decrypt ( encrypted rsa -- message )
- [ rsa-private-key ] keep rsa-modulus ^mod ;
\ No newline at end of file
+ [ private-key>> ] [ modulus>> ] bi ^mod ;
USING: arrays combinators crypto.common kernel io
io.encodings.binary io.files io.streams.byte-array math.vectors
strings sequences namespaces math parser sequences vectors
-io.binary hashtables symbols ;
+io.binary hashtables symbols math.bitfields.lib ;
IN: crypto.sha1
! Implemented according to RFC 3174.
K get nth ,
A get 5 bitroll-32 ,
E get ,
- ] { } make sum >32-bit ; inline
+ ] { } make sum 32 bits ; inline
: set-vars ( temp -- )
! E = D; D = C; C = S^30(B); B = A; A = TEMP;
: byte-array>sha1-interleave ( string -- seq )
[ zero? ] left-trim
dup length odd? [ 1 tail ] when
- seq>2seq [ byte-array>sha1 ] 2apply
- swap 2seq>seq ;
+ seq>2seq [ byte-array>sha1 ] bi@
+ 2seq>seq ;
USING: crypto.common kernel splitting math sequences namespaces
-io.binary symbols ;
+io.binary symbols math.bitfields.lib ;
IN: crypto.sha2
<PRIVATE
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size >word ;
+SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
-: a 0 ;
-: b 1 ;
-: c 2 ;
-: d 3 ;
-: e 4 ;
-: f 5 ;
-: g 6 ;
-: h 7 ;
+: a 0 ; inline
+: b 1 ; inline
+: c 2 ; inline
+: d 3 ; inline
+: e 4 ; inline
+: f 5 ; inline
+: g 6 ; inline
+: h 7 ; inline
: initial-H-256 ( -- seq )
{
initial-H-256 H set
4 word-size set
64 block-size set
- \ >32-bit >word set
byte-array>sha2
] with-scope ;
+++ /dev/null
-USING: kernel math test namespaces crypto crypto-internals ;
-
-[ 6 ] [ 5 T{ bbs f 590695557939 811977232793 } random-bbs-bits* ] unit-test
-[ 792723710536787233474130382522 ] [ 100 T{ bbs f 200352954495 846054538649 } [ random-bbs-bits* drop ] 2keep random-bbs-bits* ] unit-test
-
+++ /dev/null
-USING: kernel math test namespaces crypto ;
-
-[ 0 ] [ 1 0 0 bitroll ] unit-test
-[ 1 ] [ 1 0 1 bitroll ] unit-test
-[ 1 ] [ 1 1 1 bitroll ] unit-test
-[ 1 ] [ 1 0 2 bitroll ] unit-test
-[ 1 ] [ 1 0 1 bitroll ] unit-test
-[ 1 ] [ 1 20 2 bitroll ] unit-test
-[ 1 ] [ 1 8 8 bitroll ] unit-test
-[ 1 ] [ 1 -8 8 bitroll ] unit-test
-[ 1 ] [ 1 -32 8 bitroll ] unit-test
-[ 128 ] [ 1 -1 8 bitroll ] unit-test
-[ 8 ] [ 1 3 32 bitroll ] unit-test
-
-
USING: kernel math threads system ;
IN: crypto.timing
-: with-timing ( ... quot n -- )
+: with-timing ( quot n -- )
#! force the quotation to execute in, at minimum, n milliseconds
- millis 2slip millis - + sleep ;
-
+ millis 2slip millis - + sleep ; inline
USING: crypto.common kernel math sequences ;
IN: crypto.xor
-TUPLE: no-xor-key ;
+ERROR: no-xor-key ;
-: xor-crypt ( key seq -- seq )
- over empty? [ no-xor-key construct-empty throw ] when
+: xor-crypt ( key seq -- seq' )
+ over empty? [ no-xor-key ] when
dup length rot [ mod-nth bitxor ] curry 2map ;
\r
{ 1 0 } [ [ drop ] query-each ] must-infer-as\r
{ 1 1 } [ [ ] query-map ] must-infer-as\r
+{ 2 0 } [ [ ] with-db ] must-infer-as\r
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
-namespaces sequences sequences.lib tuples words strings
-tools.walker new-slots accessors ;
+namespaces sequences sequences.lib classes.tuple words strings
+tools.walker accessors combinators.lib ;
IN: db
TUPLE: db
update-statements
delete-statements ;
-: <db> ( handle -- obj )
- H{ } clone H{ } clone H{ } clone
- db construct-boa ;
+: new-db ( class -- obj )
+ new
+ H{ } clone >>insert-statements
+ H{ } clone >>update-statements
+ H{ } clone >>delete-statements ;
GENERIC: make-db* ( seq class -- db )
-GENERIC: db-open ( db -- )
+
+: make-db ( seq class -- db )
+ new-db make-db* ;
+
+GENERIC: db-open ( db -- db )
HOOK: db-close db ( handle -- )
-: make-db ( seq class -- db ) construct-empty make-db* ;
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
handle>> db-close
] with-variable ;
-TUPLE: statement handle sql in-params out-params bind-params bound? ;
-TUPLE: simple-statement ;
-TUPLE: prepared-statement ;
-TUPLE: nonthrowable-statement ;
+! TUPLE: sql sql in-params out-params ;
+TUPLE: statement handle sql in-params out-params bind-params bound? type ;
+TUPLE: simple-statement < statement ;
+TUPLE: prepared-statement < statement ;
+
+SINGLETON: throwable
+SINGLETON: nonthrowable
+
+: make-throwable ( obj -- obj' )
+ dup sequence? [
+ [ make-throwable ] map
+ ] [
+ throwable >>type
+ ] if ;
+
: make-nonthrowable ( obj -- obj' )
dup sequence? [
[ make-nonthrowable ] map
] [
- nonthrowable-statement construct-delegate
+ nonthrowable >>type
] if ;
-MIXIN: throwable-statement
-INSTANCE: statement throwable-statement
-INSTANCE: simple-statement throwable-statement
-INSTANCE: prepared-statement throwable-statement
-
TUPLE: result-set sql in-params out-params handle n max ;
-: <statement> ( sql in out -- statement )
- { (>>sql) (>>in-params) (>>out-params) } statement construct ;
+
+: construct-statement ( sql in out class -- statement )
+ new
+ swap >>out-params
+ swap >>in-params
+ swap >>sql
+ throwable >>type ;
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( statement -- )
+GENERIC: low-level-bind ( statement -- )
GENERIC: bind-tuple ( tuple statement -- )
GENERIC: query-results ( query -- result-set )
GENERIC: #rows ( result-set -- n )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
-GENERIC: execute-statement ( statement -- )
+GENERIC: execute-statement* ( statement type -- )
-M: throwable-statement execute-statement ( statement -- )
- dup sequence? [
- [ execute-statement ] each
- ] [
- query-results dispose
- ] if ;
+M: throwable execute-statement* ( statement type -- )
+ drop query-results dispose ;
-M: nonthrowable-statement execute-statement ( statement -- )
+M: nonthrowable execute-statement* ( statement type -- )
+ drop [ query-results dispose ] [ 2drop ] recover ;
+
+: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
- [ query-results dispose ] [ 2drop ] recover
+ dup type>> execute-statement*
] if ;
: bind-statement ( obj statement -- )
dup #rows >>max
0 >>n drop ;
-: <result-set> ( query handle tuple -- result-set )
- >r >r { sql>> in-params>> out-params>> } get-slots r>
- { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set
- construct r> construct-delegate ;
-
+: construct-result-set ( query handle class -- result-set )
+ new
+ swap >>handle
+ >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
+ swap >>out-params
+ swap >>in-params
+ swap >>sql ;
+
: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
accumulator >r query-each r> { } like ; inline
: with-db ( db seq quot -- )
- >r make-db dup db-open db r>
+ >r make-db db-open db r>
[ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
+ inline
: default-query ( query -- result-set )
query-results [ [ sql-row ] query-map ] with-disposal ;
IN: db.mysql.ffi
<< "mysql" {
- { [ win32? ] [ "libmySQL.dll" "stdcall" ] }
- { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
- { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
+ { [ os winnt? ] [ "libmySQL.dll" "stdcall" ] }
+ { [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
} cond add-library >>
LIBRARY: mysql
: mysql-error ( mysql -- )
[ mysql_error throw ] when* ;
-: mysql-connect ( mysql-connection -- )
- new-mysql over set-mysql-db-handle
- dup {
- mysql-db-handle
- mysql-db-host
- mysql-db-user
- mysql-db-password
- mysql-db-db
- mysql-db-port
- } get-slots f 0 mysql_real_connect mysql-error ;
+! : mysql-connect ( mysql-connection -- )
+ ! new-mysql over set-mysql-db-handle
+ ! dup {
+ ! mysql-db-handle
+ ! mysql-db-host
+ ! mysql-db-user
+ ! mysql-db-password
+ ! mysql-db-db
+ ! mysql-db-port
+ ! } get-slots f 0 mysql_real_connect mysql-error ;
! =========================================================
! Low level mysql utility definitions
TUPLE: mysql-result-set ;
M: mysql-db db-open ( mysql-db -- )
- drop ;
+ ;
M: mysql-db dispose ( mysql-db -- )
mysql-db-handle mysql_close ;
IN: db.postgresql.ffi
<< "postgresql" {
- { [ win32? ] [ "libpq.dll" ] }
- { [ macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
- { [ unix? ] [ "libpq.so" ] }
+ { [ os winnt? ] [ "libpq.dll" ] }
+ { [ os macosx? ] [ "libpq.dylib" ] }
+ { [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >>
! ConnSatusType
! See http://factorcode.org/license.txt for BSD license.
USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
-db.types tools.walker ascii splitting math.parser
-combinators combinators.cleave libc shuffle calendar.format
-byte-arrays destructors prettyprint new-slots accessors
-strings serialize io.encodings.binary io.streams.byte-array ;
+db.types tools.walker ascii splitting math.parser combinators
+libc shuffle calendar.format byte-arrays destructors prettyprint
+accessors strings serialize io.encodings.binary io.encodings.utf8
+alien.strings io.streams.byte-array inspector ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
"\n" split [ [ blank? ] trim ] map "\n" join ;
: postgresql-error-message ( -- str )
- db get db-handle (postgresql-error-message) ;
+ db get handle>> (postgresql-error-message) ;
: postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ;
-: postgresql-result-ok? ( n -- ? )
+ERROR: postgresql-result-null ;
+
+M: postgresql-result-null summary ( obj -- str )
+ drop "PQexec returned f." ;
+
+: postgresql-result-ok? ( res -- ? )
+ [ postgresql-result-null ] unless*
PQresultStatus
PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
: do-postgresql-statement ( statement -- res )
- db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
- dup postgresql-result-error-message swap PQclear throw
+ db get handle>> swap sql>> PQexec dup postgresql-result-ok? [
+ [ postgresql-result-error-message ] [ PQclear ] bi throw
] unless ;
: type>oid ( symbol -- n )
} case ;
: param-types ( statement -- seq )
- statement-in-params
- [ sql-spec-type type>oid ] map
- >c-uint-array ;
+ in-params>> [ type>> type>oid ] map >c-uint-array ;
: malloc-byte-array/length
[ malloc-byte-array dup free-always ] [ length ] bi ;
-
+
+: default-param-value
+ number>string* dup [
+ utf8 malloc-string dup free-always
+ ] when 0 ;
: param-values ( statement -- seq seq2 )
- [ statement-bind-params ]
- [ statement-in-params ] bi
+ [ bind-params>> ] [ in-params>> ] bi
[
- sql-spec-type {
+ >r value>> r> type>> {
{ FACTOR-BLOB [
- dup [
- object>bytes
- malloc-byte-array/length ] [ 0 ] if ] }
- { BLOB [
- dup [ malloc-byte-array/length ] [ 0 ] if ] }
- [
- drop number>string* dup [
- malloc-char-string dup free-always
- ] when 0
- ]
+ dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
+ ] }
+ { BLOB [ dup [ malloc-byte-array/length ] [ 0 ] if ] }
+ { DATE [ dup [ timestamp>ymd ] when default-param-value ] }
+ { TIME [ dup [ timestamp>hms ] when default-param-value ] }
+ { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] }
+ { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] }
+ [ drop default-param-value ]
} case 2array
] 2map flip dup empty? [
drop f f
] if ;
: param-formats ( statement -- seq )
- statement-in-params
- [ sql-spec-type type>param-format ] map
- >c-uint-array ;
+ in-params>> [ type>> type>param-format ] map >c-uint-array ;
: do-postgresql-bound-statement ( statement -- res )
[
- >r db get db-handle r>
+ >r db get handle>> r>
{
- [ statement-sql ]
- [ statement-bind-params length ]
+ [ sql>> ]
+ [ bind-params>> length ]
[ param-types ]
[ param-values ]
[ param-formats ]
} cleave
0 PQexecParams dup postgresql-result-ok? [
- dup postgresql-result-error-message swap PQclear throw
+ [ postgresql-result-error-message ] [ PQclear ] bi throw
] unless
] with-destructors ;
PQgetisnull 1 = ;
: pq-get-string ( handle row column -- obj )
- 3dup PQgetvalue alien>char-string
- dup "" = [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
+ 3dup PQgetvalue utf8 alien>string
+ dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
: pq-get-number ( handle row column -- obj )
pq-get-string dup [ string>number ] when ;
dup array? [ first ] when
{
{ +native-id+ [ pq-get-number ] }
+ { +random-id+ [ pq-get-number ] }
{ INTEGER [ pq-get-number ] }
{ BIG-INTEGER [ pq-get-number ] }
{ DOUBLE [ pq-get-number ] }
dup [ bytes>object ] when ] }
[ no-sql-type ]
} case ;
- ! PQgetlength PQgetisnull
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
-combinators.cleave namespaces.lib ;
+namespaces.lib accessors random db.queries ;
IN: db.postgresql
-TUPLE: postgresql-db host port pgopts pgtty db user pass ;
-TUPLE: postgresql-statement ;
-INSTANCE: postgresql-statement throwable-statement
-TUPLE: postgresql-result-set ;
-: <postgresql-statement> ( statement in out -- postgresql-statement )
- <statement>
- postgresql-statement construct-delegate ;
+TUPLE: postgresql-db < db
+ host port pgopts pgtty db user pass ;
+
+TUPLE: postgresql-statement < statement ;
+
+TUPLE: postgresql-result-set < result-set ;
M: postgresql-db make-db* ( seq tuple -- db )
- >r first4 r> [
- {
- set-postgresql-db-host
- set-postgresql-db-user
- set-postgresql-db-pass
- set-postgresql-db-db
- } set-slots
- ] keep ;
-
-M: postgresql-db db-open ( db -- )
- dup {
- postgresql-db-host
- postgresql-db-port
- postgresql-db-pgopts
- postgresql-db-pgtty
- postgresql-db-db
- postgresql-db-user
- postgresql-db-pass
- } get-slots connect-postgres <db> swap set-delegate ;
+ >r first4 r>
+ swap >>db
+ swap >>pass
+ swap >>user
+ swap >>host ;
+
+M: postgresql-db db-open ( db -- db )
+ dup {
+ [ host>> ]
+ [ port>> ]
+ [ pgopts>> ]
+ [ pgtty>> ]
+ [ db>> ]
+ [ user>> ]
+ [ pass>> ]
+ } cleave connect-postgres >>handle ;
M: postgresql-db dispose ( db -- )
- db-handle PQfinish ;
+ handle>> PQfinish ;
M: postgresql-statement bind-statement* ( statement -- )
drop ;
+GENERIC: postgresql-bind-conversion ( tuple obj -- low-level-binding )
+
+M: sql-spec postgresql-bind-conversion ( tuple spec -- obj )
+ slot-name>> swap get-slot-named <low-level-binding> ;
+
+M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj )
+ nip value>> <low-level-binding> ;
+
+M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
+ nip singleton>> eval-generator <low-level-binding> ;
+
M: postgresql-statement bind-tuple ( tuple statement -- )
- [
- statement-in-params
- [ sql-spec-slot-name swap get-slot-named ] with map
- ] keep set-statement-bind-params ;
+ tuck in-params>>
+ [ postgresql-bind-conversion ] with map
+ >>bind-params drop ;
M: postgresql-result-set #rows ( result-set -- n )
- result-set-handle PQntuples ;
+ handle>> PQntuples ;
M: postgresql-result-set #columns ( result-set -- n )
- result-set-handle PQnfields ;
+ handle>> PQnfields ;
+
+: result-handle-n ( result-set -- handle n )
+ [ handle>> ] [ n>> ] bi ;
M: postgresql-result-set row-column ( result-set column -- obj )
- >r dup result-set-handle swap result-set-n r> pq-get-string ;
+ >r result-handle-n r> pq-get-string ;
M: postgresql-result-set row-column-typed ( result-set column -- obj )
- dup pick result-set-out-params nth sql-spec-type
- >r >r [ result-set-handle ] [ result-set-n ] bi r> r> postgresql-column-typed ;
+ dup pick out-params>> nth type>>
+ >r >r result-handle-n r> r> postgresql-column-typed ;
M: postgresql-statement query-results ( query -- result-set )
- dup statement-bind-params [
+ dup bind-params>> [
over [ bind-statement ] keep
do-postgresql-bound-statement
] [
dup do-postgresql-statement
] if*
- postgresql-result-set <result-set>
+ postgresql-result-set construct-result-set
dup init-result-set ;
M: postgresql-result-set advance-row ( result-set -- )
- dup result-set-n 1+ swap set-result-set-n ;
+ [ 1+ ] change-n drop ;
M: postgresql-result-set more-rows? ( result-set -- ? )
- dup result-set-n swap result-set-max < ;
+ [ n>> ] [ max>> ] bi < ;
M: postgresql-statement dispose ( query -- )
- dup statement-handle PQclear
- f swap set-statement-handle ;
+ dup handle>> PQclear
+ f >>handle drop ;
M: postgresql-result-set dispose ( result-set -- )
- dup result-set-handle PQclear
- 0 0 f roll {
- set-result-set-n set-result-set-max set-result-set-handle
- } set-slots ;
+ [ handle>> PQclear ]
+ [
+ 0 >>n
+ 0 >>max
+ f >>handle drop
+ ] bi ;
M: postgresql-statement prepare-statement ( statement -- )
- [
- >r db get db-handle "" r>
- dup statement-sql swap statement-in-params
- length f PQprepare postgresql-error
- ] keep set-statement-handle ;
+ dup
+ >r db get handle>> f r>
+ [ sql>> ] [ in-params>> ] bi
+ length f PQprepare postgresql-error
+ >>handle drop ;
M: postgresql-db <simple-statement> ( sql in out -- statement )
- <postgresql-statement> ;
+ postgresql-statement construct-statement ;
M: postgresql-db <prepared-statement> ( sql in out -- statement )
- <postgresql-statement> dup prepare-statement ;
-
-M: postgresql-db begin-transaction ( -- )
- "BEGIN" sql-command ;
-
-M: postgresql-db commit-transaction ( -- )
- "COMMIT" sql-command ;
+ <simple-statement> dup prepare-statement ;
-M: postgresql-db rollback-transaction ( -- )
- "ROLLBACK" sql-command ;
-
-SYMBOL: postgresql-counter
: bind-name% ( -- )
CHAR: $ 0,
- postgresql-counter [ inc ] keep get 0# ;
+ sql-counter [ inc ] [ get 0# ] bi ;
M: postgresql-db bind% ( spec -- )
- 1, bind-name% ;
+ bind-name% 1, ;
-: postgresql-make ( class quot -- )
- >r sql-props r>
- [ postgresql-counter off call ] { "" { } { } } nmake
- <postgresql-statement> ; inline
+M: postgresql-db bind# ( spec obj -- )
+ >r bind-name% f swap type>> r> <literal-bind> 1, ;
: create-table-sql ( class -- statement )
[
"create table " 0% 0%
- "(" 0%
- [ ", " 0% ] [
- dup sql-spec-column-name 0%
+ "(" 0% [ ", " 0% ] [
+ dup column-name>> 0%
" " 0%
- dup sql-spec-type t lookup-type 0%
+ dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
- ] postgresql-make ;
+ ] query-make ;
: create-function-sql ( class -- statement )
[
"(" 0%
over [ "," 0% ]
[
- sql-spec-type f lookup-type 0%
+ type>> lookup-type 0%
] interleave
")" 0%
" returns bigint as '" 0%
"insert into " 0%
dup 0%
"(" 0%
- over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ over [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
swap [ ", " 0% ] [ drop bind-name% ] interleave
"); " 0%
"select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db create-sql-statement ( class -- seq )
[
"drop function add_" 0% 0%
"(" 0%
remove-id
- [ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave
+ [ ", " 0% ] [ type>> lookup-type 0% ] interleave
");" 0%
- ] postgresql-make ;
+ ] query-make ;
: drop-table-sql ( table -- statement )
[
"drop table " 0% 0% ";" 0% drop
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db drop-sql-statement ( class -- seq )
[
remove-id
[ ", " 0% ] [ bind% ] interleave
");" 0%
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db <insert-nonnative-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%
- dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ dup [ ", " 0% ] [ column-name>> 0% ] interleave
")" 0%
" values(" 0%
- [ ", " 0% ] [ bind% ] interleave
+ [ ", " 0% ] [
+ dup type>> +random-id+ = [
+ [
+ drop bind-name%
+ f random-id-generator
+ ] [ type>> ] bi <generator-bind> 1,
+ ] [
+ bind%
+ ] if
+ ] interleave
");" 0%
- ] postgresql-make ;
+ ] query-make ;
M: postgresql-db insert-tuple* ( tuple statement -- )
query-modify-tuple ;
-M: postgresql-db <update-tuple-statement> ( class -- statement )
- [
- "update " 0% 0%
- " set " 0%
- dup remove-id
- [ ", " 0% ]
- [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
- " where " 0%
- find-primary-key
- dup sql-spec-column-name 0% " = " 0% bind%
- ] postgresql-make ;
-
-M: postgresql-db <delete-tuple-statement> ( class -- statement )
- [
- "delete from " 0% 0%
- " where " 0%
- find-primary-key
- dup sql-spec-column-name 0% " = " 0% bind%
- ] postgresql-make ;
-
-M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
- [
- ! tuple columns table
- "select " 0%
- over [ ", " 0% ]
- [ dup sql-spec-column-name 0% 2, ] interleave
-
- " from " 0% 0%
- [ sql-spec-slot-name swap get-slot-named ] with subset
- dup empty? [
- drop
- ] [
- " where " 0%
- [ " and " 0% ]
- [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
- ] if ";" 0%
- ] postgresql-make ;
-
-M: postgresql-db type-table ( -- hash )
- H{
- { +native-id+ "integer" }
- { TEXT "text" }
- { VARCHAR "varchar" }
- { INTEGER "integer" }
- { DOUBLE "real" }
- { DATE "date" }
- { TIME "time" }
- { DATETIME "timestamp" }
- { TIMESTAMP "timestamp" }
- { BLOB "bytea" }
- { FACTOR-BLOB "bytea" }
- } ;
-
-M: postgresql-db create-type-table ( -- hash )
+M: postgresql-db persistent-table ( -- hashtable )
H{
- { +native-id+ "serial primary key" }
+ { +native-id+ { "integer" "serial primary key" f } }
+ { +assigned-id+ { f f "primary key" } }
+ { +random-id+ { "bigint" "bigint primary key" f } }
+ { TEXT { "text" "text" f } }
+ { VARCHAR { "varchar" "varchar" f } }
+ { INTEGER { "integer" "integer" f } }
+ { BIG-INTEGER { "bigint" "bigint" f } }
+ { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
+ { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
+ { DOUBLE { "real" "real" f } }
+ { DATE { "date" "date" f } }
+ { TIME { "time" "time" f } }
+ { DATETIME { "timestamp" "timestamp" f } }
+ { TIMESTAMP { "timestamp" "timestamp" f } }
+ { BLOB { "bytea" "bytea" f } }
+ { FACTOR-BLOB { "bytea" "bytea" f } }
+ { +foreign-id+ { f f "references" } }
+ { +autoincrement+ { f f "autoincrement" } }
+ { +unique+ { f f "unique" } }
+ { +default+ { f f "default" } }
+ { +null+ { f f "null" } }
+ { +not-null+ { f f "not null" } }
+ { system-random-generator { f f f } }
+ { secure-random-generator { f f f } }
+ { random-generator { f f f } }
} ;
-: postgresql-compound ( str n -- newstr )
+M: postgresql-db compound ( str obj -- str' )
over {
{ "default" [ first number>string join-space ] }
{ "varchar" [ first number>string paren append ] }
{ "references" [
first2 >r [ unparse join-space ] keep db-columns r>
- swap [ sql-spec-slot-name = ] with find nip
- sql-spec-column-name paren append
+ swap [ slot-name>> = ] with find nip
+ column-name>> paren append
] }
[ "no compound found" 3array throw ]
} case ;
-
-M: postgresql-db compound-modifier ( str seq -- newstr )
- postgresql-compound ;
-
-M: postgresql-db modifier-table ( -- hashtable )
- H{
- { +native-id+ "primary key" }
- { +assigned-id+ "primary key" }
- { +foreign-id+ "references" }
- { +autoincrement+ "autoincrement" }
- { +unique+ "unique" }
- { +default+ "default" }
- { +null+ "null" }
- { +not-null+ "not null" }
- } ;
-
-M: postgresql-db compound-type ( str n -- newstr )
- postgresql-compound ;
--- /dev/null
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math namespaces sequences random
+strings
+math.bitfields.lib namespaces.lib db db.tuples db.types
+math.intervals ;
+IN: db.queries
+
+GENERIC: where ( specs obj -- )
+
+: maybe-make-retryable ( statement -- statement )
+ dup in-params>> [ generator-bind? ] contains? [
+ make-retryable
+ ] when ;
+
+: query-make ( class quot -- )
+ >r sql-props r>
+ [ 0 sql-counter rot with-variable ] { "" { } { } } nmake
+ <simple-statement> maybe-make-retryable ; inline
+
+M: db begin-transaction ( -- ) "BEGIN" sql-command ;
+M: db commit-transaction ( -- ) "COMMIT" sql-command ;
+M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
+
+: where-primary-key% ( specs -- )
+ " where " 0%
+ find-primary-key dup column-name>> 0% " = " 0% bind% ;
+
+M: db <update-tuple-statement> ( class -- statement )
+ [
+ "update " 0% 0%
+ " set " 0%
+ dup remove-id
+ [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
+ where-primary-key%
+ ] query-make ;
+
+M: db <delete-tuple-statement> ( specs table -- sql )
+ [
+ "delete from " 0% 0%
+ " where " 0%
+ find-primary-key
+ dup column-name>> 0% " = " 0% bind%
+ ] query-make ;
+
+M: random-id-generator eval-generator ( singleton -- obj )
+ drop
+ system-random-generator get [
+ 63 [ 2^ random ] keep 1 - set-bit
+ ] with-random ;
+
+: interval-comparison ( ? str -- str )
+ "from" = " >" " <" ? swap [ "= " append ] when ;
+
+: where-interval ( spec obj from/to -- )
+ pick column-name>> 0%
+ >r first2 r> interval-comparison 0%
+ bind# ;
+
+: in-parens ( quot -- )
+ "(" 0% call ")" 0% ; inline
+
+M: interval where ( spec obj -- )
+ [
+ [ from>> "from" where-interval " and " 0% ]
+ [ to>> "to" where-interval ] 2bi
+ ] in-parens ;
+
+M: sequence where ( spec obj -- )
+ [
+ [ " or " 0% ] [ dupd where ] interleave drop
+ ] in-parens ;
+
+: object-where ( spec obj -- )
+ over column-name>> 0% " = " 0% bind# ;
+
+M: object where ( spec obj -- ) object-where ;
+
+M: integer where ( spec obj -- ) object-where ;
+
+M: string where ( spec obj -- ) object-where ;
+
+: where-clause ( tuple specs -- )
+ " where " 0% [
+ " and " 0%
+ ] [
+ 2dup slot-name>> swap get-slot-named where
+ ] interleave drop ;
+
+M: db <select-by-slots-statement> ( tuple class -- statement )
+ [
+ "select " 0%
+ over [ ", " 0% ]
+ [ dup column-name>> 0% 2, ] interleave
+
+ " from " 0% 0%
+ dupd
+ [ slot-name>> swap get-slot-named ] with subset
+ dup empty? [ 2drop ] [ where-clause ] if ";" 0%
+ ] query-make ;
USING: kernel namespaces db.sql sequences math ;
IN: db.sql.tests
-TUPLE: person name age ;
+! TUPLE: person name age ;
: insert-1
{ insert
{ table "person" }
{ select
{ columns "salary" }
{ from "staff" }
- { where { "branchno" "b003" } }
+ { where { "branchno" = "b003" } }
}
}
{ "branchno" > 3 } }
{ offset 40 }
{ limit 20 }
} ;
-
-
-USING: kernel parser quotations tuples words
+USING: kernel parser quotations classes.tuple words
namespaces.lib namespaces sequences arrays combinators
prettyprint strings math.parser sequences.lib math symbols ;
USE: tools.walker
: sql-array% ( array -- )
unclip
{
- { columns [ "," (sql-interleave) ] }
- { from [ "from" "," sql-interleave ] }
- { where [ "where" "and" sql-interleave ] }
- { group-by [ "group by" "," sql-interleave ] }
- { having [ "having" "," sql-interleave ] }
- { order-by [ "order by" "," sql-interleave ] }
- { offset [ "offset" sql% sql% ] }
- { limit [ "limit" sql% sql% ] }
- { select [ "(select" sql% sql% ")" sql% ] }
- { table [ sql% ] }
- { set [ "set" "," sql-interleave ] }
- { values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
- { count [ "count" sql-function, ] }
- { sum [ "sum" sql-function, ] }
- { avg [ "avg" sql-function, ] }
- { min [ "min" sql-function, ] }
- { max [ "max" sql-function, ] }
+ { \ columns [ "," (sql-interleave) ] }
+ { \ from [ "from" "," sql-interleave ] }
+ { \ where [ "where" "and" sql-interleave ] }
+ { \ group-by [ "group by" "," sql-interleave ] }
+ { \ having [ "having" "," sql-interleave ] }
+ { \ order-by [ "order by" "," sql-interleave ] }
+ { \ offset [ "offset" sql% sql% ] }
+ { \ limit [ "limit" sql% sql% ] }
+ { \ select [ "(select" sql% sql% ")" sql% ] }
+ { \ table [ sql% ] }
+ { \ set [ "set" "," sql-interleave ] }
+ { \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] }
+ { \ count [ "count" sql-function, ] }
+ { \ sum [ "sum" sql-function, ] }
+ { \ avg [ "avg" sql-function, ] }
+ { \ min [ "min" sql-function, ] }
+ { \ max [ "max" sql-function, ] }
[ sql% [ sql% ] each ]
} case ;
-TUPLE: no-sql-match ;
+ERROR: no-sql-match ;
: sql% ( obj -- )
{
{ [ dup string? ] [ " " 0% 0% ] }
{ [ dup number? ] [ number>string sql% ] }
{ [ dup symbol? ] [ unparse sql% ] }
{ [ dup word? ] [ unparse sql% ] }
- { [ t ] [ T{ no-sql-match } throw ] }
+ { [ dup quotation? ] [ call ] }
+ [ no-sql-match ]
} cond ;
: parse-sql ( obj -- sql in-spec out-spec in out )
[
unclip {
- { insert [ "insert into" sql% ] }
- { update [ "update" sql% ] }
- { delete [ "delete" sql% ] }
- { select [ "select" sql% ] }
+ { \ create [ "create table" sql% ] }
+ { \ drop [ "drop table" sql% ] }
+ { \ insert [ "insert into" sql% ] }
+ { \ update [ "update" sql% ] }
+ { \ delete [ "delete" sql% ] }
+ { \ select [ "select" sql% ] }
} case [ sql% ] each
] { "" { } { } { } { } } nmake ;
! An interface to the sqlite database. Tested against sqlite v3.1.3.
! Not all functions have been wrapped.
USING: alien compiler kernel math namespaces sequences strings alien.syntax
- system combinators ;
+ system combinators alien.c-types ;
IN: db.sqlite.ffi
<< "sqlite" {
- { [ winnt? ] [ "sqlite3.dll" ] }
- { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
- { [ unix? ] [ "libsqlite3.so" ] }
+ { [ os winnt? ] [ "sqlite3.dll" ] }
+ { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+ { [ os unix? ] [ "libsqlite3.so" ] }
} cond "cdecl" add-library >>
! Return values from sqlite functions
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
+FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
-FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
+FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ;
+: sqlite3-bind-uint64 ( pStmt index in64 -- int )
+ "int" "sqlite" "sqlite3_bind_int64"
+ { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ;
FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
+FUNCTION: int sqlite3_clear_bindings ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
+: sqlite3-column-uint64 ( pStmt col -- uint64 )
+ "sqlite3_uint64" "sqlite" "sqlite3_column_int64"
+ { "sqlite3_stmt*" "int" } alien-invoke ;
FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
-tools.walker ;
+tools.walker io.backend ;
IN: db.sqlite.lib
: sqlite-error ( n -- * )
{
{ [ dup SQLITE_OK = ] [ drop ] }
{ [ dup SQLITE_ERROR = ] [ sqlite-statement-error ] }
- { [ t ] [ sqlite-error ] }
+ [ sqlite-error ]
} cond ;
-: sqlite-open ( filename -- db )
+: sqlite-open ( path -- db )
+ normalize-path
"void*" <c-object>
[ sqlite3_open sqlite-check-result ] keep *void* ;
: sqlite-prepare ( db sql -- handle )
dup length "void*" <c-object> "void*" <c-object>
- [ sqlite3_prepare sqlite-check-result ] 2keep
+ [ sqlite3_prepare_v2 sqlite-check-result ] 2keep
drop *void* ;
: sqlite-bind-parameter-index ( handle name -- index )
: sqlite-bind-int64 ( handle i n -- )
sqlite3_bind_int64 sqlite-check-result ;
+: sqlite-bind-uint64 ( handle i n -- )
+ sqlite3-bind-uint64 sqlite-check-result ;
+
: sqlite-bind-double ( handle i x -- )
sqlite3_bind_double sqlite-check-result ;
parameter-index sqlite-bind-int ;
: sqlite-bind-int64-by-name ( handle name int64 -- )
- parameter-index sqlite-bind-int ;
+ parameter-index sqlite-bind-int64 ;
+
+: sqlite-bind-uint64-by-name ( handle name int64 -- )
+ parameter-index sqlite-bind-uint64 ;
: sqlite-bind-double-by-name ( handle name double -- )
parameter-index sqlite-bind-double ;
{
{ INTEGER [ sqlite-bind-int-by-name ] }
{ BIG-INTEGER [ sqlite-bind-int64-by-name ] }
+ { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] }
+ { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] }
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
- { DATE [ sqlite-bind-text-by-name ] }
- { TIME [ sqlite-bind-text-by-name ] }
- { DATETIME [ sqlite-bind-text-by-name ] }
- { TIMESTAMP [ sqlite-bind-text-by-name ] }
+ { DATE [ timestamp>ymd sqlite-bind-text-by-name ] }
+ { TIME [ timestamp>hms sqlite-bind-text-by-name ] }
+ { DATETIME [ timestamp>ymdhms sqlite-bind-text-by-name ] }
+ { TIMESTAMP [ timestamp>ymdhms sqlite-bind-text-by-name ] }
{ BLOB [ sqlite-bind-blob-by-name ] }
{ FACTOR-BLOB [
object>bytes
sqlite-bind-blob-by-name
] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
+ { +random-id+ [ sqlite-bind-int64-by-name ] }
{ NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
+: sqlite-clear-bindings ( handle -- )
+ sqlite3_clear_bindings sqlite-check-result ;
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
: sqlite-column ( handle index -- string ) sqlite3_column_text ;
: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
: sqlite-column-typed ( handle index type -- obj )
dup array? [ first ] when
{
- { +native-id+ [ sqlite3_column_int64 ] }
- { +random-id+ [ sqlite3_column_int64 ] }
+ { +native-id+ [ sqlite3_column_int64 ] }
+ { +random-id+ [ sqlite3-column-uint64 ] }
{ INTEGER [ sqlite3_column_int ] }
{ BIG-INTEGER [ sqlite3_column_int64 ] }
+ { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] }
+ { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] }
{ DOUBLE [ sqlite3_column_double ] }
{ TEXT [ sqlite3_column_text ] }
{ VARCHAR [ sqlite3_column_text ] }
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
-prettyprint sequences strings tuples alien.c-types
+prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
-words combinators.lib db.types combinators
-combinators.cleave io namespaces.lib ;
+words combinators.lib db.types combinators math.intervals
+io namespaces.lib accessors vectors math.ranges random
+math.bitfields.lib db.queries ;
USE: tools.walker
IN: db.sqlite
-TUPLE: sqlite-db path ;
+TUPLE: sqlite-db < db path ;
M: sqlite-db make-db* ( path db -- db )
- [ set-sqlite-db-path ] keep ;
+ swap >>path ;
-M: sqlite-db db-open ( db -- )
- dup sqlite-db-path sqlite-open <db>
- swap set-delegate ;
+M: sqlite-db db-open ( db -- db )
+ [ path>> sqlite-open ] [ swap >>handle ] bi ;
M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ;
-: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
-TUPLE: sqlite-statement ;
-INSTANCE: sqlite-statement throwable-statement
+TUPLE: sqlite-statement < statement ;
-TUPLE: sqlite-result-set has-more? ;
+TUPLE: sqlite-result-set < result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str in out -- obj )
- {
- set-statement-sql
- set-statement-in-params
- set-statement-out-params
- } statement construct
- sqlite-statement construct-delegate ;
+ sqlite-statement construct-statement ;
: sqlite-maybe-prepare ( statement -- statement )
- dup statement-handle [
- [
- delegate
- db get db-handle over statement-sql sqlite-prepare
- swap set-statement-handle
- ] keep
+ dup handle>> [
+ db get handle>> over sql>> sqlite-prepare
+ >>handle
] unless ;
M: sqlite-statement dispose ( statement -- )
- statement-handle
+ handle>>
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- )
- f swap set-result-set-handle ;
-
-: sqlite-bind ( triples handle -- )
- swap [ first3 sqlite-bind-type ] with each ;
+ f >>handle drop ;
: reset-statement ( statement -- )
+ sqlite-maybe-prepare handle>> sqlite-reset ;
+
+: reset-bindings ( statement -- )
sqlite-maybe-prepare
- statement-handle sqlite-reset ;
+ handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
+
+M: sqlite-statement low-level-bind ( statement -- )
+ [ statement-bind-params ] [ statement-handle ] bi
+ swap [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare
- dup statement-bound? [ dup reset-statement ] when
- [ statement-bind-params ] [ statement-handle ] bi
- sqlite-bind ;
+ dup statement-bound? [ dup reset-bindings ] when
+ low-level-bind ;
+
+GENERIC: sqlite-bind-conversion ( tuple obj -- array )
+
+TUPLE: sqlite-low-level-binding < low-level-binding key type ;
+: <sqlite-low-level-binding> ( key value type -- obj )
+ sqlite-low-level-binding new
+ swap >>type
+ swap >>value
+ swap >>key ;
+
+M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
+ [ column-name>> ":" prepend ]
+ [ slot-name>> rot get-slot-named ]
+ [ type>> ] tri <sqlite-low-level-binding> ;
+
+M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
+ nip [ key>> ] [ value>> ] [ type>> ] tri
+ <sqlite-low-level-binding> ;
+
+M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
+ nip [ key>> ] [ singleton>> eval-generator ] [ type>> ] tri
+ <sqlite-low-level-binding> ;
M: sqlite-statement bind-tuple ( tuple statement -- )
[
- statement-in-params
- [
- [ sql-spec-column-name ":" swap append ]
- [ sql-spec-slot-name rot get-slot-named ]
- [ sql-spec-type ] tri 3array
- ] with map
- ] keep
- bind-statement ;
+ in-params>> [ sqlite-bind-conversion ] with map
+ ] keep bind-statement ;
: last-insert-id ( -- id )
db get db-handle sqlite3_last_insert_rowid
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
- result-set-handle sqlite-#columns ;
+ handle>> sqlite-#columns ;
M: sqlite-result-set row-column ( result-set n -- obj )
- >r result-set-handle r> sqlite-column ;
+ [ handle>> ] [ sqlite-column ] bi* ;
M: sqlite-result-set row-column-typed ( result-set n -- obj )
- dup pick result-set-out-params nth sql-spec-type
- >r >r result-set-handle r> r> sqlite-column-typed ;
+ dup pick out-params>> nth type>>
+ >r >r handle>> r> r> sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- )
- [ result-set-handle sqlite-next ] keep
- set-sqlite-result-set-has-more? ;
+ dup handle>> sqlite-next >>has-more? drop ;
M: sqlite-result-set more-rows? ( result-set -- ? )
- sqlite-result-set-has-more? ;
+ has-more?>> ;
M: sqlite-statement query-results ( query -- result-set )
sqlite-maybe-prepare
- dup statement-handle sqlite-result-set <result-set>
+ dup handle>> sqlite-result-set construct-result-set
dup advance-row ;
-M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
-M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
-M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
-
-: sqlite-make ( class quot -- )
- >r sql-props r>
- { "" { } { } } nmake <simple-statement> ; inline
-
M: sqlite-db create-sql-statement ( class -- statement )
[
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
- dup sql-spec-column-name 0%
+ dup column-name>> 0%
" " 0%
- dup sql-spec-type t lookup-type 0%
+ dup type>> lookup-create-type 0%
modifiers 0%
] interleave ");" 0%
- ] sqlite-make ;
+ ] query-make ;
M: sqlite-db drop-sql-statement ( class -- statement )
- [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ;
+ [ "drop table " 0% 0% ";" 0% drop ] query-make ;
M: sqlite-db <insert-native-statement> ( tuple -- statement )
[
"insert into " 0% 0%
"(" 0%
maybe-remove-id
- dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
+ dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
- [ ", " 0% ] [ bind% ] interleave
+ [ ", " 0% ] [
+ dup type>> +random-id+ = [
+ [
+ column-name>> ":" prepend dup 0%
+ random-id-generator
+ ] [ type>> ] bi <generator-bind> 1,
+ ] [
+ bind%
+ ] if
+ ] interleave
");" 0%
- ] sqlite-make ;
+ ] query-make ;
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
-: where-primary-key% ( specs -- )
- " where " 0%
- find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ;
-
-: where-clause ( specs -- )
- " where " 0%
- [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ;
-
-M: sqlite-db <update-tuple-statement> ( class -- statement )
- [
- "update " 0%
- 0%
- " set " 0%
- dup remove-id
- [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
- where-primary-key%
- ] sqlite-make ;
-
-M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
- [
- "delete from " 0% 0%
- " where " 0%
- find-primary-key
- dup sql-spec-column-name 0% " = " 0% bind%
- ] sqlite-make ;
-
-! : select-interval ( interval name -- ) ;
-! : select-sequence ( seq name -- ) ;
+M: sqlite-db bind# ( spec obj -- )
+ >r
+ [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
+ [ type>> ] bi
+ r> <literal-bind> 1, ;
M: sqlite-db bind% ( spec -- )
- dup 1, sql-spec-column-name ":" swap append 0% ;
-
-M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
- [
- "select " 0%
- over [ ", " 0% ]
- [ dup sql-spec-column-name 0% 2, ] interleave
-
- " from " 0% 0%
- [ sql-spec-slot-name swap get-slot-named ] with subset
- dup empty? [ drop ] [ where-clause ] if ";" 0%
- ] sqlite-make ;
+ dup 1, column-name>> ":" prepend 0% ;
-M: sqlite-db modifier-table ( -- hashtable )
+M: sqlite-db persistent-table ( -- assoc )
H{
- { +native-id+ "primary key" }
- { +assigned-id+ "primary key" }
- { +random-id+ "primary key" }
- ! { +nonnative-id+ "primary key" }
- { +autoincrement+ "autoincrement" }
- { +unique+ "unique" }
- { +default+ "default" }
- { +null+ "null" }
- { +not-null+ "not null" }
+ { +native-id+ { "integer primary key" "integer primary key" "primary key" } }
+ { +assigned-id+ { f f "primary key" } }
+ { +random-id+ { "integer primary key" "integer primary key" "primary key" } }
+ { INTEGER { "integer" "integer" "primary key" } }
+ { BIG-INTEGER { "bigint" "bigint" } }
+ { SIGNED-BIG-INTEGER { "bigint" "bigint" } }
+ { UNSIGNED-BIG-INTEGER { "bigint" "bigint" } }
+ { TEXT { "text" "text" } }
+ { VARCHAR { "text" "text" } }
+ { DATE { "date" "date" } }
+ { TIME { "time" "time" } }
+ { DATETIME { "datetime" "datetime" } }
+ { TIMESTAMP { "timestamp" "timestamp" } }
+ { DOUBLE { "real" "real" } }
+ { BLOB { "blob" "blob" } }
+ { FACTOR-BLOB { "blob" "blob" } }
+ { +autoincrement+ { f f "autoincrement" } }
+ { +unique+ { f f "unique" } }
+ { +default+ { f f "default" } }
+ { +null+ { f f "null" } }
+ { +not-null+ { f f "not null" } }
+ { system-random-generator { f f f } }
+ { secure-random-generator { f f f } }
+ { random-generator { f f f } }
} ;
-M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
-
-M: sqlite-db compound-type ( str seq -- str' )
+M: sqlite-db compound ( str seq -- str' )
over {
{ "default" [ first number>string join-space ] }
- [ 2drop ] ! "no sqlite compound data type" 3array throw ]
+ [ 2drop ]
} case ;
-M: sqlite-db type-table ( -- assoc )
- H{
- { +native-id+ "integer primary key" }
- { +random-id+ "integer primary key" }
- { INTEGER "integer" }
- { TEXT "text" }
- { VARCHAR "text" }
- { DATE "date" }
- { TIME "time" }
- { DATETIME "datetime" }
- { TIMESTAMP "timestamp" }
- { DOUBLE "real" }
- { BLOB "blob" }
- { FACTOR-BLOB "blob" }
- } ;
-
-M: sqlite-db create-type-table ( symbol -- str ) type-table ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files kernel tools.test db db.tuples
-db.types continuations namespaces math
-prettyprint tools.walker db.sqlite calendar
-math.intervals db.postgresql ;
+USING: io.files kernel tools.test db db.tuples classes
+db.types continuations namespaces math math.ranges
+prettyprint tools.walker calendar sequences db.sqlite
+math.intervals db.postgresql accessors random math.bitfields.lib ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
[ 1 ] [ person1 get person-the-id ] unit-test
- 200 person1 get set-person-the-number
+ [ ] [ 200 person1 get set-person-the-number ] unit-test
[ ] [ person1 get update-tuple ] unit-test
"teddy"
10
3.14
- T{ timestamp f 2008 3 5 16 24 11 0 }
- T{ timestamp f 2008 11 22 f f f f }
- T{ timestamp f f f f 12 34 56 f }
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
}
] [ T{ person f 3 } select-tuple ] unit-test
"eddie"
10
3.14
- T{ timestamp f 2008 3 5 16 24 11 0 }
- T{ timestamp f 2008 11 22 f f f f }
- T{ timestamp f f f f 12 34 56 f }
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 f f f T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f
H{ { 1 2 } { 3 4 } { 5 "lol" } }
}
[ ] [ person drop-table ] unit-test ;
-: make-native-person-table ( -- )
- [ person drop-table ] [ drop ] recover
- person create-table
- T{ person f f "billy" 200 3.14 } insert-tuple
- T{ person f f "johnny" 10 3.14 } insert-tuple
- ;
-
: native-person-schema ( -- )
person "PERSON"
{
} define-persistent
"billy" 10 3.14 f f f f f <person> person1 set
"johnny" 10 3.14 f f f f f <person> person2 set
- "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <person> person3 set
- "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
+ "teddy" 10 3.14
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <person> person3 set
+ "eddie" 10 3.14
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
: assigned-person-schema ( -- )
person "PERSON"
} define-persistent
1 "billy" 10 3.14 f f f f f <assigned-person> person1 set
2 "johnny" 10 3.14 f f f f f <assigned-person> person2 set
- 3 "teddy" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f <assigned-person> person3 set
- 4 "eddie" 10 3.14 "2008-03-05 16:24:11" "2008-11-22" "12:34:56" f H{ { 1 2 } { 3 4 } { 5 "lol" } } <assigned-person> person4 set ;
+ 3 "teddy" 10 3.14
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
+ f <assigned-person> person3 set
+ 4 "eddie" 10 3.14
+ T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
+ T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
+ f H{ { 1 2 } { 3 4 } { 5 "lol" } } <assigned-person> person4 set ;
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
: test-repeated-insert
[ ] [ person ensure-table ] unit-test
-
[ ] [ person1 get insert-tuple ] unit-test
[ person1 get insert-tuple ] must-fail ;
{ T{ serialize-me f 1 H{ { 1 2 } } } }
] [ T{ serialize-me f 1 } select-tuples ] unit-test ;
-[ test-serialize ] test-sqlite
-! [ test-serialize ] test-postgresql
-
TUPLE: exam id name score ;
-: test-ranges ( -- )
+: test-intervals ( -- )
exam "EXAM"
{
{ "id" "ID" +native-id+ }
[ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test
[
- T{ exam f 3 "Kenny" 60 }
- T{ exam f 4 "Cartman" 41 }
- ] [ T{ exam f 4 f T{ interval f { 0 t } { 70 t } } } select-tuples ] unit-test
- ;
+ {
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
+ ] unit-test
-! [ test-ranges ] test-sqlite
+ [
+ { }
+ ] [
+ T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
+ ] unit-test
+ [
+ {
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
+ ] unit-test
+ [
+ {
+ T{ exam f 3 "Kenny" 60 }
+ }
+ ] [
+ T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
+ ] unit-test
+ [
+ {
+ T{ exam f 3 "Kenny" 60 }
+ T{ exam f 4 "Cartman" 41 }
+ }
+ ] [
+ T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 1 "Kyle" 100 }
+ T{ exam f 2 "Stan" 80 }
+ }
+ ] [
+ T{ exam f f { "Stan" "Kyle" } } select-tuples
+ ] unit-test
+
+ [
+ {
+ T{ exam f 1 "Kyle" 100 }
+ T{ exam f 2 "Stan" 80 }
+ T{ exam f 3 "Kenny" 60 }
+ }
+ ] [
+ T{ exam f T{ range f 1 3 1 } } select-tuples
+ ] unit-test ;
+
+TUPLE: bignum-test id m n o ;
+: <bignum-test> ( m n o -- obj )
+ bignum-test new
+ swap >>o
+ swap >>n
+ swap >>m ;
+
+: test-bignum
+ bignum-test "BIGNUM_TEST"
+ {
+ { "id" "ID" +native-id+ }
+ { "m" "M" BIG-INTEGER }
+ { "n" "N" UNSIGNED-BIG-INTEGER }
+ { "o" "O" SIGNED-BIG-INTEGER }
+ } define-persistent
+ [ bignum-test drop-table ] ignore-errors
+ [ ] [ bignum-test ensure-table ] unit-test
+ [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;
+
+ ! sqlite only
+ ! [ T{ bignum-test f 1
+ ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
+ ! [ T{ bignum-test f 1 } select-tuple ] unit-test ;
TUPLE: secret n message ;
C: <secret> secret
: test-random-id
secret "SECRET"
{
- { "n" "ID" +random-id+ }
+ { "n" "ID" +random-id+ system-random-generator }
{ "message" "MESSAGE" TEXT }
} define-persistent
[ ] [ secret ensure-table ] unit-test
+
[ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
- [ ] [ T{ secret } select-tuples ] unit-test
- ;
+ [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
+
+ [ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test
+ [ t ] [
+ T{ secret } select-tuples
+ first message>> "kilroy was here" head?
+ ] unit-test
-! [ test-random-id ] test-sqlite
- [ native-person-schema test-tuples ] test-sqlite
- [ assigned-person-schema test-tuples ] test-sqlite
-! [ assigned-person-schema test-repeated-insert ] test-sqlite
-! [ native-person-schema test-tuples ] test-postgresql
-! [ assigned-person-schema test-tuples ] test-postgresql
-! [ assigned-person-schema test-repeated-insert ] test-postgresql
+ [ t ] [
+ T{ secret } select-tuples length 3 =
+ ] unit-test ;
-! \ insert-tuple must-infer
-! \ update-tuple must-infer
-! \ delete-tuple must-infer
-! \ select-tuple must-infer
-! \ define-persistent must-infer
+[ native-person-schema test-tuples ] test-sqlite
+[ assigned-person-schema test-tuples ] test-sqlite
+[ assigned-person-schema test-repeated-insert ] test-sqlite
+[ test-bignum ] test-sqlite
+[ test-serialize ] test-sqlite
+[ test-intervals ] test-sqlite
+[ test-random-id ] test-sqlite
+
+[ native-person-schema test-tuples ] test-postgresql
+[ assigned-person-schema test-tuples ] test-postgresql
+[ assigned-person-schema test-repeated-insert ] test-postgresql
+[ test-bignum ] test-postgresql
+[ test-serialize ] test-postgresql
+[ test-intervals ] test-postgresql
+[ test-random-id ] test-postgresql
+
+TUPLE: does-not-persist ;
+
+[
+ [ does-not-persist create-sql-statement ]
+ [ class \ not-persistent = ] must-fail-with
+] test-sqlite
+
+[
+ [ does-not-persist create-sql-statement ]
+ [ class \ not-persistent = ] must-fail-with
+] test-postgresql
+
+! Don't comment these out. These words must infer
+\ bind-tuple must-infer
+\ insert-tuple must-infer
+\ update-tuple must-infer
+\ delete-tuple must-infer
+\ select-tuple must-infer
+\ define-persistent must-infer
+\ ensure-table must-infer
+\ create-table must-infer
+\ drop-table must-infer
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces
-tuples words sequences slots math
+classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
-mirrors sequences.lib tools.walker combinators.lib
-combinators.cleave ;
+mirrors sequences.lib tools.walker combinators.lib ;
IN: db.tuples
: define-persistent ( class table columns -- )
"db-columns" set-word-prop
"db-relations" set-word-prop ;
-: db-table ( class -- obj ) "db-table" word-prop ;
-: db-columns ( class -- obj ) "db-columns" word-prop ;
-: db-relations ( class -- obj ) "db-relations" word-prop ;
+ERROR: not-persistent ;
+
+: db-table ( class -- obj )
+ "db-table" word-prop [ not-persistent ] unless* ;
+
+: db-columns ( class -- obj )
+ "db-columns" word-prop ;
+
+: db-relations ( class -- obj )
+ "db-relations" word-prop ;
: set-primary-key ( key tuple -- )
[
- class db-columns find-primary-key sql-spec-slot-name
+ class db-columns find-primary-key slot-name>>
] keep set-slot-named ;
+SYMBOL: sql-counter
+: next-sql-counter ( -- str )
+ sql-counter [ inc ] [ get ] bi number>string ;
+
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
HOOK: insert-tuple* db ( tuple statement -- )
+GENERIC: eval-generator ( singleton -- obj )
+SINGLETON: retryable
+
+: make-retryable ( obj -- obj' )
+ dup sequence? [
+ [ make-retryable ] map
+ ] [
+ retryable >>type
+ ] if ;
+
+: regenerate-params ( statement -- statement )
+ dup
+ [ bind-params>> ] [ in-params>> ] bi
+ [
+ dup generator-bind? [
+ singleton>> eval-generator >>value
+ ] [
+ drop
+ ] if
+ ] 2map >>bind-params ;
+
+M: retryable execute-statement* ( statement type -- )
+ drop
+ [
+ [ query-results dispose t ]
+ [ ]
+ [ regenerate-params bind-statement* f ] cleanup
+ ] curry 10 retry drop ;
+
: resulting-tuple ( row out-params -- tuple )
- dup first sql-spec-class construct-empty [
+ dup first class>> new [
[
- >r sql-spec-slot-name r> set-slot-named
+ >r slot-name>> r> set-slot-named
] curry 2each
] keep ;
: query-tuples ( statement -- seq )
- [ statement-out-params ] keep query-results [
+ [ out-params>> ] keep query-results [
[ sql-row-typed swap resulting-tuple ] with query-map
] with-disposal ;
: query-modify-tuple ( tuple statement -- )
[ query-results [ sql-row-typed ] with-disposal ] keep
- statement-out-params rot [
- >r sql-spec-slot-name r> set-slot-named
+ out-params>> rot [
+ >r slot-name>> r> set-slot-named
] curry 2each ;
: sql-props ( class -- columns table )
- dup db-columns swap db-table ;
+ [ db-columns ] [ db-table ] bi ;
: with-disposals ( seq quot -- )
over sequence? [
[ with-disposal ] curry each
] [
with-disposal
- ] if ;
+ ] if ; inline
: create-table ( class -- )
create-sql-statement [ execute-statement ] with-disposals ;
[ bind-tuple ] 2keep insert-tuple* ;
: insert-nonnative ( tuple -- )
-! TODO logic here for unique ids
dup class
db get db-insert-statements [ <insert-nonnative-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
- dup class db-columns find-primary-key nonnative-id? [
- insert-nonnative
- ] [
- insert-native
- ] if ;
+ dup class db-columns find-primary-key nonnative-id?
+ [ insert-nonnative ] [ insert-native ] if ;
: update-tuple ( tuple -- )
dup class
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
-mirrors tuples combinators calendar.format symbols
-singleton ;
+mirrors classes.tuple combinators calendar.format symbols
+classes.singleton accessors quotations random ;
IN: db.types
-HOOK: modifier-table db ( -- hash )
-HOOK: compound-modifier db ( str seq -- hash )
-HOOK: type-table db ( -- hash )
-HOOK: create-type-table db ( -- hash )
-HOOK: compound-type db ( str n -- hash )
+HOOK: persistent-table db ( -- hash )
+HOOK: compound db ( str obj -- hash )
-TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
+TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
+
+TUPLE: literal-bind key type value ;
+C: <literal-bind> literal-bind
+
+TUPLE: generator-bind key singleton type ;
+C: <generator-bind> generator-bind
+SINGLETON: random-id-generator
+
+TUPLE: low-level-binding value ;
+C: <low-level-binding> low-level-binding
SINGLETON: +native-id+
SINGLETON: +assigned-id+
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
+: find-random-generator ( seq -- obj )
+ [
+ {
+ random-generator
+ system-random-generator
+ secure-random-generator
+ } member?
+ ] find nip [ system-random-generator ] unless* ;
+
: primary-key? ( spec -- ? )
- sql-spec-primary-key +primary-key+? ;
+ primary-key>> +primary-key+? ;
: native-id? ( spec -- ? )
- sql-spec-primary-key +native-id+? ;
+ primary-key>> +native-id+? ;
: nonnative-id? ( spec -- ? )
- sql-spec-primary-key +nonnative-id+? ;
+ primary-key>> +nonnative-id+? ;
: normalize-spec ( spec -- )
- dup sql-spec-type dup +primary-key+? [
- swap set-sql-spec-primary-key
+ dup type>> dup +primary-key+? [
+ >>primary-key drop
] [
- drop dup sql-spec-modifiers [
+ drop dup modifiers>> [
+primary-key+?
] deep-find
- [ swap set-sql-spec-primary-key ] [ drop ] if*
+ [ >>primary-key drop ] [ drop ] if*
] if ;
: find-primary-key ( specs -- obj )
- [ sql-spec-primary-key ] find nip ;
+ [ primary-key>> ] find nip ;
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
-SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
-DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ;
+SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER
+DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB
+FACTOR-BLOB NULL ;
: spec>tuple ( class spec -- tuple )
- [ ?first3 ] keep 3 ?tail*
- {
- set-sql-spec-class
- set-sql-spec-slot-name
- set-sql-spec-column-name
- set-sql-spec-type
- set-sql-spec-modifiers
- } sql-spec construct
+ 3 f pad-right
+ [ first3 ] keep 3 tail
+ sql-spec new
+ swap >>modifiers
+ swap >>type
+ swap >>column-name
+ swap >>slot-name
+ swap >>class
dup normalize-spec ;
-TUPLE: no-sql-type ;
-: no-sql-type ( -- * ) T{ no-sql-type } throw ;
-
-TUPLE: no-sql-modifier ;
-: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ;
-
: number>string* ( n/str -- str )
dup number? [ number>string ] when ;
[ relation? not ] subset ;
: remove-id ( specs -- obj )
- [ sql-spec-primary-key not ] subset ;
+ [ primary-key>> not ] subset ;
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
+ERROR: unknown-modifier ;
+
: lookup-modifier ( obj -- str )
- dup array? [
- unclip lookup-modifier swap compound-modifier
- ] [
- modifier-table at*
- [ "unknown modifier" throw ] unless
- ] if ;
+ {
+ { [ dup array? ] [ unclip lookup-modifier swap compound ] }
+ [ persistent-table at* [ unknown-modifier ] unless third ]
+ } cond ;
+
+ERROR: no-sql-type ;
-: lookup-type* ( obj -- str )
+: (lookup-type) ( obj -- str )
+ persistent-table at* [ no-sql-type ] unless ;
+
+: lookup-type ( obj -- str )
dup array? [
- first lookup-type*
+ unclip (lookup-type) first nip
] [
- type-table at*
- [ no-sql-type ] unless
+ (lookup-type) first
] if ;
: lookup-create-type ( obj -- str )
dup array? [
- unclip lookup-create-type swap compound-type
+ unclip (lookup-type) second swap compound
] [
- dup create-type-table at*
- [ nip ] [ drop lookup-type* ] if
+ (lookup-type) second
] if ;
-: lookup-type ( obj create? -- str )
- [ lookup-create-type ] [ lookup-type* ] if ;
-
: single-quote ( str -- newstr )
"'" swap "'" 3append ;
" " swap 3append ;
: modifiers ( spec -- str )
- sql-spec-modifiers
- [ lookup-modifier ] map " " join
- dup empty? [ " " swap append ] unless ;
+ modifiers>> [ lookup-modifier ] map " " join
+ dup empty? [ " " prepend ] unless ;
HOOK: bind% db ( spec -- )
-
-TUPLE: no-slot-named ;
-: no-slot-named ( -- * ) T{ no-slot-named } throw ;
-
-: slot-spec-named ( str class -- slot-spec )
- "slots" word-prop [ slot-spec-name = ] with find nip
- [ no-slot-named ] unless* ;
+HOOK: bind# db ( spec obj -- )
: offset-of-slot ( str obj -- n )
- class slot-spec-named slot-spec-offset ;
+ class "slots" word-prop slot-named slot-spec-offset ;
-: get-slot-named ( str obj -- value )
- tuck offset-of-slot [ no-slot-named ] unless* slot ;
+: get-slot-named ( name obj -- value )
+ tuck offset-of-slot slot ;
-: set-slot-named ( value str obj -- )
- tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
+: set-slot-named ( value name obj -- )
+ tuck offset-of-slot set-slot ;
: tuple>filled-slots ( tuple -- alist )
- dup <mirror> mirror-slots [ slot-spec-name ] map
- swap tuple-slots 2array flip [ nip ] assoc-subset ;
+ <mirror> [ nip ] assoc-subset ;
: tuple>params ( specs tuple -- obj )
[
- >r dup sql-spec-type swap sql-spec-slot-name r>
+ >r [ type>> ] [ slot-name>> ] bi r>
get-slot-named swap
] curry { } map>assoc ;
-USING: delegate kernel arrays tools.test ;
+USING: delegate kernel arrays tools.test words math definitions
+compiler.units parser generic prettyprint io.streams.string ;
IN: delegate.tests
+DEFER: example
+[ 1 ] [ \ example 1 "prop" set-word-prop \ example "prop" word-prop ] unit-test
+[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test
+[ 2 ] [ \ example "prop" word-prop ] unit-test
+
TUPLE: hello this that ;
C: <hello> hello
GENERIC: foo ( x -- y )
GENERIC: bar ( a -- b )
-PROTOCOL: baz foo bar ;
+GENERIC# whoa 1 ( s t -- w )
+PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
+
+: hello-test ( hello/goodbye -- array )
+ [ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
CONSULT: baz goodbye goodbye-these ;
M: hello foo hello-this ;
-M: hello bar dup hello? swap hello-that 2array ;
+M: hello bar hello-test ;
+M: hello whoa >r hello-this r> + ;
GENERIC: bing ( c -- d )
-CONSULT: hello goodbye goodbye-these ;
-M: hello bing dup hello? swap hello-that 2array ;
-MIMIC: bing goodbye hello
+PROTOCOL: bee bing ;
+CONSULT: hello goodbye goodbye-those ;
+M: hello bing hello-test ;
+MIMIC: bee goodbye hello
-[ 1 { t 0 } ] [ 1 0 <hello> [ foo ] keep bar ] unit-test
-[ { t 0 } ] [ 1 0 <hello> bing ] unit-test
+[ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
+[ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
-[ { t 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
-[ { f 0 } ] [ 1 0 <hello> f <goodbye> bing ] unit-test
+[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
+! [ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
+[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
+[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
+
+[ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
+[ V{ goodbye } ] [ baz protocol-users ] unit-test
+
+! [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ]
+! [ [ baz see ] with-string-writer ] unit-test
+
+! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
+! [ f ] [ goodbye baz method ] unit-test
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: parser generic kernel classes words slots assocs sequences arrays ;
+USING: parser generic kernel classes words slots assocs sequences arrays
+vectors definitions prettyprint combinators.lib math sets ;
IN: delegate
-: define-protocol ( wordlist protocol -- )
- swap { } like "protocol-words" set-word-prop ;
+! Protocols
+
+: cross-2each ( seq1 seq2 quot -- )
+ [ with each ] 2curry each ; inline
+
+: forget-all-methods ( classes words -- )
+ [ 2array forget ] cross-2each ;
+
+: protocol-words ( protocol -- words )
+ "protocol-words" word-prop ;
+
+: protocol-users ( protocol -- users )
+ "protocol-users" word-prop ;
+
+: users-and-words ( protocol -- users words )
+ [ protocol-users ] [ protocol-words ] bi ;
+
+: forget-old-definitions ( protocol new-wordlist -- )
+ >r users-and-words r>
+ diff forget-all-methods ;
+
+: define-protocol ( protocol wordlist -- )
+ ! 2dup forget-old-definitions
+ { } like "protocol-words" set-word-prop ;
+
+: fill-in-depth ( wordlist -- wordlist' )
+ [ dup word? [ 0 2array ] when ] map ;
: PROTOCOL:
- CREATE-WORD dup define-symbol
- parse-definition swap define-protocol ; parsing
+ CREATE-WORD
+ dup define-symbol
+ dup f "inline" set-word-prop
+ parse-definition fill-in-depth define-protocol ; parsing
+
+PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
+
+M: protocol forget*
+ [ users-and-words forget-all-methods ] [ call-next-method ] bi ;
-PREDICATE: word protocol "protocol-words" word-prop ;
+: show-words ( wordlist' -- wordlist )
+ [ dup second zero? [ first ] when ] map ;
+
+M: protocol definition protocol-words show-words ;
+
+M: protocol definer drop \ PROTOCOL: \ ; ;
+
+M: protocol synopsis* word-synopsis ; ! Necessary?
GENERIC: group-words ( group -- words )
M: protocol group-words
"protocol-words" word-prop ;
-M: generic group-words
- 1array ;
-
M: tuple-class group-words
- "slots" word-prop 1 tail ! The first slot is the delegate
- ! 1 tail should be removed when the delegate slot is removed
- dup [ slot-spec-reader ] map
- swap [ slot-spec-writer ] map append ;
+ "slot-names" word-prop [
+ [ reader-word ] [ writer-word ] bi
+ 2array [ 0 2array ] map
+ ] map concat ;
+
+! Consultation
: define-consult-method ( word class quot -- )
- pick add >r swap create-method r> define ;
+ [ drop swap first create-method ]
+ [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ;
-: define-consult ( class group quot -- )
- >r group-words swap r>
+: change-word-prop ( word prop quot -- )
+ >r swap word-props r> change-at ; inline
+
+: add ( item vector/f -- vector )
+ 2dup member? [ nip ] [ ?push ] if ;
+
+: use-protocol ( class group -- )
+ "protocol-users" [ add ] change-word-prop ;
+
+: define-consult ( group class quot -- )
+ swapd >r 2dup use-protocol group-words swap r>
[ define-consult-method ] 2curry each ;
: CONSULT:
- scan-word scan-word parse-definition swapd define-consult ; parsing
+ scan-word scan-word parse-definition define-consult ; parsing
+
+! Mimic still needs to be updated
+
+: mimic-method ( mimicker mimicked generic -- )
+ tuck method
+ [ [ create-method-in ] [ word-def ] bi* define ]
+ [ 2drop ] if* ;
: define-mimic ( group mimicker mimicked -- )
- >r >r group-words r> r> [
- pick "methods" word-prop at dup
- [ >r swap create-method r> word-def define ]
- [ 3drop ] if
- ] 2curry each ;
+ [ drop swap use-protocol ] [
+ rot group-words -rot
+ [ rot first mimic-method ] 2curry each
+ ] 3bi ;
: MIMIC:
scan-word scan-word scan-word define-mimic ; parsing
IN: delegate.protocols
PROTOCOL: sequence-protocol
- clone clone-like like new new-resizable nth nth-unsafe
+ clone clone-like like new-sequence new-resizable nth nth-unsafe
set-nth set-nth-unsafe length set-length lengthen ;
PROTOCOL: assoc-protocol
- at* assoc-size >alist set-at assoc-clone-like
+ at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 }
delete-at clear-assoc new-assoc assoc-like ;
- ! assoc-find excluded because GENERIC# 1
- ! everything should work, just slower (with >alist)
PROTOCOL: stream-protocol
stream-read1 stream-read stream-read-until dispose
make-cell-stream stream-write-table ;
PROTOCOL: definition-protocol
- where set-where forget uses redefined*
+ where set-where forget uses
synopsis* definer definition ;
-
-PROTOCOL: prettyprint-section-protocol
- section-fits? indent-section? unindent-first-line?
- newline-after? short-section? short-section long-section
- <section> delegate>block add-section ;
-
-
TUPLE: dummy-obj destroyed? ;
-: <dummy-obj> dummy-obj construct-empty ;
+: <dummy-obj> dummy-obj new ;
TUPLE: dummy-destructor obj ;
] if ;
: <destructor> ( obj -- newobj )
- f destructor construct-boa ;
+ f destructor boa ;
: add-error-destructor ( obj -- )
<destructor> error-destructors get push ;
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel new-slots sequences vectors ;
+USING: accessors assocs kernel sequences vectors ;
IN: digraphs
TUPLE: digraph ;
TUPLE: vertex value edges ;
: <digraph> ( -- digraph )
- digraph construct-empty H{ } clone over set-delegate ;
+ digraph new H{ } clone over set-delegate ;
: <vertex> ( value -- vertex )
- V{ } clone vertex construct-boa ;
+ V{ } clone vertex boa ;
: add-vertex ( key value digraph -- )
>r <vertex> swap r> set-at ;
--- /dev/null
+collections
--- /dev/null
+Eric Mertens
--- /dev/null
+USING: accessors arrays hints kernel locals math sequences ;
+
+IN: disjoint-set
+
+<PRIVATE
+
+TUPLE: disjoint-set parents ranks counts ;
+
+: count ( a disjoint-set -- n )
+ counts>> nth ; inline
+
+: add-count ( p a disjoint-set -- )
+ [ count [ + ] curry ] keep counts>> swap change-nth ; inline
+
+: parent ( a disjoint-set -- p )
+ parents>> nth ; inline
+
+: set-parent ( p a disjoint-set -- )
+ parents>> set-nth ; inline
+
+: link-sets ( p a disjoint-set -- )
+ [ set-parent ]
+ [ add-count ] 3bi ; inline
+
+: rank ( a disjoint-set -- r )
+ ranks>> nth ; inline
+
+: inc-rank ( a disjoint-set -- )
+ ranks>> [ 1+ ] change-nth ; inline
+
+: representative? ( a disjoint-set -- ? )
+ dupd parent = ; inline
+
+: representative ( a disjoint-set -- p )
+ 2dup representative? [ drop ] [
+ [ [ parent ] keep representative dup ] 2keep set-parent
+ ] if ;
+
+: representatives ( a b disjoint-set -- r r )
+ [ representative ] curry bi@ ; inline
+
+: ranks ( a b disjoint-set -- r r )
+ [ rank ] curry bi@ ; inline
+
+:: branch ( a b neg zero pos -- )
+ a b = zero [ a b < neg pos if ] if ; inline
+
+PRIVATE>
+
+: <disjoint-set> ( n -- disjoint-set )
+ [ >array ]
+ [ 0 <array> ]
+ [ 1 <array> ] tri
+ disjoint-set boa ;
+
+: equiv-set-size ( a disjoint-set -- n )
+ [ representative ] keep count ;
+
+: equiv? ( a b disjoint-set -- ? )
+ representatives = ; inline
+
+:: equate ( a b disjoint-set -- )
+ a b disjoint-set representatives
+ 2dup = [ 2drop ] [
+ 2dup disjoint-set ranks
+ [ swap ] [ over disjoint-set inc-rank ] [ ] branch
+ disjoint-set link-sets
+ ] if ;
+
+HINTS: equate disjoint-set ;
+HINTS: representative disjoint-set ;
+HINTS: equiv-set-size disjoint-set ;
--- /dev/null
+An efficient implementation of the disjoint-set data structure
--- /dev/null
+collections
: =line ( n loc -- newloc ) second 2array ;
-: lines-equal? ( loc1 loc2 -- ? ) [ first ] 2apply number= ;
+: lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ;
TUPLE: document locs ;
2over = [
3drop
] [
- >r [ first ] 2apply 1+ dup <slice> r> each
+ >r [ first ] bi@ 1+ dup <slice> r> each
] if ; inline
: start/end-on-line ( from to line# -- n1 n2 )
0 swap [ append ] change-nth ;
: append-last ( str seq -- )
- [ length 1- ] keep [ swap append ] change-nth ;
+ [ length 1- ] keep [ prepend ] change-nth ;
: loc-col/str ( loc document -- str col )
>r first2 swap r> nth swap ;
: (set-doc-range) ( newlines from to lines -- )
[ prepare-insert ] 3keep
- >r [ first ] 2apply 1+ r>
+ >r [ first ] bi@ 1+ r>
replace-slice ;
: set-doc-range ( string from to document -- )
-rot {
{ [ over { 0 0 } = ] [ drop ] }
{ [ over second zero? ] [ >r first 1- r> line-end ] }
- { [ t ] [ pick call ] }
+ [ pick call ]
} cond nip ; inline
: (next-char) ( loc document quot -- loc )
-rot {
{ [ 2dup doc-end = ] [ drop ] }
{ [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
- { [ t ] [ pick call ] }
+ [ pick call ]
} cond nip ; inline
M: char-elt prev-elt
[ >r blank? r> xor ] curry ; inline
: (prev-word) ( ? col str -- col )
- rot break-detector find-last*
- drop [ 1+ ] [ 0 ] if* ;
+ rot break-detector find-last* drop ?1+ ;
: (next-word) ( ? col str -- col )
[ rot break-detector find* drop ] keep
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel namespaces sequences definitions io.files
-inspector continuations tuples tools.crossref tools.vocabs
-io prettyprint source-files assocs vocabs vocabs.loader ;
+inspector continuations tools.crossref tools.vocabs
+io prettyprint source-files assocs vocabs vocabs.loader
+io.backend splitting accessors ;
IN: editors
TUPLE: no-edit-hook ;
: editor-restarts ( -- alist )
available-editors
- [ "Load " over append swap ] { } map>assoc ;
+ [ [ "Load " prepend ] keep ] { } map>assoc ;
: no-edit-hook ( -- )
- \ no-edit-hook construct-empty
+ \ no-edit-hook new
editor-restarts throw-restarts
require ;
: edit-location ( file line -- )
- edit-hook get [
- >r >r ?resource-path r> r> call
- ] [
- no-edit-hook edit-location
- ] if* ;
+ >r (normalize-path) r>
+ edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
: edit ( defspec -- )
where [ first2 edit-location ] when* ;
: edit-vocab ( name -- )
vocab-source-path 1 edit-location ;
+GENERIC: find-parse-error ( error -- error' )
+
+M: parse-error find-parse-error
+ dup error>> find-parse-error [ ] [ ] ?if ;
+
+M: condition find-parse-error
+ error>> find-parse-error ;
+
+M: object find-parse-error
+ drop f ;
+
: :edit ( -- )
- error get delegates [ parse-error? ] find-last nip [
- dup parse-error-file source-file-path ?resource-path
- swap parse-error-line edit-location
+ error get find-parse-error [
+ [ file>> path>> ] [ line>> ] bi edit-location
] when* ;
: fix ( word -- )
- "Fixing " write dup pprint " and all usages..." print nl
- dup usage swap add* [
- "Editing " write dup .
- "RETURN moves on to the next usage, C+d stops." print
- flush
- edit
- readln
+ [ "Fixing " write pprint " and all usages..." print nl ]
+ [ [ usage ] keep prefix ] bi
+ [
+ [ "Editing " write . ]
+ [
+ "RETURN moves on to the next usage, C+d stops." print
+ flush
+ edit
+ readln
+ ] bi
] all? drop ;
: editpadpro-path
\ editpadpro-path get-global [
- program-files "JGsoft" path+
+ program-files "JGsoft" append-path
t [ >lower "editpadpro.exe" tail? ] find-file
] unless* ;
: editplus-path ( -- path )
\ editplus-path get-global [
- program-files "\\EditPlus 2\\editplus.exe" path+
+ program-files "\\EditPlus 2\\editplus.exe" append-path
] unless* ;
: editplus ( file line -- )
: emeditor-path ( -- path )
\ emeditor-path get-global [
- program-files "\\EmEditor\\EmEditor.exe" path+
+ program-files "\\EmEditor\\EmEditor.exe" append-path
] unless* ;
: emeditor ( file line -- )
T{ gvim } vim-editor set-global
{
- { [ unix? ] [ "editors.gvim.unix" ] }
- { [ windows? ] [ "editors.gvim.windows" ] }
+ { [ os unix? ] [ "editors.gvim.unix" ] }
+ { [ os windows? ] [ "editors.gvim.windows" ] }
} cond require
-USING: io.unix.backend kernel namespaces editors.gvim.backend ;
+USING: io.unix.backend kernel namespaces editors.gvim.backend
+system ;
IN: editors.gvim.unix
-M: unix-io gvim-path
+M: unix gvim-path
\ gvim-path get-global [
"gvim"
] unless* ;
USING: editors.gvim.backend io.files io.windows kernel namespaces
-sequences windows.shell32 io.paths ;
+sequences windows.shell32 io.paths system ;
IN: editors.gvim.windows
-M: windows-io gvim-path
+M: windows gvim-path
\ gvim-path get-global [
- program-files "vim" path+
+ program-files "vim" append-path
t [ "gvim.exe" tail? ] find-file
] unless* ;
namespaces parser prettyprint sequences strings words
editors io.files io.sockets io.streams.byte-array io.binary
math.parser io.encodings.ascii io.encodings.binary
-io.encodings.utf8 ;
+io.encodings.utf8 io.files.private ;
IN: editors.jedit
: jedit-server-info ( -- port auth )
- home "/.jedit/server" path+ ascii [
+ home ".jedit/server" append-path ascii [
readln drop
readln string>number
readln string>number
] with-stream ;
: jedit-location ( file line -- )
- number>string "+line:" swap append 2array
+ number>string "+line:" prepend 2array
make-jedit-request send-jedit-request ;
: jedit-file ( file -- )
: notepadpp-path
\ notepadpp-path get-global [
- program-files "notepad++\\notepad++.exe" path+
+ program-files "notepad++\\notepad++.exe" append-path
] unless* ;
: notepadpp ( file line -- )
: scite-path ( -- path )
\ scite-path get-global [
- program-files "wscite\\SciTE.exe" path+
+ program-files "wscite\\SciTE.exe" append-path
] unless* ;
: scite-command ( file line -- cmd )
: ted-notepad-path
\ ted-notepad-path get-global [
- program-files "\\TED Notepad\\TedNPad.exe" path+
+ program-files "\\TED Notepad\\TedNPad.exe" append-path
] unless* ;
: ted-notepad ( file line -- )
--- /dev/null
+Ben Schlingelhof
--- /dev/null
+Textwrangler editor integration
--- /dev/null
+! Copyright (C) 2008 Ben Schlingelhof.
+! See http://factorcode.org/license.txt for BSD license.
+USING: definitions io.launcher kernel parser words sequences
+math math.parser namespaces editors ;
+IN: editors.textwrangler
+
+: tw ( file line -- )
+ [ "edit +" % # " " % % ] "" make run-process drop ;
+
+: tw-word ( word -- )
+ where first2 tw ;
+
+[ tw ] edit-hook set-global
: ultraedit-path ( -- path )
\ ultraedit-path get-global [
program-files
- "\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" path+
+ "IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path
] unless* ;
: ultraedit ( file line -- )
! Generate a new factor.vim file for syntax highlighting
-USING: http.server.templating.fhtml io.files ;
+USING: http.server.templating http.server.templating.fhtml
+io.files ;
IN: editors.vim.generate-syntax
: generate-vim-syntax ( -- )
- "misc/factor.vim.fgen" resource-path
+ "misc/factor.vim.fgen" resource-path <fhtml>
"misc/factor.vim" resource-path
template-convert ;
USING: definitions io io.launcher kernel math math.parser
-namespaces parser prettyprint sequences editors ;
+namespaces parser prettyprint sequences editors accessors ;
IN: editors.vim
SYMBOL: vim-path
: vim-location ( file line -- )
vim-command
- vim-detach get-global
- [ run-detached ] [ run-process ] if drop ;
+ <process> swap >>command
+ vim-detach get-global [ t >>detached ] when
+ try-process ;
"vim" vim-path set-global
[ vim-location ] edit-hook set-global
: wordpad-path ( -- path )
\ wordpad-path get [
- program-files "\\Windows NT\\Accessories\\wordpad.exe" path+
+ program-files "Windows NT\\Accessories\\wordpad.exe" append-path
] unless* ;
: wordpad ( file line -- )
- drop wordpad-path swap 2array run-detached drop ;
+ drop wordpad-path swap 2array dup . run-detached drop ;
[ wordpad ] edit-hook set-global
: html>faq ( div -- faq )
unclip swap { "h3" "ol" } [ tags-named ] with map
- first2 >r f add* r> [ html>question-list ] 2map <faq> ;
+ first2 >r f prefix r> [ html>question-list ] 2map <faq> ;
: header, ( faq -- )
dup faq-header ,
"br" contained, nl, ;
: toc-link, ( question-list number -- )
- number>string "#" swap append "href" swap 2array 1array
+ number>string "#" prepend "href" swap 2array 1array
"a" swap [ question-list-title , ] tag*, br, ;
: toc, ( faq -- )
: faq-sections, ( question-lists -- )
unclip question-list-seq length 1+ dupd
[ question-list-seq length + ] accumulate nip
- 0 -rot [ pick question-list>html [ , nl, ] 2apply 1+ ] 2each drop ;
+ 0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ;
: faq>html ( faq -- div )
"div" [
[ "<p>=</p><h2>foo</h2>" ] [ "===foo==" convert-farkup ] unit-test
[ "<h1>foo</h1><p>=</p>" ] [ "=foo==" convert-farkup ] unit-test
-[ "<span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/>" ]
+[ "<div style='white-space: pre; font-family: monospace; '><span class='KEYWORD3'>int</span> <span class='FUNCTION'>main</span><span class='OPERATOR'>(</span><span class='OPERATOR'>)</span><br/></div>" ]
[ "[c{int main()}]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\"/></p>" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
[ "<p><img src=\"lol.jpg\" alt=\"teh lol\"/></p>" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\"></a></p>" ] [ "[[lol.com]]" convert-farkup ] unit-test
[ "<p><a href=\"lol.com\">haha</a></p>" ] [ "[[lol.com|haha]]" convert-farkup ] unit-test
+
+[ ] [ "[{}]" convert-farkup drop ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io kernel memoize namespaces peg sequences strings
-html.elements xml.entities xmode.code2html splitting
-io.streams.string html peg.parsers html.elements sequences.deep
-unicode.categories ;
+USING: arrays io io.styles kernel memoize namespaces peg
+sequences strings html.elements xml.entities xmode.code2html
+splitting io.streams.string html peg.parsers html.elements
+sequences.deep unicode.categories ;
IN: farkup
+<PRIVATE
+
: delimiters ( -- string )
"*_^~%[-=|\\\n" ; inline
: render-code ( string mode -- string' )
>r string-lines r>
- [ [ htmlize-lines ] with-html-stream ] with-string-writer ;
+ [
+ [
+ H{ { wrap-margin f } } [
+ htmlize-lines
+ ] with-nesting
+ ] with-html-stream
+ ] with-string-writer ;
: escape-link ( href text -- href-esc text-esc )
>r escape-quoted-string r> escape-string ;
[ "<p>" swap "</p>" 3array ] unless
] action ;
+PRIVATE>
+
PEG: parse-farkup ( -- parser )
[
list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
--- /dev/null
+USING: arrays float-arrays help.markup help.syntax kernel\r
+float-vectors.private combinators ;\r
+IN: float-vectors\r
+\r
+ARTICLE: "float-vectors" "Float vectors"\r
+"A float vector is a resizable mutable sequence of unsigned floats. Float vector words are found in the " { $vocab-link "float-vectors" } " vocabulary."\r
+$nl\r
+"Float vectors form a class:"\r
+{ $subsection float-vector }\r
+{ $subsection float-vector? }\r
+"Creating float vectors:"\r
+{ $subsection >float-vector }\r
+{ $subsection <float-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: FV{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new float vector is to write:"\r
+{ $code "FV{ } clone" } ;\r
+\r
+ABOUT: "float-vectors"\r
+\r
+HELP: float-vector\r
+{ $description "The class of resizable float vectors. See " { $link "float-vectors" } " for information." } ;\r
+\r
+HELP: <float-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "float-vector" float-vector } }\r
+{ $description "Creates a new float vector that can hold " { $snippet "n" } " floats before resizing." } ;\r
+\r
+HELP: >float-vector\r
+{ $values { "seq" "a sequence" } { "float-vector" float-vector } }\r
+{ $description "Outputs a freshly-allocated float vector with the same elements as a given sequence." }\r
+{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;\r
+\r
+HELP: float-array>vector\r
+{ $values { "float-array" "an array" } { "length" "a non-negative integer" } { "float-vector" float-vector } }\r
+{ $description "Creates a new float vector using the array for underlying storage with the specified initial length." }\r
+{ $warning "This word is in the " { $vocab-link "float-vectors.private" } " vocabulary because it does not perform type or bounds checks. User code should call " { $link >float-vector } " instead." } ;\r
+\r
+HELP: FV{\r
+{ $syntax "FV{ elements... }" }\r
+{ $values { "elements" "a list of real numbers" } }\r
+{ $description "Marks the beginning of a literal float vector. Literal float vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "FV{ 1.0 2.0 3.0 }" } } ;\r
--- /dev/null
+IN: float-vectors.tests\r
+USING: tools.test float-vectors vectors sequences kernel ;\r
+\r
+[ 0 ] [ 123 <float-vector> length ] unit-test\r
+\r
+: do-it\r
+ 12345 [ over push ] each ;\r
+\r
+[ t ] [\r
+ 3 <float-vector> do-it\r
+ 3 <vector> do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ FV{ } float-vector? ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays kernel kernel.private math sequences\r
+sequences.private growable float-arrays prettyprint.backend\r
+parser accessors ;\r
+IN: float-vectors\r
+\r
+TUPLE: float-vector underlying fill ;\r
+\r
+M: float-vector underlying underlying>> { float-array } declare ;\r
+\r
+M: float-vector set-underlying (>>underlying) ;\r
+\r
+M: float-vector length fill>> { array-capacity } declare ;\r
+\r
+M: float-vector set-fill (>>fill) ;\r
+\r
+<PRIVATE\r
+\r
+: float-array>vector ( float-array length -- float-vector )\r
+ float-vector boa ; inline\r
+\r
+PRIVATE>\r
+\r
+: <float-vector> ( n -- float-vector )\r
+ 0.0 <float-array> 0 float-array>vector ; inline\r
+\r
+: >float-vector ( seq -- float-vector )\r
+ T{ float-vector f F{ } 0 } clone-like ;\r
+\r
+M: float-vector like\r
+ drop dup float-vector? [\r
+ dup float-array?\r
+ [ dup length float-array>vector ] [ >float-vector ] if\r
+ ] unless ;\r
+\r
+M: float-vector new-sequence\r
+ drop [ 0.0 <float-array> ] keep >fixnum float-array>vector ;\r
+\r
+M: float-vector equal?\r
+ over float-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: float-array new-resizable drop <float-vector> ;\r
+\r
+INSTANCE: float-vector growable\r
+\r
+: FV{ \ } [ >float-vector ] parse-literal ; parsing\r
+\r
+M: float-vector >pprint-sequence ;\r
+\r
+M: float-vector pprint-delims drop \ FV{ \ } ;\r
--- /dev/null
+Growable float arrays
--- /dev/null
+collections
IN: freetype
<< "freetype" {
- { [ macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] }
- { [ windows? ] [ "freetype6.dll" "cdecl" add-library ] }
+ { [ os macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] }
+ { [ os windows? ] [ "freetype6.dll" "cdecl" add-library ] }
{ [ t ] [ drop ] }
} cond >>
{ { $link curry } { $snippet ": curry '[ , @ ] ;" } }\r
{ { $link with } { $snippet ": with swapd '[ , _ @ ] ;" } }\r
{ { $link compose } { $snippet ": compose '[ @ @ ] ;" } }\r
- { { $link 2apply } { $snippet ": 2apply tuck '[ , @ , @ ] call ;" } }\r
+ { { $link bi@ } { $snippet ": bi@ tuck '[ , @ , @ ] call ;" } }\r
} ;\r
\r
ARTICLE: "fry.philosophy" "Fried quotation philosophy"\r
: funny-dip '[ @ _ ] call ; inline
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
+
+[ { 1 2 3 } ] [
+ 3 1 '[ , [ , + ] map ] call
+] unit-test
: @ "Only valid inside a fry" throw ;
: _ "Only valid inside a fry" throw ;
-DEFER: (fry)
+DEFER: (shallow-fry)
-: ((fry)) ( accum quot adder -- result )
- >r [ ] swap (fry) r>
+: ((shallow-fry)) ( accum quot adder -- result )
+ >r [ ] swap (shallow-fry) r>
append swap dup empty? [ drop ] [
[ swap compose ] curry append
] if ; inline
-: (fry) ( accum quot -- result )
+: (shallow-fry) ( accum quot -- result )
dup empty? [
drop 1quotation
] [
unclip {
- { , [ [ curry ] ((fry)) ] }
- { @ [ [ compose ] ((fry)) ] }
+ { \ , [ [ curry ] ((shallow-fry)) ] }
+ { \ @ [ [ compose ] ((shallow-fry)) ] }
! to avoid confusion, remove if fry goes core
- { namespaces:, [ [ curry ] ((fry)) ] }
+ { \ namespaces:, [ [ curry ] ((shallow-fry)) ] }
- [ swap >r add r> (fry) ]
+ [ swap >r suffix r> (shallow-fry) ]
} case
] if ;
-: trivial-fry ( quot -- quot' ) [ ] swap (fry) ;
+: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
-: fry ( quot -- quot' )
+: deep-fry ( quot -- quot' )
{ _ } last-split1 [
[
- trivial-fry %
+ shallow-fry %
[ >r ] %
- fry %
+ deep-fry %
[ [ dip ] curry r> compose ] %
] [ ] make
] [
- trivial-fry
+ shallow-fry
] if* ;
+: fry ( quot -- quot' )
+ [
+ [
+ dup callable? [
+ [
+ [ { , namespaces:, @ } member? ] subset length
+ \ , <repetition> %
+ ]
+ [ deep-fry % ] bi
+ ] [ namespaces:, ] if
+ ] each
+ ] [ ] make deep-fry ;
+
: '[ \ ] parse-until fry over push-all ; parsing
TUPLE: cursortree cursors ;
: <cursortree> ( seq -- cursortree )
- <gb> cursortree construct-empty tuck set-delegate <avl>
+ <gb> cursortree new tuck set-delegate <avl>
over set-cursortree-cursors ;
GENERIC: cursortree-gb ( cursortree -- gb )
M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ;
: <cursor> ( cursortree -- cursor )
- cursor construct-empty tuck set-cursor-tree ;
+ cursor new tuck set-cursor-tree ;
: make-cursor ( cursortree pos cursor -- cursor )
>r swap <cursor> r> tuck set-delegate tuck set-cursor-pos ;
: <left-cursor> ( cursortree pos -- left-cursor )
- left-cursor construct-empty make-cursor ;
+ left-cursor new make-cursor ;
: <right-cursor> ( cursortree pos -- right-cursor )
- right-cursor construct-empty make-cursor ;
+ right-cursor new make-cursor ;
: cursors ( cursortree -- seq )
cursortree-cursors values concat ;
tuck gb-expand-factor * ceiling >fixnum swap gb-min-size max ;
: <gb> ( seq -- gb )
- gb construct-empty
+ gb new
5 over set-gb-min-size
1.5 over set-gb-expand-factor
[ >r length r> set-gb-gap-start ] 2keep
+collections
collections sequences
load-bitmap [ <graphics-gadget> "bitmap" open-window ] keep ;
: test-bitmap24 ( -- )
- "misc/graphics/bmps/thiswayup24.bmp" resource-path bitmap. ;
+ "extra/graphics/bitmap/test-data/thiswayup24.bmp" resource-path bitmap. ;
: test-bitmap8 ( -- )
- "misc/graphics/bmps/rgb8bit.bmp" resource-path bitmap. ;
+ "extra/graphics/bitmap/test-data/rgb8bit.bmp" resource-path bitmap. ;
: test-bitmap4 ( -- )
- "misc/graphics/bmps/rgb4bit.bmp" resource-path
+ "extra/graphics/bitmap/test-data/rgb4bit.bmp" resource-path
load-bitmap ;
! bitmap. ;
: test-bitmap1 ( -- )
- "misc/graphics/bmps/1bit.bmp" resource-path bitmap. ;
+ "extra/graphics/bitmap/test-data/1bit.bmp" resource-path bitmap. ;
+USING: system ;
IN: hardware-info.backend
-SYMBOL: os
HOOK: cpus os ( -- n )
-
+HOOK: cpu-mhz os ( -- n )
HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n )
-USING: alien.syntax kernel math prettyprint
+USING: alien.syntax kernel math prettyprint io math.parser
combinators vocabs.loader hardware-info.backend system ;
IN: hardware-info
-: kb. ( x -- ) 10 2^ /f . ;
-: megs. ( x -- ) 20 2^ /f . ;
-: gigs. ( x -- ) 30 2^ /f . ;
+: write-unit ( x n str -- )
+ [ 2^ /f number>string write bl ] [ write ] bi* ;
-<<
-{
- { [ windows? ] [ "hardware-info.windows" ] }
- { [ linux? ] [ "hardware-info.linux" ] }
- { [ macosx? ] [ "hardware-info.macosx" ] }
- { [ t ] [ f ] }
+: kb ( x -- ) 10 "kB" write-unit ;
+: megs ( x -- ) 20 "MB" write-unit ;
+: gigs ( x -- ) 30 "GB" write-unit ;
+: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
+
+<< {
+ { [ os windows? ] [ "hardware-info.windows" ] }
+ { [ os linux? ] [ "hardware-info.linux" ] }
+ { [ os macosx? ] [ "hardware-info.macosx" ] }
+ [ f ]
} cond [ require ] when* >>
+: hardware-report. ( -- )
+ "CPUs: " write cpus number>string write nl
+ "CPU Speed: " write cpu-mhz ghz nl
+ "Physical RAM: " write physical-mem megs nl ;
-USING: alien alien.c-types alien.syntax byte-arrays kernel
-namespaces sequences unix hardware-info.backend ;
+USING: alien alien.c-types alien.strings alien.syntax
+byte-arrays kernel namespaces sequences unix
+hardware-info.backend system io.unix.backend io.encodings.ascii
+;
IN: hardware-info.macosx
-TUPLE: macosx ;
-T{ macosx } os set-global
-
! See /usr/include/sys/sysctl.h for constants
LIBRARY: libc
[ <int> ] map concat ;
: (sysctl-query) ( name namelen oldp oldlenp -- oldp error/f )
- over >r
- f 0 sysctl -1 = [ err_no strerror ] [ f ] if
- r> swap ;
+ over >r f 0 sysctl io-error r> ;
: sysctl-query ( seq n -- byte-array )
- >r [ make-int-array ] keep length r>
- [ <byte-array> ] keep <uint>
- (sysctl-query) [ throw ] when* ;
+ >r [ make-int-array ] [ length ] bi r>
+ [ <byte-array> ] [ <uint> ] bi (sysctl-query) ;
: sysctl-query-string ( seq -- n )
- 4096 sysctl-query alien>char-string ;
+ 4096 sysctl-query ascii malloc-string ;
: sysctl-query-uint ( seq -- n )
4 sysctl-query *uint ;
: model ( -- str ) { 6 2 } sysctl-query-string ;
M: macosx cpus ( -- n ) { 6 3 } sysctl-query-uint ;
: byte-order ( -- n ) { 6 4 } sysctl-query-uint ;
-: user-mem ( -- n ) { 6 4 } sysctl-query-uint ;
+M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
+: user-mem ( -- n ) { 6 6 } sysctl-query-uint ;
: page-size ( -- n ) { 6 7 } sysctl-query-uint ;
+: disknames ( -- n ) { 6 8 } 8 sysctl-query ;
+: diskstats ( -- n ) { 6 9 } 8 sysctl-query ;
+: epoch ( -- n ) { 6 10 } sysctl-query-uint ;
+: floating-point ( -- n ) { 6 11 } sysctl-query-uint ;
+: machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
+: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
: bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ;
-: cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ;
+M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ;
: cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;
: l2-cache-size ( -- n ) { 6 20 } sysctl-query-uint ;
: l3-cache-settings ( -- n ) { 6 21 } sysctl-query-uint ;
: l3-cache-size ( -- n ) { 6 22 } sysctl-query-uint ;
-: bus-frequency2 ( -- n ) { 6 23 } sysctl-query-uint ;
-M: macosx physical-mem ( -- n ) { 6 24 } sysctl-query-ulonglong ;
+: tb-frequency ( -- n ) { 6 23 } sysctl-query-uint ;
+: mem-size ( -- n ) { 6 24 } sysctl-query-ulonglong ;
: available-cpus ( -- n ) { 6 25 } sysctl-query-uint ;
USING: alien.c-types hardware-info kernel math namespaces
-windows windows.kernel32 hardware-info.backend ;
+windows windows.kernel32 hardware-info.backend system ;
IN: hardware-info.windows.ce
-TUPLE: wince-os ;
-T{ wince-os } os set-global
-
: memory-status ( -- MEMORYSTATUS )
"MEMORYSTATUS" <c-object>
"MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
[ GlobalMemoryStatus ] keep ;
-M: wince-os cpus ( -- n ) 1 ;
+M: wince cpus ( -- n ) 1 ;
-M: wince-os memory-load ( -- n )
+M: wince memory-load ( -- n )
memory-status MEMORYSTATUS-dwMemoryLoad ;
-M: wince-os physical-mem ( -- n )
+M: wince physical-mem ( -- n )
memory-status MEMORYSTATUS-dwTotalPhys ;
-M: wince-os available-mem ( -- n )
+M: wince available-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailPhys ;
-M: wince-os total-page-file ( -- n )
+M: wince total-page-file ( -- n )
memory-status MEMORYSTATUS-dwTotalPageFile ;
-M: wince-os available-page-file ( -- n )
+M: wince available-page-file ( -- n )
memory-status MEMORYSTATUS-dwAvailPageFile ;
-M: wince-os total-virtual-mem ( -- n )
+M: wince total-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwTotalVirtual ;
-M: wince-os available-virtual-mem ( -- n )
+M: wince available-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailVirtual ;
-USING: alien alien.c-types
+USING: alien alien.c-types alien.strings
kernel libc math namespaces hardware-info.backend
-windows windows.advapi32 windows.kernel32 ;
+windows windows.advapi32 windows.kernel32 system ;
IN: hardware-info.windows.nt
-TUPLE: winnt-os ;
-T{ winnt-os } os set-global
-
: system-info ( -- SYSTEM_INFO )
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
-M: winnt-os cpus ( -- n )
+M: winnt cpus ( -- n )
system-info SYSTEM_INFO-dwNumberOfProcessors ;
: memory-status ( -- MEMORYSTATUSEX )
"MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
[ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ;
-M: winnt-os memory-load ( -- n )
+M: winnt memory-load ( -- n )
memory-status MEMORYSTATUSEX-dwMemoryLoad ;
-M: winnt-os physical-mem ( -- n )
+M: winnt physical-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPhys ;
-M: winnt-os available-mem ( -- n )
+M: winnt available-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPhys ;
-M: winnt-os total-page-file ( -- n )
+M: winnt total-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPageFile ;
-M: winnt-os available-page-file ( -- n )
+M: winnt available-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPageFile ;
-M: winnt-os total-virtual-mem ( -- n )
+M: winnt total-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalVirtual ;
-M: winnt-os available-virtual-mem ( -- n )
+M: winnt available-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
+: pull-win32-string [ utf16n alien>string ] keep free ;
+
: computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1+ [ malloc ] keep
<int> dupd GetComputerName zero? [
free win32-error f
] [
- [ alien>u16-string ] keep free
+ pull-win32-string
] if ;
: username ( -- string )
<int> dupd GetUserName zero? [
free win32-error f
] [
- [ alien>u16-string ] keep free
+ pull-win32-string
] if ;
USING: alien alien.c-types kernel libc math namespaces
windows windows.kernel32 windows.advapi32
words combinators vocabs.loader hardware-info.backend
-system ;
+system alien.strings ;
IN: hardware-info.windows
: system-info ( -- SYSTEM_INFO )
os-version OSVERSIONINFO-dwPlatformId ;
: windows-service-pack ( -- string )
- os-version OSVERSIONINFO-szCSDVersion alien>u16-string ;
+ os-version OSVERSIONINFO-szCSDVersion utf16n alien>string ;
: feature-present? ( n -- ? )
IsProcessorFeaturePresent zero? not ;
: get-directory ( word -- str )
>r MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd r>
- execute win32-error=0/f alien>u16-string ; inline
+ execute win32-error=0/f utf16n alien>string ; inline
: windows-directory ( -- str )
\ GetWindowsDirectory get-directory ;
<<
{
- { [ wince? ] [ "hardware-info.windows.ce" ] }
- { [ winnt? ] [ "hardware-info.windows.nt" ] }
+ { [ os wince? ] [ "hardware-info.windows.ce" ] }
+ { [ os winnt? ] [ "hardware-info.windows.nt" ] }
} cond [ require ] when* >>
USING: tools.deploy.config ;
H{
- { deploy-io 1 }
- { deploy-compiler? t }
{ deploy-word-defs? f }
- { deploy-word-props? f }
- { deploy-math? t }
+ { deploy-random? f }
{ deploy-name "Hello world" }
- { deploy-c-types? f }
- { deploy-ui? t }
{ deploy-threads? t }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-c-types? f }
+ { deploy-io 1 }
{ deploy-reflection 1 }
+ { deploy-ui? t }
{ "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
USING: tools.deploy.config ;
H{
+ { deploy-word-defs? f }
+ { deploy-random? f }
{ deploy-name "Hello world (console)" }
{ deploy-threads? f }
- { deploy-c-types? f }
{ deploy-compiler? f }
- { deploy-ui? f }
{ deploy-math? f }
- { deploy-reflection 1 }
- { deploy-word-defs? f }
+ { deploy-c-types? f }
{ deploy-io 2 }
- { deploy-word-props? f }
+ { deploy-reflection 1 }
+ { deploy-ui? f }
{ "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
}
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
- "\"mydata.dat\" dup file-info file-info-length ["
+ "\"mydata.dat\" dup file-info size>> ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-file"
}
":errors - print 2 compiler errors."
":warnings - print 50 compiler warnings."
}
-"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erronous stack effect declarations."
+"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
{ $references
"To learn more about the compiler and static stack effect inference, read these articles:"
"compiler"
{ $code "#! /usr/bin/env factor -script" }
"Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
$nl
-"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch supresses compiler messages, and exits Factor when the script finishes."
+"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch suppresses compiler messages, and exits Factor when the script finishes."
{ $references
{ }
"cli"
} ;
ARTICLE: "cookbook-philosophy" "Factor philosophy"
-"Factor is a high-level language with automatic memory management, runtime type checking, and strong typing. Factor code should be as simple as possible, but not simpler. If you are coming to Factor from another programming language, one of your first observations might be related to the amount of code you " { $emphasis "don't" } " have to write."
+"Learning a stack language is like learning to ride a bicycle: it takes a bit of practice and you might graze your knees a couple of times, but once you get the hang of it, it becomes second nature."
$nl
-"If you try to write Factor word definitions which are longer than a couple of lines, you will find it hard to keep track of the stack contents. Well-written Factor code is " { $emphasis "factored" } " into short definitions, where each definition is easy to test interactively, and has a clear purpose. Well-chosen word names are critical, and having a thesaurus on hand really helps."
-$nl
-"If you run into problems with stack shuffling, take a deep breath and a step back, and reconsider the problem. A much simpler solution is waiting right around the corner, a natural solution which requires far less stack shuffling and far less code. As a last resort, if no simple solution exists, consider defining a domain-specific language."
-$nl
-"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition and save yourself some debugging time."
-$nl
-"In addition to writing short definitions and testing them interactively, a great habit to get into is writing unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } "."
+"The most common difficulty encountered by beginners is trouble reading and writing code as a result of trying to place too many values on the stack at a time."
$nl
+"Keep the following guidelines in mind to avoid losing your sense of balance:"
+{ $list
+ "Simplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
+ "In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code."
+ "If your code looks repetitive, factor it some more."
+ "If after factoring, your code still looks repetitive, introduce combinators."
+ "If after introducing combinators, your code still looks repetitive, look into using meta-programming techniques."
+ "Try to place items on the stack in the order in which they are needed. If everything is in the correct order, no shuffling needs to be performed."
+ "If you find yourself writing a stack comment in the middle of a word, break the word up."
+ { "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." }
+ { "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." }
+ "Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition."
+ { "Learn to use the " { $link "inference" } " tool." }
+ { "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." }
+ "Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution."
+ { "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." }
+ { "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." }
+ { "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." }
+ { "If you find yourself wishing you could iterate over the datastack, or capture the contents of the datastack into a sequence, or push each element of a sequence onto the datastack, there is almost always a better way. Use " { $link "sequences" } " instead." }
+ "Don't use meta-programming if there's a simpler way."
+ "Don't worry about efficiency unless your program is too slow. Don't prefer complex code to simple code just because you feel it will be more efficient. The Factor compiler is designed to make idiomatic code run fast."
+ { "None of the above are hard-and-fast rules: there are exceptions to all of them. But one rule unconditionally holds: " { $emphasis "there is always a simpler way" } "." }
+}
"Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code."
$nl
"Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ;
$nl
"Unit tests for the " { $vocab-link "inference" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:"
{ $code "\"inference\" test" }
- "In general, you should strive to write code with inferrable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
+ "In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
} ;
collect-elements [ \ f or ] map ;
: help-path ( topic -- seq )
- [ dup ] [ [ article-parent ] keep ] [ ] unfold nip 1 tail ;
+ [ article-parent ] follow 1 tail ;
: set-article-parents ( parent article -- )
article-children [ set-article-parent ] with each ;
namespaces words sequences classes assocs vocabs kernel arrays
prettyprint.backend kernel.private io generic math system
strings sbufs vectors byte-arrays bit-arrays float-arrays
-quotations io.streams.byte-array io.encodings.string ;
+quotations io.streams.byte-array io.encodings.string
+classes.builtin parser ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
{ { $snippet { $emphasis "foo" } "?" } "outputs a boolean" { { $link empty? } } }
{ { $snippet "?" { $emphasis "foo" } } { "conditionally performs " { $snippet { $emphasis "foo" } } } { { $links ?nth } } }
{ { $snippet "<" { $emphasis "foo" } ">" } { "creates a new " { $snippet "foo" } } { { $link <array> } } }
+ { { $snippet "new-" { $emphasis "foo" } } { "creates a new " { $snippet "foo" } ", taking some kind of parameter from the stack which determines the type of the object to be created" } { { $link new-sequence } ", " { $link new-lexer } ", " { $link new } } }
{ { $snippet { $emphasis "foo" } "*" } { "alternative form of " { $snippet "foo" } ", or a generic word called by " { $snippet "foo" } } { { $links at* pprint* } } }
{ { $snippet "(" { $emphasis "foo" } ")" } { "implementation detail word used by " { $snippet "foo" } } { { $link (clone) } } }
{ { $snippet "set-" { $emphasis "foo" } } { "sets " { $snippet "foo" } " to a new value" } { $links set-length } }
"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage."
{ $see-also "compiler" } ;
-ARTICLE: "dataflow" "Data and control flow"
-{ $subsection "evaluator" }
-{ $subsection "words" }
-{ $subsection "effects" }
-{ $subsection "shuffle-words" }
-{ $subsection "booleans" }
-{ $subsection "conditionals" }
-{ $subsection "basic-combinators" }
-{ $subsection "combinators" }
-{ $subsection "continuations" } ;
-
USING: concurrency.combinators
concurrency.messaging
concurrency.promises
{ $subsection "vectors" }
"Resizable specialized sequences:"
{ $subsection "sbufs" }
-{ $subsection "bit-vectors" }
-{ $subsection "byte-vectors" }
-{ $subsection "float-vectors" }
+{ $vocab-subsection "Bit vectors" "bit-vectors" }
+{ $vocab-subsection "Byte vectors" "byte-vectors" }
+{ $vocab-subsection "Float vectors" "float-vectors" }
{ $heading "Associative mappings" }
{ $subsection "assocs" }
{ $subsection "namespaces" }
"Implementations:"
{ $subsection "hashtables" }
{ $subsection "alists" }
+{ $subsection "enums" }
{ $heading "Other collections" }
{ $subsection "boxes" }
{ $subsection "dlists" }
{ $subsection "graphs" }
{ $subsection "buffers" } ;
-USING: io.sockets io.launcher io.mmap io.monitors ;
+USING: io.sockets io.launcher io.mmap io.monitors
+io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;
+
+ARTICLE: "encodings-introduction" "An introduction to encodings"
+"In order to express text in terms of binary, some sort of encoding has to be used. In a modern context, this is understood as a two-way mapping between Unicode code points (characters) and some amount of binary. Since English isn't the only language in the world, ASCII is not sufficient as a mapping from binary to Unicode; it can't even express em-dashes or curly quotes. Unicode was designed as a universal character set that could potentially represent everything." $nl
+"Not all encodings can represent all Unicode code points, but Unicode can represent basically everything that exists in modern encodings. Some encodings are language-specific, and some can represent everything in Unicode. Though the world is moving toward Unicode and UTF-8, the reality today is that there are several encodings which must be taken into account." $nl
+"Factor uses a system of encoding descriptors to denote encodings. Encoding descriptors are objects which describe encodings. Examples are " { $link utf8 } ", " { $link ascii } " and " { $link binary } ". Encoding descriptors can be passed around independently. Each encoding descriptor has some method for constructing an encoded or decoded stream, and the resulting stream has an encoding descriptor stored which has methods for reading or writing characters." $nl
+"Constructors for streams which deal with bytes usually take an encoding as an explicit parameter. For example, to open a text file for reading whose contents are in UTF-8, use the following"
+{ $code "\"file.txt\" utf8 <file-reader>" }
+"If there is an error in the encoded stream, a replacement character (0xFFFD) will be inserted. To throw an exception upon error, use a strict encoding as follows"
+{ $code "\"file.txt\" utf8 strict <file-reader>" }
+"In a similar way, encodings can be specified when opening a file for writing."
+{ $code "\"file.txt\" ascii <file-writer>" }
+"An encoding is also needed for some words that don't return streams, such as " { $link file-contents } ", for example"
+{ $code "\"file.txt\" utf16 file-contents" }
+"Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text."
+$nl
+"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ;
ARTICLE: "io" "Input and output"
{ $heading "Streams" }
{ $subsection "io.mmap" }
{ $subsection "io.monitors" }
{ $heading "Encodings" }
+{ $subsection "encodings-introduction" }
{ $subsection "io.encodings" }
{ $subsection "io.encodings.string" }
{ $heading "Other features" }
{ $subsection "tools.vocabs" }
"Exploratory tools:"
{ $subsection "editor" }
+{ $subsection "listener" }
{ $subsection "tools.crossref" }
{ $subsection "inspector" }
"Debugging tools:"
{ $subsection "collections" }
{ $subsection "io" }
{ $subsection "concurrency" }
-{ $subsection "os" }
+{ $subsection "system" }
{ $subsection "alien" }
{ $heading "Environment reference" }
{ $subsection "cli" }
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io kernel namespaces parser prettyprint sequences
words assocs definitions generic quotations effects slots
-continuations tuples debugger combinators vocabs help.stylesheet
-help.topics help.crossref help.markup sorting classes
-vocabs.loader ;
+continuations classes.tuple debugger combinators vocabs
+help.stylesheet help.topics help.crossref help.markup sorting
+classes vocabs.loader ;
IN: help
GENERIC: word-help* ( word -- content )
M: word word-help* drop f ;
-M: slot-reader word-help* drop \ $slot-reader ;
-
-M: slot-writer word-help* drop \ $slot-writer ;
-
M: predicate word-help* drop \ $predicate ;
: all-articles ( -- seq )
\ $error-description swap word-help elements empty? not ;
: sort-articles ( seq -- newseq )
- [ dup article-title ] { } map>assoc sort-values 0 <column> ;
+ [ dup article-title ] { } map>assoc sort-values keys ;
: all-errors ( -- seq )
all-words [ error? ] subset sort-articles ;
: about ( vocab -- )
dup require
dup vocab [ ] [
- "No such vocabulary: " swap append throw
+ "No such vocabulary: " prepend throw
] ?if
dup vocab-help [
help
{
{ [ dup empty? ] [ (:help-none) ] }
{ [ dup length 1 = ] [ first help ] }
- { [ t ] [ (:help-multi) ] }
+ [ (:help-multi) ]
} cond (:help-debugger) ;
: remove-article ( name -- )
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate
-macros combinators.lib sequences.lib math ;
+macros combinators.lib sequences.lib math sets ;
IN: help.lint
: check-example ( element -- )
{
$shuffle
$values-x/y
- $slot-reader
- $slot-writer
$predicate
$class-description
$error-description
: check-see-also ( word element -- )
nip \ $see-also swap elements [
- 1 tail dup prune [ length ] 2apply assert=
+ 1 tail dup prune [ length ] bi@ assert=
] each ;
: vocab-exists? ( name -- ? )
TUPLE: blahblah quux ;
-: test-slot blahblah "slots" word-prop second ;
-
-[
- { { "blahblah" { $instance blahblah } } { "quux" { $instance object } } }
-] [
- test-slot blahblah ($spec-reader-values)
-] unit-test
-
-[ ] [
- test-slot blahblah $spec-reader-values
-] unit-test
-
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ blahblah-quux help ] unit-test
! Element types are words whose name begins with $.
-PREDICATE: array simple-element
+PREDICATE: simple-element < array
dup empty? [ drop t ] [ first word? not ] if ;
SYMBOL: last-element
[ strong-style get print-element* ] ($heading) ;
: ($code-style) ( presentation -- hash )
- presented associate code-style get union ;
+ presented associate code-style get assoc-union ;
: ($code) ( presentation quot -- )
[
link-style get [ write-object ] with-style ;
: ($link) ( article -- )
- dup article-name swap >link write-link
- span last-element set ;
+ [ dup article-name swap >link write-link ] ($span) ;
: $link ( element -- )
first ($link) ;
[ first ($long-link) ] ($subsection) ;
: ($vocab-link) ( text vocab -- )
- dup vocab-root >vocab-link write-link ;
+ >vocab-link write-link ;
: $vocab-subsection ( element -- )
[
: values-row ( seq -- seq )
unclip \ $snippet swap ?word-name 2array
- swap dup first word? [ \ $instance add* ] when 2array ;
+ swap dup first word? [ \ $instance prefix ] when 2array ;
: $values ( element -- )
"Inputs and outputs" $heading
{ $link with-pprint } " combinator."
} $notes ;
-: ($spec-reader-values) ( slot-spec class -- element )
- dup ?word-name swap 2array
- over slot-spec-name
- rot slot-spec-type 2array 2array
- [ { $instance } swap add ] assoc-map ;
-
-: $spec-reader-values ( slot-spec class -- )
- ($spec-reader-values) $values ;
-
-: $spec-reader-description ( slot-spec class -- )
- [
- "Outputs the value stored in the " ,
- { $snippet } rot slot-spec-name add ,
- " slot of " ,
- { $instance } swap add ,
- " instance." ,
- ] { } make $description ;
-
-: $spec-reader ( reader slot-specs class -- )
- >r slot-of-reader r>
- over [
- 2dup $spec-reader-values
- 2dup $spec-reader-description
- ] when 2drop ;
-
-GENERIC: slot-specs ( help-type -- specs )
-
-M: word slot-specs "slots" word-prop ;
-
-: $slot-reader ( reader -- )
- first dup "reading" word-prop [ slot-specs ] keep
- $spec-reader ;
-
-: $spec-writer-values ( slot-spec class -- )
- ($spec-reader-values) reverse $values ;
-
-: $spec-writer-description ( slot-spec class -- )
- [
- "Stores a new value to the " ,
- { $snippet } rot slot-spec-name add ,
- " slot of " ,
- { $instance } swap add ,
- " instance." ,
- ] { } make $description ;
-
-: $spec-writer ( writer slot-specs class -- )
- >r slot-of-writer r>
- over [
- 2dup $spec-writer-values
- 2dup $spec-writer-description
- dup ?word-name 1array $side-effects
- ] when 2drop ;
-
-: $slot-writer ( reader -- )
- first dup "writing" word-prop [ slot-specs ] keep
- $spec-writer ;
-
GENERIC: elements* ( elt-type element -- )
M: simple-element elements* [ elements* ] with each ;
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel parser sequences words help help.topics
namespaces vocabs definitions compiler.units ;
over add-article >link r> remember-definition ; parsing
: ABOUT:
- scan-word dup parsing? [
- V{ } clone swap execute first
- ] when in get vocab set-vocab-help ; parsing
+ scan-object
+ in get vocab
+ dup changed-definition
+ set-vocab-help ; parsing
GENERIC: >link ( obj -- obj )
M: link >link ;
M: vocab-spec >link ;
-M: object >link link construct-boa ;
+M: object >link link boa ;
-PREDICATE: link word-link link-name word? ;
+PREDICATE: word-link < link link-name word? ;
M: link summary
[
TUPLE: article title content loc ;
: <article> ( title content -- article )
- f \ article construct-boa ;
+ f \ article boa ;
M: article article-name article-title ;
TUPLE: no-article name ;
-: no-article ( name -- * ) \ no-article construct-boa throw ;
+: no-article ( name -- * ) \ no-article boa throw ;
M: no-article summary
drop "Help article does not exist" ;
! <a =href a> "Click me" write </a>
!
! (url -- )
-! <a "http://" swap append =href a> "click" write </a>
+! <a "http://" prepend =href a> "click" write </a>
!
! (url -- )
! <a [ "http://" % % ] "" make =href a> "click" write </a>
dup <foo> swap [ <foo> write-html ] curry
empty-effect html-word ;
-: <foo "<" swap append ;
+: <foo "<" prepend ;
: def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned
: attribute-effect T{ effect f { "string" } 0 } ;
: define-attribute-word ( name -- )
- dup "=" swap append swap
+ dup "=" prepend swap
[ write-attr ] curry attribute-effect html-word ;
[
"id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
- "media"
+ "media" "title"
] [ define-attribute-word ] each
] with-compilation-unit
IN: html.tests
: make-html-string
- [ with-html-stream ] with-string-writer ;
+ [ with-html-stream ] with-string-writer ; inline
+
+[ [ ] make-html-string ] must-infer
[ ] [
512 <sbuf> <html-stream> drop
[ "<a href='http://www.funky-town.com/austin'><</a>" ] [
[
- "<" "austin" funky construct-boa write-object
+ "<" "austin" funky boa write-object
] make-html-string
] unit-test
TUPLE: html-sub-stream style stream ;
: (html-sub-stream) ( style stream -- stream )
- html-sub-stream construct-boa
+ html-sub-stream boa
512 <sbuf> <html-stream> over set-delegate ;
: <html-sub-stream> ( style stream class -- stream )
! Utilities
: with-html-stream ( quot -- )
- stdio get <html-stream> swap with-stream* ;
+ stdio get <html-stream> swap with-stream* ; inline
: xhtml-preamble
"<?xml version=\"1.0\"?>" write-html
[ print-closing-named-tag ] }
{ [ dup tag-name string? ]
[ print-opening-named-tag ] }
- { [ t ] [ <unknown-tag-error> throw ] }
+ [ <unknown-tag-error> throw ]
} cond ;
SYMBOL: tablestack
[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
-[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
-[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
-[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arc.com/foo.txt?xxx" download-name ] unit-test
+[ "foo.txt" ] [ "http://www.arc.com/foo.txt/" download-name ] unit-test
+[ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test
[
TUPLE{ request
port: 80
version: "1.1"
cookies: V{ }
- header: H{ }
+ header: H{ { "connection" "close" } }
}
] [
[
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
splitting calendar continuations accessors vectors
-io.encodings.latin1 io.encodings.binary fry ;
+io.encodings.8-bit io.encodings.binary fry debugger inspector ;
IN: http.client
+: max-redirects 10 ;
+
+ERROR: too-many-redirects ;
+
+M: too-many-redirects summary
+ drop
+ [ "Redirection limit of " % max-redirects # " exceeded" % ] "" make ;
+
DEFER: http-request
<PRIVATE
: parse-url ( url -- resource host port )
"http://" ?head [ "Only http:// supported" throw ] unless
- "/" split1 [ "/" swap append ] [ "/" ] if*
+ "/" split1 [ "/" prepend ] [ "/" ] if*
swap parse-host ;
: store-path ( request path -- request )
: relative-redirect ( path -- request )
request get swap store-path ;
+SYMBOL: redirects
+
+: absolute-url? ( url -- ? )
+ [ "http://" head? ] [ "https://" head? ] bi or ;
+
: do-redirect ( response -- response stream )
dup response-code 300 399 between? [
stdio get dispose
- header>> "location" swap at
- dup "http://" head? [
- absolute-redirect
+ redirects inc
+ redirects get max-redirects < [
+ header>> "location" swap at
+ dup absolute-url? [
+ absolute-redirect
+ ] [
+ relative-redirect
+ ] if "GET" >>method http-request
] [
- relative-redirect
- ] if "GET" >>method http-request
+ too-many-redirects
+ ] if
] [
stdio get
] if ;
-: request-addr ( request -- addr )
- dup host>> swap port>> <inet> ;
-
: close-on-error ( stream quot -- )
'[ , with-stream* ] [ ] pick '[ , dispose ] cleanup ; inline
] close-on-error
] with-variable ;
+: read-chunks ( -- )
+ read-crlf ";" split1 drop hex> dup { f 0 } member?
+ [ drop ] [ read % read-crlf "" assert= read-chunks ] if ;
+
+: do-chunked-encoding ( response stream -- response stream/string )
+ over "transfer-encoding" header "chunked" = [
+ [ [ read-chunks ] "" make ] with-stream
+ ] when ;
+
: <get-request> ( url -- request )
<request> request-with-url "GET" >>method ;
-: http-get-stream ( url -- response stream )
- <get-request> http-request ;
+: string-or-contents ( stream/string -- string )
+ dup string? [ contents ] unless ;
+
+: http-get-stream ( url -- response stream/string )
+ <get-request> http-request do-chunked-encoding ;
: success? ( code -- ? ) 200 = ;
-: check-response ( response -- )
- code>> success?
- [ "HTTP download failed" throw ] unless ;
+ERROR: download-failed response body ;
+
+M: download-failed error.
+ "HTTP download failed:" print nl
+ [
+ response>>
+ write-response-code
+ write-response-message nl
+ drop
+ ]
+ [ body>> write ] bi ;
+
+: check-response ( response string -- string )
+ over code>> success? [ nip ] [ download-failed ] if ;
: http-get ( url -- string )
- http-get-stream contents swap check-response ;
+ http-get-stream string-or-contents check-response ;
: download-name ( url -- name )
file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
- swap http-get-stream swap check-response
- [ swap latin1 <file-writer> stream-copy ] with-disposal ;
+ swap http-get-stream check-response
+ dup string? [
+ latin1 [ write ] with-file-writer
+ ] [
+ [ swap latin1 <file-writer> stream-copy ] with-disposal
+ ] if ;
: download ( url -- )
dup download-name download-to ;
swap >>post-data-type ;
: http-post ( content-type content url -- response string )
- <post-request> http-request contents ;
+ <post-request> http-request do-chunked-encoding string-or-contents ;
USING: http tools.test multiline tuple-syntax
-io.streams.string kernel arrays splitting sequences ;
+io.streams.string kernel arrays splitting sequences
+assocs io.sockets ;
IN: http.tests
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
[ "/bar" ] [ "/bar" url>path ] unit-test
+: lf>crlf "\n" split "\r\n" join ;
+
STRING: read-request-test-1
GET http://foo/bar HTTP/1.1
Some-Header: 1
cookies: V{ }
}
] [
- read-request-test-1 [
+ read-request-test-1 lf>crlf [
read-request
] with-string-reader
] unit-test
;
read-request-test-1' 1array [
- read-request-test-1
+ read-request-test-1 lf>crlf
[ read-request ] with-string-reader
[ write-request ] with-string-writer
! normalize crlf
STRING: read-request-test-2
HEAD http://foo/bar HTTP/1.1
Host: www.sex.com
+
;
[
cookies: V{ }
}
] [
- read-request-test-2 [
+ read-request-test-2 lf>crlf [
read-request
] with-string-reader
] unit-test
cookies: V{ }
}
] [
- read-response-test-1
+ read-response-test-1 lf>crlf
[ read-response ] with-string-reader
] unit-test
;
read-response-test-1' 1array [
- read-response-test-1
+ read-response-test-1 lf>crlf
[ read-response ] with-string-reader
[ write-response ] with-string-writer
! normalize crlf
[ ] [
[
<dispatcher>
- <action>
- [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
- "quit" add-responder
- "extra/http/test" resource-path <static> >>default
+ <action>
+ [ stop-server "text/html" <content> [ "Goodbye" write ] >>body ] >>display
+ "quit" add-responder
+ <dispatcher>
+ "extra/http/test" resource-path <static> >>default
+ "nested" add-responder
+ <action>
+ [ "redirect-loop" f <permanent-redirect> ] >>display
+ "redirect-loop" add-responder
main-responder set
[ 1237 httpd ] "HTTPD test" spawn drop
[ t ] [
"extra/http/test/foo.html" resource-path ascii file-contents
- "http://localhost:1237/foo.html" http-get =
+ "http://localhost:1237/nested/foo.html" http-get =
+] unit-test
+
+! Try with a slightly malformed request
+[ t ] [
+ "localhost" 1237 <inet> ascii <client> [
+ "GET nested HTTP/1.0\r\n" write flush
+ "\r\n" write flush
+ read-crlf drop
+ read-header
+ ] with-stream "location" swap at "/" head?
] unit-test
+[ "http://localhost:1237/redirect-loop" http-get ]
+[ too-many-redirects? ] must-fail-with
+
[ "Goodbye" ] [
"http://localhost:1237/quit" http-get
] unit-test
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry hashtables io io.streams.string kernel math
-namespaces math.parser assocs sequences strings splitting ascii
-io.encodings.utf8 io.encodings.string namespaces unicode.case
-combinators vectors sorting new-slots accessors calendar
-calendar.format quotations arrays combinators.cleave
-combinators.lib byte-arrays ;
+USING: accessors kernel combinators math namespaces
+
+assocs sequences splitting sorting sets debugger
+strings vectors hashtables quotations arrays byte-arrays
+math.parser calendar calendar.format
+
+io io.streams.string io.encodings.utf8 io.encodings.string
+io.sockets
+
+unicode.case unicode.categories qualified ;
+
+EXCLUDE: fry => , ;
+
IN: http
: http-port 80 ; inline
#! In a URL, can this character be used without
#! URL-encoding?
{
- [ dup letter? ]
- [ dup LETTER? ]
- [ dup digit? ]
- [ dup "/_-.:" member? ]
- } || nip ; foldable
+ { [ dup letter? ] [ t ] }
+ { [ dup LETTER? ] [ t ] }
+ { [ dup digit? ] [ t ] }
+ { [ dup "/_-.:" member? ] [ t ] }
+ [ f ]
+ } cond nip ; foldable
: push-utf8 ( ch -- )
1string utf8 encode
] if
] if ;
+: read-lf ( -- string )
+ "\n" read-until CHAR: \n assert= ;
+
+: read-crlf ( -- string )
+ "\r" read-until
+ [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
+
: read-header-line ( -- )
- readln dup
+ read-crlf dup
empty? [ drop ] [ header-line read-header-line ] if ;
: read-header ( -- assoc )
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
- dup "\r\n" seq-intersect empty?
+ dup "\r\n" intersect empty?
[ "Header injection attack" throw ] unless ;
: write-header ( assoc -- )
: query>assoc ( query -- assoc )
dup [
"&" split [
- "=" split1 [ dup [ url-decode ] when ] 2apply
+ "=" split1 [ dup [ url-decode ] when ] bi@
] H{ } map>assoc
] when ;
TUPLE: cookie name value path domain expires http-only ;
: <cookie> ( value name -- cookie )
- cookie construct-empty
+ cookie new
swap >>name swap >>value ;
: parse-cookies ( string -- seq )
: (unparse-cookie) ( key value -- )
{
- { [ dup f eq? ] [ 2drop ] }
- { [ dup t eq? ] [ drop , ] }
- { [ t ] [ "=" swap 3append , ] }
- } cond ;
+ { f [ drop ] }
+ { t [ , ] }
+ [ "=" swap 3append , ]
+ } case ;
: unparse-cookie ( cookie -- strings )
[
post-data-type
cookies ;
+: set-header ( request/response value key -- request/response )
+ pick header>> set-at ;
+
: <request>
- request construct-empty
+ request new
"1.1" >>version
http-port >>port
H{ } clone >>header
H{ } clone >>query
- V{ } clone >>cookies ;
+ V{ } clone >>cookies
+ "close" "connection" set-header ;
: query-param ( request key -- value )
swap query>> at ;
dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
: read-request-version ( request -- request )
- readln [ CHAR: \s = ] left-trim
+ read-crlf [ CHAR: \s = ] left-trim
parse-version
>>version ;
"application/x-www-form-urlencoded" >>post-data-type
] if ;
+: request-addr ( request -- addr )
+ [ host>> ] [ port>> ] bi <inet> ;
+
+: request-host ( request -- string )
+ [ host>> ] [ drop ":" ] [ port>> number>string ] tri 3append ;
+
: write-request-header ( request -- request )
dup header>> >hashtable
- over host>> [ "host" pick set-at ] when*
+ over host>> [ over request-host "host" pick set-at ] when
over post-data>> [ length "content-length" pick set-at ] when*
over post-data-type>> [ "content-type" pick set-at ] when*
over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
tri
] with-string-writer ;
-: set-header ( request/response value key -- request/response )
- pick header>> set-at ;
-
GENERIC: write-response ( response -- )
GENERIC: write-full-response ( request response -- )
body ;
: <response>
- response construct-empty
- "1.1" >>version
- H{ } clone >>header
- "close" "connection" set-header
- now timestamp>http-string "date" set-header
- V{ } clone >>cookies ;
+ response new
+ "1.1" >>version
+ H{ } clone >>header
+ "close" "connection" set-header
+ now timestamp>http-string "date" set-header
+ V{ } clone >>cookies ;
: read-response-version
" \t" read-until
>>code ;
: read-response-message
- readln >>message ;
+ read-crlf >>message ;
: read-response-header
read-header >>header
[ unparse-cookies "set-cookie" pick set-at ] when*
write-header ;
+GENERIC: write-response-body* ( body -- )
+
+M: f write-response-body* drop ;
+
+M: string write-response-body* write ;
+
+M: callable write-response-body* call ;
+
+M: object write-response-body* stdio get stream-copy ;
+
: write-response-body ( response -- response )
- dup body>> {
- { [ dup not ] [ drop ] }
- { [ dup string? ] [ write ] }
- { [ dup callable? ] [ call ] }
- { [ t ] [ stdio get stream-copy ] }
- } cond ;
+ dup body>> write-response-body* ;
M: response write-response ( respose -- )
write-response-version
body ;
: <raw-response> ( -- response )
- raw-response construct-empty
+ raw-response new
"1.1" >>version ;
M: raw-response write-response ( respose -- )
IN: http.server.actions.tests
USING: http.server.actions http.server.validators
tools.test math math.parser multiline namespaces http
-io.streams.string http.server sequences accessors ;
+io.streams.string http.server sequences splitting accessors ;
[
"a" [ v-number ] { { "a" "123" } } validate-param
{ { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
"action-1" set
+: lf>crlf "\n" split "\r\n" join ;
+
STRING: action-request-test-1
GET http://foo/bar?a=12&b=13 HTTP/1.1
;
[ 25 ] [
- action-request-test-1 [ read-request ] with-string-reader
+ action-request-test-1 lf>crlf
+ [ read-request ] with-string-reader
request set
"/blah"
"action-1" get call-responder
] unit-test
<action>
- [ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
- { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
+ [ +append-path get "xxx" get "X" <repetition> concat append ] >>submit
+ { { +append-path [ ] } { "xxx" [ v-number ] } } >>post-params
"action-2" set
STRING: action-request-test-2
;
[ "/blahXXXX" ] [
- action-request-test-2 [ read-request ] with-string-reader
+ action-request-test-2 lf>crlf
+ [ read-request ] with-string-reader
request set
"/blah"
"action-2" get call-responder
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors new-slots sequences kernel assocs combinators\r
+USING: accessors sequences kernel assocs combinators\r
http.server http.server.validators http hashtables namespaces\r
-combinators.cleave fry continuations locals ;\r
+fry continuations locals ;\r
IN: http.server.actions\r
\r
-SYMBOL: +path+\r
+SYMBOL: +append-path\r
\r
SYMBOL: params\r
\r
TUPLE: action init display submit get-params post-params ;\r
\r
: <action>\r
- action construct-empty\r
+ action new\r
[ ] >>init\r
[ <400> ] >>display\r
[ <400> ] >>submit ;\r
M: action call-responder ( path action -- response )\r
'[\r
, ,\r
- [ +path+ associate request-params union params set ]\r
+ [ +append-path associate request-params assoc-union params set ]\r
[ action set ] bi*\r
request get method>> {\r
{ "GET" [ handle-get ] }\r
! Copyright (c) 2007 Chris Double.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors new-slots quotations assocs kernel splitting\r
+USING: accessors quotations assocs kernel splitting\r
base64 html.elements io combinators http.server\r
http.server.auth.providers http.server.auth.providers.null\r
http sequences ;\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
+++ /dev/null
-<% USING: http.server.components http.server.auth.login\r
-http.server namespaces kernel combinators ; %>\r
-<html>\r
-<body>\r
-<h1>Edit profile</h1>\r
-\r
-<form method="POST" action="edit-profile">\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-view %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Real name:</td>\r
-<td><% "realname" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying a real name is optional.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Current password:</td>\r
-<td><% "password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>If you don't want to change your current password, leave this field blank.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>New password:</td>\r
-<td><% "new-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Verify:</td>\r
-<td><% "verify-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>If you are changing your password, enter it twice to ensure it is correct.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>E-mail:</td>\r
-<td><% "email" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Update" />\r
-\r
-<% {\r
- { [ login-failed? get ] [ "invalid password" render-error ] }\r
- { [ password-mismatch? get ] [ "passwords do not match" render-error ] }\r
- { [ t ] [ ] }\r
-} cond %>\r
-\r
-</p>\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Profile</t:title>
+
+ <t:form action="edit-profile">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:view component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:edit component="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Current password:</th>
+ <td><t:edit component="password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you don't want to change your current password, leave this field blank.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">New password:</th>
+ <td><t:edit component="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:edit component="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>If you are changing your password, enter it twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:edit component="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Update" />
+
+ <t:if var="http.server.auth.login:login-failed?">
+ <t:error>invalid password</t:error>
+ </t:if>
+
+ <t:if var="http.server.auth.login:password-mismatch?">
+ <t:error>passwords do not match</t:error>
+ </t:if>
+ </p>
+
+ </t:form>
+
+</t:chloe>
! Copyright (c) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors new-slots quotations assocs kernel splitting\r
-base64 html.elements io combinators http.server\r
-http.server.auth.providers http.server.auth.providers.null\r
-http.server.actions http.server.components http.server.sessions\r
-http.server.templating.fhtml http.server.validators\r
-http.server.auth http sequences io.files namespaces hashtables\r
-fry io.sockets combinators.cleave arrays threads locals\r
-qualified continuations destructors ;\r
+USING: accessors quotations assocs kernel splitting\r
+base64 io combinators sequences io.files namespaces hashtables\r
+fry io.sockets arrays threads locals qualified continuations\r
+destructors\r
+\r
+html.elements\r
+http\r
+http.server\r
+http.server.auth\r
+http.server.auth.providers\r
+http.server.auth.providers.null\r
+http.server.actions\r
+http.server.components\r
+http.server.forms\r
+http.server.sessions\r
+http.server.boilerplate\r
+http.server.templating\r
+http.server.templating.chloe\r
+http.server.validators ;\r
IN: http.server.auth.login\r
QUALIFIED: smtp\r
\r
SYMBOL: post-login-url\r
SYMBOL: login-failed?\r
\r
-TUPLE: login users ;\r
+TUPLE: login < dispatcher users ;\r
\r
: users login get users>> ;\r
\r
: save-user-after ( user -- )\r
<user-saver> add-always-destructor ;\r
\r
+: login-template ( name -- template )\r
+ "resource:extra/http/server/auth/login/" swap ".xml"\r
+ 3append <chloe> ;\r
+\r
! ! ! Login\r
\r
: <login-form>\r
"login" <form>\r
- "resource:extra/http/server/auth/login/login.fhtml" >>edit-template\r
+ "login" login-template >>edit-template\r
"username" <username>\r
t >>required\r
add-field\r
<action>\r
[ blank-values ] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
\r
: <register-form> ( -- form )\r
"register" <form>\r
- "resource:extra/http/server/auth/login/register.fhtml" >>edit-template\r
+ "register" login-template >>edit-template\r
"username" <username>\r
t >>required\r
add-field\r
<action>\r
[ blank-values ] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
\r
successful-login\r
\r
- login get responder>> init-user-profile\r
+ login get default>> responder>> init-user-profile\r
] >>submit\r
] ;\r
\r
\r
: <edit-profile-form> ( -- form )\r
"edit-profile" <form>\r
- "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template\r
+ "edit-profile" login-template >>edit-template\r
"username" <username> add-field\r
"realname" <string> add-field\r
"password" <password> add-field\r
dup email>> "email" set-value\r
] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
"password" value uid users check-login\r
[ login-failed? on validation-failed ] unless\r
\r
- "new-password" value set-password\r
+ "new-password" value >>password\r
] unless\r
\r
"realname" value >>realname\r
\r
: <recover-form-1> ( -- form )\r
"register" <form>\r
- "resource:extra/http/server/auth/login/recover-1.fhtml" >>edit-template\r
+ "recover-1" login-template >>edit-template\r
"username" <username>\r
t >>required\r
add-field\r
<action>\r
[ blank-values ] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ form edit-form ] >>body\r
- ] >>display\r
+ [ form edit-form ] >>display\r
\r
[\r
blank-values\r
send-password-email\r
] when*\r
\r
- "resource:extra/http/server/auth/login/recover-2.fhtml" serve-template\r
+ "recover-2" login-template serve-template\r
] >>submit\r
] ;\r
\r
: <recover-form-3>\r
"new-password" <form>\r
- "resource:extra/http/server/auth/login/recover-3.fhtml" >>edit-template\r
- "username" <username> <hidden>\r
+ "recover-3" login-template >>edit-template\r
+ "username" <username>\r
+ hidden >>renderer\r
t >>required\r
add-field\r
"new-password" <password>\r
"verify-password" <password>\r
t >>required\r
add-field\r
- "ticket" <string> <hidden>\r
+ "ticket" <string>\r
+ hidden >>renderer\r
t >>required\r
add-field ;\r
\r
] H{ } make-assoc values set\r
] >>init\r
\r
- [\r
- "text/html" <content>\r
- [ <recover-form-3> edit-form ] >>body\r
- ] >>display\r
+ [ <recover-form-3> edit-form ] >>display\r
\r
[\r
blank-values\r
"new-password" value >>password\r
users update-user\r
\r
- "resource:extra/http/server/auth/login/recover-4.fhtml"\r
- serve-template\r
+ "recover-4" login-template serve-template\r
] [\r
<400>\r
] if*\r
"login" f <permanent-redirect> ;\r
\r
M: protected call-responder ( path responder -- response )\r
- logged-in-user sget [\r
- dup save-user-after\r
+ logged-in-user sget dup [\r
+ save-user-after\r
request get request-url previous-page sset\r
responder>> call-responder\r
] [\r
- 2drop\r
+ 3drop\r
request get method>> { "GET" "HEAD" } member?\r
[ show-login-page ] [ <400> ] if\r
] if ;\r
\r
M: login call-responder ( path responder -- response )\r
dup login set\r
- delegate call-responder ;\r
+ call-next-method ;\r
+\r
+: <login-boilerplate> ( responder -- responder' )\r
+ <boilerplate>\r
+ "boilerplate" login-template >>template ;\r
\r
: <login> ( responder -- auth )\r
- login <webapp>\r
- swap <protected> >>default\r
- <login-action> "login" add-responder\r
- <logout-action> "logout" add-responder\r
+ login new-dispatcher\r
+ swap >>default\r
+ <login-action> <login-boilerplate> "login" add-responder\r
+ <logout-action> <login-boilerplate> "logout" add-responder\r
no-users >>users ;\r
\r
! ! ! Configuration\r
\r
: allow-edit-profile ( login -- login )\r
- <edit-profile-action> <protected> "edit-profile" add-responder ;\r
+ <edit-profile-action> <protected> <login-boilerplate>\r
+ "edit-profile" add-responder ;\r
\r
: allow-registration ( login -- login )\r
- <register-action> "register" add-responder ;\r
+ <register-action> <login-boilerplate>\r
+ "register" add-responder ;\r
\r
: allow-password-recovery ( login -- login )\r
- <recover-action-1> "recover-password" add-responder\r
- <recover-action-3> "new-password" add-responder ;\r
+ <recover-action-1> <login-boilerplate>\r
+ "recover-password" add-responder\r
+ <recover-action-3> <login-boilerplate>\r
+ "new-password" add-responder ;\r
\r
: allow-edit-profile? ( -- ? )\r
login get responders>> "edit-profile" swap key? ;\r
+++ /dev/null
-<% USING: http.server.auth.login http.server.components http.server\r
-kernel namespaces ; %>\r
-<html>\r
-<body>\r
-<h1>Login required</h1>\r
-\r
-<form method="POST" action="login">\r
-\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Password:</td>\r
-<td><% "password" component render-edit %></td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Log in" />\r
-<%\r
-login-failed? get\r
-[ "Invalid username or password" render-error ] when\r
-%>\r
-</p>\r
-\r
-</form>\r
-\r
-<p>\r
-<% allow-registration? [ %>\r
- <a href="<% "register" f write-link %>">Register</a>\r
-<% ] when %>\r
-<% allow-password-recovery? [ %>\r
- <a href="<% "recover-password" f write-link %>">\r
- Recover Password\r
- </a>\r
-<% ] when %>\r
-</p>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Login</t:title>
+
+ <t:form action="login">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:edit component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:edit component="password" /></td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Log in" />
+
+ <t:if var="http.server.auth.login:login-failed?">
+ <t:error>invalid username or password</t:error>
+ </t:if>
+ </p>
+
+ </t:form>
+
+ <p>
+ <t:if code="http.server.auth.login:login-failed?">
+ <t:a href="register">Register</t:a>
+ </t:if>
+ |
+ <t:if code="http.server.auth.login:allow-password-recovery?">
+ <t:a href="recover-password">Recover Password</t:a>
+ </t:if>
+ </p>
+
+</t:chloe>
+++ /dev/null
-<% USING: http.server.components http.server ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 1 of 4</h1>\r
-\r
-<p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>\r
-\r
-<form method="POST" action="recover-password">\r
-\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>E-mail:</td>\r
-<td><% "email" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Captcha:</td>\r
-<td><% "captcha" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<input type="submit" value="Recover password" />\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 1 of 4</t:title>
+
+ <p>Enter the username and e-mail address you used to register for this site, and you will receive a link for activating a new password.</p>
+
+ <t:form action="recover-password">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:edit component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:edit component="email" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:edit component="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to e-mail you will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <input type="submit" value="Recover password" />
+
+ </t:form>
+
+</t:chloe>
+++ /dev/null
-<% USING: http.server.components ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 2 of 4</h1>\r
-\r
-<p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 2 of 4</t:title>
+
+ <p>If you entered the correct username and e-mail address, you should receive an e-mail shortly. Click the link in the e-mail for further instructions.</p>
+
+</t:chloe>
+++ /dev/null
-<% USING: http.server.components http.server.auth.login http.server\r
-namespaces kernel combinators ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 3 of 4</h1>\r
-\r
-<p>Choose a new password for your account.</p>\r
-\r
-<form method="POST" action="new-password">\r
-\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<% "username" component render-edit %>\r
-<% "ticket" component render-edit %>\r
-\r
-<tr>\r
-<td>Password:</td>\r
-<td><% "new-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Verify password:</td>\r
-<td><% "verify-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Enter your password twice to ensure it is correct.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Set password" />\r
-\r
-<% password-mismatch? get [\r
- "passwords do not match" render-error\r
-] when %>\r
-\r
-</p>\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Recover lost password: step 3 of 4</t:title>
+
+ <p>Choose a new password for your account.</p>
+
+ <t:form action="new-password">
+
+ <table>
+
+ <t:edit component="username" />
+ <t:edit component="ticket" />
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:edit component="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify password:</th>
+ <td><t:edit component="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ </table>
+
+ <p>
+ <input type="submit" value="Set password" />
+
+ <t:if var="http.server.auth.login:password-mismatch?">
+ <t:error>passwords do not match</t:error>
+ </t:if>
+ </p>
+
+ </t:form>
+
+</t:chloe>
+++ /dev/null
-<% USING: http.server ; %>\r
-<html>\r
-<body>\r
-<h1>Recover lost password: step 4 of 4</h1>\r
-\r
-<p>Your password has been reset.\r
-You may now <a href="<% "login" f write-link %>">log in</a>.</p>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>\r
+\r
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">\r
+\r
+ <t:title>Recover lost password: step 4 of 4</t:title>\r
+\r
+ <p>Your password has been reset. You may now <t:a href="login">log in</t:a>.</p>\r
+\r
+</t:chloe>\r
+++ /dev/null
-<% USING: http.server.components http.server.auth.login\r
-http.server namespaces kernel combinators ; %>\r
-<html>\r
-<body>\r
-<h1>New user registration</h1>\r
-\r
-<form method="POST" action="register">\r
-<% hidden-form-field %>\r
-\r
-<table>\r
-\r
-<tr>\r
-<td>User name:</td>\r
-<td><% "username" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Real name:</td>\r
-<td><% "realname" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying a real name is optional.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Password:</td>\r
-<td><% "new-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Verify:</td>\r
-<td><% "verify-password" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Enter your password twice to ensure it is correct.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>E-mail:</td>\r
-<td><% "email" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>\r
-</tr>\r
-\r
-<tr>\r
-<td>Captcha:</td>\r
-<td><% "captcha" component render-edit %></td>\r
-</tr>\r
-\r
-<tr>\r
-<td></td>\r
-<td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>\r
-</tr>\r
-\r
-</table>\r
-\r
-<p><input type="submit" value="Register" />\r
-\r
-<% {\r
- { [ password-mismatch? get ] [ "passwords do not match" render-error ] }\r
- { [ user-exists? get ] [ "username taken" render-error ] }\r
- { [ t ] [ ] }\r
-} cond %>\r
-\r
-</p>\r
-\r
-</form>\r
-\r
-</body>\r
-</html>\r
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>New User Registration</t:title>
+
+ <t:form action="register">
+
+ <table>
+
+ <tr>
+ <th class="field-label">User name:</th>
+ <td><t:edit component="username" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Real name:</th>
+ <td><t:edit component="realname" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying a real name is optional.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Password:</th>
+ <td><t:edit component="new-password" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Verify:</th>
+ <td><t:edit component="verify-password" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Enter your password twice to ensure it is correct.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">E-mail:</th>
+ <td><t:edit component="email" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Captcha:</th>
+ <td><t:edit component="captcha" /></td>
+ </tr>
+
+ <tr>
+ <td></td>
+ <td>Leave the captcha blank. Spam-bots will fill it indiscriminantly, so their attempts to register will be blocked.</td>
+ </tr>
+
+ </table>
+
+ <p>
+
+ <input type="submit" value="Register" />
+
+ <t:if var="http.server.auth.login:user-exists?">
+ <t:error>username taken</t:error>
+ </t:if>
+
+ <t:if var="http.server.auth.login:password-mismatch?">
+ <t:error>passwords do not match</t:error>
+ </t:if>
+
+ </p>
+
+ </t:form>
+
+</t:chloe>
\r
[ t ] [ "user" get >boolean ] unit-test\r
\r
-[ ] [ "user" get "fdasf" set-password drop ] unit-test\r
+[ ] [ "user" get "fdasf" >>password drop ] unit-test\r
\r
[ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test\r
\r
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
IN: http.server.auth.providers.assoc\r
-USING: new-slots accessors assocs kernel\r
+USING: accessors assocs kernel\r
http.server.auth.providers ;\r
\r
TUPLE: users-in-memory assoc ;\r
\r
: <users-in-memory> ( -- provider )\r
- H{ } clone users-in-memory construct-boa ;\r
+ H{ } clone users-in-memory boa ;\r
\r
M: users-in-memory get-user ( username provider -- user/f )\r
assoc>> at ;\r
\r
[ t ] [ "user" get >boolean ] unit-test\r
\r
- [ ] [ "user" get "fdasf" set-password drop ] unit-test\r
+ [ ] [ "user" get "fdasf" >>password drop ] unit-test\r
\r
[ ] [ "user" get "provider" get update-user ] unit-test\r
\r
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: db db.tuples db.types new-slots accessors\r
-http.server.auth.providers kernel continuations\r
-singleton ;\r
-IN: http.server.auth.providers.db\r
-\r
-user "USERS"\r
-{\r
- { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }\r
- { "realname" "REALNAME" { VARCHAR 256 } }\r
- { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }\r
- { "email" "EMAIL" { VARCHAR 256 } }\r
- { "ticket" "TICKET" { VARCHAR 256 } }\r
- { "profile" "PROFILE" FACTOR-BLOB }\r
-} define-persistent\r
-\r
-: init-users-table user ensure-table ;\r
-\r
-SINGLETON: users-in-db\r
-\r
-: find-user ( username -- user )\r
- <user>\r
- swap >>username\r
- select-tuple ;\r
-\r
-M: users-in-db get-user\r
- drop\r
- find-user ;\r
-\r
-M: users-in-db new-user\r
- drop\r
- [\r
- dup username>> find-user [\r
- drop f\r
- ] [\r
- dup insert-tuple\r
- ] if\r
- ] with-transaction ;\r
-\r
-M: users-in-db update-user\r
- drop update-tuple ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db db.tuples db.types accessors
+http.server.auth.providers kernel continuations
+classes.singleton ;
+IN: http.server.auth.providers.db
+
+user "USERS"
+{
+ { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
+ { "realname" "REALNAME" { VARCHAR 256 } }
+ { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
+ { "email" "EMAIL" { VARCHAR 256 } }
+ { "ticket" "TICKET" { VARCHAR 256 } }
+ { "profile" "PROFILE" FACTOR-BLOB }
+} define-persistent
+
+: init-users-table user ensure-table ;
+
+SINGLETON: users-in-db
+
+: find-user ( username -- user )
+ <user>
+ swap >>username
+ select-tuple ;
+
+M: users-in-db get-user
+ drop
+ find-user ;
+
+M: users-in-db new-user
+ drop
+ [
+ dup username>> find-user [
+ drop f
+ ] [
+ dup insert-tuple
+ ] if
+ ] with-transaction ;
+
+M: users-in-db update-user
+ drop update-tuple ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel new-slots accessors random math.parser locals\r
+USING: kernel accessors random math.parser locals\r
sequences math crypto.sha2 ;\r
IN: http.server.auth.providers\r
\r
TUPLE: user username realname password email ticket profile ;\r
\r
-: <user> user construct-empty H{ } clone >>profile ;\r
+: <user> user new H{ } clone >>profile ;\r
\r
GENERIC: get-user ( username provider -- user/f )\r
\r
: check-login ( password username provider -- user/f )\r
get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;\r
\r
-: set-password ( user password -- user ) >>password ;\r
-\r
! Password recovery support\r
\r
:: issue-ticket ( email username provider -- user/f )\r
user email>> length 0 > [\r
user email>> email = [\r
user\r
- random-256 >hex >>ticket\r
+ 256 random-bits >hex >>ticket\r
dup provider update-user\r
] [ f ] if\r
] [ f ] if\r
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel namespaces boxes sequences strings
+io io.streams.string arrays
+html.elements
+http
+http.server
+http.server.templating ;
+IN: http.server.boilerplate
+
+TUPLE: boilerplate responder template ;
+
+: <boilerplate> f boilerplate boa ;
+
+SYMBOL: title
+
+: set-title ( string -- )
+ title get >box ;
+
+: write-title ( -- )
+ title get value>> write ;
+
+SYMBOL: style
+
+: add-style ( string -- )
+ "\n" style get push-all
+ style get push-all ;
+
+: write-style ( -- )
+ style get >string write ;
+
+SYMBOL: atom-feed
+
+: set-atom-feed ( title url -- )
+ 2array atom-feed get >box ;
+
+: write-atom-feed ( -- )
+ atom-feed get value>> [
+ <link "alternate" =rel "application/atom+xml" =type
+ [ first =title ] [ second =href ] bi
+ link/>
+ ] when* ;
+
+SYMBOL: nested-template?
+
+SYMBOL: next-template
+
+: call-next-template ( -- )
+ next-template get write ;
+
+M: f call-template* drop call-next-template ;
+
+: with-boilerplate ( body template -- )
+ [
+ title get [ <box> title set ] unless
+ atom-feed get [ <box> atom-feed set ] unless
+ style get [ SBUF" " clone style set ] unless
+
+ [
+ [
+ nested-template? on
+ write-response-body*
+ ] with-string-writer
+ next-template set
+ ]
+ [ call-template ]
+ bi*
+ ] with-scope ; inline
+
+M: boilerplate call-responder
+ tuck responder>> call-responder
+ dup "content-type" header "text/html" = [
+ clone swap template>>
+ [ [ with-boilerplate ] 2curry ] curry change-body
+ ] [ nip ] if ;
! Copyright (C) 2006, 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: html http http.server io kernel math namespaces\r
-continuations calendar sequences assocs new-slots hashtables\r
-accessors arrays alarms quotations combinators\r
-combinators.cleave fry assocs.lib ;\r
+continuations calendar sequences assocs hashtables\r
+accessors arrays alarms quotations combinators fry assocs.lib ;\r
IN: http.server.callbacks\r
\r
SYMBOL: responder\r
#! A continuation responder is a special type of session\r
#! manager. However it works entirely differently from\r
#! the URL and cookie session managers.\r
- H{ } clone callback-responder construct-boa ;\r
+ H{ } clone callback-responder boa ;\r
\r
TUPLE: callback cont quot expires alarm responder ;\r
\r
] when drop ;\r
\r
: <callback> ( cont quot expires? -- callback )\r
- f callback-responder get callback construct-boa\r
+ f callback-responder get callback boa\r
dup touch-callback ;\r
\r
: invoke-callback ( callback -- response )\r
IN: http.server.components.tests\r
-USING: http.server.components http.server.validators\r
-namespaces tools.test kernel accessors new-slots\r
-tuple-syntax mirrors http.server.actions ;\r
+USING: http.server.components http.server.forms\r
+http.server.validators namespaces tools.test kernel accessors\r
+tuple-syntax mirrors\r
+http http.server.actions http.server.templating.fhtml\r
+io.streams.string io.streams.null ;\r
\r
validation-failed? off\r
\r
\r
TUPLE: test-tuple text number more-text ;\r
\r
-: <test-tuple> test-tuple construct-empty ;\r
+: <test-tuple> test-tuple new ;\r
\r
: <test-form> ( -- form )\r
"test" <form>\r
- "resource:extra/http/server/components/test/form.fhtml" >>view-template\r
- "resource:extra/http/server/components/test/form.fhtml" >>edit-template\r
+ "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>view-template\r
+ "resource:extra/http/server/components/test/form.fhtml" <fhtml> >>edit-template\r
"text" <string>\r
t >>required\r
add-field\r
"hi" >>default\r
add-field ;\r
\r
-[ ] [ <test-tuple> <mirror> values set <test-form> view-form ] unit-test\r
+[ ] [ <test-tuple> <mirror> values set <test-form> view-form write-response-body drop ] unit-test\r
\r
-[ ] [ <test-tuple> <mirror> values set <test-form> edit-form ] unit-test\r
+[ ] [ <test-tuple> <mirror> values set <test-form> edit-form write-response-body drop ] unit-test\r
\r
[ TUPLE{ test-tuple number: 123 more-text: "hi" } ] [\r
<test-tuple> from-tuple\r
"123" "n" get validate value>>\r
] unit-test\r
\r
- [ ] [ "n" get t >>integer drop ] unit-test\r
+ [ ] [ "i" <integer> "i" set ] unit-test\r
\r
[ 3 ] [\r
- "3" "n" get validate\r
+ "3" "i" get validate\r
] unit-test\r
+ \r
+ [ t ] [\r
+ "3.9" "i" get validate validation-error?\r
+ ] unit-test\r
+\r
+ H{ } clone values set\r
+\r
+ [ ] [ 3 "i" set-value ] unit-test\r
+\r
+ [ "3" ] [ [ "i" get render-view ] with-string-writer ] unit-test\r
+\r
+ [ ] [ [ "i" get render-edit ] with-null-stream ] unit-test\r
+\r
+ [ ] [ "t" <text> "t" set ] unit-test\r
+\r
+ [ ] [ "hello world" "t" set-value ] unit-test\r
+\r
+ [ ] [ [ "t" get render-edit ] with-null-stream ] unit-test\r
] with-scope\r
\r
[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test\r
+\r
+[ ] [ "password" <password> "p" set ] unit-test\r
+\r
+[ ] [ "pub-date" <date> "d" set ] unit-test\r
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: new-slots html.elements http.server.validators accessors
-namespaces kernel io math.parser assocs classes words tuples
-arrays sequences io.files http.server.templating.fhtml
-http.server.actions splitting mirrors hashtables
-combinators.cleave fry continuations math ;
+USING: accessors namespaces kernel io math.parser assocs classes
+words classes.tuple arrays sequences splitting mirrors
+hashtables fry combinators continuations math
+calendar.format html.elements
+http.server.validators ;
IN: http.server.components
+! Renderer protocol
+GENERIC: render-summary* ( value renderer -- )
+GENERIC: render-view* ( value renderer -- )
+GENERIC: render-edit* ( value id renderer -- )
+
+M: object render-summary* render-view* ;
+
+TUPLE: field type ;
+
+C: <field> field
+
+M: field render-view* drop write ;
+
+M: field render-edit*
+ <input type>> =type [ =id ] [ =name ] bi =value input/> ;
+
+: render-error ( message -- )
+ <span "error" =class span> write </span> ;
+
+TUPLE: hidden < field ;
+
+: hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
+
+M: hidden render-view* 2drop ;
+
+! Component protocol
SYMBOL: components
-TUPLE: component id required default ;
+TUPLE: component id required default renderer ;
: component ( name -- component )
dup components get at
- [ ] [ "No such component: " swap append throw ] ?if ;
+ [ ] [ "No such component: " prepend throw ] ?if ;
+
+GENERIC: init ( component -- component )
+
+M: component init ;
GENERIC: validate* ( value component -- result )
-GENERIC: render-view* ( value component -- )
-GENERIC: render-edit* ( value component -- )
-GENERIC: render-error* ( reason value component -- )
+GENERIC: component-string ( value component -- string )
SYMBOL: values
: set-value values get set-at ;
-: validate ( value component -- result )
- '[
- ,
- over empty? [
- [ default>> [ v-default ] when* ]
- [ required>> [ v-required ] when ]
- bi
- ] [ validate* ] if
- ] with-validator ;
+: blank-values H{ } clone values set ;
-: render-view ( component -- )
- [ id>> value ] [ render-view* ] bi ;
+: from-tuple <mirror> values set ;
-: render-error ( error -- )
- <span "error" =class span> write </span> ;
+: values-tuple values get mirror-object ;
-: render-edit ( component -- )
- dup id>> value dup validation-error? [
- [ reason>> ] [ value>> ] bi rot render-error*
- ] [
- swap [ default>> or ] keep render-edit*
- ] if ;
-
-: <component> ( id class -- component )
- \ component construct-empty
- swap construct-delegate
- swap >>id ; inline
-
-! Forms
-TUPLE: form view-template edit-template components ;
-
-: <form> ( id -- form )
- form <component>
- V{ } clone >>components ;
-
-: add-field ( form component -- form )
- dup id>> pick components>> set-at ;
-
-: with-form ( form quot -- )
- >r components>> components r> with-variable ; inline
-
-: set-defaults ( form -- )
- [
- components get [
- swap values get [
- swap default>> or
- ] change-at
- ] assoc-each
- ] with-form ;
-
-: view-form ( form -- )
- dup view-template>> '[ , run-template ] with-form ;
-
-: edit-form ( form -- )
- dup edit-template>> '[ , run-template ] with-form ;
-
-: validate-param ( id component -- )
- [ [ params get at ] [ validate ] bi* ]
- [ drop set-value ] 2bi ;
-
-: (validate-form) ( form -- error? )
- [
- validation-failed? off
- components get [ validate-param ] assoc-each
- validation-failed? get
- ] with-form ;
-
-: validate-form ( form -- )
- (validate-form) [ validation-failed ] when ;
+: render-view-or-summary ( component -- value renderer )
+ [ id>> value ] [ component-string ] [ renderer>> ] tri ;
-: blank-values H{ } clone values set ;
+: render-view ( component -- )
+ render-view-or-summary render-view* ;
-: from-tuple <mirror> values set ;
+: render-summary ( component -- )
+ render-view-or-summary render-summary* ;
-: values-tuple values get mirror-object ;
+<PRIVATE
-! ! !
-! Canned components: for simple applications and prototyping
-! ! !
+: render-edit-string ( string component -- )
+ [ id>> ] [ renderer>> ] bi render-edit* ;
-: render-input ( value component type -- )
- <input
- =type
- id>> [ =id ] [ =name ] bi
- =value
- input/> ;
+: render-edit-error ( component -- )
+ [ id>> value ] keep
+ [ [ value>> ] dip render-edit-string ]
+ [ drop reason>> render-error ] 2bi ;
-! Hidden fields
-TUPLE: hidden ;
+: value-or-default ( component -- value )
+ [ id>> value ] [ default>> ] bi or ;
-: <hidden> ( component -- component )
- hidden construct-delegate ;
+: render-edit-value ( component -- )
+ [ value-or-default ]
+ [ component-string ]
+ [ render-edit-string ]
+ tri ;
-M: hidden render-view*
- 2drop ;
+PRIVATE>
-M: hidden render-edit*
- >r dup number? [ number>string ] when r>
- "hidden" render-input ;
+: render-edit ( component -- )
+ dup id>> value validation-error?
+ [ render-edit-error ] [ render-edit-value ] if ;
-! String input fields
-TUPLE: string min-length max-length ;
+: validate ( value component -- result )
+ '[
+ ,
+ over empty? [
+ [ default>> [ v-default ] when* ]
+ [ required>> [ v-required ] when ]
+ bi
+ ] [ validate* ] if
+ ] with-validator ;
-: <string> ( id -- component ) string <component> ;
+: new-component ( id class renderer -- component )
+ swap new
+ swap >>renderer
+ swap >>id
+ init ; inline
-M: string validate*
- [ v-one-line ] [
- [ min-length>> [ v-min-length ] when* ]
- [ max-length>> [ v-max-length ] when* ]
- bi
- ] bi* ;
+! String input fields
+TUPLE: string < component one-line min-length max-length ;
-M: string render-view*
- drop write ;
+: new-string ( id class -- component )
+ "text" <field> new-component
+ t >>one-line ; inline
+
+: <string> ( id -- component )
+ string new-string ;
-M: string render-edit*
- "text" render-input ;
+M: string validate*
+ [ one-line>> [ v-one-line ] when ]
+ [ min-length>> [ v-min-length ] when* ]
+ [ max-length>> [ v-max-length ] when* ]
+ tri ;
-M: string render-error*
- "text" render-input render-error ;
+M: string component-string
+ drop ;
! Username fields
-TUPLE: username ;
+TUPLE: username < string ;
+
+M: username init
+ 2 >>min-length
+ 20 >>max-length ;
: <username> ( id -- component )
- <string> username construct-delegate
- 2 >>min-length
- 20 >>max-length ;
+ username new-string ;
M: username validate*
- delegate validate* v-one-word ;
+ call-next-method v-one-word ;
! E-mail fields
-TUPLE: email ;
+TUPLE: email < string ;
: <email> ( id -- component )
- <string> email construct-delegate
+ email new-string
5 >>min-length
60 >>max-length ;
M: email validate*
- delegate validate* dup empty? [ v-email ] unless ;
+ call-next-method dup empty? [ v-email ] unless ;
-! Password fields
-TUPLE: password ;
+! URL fields
+TUPLE: url < string ;
-: <password> ( id -- component )
- <string> password construct-delegate
- 6 >>min-length
+: <url> ( id -- component )
+ url new-string
+ 5 >>min-length
60 >>max-length ;
-M: password validate*
- delegate validate* v-one-word ;
+M: url validate*
+ call-next-method dup empty? [ v-url ] unless ;
+
+! Don't send passwords back to the user
+TUPLE: password-renderer < field ;
-M: password render-edit*
- >r drop f r> "password" render-input ;
+: password-renderer T{ password-renderer f "password" } ;
-M: password render-error*
- render-edit* render-error ;
+: blank-password >r >r drop "" r> r> ;
+
+M: password-renderer render-edit*
+ blank-password call-next-method ;
+
+! Password fields
+TUPLE: password < string ;
+
+M: password init
+ 6 >>min-length
+ 60 >>max-length ;
+
+: <password> ( id -- component )
+ password new-string
+ password-renderer >>renderer ;
+
+M: password validate*
+ call-next-method v-one-word ;
! Number fields
-TUPLE: number min-value max-value integer ;
+TUPLE: number < string min-value max-value ;
-: <number> ( id -- component ) number <component> ;
+: <number> ( id -- component )
+ number new-string ;
M: number validate*
[ v-number ] [
- [ integer>> [ v-integer ] when ]
[ min-value>> [ v-min-value ] when* ]
[ max-value>> [ v-max-value ] when* ]
- tri
+ bi
] bi* ;
-M: number render-view*
- drop number>string write ;
+M: number component-string
+ drop dup [ number>string ] when ;
-M: number render-edit*
- >r number>string r> "text" render-input ;
+! Integer fields
+TUPLE: integer < number ;
-M: number render-error*
- "text" render-input render-error ;
+: <integer> ( id -- component )
+ integer new-string ;
+
+M: integer validate*
+ call-next-method v-integer ;
+
+! Simple captchas
+TUPLE: captcha < string ;
+
+: <captcha> ( id -- component )
+ captcha new-string ;
+
+M: captcha validate*
+ drop v-captcha ;
! Text areas
-TUPLE: text ;
+TUPLE: text-renderer rows cols ;
-: <text> ( id -- component ) text <component> ;
+: new-text-renderer ( class -- renderer )
+ new
+ 60 >>cols
+ 20 >>rows ;
-M: text validate* drop ;
+: <text-renderer> ( -- renderer )
+ text-renderer new-text-renderer ;
-M: text render-view*
+M: text-renderer render-view*
drop write ;
-: render-textarea
+M: text-renderer render-edit*
<textarea
- id>> [ =id ] [ =name ] bi
+ [ rows>> [ number>string =rows ] when* ]
+ [ cols>> [ number>string =cols ] when* ] bi
+ [ =id ]
+ [ =name ] bi
textarea>
write
</textarea> ;
-M: text render-edit*
- render-textarea ;
+TUPLE: text < string ;
-M: text render-error*
- render-textarea render-error ;
+: new-text ( id class -- component )
+ new-string
+ f >>one-line
+ <text-renderer> >>renderer ;
-! Simple captchas
-TUPLE: captcha ;
+: <text> ( id -- component )
+ text new-text ;
-: <captcha> ( id -- component )
- <string> captcha construct-delegate ;
+! HTML text component
+TUPLE: html-text-renderer < text-renderer ;
-M: captcha validate*
- drop v-captcha ;
+: <html-text-renderer> ( -- renderer )
+ html-text-renderer new-text-renderer ;
+
+M: html-text-renderer render-view*
+ drop write ;
+
+TUPLE: html-text < text ;
+
+: <html-text> ( id -- component )
+ html-text new-text
+ <html-text-renderer> >>renderer ;
+
+! Date component
+TUPLE: date < string ;
+
+: <date> ( id -- component )
+ date new-string ;
+
+M: date component-string
+ drop timestamp>string ;
+
+! Link components
+
+GENERIC: link-title ( obj -- string )
+GENERIC: link-href ( obj -- url )
+
+SINGLETON: link-renderer
+
+M: link-renderer render-view*
+ drop <a dup link-href =href a> link-title write </a> ;
+
+TUPLE: link < string ;
+
+: <link> ( id -- component )
+ link new-string
+ link-renderer >>renderer ;
+
+! List components
+SYMBOL: +plain+
+SYMBOL: +ordered+
+SYMBOL: +unordered+
+
+TUPLE: list-renderer component type ;
+
+C: <list-renderer> list-renderer
+
+: render-plain-list ( seq component quot -- )
+ '[ , component>> renderer>> @ ] each ; inline
+
+: render-li-list ( seq component quot -- )
+ '[ <li> @ </li> ] render-plain-list ; inline
+
+: render-ordered-list ( seq quot component -- )
+ <ol> render-li-list </ol> ; inline
+
+: render-unordered-list ( seq quot component -- )
+ <ul> render-li-list </ul> ; inline
+
+: render-list ( value renderer quot -- )
+ over type>> {
+ { +plain+ [ render-plain-list ] }
+ { +ordered+ [ render-ordered-list ] }
+ { +unordered+ [ render-unordered-list ] }
+ } case ; inline
+
+M: list-renderer render-view*
+ [ render-view* ] render-list ;
+
+M: list-renderer render-summary*
+ [ render-summary* ] render-list ;
+
+TUPLE: list < component ;
+
+: <list> ( id component type -- list )
+ <list-renderer> list swap new-component ;
+
+M: list component-string drop ;
! Copyright (C) 2008 Slava Pestov\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: splitting http.server.components kernel io sequences\r
-farkup ;\r
+USING: splitting kernel io sequences farkup accessors\r
+http.server.components ;\r
IN: http.server.components.farkup\r
\r
-TUPLE: farkup ;\r
+TUPLE: farkup-renderer < text-renderer ;\r
\r
-: <farkup> ( id -- component )\r
- <text> farkup construct-delegate ;\r
+: <farkup-renderer> ( -- renderer )\r
+ farkup-renderer new-text-renderer ;\r
\r
-M: farkup render-view*\r
+M: farkup-renderer render-view*\r
drop string-lines "\n" join convert-farkup write ;\r
+\r
+: <farkup> ( id -- component )\r
+ <text>\r
+ <farkup-renderer> >>renderer ;\r
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces db.tuples math.parser
+accessors fry locals hashtables
+http.server
+http.server.actions
+http.server.components
+http.server.forms
+http.server.validators ;
IN: http.server.crud
-USING: kernel namespaces db.tuples math.parser http.server
-http.server.actions http.server.components
-http.server.validators accessors fry locals hashtables ;
:: <view-action> ( form ctor -- action )
<action>
[ "id" get ctor call select-tuple from-tuple ] >>init
- [
- "text/html" <content>
- [ form view-form ] >>body
- ] >>display ;
+ [ form view-form ] >>display ;
: <id-redirect> ( id next -- response )
swap number>string "id" associate <permanent-redirect> ;
-:: <create-action> ( form ctor next -- action )
+:: <edit-action> ( form ctor next -- action )
<action>
- [ f ctor call from-tuple form set-defaults ] >>init
+ { { "id" [ [ v-number ] v-optional ] } } >>get-params
[
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
-
- [
- f ctor call from-tuple
+ "id" get ctor call
- form validate-form
-
- values-tuple insert-tuple
+ "id" get
+ [ select-tuple from-tuple ]
+ [ from-tuple form set-defaults ]
+ if
+ ] >>init
- "id" value next <id-redirect>
- ] >>submit ;
-
-:: <edit-action> ( form ctor next -- action )
- <action>
- { { "id" [ v-number ] } } >>get-params
- [ "id" get ctor call select-tuple from-tuple ] >>init
-
- [
- "text/html" <content>
- [ form edit-form ] >>body
- ] >>display
+ [ form edit-form ] >>display
[
f ctor call from-tuple
form validate-form
- values-tuple update-tuple
+ values-tuple
+ "id" value [ update-tuple ] [ insert-tuple ] if
"id" value next <id-redirect>
] >>submit ;
next f <permanent-redirect>
] >>submit ;
+
+:: <list-action> ( form ctor -- action )
+ <action>
+ [
+ blank-values
+
+ f ctor call select-tuples "list" set-value
+
+ form view-form
+ ] >>display ;
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: db http.server kernel new-slots accessors\r
-continuations namespaces destructors combinators.cleave ;\r
+USING: db http.server kernel accessors\r
+continuations namespaces destructors ;\r
IN: http.server.db\r
\r
TUPLE: db-persistence responder db params ;\r
C: <db-persistence> db-persistence\r
\r
: connect-db ( db-persistence -- )\r
- [ db>> ] [ params>> ] bi make-db\r
- [ db set ] [ db-open ] [ add-always-destructor ] tri ;\r
+ [ db>> ] [ params>> ] bi make-db db-open\r
+ [ db set ] [ add-always-destructor ] bi ;\r
\r
M: db-persistence call-responder\r
[ connect-db ] [ responder>> call-responder ] bi ;\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors assocs namespaces io.files sequences fry
+http.server
+http.server.actions
+http.server.components
+http.server.validators
+http.server.templating ;
+IN: http.server.forms
+
+TUPLE: form < component
+view-template edit-template summary-template
+components ;
+
+M: form init V{ } clone >>components ;
+
+: <form> ( id -- form )
+ form f new-component
+ dup >>renderer ;
+
+: add-field ( form component -- form )
+ dup id>> pick components>> set-at ;
+
+: set-components ( form -- )
+ components>> components set ;
+
+: with-form ( form quot -- )
+ [ [ set-components ] [ call ] bi* ] with-scope ; inline
+
+: set-defaults ( form -- )
+ [
+ components get [
+ swap values get [
+ swap default>> or
+ ] change-at
+ ] assoc-each
+ ] with-form ;
+
+: <form-response> ( form template -- response )
+ [ components>> components set ]
+ [ "text/html" <content> swap >>body ]
+ bi* ;
+
+: view-form ( form -- response )
+ dup view-template>> <form-response> ;
+
+: edit-form ( form -- response )
+ dup edit-template>> <form-response> ;
+
+: validate-param ( id component -- )
+ [ [ params get at ] [ validate ] bi* ]
+ [ drop set-value ] 2bi ;
+
+: (validate-form) ( form -- error? )
+ [
+ validation-failed? off
+ components get [ validate-param ] assoc-each
+ validation-failed? get
+ ] with-form ;
+
+: validate-form ( form -- )
+ (validate-form) [ validation-failed ] when ;
+
+: render-form ( value form template -- )
+ [
+ [ from-tuple ]
+ [ set-components ]
+ [ call-template ]
+ tri*
+ ] with-scope ;
+
+M: form component-string drop ;
+
+M: form render-summary*
+ dup summary-template>> render-form ;
+
+M: form render-view*
+ dup view-template>> render-form ;
+
+M: form render-edit*
+ nip dup edit-template>> render-form ;
USING: http.server tools.test kernel namespaces accessors
-new-slots io http math sequences assocs ;
+io http math sequences assocs ;
IN: http.server.tests
[
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces io io.timeouts strings splitting
threads http sequences prettyprint io.server logging calendar
-new-slots html.elements accessors math.parser combinators.lib
+html.elements accessors math.parser combinators.lib
tools.vocabs debugger html continuations random combinators
-destructors io.encodings.latin1 fry combinators.cleave ;
+destructors io.encodings.8-bit fry ;
IN: http.server
GENERIC: call-responder ( path responder -- response )
{
{ [ over "http://" head? ] [ link>string ] }
{ [ over "/" head? ] [ absolute-redirect ] }
- { [ t ] [ relative-redirect ] }
+ [ relative-redirect ]
} cond ;
: <redirect> ( to query code message -- response )
TUPLE: dispatcher default responders ;
+: new-dispatcher ( class -- dispatcher )
+ new
+ 404-responder get >>default
+ H{ } clone >>responders ; inline
+
: <dispatcher> ( -- dispatcher )
- 404-responder get H{ } clone dispatcher construct-boa ;
+ dispatcher new-dispatcher ;
: split-path ( path -- rest first )
[ CHAR: / = ] left-trim "/" split1 swap ;
2drop redirect-with-/
] if ;
-: <webapp> ( class -- dispatcher )
- <dispatcher> swap construct-delegate ; inline
-
TUPLE: vhost-dispatcher default responders ;
: <vhost-dispatcher> ( -- dispatcher )
- 404-responder get H{ } clone vhost-dispatcher construct-boa ;
+ 404-responder get H{ } clone vhost-dispatcher boa ;
: find-vhost ( dispatcher -- responder )
request get host>> over responders>> at*
SYMBOL: development-mode
+: http-error. ( error -- )
+ "Internal server error" [
+ development-mode get [
+ [ print-error nl :c ] with-html-stream
+ ] [
+ 500 "Internal server error"
+ trivial-response-body
+ ] if
+ ] simple-page ;
+
: <500> ( error -- response )
500 "Internal server error" <trivial-response>
- swap '[
- , "Internal server error" [
- development-mode get [
- [ print-error nl :c ] with-html-stream
- ] [
- 500 "Internal server error"
- trivial-response-body
- ] if
- ] simple-page
- ] >>body ;
+ swap '[ , http-error. ] >>body ;
: do-response ( response -- )
dup write-response
request get method>> "HEAD" =
- [ drop ] [ write-response-body ] if ;
+ [ drop ] [
+ '[
+ , write-response-body
+ ] [
+ http-error.
+ ] recover
+ ] if ;
LOG: httpd-hit NOTICE
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs calendar kernel math.parser namespaces random
-new-slots accessors http http.server
+accessors http http.server
http.server.sessions.storage http.server.sessions.storage.assoc
-quotations hashtables sequences fry combinators.cleave
-html.elements symbols continuations destructors ;
+quotations hashtables sequences fry html.elements symbols
+continuations destructors ;
IN: http.server.sessions
! ! ! ! ! !
TUPLE: session-manager responder sessions ;
-: <session-manager> ( responder class -- responder' )
- >r <sessions-in-memory> session-manager construct-boa
- r> construct-delegate ; inline
+: new-session-manager ( responder class -- responder' )
+ new
+ <sessions-in-memory> >>sessions
+ swap >>responder ; inline
SYMBOLS: session session-id session-changed? ;
[ [ session-id set ] [ session set ] bi* ] 2bi
[ session-manager set ] [ responder>> call-responder ] bi ;
-TUPLE: null-sessions ;
+TUPLE: null-sessions < session-manager ;
: <null-sessions>
- null-sessions <session-manager> ;
+ null-sessions new-session-manager ;
M: null-sessions call-responder ( path responder -- response )
H{ } clone f call-responder/session ;
-TUPLE: url-sessions ;
+TUPLE: url-sessions < session-manager ;
: <url-sessions> ( responder -- responder' )
- url-sessions <session-manager> ;
+ url-sessions new-session-manager ;
: session-id-key "factorsessid" ;
[ drop ] [ get-session ] 2bi ;
: add-session-id ( query -- query' )
- session-id get [ session-id-key associate union ] when* ;
+ session-id get [ session-id-key associate assoc-union ] when* ;
: session-form-field ( -- )
<input
2drop nip new-url-session
] if ;
-TUPLE: cookie-sessions ;
+TUPLE: cookie-sessions < session-manager ;
: <cookie-sessions> ( responder -- responder' )
- cookie-sessions <session-manager> ;
+ cookie-sessions new-session-manager ;
: current-cookie-session ( responder -- id namespace/f )
request get session-id-key get-cookie dup
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: assocs assocs.lib new-slots accessors\r
-http.server.sessions.storage combinators.cleave alarms kernel\r
-fry http.server ;\r
+USING: assocs assocs.lib accessors http.server.sessions.storage\r
+alarms kernel fry http.server ;\r
IN: http.server.sessions.storage.assoc\r
\r
TUPLE: sessions-in-memory sessions alarms ;\r
\r
: <sessions-in-memory> ( -- storage )\r
- H{ } clone H{ } clone sessions-in-memory construct-boa ;\r
+ H{ } clone H{ } clone sessions-in-memory boa ;\r
\r
: cancel-session-timeout ( id storage -- )\r
alarms>> at [ cancel-alarm ] when* ;\r
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: assocs new-slots accessors http.server.sessions.storage\r
-alarms kernel http.server db.tuples db.types singleton\r
-combinators.cleave math.parser ;\r
-IN: http.server.sessions.storage.db\r
-\r
-SINGLETON: sessions-in-db\r
-\r
-TUPLE: session id namespace ;\r
-\r
-session "SESSIONS"\r
-{\r
- { "id" "ID" INTEGER +native-id+ }\r
- { "namespace" "NAMESPACE" FACTOR-BLOB }\r
-} define-persistent\r
-\r
-: init-sessions-table session ensure-table ;\r
-\r
-: <session> ( id -- session )\r
- session construct-empty\r
- swap dup [ string>number ] when >>id ;\r
-\r
-M: sessions-in-db get-session ( id storage -- namespace/f )\r
- drop\r
- dup [\r
- <session>\r
- select-tuple dup [ namespace>> ] when\r
- ] when ;\r
-\r
-M: sessions-in-db update-session ( namespace id storage -- )\r
- drop\r
- <session>\r
- swap >>namespace\r
- update-tuple ;\r
-\r
-M: sessions-in-db delete-session ( id storage -- )\r
- drop\r
- <session>\r
- delete-tuple ;\r
-\r
-M: sessions-in-db new-session ( namespace storage -- id )\r
- drop\r
- f <session>\r
- swap >>namespace\r
- [ insert-tuple ] [ id>> number>string ] bi ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs accessors http.server.sessions.storage
+alarms kernel http.server db.tuples db.types math.parser
+classes.singleton ;
+IN: http.server.sessions.storage.db
+
+SINGLETON: sessions-in-db
+
+TUPLE: session id namespace ;
+
+session "SESSIONS"
+{
+ { "id" "ID" INTEGER +native-id+ }
+ { "namespace" "NAMESPACE" FACTOR-BLOB }
+} define-persistent
+
+: init-sessions-table session ensure-table ;
+
+: <session> ( id -- session )
+ session new
+ swap dup [ string>number ] when >>id ;
+
+M: sessions-in-db get-session ( id storage -- namespace/f )
+ drop
+ dup [
+ <session>
+ select-tuple dup [ namespace>> ] when
+ ] when ;
+
+M: sessions-in-db update-session ( namespace id storage -- )
+ drop
+ <session>
+ swap >>namespace
+ update-tuple ;
+
+M: sessions-in-db delete-session ( id storage -- )
+ drop
+ <session>
+ delete-tuple ;
+
+M: sessions-in-db new-session ( namespace storage -- id )
+ drop
+ f <session>
+ swap >>namespace
+ [ insert-tuple ] [ id>> number>string ] bi ;
USING: calendar html io io.files kernel math math.parser http\r
http.server namespaces parser sequences strings assocs\r
hashtables debugger http.mime sorting html.elements logging\r
-calendar.format new-slots accessors io.encodings.binary\r
-combinators.cleave fry ;\r
+calendar.format accessors io.encodings.binary fry ;\r
IN: http.server.static\r
\r
! special maps mime types to quots with effect ( path -- )\r
TUPLE: file-responder root hook special ;\r
\r
: file-http-date ( filename -- string )\r
- file-info file-info-modified timestamp>http-string ;\r
+ file-info modified>> timestamp>http-string ;\r
\r
: last-modified-matches? ( filename -- ? )\r
file-http-date dup [\r
304 "Not modified" <trivial-response> ;\r
\r
: <file-responder> ( root hook -- responder )\r
- H{ } clone file-responder construct-boa ;\r
+ H{ } clone file-responder boa ;\r
\r
: <static> ( root -- responder )\r
[\r
<content>\r
swap\r
- [ file-info file-info-size "content-length" set-header ]\r
+ [ file-info size>> "content-length" set-header ]\r
[ file-http-date "last-modified" set-header ]\r
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]\r
tri\r
[ 2drop <304> ] [ file-responder get hook>> call ] if ;\r
\r
: serving-path ( filename -- filename )\r
- "" or file-responder get root>> swap path+ ;\r
+ file-responder get root>> right-trim-separators\r
+ "/"\r
+ rot "" or left-trim-separators 3append ;\r
\r
: serve-file ( filename -- response )\r
dup mime-type\r
swap '[ , directory. ] >>body ;\r
\r
: find-index ( filename -- path )\r
- { "index.html" "index.fhtml" } [ path+ ] with map\r
+ { "index.html" "index.fhtml" } [ append-path ] with map\r
[ exists? ] find nip ;\r
\r
: serve-directory ( filename -- response )\r
--- /dev/null
+USING: http.server.templating http.server.templating.chloe
+http.server.components http.server.boilerplate tools.test
+io.streams.string kernel sequences ascii boxes namespaces xml
+splitting ;
+IN: http.server.templating.chloe.tests
+
+[ "foo" ]
+[ "<a href=\"foo\">blah</a>" string>xml "href" required-attr ]
+unit-test
+
+[ "<a name=\"foo\">blah</a>" string>xml "href" required-attr ]
+[ "href attribute is required" = ]
+must-fail-with
+
+[ f ] [ f parse-query-attr ] unit-test
+
+[ f ] [ "" parse-query-attr ] unit-test
+
+[ H{ { "a" "b" } } ] [
+ blank-values
+ "b" "a" set-value
+ "a" parse-query-attr
+] unit-test
+
+[ H{ { "a" "b" } { "c" "d" } } ] [
+ blank-values
+ "b" "a" set-value
+ "d" "c" set-value
+ "a,c" parse-query-attr
+] unit-test
+
+: run-template
+ with-string-writer [ "\r\n\t" member? not ] subset
+ "?>" split1 nip ; inline
+
+: test-template ( name -- template )
+ "resource:extra/http/server/templating/chloe/test/"
+ swap
+ ".xml" 3append <chloe> ;
+
+[ "Hello world" ] [
+ [
+ "test1" test-template call-template
+ ] run-template
+] unit-test
+
+[ "Blah blah" "Hello world" ] [
+ [
+ <box> title set
+ [
+ "test2" test-template call-template
+ ] run-template
+ title get box>
+ ] with-scope
+] unit-test
+
+[ "<html><head><title>Hello world</title></head><body>Blah blah</body></html>" ] [
+ [
+ [
+ "test2" test-template call-template
+ ] "test3" test-template with-boilerplate
+ ] run-template
+] unit-test
+
+: test4-aux? t ;
+
+[ "True" ] [
+ [
+ "test4" test-template call-template
+ ] run-template
+] unit-test
+
+: test5-aux? f ;
+
+[ "" ] [
+ [
+ "test5" test-template call-template
+ ] run-template
+] unit-test
+
+SYMBOL: test6-aux?
+
+[ "True" ] [
+ [
+ test6-aux? on
+ "test6" test-template call-template
+ ] run-template
+] unit-test
+
+SYMBOL: test7-aux?
+
+[ "" ] [
+ [
+ test7-aux? off
+ "test7" test-template call-template
+ ] run-template
+] unit-test
--- /dev/null
+USING: accessors kernel sequences combinators kernel namespaces
+classes.tuple assocs splitting words arrays
+io io.files io.encodings.utf8 html.elements unicode.case
+tuple-syntax xml xml.data xml.writer xml.utilities
+http.server
+http.server.auth
+http.server.components
+http.server.sessions
+http.server.templating
+http.server.boilerplate ;
+IN: http.server.templating.chloe
+
+! Chloe is Ed's favorite web designer
+
+TUPLE: chloe path ;
+
+C: <chloe> chloe
+
+DEFER: process-template
+
+: chloe-ns TUPLE{ name url: "http://factorcode.org/chloe/1.0" } ;
+
+: chloe-tag? ( tag -- ? )
+ {
+ { [ dup tag? not ] [ f ] }
+ { [ dup chloe-ns names-match? not ] [ f ] }
+ [ t ]
+ } cond nip ;
+
+SYMBOL: tags
+
+: required-attr ( tag name -- value )
+ dup rot at*
+ [ nip ] [ drop " attribute is required" append throw ] if ;
+
+: optional-attr ( tag name -- value )
+ swap at ;
+
+: write-title-tag ( tag -- )
+ drop
+ "head" tags get member? "title" tags get member? not and
+ [ <title> write-title </title> ] [ write-title ] if ;
+
+: style-tag ( tag -- )
+ dup "include" optional-attr dup [
+ swap children>string empty? [
+ "style tag cannot have both an include attribute and a body" throw
+ ] unless
+ utf8 file-contents
+ ] [
+ drop children>string
+ ] if add-style ;
+
+: write-style-tag ( tag -- )
+ drop <style> write-style </style> ;
+
+: atom-tag ( tag -- )
+ [ "title" required-attr ]
+ [ "href" required-attr ]
+ bi set-atom-feed ;
+
+: write-atom-tag ( tag -- )
+ drop
+ "head" tags get member? [
+ write-atom-feed
+ ] [
+ atom-feed get value>> second write
+ ] if ;
+
+: component-attr ( tag -- name )
+ "component" required-attr ;
+
+: view-tag ( tag -- )
+ component-attr component render-view ;
+
+: edit-tag ( tag -- )
+ component-attr component render-edit ;
+
+: summary-tag ( tag -- )
+ component-attr component render-summary ;
+
+: parse-query-attr ( string -- assoc )
+ dup empty?
+ [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ;
+
+: a-start-tag ( tag -- )
+ <a
+ dup "value" optional-attr [ value f ] [
+ [ "href" required-attr ]
+ [ "query" optional-attr parse-query-attr ]
+ bi
+ ] ?if link>string =href
+ a> ;
+
+: process-tag-children ( tag -- )
+ [ process-template ] each ;
+
+: a-tag ( tag -- )
+ [ a-start-tag ]
+ [ process-tag-children ]
+ [ drop </a> ]
+ tri ;
+
+: form-start-tag ( tag -- )
+ <form
+ "POST" =method
+ tag-attrs print-attrs
+ form>
+ hidden-form-field ;
+
+: form-tag ( tag -- )
+ [ form-start-tag ]
+ [ process-tag-children ]
+ [ drop </form> ]
+ tri ;
+
+: attr>word ( value -- word/f )
+ dup ":" split1 swap lookup
+ [ ] [ "No such word: " swap append throw ] ?if ;
+
+: attr>var ( value -- word/f )
+ attr>word dup symbol? [
+ "Must be a symbol: " swap append throw
+ ] unless ;
+
+: if-satisfied? ( tag -- ? )
+ {
+ [ "code" optional-attr [ attr>word execute ] [ t ] if* ]
+ [ "var" optional-attr [ attr>var get ] [ t ] if* ]
+ [ "svar" optional-attr [ attr>var sget ] [ t ] if* ]
+ [ "uvar" optional-attr [ attr>var uget ] [ t ] if* ]
+ } cleave 4array [ ] all? ;
+
+: if-tag ( tag -- )
+ dup if-satisfied? [ process-tag-children ] [ drop ] if ;
+
+: error-tag ( tag -- )
+ children>string render-error ;
+
+: process-chloe-tag ( tag -- )
+ dup name-tag {
+ { "chloe" [ [ process-template ] each ] }
+ { "title" [ children>string set-title ] }
+ { "write-title" [ write-title-tag ] }
+ { "style" [ style-tag ] }
+ { "write-style" [ write-style-tag ] }
+ { "atom" [ atom-tag ] }
+ { "write-atom" [ write-atom-tag ] }
+ { "view" [ view-tag ] }
+ { "edit" [ edit-tag ] }
+ { "summary" [ summary-tag ] }
+ { "a" [ a-tag ] }
+ { "form" [ form-tag ] }
+ { "error" [ error-tag ] }
+ { "if" [ if-tag ] }
+ { "comment" [ drop ] }
+ { "call-next-template" [ drop call-next-template ] }
+ [ "Unknown chloe tag: " swap append throw ]
+ } case ;
+
+: process-tag ( tag -- )
+ {
+ [ name-tag >lower tags get push ]
+ [ write-start-tag ]
+ [ process-tag-children ]
+ [ write-end-tag ]
+ [ drop tags get pop* ]
+ } cleave ;
+
+: process-template ( xml -- )
+ {
+ { [ dup [ chloe-tag? ] is? ] [ process-chloe-tag ] }
+ { [ dup [ tag? ] is? ] [ process-tag ] }
+ { [ t ] [ write-item ] }
+ } cond ;
+
+: process-chloe ( xml -- )
+ [
+ V{ } clone tags set
+
+ nested-template? get [
+ process-template
+ ] [
+ {
+ [ xml-prolog write-prolog ]
+ [ xml-before write-chunk ]
+ [ process-template ]
+ [ xml-after write-chunk ]
+ } cleave
+ ] if
+ ] with-scope ;
+
+M: chloe call-template*
+ path>> utf8 <file-reader> read-xml process-chloe ;
+
+INSTANCE: chloe template
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ Hello world
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+ Blah blah
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <t:title>Hello world</t:title>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+ <html>
+ <head>
+ <t:write-title />
+ </head>
+ <body>
+ <t:call-next-template />
+ </body>
+ </html>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if code="http.server.templating.chloe.tests:test4-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if code="http.server.templating.chloe.tests:test5-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if var="http.server.templating.chloe.tests:test6-aux?">
+ True
+ </t:if>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:if var="http.server.templating.chloe.tests:test7-aux?">
+ True
+ </t:if>
+
+</t:chloe>
USING: io io.files io.streams.string io.encodings.utf8
-http.server.templating.fhtml kernel tools.test sequences
-parser ;
+http.server.templating http.server.templating.fhtml kernel
+tools.test sequences parser ;
IN: http.server.templating.fhtml.tests
: test-template ( path -- ? )
"resource:extra/http/server/templating/fhtml/test/"
- swap append
+ prepend
[
- ".fhtml" append [ run-template ] with-string-writer
+ ".fhtml" append <fhtml> [ call-template ] with-string-writer
] keep
- ".html" append ?resource-path utf8 file-contents = ;
+ ".html" append utf8 file-contents = ;
[ t ] [ "example" test-template ] unit-test
[ t ] [ "bug" test-template ] unit-test
! Copyright (C) 2005 Alex Chapman
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: continuations sequences kernel parser namespaces io
-io.files io.streams.string html html.elements source-files
-debugger combinators math quotations generic strings splitting
-accessors http.server.static http.server assocs
-io.encodings.utf8 fry ;
-
+USING: continuations sequences kernel namespaces debugger
+combinators math quotations generic strings splitting
+accessors assocs fry
+parser io io.files io.streams.string io.encodings.utf8 source-files
+html html.elements
+http.server.static http.server http.server.templating ;
IN: http.server.templating.fhtml
: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;
-! See apps/http-server/test/ or libs/furnace/ for template usage
-! examples
-
! We use a custom lexer so that %> ends a token even if not
! followed by whitespace
-TUPLE: template-lexer ;
+TUPLE: template-lexer < lexer ;
: <template-lexer> ( lines -- lexer )
- <lexer> template-lexer construct-delegate ;
+ template-lexer new-lexer ;
M: template-lexer skip-word
[
{
{ [ 2dup nth CHAR: " = ] [ drop 1+ ] }
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
- { [ t ] [ f skip ] }
+ [ f skip ]
} cond
- ] change-column ;
+ ] change-lexer-column ;
DEFER: <% delimiter
: check-<% ( lexer -- col )
- "<%" over lexer-line-text rot lexer-column start* ;
+ "<%" over line-text>> rot column>> start* ;
: found-<% ( accum lexer col -- accum )
[
- over lexer-line-text
- >r >r lexer-column r> r> subseq parsed
+ over line-text>>
+ >r >r column>> r> r> subseq parsed
\ write-html parsed
- ] 2keep 2 + swap set-lexer-column ;
+ ] 2keep 2 + >>column drop ;
: still-looking ( accum lexer -- accum )
[
- dup lexer-line-text swap lexer-column tail
+ [ line-text>> ] [ column>> ] bi tail
parsed \ print-html parsed
] keep next-line ;
: html-error. ( error -- )
<pre> error. </pre> ;
-: run-template ( filename -- )
+TUPLE: fhtml path ;
+
+C: <fhtml> fhtml
+
+M: fhtml call-template* ( filename -- )
'[
- , [
+ , path>> [
"quiet" on
parser-notes off
templating-vocab use+
! so that reload works properly
dup source-file file set
- ?resource-path utf8 file-contents
+ utf8 file-contents
[ eval-template ] [ html-error. drop ] recover
] with-file-vocabs
] assert-depth ;
-: template-convert ( infile outfile -- )
- utf8 [ run-template ] with-file-writer ;
-
-! responder integration
-: serve-template ( name -- response )
- "text/html" <content>
- swap '[ , run-template ] >>body ;
-
! file responder integration
: enable-fhtml ( responder -- responder )
- [ serve-template ]
+ [ <fhtml> serve-template ]
"application/x-factor-server-page"
pick special>> set-at ;
+
+INSTANCE: fhtml template
--- /dev/null
+USING: accessors kernel fry io io.encodings.utf8 io.files
+http http.server debugger prettyprint continuations ;
+IN: http.server.templating
+
+MIXIN: template
+
+GENERIC: call-template* ( template -- )
+
+ERROR: template-error template error ;
+
+M: template-error error.
+ "Error while processing template " write
+ [ template>> pprint ":" print nl ]
+ [ error>> error. ]
+ bi ;
+
+: call-template ( template -- )
+ [ call-template* ] [ template-error ] recover ;
+
+M: template write-response-body* call-template ;
+
+: template-convert ( template output -- )
+ utf8 [ call-template ] with-file-writer ;
+
+! responder integration
+: serve-template ( template -- response )
+ "text/html" <content>
+ swap '[ , call-template ] >>body ;
[ "slava@factorcodeorg" v-email ]
[ "invalid e-mail" = ] must-fail-with
+
+[ "http://www.factorcode.org" ]
+[ "http://www.factorcode.org" v-url ] unit-test
+
+[ "http:/www.factorcode.org" v-url ]
+[ "invalid URL" = ] must-fail-with
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences math namespaces
-math.parser assocs new-slots regexp fry unicode.categories
-combinators.cleave sequences ;
+USING: kernel continuations sequences math namespaces sets
+math.parser assocs regexp fry unicode.categories sequences ;
IN: http.server.validators
SYMBOL: validation-failed?
C: <validation-error> validation-error
: with-validator ( value quot -- result )
- [ validation-failed? on <validation-error> ] recover ;
- inline
+ [ validation-failed? on <validation-error> ] recover ; inline
: v-default ( str def -- str )
over empty? spin ? ;
: v-required ( str -- str )
dup empty? [ "required" throw ] when ;
+: v-optional ( str quot -- str )
+ over empty? [ 2drop f ] [ call ] if ; inline
+
: v-min-length ( str n -- str )
over length over < [
[ "must be at least " % # " characters" % ] "" make
: v-regexp ( str what regexp -- str )
>r over r> matches?
- [ drop ] [ "invalid " swap append throw ] if ;
+ [ drop ] [ "invalid " prepend throw ] if ;
: v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html
"e-mail"
- R/ [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}/i
+ R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
+ v-regexp ;
+
+: v-url ( str -- str )
+ "URL"
+ R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
v-regexp ;
: v-captcha ( str -- str )
dup empty? [ "must remain blank" throw ] unless ;
: v-one-line ( str -- str )
- dup "\r\n" seq-intersect empty?
+ dup "\r\n" intersect empty?
[ "must be a single line" throw ] unless ;
: v-one-word ( str -- str )
: binary-op ( quot -- ? )
>r get-cba r>
- swap >r >r [ reg-val ] 2apply swap r> call r>
+ swap >r >r [ reg-val ] bi@ swap r> call r>
set-reg f ; inline
: op1 ( opcode -- ? )
[ swap arr-val ] binary-op ;
: op2 ( opcode -- ? )
- get-cba >r [ reg-val ] 2apply r> reg-val set-arr f ;
+ get-cba >r [ reg-val ] bi@ r> reg-val set-arr f ;
: op3 ( opcode -- ? )
[ + >32bit ] binary-op ;
USING: inverse tools.test arrays math kernel sequences
-math.functions math.constants ;
+math.functions math.constants continuations ;
IN: inverse-tests
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
{
{ [ <cons> ] [ list-sum + ] }
{ [ <nil> ] [ 0 ] }
- { [ ] [ "Malformed list" throw ] }
+ [ "Malformed list" throw ]
} switch ;
[ 10 ] [ 1 2 3 4 <nil> <cons> <cons> <cons> <cons> list-sum ] unit-test
[ 1 2 ] [ 1 2 <cons> [ <cons> ] undo ] unit-test
[ t ] [ 1 2 <cons> [ <cons> ] matches? ] unit-test
[ f ] [ 1 2 <cons> [ <foo> ] matches? ] unit-test
+[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
-: empty-cons ( -- cons ) cons construct-empty ;
+: empty-cons ( -- cons ) cons new ;
: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
[ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
[ t ] [ pi [ pi ] matches? ] unit-test
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
+[ ] [ 3 [ _ ] undo ] unit-test
USING: kernel words inspector slots quotations sequences assocs
math arrays inference effects shuffle continuations debugger
-tuples namespaces vectors bit-arrays byte-arrays strings sbufs
-math.functions macros sequences.private combinators ;
+classes.tuple namespaces vectors bit-arrays byte-arrays strings
+sbufs math.functions macros sequences.private combinators
+mirrors combinators.lib ;
IN: inverse
TUPLE: fail ;
-: fail ( -- * ) \ fail construct-empty throw ;
+: fail ( -- * ) \ fail new throw ;
M: fail summary drop "Unification failed" ;
: assure ( ? -- ) [ fail ] unless ;
"pop-inverse" set-word-prop ;
TUPLE: no-inverse word ;
-: no-inverse ( word -- * ) \ no-inverse construct-empty throw ;
+: no-inverse ( word -- * ) \ no-inverse new throw ;
M: no-inverse summary
drop "The word cannot be used in pattern matching" ;
: undo-literal ( object -- quot )
[ =/fail ] curry ;
-PREDICATE: word normal-inverse "inverse" word-prop ;
-PREDICATE: word math-inverse "math-inverse" word-prop ;
-PREDICATE: word pop-inverse "pop-length" word-prop ;
+PREDICATE: normal-inverse < word "inverse" word-prop ;
+PREDICATE: math-inverse < word "math-inverse" word-prop ;
+PREDICATE: pop-inverse < word "pop-length" word-prop ;
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
-: inline-word ( word -- )
- {
- { [ dup word? not over symbol? or ] [ , ] }
- { [ dup explicit-inverse? ] [ , ] }
- ! { [ dup compound? over { if dispatch } member? not and ]
- ! [ word-def [ inline-word ] each ] }
- { [ dup word? over { if dispatch } member? not and ]
- [ word-def [ inline-word ] each ] }
- { [ drop t ] [ "Quotation is not invertible" throw ] }
- } cond ;
-
-: math-exp? ( n n word -- ? )
- { + - * / ^ } member? -rot [ number? ] both? and ;
-
-: (fold-constants) ( quot -- )
- dup length 3 < [ % ] [
- dup first3 3dup math-exp?
- [ execute , 3 ] [ 2drop , 1 ] if
- tail-slice (fold-constants)
+: enough? ( stack word -- ? )
+ dup deferred? [ 2drop f ] [
+ [ >r length r> 1quotation infer effect-in >= ]
+ [ 3drop f ] recover
] if ;
-: fold-constants ( quot -- folded )
- [ (fold-constants) ] [ ] make ;
+: fold-word ( stack word -- stack )
+ 2dup enough?
+ [ 1quotation with-datastack ] [ >r % r> , { } ] if ;
-: do-inlining ( quot -- inlined-quot )
- [ [ inline-word ] each ] [ ] make fold-constants ;
+: fold ( quot -- folded-quot )
+ [ { } swap [ fold-word ] each % ] [ ] make ;
+
+: flattenable? ( object -- ? )
+ { [ word? ] [ primitive? not ] [
+ { "inverse" "math-inverse" "pop-inverse" }
+ [ word-prop ] with contains? not
+ ] } <-&& ;
+
+: (flatten) ( quot -- )
+ [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;
+
+ : retain-stack-overflow? ( error -- ? )
+ { "kernel-error" 14 f f } = ;
+
+: flatten ( quot -- expanded )
+ [ [ (flatten) ] [ ] make ] [
+ dup retain-stack-overflow?
+ [ drop "No inverse defined on recursive word" ] when
+ throw
+ ] recover ;
GENERIC: inverse ( revquot word -- revquot* quot )
M: object inverse undo-literal ;
+
M: symbol inverse undo-literal ;
+M: word inverse drop "Inverse is undefined" throw ;
+
M: normal-inverse inverse
"inverse" word-prop ;
[ unclip-slice inverse % (undo) ] if ;
: [undo] ( quot -- undo )
- do-inlining reverse [ (undo) ] [ ] make ;
+ flatten fold reverse [ (undo) ] [ ] make ;
MACRO: undo ( quot -- ) [undo] ;
\ - [ + ] [ - ] define-math-inverse
\ * [ / ] [ / ] define-math-inverse
\ / [ * ] [ / ] define-math-inverse
-\ ^ [ recip ^ ] [ [ log ] 2apply / ] define-math-inverse
+\ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse
\ ? 2 [
- [ assert-literal ] 2apply
+ [ assert-literal ] bi@
[ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
2curry
] define-pop-inverse
-: _ f ;
+DEFER: _
\ _ [ drop ] define-inverse
: both ( object object -- object )
\ first3 [ 3array ] define-inverse
\ first4 [ 4array ] define-inverse
+\ prefix [ unclip ] define-inverse
+\ unclip [ prefix ] define-inverse
+\ suffix [ dup 1 head* swap peek ] define-inverse
+
! Constructor inverse
: deconstruct-pred ( class -- quot )
"predicate" word-prop [ dupd call assure ] curry ;
: slot-readers ( class -- quot )
- "slots" word-prop 1 tail ! tail gets rid of delegate
+ all-slots 1 tail ! tail gets rid of delegate
[ slot-spec-reader 1quotation [ keep ] curry ] map concat
[ ] like [ drop ] compose ;
: boa-inverse ( class -- quot )
[ deconstruct-pred ] keep slot-readers compose ;
-\ construct-boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
+\ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
: empty-inverse ( class -- quot )
deconstruct-pred
[ tuple>array 1 tail [ ] contains? [ fail ] when ]
compose ;
-\ construct-empty 1 [ ?wrapped empty-inverse ] define-pop-inverse
+\ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
: writer>reader ( word -- word' )
[ "writing" word-prop "slots" word-prop ] keep
MACRO: matches? ( quot -- ? ) [matches?] ;
TUPLE: no-match ;
-: no-match ( -- * ) \ no-match construct-empty throw ;
+: no-match ( -- * ) \ no-match new throw ;
M: no-match summary drop "Fall through in switch" ;
: recover-chain ( seq -- quot )
[ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
: [switch] ( quot-alist -- quot )
+ [ dup quotation? [ [ ] swap 2array ] when ] map
reverse [ >r [undo] r> compose ] { } assoc>map
recover-chain ;
"Reading from the buffer:"
{ $subsection buffer-peek }
{ $subsection buffer-pop }
-{ $subsection buffer> }
-{ $subsection buffer>> }
-{ $subsection buffer-until }
+{ $subsection buffer-read }
"Writing to the buffer:"
{ $subsection extend-buffer }
{ $subsection byte>buffer }
{ $description "De-allocates a buffer's underlying storage. The buffer may not be used after being freed." }
{ $warning "You " { $emphasis "must" } " free a buffer using this word, before letting the GC collect the buffer tuple instance." } ;
-HELP: (buffer>>)
-{ $values { "buffer" buffer } { "byte-array" byte-array } }
-{ $description "Collects the entire contents of the buffer into a string." } ;
-
HELP: buffer-reset
{ $values { "n" "a non-negative integer" } { "buffer" buffer } }
{ $description "Resets the fill pointer to 0 and the position to " { $snippet "count" } "." } ;
{ $values { "buffer" buffer } { "alien" alien } }
{ $description "Outputs the memory address of the current fill-pointer." } ;
-HELP: (buffer>)
+HELP: (buffer-read)
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
-{ $description "Outputs a string of the first " { $snippet "n" } " characters at the buffer's current position. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ;
+{ $description "Outputs a byte array of the first " { $snippet "n" } " bytes at the buffer's current position. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;
-HELP: buffer>
+HELP: buffer-read
{ $values { "n" "a non-negative integer" } { "buffer" buffer } { "byte-array" byte-array } }
-{ $description "Collects a string of " { $snippet "n" } " characters starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " characters available, the output is truncated." } ;
-
-HELP: buffer>>
-{ $values { "buffer" buffer } { "byte-array" byte-array } }
-{ $description "Collects the contents of the buffer into a string, and resets the position and fill pointer to 0." } ;
+{ $description "Collects a byte array of " { $snippet "n" } " bytes starting from the buffer's current position, and advances the position accordingly. If there are less than " { $snippet "n" } " bytes available, the output is truncated." } ;
HELP: buffer-length
{ $values { "buffer" buffer } { "n" "a non-negative integer" } }
HELP: >buffer
{ $values { "byte-array" byte-array } { "buffer" buffer } }
-{ $description "Copies a string to the buffer's fill pointer, and advances it accordingly." } ;
+{ $description "Copies a byte array to the buffer's fill pointer, and advances it accordingly." } ;
HELP: byte>buffer
{ $values { "byte" "a byte" } { "buffer" buffer } }
HELP: buffer-pop
{ $values { "buffer" buffer } { "byte" "a byte" } }
{ $description "Outputs the byte at the buffer position and advances the position." } ;
-
-HELP: buffer-until
-{ $values { "separators" "a sequence of bytes" } { "buffer" buffer } { "byte-array" byte-array } { "separator" "a byte or " { $link f } } }
-{ $description "Searches the buffer for a byte appearing in " { $snippet "separators" } ", starting from " { $link buffer-pos } ". If a separator is found, all data up to but not including the separator is output, together with the separator itself; otherwise the remainder of the buffer's contents are output together with " { $link f } "." } ;
IN: io.buffers.tests
USING: alien alien.c-types io.buffers kernel kernel.private libc
-sequences tools.test namespaces byte-arrays strings ;
+sequences tools.test namespaces byte-arrays strings accessors ;
: buffer-set ( string buffer -- )
over >byte-array over buffer-ptr byte-array>memory
: string>buffer ( string -- buffer )
dup length <buffer> tuck buffer-set ;
+: buffer-read-all ( buffer -- byte-array )
+ [ [ pos>> ] [ ptr>> ] bi <displaced-alien> ]
+ [ buffer-length ] bi
+ memory>byte-array ;
+
[ B{ } 65536 ] [
65536 <buffer>
- dup (buffer>>)
+ dup buffer-read-all
over buffer-capacity
rot buffer-free
] unit-test
[ "hello world" "" ] [
"hello world" string>buffer
- dup (buffer>>) >string
+ dup buffer-read-all >string
0 pick buffer-reset
- over (buffer>>) >string
+ over buffer-read-all >string
rot buffer-free
] unit-test
[ "hello" ] [
"hello world" string>buffer
- 5 over buffer> >string swap buffer-free
+ 5 over buffer-read >string swap buffer-free
] unit-test
[ 11 ] [
[ "hello world" ] [
"hello" 1024 <buffer> [ buffer-set ] keep
" world" >byte-array over >buffer
- dup (buffer>>) >string swap buffer-free
+ dup buffer-read-all >string swap buffer-free
] unit-test
[ CHAR: e ] [
1 over buffer-consume [ buffer-pop ] keep buffer-free
] unit-test
-[ "hello" CHAR: \r ] [
- "hello\rworld" string>buffer
- "\r" over buffer-until >r >string r>
- rot buffer-free
-] unit-test
-
-[ "hello" CHAR: \r ] [
- "hello\rworld" string>buffer
- "\n\r" over buffer-until >r >string r>
- rot buffer-free
-] unit-test
-
-[ "hello\rworld" f ] [
- "hello\rworld" string>buffer
- "X" over buffer-until >r >string r>
- rot buffer-free
-] unit-test
-
-[ "hello" CHAR: \r "world" CHAR: \n ] [
- "hello\rworld\n" string>buffer
- [ "\r\n" swap buffer-until >r >string r> ] keep
- [ "\r\n" swap buffer-until >r >string r> ] keep
- buffer-free
-] unit-test
-
"hello world" string>buffer "b" set
-[ "hello world" ] [ 1000 "b" get buffer> >string ] unit-test
+[ "hello world" ] [ 1000 "b" get buffer-read >string ] unit-test
"b" get buffer-free
100 <buffer> "b" set
! See http://factorcode.org/license.txt for BSD license.
IN: io.buffers
USING: alien alien.accessors alien.c-types alien.syntax kernel
-kernel.private libc math sequences byte-arrays strings hints ;
+kernel.private libc math sequences byte-arrays strings hints
+accessors ;
TUPLE: buffer size ptr fill pos ;
: <buffer> ( n -- buffer )
- dup malloc 0 0 buffer construct-boa ;
+ dup malloc 0 0 buffer boa ;
: buffer-free ( buffer -- )
dup buffer-ptr free f swap set-buffer-ptr ;
: buffer-pop ( buffer -- byte )
dup buffer-peek 1 rot buffer-consume ;
-: (buffer>) ( n buffer -- byte-array )
- [ dup buffer-fill swap buffer-pos - min ] keep
+: (buffer-read) ( n buffer -- byte-array )
+ [ [ fill>> ] [ pos>> ] bi - min ] keep
buffer@ swap memory>byte-array ;
-: buffer> ( n buffer -- byte-array )
- [ (buffer>) ] 2keep buffer-consume ;
-
-: (buffer>>) ( buffer -- byte-array )
- dup buffer-pos over buffer-ptr <displaced-alien>
- over buffer-fill rot buffer-pos - memory>byte-array ;
-
-: buffer>> ( buffer -- byte-array )
- dup (buffer>>) 0 rot buffer-reset ;
-
-: search-buffer-until ( start end alien separators -- n )
- [ >r swap alien-unsigned-1 r> memq? ] 2curry find* drop ;
-
-HINTS: search-buffer-until { fixnum fixnum simple-alien string } ;
-
-: finish-buffer-until ( buffer n -- byte-array separator )
- [
- over buffer-pos -
- over buffer>
- swap buffer-pop
- ] [
- buffer>> f
- ] if* ;
-
-: buffer-until ( separators buffer -- byte-array separator )
- tuck { buffer-pos buffer-fill buffer-ptr } get-slots roll
- search-buffer-until finish-buffer-until ;
+: buffer-read ( n buffer -- byte-array )
+ [ (buffer-read) ] [ buffer-consume ] 2bi ;
: buffer-length ( buffer -- n )
- dup buffer-fill swap buffer-pos - ;
+ [ fill>> ] [ pos>> ] bi - ;
: buffer-capacity ( buffer -- n )
- dup buffer-size swap buffer-fill - ;
+ [ size>> ] [ fill>> ] bi - ;
: buffer-empty? ( buffer -- ? )
- buffer-fill zero? ;
+ fill>> zero? ;
: extend-buffer ( n buffer -- )
2dup buffer-ptr swap realloc
: byte>buffer ( byte buffer -- )
1 over check-overflow
[ buffer-end 0 set-alien-unsigned-1 ] keep
- [ buffer-fill 1+ ] keep set-buffer-fill ;
+ [ 1+ ] change-fill drop ;
: n>buffer ( n buffer -- )
[ buffer-fill + ] keep
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup io.encodings.8-bit.private
+strings ;
+IN: io.encodings.8-bit
+
+ARTICLE: "io.encodings.8-bit" "8-bit encodings"
+"Many encodings are a simple mapping of bytes onto characters. The " { $vocab-link "io.encodings.8-bit" } " vocabulary implements these generically using existing resource files. These encodings should be used with extreme caution, as fully general Unicode encodings like UTF-8 are nearly always more appropriate. The following 8-bit encodings are already defined:"
+{ $subsection latin1 }
+{ $subsection latin2 }
+{ $subsection latin3 }
+{ $subsection latin4 }
+{ $subsection latin/cyrillic }
+{ $subsection latin/arabic }
+{ $subsection latin/greek }
+{ $subsection latin/hebrew }
+{ $subsection latin5 }
+{ $subsection latin6 }
+{ $subsection latin/thai }
+{ $subsection latin7 }
+{ $subsection latin8 }
+{ $subsection latin9 }
+{ $subsection latin10 }
+{ $subsection koi8-r }
+{ $subsection windows-1252 }
+{ $subsection ebcdic }
+{ $subsection mac-roman }
+"Words used in defining these"
+{ $subsection 8-bit }
+{ $subsection define-8-bit-encoding } ;
+
+ABOUT: "io.encodings.8-bit"
+
+HELP: 8-bit
+{ $class-description "Describes an 8-bit encoding, including its name (a symbol) and a table used for encoding and decoding." } ;
+
+HELP: define-8-bit-encoding
+{ $values { "name" string } { "stream" "an input stream" } }
+{ $description "Creates a new encoding. The stream should be in a similar format to those at " { $url "ftp://ftp.unicode.org/Public/MAPPINGS/ISO8859/" } } ;
+
+HELP: latin1
+{ $description "This is the ISO-8859-1 encoding, also called Latin-1: Western European. It is an 8-bit superset of ASCII which is the default for a mimetype starting with 'text' and provides the characters necessary for most western European languages." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin2
+{ $description "This is the ISO-8859-2 encoding, also called Latin-2: Eastern European. It is an 8-bit superset of ASCII and provides the characters necessary for most eastern European languages." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin3
+{ $description "This is the ISO-8859-3 encoding, also called Latin-3: South European. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, Maltese and Esperanto." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin4
+{ $description "This is the ISO-8859-4 encoding, also called Latin-4: North European. It is an 8-bit superset of ASCII and provides the characters necessary for Latvian, Lithuanian, Estonian, Greenlandic and Sami." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin/cyrillic
+{ $description "This is the ISO-8859-5 encoding, also called Latin/Cyrillic. It is an 8-bit superset of ASCII and provides the characters necessary for most languages which use Cyrilic, including Russian, Macedonian, Belarusian, Bulgarian, Serbian, and Ukrainian. KOI8-R is used much more commonly." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin/arabic
+{ $description "This is the ISO-8859-6 encoding, also called Latin/Arabic. It is an 8-bit superset of ASCII and provides the characters necessary for Arabic, though not other languages which use Arabic script." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin/greek
+{ $description "This is the ISO-8859-7 encoding, also called Latin/Greek. It is an 8-bit superset of ASCII and provides the characters necessary for Greek written in modern monotonic orthography, or ancient Greek without accent marks." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin/hebrew
+{ $description "This is the ISO-8859-8 encoding, also called Latin/Hebrew. It is an 8-bit superset of ASCII and provides the characters necessary for modern Hebrew without explicit vowels. Generally, this is interpreted in logical order, making it ISO-8859-8-I, technically." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin5
+{ $description "This is the ISO-8859-9 encoding, also called Latin-5: Turkish. It is an 8-bit superset of ASCII and provides the characters necessary for Turkish, similar to Latin-1 but replacing the spots used for Icelandic with characters used in Turkish." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin6
+{ $description "This is the ISO-8859-10 encoding, also called Latin-6: Nordic. It is an 8-bit superset of ASCII containing the same characters as Latin-4, but rearranged to be of better use to nordic languages." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin/thai
+{ $description "This is the ISO-8859-11 encoding, also called Latin/Thai. It is an 8-bit superset of ASCII containing the characters necessary to represent Thai. It is basically identical to TIS-620." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin7
+{ $description "This is the ISO-8859-13 encoding, also called Latin-7: Baltic Rim. It is an 8-bit superset of ASCII containing all characters necesary to represent Baltic Rim languages, as previous character sets were incomplete." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin8
+{ $description "This is the ISO-8859-14 encoding, also called Latin-8: Celtic. It is an 8-bit superset of ASCII designed for Celtic languages like Gaelic and Breton." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin9
+{ $description "This is the ISO-8859-15 encoding, also called Latin-9 and unoffically as Latin-0. It is an 8-bit superset of ASCII designed as a modification of Latin-1, removing little-used characters in favor of the Euro symbol and other characters." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: latin10
+{ $description "This is the ISO-8859-16 encoding, also called Latin-10: South-Eastern European. It is an 8-bit superset of ASCII." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: windows-1252
+{ $description "Windows 1252 is an 8-bit superset of ASCII which is closely related to Latin-1. Control characters in the 0x80 to 0x9F range are replaced with printable characters such as the Euro symbol." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: ebcdic
+{ $description "EBCDIC is an 8-bit legacy encoding designed for IBM mainframes like System/360 in the 1960s. It has since fallen into disuse. It contains large unallocated regions, and the version included here (code page 37) contains auxiliary characters in this region for English- and Portugese-speaking countries." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: mac-roman
+{ $description "Mac Roman is an 8-bit superset of ASCII which was the standard encoding on Mac OS prior to version 10. It is incompatible with Latin-1 in all but a few places and ASCII, and it is suitable for encoding many Western European languages." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: koi8-r
+{ $description "KOI8-R is an 8-bit superset of ASCII which encodes the Cyrillic alphabet, as used in Russian and Bulgarian. Characters are in such an order that, if the eight bit is stripped, text is still interpretable as ASCII. Block-building characters also exist." }
+{ $see-also "encodings-introduction" } ;
--- /dev/null
+USING: io.encodings.string io.encodings.8-bit tools.test strings arrays ;
+IN: io.encodings.8-bit.tests
+
+[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
+[ { 256 } >string latin1 encode ] must-fail
+[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test
+
+[ "bar" ] [ "bar" latin1 decode ] unit-test
+[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
+[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: math.parser arrays io.encodings sequences kernel assocs
+hashtables io.encodings.ascii generic parser classes.tuple words
+io io.files splitting namespaces math compiler.units accessors ;
+IN: io.encodings.8-bit
+
+<PRIVATE
+
+: mappings {
+ { "latin1" "8859-1" }
+ { "latin2" "8859-2" }
+ { "latin3" "8859-3" }
+ { "latin4" "8859-4" }
+ { "latin/cyrillic" "8859-5" }
+ { "latin/arabic" "8859-6" }
+ { "latin/greek" "8859-7" }
+ { "latin/hebrew" "8859-8" }
+ { "latin5" "8859-9" }
+ { "latin6" "8859-10" }
+ { "latin/thai" "8859-11" }
+ { "latin7" "8859-13" }
+ { "latin8" "8859-14" }
+ { "latin9" "8859-15" }
+ { "latin10" "8859-16" }
+ { "koi8-r" "KOI8-R" }
+ { "windows-1252" "CP1252" }
+ { "ebcdic" "CP037" }
+ { "mac-roman" "ROMAN" }
+} ;
+
+: encoding-file ( file-name -- stream )
+ "extra/io/encodings/8-bit/" ".TXT"
+ swapd 3append resource-path
+ ascii <file-reader> ;
+
+: tail-if ( seq n -- newseq )
+ 2dup swap length <= [ tail ] [ drop ] if ;
+
+: process-contents ( lines -- assoc )
+ [ "#" split1 drop ] map
+ [ empty? not ] subset
+ [ "\t" split 2 head [ 2 tail-if hex> ] map ] map ;
+
+: byte>ch ( assoc -- array )
+ 256 replacement-char <array>
+ [ [ swapd set-nth ] curry assoc-each ] keep ;
+
+: ch>byte ( assoc -- newassoc )
+ [ swap ] assoc-map >hashtable ;
+
+: parse-file ( path -- byte>ch ch>byte )
+ lines process-contents
+ [ byte>ch ] [ ch>byte ] bi ;
+
+TUPLE: 8-bit name decode encode ;
+
+: encode-8-bit ( char stream assoc -- )
+ swapd at* [ encode-error ] unless swap stream-write1 ;
+
+M: 8-bit encode-char
+ encode>> encode-8-bit ;
+
+: decode-8-bit ( stream array -- char/f )
+ swap stream-read1 dup
+ [ swap nth [ replacement-char ] unless* ]
+ [ nip ] if ;
+
+M: 8-bit decode-char
+ decode>> decode-8-bit ;
+
+: make-8-bit ( word byte>ch ch>byte -- )
+ [ 8-bit boa ] 2curry dupd curry define ;
+
+: define-8-bit-encoding ( name stream -- )
+ >r in get create r> parse-file make-8-bit ;
+
+PRIVATE>
+
+[
+ "io.encodings.8-bit" in [
+ mappings [ encoding-file define-8-bit-encoding ] assoc-each
+ ] with-variable
+] with-compilation-unit
--- /dev/null
+#
+# Name: ISO/IEC 8859-1:1998 to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 1999 July 27
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1991-1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-1:1998 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-1 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-1 order.
+#
+# Version history
+# 1.0 version updates 0.1 version by adding mappings for all
+# control characters.
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x00A1 # INVERTED EXCLAMATION MARK
+0xA2 0x00A2 # CENT SIGN
+0xA3 0x00A3 # POUND SIGN
+0xA4 0x00A4 # CURRENCY SIGN
+0xA5 0x00A5 # YEN SIGN
+0xA6 0x00A6 # BROKEN BAR
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x00A8 # DIAERESIS
+0xA9 0x00A9 # COPYRIGHT SIGN
+0xAA 0x00AA # FEMININE ORDINAL INDICATOR
+0xAB 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC # NOT SIGN
+0xAD 0x00AD # SOFT HYPHEN
+0xAE 0x00AE # REGISTERED SIGN
+0xAF 0x00AF # MACRON
+0xB0 0x00B0 # DEGREE SIGN
+0xB1 0x00B1 # PLUS-MINUS SIGN
+0xB2 0x00B2 # SUPERSCRIPT TWO
+0xB3 0x00B3 # SUPERSCRIPT THREE
+0xB4 0x00B4 # ACUTE ACCENT
+0xB5 0x00B5 # MICRO SIGN
+0xB6 0x00B6 # PILCROW SIGN
+0xB7 0x00B7 # MIDDLE DOT
+0xB8 0x00B8 # CEDILLA
+0xB9 0x00B9 # SUPERSCRIPT ONE
+0xBA 0x00BA # MASCULINE ORDINAL INDICATOR
+0xBB 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x00BC # VULGAR FRACTION ONE QUARTER
+0xBD 0x00BD # VULGAR FRACTION ONE HALF
+0xBE 0x00BE # VULGAR FRACTION THREE QUARTERS
+0xBF 0x00BF # INVERTED QUESTION MARK
+0xC0 0x00C0 # LATIN CAPITAL LETTER A WITH GRAVE
+0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3 0x00C3 # LATIN CAPITAL LETTER A WITH TILDE
+0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE
+0xC6 0x00C6 # LATIN CAPITAL LETTER AE
+0xC7 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8 0x00C8 # LATIN CAPITAL LETTER E WITH GRAVE
+0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x00CA # LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x00CC # LATIN CAPITAL LETTER I WITH GRAVE
+0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x00CF # LATIN CAPITAL LETTER I WITH DIAERESIS
+0xD0 0x00D0 # LATIN CAPITAL LETTER ETH (Icelandic)
+0xD1 0x00D1 # LATIN CAPITAL LETTER N WITH TILDE
+0xD2 0x00D2 # LATIN CAPITAL LETTER O WITH GRAVE
+0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x00D5 # LATIN CAPITAL LETTER O WITH TILDE
+0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 # MULTIPLICATION SIGN
+0xD8 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE
+0xD9 0x00D9 # LATIN CAPITAL LETTER U WITH GRAVE
+0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x00DD # LATIN CAPITAL LETTER Y WITH ACUTE
+0xDE 0x00DE # LATIN CAPITAL LETTER THORN (Icelandic)
+0xDF 0x00DF # LATIN SMALL LETTER SHARP S (German)
+0xE0 0x00E0 # LATIN SMALL LETTER A WITH GRAVE
+0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x00E3 # LATIN SMALL LETTER A WITH TILDE
+0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE
+0xE6 0x00E6 # LATIN SMALL LETTER AE
+0xE7 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x00E8 # LATIN SMALL LETTER E WITH GRAVE
+0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x00EA # LATIN SMALL LETTER E WITH CIRCUMFLEX
+0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x00EC # LATIN SMALL LETTER I WITH GRAVE
+0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x00EF # LATIN SMALL LETTER I WITH DIAERESIS
+0xF0 0x00F0 # LATIN SMALL LETTER ETH (Icelandic)
+0xF1 0x00F1 # LATIN SMALL LETTER N WITH TILDE
+0xF2 0x00F2 # LATIN SMALL LETTER O WITH GRAVE
+0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x00F5 # LATIN SMALL LETTER O WITH TILDE
+0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 # DIVISION SIGN
+0xF8 0x00F8 # LATIN SMALL LETTER O WITH STROKE
+0xF9 0x00F9 # LATIN SMALL LETTER U WITH GRAVE
+0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x00FD # LATIN SMALL LETTER Y WITH ACUTE
+0xFE 0x00FE # LATIN SMALL LETTER THORN (Icelandic)
+0xFF 0x00FF # LATIN SMALL LETTER Y WITH DIAERESIS
--- /dev/null
+#
+# Name: ISO/IEC 8859-10:1998 to Unicode
+# Unicode version: 3.0
+# Table version: 1.1
+# Table format: Format A
+# Date: 1999 October 11
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-10:1998 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-10 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-10 order.
+#
+# Version history
+# 1.0 version new.
+# 1.1 corrected mistake in mapping of 0xA4
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x0104 # LATIN CAPITAL LETTER A WITH OGONEK
+0xA2 0x0112 # LATIN CAPITAL LETTER E WITH MACRON
+0xA3 0x0122 # LATIN CAPITAL LETTER G WITH CEDILLA
+0xA4 0x012A # LATIN CAPITAL LETTER I WITH MACRON
+0xA5 0x0128 # LATIN CAPITAL LETTER I WITH TILDE
+0xA6 0x0136 # LATIN CAPITAL LETTER K WITH CEDILLA
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x013B # LATIN CAPITAL LETTER L WITH CEDILLA
+0xA9 0x0110 # LATIN CAPITAL LETTER D WITH STROKE
+0xAA 0x0160 # LATIN CAPITAL LETTER S WITH CARON
+0xAB 0x0166 # LATIN CAPITAL LETTER T WITH STROKE
+0xAC 0x017D # LATIN CAPITAL LETTER Z WITH CARON
+0xAD 0x00AD # SOFT HYPHEN
+0xAE 0x016A # LATIN CAPITAL LETTER U WITH MACRON
+0xAF 0x014A # LATIN CAPITAL LETTER ENG
+0xB0 0x00B0 # DEGREE SIGN
+0xB1 0x0105 # LATIN SMALL LETTER A WITH OGONEK
+0xB2 0x0113 # LATIN SMALL LETTER E WITH MACRON
+0xB3 0x0123 # LATIN SMALL LETTER G WITH CEDILLA
+0xB4 0x012B # LATIN SMALL LETTER I WITH MACRON
+0xB5 0x0129 # LATIN SMALL LETTER I WITH TILDE
+0xB6 0x0137 # LATIN SMALL LETTER K WITH CEDILLA
+0xB7 0x00B7 # MIDDLE DOT
+0xB8 0x013C # LATIN SMALL LETTER L WITH CEDILLA
+0xB9 0x0111 # LATIN SMALL LETTER D WITH STROKE
+0xBA 0x0161 # LATIN SMALL LETTER S WITH CARON
+0xBB 0x0167 # LATIN SMALL LETTER T WITH STROKE
+0xBC 0x017E # LATIN SMALL LETTER Z WITH CARON
+0xBD 0x2015 # HORIZONTAL BAR
+0xBE 0x016B # LATIN SMALL LETTER U WITH MACRON
+0xBF 0x014B # LATIN SMALL LETTER ENG
+0xC0 0x0100 # LATIN CAPITAL LETTER A WITH MACRON
+0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3 0x00C3 # LATIN CAPITAL LETTER A WITH TILDE
+0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE
+0xC6 0x00C6 # LATIN CAPITAL LETTER AE
+0xC7 0x012E # LATIN CAPITAL LETTER I WITH OGONEK
+0xC8 0x010C # LATIN CAPITAL LETTER C WITH CARON
+0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x0118 # LATIN CAPITAL LETTER E WITH OGONEK
+0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x0116 # LATIN CAPITAL LETTER E WITH DOT ABOVE
+0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x00CF # LATIN CAPITAL LETTER I WITH DIAERESIS
+0xD0 0x00D0 # LATIN CAPITAL LETTER ETH (Icelandic)
+0xD1 0x0145 # LATIN CAPITAL LETTER N WITH CEDILLA
+0xD2 0x014C # LATIN CAPITAL LETTER O WITH MACRON
+0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x00D5 # LATIN CAPITAL LETTER O WITH TILDE
+0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x0168 # LATIN CAPITAL LETTER U WITH TILDE
+0xD8 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE
+0xD9 0x0172 # LATIN CAPITAL LETTER U WITH OGONEK
+0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x00DD # LATIN CAPITAL LETTER Y WITH ACUTE
+0xDE 0x00DE # LATIN CAPITAL LETTER THORN (Icelandic)
+0xDF 0x00DF # LATIN SMALL LETTER SHARP S (German)
+0xE0 0x0101 # LATIN SMALL LETTER A WITH MACRON
+0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x00E3 # LATIN SMALL LETTER A WITH TILDE
+0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE
+0xE6 0x00E6 # LATIN SMALL LETTER AE
+0xE7 0x012F # LATIN SMALL LETTER I WITH OGONEK
+0xE8 0x010D # LATIN SMALL LETTER C WITH CARON
+0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x0119 # LATIN SMALL LETTER E WITH OGONEK
+0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x0117 # LATIN SMALL LETTER E WITH DOT ABOVE
+0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x00EF # LATIN SMALL LETTER I WITH DIAERESIS
+0xF0 0x00F0 # LATIN SMALL LETTER ETH (Icelandic)
+0xF1 0x0146 # LATIN SMALL LETTER N WITH CEDILLA
+0xF2 0x014D # LATIN SMALL LETTER O WITH MACRON
+0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x00F5 # LATIN SMALL LETTER O WITH TILDE
+0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x0169 # LATIN SMALL LETTER U WITH TILDE
+0xF8 0x00F8 # LATIN SMALL LETTER O WITH STROKE
+0xF9 0x0173 # LATIN SMALL LETTER U WITH OGONEK
+0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x00FD # LATIN SMALL LETTER Y WITH ACUTE
+0xFE 0x00FE # LATIN SMALL LETTER THORN (Icelandic)
+0xFF 0x0138 # LATIN SMALL LETTER KRA
--- /dev/null
+#
+# Name: ISO/IEC 8859-11:2001 to Unicode
+# Unicode version: 3.2
+# Table version: 1.0
+# Table format: Format A
+# Date: 2002 October 7
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 2002 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-11:2001 characters map into Unicode.
+#
+# ISO/IEC 8859-11:2001 is equivalent to TIS 620-2533 (1990) with
+# the addition of 0xA0 NO-BREAK SPACE.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-11 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-11 order.
+#
+# Version history:
+# 2002 October 7 Created
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# For any comments or problems, please use the Unicode
+# web contact form at:
+# http://www.unicode.org/unicode/reporting.html
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x0E01 # THAI CHARACTER KO KAI
+0xA2 0x0E02 # THAI CHARACTER KHO KHAI
+0xA3 0x0E03 # THAI CHARACTER KHO KHUAT
+0xA4 0x0E04 # THAI CHARACTER KHO KHWAI
+0xA5 0x0E05 # THAI CHARACTER KHO KHON
+0xA6 0x0E06 # THAI CHARACTER KHO RAKHANG
+0xA7 0x0E07 # THAI CHARACTER NGO NGU
+0xA8 0x0E08 # THAI CHARACTER CHO CHAN
+0xA9 0x0E09 # THAI CHARACTER CHO CHING
+0xAA 0x0E0A # THAI CHARACTER CHO CHANG
+0xAB 0x0E0B # THAI CHARACTER SO SO
+0xAC 0x0E0C # THAI CHARACTER CHO CHOE
+0xAD 0x0E0D # THAI CHARACTER YO YING
+0xAE 0x0E0E # THAI CHARACTER DO CHADA
+0xAF 0x0E0F # THAI CHARACTER TO PATAK
+0xB0 0x0E10 # THAI CHARACTER THO THAN
+0xB1 0x0E11 # THAI CHARACTER THO NANGMONTHO
+0xB2 0x0E12 # THAI CHARACTER THO PHUTHAO
+0xB3 0x0E13 # THAI CHARACTER NO NEN
+0xB4 0x0E14 # THAI CHARACTER DO DEK
+0xB5 0x0E15 # THAI CHARACTER TO TAO
+0xB6 0x0E16 # THAI CHARACTER THO THUNG
+0xB7 0x0E17 # THAI CHARACTER THO THAHAN
+0xB8 0x0E18 # THAI CHARACTER THO THONG
+0xB9 0x0E19 # THAI CHARACTER NO NU
+0xBA 0x0E1A # THAI CHARACTER BO BAIMAI
+0xBB 0x0E1B # THAI CHARACTER PO PLA
+0xBC 0x0E1C # THAI CHARACTER PHO PHUNG
+0xBD 0x0E1D # THAI CHARACTER FO FA
+0xBE 0x0E1E # THAI CHARACTER PHO PHAN
+0xBF 0x0E1F # THAI CHARACTER FO FAN
+0xC0 0x0E20 # THAI CHARACTER PHO SAMPHAO
+0xC1 0x0E21 # THAI CHARACTER MO MA
+0xC2 0x0E22 # THAI CHARACTER YO YAK
+0xC3 0x0E23 # THAI CHARACTER RO RUA
+0xC4 0x0E24 # THAI CHARACTER RU
+0xC5 0x0E25 # THAI CHARACTER LO LING
+0xC6 0x0E26 # THAI CHARACTER LU
+0xC7 0x0E27 # THAI CHARACTER WO WAEN
+0xC8 0x0E28 # THAI CHARACTER SO SALA
+0xC9 0x0E29 # THAI CHARACTER SO RUSI
+0xCA 0x0E2A # THAI CHARACTER SO SUA
+0xCB 0x0E2B # THAI CHARACTER HO HIP
+0xCC 0x0E2C # THAI CHARACTER LO CHULA
+0xCD 0x0E2D # THAI CHARACTER O ANG
+0xCE 0x0E2E # THAI CHARACTER HO NOKHUK
+0xCF 0x0E2F # THAI CHARACTER PAIYANNOI
+0xD0 0x0E30 # THAI CHARACTER SARA A
+0xD1 0x0E31 # THAI CHARACTER MAI HAN-AKAT
+0xD2 0x0E32 # THAI CHARACTER SARA AA
+0xD3 0x0E33 # THAI CHARACTER SARA AM
+0xD4 0x0E34 # THAI CHARACTER SARA I
+0xD5 0x0E35 # THAI CHARACTER SARA II
+0xD6 0x0E36 # THAI CHARACTER SARA UE
+0xD7 0x0E37 # THAI CHARACTER SARA UEE
+0xD8 0x0E38 # THAI CHARACTER SARA U
+0xD9 0x0E39 # THAI CHARACTER SARA UU
+0xDA 0x0E3A # THAI CHARACTER PHINTHU
+0xDF 0x0E3F # THAI CURRENCY SYMBOL BAHT
+0xE0 0x0E40 # THAI CHARACTER SARA E
+0xE1 0x0E41 # THAI CHARACTER SARA AE
+0xE2 0x0E42 # THAI CHARACTER SARA O
+0xE3 0x0E43 # THAI CHARACTER SARA AI MAIMUAN
+0xE4 0x0E44 # THAI CHARACTER SARA AI MAIMALAI
+0xE5 0x0E45 # THAI CHARACTER LAKKHANGYAO
+0xE6 0x0E46 # THAI CHARACTER MAIYAMOK
+0xE7 0x0E47 # THAI CHARACTER MAITAIKHU
+0xE8 0x0E48 # THAI CHARACTER MAI EK
+0xE9 0x0E49 # THAI CHARACTER MAI THO
+0xEA 0x0E4A # THAI CHARACTER MAI TRI
+0xEB 0x0E4B # THAI CHARACTER MAI CHATTAWA
+0xEC 0x0E4C # THAI CHARACTER THANTHAKHAT
+0xED 0x0E4D # THAI CHARACTER NIKHAHIT
+0xEE 0x0E4E # THAI CHARACTER YAMAKKAN
+0xEF 0x0E4F # THAI CHARACTER FONGMAN
+0xF0 0x0E50 # THAI DIGIT ZERO
+0xF1 0x0E51 # THAI DIGIT ONE
+0xF2 0x0E52 # THAI DIGIT TWO
+0xF3 0x0E53 # THAI DIGIT THREE
+0xF4 0x0E54 # THAI DIGIT FOUR
+0xF5 0x0E55 # THAI DIGIT FIVE
+0xF6 0x0E56 # THAI DIGIT SIX
+0xF7 0x0E57 # THAI DIGIT SEVEN
+0xF8 0x0E58 # THAI DIGIT EIGHT
+0xF9 0x0E59 # THAI DIGIT NINE
+0xFA 0x0E5A # THAI CHARACTER ANGKHANKHU
+0xFB 0x0E5B # THAI CHARACTER KHOMUT
--- /dev/null
+#
+# Name: ISO/IEC 8859-13:1998 to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 1999 July 27
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1998 - 1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-13:1998 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-13 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-13 order.
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x201D # RIGHT DOUBLE QUOTATION MARK
+0xA2 0x00A2 # CENT SIGN
+0xA3 0x00A3 # POUND SIGN
+0xA4 0x00A4 # CURRENCY SIGN
+0xA5 0x201E # DOUBLE LOW-9 QUOTATION MARK
+0xA6 0x00A6 # BROKEN BAR
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE
+0xA9 0x00A9 # COPYRIGHT SIGN
+0xAA 0x0156 # LATIN CAPITAL LETTER R WITH CEDILLA
+0xAB 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC # NOT SIGN
+0xAD 0x00AD # SOFT HYPHEN
+0xAE 0x00AE # REGISTERED SIGN
+0xAF 0x00C6 # LATIN CAPITAL LETTER AE
+0xB0 0x00B0 # DEGREE SIGN
+0xB1 0x00B1 # PLUS-MINUS SIGN
+0xB2 0x00B2 # SUPERSCRIPT TWO
+0xB3 0x00B3 # SUPERSCRIPT THREE
+0xB4 0x201C # LEFT DOUBLE QUOTATION MARK
+0xB5 0x00B5 # MICRO SIGN
+0xB6 0x00B6 # PILCROW SIGN
+0xB7 0x00B7 # MIDDLE DOT
+0xB8 0x00F8 # LATIN SMALL LETTER O WITH STROKE
+0xB9 0x00B9 # SUPERSCRIPT ONE
+0xBA 0x0157 # LATIN SMALL LETTER R WITH CEDILLA
+0xBB 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x00BC # VULGAR FRACTION ONE QUARTER
+0xBD 0x00BD # VULGAR FRACTION ONE HALF
+0xBE 0x00BE # VULGAR FRACTION THREE QUARTERS
+0xBF 0x00E6 # LATIN SMALL LETTER AE
+0xC0 0x0104 # LATIN CAPITAL LETTER A WITH OGONEK
+0xC1 0x012E # LATIN CAPITAL LETTER I WITH OGONEK
+0xC2 0x0100 # LATIN CAPITAL LETTER A WITH MACRON
+0xC3 0x0106 # LATIN CAPITAL LETTER C WITH ACUTE
+0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE
+0xC6 0x0118 # LATIN CAPITAL LETTER E WITH OGONEK
+0xC7 0x0112 # LATIN CAPITAL LETTER E WITH MACRON
+0xC8 0x010C # LATIN CAPITAL LETTER C WITH CARON
+0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x0179 # LATIN CAPITAL LETTER Z WITH ACUTE
+0xCB 0x0116 # LATIN CAPITAL LETTER E WITH DOT ABOVE
+0xCC 0x0122 # LATIN CAPITAL LETTER G WITH CEDILLA
+0xCD 0x0136 # LATIN CAPITAL LETTER K WITH CEDILLA
+0xCE 0x012A # LATIN CAPITAL LETTER I WITH MACRON
+0xCF 0x013B # LATIN CAPITAL LETTER L WITH CEDILLA
+0xD0 0x0160 # LATIN CAPITAL LETTER S WITH CARON
+0xD1 0x0143 # LATIN CAPITAL LETTER N WITH ACUTE
+0xD2 0x0145 # LATIN CAPITAL LETTER N WITH CEDILLA
+0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x014C # LATIN CAPITAL LETTER O WITH MACRON
+0xD5 0x00D5 # LATIN CAPITAL LETTER O WITH TILDE
+0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 # MULTIPLICATION SIGN
+0xD8 0x0172 # LATIN CAPITAL LETTER U WITH OGONEK
+0xD9 0x0141 # LATIN CAPITAL LETTER L WITH STROKE
+0xDA 0x015A # LATIN CAPITAL LETTER S WITH ACUTE
+0xDB 0x016A # LATIN CAPITAL LETTER U WITH MACRON
+0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x017B # LATIN CAPITAL LETTER Z WITH DOT ABOVE
+0xDE 0x017D # LATIN CAPITAL LETTER Z WITH CARON
+0xDF 0x00DF # LATIN SMALL LETTER SHARP S (German)
+0xE0 0x0105 # LATIN SMALL LETTER A WITH OGONEK
+0xE1 0x012F # LATIN SMALL LETTER I WITH OGONEK
+0xE2 0x0101 # LATIN SMALL LETTER A WITH MACRON
+0xE3 0x0107 # LATIN SMALL LETTER C WITH ACUTE
+0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE
+0xE6 0x0119 # LATIN SMALL LETTER E WITH OGONEK
+0xE7 0x0113 # LATIN SMALL LETTER E WITH MACRON
+0xE8 0x010D # LATIN SMALL LETTER C WITH CARON
+0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x017A # LATIN SMALL LETTER Z WITH ACUTE
+0xEB 0x0117 # LATIN SMALL LETTER E WITH DOT ABOVE
+0xEC 0x0123 # LATIN SMALL LETTER G WITH CEDILLA
+0xED 0x0137 # LATIN SMALL LETTER K WITH CEDILLA
+0xEE 0x012B # LATIN SMALL LETTER I WITH MACRON
+0xEF 0x013C # LATIN SMALL LETTER L WITH CEDILLA
+0xF0 0x0161 # LATIN SMALL LETTER S WITH CARON
+0xF1 0x0144 # LATIN SMALL LETTER N WITH ACUTE
+0xF2 0x0146 # LATIN SMALL LETTER N WITH CEDILLA
+0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x014D # LATIN SMALL LETTER O WITH MACRON
+0xF5 0x00F5 # LATIN SMALL LETTER O WITH TILDE
+0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 # DIVISION SIGN
+0xF8 0x0173 # LATIN SMALL LETTER U WITH OGONEK
+0xF9 0x0142 # LATIN SMALL LETTER L WITH STROKE
+0xFA 0x015B # LATIN SMALL LETTER S WITH ACUTE
+0xFB 0x016B # LATIN SMALL LETTER U WITH MACRON
+0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x017C # LATIN SMALL LETTER Z WITH DOT ABOVE
+0xFE 0x017E # LATIN SMALL LETTER Z WITH CARON
+0xFF 0x2019 # RIGHT SINGLE QUOTATION MARK
--- /dev/null
+#
+# Name: ISO/IEC 8859-14:1998 to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 1999 July 27
+# Authors: Markus Kuhn <http://www.cl.cam.ac.uk/~mgk25/>
+# Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1998 - 1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-14:1998 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-14 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-14 order.
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x1E02 # LATIN CAPITAL LETTER B WITH DOT ABOVE
+0xA2 0x1E03 # LATIN SMALL LETTER B WITH DOT ABOVE
+0xA3 0x00A3 # POUND SIGN
+0xA4 0x010A # LATIN CAPITAL LETTER C WITH DOT ABOVE
+0xA5 0x010B # LATIN SMALL LETTER C WITH DOT ABOVE
+0xA6 0x1E0A # LATIN CAPITAL LETTER D WITH DOT ABOVE
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x1E80 # LATIN CAPITAL LETTER W WITH GRAVE
+0xA9 0x00A9 # COPYRIGHT SIGN
+0xAA 0x1E82 # LATIN CAPITAL LETTER W WITH ACUTE
+0xAB 0x1E0B # LATIN SMALL LETTER D WITH DOT ABOVE
+0xAC 0x1EF2 # LATIN CAPITAL LETTER Y WITH GRAVE
+0xAD 0x00AD # SOFT HYPHEN
+0xAE 0x00AE # REGISTERED SIGN
+0xAF 0x0178 # LATIN CAPITAL LETTER Y WITH DIAERESIS
+0xB0 0x1E1E # LATIN CAPITAL LETTER F WITH DOT ABOVE
+0xB1 0x1E1F # LATIN SMALL LETTER F WITH DOT ABOVE
+0xB2 0x0120 # LATIN CAPITAL LETTER G WITH DOT ABOVE
+0xB3 0x0121 # LATIN SMALL LETTER G WITH DOT ABOVE
+0xB4 0x1E40 # LATIN CAPITAL LETTER M WITH DOT ABOVE
+0xB5 0x1E41 # LATIN SMALL LETTER M WITH DOT ABOVE
+0xB6 0x00B6 # PILCROW SIGN
+0xB7 0x1E56 # LATIN CAPITAL LETTER P WITH DOT ABOVE
+0xB8 0x1E81 # LATIN SMALL LETTER W WITH GRAVE
+0xB9 0x1E57 # LATIN SMALL LETTER P WITH DOT ABOVE
+0xBA 0x1E83 # LATIN SMALL LETTER W WITH ACUTE
+0xBB 0x1E60 # LATIN CAPITAL LETTER S WITH DOT ABOVE
+0xBC 0x1EF3 # LATIN SMALL LETTER Y WITH GRAVE
+0xBD 0x1E84 # LATIN CAPITAL LETTER W WITH DIAERESIS
+0xBE 0x1E85 # LATIN SMALL LETTER W WITH DIAERESIS
+0xBF 0x1E61 # LATIN SMALL LETTER S WITH DOT ABOVE
+0xC0 0x00C0 # LATIN CAPITAL LETTER A WITH GRAVE
+0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3 0x00C3 # LATIN CAPITAL LETTER A WITH TILDE
+0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE
+0xC6 0x00C6 # LATIN CAPITAL LETTER AE
+0xC7 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8 0x00C8 # LATIN CAPITAL LETTER E WITH GRAVE
+0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x00CA # LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x00CC # LATIN CAPITAL LETTER I WITH GRAVE
+0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x00CF # LATIN CAPITAL LETTER I WITH DIAERESIS
+0xD0 0x0174 # LATIN CAPITAL LETTER W WITH CIRCUMFLEX
+0xD1 0x00D1 # LATIN CAPITAL LETTER N WITH TILDE
+0xD2 0x00D2 # LATIN CAPITAL LETTER O WITH GRAVE
+0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x00D5 # LATIN CAPITAL LETTER O WITH TILDE
+0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x1E6A # LATIN CAPITAL LETTER T WITH DOT ABOVE
+0xD8 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE
+0xD9 0x00D9 # LATIN CAPITAL LETTER U WITH GRAVE
+0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x00DD # LATIN CAPITAL LETTER Y WITH ACUTE
+0xDE 0x0176 # LATIN CAPITAL LETTER Y WITH CIRCUMFLEX
+0xDF 0x00DF # LATIN SMALL LETTER SHARP S
+0xE0 0x00E0 # LATIN SMALL LETTER A WITH GRAVE
+0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x00E3 # LATIN SMALL LETTER A WITH TILDE
+0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE
+0xE6 0x00E6 # LATIN SMALL LETTER AE
+0xE7 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x00E8 # LATIN SMALL LETTER E WITH GRAVE
+0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x00EA # LATIN SMALL LETTER E WITH CIRCUMFLEX
+0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x00EC # LATIN SMALL LETTER I WITH GRAVE
+0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x00EF # LATIN SMALL LETTER I WITH DIAERESIS
+0xF0 0x0175 # LATIN SMALL LETTER W WITH CIRCUMFLEX
+0xF1 0x00F1 # LATIN SMALL LETTER N WITH TILDE
+0xF2 0x00F2 # LATIN SMALL LETTER O WITH GRAVE
+0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x00F5 # LATIN SMALL LETTER O WITH TILDE
+0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x1E6B # LATIN SMALL LETTER T WITH DOT ABOVE
+0xF8 0x00F8 # LATIN SMALL LETTER O WITH STROKE
+0xF9 0x00F9 # LATIN SMALL LETTER U WITH GRAVE
+0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x00FD # LATIN SMALL LETTER Y WITH ACUTE
+0xFE 0x0177 # LATIN SMALL LETTER Y WITH CIRCUMFLEX
+0xFF 0x00FF # LATIN SMALL LETTER Y WITH DIAERESIS
+
--- /dev/null
+#
+# Name: ISO/IEC 8859-15:1999 to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 1999 July 27
+# Authors: Markus Kuhn <http://www.cl.cam.ac.uk/~mgk25/>
+# Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1998 - 1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-15:1999 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-15 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-15 order.
+#
+# Version history
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x00A1 # INVERTED EXCLAMATION MARK
+0xA2 0x00A2 # CENT SIGN
+0xA3 0x00A3 # POUND SIGN
+0xA4 0x20AC # EURO SIGN
+0xA5 0x00A5 # YEN SIGN
+0xA6 0x0160 # LATIN CAPITAL LETTER S WITH CARON
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x0161 # LATIN SMALL LETTER S WITH CARON
+0xA9 0x00A9 # COPYRIGHT SIGN
+0xAA 0x00AA # FEMININE ORDINAL INDICATOR
+0xAB 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC # NOT SIGN
+0xAD 0x00AD # SOFT HYPHEN
+0xAE 0x00AE # REGISTERED SIGN
+0xAF 0x00AF # MACRON
+0xB0 0x00B0 # DEGREE SIGN
+0xB1 0x00B1 # PLUS-MINUS SIGN
+0xB2 0x00B2 # SUPERSCRIPT TWO
+0xB3 0x00B3 # SUPERSCRIPT THREE
+0xB4 0x017D # LATIN CAPITAL LETTER Z WITH CARON
+0xB5 0x00B5 # MICRO SIGN
+0xB6 0x00B6 # PILCROW SIGN
+0xB7 0x00B7 # MIDDLE DOT
+0xB8 0x017E # LATIN SMALL LETTER Z WITH CARON
+0xB9 0x00B9 # SUPERSCRIPT ONE
+0xBA 0x00BA # MASCULINE ORDINAL INDICATOR
+0xBB 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x0152 # LATIN CAPITAL LIGATURE OE
+0xBD 0x0153 # LATIN SMALL LIGATURE OE
+0xBE 0x0178 # LATIN CAPITAL LETTER Y WITH DIAERESIS
+0xBF 0x00BF # INVERTED QUESTION MARK
+0xC0 0x00C0 # LATIN CAPITAL LETTER A WITH GRAVE
+0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3 0x00C3 # LATIN CAPITAL LETTER A WITH TILDE
+0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE
+0xC6 0x00C6 # LATIN CAPITAL LETTER AE
+0xC7 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8 0x00C8 # LATIN CAPITAL LETTER E WITH GRAVE
+0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x00CA # LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x00CC # LATIN CAPITAL LETTER I WITH GRAVE
+0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x00CF # LATIN CAPITAL LETTER I WITH DIAERESIS
+0xD0 0x00D0 # LATIN CAPITAL LETTER ETH
+0xD1 0x00D1 # LATIN CAPITAL LETTER N WITH TILDE
+0xD2 0x00D2 # LATIN CAPITAL LETTER O WITH GRAVE
+0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x00D5 # LATIN CAPITAL LETTER O WITH TILDE
+0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 # MULTIPLICATION SIGN
+0xD8 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE
+0xD9 0x00D9 # LATIN CAPITAL LETTER U WITH GRAVE
+0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x00DD # LATIN CAPITAL LETTER Y WITH ACUTE
+0xDE 0x00DE # LATIN CAPITAL LETTER THORN
+0xDF 0x00DF # LATIN SMALL LETTER SHARP S
+0xE0 0x00E0 # LATIN SMALL LETTER A WITH GRAVE
+0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x00E3 # LATIN SMALL LETTER A WITH TILDE
+0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE
+0xE6 0x00E6 # LATIN SMALL LETTER AE
+0xE7 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x00E8 # LATIN SMALL LETTER E WITH GRAVE
+0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x00EA # LATIN SMALL LETTER E WITH CIRCUMFLEX
+0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x00EC # LATIN SMALL LETTER I WITH GRAVE
+0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x00EF # LATIN SMALL LETTER I WITH DIAERESIS
+0xF0 0x00F0 # LATIN SMALL LETTER ETH
+0xF1 0x00F1 # LATIN SMALL LETTER N WITH TILDE
+0xF2 0x00F2 # LATIN SMALL LETTER O WITH GRAVE
+0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x00F5 # LATIN SMALL LETTER O WITH TILDE
+0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 # DIVISION SIGN
+0xF8 0x00F8 # LATIN SMALL LETTER O WITH STROKE
+0xF9 0x00F9 # LATIN SMALL LETTER U WITH GRAVE
+0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x00FD # LATIN SMALL LETTER Y WITH ACUTE
+0xFE 0x00FE # LATIN SMALL LETTER THORN
+0xFF 0x00FF # LATIN SMALL LETTER Y WITH DIAERESIS
+
--- /dev/null
+#
+# Name: ISO/IEC 8859-16:2001 to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 2001 July 26
+# Authors: Markus Kuhn <http://www.cl.cam.ac.uk/~mgk25/>
+#
+# Copyright (c) 1999-2001 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-16:2001 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-16 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-16 order.
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x0104 # LATIN CAPITAL LETTER A WITH OGONEK
+0xA2 0x0105 # LATIN SMALL LETTER A WITH OGONEK
+0xA3 0x0141 # LATIN CAPITAL LETTER L WITH STROKE
+0xA4 0x20AC # EURO SIGN
+0xA5 0x201E # DOUBLE LOW-9 QUOTATION MARK
+0xA6 0x0160 # LATIN CAPITAL LETTER S WITH CARON
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x0161 # LATIN SMALL LETTER S WITH CARON
+0xA9 0x00A9 # COPYRIGHT SIGN
+0xAA 0x0218 # LATIN CAPITAL LETTER S WITH COMMA BELOW
+0xAB 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x0179 # LATIN CAPITAL LETTER Z WITH ACUTE
+0xAD 0x00AD # SOFT HYPHEN
+0xAE 0x017A # LATIN SMALL LETTER Z WITH ACUTE
+0xAF 0x017B # LATIN CAPITAL LETTER Z WITH DOT ABOVE
+0xB0 0x00B0 # DEGREE SIGN
+0xB1 0x00B1 # PLUS-MINUS SIGN
+0xB2 0x010C # LATIN CAPITAL LETTER C WITH CARON
+0xB3 0x0142 # LATIN SMALL LETTER L WITH STROKE
+0xB4 0x017D # LATIN CAPITAL LETTER Z WITH CARON
+0xB5 0x201D # RIGHT DOUBLE QUOTATION MARK
+0xB6 0x00B6 # PILCROW SIGN
+0xB7 0x00B7 # MIDDLE DOT
+0xB8 0x017E # LATIN SMALL LETTER Z WITH CARON
+0xB9 0x010D # LATIN SMALL LETTER C WITH CARON
+0xBA 0x0219 # LATIN SMALL LETTER S WITH COMMA BELOW
+0xBB 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x0152 # LATIN CAPITAL LIGATURE OE
+0xBD 0x0153 # LATIN SMALL LIGATURE OE
+0xBE 0x0178 # LATIN CAPITAL LETTER Y WITH DIAERESIS
+0xBF 0x017C # LATIN SMALL LETTER Z WITH DOT ABOVE
+0xC0 0x00C0 # LATIN CAPITAL LETTER A WITH GRAVE
+0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3 0x0102 # LATIN CAPITAL LETTER A WITH BREVE
+0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x0106 # LATIN CAPITAL LETTER C WITH ACUTE
+0xC6 0x00C6 # LATIN CAPITAL LETTER AE
+0xC7 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8 0x00C8 # LATIN CAPITAL LETTER E WITH GRAVE
+0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x00CA # LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x00CC # LATIN CAPITAL LETTER I WITH GRAVE
+0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x00CF # LATIN CAPITAL LETTER I WITH DIAERESIS
+0xD0 0x0110 # LATIN CAPITAL LETTER D WITH STROKE
+0xD1 0x0143 # LATIN CAPITAL LETTER N WITH ACUTE
+0xD2 0x00D2 # LATIN CAPITAL LETTER O WITH GRAVE
+0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x0150 # LATIN CAPITAL LETTER O WITH DOUBLE ACUTE
+0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x015A # LATIN CAPITAL LETTER S WITH ACUTE
+0xD8 0x0170 # LATIN CAPITAL LETTER U WITH DOUBLE ACUTE
+0xD9 0x00D9 # LATIN CAPITAL LETTER U WITH GRAVE
+0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x0118 # LATIN CAPITAL LETTER E WITH OGONEK
+0xDE 0x021A # LATIN CAPITAL LETTER T WITH COMMA BELOW
+0xDF 0x00DF # LATIN SMALL LETTER SHARP S
+0xE0 0x00E0 # LATIN SMALL LETTER A WITH GRAVE
+0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x0103 # LATIN SMALL LETTER A WITH BREVE
+0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x0107 # LATIN SMALL LETTER C WITH ACUTE
+0xE6 0x00E6 # LATIN SMALL LETTER AE
+0xE7 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x00E8 # LATIN SMALL LETTER E WITH GRAVE
+0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x00EA # LATIN SMALL LETTER E WITH CIRCUMFLEX
+0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x00EC # LATIN SMALL LETTER I WITH GRAVE
+0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x00EF # LATIN SMALL LETTER I WITH DIAERESIS
+0xF0 0x0111 # LATIN SMALL LETTER D WITH STROKE
+0xF1 0x0144 # LATIN SMALL LETTER N WITH ACUTE
+0xF2 0x00F2 # LATIN SMALL LETTER O WITH GRAVE
+0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x0151 # LATIN SMALL LETTER O WITH DOUBLE ACUTE
+0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x015B # LATIN SMALL LETTER S WITH ACUTE
+0xF8 0x0171 # LATIN SMALL LETTER U WITH DOUBLE ACUTE
+0xF9 0x00F9 # LATIN SMALL LETTER U WITH GRAVE
+0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x0119 # LATIN SMALL LETTER E WITH OGONEK
+0xFE 0x021B # LATIN SMALL LETTER T WITH COMMA BELOW
+0xFF 0x00FF # LATIN SMALL LETTER Y WITH DIAERESIS
--- /dev/null
+#
+# Name: ISO 8859-2:1999 to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 1999 July 27
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1991-1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-2:1999 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-2 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-2 order.
+#
+# Version history
+# 1.0 version updates 0.1 version by adding mappings for all
+# control characters.
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x0104 # LATIN CAPITAL LETTER A WITH OGONEK
+0xA2 0x02D8 # BREVE
+0xA3 0x0141 # LATIN CAPITAL LETTER L WITH STROKE
+0xA4 0x00A4 # CURRENCY SIGN
+0xA5 0x013D # LATIN CAPITAL LETTER L WITH CARON
+0xA6 0x015A # LATIN CAPITAL LETTER S WITH ACUTE
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x00A8 # DIAERESIS
+0xA9 0x0160 # LATIN CAPITAL LETTER S WITH CARON
+0xAA 0x015E # LATIN CAPITAL LETTER S WITH CEDILLA
+0xAB 0x0164 # LATIN CAPITAL LETTER T WITH CARON
+0xAC 0x0179 # LATIN CAPITAL LETTER Z WITH ACUTE
+0xAD 0x00AD # SOFT HYPHEN
+0xAE 0x017D # LATIN CAPITAL LETTER Z WITH CARON
+0xAF 0x017B # LATIN CAPITAL LETTER Z WITH DOT ABOVE
+0xB0 0x00B0 # DEGREE SIGN
+0xB1 0x0105 # LATIN SMALL LETTER A WITH OGONEK
+0xB2 0x02DB # OGONEK
+0xB3 0x0142 # LATIN SMALL LETTER L WITH STROKE
+0xB4 0x00B4 # ACUTE ACCENT
+0xB5 0x013E # LATIN SMALL LETTER L WITH CARON
+0xB6 0x015B # LATIN SMALL LETTER S WITH ACUTE
+0xB7 0x02C7 # CARON
+0xB8 0x00B8 # CEDILLA
+0xB9 0x0161 # LATIN SMALL LETTER S WITH CARON
+0xBA 0x015F # LATIN SMALL LETTER S WITH CEDILLA
+0xBB 0x0165 # LATIN SMALL LETTER T WITH CARON
+0xBC 0x017A # LATIN SMALL LETTER Z WITH ACUTE
+0xBD 0x02DD # DOUBLE ACUTE ACCENT
+0xBE 0x017E # LATIN SMALL LETTER Z WITH CARON
+0xBF 0x017C # LATIN SMALL LETTER Z WITH DOT ABOVE
+0xC0 0x0154 # LATIN CAPITAL LETTER R WITH ACUTE
+0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3 0x0102 # LATIN CAPITAL LETTER A WITH BREVE
+0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x0139 # LATIN CAPITAL LETTER L WITH ACUTE
+0xC6 0x0106 # LATIN CAPITAL LETTER C WITH ACUTE
+0xC7 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8 0x010C # LATIN CAPITAL LETTER C WITH CARON
+0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x0118 # LATIN CAPITAL LETTER E WITH OGONEK
+0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x011A # LATIN CAPITAL LETTER E WITH CARON
+0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x010E # LATIN CAPITAL LETTER D WITH CARON
+0xD0 0x0110 # LATIN CAPITAL LETTER D WITH STROKE
+0xD1 0x0143 # LATIN CAPITAL LETTER N WITH ACUTE
+0xD2 0x0147 # LATIN CAPITAL LETTER N WITH CARON
+0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x0150 # LATIN CAPITAL LETTER O WITH DOUBLE ACUTE
+0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 # MULTIPLICATION SIGN
+0xD8 0x0158 # LATIN CAPITAL LETTER R WITH CARON
+0xD9 0x016E # LATIN CAPITAL LETTER U WITH RING ABOVE
+0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x0170 # LATIN CAPITAL LETTER U WITH DOUBLE ACUTE
+0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x00DD # LATIN CAPITAL LETTER Y WITH ACUTE
+0xDE 0x0162 # LATIN CAPITAL LETTER T WITH CEDILLA
+0xDF 0x00DF # LATIN SMALL LETTER SHARP S
+0xE0 0x0155 # LATIN SMALL LETTER R WITH ACUTE
+0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x0103 # LATIN SMALL LETTER A WITH BREVE
+0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x013A # LATIN SMALL LETTER L WITH ACUTE
+0xE6 0x0107 # LATIN SMALL LETTER C WITH ACUTE
+0xE7 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x010D # LATIN SMALL LETTER C WITH CARON
+0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x0119 # LATIN SMALL LETTER E WITH OGONEK
+0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x011B # LATIN SMALL LETTER E WITH CARON
+0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x010F # LATIN SMALL LETTER D WITH CARON
+0xF0 0x0111 # LATIN SMALL LETTER D WITH STROKE
+0xF1 0x0144 # LATIN SMALL LETTER N WITH ACUTE
+0xF2 0x0148 # LATIN SMALL LETTER N WITH CARON
+0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x0151 # LATIN SMALL LETTER O WITH DOUBLE ACUTE
+0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 # DIVISION SIGN
+0xF8 0x0159 # LATIN SMALL LETTER R WITH CARON
+0xF9 0x016F # LATIN SMALL LETTER U WITH RING ABOVE
+0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x0171 # LATIN SMALL LETTER U WITH DOUBLE ACUTE
+0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x00FD # LATIN SMALL LETTER Y WITH ACUTE
+0xFE 0x0163 # LATIN SMALL LETTER T WITH CEDILLA
+0xFF 0x02D9 # DOT ABOVE
--- /dev/null
+#
+# Name: ISO/IEC 8859-3:1999 to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 1999 July 27
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1991-1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-3:1999 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-3 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-3 order.
+#
+# Version history
+# 1.0 version updates 0.1 version by adding mappings for all
+# control characters.
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x0126 # LATIN CAPITAL LETTER H WITH STROKE
+0xA2 0x02D8 # BREVE
+0xA3 0x00A3 # POUND SIGN
+0xA4 0x00A4 # CURRENCY SIGN
+0xA6 0x0124 # LATIN CAPITAL LETTER H WITH CIRCUMFLEX
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x00A8 # DIAERESIS
+0xA9 0x0130 # LATIN CAPITAL LETTER I WITH DOT ABOVE
+0xAA 0x015E # LATIN CAPITAL LETTER S WITH CEDILLA
+0xAB 0x011E # LATIN CAPITAL LETTER G WITH BREVE
+0xAC 0x0134 # LATIN CAPITAL LETTER J WITH CIRCUMFLEX
+0xAD 0x00AD # SOFT HYPHEN
+0xAF 0x017B # LATIN CAPITAL LETTER Z WITH DOT ABOVE
+0xB0 0x00B0 # DEGREE SIGN
+0xB1 0x0127 # LATIN SMALL LETTER H WITH STROKE
+0xB2 0x00B2 # SUPERSCRIPT TWO
+0xB3 0x00B3 # SUPERSCRIPT THREE
+0xB4 0x00B4 # ACUTE ACCENT
+0xB5 0x00B5 # MICRO SIGN
+0xB6 0x0125 # LATIN SMALL LETTER H WITH CIRCUMFLEX
+0xB7 0x00B7 # MIDDLE DOT
+0xB8 0x00B8 # CEDILLA
+0xB9 0x0131 # LATIN SMALL LETTER DOTLESS I
+0xBA 0x015F # LATIN SMALL LETTER S WITH CEDILLA
+0xBB 0x011F # LATIN SMALL LETTER G WITH BREVE
+0xBC 0x0135 # LATIN SMALL LETTER J WITH CIRCUMFLEX
+0xBD 0x00BD # VULGAR FRACTION ONE HALF
+0xBF 0x017C # LATIN SMALL LETTER Z WITH DOT ABOVE
+0xC0 0x00C0 # LATIN CAPITAL LETTER A WITH GRAVE
+0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x010A # LATIN CAPITAL LETTER C WITH DOT ABOVE
+0xC6 0x0108 # LATIN CAPITAL LETTER C WITH CIRCUMFLEX
+0xC7 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8 0x00C8 # LATIN CAPITAL LETTER E WITH GRAVE
+0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x00CA # LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x00CC # LATIN CAPITAL LETTER I WITH GRAVE
+0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x00CF # LATIN CAPITAL LETTER I WITH DIAERESIS
+0xD1 0x00D1 # LATIN CAPITAL LETTER N WITH TILDE
+0xD2 0x00D2 # LATIN CAPITAL LETTER O WITH GRAVE
+0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x0120 # LATIN CAPITAL LETTER G WITH DOT ABOVE
+0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 # MULTIPLICATION SIGN
+0xD8 0x011C # LATIN CAPITAL LETTER G WITH CIRCUMFLEX
+0xD9 0x00D9 # LATIN CAPITAL LETTER U WITH GRAVE
+0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x016C # LATIN CAPITAL LETTER U WITH BREVE
+0xDE 0x015C # LATIN CAPITAL LETTER S WITH CIRCUMFLEX
+0xDF 0x00DF # LATIN SMALL LETTER SHARP S
+0xE0 0x00E0 # LATIN SMALL LETTER A WITH GRAVE
+0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x010B # LATIN SMALL LETTER C WITH DOT ABOVE
+0xE6 0x0109 # LATIN SMALL LETTER C WITH CIRCUMFLEX
+0xE7 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x00E8 # LATIN SMALL LETTER E WITH GRAVE
+0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x00EA # LATIN SMALL LETTER E WITH CIRCUMFLEX
+0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x00EC # LATIN SMALL LETTER I WITH GRAVE
+0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x00EF # LATIN SMALL LETTER I WITH DIAERESIS
+0xF1 0x00F1 # LATIN SMALL LETTER N WITH TILDE
+0xF2 0x00F2 # LATIN SMALL LETTER O WITH GRAVE
+0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x0121 # LATIN SMALL LETTER G WITH DOT ABOVE
+0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 # DIVISION SIGN
+0xF8 0x011D # LATIN SMALL LETTER G WITH CIRCUMFLEX
+0xF9 0x00F9 # LATIN SMALL LETTER U WITH GRAVE
+0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x016D # LATIN SMALL LETTER U WITH BREVE
+0xFE 0x015D # LATIN SMALL LETTER S WITH CIRCUMFLEX
+0xFF 0x02D9 # DOT ABOVE
--- /dev/null
+#
+# Name: ISO/IEC 8859-4:1998 to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 1999 July 27
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1991-1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-4:1998 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-4 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-4 order.
+#
+# Version history
+# 1.0 version updates 0.1 version by adding mappings for all
+# control characters.
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x0104 # LATIN CAPITAL LETTER A WITH OGONEK
+0xA2 0x0138 # LATIN SMALL LETTER KRA
+0xA3 0x0156 # LATIN CAPITAL LETTER R WITH CEDILLA
+0xA4 0x00A4 # CURRENCY SIGN
+0xA5 0x0128 # LATIN CAPITAL LETTER I WITH TILDE
+0xA6 0x013B # LATIN CAPITAL LETTER L WITH CEDILLA
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x00A8 # DIAERESIS
+0xA9 0x0160 # LATIN CAPITAL LETTER S WITH CARON
+0xAA 0x0112 # LATIN CAPITAL LETTER E WITH MACRON
+0xAB 0x0122 # LATIN CAPITAL LETTER G WITH CEDILLA
+0xAC 0x0166 # LATIN CAPITAL LETTER T WITH STROKE
+0xAD 0x00AD # SOFT HYPHEN
+0xAE 0x017D # LATIN CAPITAL LETTER Z WITH CARON
+0xAF 0x00AF # MACRON
+0xB0 0x00B0 # DEGREE SIGN
+0xB1 0x0105 # LATIN SMALL LETTER A WITH OGONEK
+0xB2 0x02DB # OGONEK
+0xB3 0x0157 # LATIN SMALL LETTER R WITH CEDILLA
+0xB4 0x00B4 # ACUTE ACCENT
+0xB5 0x0129 # LATIN SMALL LETTER I WITH TILDE
+0xB6 0x013C # LATIN SMALL LETTER L WITH CEDILLA
+0xB7 0x02C7 # CARON
+0xB8 0x00B8 # CEDILLA
+0xB9 0x0161 # LATIN SMALL LETTER S WITH CARON
+0xBA 0x0113 # LATIN SMALL LETTER E WITH MACRON
+0xBB 0x0123 # LATIN SMALL LETTER G WITH CEDILLA
+0xBC 0x0167 # LATIN SMALL LETTER T WITH STROKE
+0xBD 0x014A # LATIN CAPITAL LETTER ENG
+0xBE 0x017E # LATIN SMALL LETTER Z WITH CARON
+0xBF 0x014B # LATIN SMALL LETTER ENG
+0xC0 0x0100 # LATIN CAPITAL LETTER A WITH MACRON
+0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3 0x00C3 # LATIN CAPITAL LETTER A WITH TILDE
+0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE
+0xC6 0x00C6 # LATIN CAPITAL LETTER AE
+0xC7 0x012E # LATIN CAPITAL LETTER I WITH OGONEK
+0xC8 0x010C # LATIN CAPITAL LETTER C WITH CARON
+0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x0118 # LATIN CAPITAL LETTER E WITH OGONEK
+0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x0116 # LATIN CAPITAL LETTER E WITH DOT ABOVE
+0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x012A # LATIN CAPITAL LETTER I WITH MACRON
+0xD0 0x0110 # LATIN CAPITAL LETTER D WITH STROKE
+0xD1 0x0145 # LATIN CAPITAL LETTER N WITH CEDILLA
+0xD2 0x014C # LATIN CAPITAL LETTER O WITH MACRON
+0xD3 0x0136 # LATIN CAPITAL LETTER K WITH CEDILLA
+0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x00D5 # LATIN CAPITAL LETTER O WITH TILDE
+0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 # MULTIPLICATION SIGN
+0xD8 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE
+0xD9 0x0172 # LATIN CAPITAL LETTER U WITH OGONEK
+0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x0168 # LATIN CAPITAL LETTER U WITH TILDE
+0xDE 0x016A # LATIN CAPITAL LETTER U WITH MACRON
+0xDF 0x00DF # LATIN SMALL LETTER SHARP S
+0xE0 0x0101 # LATIN SMALL LETTER A WITH MACRON
+0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x00E3 # LATIN SMALL LETTER A WITH TILDE
+0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE
+0xE6 0x00E6 # LATIN SMALL LETTER AE
+0xE7 0x012F # LATIN SMALL LETTER I WITH OGONEK
+0xE8 0x010D # LATIN SMALL LETTER C WITH CARON
+0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x0119 # LATIN SMALL LETTER E WITH OGONEK
+0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x0117 # LATIN SMALL LETTER E WITH DOT ABOVE
+0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x012B # LATIN SMALL LETTER I WITH MACRON
+0xF0 0x0111 # LATIN SMALL LETTER D WITH STROKE
+0xF1 0x0146 # LATIN SMALL LETTER N WITH CEDILLA
+0xF2 0x014D # LATIN SMALL LETTER O WITH MACRON
+0xF3 0x0137 # LATIN SMALL LETTER K WITH CEDILLA
+0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x00F5 # LATIN SMALL LETTER O WITH TILDE
+0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 # DIVISION SIGN
+0xF8 0x00F8 # LATIN SMALL LETTER O WITH STROKE
+0xF9 0x0173 # LATIN SMALL LETTER U WITH OGONEK
+0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x0169 # LATIN SMALL LETTER U WITH TILDE
+0xFE 0x016B # LATIN SMALL LETTER U WITH MACRON
+0xFF 0x02D9 # DOT ABOVE
--- /dev/null
+#
+# Name: ISO 8859-5:1999 to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 1999 July 27
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1991-1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-5:1999 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-5 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-5 order.
+#
+# Version history
+# 1.0 version updates 0.1 version by adding mappings for all
+# control characters.
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x0401 # CYRILLIC CAPITAL LETTER IO
+0xA2 0x0402 # CYRILLIC CAPITAL LETTER DJE
+0xA3 0x0403 # CYRILLIC CAPITAL LETTER GJE
+0xA4 0x0404 # CYRILLIC CAPITAL LETTER UKRAINIAN IE
+0xA5 0x0405 # CYRILLIC CAPITAL LETTER DZE
+0xA6 0x0406 # CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I
+0xA7 0x0407 # CYRILLIC CAPITAL LETTER YI
+0xA8 0x0408 # CYRILLIC CAPITAL LETTER JE
+0xA9 0x0409 # CYRILLIC CAPITAL LETTER LJE
+0xAA 0x040A # CYRILLIC CAPITAL LETTER NJE
+0xAB 0x040B # CYRILLIC CAPITAL LETTER TSHE
+0xAC 0x040C # CYRILLIC CAPITAL LETTER KJE
+0xAD 0x00AD # SOFT HYPHEN
+0xAE 0x040E # CYRILLIC CAPITAL LETTER SHORT U
+0xAF 0x040F # CYRILLIC CAPITAL LETTER DZHE
+0xB0 0x0410 # CYRILLIC CAPITAL LETTER A
+0xB1 0x0411 # CYRILLIC CAPITAL LETTER BE
+0xB2 0x0412 # CYRILLIC CAPITAL LETTER VE
+0xB3 0x0413 # CYRILLIC CAPITAL LETTER GHE
+0xB4 0x0414 # CYRILLIC CAPITAL LETTER DE
+0xB5 0x0415 # CYRILLIC CAPITAL LETTER IE
+0xB6 0x0416 # CYRILLIC CAPITAL LETTER ZHE
+0xB7 0x0417 # CYRILLIC CAPITAL LETTER ZE
+0xB8 0x0418 # CYRILLIC CAPITAL LETTER I
+0xB9 0x0419 # CYRILLIC CAPITAL LETTER SHORT I
+0xBA 0x041A # CYRILLIC CAPITAL LETTER KA
+0xBB 0x041B # CYRILLIC CAPITAL LETTER EL
+0xBC 0x041C # CYRILLIC CAPITAL LETTER EM
+0xBD 0x041D # CYRILLIC CAPITAL LETTER EN
+0xBE 0x041E # CYRILLIC CAPITAL LETTER O
+0xBF 0x041F # CYRILLIC CAPITAL LETTER PE
+0xC0 0x0420 # CYRILLIC CAPITAL LETTER ER
+0xC1 0x0421 # CYRILLIC CAPITAL LETTER ES
+0xC2 0x0422 # CYRILLIC CAPITAL LETTER TE
+0xC3 0x0423 # CYRILLIC CAPITAL LETTER U
+0xC4 0x0424 # CYRILLIC CAPITAL LETTER EF
+0xC5 0x0425 # CYRILLIC CAPITAL LETTER HA
+0xC6 0x0426 # CYRILLIC CAPITAL LETTER TSE
+0xC7 0x0427 # CYRILLIC CAPITAL LETTER CHE
+0xC8 0x0428 # CYRILLIC CAPITAL LETTER SHA
+0xC9 0x0429 # CYRILLIC CAPITAL LETTER SHCHA
+0xCA 0x042A # CYRILLIC CAPITAL LETTER HARD SIGN
+0xCB 0x042B # CYRILLIC CAPITAL LETTER YERU
+0xCC 0x042C # CYRILLIC CAPITAL LETTER SOFT SIGN
+0xCD 0x042D # CYRILLIC CAPITAL LETTER E
+0xCE 0x042E # CYRILLIC CAPITAL LETTER YU
+0xCF 0x042F # CYRILLIC CAPITAL LETTER YA
+0xD0 0x0430 # CYRILLIC SMALL LETTER A
+0xD1 0x0431 # CYRILLIC SMALL LETTER BE
+0xD2 0x0432 # CYRILLIC SMALL LETTER VE
+0xD3 0x0433 # CYRILLIC SMALL LETTER GHE
+0xD4 0x0434 # CYRILLIC SMALL LETTER DE
+0xD5 0x0435 # CYRILLIC SMALL LETTER IE
+0xD6 0x0436 # CYRILLIC SMALL LETTER ZHE
+0xD7 0x0437 # CYRILLIC SMALL LETTER ZE
+0xD8 0x0438 # CYRILLIC SMALL LETTER I
+0xD9 0x0439 # CYRILLIC SMALL LETTER SHORT I
+0xDA 0x043A # CYRILLIC SMALL LETTER KA
+0xDB 0x043B # CYRILLIC SMALL LETTER EL
+0xDC 0x043C # CYRILLIC SMALL LETTER EM
+0xDD 0x043D # CYRILLIC SMALL LETTER EN
+0xDE 0x043E # CYRILLIC SMALL LETTER O
+0xDF 0x043F # CYRILLIC SMALL LETTER PE
+0xE0 0x0440 # CYRILLIC SMALL LETTER ER
+0xE1 0x0441 # CYRILLIC SMALL LETTER ES
+0xE2 0x0442 # CYRILLIC SMALL LETTER TE
+0xE3 0x0443 # CYRILLIC SMALL LETTER U
+0xE4 0x0444 # CYRILLIC SMALL LETTER EF
+0xE5 0x0445 # CYRILLIC SMALL LETTER HA
+0xE6 0x0446 # CYRILLIC SMALL LETTER TSE
+0xE7 0x0447 # CYRILLIC SMALL LETTER CHE
+0xE8 0x0448 # CYRILLIC SMALL LETTER SHA
+0xE9 0x0449 # CYRILLIC SMALL LETTER SHCHA
+0xEA 0x044A # CYRILLIC SMALL LETTER HARD SIGN
+0xEB 0x044B # CYRILLIC SMALL LETTER YERU
+0xEC 0x044C # CYRILLIC SMALL LETTER SOFT SIGN
+0xED 0x044D # CYRILLIC SMALL LETTER E
+0xEE 0x044E # CYRILLIC SMALL LETTER YU
+0xEF 0x044F # CYRILLIC SMALL LETTER YA
+0xF0 0x2116 # NUMERO SIGN
+0xF1 0x0451 # CYRILLIC SMALL LETTER IO
+0xF2 0x0452 # CYRILLIC SMALL LETTER DJE
+0xF3 0x0453 # CYRILLIC SMALL LETTER GJE
+0xF4 0x0454 # CYRILLIC SMALL LETTER UKRAINIAN IE
+0xF5 0x0455 # CYRILLIC SMALL LETTER DZE
+0xF6 0x0456 # CYRILLIC SMALL LETTER BYELORUSSIAN-UKRAINIAN I
+0xF7 0x0457 # CYRILLIC SMALL LETTER YI
+0xF8 0x0458 # CYRILLIC SMALL LETTER JE
+0xF9 0x0459 # CYRILLIC SMALL LETTER LJE
+0xFA 0x045A # CYRILLIC SMALL LETTER NJE
+0xFB 0x045B # CYRILLIC SMALL LETTER TSHE
+0xFC 0x045C # CYRILLIC SMALL LETTER KJE
+0xFD 0x00A7 # SECTION SIGN
+0xFE 0x045E # CYRILLIC SMALL LETTER SHORT U
+0xFF 0x045F # CYRILLIC SMALL LETTER DZHE
--- /dev/null
+#
+# Name: ISO 8859-6:1999 to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 1999 July 27
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1991-1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-6:1999 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-6 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-6 order.
+#
+# Version history
+# 1.0 version updates 0.1 version by adding mappings for all
+# control characters.
+# 0x30..0x39 remapped to the ASCII digits (U+0030..U+0039) instead
+# of the Arabic digits (U+0660..U+0669).
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA4 0x00A4 # CURRENCY SIGN
+0xAC 0x060C # ARABIC COMMA
+0xAD 0x00AD # SOFT HYPHEN
+0xBB 0x061B # ARABIC SEMICOLON
+0xBF 0x061F # ARABIC QUESTION MARK
+0xC1 0x0621 # ARABIC LETTER HAMZA
+0xC2 0x0622 # ARABIC LETTER ALEF WITH MADDA ABOVE
+0xC3 0x0623 # ARABIC LETTER ALEF WITH HAMZA ABOVE
+0xC4 0x0624 # ARABIC LETTER WAW WITH HAMZA ABOVE
+0xC5 0x0625 # ARABIC LETTER ALEF WITH HAMZA BELOW
+0xC6 0x0626 # ARABIC LETTER YEH WITH HAMZA ABOVE
+0xC7 0x0627 # ARABIC LETTER ALEF
+0xC8 0x0628 # ARABIC LETTER BEH
+0xC9 0x0629 # ARABIC LETTER TEH MARBUTA
+0xCA 0x062A # ARABIC LETTER TEH
+0xCB 0x062B # ARABIC LETTER THEH
+0xCC 0x062C # ARABIC LETTER JEEM
+0xCD 0x062D # ARABIC LETTER HAH
+0xCE 0x062E # ARABIC LETTER KHAH
+0xCF 0x062F # ARABIC LETTER DAL
+0xD0 0x0630 # ARABIC LETTER THAL
+0xD1 0x0631 # ARABIC LETTER REH
+0xD2 0x0632 # ARABIC LETTER ZAIN
+0xD3 0x0633 # ARABIC LETTER SEEN
+0xD4 0x0634 # ARABIC LETTER SHEEN
+0xD5 0x0635 # ARABIC LETTER SAD
+0xD6 0x0636 # ARABIC LETTER DAD
+0xD7 0x0637 # ARABIC LETTER TAH
+0xD8 0x0638 # ARABIC LETTER ZAH
+0xD9 0x0639 # ARABIC LETTER AIN
+0xDA 0x063A # ARABIC LETTER GHAIN
+0xE0 0x0640 # ARABIC TATWEEL
+0xE1 0x0641 # ARABIC LETTER FEH
+0xE2 0x0642 # ARABIC LETTER QAF
+0xE3 0x0643 # ARABIC LETTER KAF
+0xE4 0x0644 # ARABIC LETTER LAM
+0xE5 0x0645 # ARABIC LETTER MEEM
+0xE6 0x0646 # ARABIC LETTER NOON
+0xE7 0x0647 # ARABIC LETTER HEH
+0xE8 0x0648 # ARABIC LETTER WAW
+0xE9 0x0649 # ARABIC LETTER ALEF MAKSURA
+0xEA 0x064A # ARABIC LETTER YEH
+0xEB 0x064B # ARABIC FATHATAN
+0xEC 0x064C # ARABIC DAMMATAN
+0xED 0x064D # ARABIC KASRATAN
+0xEE 0x064E # ARABIC FATHA
+0xEF 0x064F # ARABIC DAMMA
+0xF0 0x0650 # ARABIC KASRA
+0xF1 0x0651 # ARABIC SHADDA
+0xF2 0x0652 # ARABIC SUKUN
--- /dev/null
+#
+# Name: ISO 8859-7:2003 to Unicode
+# Unicode version: 4.0
+# Table version: 2.0
+# Table format: Format A
+# Date: 2003-Nov-12
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1991-2003 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO 8859-7:2003 characters map into Unicode.
+#
+# ISO 8859-7:1987 is equivalent to ISO-IR-126, ELOT 928,
+# and ECMA 118. ISO 8859-7:2003 adds two currency signs
+# and one other character not in the earlier standard.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO 8859-7 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO 8859-7 order.
+#
+# Version history
+# 1.0 version updates 0.1 version by adding mappings for all
+# control characters.
+# Remap 0xA1 to U+2018 (instead of 0x02BD) to match text of 8859-7
+# Remap 0xA2 to U+2019 (instead of 0x02BC) to match text of 8859-7
+#
+# 2.0 version updates 1.0 version by adding mappings for the
+# three newly added characters 0xA4, 0xA5, 0xAA.
+#
+# Updated versions of this file may be found in:
+# <http://www.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact the Unicode Consortium at:
+# <http://www.unicode.org/reporting.html>
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x2018 # LEFT SINGLE QUOTATION MARK
+0xA2 0x2019 # RIGHT SINGLE QUOTATION MARK
+0xA3 0x00A3 # POUND SIGN
+0xA4 0x20AC # EURO SIGN
+0xA5 0x20AF # DRACHMA SIGN
+0xA6 0x00A6 # BROKEN BAR
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x00A8 # DIAERESIS
+0xA9 0x00A9 # COPYRIGHT SIGN
+0xAA 0x037A # GREEK YPOGEGRAMMENI
+0xAB 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC # NOT SIGN
+0xAD 0x00AD # SOFT HYPHEN
+0xAF 0x2015 # HORIZONTAL BAR
+0xB0 0x00B0 # DEGREE SIGN
+0xB1 0x00B1 # PLUS-MINUS SIGN
+0xB2 0x00B2 # SUPERSCRIPT TWO
+0xB3 0x00B3 # SUPERSCRIPT THREE
+0xB4 0x0384 # GREEK TONOS
+0xB5 0x0385 # GREEK DIALYTIKA TONOS
+0xB6 0x0386 # GREEK CAPITAL LETTER ALPHA WITH TONOS
+0xB7 0x00B7 # MIDDLE DOT
+0xB8 0x0388 # GREEK CAPITAL LETTER EPSILON WITH TONOS
+0xB9 0x0389 # GREEK CAPITAL LETTER ETA WITH TONOS
+0xBA 0x038A # GREEK CAPITAL LETTER IOTA WITH TONOS
+0xBB 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x038C # GREEK CAPITAL LETTER OMICRON WITH TONOS
+0xBD 0x00BD # VULGAR FRACTION ONE HALF
+0xBE 0x038E # GREEK CAPITAL LETTER UPSILON WITH TONOS
+0xBF 0x038F # GREEK CAPITAL LETTER OMEGA WITH TONOS
+0xC0 0x0390 # GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
+0xC1 0x0391 # GREEK CAPITAL LETTER ALPHA
+0xC2 0x0392 # GREEK CAPITAL LETTER BETA
+0xC3 0x0393 # GREEK CAPITAL LETTER GAMMA
+0xC4 0x0394 # GREEK CAPITAL LETTER DELTA
+0xC5 0x0395 # GREEK CAPITAL LETTER EPSILON
+0xC6 0x0396 # GREEK CAPITAL LETTER ZETA
+0xC7 0x0397 # GREEK CAPITAL LETTER ETA
+0xC8 0x0398 # GREEK CAPITAL LETTER THETA
+0xC9 0x0399 # GREEK CAPITAL LETTER IOTA
+0xCA 0x039A # GREEK CAPITAL LETTER KAPPA
+0xCB 0x039B # GREEK CAPITAL LETTER LAMDA
+0xCC 0x039C # GREEK CAPITAL LETTER MU
+0xCD 0x039D # GREEK CAPITAL LETTER NU
+0xCE 0x039E # GREEK CAPITAL LETTER XI
+0xCF 0x039F # GREEK CAPITAL LETTER OMICRON
+0xD0 0x03A0 # GREEK CAPITAL LETTER PI
+0xD1 0x03A1 # GREEK CAPITAL LETTER RHO
+0xD3 0x03A3 # GREEK CAPITAL LETTER SIGMA
+0xD4 0x03A4 # GREEK CAPITAL LETTER TAU
+0xD5 0x03A5 # GREEK CAPITAL LETTER UPSILON
+0xD6 0x03A6 # GREEK CAPITAL LETTER PHI
+0xD7 0x03A7 # GREEK CAPITAL LETTER CHI
+0xD8 0x03A8 # GREEK CAPITAL LETTER PSI
+0xD9 0x03A9 # GREEK CAPITAL LETTER OMEGA
+0xDA 0x03AA # GREEK CAPITAL LETTER IOTA WITH DIALYTIKA
+0xDB 0x03AB # GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA
+0xDC 0x03AC # GREEK SMALL LETTER ALPHA WITH TONOS
+0xDD 0x03AD # GREEK SMALL LETTER EPSILON WITH TONOS
+0xDE 0x03AE # GREEK SMALL LETTER ETA WITH TONOS
+0xDF 0x03AF # GREEK SMALL LETTER IOTA WITH TONOS
+0xE0 0x03B0 # GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
+0xE1 0x03B1 # GREEK SMALL LETTER ALPHA
+0xE2 0x03B2 # GREEK SMALL LETTER BETA
+0xE3 0x03B3 # GREEK SMALL LETTER GAMMA
+0xE4 0x03B4 # GREEK SMALL LETTER DELTA
+0xE5 0x03B5 # GREEK SMALL LETTER EPSILON
+0xE6 0x03B6 # GREEK SMALL LETTER ZETA
+0xE7 0x03B7 # GREEK SMALL LETTER ETA
+0xE8 0x03B8 # GREEK SMALL LETTER THETA
+0xE9 0x03B9 # GREEK SMALL LETTER IOTA
+0xEA 0x03BA # GREEK SMALL LETTER KAPPA
+0xEB 0x03BB # GREEK SMALL LETTER LAMDA
+0xEC 0x03BC # GREEK SMALL LETTER MU
+0xED 0x03BD # GREEK SMALL LETTER NU
+0xEE 0x03BE # GREEK SMALL LETTER XI
+0xEF 0x03BF # GREEK SMALL LETTER OMICRON
+0xF0 0x03C0 # GREEK SMALL LETTER PI
+0xF1 0x03C1 # GREEK SMALL LETTER RHO
+0xF2 0x03C2 # GREEK SMALL LETTER FINAL SIGMA
+0xF3 0x03C3 # GREEK SMALL LETTER SIGMA
+0xF4 0x03C4 # GREEK SMALL LETTER TAU
+0xF5 0x03C5 # GREEK SMALL LETTER UPSILON
+0xF6 0x03C6 # GREEK SMALL LETTER PHI
+0xF7 0x03C7 # GREEK SMALL LETTER CHI
+0xF8 0x03C8 # GREEK SMALL LETTER PSI
+0xF9 0x03C9 # GREEK SMALL LETTER OMEGA
+0xFA 0x03CA # GREEK SMALL LETTER IOTA WITH DIALYTIKA
+0xFB 0x03CB # GREEK SMALL LETTER UPSILON WITH DIALYTIKA
+0xFC 0x03CC # GREEK SMALL LETTER OMICRON WITH TONOS
+0xFD 0x03CD # GREEK SMALL LETTER UPSILON WITH TONOS
+0xFE 0x03CE # GREEK SMALL LETTER OMEGA WITH TONOS
--- /dev/null
+#
+# Name: ISO/IEC 8859-8:1999 to Unicode
+# Unicode version: 3.0
+# Table version: 1.1
+# Table format: Format A
+# Date: 2000-Jan-03
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1991-1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-8:1999 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-8 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-8 order.
+#
+# Version history
+# 1.0 version updates 0.1 version by adding mappings for all
+# control characters.
+# 1.1 version updates to the published 8859-8:1999, correcting
+# the mapping of 0xAF and adding mappings for LRM and RLM.
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA2 0x00A2 # CENT SIGN
+0xA3 0x00A3 # POUND SIGN
+0xA4 0x00A4 # CURRENCY SIGN
+0xA5 0x00A5 # YEN SIGN
+0xA6 0x00A6 # BROKEN BAR
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x00A8 # DIAERESIS
+0xA9 0x00A9 # COPYRIGHT SIGN
+0xAA 0x00D7 # MULTIPLICATION SIGN
+0xAB 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC # NOT SIGN
+0xAD 0x00AD # SOFT HYPHEN
+0xAE 0x00AE # REGISTERED SIGN
+0xAF 0x00AF # MACRON
+0xB0 0x00B0 # DEGREE SIGN
+0xB1 0x00B1 # PLUS-MINUS SIGN
+0xB2 0x00B2 # SUPERSCRIPT TWO
+0xB3 0x00B3 # SUPERSCRIPT THREE
+0xB4 0x00B4 # ACUTE ACCENT
+0xB5 0x00B5 # MICRO SIGN
+0xB6 0x00B6 # PILCROW SIGN
+0xB7 0x00B7 # MIDDLE DOT
+0xB8 0x00B8 # CEDILLA
+0xB9 0x00B9 # SUPERSCRIPT ONE
+0xBA 0x00F7 # DIVISION SIGN
+0xBB 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x00BC # VULGAR FRACTION ONE QUARTER
+0xBD 0x00BD # VULGAR FRACTION ONE HALF
+0xBE 0x00BE # VULGAR FRACTION THREE QUARTERS
+0xDF 0x2017 # DOUBLE LOW LINE
+0xE0 0x05D0 # HEBREW LETTER ALEF
+0xE1 0x05D1 # HEBREW LETTER BET
+0xE2 0x05D2 # HEBREW LETTER GIMEL
+0xE3 0x05D3 # HEBREW LETTER DALET
+0xE4 0x05D4 # HEBREW LETTER HE
+0xE5 0x05D5 # HEBREW LETTER VAV
+0xE6 0x05D6 # HEBREW LETTER ZAYIN
+0xE7 0x05D7 # HEBREW LETTER HET
+0xE8 0x05D8 # HEBREW LETTER TET
+0xE9 0x05D9 # HEBREW LETTER YOD
+0xEA 0x05DA # HEBREW LETTER FINAL KAF
+0xEB 0x05DB # HEBREW LETTER KAF
+0xEC 0x05DC # HEBREW LETTER LAMED
+0xED 0x05DD # HEBREW LETTER FINAL MEM
+0xEE 0x05DE # HEBREW LETTER MEM
+0xEF 0x05DF # HEBREW LETTER FINAL NUN
+0xF0 0x05E0 # HEBREW LETTER NUN
+0xF1 0x05E1 # HEBREW LETTER SAMEKH
+0xF2 0x05E2 # HEBREW LETTER AYIN
+0xF3 0x05E3 # HEBREW LETTER FINAL PE
+0xF4 0x05E4 # HEBREW LETTER PE
+0xF5 0x05E5 # HEBREW LETTER FINAL TSADI
+0xF6 0x05E6 # HEBREW LETTER TSADI
+0xF7 0x05E7 # HEBREW LETTER QOF
+0xF8 0x05E8 # HEBREW LETTER RESH
+0xF9 0x05E9 # HEBREW LETTER SHIN
+0xFA 0x05EA # HEBREW LETTER TAV
+0xFD 0x200E # LEFT-TO-RIGHT MARK
+0xFE 0x200F # RIGHT-TO-LEFT MARK
+
--- /dev/null
+#
+# Name: ISO/IEC 8859-9:1999 to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 1999 July 27
+# Authors: Ken Whistler <kenw@sybase.com>
+#
+# Copyright (c) 1991-1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on magnetic media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# ISO/IEC 8859-9:1999 characters map into Unicode.
+#
+# Format: Three tab-separated columns
+# Column #1 is the ISO/IEC 8859-9 code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in ISO/IEC 8859-9 order.
+#
+# ISO/IEC 8859-9 is also equivalent to ISO-IR-148.
+#
+# Version history
+# 1.0 version updates 0.1 version by adding mappings for all
+# control characters.
+#
+# Updated versions of this file may be found in:
+# <ftp://ftp.unicode.org/Public/MAPPINGS/>
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x0080 # <control>
+0x81 0x0081 # <control>
+0x82 0x0082 # <control>
+0x83 0x0083 # <control>
+0x84 0x0084 # <control>
+0x85 0x0085 # <control>
+0x86 0x0086 # <control>
+0x87 0x0087 # <control>
+0x88 0x0088 # <control>
+0x89 0x0089 # <control>
+0x8A 0x008A # <control>
+0x8B 0x008B # <control>
+0x8C 0x008C # <control>
+0x8D 0x008D # <control>
+0x8E 0x008E # <control>
+0x8F 0x008F # <control>
+0x90 0x0090 # <control>
+0x91 0x0091 # <control>
+0x92 0x0092 # <control>
+0x93 0x0093 # <control>
+0x94 0x0094 # <control>
+0x95 0x0095 # <control>
+0x96 0x0096 # <control>
+0x97 0x0097 # <control>
+0x98 0x0098 # <control>
+0x99 0x0099 # <control>
+0x9A 0x009A # <control>
+0x9B 0x009B # <control>
+0x9C 0x009C # <control>
+0x9D 0x009D # <control>
+0x9E 0x009E # <control>
+0x9F 0x009F # <control>
+0xA0 0x00A0 # NO-BREAK SPACE
+0xA1 0x00A1 # INVERTED EXCLAMATION MARK
+0xA2 0x00A2 # CENT SIGN
+0xA3 0x00A3 # POUND SIGN
+0xA4 0x00A4 # CURRENCY SIGN
+0xA5 0x00A5 # YEN SIGN
+0xA6 0x00A6 # BROKEN BAR
+0xA7 0x00A7 # SECTION SIGN
+0xA8 0x00A8 # DIAERESIS
+0xA9 0x00A9 # COPYRIGHT SIGN
+0xAA 0x00AA # FEMININE ORDINAL INDICATOR
+0xAB 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC # NOT SIGN
+0xAD 0x00AD # SOFT HYPHEN
+0xAE 0x00AE # REGISTERED SIGN
+0xAF 0x00AF # MACRON
+0xB0 0x00B0 # DEGREE SIGN
+0xB1 0x00B1 # PLUS-MINUS SIGN
+0xB2 0x00B2 # SUPERSCRIPT TWO
+0xB3 0x00B3 # SUPERSCRIPT THREE
+0xB4 0x00B4 # ACUTE ACCENT
+0xB5 0x00B5 # MICRO SIGN
+0xB6 0x00B6 # PILCROW SIGN
+0xB7 0x00B7 # MIDDLE DOT
+0xB8 0x00B8 # CEDILLA
+0xB9 0x00B9 # SUPERSCRIPT ONE
+0xBA 0x00BA # MASCULINE ORDINAL INDICATOR
+0xBB 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x00BC # VULGAR FRACTION ONE QUARTER
+0xBD 0x00BD # VULGAR FRACTION ONE HALF
+0xBE 0x00BE # VULGAR FRACTION THREE QUARTERS
+0xBF 0x00BF # INVERTED QUESTION MARK
+0xC0 0x00C0 # LATIN CAPITAL LETTER A WITH GRAVE
+0xC1 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3 0x00C3 # LATIN CAPITAL LETTER A WITH TILDE
+0xC4 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE
+0xC6 0x00C6 # LATIN CAPITAL LETTER AE
+0xC7 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8 0x00C8 # LATIN CAPITAL LETTER E WITH GRAVE
+0xC9 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x00CA # LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+0xCB 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x00CC # LATIN CAPITAL LETTER I WITH GRAVE
+0xCD 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x00CF # LATIN CAPITAL LETTER I WITH DIAERESIS
+0xD0 0x011E # LATIN CAPITAL LETTER G WITH BREVE
+0xD1 0x00D1 # LATIN CAPITAL LETTER N WITH TILDE
+0xD2 0x00D2 # LATIN CAPITAL LETTER O WITH GRAVE
+0xD3 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x00D5 # LATIN CAPITAL LETTER O WITH TILDE
+0xD6 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 # MULTIPLICATION SIGN
+0xD8 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE
+0xD9 0x00D9 # LATIN CAPITAL LETTER U WITH GRAVE
+0xDA 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xDC 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x0130 # LATIN CAPITAL LETTER I WITH DOT ABOVE
+0xDE 0x015E # LATIN CAPITAL LETTER S WITH CEDILLA
+0xDF 0x00DF # LATIN SMALL LETTER SHARP S
+0xE0 0x00E0 # LATIN SMALL LETTER A WITH GRAVE
+0xE1 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x00E3 # LATIN SMALL LETTER A WITH TILDE
+0xE4 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE
+0xE6 0x00E6 # LATIN SMALL LETTER AE
+0xE7 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x00E8 # LATIN SMALL LETTER E WITH GRAVE
+0xE9 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x00EA # LATIN SMALL LETTER E WITH CIRCUMFLEX
+0xEB 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x00EC # LATIN SMALL LETTER I WITH GRAVE
+0xED 0x00ED # LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x00EF # LATIN SMALL LETTER I WITH DIAERESIS
+0xF0 0x011F # LATIN SMALL LETTER G WITH BREVE
+0xF1 0x00F1 # LATIN SMALL LETTER N WITH TILDE
+0xF2 0x00F2 # LATIN SMALL LETTER O WITH GRAVE
+0xF3 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x00F5 # LATIN SMALL LETTER O WITH TILDE
+0xF6 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 # DIVISION SIGN
+0xF8 0x00F8 # LATIN SMALL LETTER O WITH STROKE
+0xF9 0x00F9 # LATIN SMALL LETTER U WITH GRAVE
+0xFA 0x00FA # LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x0131 # LATIN SMALL LETTER DOTLESS I
+0xFE 0x015F # LATIN SMALL LETTER S WITH CEDILLA
+0xFF 0x00FF # LATIN SMALL LETTER Y WITH DIAERESIS
+
+
--- /dev/null
+#
+# Name: cp037_IBMUSCanada to Unicode table
+# Unicode version: 2.0
+# Table version: 2.00
+# Table format: Format A
+# Date: 04/24/96
+# Contact: Shawn.Steele@microsoft.com
+#
+# General notes: none
+#
+# Format: Three tab-separated columns
+# Column #1 is the cp037_IBMUSCanada code (in hex)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 is the Unicode name (follows a comment sign, '#')
+#
+# The entries are in cp037_IBMUSCanada order
+#
+0x00 0x0000 #NULL
+0x01 0x0001 #START OF HEADING
+0x02 0x0002 #START OF TEXT
+0x03 0x0003 #END OF TEXT
+0x04 0x009C #CONTROL
+0x05 0x0009 #HORIZONTAL TABULATION
+0x06 0x0086 #CONTROL
+0x07 0x007F #DELETE
+0x08 0x0097 #CONTROL
+0x09 0x008D #CONTROL
+0x0A 0x008E #CONTROL
+0x0B 0x000B #VERTICAL TABULATION
+0x0C 0x000C #FORM FEED
+0x0D 0x000D #CARRIAGE RETURN
+0x0E 0x000E #SHIFT OUT
+0x0F 0x000F #SHIFT IN
+0x10 0x0010 #DATA LINK ESCAPE
+0x11 0x0011 #DEVICE CONTROL ONE
+0x12 0x0012 #DEVICE CONTROL TWO
+0x13 0x0013 #DEVICE CONTROL THREE
+0x14 0x009D #CONTROL
+0x15 0x0085 #CONTROL
+0x16 0x0008 #BACKSPACE
+0x17 0x0087 #CONTROL
+0x18 0x0018 #CANCEL
+0x19 0x0019 #END OF MEDIUM
+0x1A 0x0092 #CONTROL
+0x1B 0x008F #CONTROL
+0x1C 0x001C #FILE SEPARATOR
+0x1D 0x001D #GROUP SEPARATOR
+0x1E 0x001E #RECORD SEPARATOR
+0x1F 0x001F #UNIT SEPARATOR
+0x20 0x0080 #CONTROL
+0x21 0x0081 #CONTROL
+0x22 0x0082 #CONTROL
+0x23 0x0083 #CONTROL
+0x24 0x0084 #CONTROL
+0x25 0x000A #LINE FEED
+0x26 0x0017 #END OF TRANSMISSION BLOCK
+0x27 0x001B #ESCAPE
+0x28 0x0088 #CONTROL
+0x29 0x0089 #CONTROL
+0x2A 0x008A #CONTROL
+0x2B 0x008B #CONTROL
+0x2C 0x008C #CONTROL
+0x2D 0x0005 #ENQUIRY
+0x2E 0x0006 #ACKNOWLEDGE
+0x2F 0x0007 #BELL
+0x30 0x0090 #CONTROL
+0x31 0x0091 #CONTROL
+0x32 0x0016 #SYNCHRONOUS IDLE
+0x33 0x0093 #CONTROL
+0x34 0x0094 #CONTROL
+0x35 0x0095 #CONTROL
+0x36 0x0096 #CONTROL
+0x37 0x0004 #END OF TRANSMISSION
+0x38 0x0098 #CONTROL
+0x39 0x0099 #CONTROL
+0x3A 0x009A #CONTROL
+0x3B 0x009B #CONTROL
+0x3C 0x0014 #DEVICE CONTROL FOUR
+0x3D 0x0015 #NEGATIVE ACKNOWLEDGE
+0x3E 0x009E #CONTROL
+0x3F 0x001A #SUBSTITUTE
+0x40 0x0020 #SPACE
+0x41 0x00A0 #NO-BREAK SPACE
+0x42 0x00E2 #LATIN SMALL LETTER A WITH CIRCUMFLEX
+0x43 0x00E4 #LATIN SMALL LETTER A WITH DIAERESIS
+0x44 0x00E0 #LATIN SMALL LETTER A WITH GRAVE
+0x45 0x00E1 #LATIN SMALL LETTER A WITH ACUTE
+0x46 0x00E3 #LATIN SMALL LETTER A WITH TILDE
+0x47 0x00E5 #LATIN SMALL LETTER A WITH RING ABOVE
+0x48 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA
+0x49 0x00F1 #LATIN SMALL LETTER N WITH TILDE
+0x4A 0x00A2 #CENT SIGN
+0x4B 0x002E #FULL STOP
+0x4C 0x003C #LESS-THAN SIGN
+0x4D 0x0028 #LEFT PARENTHESIS
+0x4E 0x002B #PLUS SIGN
+0x4F 0x007C #VERTICAL LINE
+0x50 0x0026 #AMPERSAND
+0x51 0x00E9 #LATIN SMALL LETTER E WITH ACUTE
+0x52 0x00EA #LATIN SMALL LETTER E WITH CIRCUMFLEX
+0x53 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS
+0x54 0x00E8 #LATIN SMALL LETTER E WITH GRAVE
+0x55 0x00ED #LATIN SMALL LETTER I WITH ACUTE
+0x56 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX
+0x57 0x00EF #LATIN SMALL LETTER I WITH DIAERESIS
+0x58 0x00EC #LATIN SMALL LETTER I WITH GRAVE
+0x59 0x00DF #LATIN SMALL LETTER SHARP S (GERMAN)
+0x5A 0x0021 #EXCLAMATION MARK
+0x5B 0x0024 #DOLLAR SIGN
+0x5C 0x002A #ASTERISK
+0x5D 0x0029 #RIGHT PARENTHESIS
+0x5E 0x003B #SEMICOLON
+0x5F 0x00AC #NOT SIGN
+0x60 0x002D #HYPHEN-MINUS
+0x61 0x002F #SOLIDUS
+0x62 0x00C2 #LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0x63 0x00C4 #LATIN CAPITAL LETTER A WITH DIAERESIS
+0x64 0x00C0 #LATIN CAPITAL LETTER A WITH GRAVE
+0x65 0x00C1 #LATIN CAPITAL LETTER A WITH ACUTE
+0x66 0x00C3 #LATIN CAPITAL LETTER A WITH TILDE
+0x67 0x00C5 #LATIN CAPITAL LETTER A WITH RING ABOVE
+0x68 0x00C7 #LATIN CAPITAL LETTER C WITH CEDILLA
+0x69 0x00D1 #LATIN CAPITAL LETTER N WITH TILDE
+0x6A 0x00A6 #BROKEN BAR
+0x6B 0x002C #COMMA
+0x6C 0x0025 #PERCENT SIGN
+0x6D 0x005F #LOW LINE
+0x6E 0x003E #GREATER-THAN SIGN
+0x6F 0x003F #QUESTION MARK
+0x70 0x00F8 #LATIN SMALL LETTER O WITH STROKE
+0x71 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE
+0x72 0x00CA #LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+0x73 0x00CB #LATIN CAPITAL LETTER E WITH DIAERESIS
+0x74 0x00C8 #LATIN CAPITAL LETTER E WITH GRAVE
+0x75 0x00CD #LATIN CAPITAL LETTER I WITH ACUTE
+0x76 0x00CE #LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0x77 0x00CF #LATIN CAPITAL LETTER I WITH DIAERESIS
+0x78 0x00CC #LATIN CAPITAL LETTER I WITH GRAVE
+0x79 0x0060 #GRAVE ACCENT
+0x7A 0x003A #COLON
+0x7B 0x0023 #NUMBER SIGN
+0x7C 0x0040 #COMMERCIAL AT
+0x7D 0x0027 #APOSTROPHE
+0x7E 0x003D #EQUALS SIGN
+0x7F 0x0022 #QUOTATION MARK
+0x80 0x00D8 #LATIN CAPITAL LETTER O WITH STROKE
+0x81 0x0061 #LATIN SMALL LETTER A
+0x82 0x0062 #LATIN SMALL LETTER B
+0x83 0x0063 #LATIN SMALL LETTER C
+0x84 0x0064 #LATIN SMALL LETTER D
+0x85 0x0065 #LATIN SMALL LETTER E
+0x86 0x0066 #LATIN SMALL LETTER F
+0x87 0x0067 #LATIN SMALL LETTER G
+0x88 0x0068 #LATIN SMALL LETTER H
+0x89 0x0069 #LATIN SMALL LETTER I
+0x8A 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0x8B 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0x8C 0x00F0 #LATIN SMALL LETTER ETH (ICELANDIC)
+0x8D 0x00FD #LATIN SMALL LETTER Y WITH ACUTE
+0x8E 0x00FE #LATIN SMALL LETTER THORN (ICELANDIC)
+0x8F 0x00B1 #PLUS-MINUS SIGN
+0x90 0x00B0 #DEGREE SIGN
+0x91 0x006A #LATIN SMALL LETTER J
+0x92 0x006B #LATIN SMALL LETTER K
+0x93 0x006C #LATIN SMALL LETTER L
+0x94 0x006D #LATIN SMALL LETTER M
+0x95 0x006E #LATIN SMALL LETTER N
+0x96 0x006F #LATIN SMALL LETTER O
+0x97 0x0070 #LATIN SMALL LETTER P
+0x98 0x0071 #LATIN SMALL LETTER Q
+0x99 0x0072 #LATIN SMALL LETTER R
+0x9A 0x00AA #FEMININE ORDINAL INDICATOR
+0x9B 0x00BA #MASCULINE ORDINAL INDICATOR
+0x9C 0x00E6 #LATIN SMALL LIGATURE AE
+0x9D 0x00B8 #CEDILLA
+0x9E 0x00C6 #LATIN CAPITAL LIGATURE AE
+0x9F 0x00A4 #CURRENCY SIGN
+0xA0 0x00B5 #MICRO SIGN
+0xA1 0x007E #TILDE
+0xA2 0x0073 #LATIN SMALL LETTER S
+0xA3 0x0074 #LATIN SMALL LETTER T
+0xA4 0x0075 #LATIN SMALL LETTER U
+0xA5 0x0076 #LATIN SMALL LETTER V
+0xA6 0x0077 #LATIN SMALL LETTER W
+0xA7 0x0078 #LATIN SMALL LETTER X
+0xA8 0x0079 #LATIN SMALL LETTER Y
+0xA9 0x007A #LATIN SMALL LETTER Z
+0xAA 0x00A1 #INVERTED EXCLAMATION MARK
+0xAB 0x00BF #INVERTED QUESTION MARK
+0xAC 0x00D0 #LATIN CAPITAL LETTER ETH (ICELANDIC)
+0xAD 0x00DD #LATIN CAPITAL LETTER Y WITH ACUTE
+0xAE 0x00DE #LATIN CAPITAL LETTER THORN (ICELANDIC)
+0xAF 0x00AE #REGISTERED SIGN
+0xB0 0x005E #CIRCUMFLEX ACCENT
+0xB1 0x00A3 #POUND SIGN
+0xB2 0x00A5 #YEN SIGN
+0xB3 0x00B7 #MIDDLE DOT
+0xB4 0x00A9 #COPYRIGHT SIGN
+0xB5 0x00A7 #SECTION SIGN
+0xB6 0x00B6 #PILCROW SIGN
+0xB7 0x00BC #VULGAR FRACTION ONE QUARTER
+0xB8 0x00BD #VULGAR FRACTION ONE HALF
+0xB9 0x00BE #VULGAR FRACTION THREE QUARTERS
+0xBA 0x005B #LEFT SQUARE BRACKET
+0xBB 0x005D #RIGHT SQUARE BRACKET
+0xBC 0x00AF #MACRON
+0xBD 0x00A8 #DIAERESIS
+0xBE 0x00B4 #ACUTE ACCENT
+0xBF 0x00D7 #MULTIPLICATION SIGN
+0xC0 0x007B #LEFT CURLY BRACKET
+0xC1 0x0041 #LATIN CAPITAL LETTER A
+0xC2 0x0042 #LATIN CAPITAL LETTER B
+0xC3 0x0043 #LATIN CAPITAL LETTER C
+0xC4 0x0044 #LATIN CAPITAL LETTER D
+0xC5 0x0045 #LATIN CAPITAL LETTER E
+0xC6 0x0046 #LATIN CAPITAL LETTER F
+0xC7 0x0047 #LATIN CAPITAL LETTER G
+0xC8 0x0048 #LATIN CAPITAL LETTER H
+0xC9 0x0049 #LATIN CAPITAL LETTER I
+0xCA 0x00AD #SOFT HYPHEN
+0xCB 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xCC 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS
+0xCD 0x00F2 #LATIN SMALL LETTER O WITH GRAVE
+0xCE 0x00F3 #LATIN SMALL LETTER O WITH ACUTE
+0xCF 0x00F5 #LATIN SMALL LETTER O WITH TILDE
+0xD0 0x007D #RIGHT CURLY BRACKET
+0xD1 0x004A #LATIN CAPITAL LETTER J
+0xD2 0x004B #LATIN CAPITAL LETTER K
+0xD3 0x004C #LATIN CAPITAL LETTER L
+0xD4 0x004D #LATIN CAPITAL LETTER M
+0xD5 0x004E #LATIN CAPITAL LETTER N
+0xD6 0x004F #LATIN CAPITAL LETTER O
+0xD7 0x0050 #LATIN CAPITAL LETTER P
+0xD8 0x0051 #LATIN CAPITAL LETTER Q
+0xD9 0x0052 #LATIN CAPITAL LETTER R
+0xDA 0x00B9 #SUPERSCRIPT ONE
+0xDB 0x00FB #LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xDC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS
+0xDD 0x00F9 #LATIN SMALL LETTER U WITH GRAVE
+0xDE 0x00FA #LATIN SMALL LETTER U WITH ACUTE
+0xDF 0x00FF #LATIN SMALL LETTER Y WITH DIAERESIS
+0xE0 0x005C #REVERSE SOLIDUS
+0xE1 0x00F7 #DIVISION SIGN
+0xE2 0x0053 #LATIN CAPITAL LETTER S
+0xE3 0x0054 #LATIN CAPITAL LETTER T
+0xE4 0x0055 #LATIN CAPITAL LETTER U
+0xE5 0x0056 #LATIN CAPITAL LETTER V
+0xE6 0x0057 #LATIN CAPITAL LETTER W
+0xE7 0x0058 #LATIN CAPITAL LETTER X
+0xE8 0x0059 #LATIN CAPITAL LETTER Y
+0xE9 0x005A #LATIN CAPITAL LETTER Z
+0xEA 0x00B2 #SUPERSCRIPT TWO
+0xEB 0x00D4 #LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xEC 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS
+0xED 0x00D2 #LATIN CAPITAL LETTER O WITH GRAVE
+0xEE 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE
+0xEF 0x00D5 #LATIN CAPITAL LETTER O WITH TILDE
+0xF0 0x0030 #DIGIT ZERO
+0xF1 0x0031 #DIGIT ONE
+0xF2 0x0032 #DIGIT TWO
+0xF3 0x0033 #DIGIT THREE
+0xF4 0x0034 #DIGIT FOUR
+0xF5 0x0035 #DIGIT FIVE
+0xF6 0x0036 #DIGIT SIX
+0xF7 0x0037 #DIGIT SEVEN
+0xF8 0x0038 #DIGIT EIGHT
+0xF9 0x0039 #DIGIT NINE
+0xFA 0x00B3 #SUPERSCRIPT THREE
+0xFB 0x00DB #LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xFC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS
+0xFD 0x00D9 #LATIN CAPITAL LETTER U WITH GRAVE
+0xFE 0x00DA #LATIN CAPITAL LETTER U WITH ACUTE
+0xFF 0x009F #CONTROL
--- /dev/null
+#
+# Name: cp1252 to Unicode table
+# Unicode version: 2.0
+# Table version: 2.01
+# Table format: Format A
+# Date: 04/15/98
+#
+# Contact: Shawn.Steele@microsoft.com
+#
+# General notes: none
+#
+# Format: Three tab-separated columns
+# Column #1 is the cp1252 code (in hex)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 is the Unicode name (follows a comment sign, '#')
+#
+# The entries are in cp1252 order
+#
+0x00 0x0000 #NULL
+0x01 0x0001 #START OF HEADING
+0x02 0x0002 #START OF TEXT
+0x03 0x0003 #END OF TEXT
+0x04 0x0004 #END OF TRANSMISSION
+0x05 0x0005 #ENQUIRY
+0x06 0x0006 #ACKNOWLEDGE
+0x07 0x0007 #BELL
+0x08 0x0008 #BACKSPACE
+0x09 0x0009 #HORIZONTAL TABULATION
+0x0A 0x000A #LINE FEED
+0x0B 0x000B #VERTICAL TABULATION
+0x0C 0x000C #FORM FEED
+0x0D 0x000D #CARRIAGE RETURN
+0x0E 0x000E #SHIFT OUT
+0x0F 0x000F #SHIFT IN
+0x10 0x0010 #DATA LINK ESCAPE
+0x11 0x0011 #DEVICE CONTROL ONE
+0x12 0x0012 #DEVICE CONTROL TWO
+0x13 0x0013 #DEVICE CONTROL THREE
+0x14 0x0014 #DEVICE CONTROL FOUR
+0x15 0x0015 #NEGATIVE ACKNOWLEDGE
+0x16 0x0016 #SYNCHRONOUS IDLE
+0x17 0x0017 #END OF TRANSMISSION BLOCK
+0x18 0x0018 #CANCEL
+0x19 0x0019 #END OF MEDIUM
+0x1A 0x001A #SUBSTITUTE
+0x1B 0x001B #ESCAPE
+0x1C 0x001C #FILE SEPARATOR
+0x1D 0x001D #GROUP SEPARATOR
+0x1E 0x001E #RECORD SEPARATOR
+0x1F 0x001F #UNIT SEPARATOR
+0x20 0x0020 #SPACE
+0x21 0x0021 #EXCLAMATION MARK
+0x22 0x0022 #QUOTATION MARK
+0x23 0x0023 #NUMBER SIGN
+0x24 0x0024 #DOLLAR SIGN
+0x25 0x0025 #PERCENT SIGN
+0x26 0x0026 #AMPERSAND
+0x27 0x0027 #APOSTROPHE
+0x28 0x0028 #LEFT PARENTHESIS
+0x29 0x0029 #RIGHT PARENTHESIS
+0x2A 0x002A #ASTERISK
+0x2B 0x002B #PLUS SIGN
+0x2C 0x002C #COMMA
+0x2D 0x002D #HYPHEN-MINUS
+0x2E 0x002E #FULL STOP
+0x2F 0x002F #SOLIDUS
+0x30 0x0030 #DIGIT ZERO
+0x31 0x0031 #DIGIT ONE
+0x32 0x0032 #DIGIT TWO
+0x33 0x0033 #DIGIT THREE
+0x34 0x0034 #DIGIT FOUR
+0x35 0x0035 #DIGIT FIVE
+0x36 0x0036 #DIGIT SIX
+0x37 0x0037 #DIGIT SEVEN
+0x38 0x0038 #DIGIT EIGHT
+0x39 0x0039 #DIGIT NINE
+0x3A 0x003A #COLON
+0x3B 0x003B #SEMICOLON
+0x3C 0x003C #LESS-THAN SIGN
+0x3D 0x003D #EQUALS SIGN
+0x3E 0x003E #GREATER-THAN SIGN
+0x3F 0x003F #QUESTION MARK
+0x40 0x0040 #COMMERCIAL AT
+0x41 0x0041 #LATIN CAPITAL LETTER A
+0x42 0x0042 #LATIN CAPITAL LETTER B
+0x43 0x0043 #LATIN CAPITAL LETTER C
+0x44 0x0044 #LATIN CAPITAL LETTER D
+0x45 0x0045 #LATIN CAPITAL LETTER E
+0x46 0x0046 #LATIN CAPITAL LETTER F
+0x47 0x0047 #LATIN CAPITAL LETTER G
+0x48 0x0048 #LATIN CAPITAL LETTER H
+0x49 0x0049 #LATIN CAPITAL LETTER I
+0x4A 0x004A #LATIN CAPITAL LETTER J
+0x4B 0x004B #LATIN CAPITAL LETTER K
+0x4C 0x004C #LATIN CAPITAL LETTER L
+0x4D 0x004D #LATIN CAPITAL LETTER M
+0x4E 0x004E #LATIN CAPITAL LETTER N
+0x4F 0x004F #LATIN CAPITAL LETTER O
+0x50 0x0050 #LATIN CAPITAL LETTER P
+0x51 0x0051 #LATIN CAPITAL LETTER Q
+0x52 0x0052 #LATIN CAPITAL LETTER R
+0x53 0x0053 #LATIN CAPITAL LETTER S
+0x54 0x0054 #LATIN CAPITAL LETTER T
+0x55 0x0055 #LATIN CAPITAL LETTER U
+0x56 0x0056 #LATIN CAPITAL LETTER V
+0x57 0x0057 #LATIN CAPITAL LETTER W
+0x58 0x0058 #LATIN CAPITAL LETTER X
+0x59 0x0059 #LATIN CAPITAL LETTER Y
+0x5A 0x005A #LATIN CAPITAL LETTER Z
+0x5B 0x005B #LEFT SQUARE BRACKET
+0x5C 0x005C #REVERSE SOLIDUS
+0x5D 0x005D #RIGHT SQUARE BRACKET
+0x5E 0x005E #CIRCUMFLEX ACCENT
+0x5F 0x005F #LOW LINE
+0x60 0x0060 #GRAVE ACCENT
+0x61 0x0061 #LATIN SMALL LETTER A
+0x62 0x0062 #LATIN SMALL LETTER B
+0x63 0x0063 #LATIN SMALL LETTER C
+0x64 0x0064 #LATIN SMALL LETTER D
+0x65 0x0065 #LATIN SMALL LETTER E
+0x66 0x0066 #LATIN SMALL LETTER F
+0x67 0x0067 #LATIN SMALL LETTER G
+0x68 0x0068 #LATIN SMALL LETTER H
+0x69 0x0069 #LATIN SMALL LETTER I
+0x6A 0x006A #LATIN SMALL LETTER J
+0x6B 0x006B #LATIN SMALL LETTER K
+0x6C 0x006C #LATIN SMALL LETTER L
+0x6D 0x006D #LATIN SMALL LETTER M
+0x6E 0x006E #LATIN SMALL LETTER N
+0x6F 0x006F #LATIN SMALL LETTER O
+0x70 0x0070 #LATIN SMALL LETTER P
+0x71 0x0071 #LATIN SMALL LETTER Q
+0x72 0x0072 #LATIN SMALL LETTER R
+0x73 0x0073 #LATIN SMALL LETTER S
+0x74 0x0074 #LATIN SMALL LETTER T
+0x75 0x0075 #LATIN SMALL LETTER U
+0x76 0x0076 #LATIN SMALL LETTER V
+0x77 0x0077 #LATIN SMALL LETTER W
+0x78 0x0078 #LATIN SMALL LETTER X
+0x79 0x0079 #LATIN SMALL LETTER Y
+0x7A 0x007A #LATIN SMALL LETTER Z
+0x7B 0x007B #LEFT CURLY BRACKET
+0x7C 0x007C #VERTICAL LINE
+0x7D 0x007D #RIGHT CURLY BRACKET
+0x7E 0x007E #TILDE
+0x7F 0x007F #DELETE
+0x80 0x20AC #EURO SIGN
+0x81 #UNDEFINED
+0x82 0x201A #SINGLE LOW-9 QUOTATION MARK
+0x83 0x0192 #LATIN SMALL LETTER F WITH HOOK
+0x84 0x201E #DOUBLE LOW-9 QUOTATION MARK
+0x85 0x2026 #HORIZONTAL ELLIPSIS
+0x86 0x2020 #DAGGER
+0x87 0x2021 #DOUBLE DAGGER
+0x88 0x02C6 #MODIFIER LETTER CIRCUMFLEX ACCENT
+0x89 0x2030 #PER MILLE SIGN
+0x8A 0x0160 #LATIN CAPITAL LETTER S WITH CARON
+0x8B 0x2039 #SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+0x8C 0x0152 #LATIN CAPITAL LIGATURE OE
+0x8D #UNDEFINED
+0x8E 0x017D #LATIN CAPITAL LETTER Z WITH CARON
+0x8F #UNDEFINED
+0x90 #UNDEFINED
+0x91 0x2018 #LEFT SINGLE QUOTATION MARK
+0x92 0x2019 #RIGHT SINGLE QUOTATION MARK
+0x93 0x201C #LEFT DOUBLE QUOTATION MARK
+0x94 0x201D #RIGHT DOUBLE QUOTATION MARK
+0x95 0x2022 #BULLET
+0x96 0x2013 #EN DASH
+0x97 0x2014 #EM DASH
+0x98 0x02DC #SMALL TILDE
+0x99 0x2122 #TRADE MARK SIGN
+0x9A 0x0161 #LATIN SMALL LETTER S WITH CARON
+0x9B 0x203A #SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+0x9C 0x0153 #LATIN SMALL LIGATURE OE
+0x9D #UNDEFINED
+0x9E 0x017E #LATIN SMALL LETTER Z WITH CARON
+0x9F 0x0178 #LATIN CAPITAL LETTER Y WITH DIAERESIS
+0xA0 0x00A0 #NO-BREAK SPACE
+0xA1 0x00A1 #INVERTED EXCLAMATION MARK
+0xA2 0x00A2 #CENT SIGN
+0xA3 0x00A3 #POUND SIGN
+0xA4 0x00A4 #CURRENCY SIGN
+0xA5 0x00A5 #YEN SIGN
+0xA6 0x00A6 #BROKEN BAR
+0xA7 0x00A7 #SECTION SIGN
+0xA8 0x00A8 #DIAERESIS
+0xA9 0x00A9 #COPYRIGHT SIGN
+0xAA 0x00AA #FEMININE ORDINAL INDICATOR
+0xAB 0x00AB #LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xAC 0x00AC #NOT SIGN
+0xAD 0x00AD #SOFT HYPHEN
+0xAE 0x00AE #REGISTERED SIGN
+0xAF 0x00AF #MACRON
+0xB0 0x00B0 #DEGREE SIGN
+0xB1 0x00B1 #PLUS-MINUS SIGN
+0xB2 0x00B2 #SUPERSCRIPT TWO
+0xB3 0x00B3 #SUPERSCRIPT THREE
+0xB4 0x00B4 #ACUTE ACCENT
+0xB5 0x00B5 #MICRO SIGN
+0xB6 0x00B6 #PILCROW SIGN
+0xB7 0x00B7 #MIDDLE DOT
+0xB8 0x00B8 #CEDILLA
+0xB9 0x00B9 #SUPERSCRIPT ONE
+0xBA 0x00BA #MASCULINE ORDINAL INDICATOR
+0xBB 0x00BB #RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xBC 0x00BC #VULGAR FRACTION ONE QUARTER
+0xBD 0x00BD #VULGAR FRACTION ONE HALF
+0xBE 0x00BE #VULGAR FRACTION THREE QUARTERS
+0xBF 0x00BF #INVERTED QUESTION MARK
+0xC0 0x00C0 #LATIN CAPITAL LETTER A WITH GRAVE
+0xC1 0x00C1 #LATIN CAPITAL LETTER A WITH ACUTE
+0xC2 0x00C2 #LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xC3 0x00C3 #LATIN CAPITAL LETTER A WITH TILDE
+0xC4 0x00C4 #LATIN CAPITAL LETTER A WITH DIAERESIS
+0xC5 0x00C5 #LATIN CAPITAL LETTER A WITH RING ABOVE
+0xC6 0x00C6 #LATIN CAPITAL LETTER AE
+0xC7 0x00C7 #LATIN CAPITAL LETTER C WITH CEDILLA
+0xC8 0x00C8 #LATIN CAPITAL LETTER E WITH GRAVE
+0xC9 0x00C9 #LATIN CAPITAL LETTER E WITH ACUTE
+0xCA 0x00CA #LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+0xCB 0x00CB #LATIN CAPITAL LETTER E WITH DIAERESIS
+0xCC 0x00CC #LATIN CAPITAL LETTER I WITH GRAVE
+0xCD 0x00CD #LATIN CAPITAL LETTER I WITH ACUTE
+0xCE 0x00CE #LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xCF 0x00CF #LATIN CAPITAL LETTER I WITH DIAERESIS
+0xD0 0x00D0 #LATIN CAPITAL LETTER ETH
+0xD1 0x00D1 #LATIN CAPITAL LETTER N WITH TILDE
+0xD2 0x00D2 #LATIN CAPITAL LETTER O WITH GRAVE
+0xD3 0x00D3 #LATIN CAPITAL LETTER O WITH ACUTE
+0xD4 0x00D4 #LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xD5 0x00D5 #LATIN CAPITAL LETTER O WITH TILDE
+0xD6 0x00D6 #LATIN CAPITAL LETTER O WITH DIAERESIS
+0xD7 0x00D7 #MULTIPLICATION SIGN
+0xD8 0x00D8 #LATIN CAPITAL LETTER O WITH STROKE
+0xD9 0x00D9 #LATIN CAPITAL LETTER U WITH GRAVE
+0xDA 0x00DA #LATIN CAPITAL LETTER U WITH ACUTE
+0xDB 0x00DB #LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xDC 0x00DC #LATIN CAPITAL LETTER U WITH DIAERESIS
+0xDD 0x00DD #LATIN CAPITAL LETTER Y WITH ACUTE
+0xDE 0x00DE #LATIN CAPITAL LETTER THORN
+0xDF 0x00DF #LATIN SMALL LETTER SHARP S
+0xE0 0x00E0 #LATIN SMALL LETTER A WITH GRAVE
+0xE1 0x00E1 #LATIN SMALL LETTER A WITH ACUTE
+0xE2 0x00E2 #LATIN SMALL LETTER A WITH CIRCUMFLEX
+0xE3 0x00E3 #LATIN SMALL LETTER A WITH TILDE
+0xE4 0x00E4 #LATIN SMALL LETTER A WITH DIAERESIS
+0xE5 0x00E5 #LATIN SMALL LETTER A WITH RING ABOVE
+0xE6 0x00E6 #LATIN SMALL LETTER AE
+0xE7 0x00E7 #LATIN SMALL LETTER C WITH CEDILLA
+0xE8 0x00E8 #LATIN SMALL LETTER E WITH GRAVE
+0xE9 0x00E9 #LATIN SMALL LETTER E WITH ACUTE
+0xEA 0x00EA #LATIN SMALL LETTER E WITH CIRCUMFLEX
+0xEB 0x00EB #LATIN SMALL LETTER E WITH DIAERESIS
+0xEC 0x00EC #LATIN SMALL LETTER I WITH GRAVE
+0xED 0x00ED #LATIN SMALL LETTER I WITH ACUTE
+0xEE 0x00EE #LATIN SMALL LETTER I WITH CIRCUMFLEX
+0xEF 0x00EF #LATIN SMALL LETTER I WITH DIAERESIS
+0xF0 0x00F0 #LATIN SMALL LETTER ETH
+0xF1 0x00F1 #LATIN SMALL LETTER N WITH TILDE
+0xF2 0x00F2 #LATIN SMALL LETTER O WITH GRAVE
+0xF3 0x00F3 #LATIN SMALL LETTER O WITH ACUTE
+0xF4 0x00F4 #LATIN SMALL LETTER O WITH CIRCUMFLEX
+0xF5 0x00F5 #LATIN SMALL LETTER O WITH TILDE
+0xF6 0x00F6 #LATIN SMALL LETTER O WITH DIAERESIS
+0xF7 0x00F7 #DIVISION SIGN
+0xF8 0x00F8 #LATIN SMALL LETTER O WITH STROKE
+0xF9 0x00F9 #LATIN SMALL LETTER U WITH GRAVE
+0xFA 0x00FA #LATIN SMALL LETTER U WITH ACUTE
+0xFB 0x00FB #LATIN SMALL LETTER U WITH CIRCUMFLEX
+0xFC 0x00FC #LATIN SMALL LETTER U WITH DIAERESIS
+0xFD 0x00FD #LATIN SMALL LETTER Y WITH ACUTE
+0xFE 0x00FE #LATIN SMALL LETTER THORN
+0xFF 0x00FF #LATIN SMALL LETTER Y WITH DIAERESIS
--- /dev/null
+#
+# Name: KOI8-R (RFC1489) to Unicode
+# Unicode version: 3.0
+# Table version: 1.0
+# Table format: Format A
+# Date: 18 August 1999
+# Authors: Helmut Richter <richter@lrz.de>
+#
+# Copyright (c) 1991-1999 Unicode, Inc. All Rights reserved.
+#
+# This file is provided as-is by Unicode, Inc. (The Unicode Consortium).
+# 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 applicability of information provided. If this
+# file has been provided on optical media by Unicode, Inc., the sole
+# remedy for any claim will be exchange of defective media within 90
+# days of receipt.
+#
+# 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 for
+# internal or external distribution as long as this notice remains
+# attached.
+#
+# General notes:
+#
+# This table contains the data the Unicode Consortium has on how
+# KOI8-R characters map into Unicode. The underlying document is the
+# mapping described in RFC 1489. No statements are made as to whether
+# this mapping is the same as the mapping defined as "Code Page 878"
+# with some vendors.
+#
+# Format: Three tab-separated columns
+# Column #1 is the KOI8-R code (in hex as 0xXX)
+# Column #2 is the Unicode (in hex as 0xXXXX)
+# Column #3 the Unicode name (follows a comment sign, '#')
+#
+# The entries are in KOI8-R order.
+#
+# Version history
+# 1.0 version: created.
+#
+# Any comments or problems, contact <errata@unicode.org>
+# Please note that <errata@unicode.org> is an archival address;
+# notices will be checked, but do not expect an immediate response.
+#
+0x00 0x0000 # NULL
+0x01 0x0001 # START OF HEADING
+0x02 0x0002 # START OF TEXT
+0x03 0x0003 # END OF TEXT
+0x04 0x0004 # END OF TRANSMISSION
+0x05 0x0005 # ENQUIRY
+0x06 0x0006 # ACKNOWLEDGE
+0x07 0x0007 # BELL
+0x08 0x0008 # BACKSPACE
+0x09 0x0009 # HORIZONTAL TABULATION
+0x0A 0x000A # LINE FEED
+0x0B 0x000B # VERTICAL TABULATION
+0x0C 0x000C # FORM FEED
+0x0D 0x000D # CARRIAGE RETURN
+0x0E 0x000E # SHIFT OUT
+0x0F 0x000F # SHIFT IN
+0x10 0x0010 # DATA LINK ESCAPE
+0x11 0x0011 # DEVICE CONTROL ONE
+0x12 0x0012 # DEVICE CONTROL TWO
+0x13 0x0013 # DEVICE CONTROL THREE
+0x14 0x0014 # DEVICE CONTROL FOUR
+0x15 0x0015 # NEGATIVE ACKNOWLEDGE
+0x16 0x0016 # SYNCHRONOUS IDLE
+0x17 0x0017 # END OF TRANSMISSION BLOCK
+0x18 0x0018 # CANCEL
+0x19 0x0019 # END OF MEDIUM
+0x1A 0x001A # SUBSTITUTE
+0x1B 0x001B # ESCAPE
+0x1C 0x001C # FILE SEPARATOR
+0x1D 0x001D # GROUP SEPARATOR
+0x1E 0x001E # RECORD SEPARATOR
+0x1F 0x001F # UNIT SEPARATOR
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+0x7F 0x007F # DELETE
+0x80 0x2500 # BOX DRAWINGS LIGHT HORIZONTAL
+0x81 0x2502 # BOX DRAWINGS LIGHT VERTICAL
+0x82 0x250C # BOX DRAWINGS LIGHT DOWN AND RIGHT
+0x83 0x2510 # BOX DRAWINGS LIGHT DOWN AND LEFT
+0x84 0x2514 # BOX DRAWINGS LIGHT UP AND RIGHT
+0x85 0x2518 # BOX DRAWINGS LIGHT UP AND LEFT
+0x86 0x251C # BOX DRAWINGS LIGHT VERTICAL AND RIGHT
+0x87 0x2524 # BOX DRAWINGS LIGHT VERTICAL AND LEFT
+0x88 0x252C # BOX DRAWINGS LIGHT DOWN AND HORIZONTAL
+0x89 0x2534 # BOX DRAWINGS LIGHT UP AND HORIZONTAL
+0x8A 0x253C # BOX DRAWINGS LIGHT VERTICAL AND HORIZONTAL
+0x8B 0x2580 # UPPER HALF BLOCK
+0x8C 0x2584 # LOWER HALF BLOCK
+0x8D 0x2588 # FULL BLOCK
+0x8E 0x258C # LEFT HALF BLOCK
+0x8F 0x2590 # RIGHT HALF BLOCK
+0x90 0x2591 # LIGHT SHADE
+0x91 0x2592 # MEDIUM SHADE
+0x92 0x2593 # DARK SHADE
+0x93 0x2320 # TOP HALF INTEGRAL
+0x94 0x25A0 # BLACK SQUARE
+0x95 0x2219 # BULLET OPERATOR
+0x96 0x221A # SQUARE ROOT
+0x97 0x2248 # ALMOST EQUAL TO
+0x98 0x2264 # LESS-THAN OR EQUAL TO
+0x99 0x2265 # GREATER-THAN OR EQUAL TO
+0x9A 0x00A0 # NO-BREAK SPACE
+0x9B 0x2321 # BOTTOM HALF INTEGRAL
+0x9C 0x00B0 # DEGREE SIGN
+0x9D 0x00B2 # SUPERSCRIPT TWO
+0x9E 0x00B7 # MIDDLE DOT
+0x9F 0x00F7 # DIVISION SIGN
+0xA0 0x2550 # BOX DRAWINGS DOUBLE HORIZONTAL
+0xA1 0x2551 # BOX DRAWINGS DOUBLE VERTICAL
+0xA2 0x2552 # BOX DRAWINGS DOWN SINGLE AND RIGHT DOUBLE
+0xA3 0x0451 # CYRILLIC SMALL LETTER IO
+0xA4 0x2553 # BOX DRAWINGS DOWN DOUBLE AND RIGHT SINGLE
+0xA5 0x2554 # BOX DRAWINGS DOUBLE DOWN AND RIGHT
+0xA6 0x2555 # BOX DRAWINGS DOWN SINGLE AND LEFT DOUBLE
+0xA7 0x2556 # BOX DRAWINGS DOWN DOUBLE AND LEFT SINGLE
+0xA8 0x2557 # BOX DRAWINGS DOUBLE DOWN AND LEFT
+0xA9 0x2558 # BOX DRAWINGS UP SINGLE AND RIGHT DOUBLE
+0xAA 0x2559 # BOX DRAWINGS UP DOUBLE AND RIGHT SINGLE
+0xAB 0x255A # BOX DRAWINGS DOUBLE UP AND RIGHT
+0xAC 0x255B # BOX DRAWINGS UP SINGLE AND LEFT DOUBLE
+0xAD 0x255C # BOX DRAWINGS UP DOUBLE AND LEFT SINGLE
+0xAE 0x255D # BOX DRAWINGS DOUBLE UP AND LEFT
+0xAF 0x255E # BOX DRAWINGS VERTICAL SINGLE AND RIGHT DOUBLE
+0xB0 0x255F # BOX DRAWINGS VERTICAL DOUBLE AND RIGHT SINGLE
+0xB1 0x2560 # BOX DRAWINGS DOUBLE VERTICAL AND RIGHT
+0xB2 0x2561 # BOX DRAWINGS VERTICAL SINGLE AND LEFT DOUBLE
+0xB3 0x0401 # CYRILLIC CAPITAL LETTER IO
+0xB4 0x2562 # BOX DRAWINGS VERTICAL DOUBLE AND LEFT SINGLE
+0xB5 0x2563 # BOX DRAWINGS DOUBLE VERTICAL AND LEFT
+0xB6 0x2564 # BOX DRAWINGS DOWN SINGLE AND HORIZONTAL DOUBLE
+0xB7 0x2565 # BOX DRAWINGS DOWN DOUBLE AND HORIZONTAL SINGLE
+0xB8 0x2566 # BOX DRAWINGS DOUBLE DOWN AND HORIZONTAL
+0xB9 0x2567 # BOX DRAWINGS UP SINGLE AND HORIZONTAL DOUBLE
+0xBA 0x2568 # BOX DRAWINGS UP DOUBLE AND HORIZONTAL SINGLE
+0xBB 0x2569 # BOX DRAWINGS DOUBLE UP AND HORIZONTAL
+0xBC 0x256A # BOX DRAWINGS VERTICAL SINGLE AND HORIZONTAL DOUBLE
+0xBD 0x256B # BOX DRAWINGS VERTICAL DOUBLE AND HORIZONTAL SINGLE
+0xBE 0x256C # BOX DRAWINGS DOUBLE VERTICAL AND HORIZONTAL
+0xBF 0x00A9 # COPYRIGHT SIGN
+0xC0 0x044E # CYRILLIC SMALL LETTER YU
+0xC1 0x0430 # CYRILLIC SMALL LETTER A
+0xC2 0x0431 # CYRILLIC SMALL LETTER BE
+0xC3 0x0446 # CYRILLIC SMALL LETTER TSE
+0xC4 0x0434 # CYRILLIC SMALL LETTER DE
+0xC5 0x0435 # CYRILLIC SMALL LETTER IE
+0xC6 0x0444 # CYRILLIC SMALL LETTER EF
+0xC7 0x0433 # CYRILLIC SMALL LETTER GHE
+0xC8 0x0445 # CYRILLIC SMALL LETTER HA
+0xC9 0x0438 # CYRILLIC SMALL LETTER I
+0xCA 0x0439 # CYRILLIC SMALL LETTER SHORT I
+0xCB 0x043A # CYRILLIC SMALL LETTER KA
+0xCC 0x043B # CYRILLIC SMALL LETTER EL
+0xCD 0x043C # CYRILLIC SMALL LETTER EM
+0xCE 0x043D # CYRILLIC SMALL LETTER EN
+0xCF 0x043E # CYRILLIC SMALL LETTER O
+0xD0 0x043F # CYRILLIC SMALL LETTER PE
+0xD1 0x044F # CYRILLIC SMALL LETTER YA
+0xD2 0x0440 # CYRILLIC SMALL LETTER ER
+0xD3 0x0441 # CYRILLIC SMALL LETTER ES
+0xD4 0x0442 # CYRILLIC SMALL LETTER TE
+0xD5 0x0443 # CYRILLIC SMALL LETTER U
+0xD6 0x0436 # CYRILLIC SMALL LETTER ZHE
+0xD7 0x0432 # CYRILLIC SMALL LETTER VE
+0xD8 0x044C # CYRILLIC SMALL LETTER SOFT SIGN
+0xD9 0x044B # CYRILLIC SMALL LETTER YERU
+0xDA 0x0437 # CYRILLIC SMALL LETTER ZE
+0xDB 0x0448 # CYRILLIC SMALL LETTER SHA
+0xDC 0x044D # CYRILLIC SMALL LETTER E
+0xDD 0x0449 # CYRILLIC SMALL LETTER SHCHA
+0xDE 0x0447 # CYRILLIC SMALL LETTER CHE
+0xDF 0x044A # CYRILLIC SMALL LETTER HARD SIGN
+0xE0 0x042E # CYRILLIC CAPITAL LETTER YU
+0xE1 0x0410 # CYRILLIC CAPITAL LETTER A
+0xE2 0x0411 # CYRILLIC CAPITAL LETTER BE
+0xE3 0x0426 # CYRILLIC CAPITAL LETTER TSE
+0xE4 0x0414 # CYRILLIC CAPITAL LETTER DE
+0xE5 0x0415 # CYRILLIC CAPITAL LETTER IE
+0xE6 0x0424 # CYRILLIC CAPITAL LETTER EF
+0xE7 0x0413 # CYRILLIC CAPITAL LETTER GHE
+0xE8 0x0425 # CYRILLIC CAPITAL LETTER HA
+0xE9 0x0418 # CYRILLIC CAPITAL LETTER I
+0xEA 0x0419 # CYRILLIC CAPITAL LETTER SHORT I
+0xEB 0x041A # CYRILLIC CAPITAL LETTER KA
+0xEC 0x041B # CYRILLIC CAPITAL LETTER EL
+0xED 0x041C # CYRILLIC CAPITAL LETTER EM
+0xEE 0x041D # CYRILLIC CAPITAL LETTER EN
+0xEF 0x041E # CYRILLIC CAPITAL LETTER O
+0xF0 0x041F # CYRILLIC CAPITAL LETTER PE
+0xF1 0x042F # CYRILLIC CAPITAL LETTER YA
+0xF2 0x0420 # CYRILLIC CAPITAL LETTER ER
+0xF3 0x0421 # CYRILLIC CAPITAL LETTER ES
+0xF4 0x0422 # CYRILLIC CAPITAL LETTER TE
+0xF5 0x0423 # CYRILLIC CAPITAL LETTER U
+0xF6 0x0416 # CYRILLIC CAPITAL LETTER ZHE
+0xF7 0x0412 # CYRILLIC CAPITAL LETTER VE
+0xF8 0x042C # CYRILLIC CAPITAL LETTER SOFT SIGN
+0xF9 0x042B # CYRILLIC CAPITAL LETTER YERU
+0xFA 0x0417 # CYRILLIC CAPITAL LETTER ZE
+0xFB 0x0428 # CYRILLIC CAPITAL LETTER SHA
+0xFC 0x042D # CYRILLIC CAPITAL LETTER E
+0xFD 0x0429 # CYRILLIC CAPITAL LETTER SHCHA
+0xFE 0x0427 # CYRILLIC CAPITAL LETTER CHE
+0xFF 0x042A # CYRILLIC CAPITAL LETTER HARD SIGN
--- /dev/null
+#=======================================================================
+# File name: ROMAN.TXT
+#
+# Contents: Map (external version) from Mac OS Roman
+# character set to Unicode 2.1 and later.
+#
+# Copyright: (c) 1994-2002, 2005 by Apple Computer, Inc., all rights
+# reserved.
+#
+# Contact: charsets@apple.com
+#
+# Changes:
+#
+# c02 2005-Apr-05 Update header comments. Matches internal xml
+# <c1.1> and Text Encoding Converter 2.0.
+# b4,c1 2002-Dec-19 Update URLs, notes. Matches internal
+# utom<b5>.
+# b03 1999-Sep-22 Update contact e-mail address. Matches
+# internal utom<b4>, ufrm<b3>, and Text
+# Encoding Converter version 1.5.
+# b02 1998-Aug-18 Encoding changed for Mac OS 8.5; change
+# mapping of 0xDB from CURRENCY SIGN to
+# EURO SIGN. Matches internal utom<b3>,
+# ufrm<b3>.
+# n08 1998-Feb-05 Minor update to header comments
+# n06 1997-Dec-14 Add warning about future changes to 0xDB
+# from CURRENCY SIGN to EURO SIGN. Clarify
+# some header information
+# n04 1997-Dec-01 Update to match internal utom<n3>, ufrm<n22>:
+# Change standard mapping for 0xBD from U+2126
+# to its canonical decomposition, U+03A9.
+# n03 1995-Apr-15 First version (after fixing some typos).
+# Matches internal ufrm<n9>.
+#
+# Standard header:
+# ----------------
+#
+# Apple, the Apple logo, and Macintosh are trademarks of Apple
+# Computer, Inc., registered in the United States and other countries.
+# Unicode is a trademark of Unicode Inc. For the sake of brevity,
+# throughout this document, "Macintosh" can be used to refer to
+# Macintosh computers and "Unicode" can be used to refer to the
+# Unicode standard.
+#
+# Apple Computer, Inc. ("Apple") makes no warranty or representation,
+# either express or implied, with respect to this document and the
+# included data, its quality, accuracy, or fitness for a particular
+# purpose. In no event will Apple be liable for direct, indirect,
+# special, incidental, or consequential damages resulting from any
+# defect or inaccuracy in this document or the included data.
+#
+# These mapping tables and character lists are subject to change.
+# The latest tables should be available from the following:
+#
+# <http://www.unicode.org/Public/MAPPINGS/VENDORS/APPLE/>
+#
+# For general information about Mac OS encodings and these mapping
+# tables, see the file "README.TXT".
+#
+# Format:
+# -------
+#
+# Three tab-separated columns;
+# '#' begins a comment which continues to the end of the line.
+# Column #1 is the Mac OS Roman code (in hex as 0xNN)
+# Column #2 is the corresponding Unicode (in hex as 0xNNNN)
+# Column #3 is a comment containing the Unicode name
+#
+# The entries are in Mac OS Roman code order.
+#
+# One of these mappings requires the use of a corporate character.
+# See the file "CORPCHAR.TXT" and notes below.
+#
+# Control character mappings are not shown in this table, following
+# the conventions of the standard UTC mapping tables. However, the
+# Mac OS Roman character set uses the standard control characters at
+# 0x00-0x1F and 0x7F.
+#
+# Notes on Mac OS Roman:
+# ----------------------
+#
+# This is a legacy Mac OS encoding; in the Mac OS X Carbon and Cocoa
+# environments, it is only supported directly in programming
+# interfaces for QuickDraw Text, the Script Manager, and related
+# Text Utilities. For other purposes it is supported via transcoding
+# to and from Unicode.
+#
+# This character set is used for at least the following Mac OS
+# localizations: U.S., British, Canadian French, French, Swiss
+# French, German, Swiss German, Italian, Swiss Italian, Dutch,
+# Swedish, Norwegian, Danish, Finnish, Spanish, Catalan,
+# Portuguese, Brazilian, and the default International system.
+#
+# Variants of Mac OS Roman are used for Croatian, Icelandic,
+# Turkish, Romanian, and other encodings. Separate mapping tables
+# are available for these encodings.
+#
+# Before Mac OS 8.5, code point 0xDB was CURRENCY SIGN, and was
+# mapped to U+00A4. In Mac OS 8.5 and later versions, code point
+# 0xDB is changed to EURO SIGN and maps to U+20AC; the standard
+# Apple fonts are updated for Mac OS 8.5 to reflect this. There is
+# a "currency sign" variant of the Mac OS Roman encoding that still
+# maps 0xDB to U+00A4; this can be used for older fonts.
+#
+# Before Mac OS 8.5, the ROM bitmap versions of the fonts Chicago,
+# New York, Geneva, and Monaco did not implement the full Mac OS
+# Roman character set; they only supported character codes up to
+# 0xD8. The TrueType versions of these fonts have always implemented
+# the full character set, as with the bitmap and TrueType versions
+# of the other standard Roman fonts.
+#
+# In all Mac OS encodings, fonts such as Chicago which are used
+# as "system" fonts (for menus, dialogs, etc.) have four glyphs
+# at code points 0x11-0x14 for transient use by the Menu Manager.
+# These glyphs are not intended as characters for use in normal
+# text, and the associated code points are not generally
+# interpreted as associated with these glyphs; they are usually
+# interpreted (if at all) as the control codes DC1-DC4.
+#
+# Unicode mapping issues and notes:
+# ---------------------------------
+#
+# The following corporate zone Unicode character is used in this
+# mapping:
+#
+# 0xF8FF Apple logo
+#
+# NOTE: The graphic image associated with the Apple logo character
+# is not authorized for use without permission of Apple, and
+# unauthorized use might constitute trademark infringement.
+#
+# Details of mapping changes in each version:
+# -------------------------------------------
+#
+# Changes from version n08 to version b02:
+#
+# - Encoding changed for Mac OS 8.5; change mapping of 0xDB from
+# CURRENCY SIGN (U+00A4) to EURO SIGN (U+20AC).
+#
+# Changes from version n03 to version n04:
+#
+# - Change mapping of 0xBD from U+2126 to its canonical
+# decomposition, U+03A9.
+#
+##################
+
+0x20 0x0020 # SPACE
+0x21 0x0021 # EXCLAMATION MARK
+0x22 0x0022 # QUOTATION MARK
+0x23 0x0023 # NUMBER SIGN
+0x24 0x0024 # DOLLAR SIGN
+0x25 0x0025 # PERCENT SIGN
+0x26 0x0026 # AMPERSAND
+0x27 0x0027 # APOSTROPHE
+0x28 0x0028 # LEFT PARENTHESIS
+0x29 0x0029 # RIGHT PARENTHESIS
+0x2A 0x002A # ASTERISK
+0x2B 0x002B # PLUS SIGN
+0x2C 0x002C # COMMA
+0x2D 0x002D # HYPHEN-MINUS
+0x2E 0x002E # FULL STOP
+0x2F 0x002F # SOLIDUS
+0x30 0x0030 # DIGIT ZERO
+0x31 0x0031 # DIGIT ONE
+0x32 0x0032 # DIGIT TWO
+0x33 0x0033 # DIGIT THREE
+0x34 0x0034 # DIGIT FOUR
+0x35 0x0035 # DIGIT FIVE
+0x36 0x0036 # DIGIT SIX
+0x37 0x0037 # DIGIT SEVEN
+0x38 0x0038 # DIGIT EIGHT
+0x39 0x0039 # DIGIT NINE
+0x3A 0x003A # COLON
+0x3B 0x003B # SEMICOLON
+0x3C 0x003C # LESS-THAN SIGN
+0x3D 0x003D # EQUALS SIGN
+0x3E 0x003E # GREATER-THAN SIGN
+0x3F 0x003F # QUESTION MARK
+0x40 0x0040 # COMMERCIAL AT
+0x41 0x0041 # LATIN CAPITAL LETTER A
+0x42 0x0042 # LATIN CAPITAL LETTER B
+0x43 0x0043 # LATIN CAPITAL LETTER C
+0x44 0x0044 # LATIN CAPITAL LETTER D
+0x45 0x0045 # LATIN CAPITAL LETTER E
+0x46 0x0046 # LATIN CAPITAL LETTER F
+0x47 0x0047 # LATIN CAPITAL LETTER G
+0x48 0x0048 # LATIN CAPITAL LETTER H
+0x49 0x0049 # LATIN CAPITAL LETTER I
+0x4A 0x004A # LATIN CAPITAL LETTER J
+0x4B 0x004B # LATIN CAPITAL LETTER K
+0x4C 0x004C # LATIN CAPITAL LETTER L
+0x4D 0x004D # LATIN CAPITAL LETTER M
+0x4E 0x004E # LATIN CAPITAL LETTER N
+0x4F 0x004F # LATIN CAPITAL LETTER O
+0x50 0x0050 # LATIN CAPITAL LETTER P
+0x51 0x0051 # LATIN CAPITAL LETTER Q
+0x52 0x0052 # LATIN CAPITAL LETTER R
+0x53 0x0053 # LATIN CAPITAL LETTER S
+0x54 0x0054 # LATIN CAPITAL LETTER T
+0x55 0x0055 # LATIN CAPITAL LETTER U
+0x56 0x0056 # LATIN CAPITAL LETTER V
+0x57 0x0057 # LATIN CAPITAL LETTER W
+0x58 0x0058 # LATIN CAPITAL LETTER X
+0x59 0x0059 # LATIN CAPITAL LETTER Y
+0x5A 0x005A # LATIN CAPITAL LETTER Z
+0x5B 0x005B # LEFT SQUARE BRACKET
+0x5C 0x005C # REVERSE SOLIDUS
+0x5D 0x005D # RIGHT SQUARE BRACKET
+0x5E 0x005E # CIRCUMFLEX ACCENT
+0x5F 0x005F # LOW LINE
+0x60 0x0060 # GRAVE ACCENT
+0x61 0x0061 # LATIN SMALL LETTER A
+0x62 0x0062 # LATIN SMALL LETTER B
+0x63 0x0063 # LATIN SMALL LETTER C
+0x64 0x0064 # LATIN SMALL LETTER D
+0x65 0x0065 # LATIN SMALL LETTER E
+0x66 0x0066 # LATIN SMALL LETTER F
+0x67 0x0067 # LATIN SMALL LETTER G
+0x68 0x0068 # LATIN SMALL LETTER H
+0x69 0x0069 # LATIN SMALL LETTER I
+0x6A 0x006A # LATIN SMALL LETTER J
+0x6B 0x006B # LATIN SMALL LETTER K
+0x6C 0x006C # LATIN SMALL LETTER L
+0x6D 0x006D # LATIN SMALL LETTER M
+0x6E 0x006E # LATIN SMALL LETTER N
+0x6F 0x006F # LATIN SMALL LETTER O
+0x70 0x0070 # LATIN SMALL LETTER P
+0x71 0x0071 # LATIN SMALL LETTER Q
+0x72 0x0072 # LATIN SMALL LETTER R
+0x73 0x0073 # LATIN SMALL LETTER S
+0x74 0x0074 # LATIN SMALL LETTER T
+0x75 0x0075 # LATIN SMALL LETTER U
+0x76 0x0076 # LATIN SMALL LETTER V
+0x77 0x0077 # LATIN SMALL LETTER W
+0x78 0x0078 # LATIN SMALL LETTER X
+0x79 0x0079 # LATIN SMALL LETTER Y
+0x7A 0x007A # LATIN SMALL LETTER Z
+0x7B 0x007B # LEFT CURLY BRACKET
+0x7C 0x007C # VERTICAL LINE
+0x7D 0x007D # RIGHT CURLY BRACKET
+0x7E 0x007E # TILDE
+#
+0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS
+0x81 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE
+0x82 0x00C7 # LATIN CAPITAL LETTER C WITH CEDILLA
+0x83 0x00C9 # LATIN CAPITAL LETTER E WITH ACUTE
+0x84 0x00D1 # LATIN CAPITAL LETTER N WITH TILDE
+0x85 0x00D6 # LATIN CAPITAL LETTER O WITH DIAERESIS
+0x86 0x00DC # LATIN CAPITAL LETTER U WITH DIAERESIS
+0x87 0x00E1 # LATIN SMALL LETTER A WITH ACUTE
+0x88 0x00E0 # LATIN SMALL LETTER A WITH GRAVE
+0x89 0x00E2 # LATIN SMALL LETTER A WITH CIRCUMFLEX
+0x8A 0x00E4 # LATIN SMALL LETTER A WITH DIAERESIS
+0x8B 0x00E3 # LATIN SMALL LETTER A WITH TILDE
+0x8C 0x00E5 # LATIN SMALL LETTER A WITH RING ABOVE
+0x8D 0x00E7 # LATIN SMALL LETTER C WITH CEDILLA
+0x8E 0x00E9 # LATIN SMALL LETTER E WITH ACUTE
+0x8F 0x00E8 # LATIN SMALL LETTER E WITH GRAVE
+0x90 0x00EA # LATIN SMALL LETTER E WITH CIRCUMFLEX
+0x91 0x00EB # LATIN SMALL LETTER E WITH DIAERESIS
+0x92 0x00ED # LATIN SMALL LETTER I WITH ACUTE
+0x93 0x00EC # LATIN SMALL LETTER I WITH GRAVE
+0x94 0x00EE # LATIN SMALL LETTER I WITH CIRCUMFLEX
+0x95 0x00EF # LATIN SMALL LETTER I WITH DIAERESIS
+0x96 0x00F1 # LATIN SMALL LETTER N WITH TILDE
+0x97 0x00F3 # LATIN SMALL LETTER O WITH ACUTE
+0x98 0x00F2 # LATIN SMALL LETTER O WITH GRAVE
+0x99 0x00F4 # LATIN SMALL LETTER O WITH CIRCUMFLEX
+0x9A 0x00F6 # LATIN SMALL LETTER O WITH DIAERESIS
+0x9B 0x00F5 # LATIN SMALL LETTER O WITH TILDE
+0x9C 0x00FA # LATIN SMALL LETTER U WITH ACUTE
+0x9D 0x00F9 # LATIN SMALL LETTER U WITH GRAVE
+0x9E 0x00FB # LATIN SMALL LETTER U WITH CIRCUMFLEX
+0x9F 0x00FC # LATIN SMALL LETTER U WITH DIAERESIS
+0xA0 0x2020 # DAGGER
+0xA1 0x00B0 # DEGREE SIGN
+0xA2 0x00A2 # CENT SIGN
+0xA3 0x00A3 # POUND SIGN
+0xA4 0x00A7 # SECTION SIGN
+0xA5 0x2022 # BULLET
+0xA6 0x00B6 # PILCROW SIGN
+0xA7 0x00DF # LATIN SMALL LETTER SHARP S
+0xA8 0x00AE # REGISTERED SIGN
+0xA9 0x00A9 # COPYRIGHT SIGN
+0xAA 0x2122 # TRADE MARK SIGN
+0xAB 0x00B4 # ACUTE ACCENT
+0xAC 0x00A8 # DIAERESIS
+0xAD 0x2260 # NOT EQUAL TO
+0xAE 0x00C6 # LATIN CAPITAL LETTER AE
+0xAF 0x00D8 # LATIN CAPITAL LETTER O WITH STROKE
+0xB0 0x221E # INFINITY
+0xB1 0x00B1 # PLUS-MINUS SIGN
+0xB2 0x2264 # LESS-THAN OR EQUAL TO
+0xB3 0x2265 # GREATER-THAN OR EQUAL TO
+0xB4 0x00A5 # YEN SIGN
+0xB5 0x00B5 # MICRO SIGN
+0xB6 0x2202 # PARTIAL DIFFERENTIAL
+0xB7 0x2211 # N-ARY SUMMATION
+0xB8 0x220F # N-ARY PRODUCT
+0xB9 0x03C0 # GREEK SMALL LETTER PI
+0xBA 0x222B # INTEGRAL
+0xBB 0x00AA # FEMININE ORDINAL INDICATOR
+0xBC 0x00BA # MASCULINE ORDINAL INDICATOR
+0xBD 0x03A9 # GREEK CAPITAL LETTER OMEGA
+0xBE 0x00E6 # LATIN SMALL LETTER AE
+0xBF 0x00F8 # LATIN SMALL LETTER O WITH STROKE
+0xC0 0x00BF # INVERTED QUESTION MARK
+0xC1 0x00A1 # INVERTED EXCLAMATION MARK
+0xC2 0x00AC # NOT SIGN
+0xC3 0x221A # SQUARE ROOT
+0xC4 0x0192 # LATIN SMALL LETTER F WITH HOOK
+0xC5 0x2248 # ALMOST EQUAL TO
+0xC6 0x2206 # INCREMENT
+0xC7 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xC8 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+0xC9 0x2026 # HORIZONTAL ELLIPSIS
+0xCA 0x00A0 # NO-BREAK SPACE
+0xCB 0x00C0 # LATIN CAPITAL LETTER A WITH GRAVE
+0xCC 0x00C3 # LATIN CAPITAL LETTER A WITH TILDE
+0xCD 0x00D5 # LATIN CAPITAL LETTER O WITH TILDE
+0xCE 0x0152 # LATIN CAPITAL LIGATURE OE
+0xCF 0x0153 # LATIN SMALL LIGATURE OE
+0xD0 0x2013 # EN DASH
+0xD1 0x2014 # EM DASH
+0xD2 0x201C # LEFT DOUBLE QUOTATION MARK
+0xD3 0x201D # RIGHT DOUBLE QUOTATION MARK
+0xD4 0x2018 # LEFT SINGLE QUOTATION MARK
+0xD5 0x2019 # RIGHT SINGLE QUOTATION MARK
+0xD6 0x00F7 # DIVISION SIGN
+0xD7 0x25CA # LOZENGE
+0xD8 0x00FF # LATIN SMALL LETTER Y WITH DIAERESIS
+0xD9 0x0178 # LATIN CAPITAL LETTER Y WITH DIAERESIS
+0xDA 0x2044 # FRACTION SLASH
+0xDB 0x20AC # EURO SIGN
+0xDC 0x2039 # SINGLE LEFT-POINTING ANGLE QUOTATION MARK
+0xDD 0x203A # SINGLE RIGHT-POINTING ANGLE QUOTATION MARK
+0xDE 0xFB01 # LATIN SMALL LIGATURE FI
+0xDF 0xFB02 # LATIN SMALL LIGATURE FL
+0xE0 0x2021 # DOUBLE DAGGER
+0xE1 0x00B7 # MIDDLE DOT
+0xE2 0x201A # SINGLE LOW-9 QUOTATION MARK
+0xE3 0x201E # DOUBLE LOW-9 QUOTATION MARK
+0xE4 0x2030 # PER MILLE SIGN
+0xE5 0x00C2 # LATIN CAPITAL LETTER A WITH CIRCUMFLEX
+0xE6 0x00CA # LATIN CAPITAL LETTER E WITH CIRCUMFLEX
+0xE7 0x00C1 # LATIN CAPITAL LETTER A WITH ACUTE
+0xE8 0x00CB # LATIN CAPITAL LETTER E WITH DIAERESIS
+0xE9 0x00C8 # LATIN CAPITAL LETTER E WITH GRAVE
+0xEA 0x00CD # LATIN CAPITAL LETTER I WITH ACUTE
+0xEB 0x00CE # LATIN CAPITAL LETTER I WITH CIRCUMFLEX
+0xEC 0x00CF # LATIN CAPITAL LETTER I WITH DIAERESIS
+0xED 0x00CC # LATIN CAPITAL LETTER I WITH GRAVE
+0xEE 0x00D3 # LATIN CAPITAL LETTER O WITH ACUTE
+0xEF 0x00D4 # LATIN CAPITAL LETTER O WITH CIRCUMFLEX
+0xF0 0xF8FF # Apple logo
+0xF1 0x00D2 # LATIN CAPITAL LETTER O WITH GRAVE
+0xF2 0x00DA # LATIN CAPITAL LETTER U WITH ACUTE
+0xF3 0x00DB # LATIN CAPITAL LETTER U WITH CIRCUMFLEX
+0xF4 0x00D9 # LATIN CAPITAL LETTER U WITH GRAVE
+0xF5 0x0131 # LATIN SMALL LETTER DOTLESS I
+0xF6 0x02C6 # MODIFIER LETTER CIRCUMFLEX ACCENT
+0xF7 0x02DC # SMALL TILDE
+0xF8 0x00AF # MACRON
+0xF9 0x02D8 # BREVE
+0xFA 0x02D9 # DOT ABOVE
+0xFB 0x02DA # RING ABOVE
+0xFC 0x00B8 # CEDILLA
+0xFD 0x02DD # DOUBLE ACUTE ACCENT
+0xFE 0x02DB # OGONEK
+0xFF 0x02C7 # CARON
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+Definitions of 8-bit encodings like ISO 8859 and Windows 1252
--- /dev/null
+USING: help.markup help.syntax ;
+IN: io.encodings.ascii
+
+HELP: ascii
+{ $class-description "This is the encoding descriptor which denotes an ASCII encoding. By default, if there's a non-ASCII character in an input stream, it will be replaced with a replacement character (U+FFFD), and if a non-ASCII character is used in output, an exception is thrown." }
+{ $see-also "encodings-introduction" } ;
+
+ABOUT: ascii
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings strings kernel math sequences byte-arrays io.encodings ;
+USING: io io.encodings kernel math io.encodings.private ;
IN: io.encodings.ascii
-: encode-check< ( string stream max -- )
- [ pick <= [ encode-error ] [ stream-write1 ] if ] 2curry each ;
+<PRIVATE
+: encode-if< ( char stream encoding max -- )
+ nip 1- pick < [ encode-error ] [ stream-write1 ] if ;
-: push-if< ( sbuf character max -- )
- over <= [ drop HEX: fffd ] when swap push ;
+: decode-if< ( stream encoding max -- character )
+ nip swap stream-read1
+ [ tuck > [ drop replacement-char ] unless ]
+ [ drop f ] if* ;
+PRIVATE>
TUPLE: ascii ;
-M: ascii stream-write-encoded ( string stream encoding -- )
- drop 128 encode-check< ;
+M: ascii encode-char
+ 128 encode-if< ;
-M: ascii decode-step
- drop 128 push-if< ;
+M: ascii decode-char
+ 128 decode-if< ;
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-USING: help.syntax help.markup ;
-IN: io.encodings.latin1
-
-HELP: latin1
-{ $class-description "This class is used for Latin 1 (ISO 8859-1) encoding and decoding" } ;
+++ /dev/null
-USING: io.encodings.string io.encodings.latin1 tools.test strings arrays ;
-IN: io.encodings.latin1.tests
-
-[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
-[ { 256 } >string latin1 encode ] must-fail
-[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test
-
-[ "bar" ] [ "bar" latin1 decode ] unit-test
-[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings strings kernel io.encodings.ascii sequences math ;
-IN: io.encodings.latin1
-
-TUPLE: latin1 ;
-
-M: latin1 stream-write-encoded
- drop 256 encode-check< ;
-
-M: latin1 decode-step
- drop swap push ;
+++ /dev/null
-ISO 8859-1 encoding/decoding
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup ;
+IN: io.encodings.strict
+
+HELP: strict ( encoding -- strict-encoding )
+{ $values { "encoding" "an encoding descriptor" } { "strict-encoding" "a strict encoding descriptor" } }
+{ $description "Makes an encoding strict, that is, in the presence of a malformed code point, an error is thrown. Note that the existence of a replacement character in a file (U+FFFD) also throws an error." } ;
+
+ABOUT: strict
--- /dev/null
+USING: io.encodings.strict io.encodings.ascii tools.test
+arrays io.encodings.string ;
+IN: io.encodings.strict.test
+
+[ { HEX: fffd } ] [ { 128 } ascii decode >array ] unit-test
+[ { 128 } ascii strict decode ] must-fail
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings kernel accessors inspector ;
+IN: io.encodings.strict
+
+TUPLE: strict code ;
+C: strict strict
+
+TUPLE: decode-error ;
+: decode-error ( -- * ) \ decode-error new throw ;
+M: decode-error summary
+ drop "Error in decoding input stream" ;
+
+M: strict <decoder>
+ code>> <decoder> [ strict ] change-code ;
+
+M: strict decode-char
+ code>> decode-char dup replacement-char = [ decode-error ] when ;
--- /dev/null
+Strict wrapper for encodings
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-UTF16 encoding/decoding
+++ /dev/null
-USING: help.markup help.syntax io.encodings strings ;
-IN: io.encodings.utf16
-
-ARTICLE: "utf16" "Working with UTF-16-encoded data"
-"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
-{ $subsection utf16le }
-{ $subsection utf16be }
-{ $subsection utf16 }
-"All of these conform to the " { $link "encodings-protocol" } "." ;
-
-ABOUT: "utf16"
-
-HELP: utf16le
-{ $class-description "The encoding protocol for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ;
-
-HELP: utf16be
-{ $class-description "The encoding protocol for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." } ;
-
-HELP: utf16
-{ $class-description "The encoding protocol for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." } ;
-
-{ utf16 utf16le utf16be } related-words
+++ /dev/null
-USING: kernel tools.test io.encodings.utf16 arrays sbufs
-sequences io.encodings io unicode io.encodings.string ;
-
-[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test
-[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
-
-[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test
-
-[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
-
-[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test
-
-[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
-[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
-
-[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel sequences sbufs vectors namespaces io.binary
-io.encodings combinators splitting io byte-arrays ;
-IN: io.encodings.utf16
-
-! UTF-16BE decoding
-
-TUPLE: utf16be ch state ;
-
-SYMBOL: double
-SYMBOL: quad1
-SYMBOL: quad2
-SYMBOL: quad3
-SYMBOL: ignore
-
-: do-ignore ( -- ch state ) 0 ignore ;
-
-: append-nums ( byte ch -- ch )
- 8 shift bitor ;
-
-: end-multibyte ( buf byte ch -- buf ch state )
- append-nums push-decoded ;
-
-: begin-utf16be ( buf byte -- buf ch state )
- dup -3 shift BIN: 11011 number= [
- dup BIN: 00000100 bitand zero?
- [ BIN: 11 bitand quad1 ]
- [ drop do-ignore ] if
- ] [ double ] if ;
-
-: handle-quad2be ( byte ch -- ch state )
- swap dup -2 shift BIN: 110111 number= [
- >r 2 shift r> BIN: 11 bitand bitor quad3
- ] [ 2drop do-ignore ] if ;
-
-: decode-utf16be-step ( buf byte ch state -- buf ch state )
- {
- { begin [ drop begin-utf16be ] }
- { double [ end-multibyte ] }
- { quad1 [ append-nums quad2 ] }
- { quad2 [ handle-quad2be ] }
- { quad3 [ append-nums HEX: 10000 + push-decoded ] }
- { ignore [ 2drop push-replacement ] }
- } case ;
-
-: unpack-state-be ( encoding -- ch state )
- { utf16be-ch utf16be-state } get-slots ;
-
-: pack-state-be ( ch state encoding -- )
- { set-utf16be-ch set-utf16be-state } set-slots ;
-
-M: utf16be decode-step
- [ unpack-state-be decode-utf16be-step ] keep pack-state-be drop ;
-
-M: utf16be init-decoder nip begin over set-utf16be-state ;
-
-! UTF-16LE decoding
-
-TUPLE: utf16le ch state ;
-
-: handle-double ( buf byte ch -- buf ch state )
- swap dup -3 shift BIN: 11011 = [
- dup BIN: 100 bitand 0 number=
- [ BIN: 11 bitand 8 shift bitor quad2 ]
- [ 2drop push-replacement ] if
- ] [ end-multibyte ] if ;
-
-: handle-quad3le ( buf byte ch -- buf ch state )
- swap dup -2 shift BIN: 110111 = [
- BIN: 11 bitand append-nums HEX: 10000 + push-decoded
- ] [ 2drop push-replacement ] if ;
-
-: decode-utf16le-step ( buf byte ch state -- buf ch state )
- {
- { begin [ drop double ] }
- { double [ handle-double ] }
- { quad1 [ append-nums quad2 ] }
- { quad2 [ 10 shift bitor quad3 ] }
- { quad3 [ handle-quad3le ] }
- } case ;
-
-: unpack-state-le ( encoding -- ch state )
- { utf16le-ch utf16le-state } get-slots ;
-
-: pack-state-le ( ch state encoding -- )
- { set-utf16le-ch set-utf16le-state } set-slots ;
-
-M: utf16le decode-step
- [ unpack-state-le decode-utf16le-step ] keep pack-state-le drop ;
-
-M: utf16le init-decoder nip begin over set-utf16le-state ;
-
-! UTF-16LE/BE encoding
-
-: encode-first
- -10 shift
- dup -8 shift BIN: 11011000 bitor
- swap HEX: FF bitand ;
-
-: encode-second
- BIN: 1111111111 bitand
- dup -8 shift BIN: 11011100 bitor
- swap BIN: 11111111 bitand ;
-
-: char>utf16be ( char -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- dup encode-first swap write1 write1
- encode-second swap write1 write1
- ] [ h>b/b write1 write1 ] if ;
-
-: stream-write-utf16be ( string stream -- )
- [ [ char>utf16be ] each ] with-stream* ;
-
-M: utf16be stream-write-encoded ( string stream encoding -- )
- drop stream-write-utf16be ;
-
-: char>utf16le ( char -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- dup encode-first write1 write1
- encode-second write1 write1
- ] [ h>b/b swap write1 write1 ] if ;
-
-: stream-write-utf16le ( string stream -- )
- [ [ char>utf16le ] each ] with-stream* ;
-
-M: utf16le stream-write-encoded ( string stream encoding -- )
- drop stream-write-utf16le ;
-
-! UTF-16
-
-: bom-le B{ HEX: ff HEX: fe } ; inline
-
-: bom-be B{ HEX: fe HEX: ff } ; inline
-
-: start-utf16le? ( seq1 -- seq2 ? ) bom-le ?head ;
-
-: start-utf16be? ( seq1 -- seq2 ? ) bom-be ?head ;
-
-TUPLE: utf16 started? ;
-
-M: utf16 stream-write-encoded
- dup utf16-started? [ drop ]
- [ t swap set-utf16-started? bom-le over stream-write ] if
- stream-write-utf16le ;
-
-: bom>le/be ( bom -- le/be )
- dup bom-le sequence= [ drop utf16le ] [
- bom-be sequence= [ utf16be ] [ decode-error ] if
- ] if ;
-
-M: utf16 init-decoder ( stream encoding -- newencoding )
- 2 rot stream-read bom>le/be construct-empty init-decoder ;
USING: io.backend ;
IN: io.files.unique.backend
-HOOK: (make-unique-file) io-backend ( path -- stream )
+HOOK: (make-unique-file) io-backend ( path -- )
HOOK: temporary-path io-backend ( -- path )
"Files:"
{ $subsection make-unique-file }
{ $subsection with-unique-file }
-{ $subsection with-temporary-file }
"Directories:"
{ $subsection make-unique-directory }
-{ $subsection with-unique-directory }
-{ $subsection with-temporary-directory } ;
+{ $subsection with-unique-directory } ;
ABOUT: "unique"
-HELP: make-unique-file ( prefix suffix -- path stream )
+HELP: make-unique-file ( prefix suffix -- path )
{ $values { "prefix" "a string" } { "suffix" "a string" }
-{ "path" "a pathname string" } { "stream" "an output stream" } }
-{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname and a " { $link <writer> } " stream." }
+{ "path" "a pathname string" } }
+{ $description "Creates a file that is guaranteed not to exist in a platform-specific temporary directory. The file name is composed of a prefix, a number of random digits and letters, and the suffix. Returns the full pathname." }
{ $errors "Throws an error if a new unique file cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
{ $see-also with-unique-file } ;
{ $errors "Throws an error if the directory cannot be created after a number of tries. Since each try generates a new random name, the most likely error is incorrect directory permissions on the temporary directory." }
{ $see-also with-unique-directory } ;
-HELP: with-unique-file ( quot -- path )
-{ $values { "quot" "a quotation" } { "path" "a pathname string" } }
-{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. Returns the full pathname after the stream has been closed." }
-{ $notes "The unique file will remain after calling this word." }
-{ $see-also with-temporary-file } ;
-
-HELP: with-unique-directory ( quot -- path )
-{ $values { "quot" "a quotation" } { "path" "a pathname string" } }
-{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. Returns the full pathname after the quotation has been called." }
-{ $notes "The directory will remain after calling this word." }
-{ $see-also with-temporary-directory } ;
-
-HELP: with-temporary-file ( quot -- )
-{ $values { "quot" "a quotation" } }
-{ $description "Creates a file with " { $link make-unique-file } " and calls " { $link with-stream } " on the newly created file. The file is deleted after the quotation returns." }
-{ $see-also with-unique-file } ;
+HELP: with-unique-file ( prefix suffix quot -- )
+{ $values { "prefix" "a string" } { "suffix" "a string" }
+{ "quot" "a quotation" } }
+{ $description "Creates a file with " { $link make-unique-file } " and calls the quotation with the path name on the stack." }
+{ $notes "The unique file will be deleted after calling this word." } ;
-HELP: with-temporary-directory ( quot -- )
+HELP: with-unique-directory ( quot -- )
{ $values { "quot" "a quotation" } }
-{ $description "Creates a directory with " { $link make-unique-directory } " and calls " { $link with-directory } " on the newly created directory. The directory is deleted after the quotation returns." }
-{ $see-also with-unique-directory } ;
+{ $description "Creates a directory with " { $link make-unique-directory } " and calls the quotation with the pathname on the stack." }
+{ $notes "The directory will be deleted after calling this word." } ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitfields combinators.lib math.parser
random sequences sequences.lib continuations namespaces
-io.files io.backend io.nonblocking io arrays
-io.files.unique.backend system combinators vocabs.loader ;
+io.files io arrays io.files.unique.backend system
+combinators vocabs.loader ;
IN: io.files.unique
<PRIVATE
: unique-retries ( -- n ) 10 ; inline
PRIVATE>
-: make-unique-file ( prefix suffix -- path stream )
+: make-unique-file ( prefix suffix -- path )
temporary-path -rot
[
- unique-length random-name swap 3append path+
+ unique-length random-name swap 3append append-path
dup (make-unique-file)
] 3curry unique-retries retry ;
-: with-unique-file ( quot -- path )
- >r f f make-unique-file r> rot [ with-stream ] dip ; inline
-
-: with-temporary-file ( quot -- )
- with-unique-file delete-file ; inline
+: with-unique-file ( prefix suffix quot -- )
+ >r make-unique-file r> keep delete-file ; inline
: make-unique-directory ( -- path )
[
- temporary-path unique-length random-name path+
+ temporary-path unique-length random-name append-path
dup make-directory
] unique-retries retry ;
-: with-unique-directory ( quot -- path )
+: with-unique-directory ( quot -- )
>r make-unique-directory r>
- [ with-directory ] curry keep ; inline
-
-: with-temporary-directory ( quot -- )
- with-unique-directory delete-tree ; inline
+ [ with-directory ] curry keep delete-tree ; inline
{
- { [ unix? ] [ "io.unix.files.unique" ] }
- { [ windows? ] [ "io.windows.files.unique" ] }
+ { [ os unix? ] [ "io.unix.files.unique" ] }
+ { [ os windows? ] [ "io.windows.files.unique" ] }
} cond require
{ "a file stream or a socket - the stream is connected to the given Factor stream, which cannot be used again from within Factor and must be closed after the process has been started" }
} ;
+ARTICLE: "io.launcher.priority" "Setting process priority"
+"The priority of the child process can be set by storing one of the below symbols in the " { $snippet "priority" } " slot of a " { $link process } " tuple:"
+{ $list
+ { $link +lowest-priority+ }
+ { $link +low-priority+ }
+ { $link +normal-priority+ }
+ { $link +high-priority+ }
+ { $link +highest-priority+ }
+}
+"The default value is " { $link f } ", which denotes that the child process should inherit the current process priority." ;
+
HELP: +closed+
{ $description "Possible value for the " { $snippet "stdin" } ", " { $snippet "stdout" } ", and " { $snippet "stderr" } " slots of a " { $link process } "." } ;
{ $values { "desc" "a launch descriptor" } }
{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ;
+{ run-process try-process run-detached } related-words
+
HELP: kill-process
{ $values { "process" process } }
{ $description "Kills a running process. Does nothing if the process has already exited." } ;
{ $values { "process" process } }
{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ;
-HELP: process-stream
-{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
-
HELP: <process-stream>
{ $values
{ "desc" "a launch descriptor" }
{ "desc" "a launch descriptor" }
{ "quot" quotation }
{ "status" "an exit code" } }
-{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ;
+{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a process stream. After the quotation returns, waits for the process to end and outputs the exit code." } ;
HELP: wait-for-process
{ $values { "process" process } { "status" integer } }
"Launching processes:"
{ $subsection run-process }
{ $subsection try-process }
+{ $subsection run-detached }
"Redirecting standard input and output to a pipe:"
{ $subsection <process-stream> }
{ $subsection with-process-stream } ;
{ $subsection "io.launcher.detached" }
{ $subsection "io.launcher.environment" }
{ $subsection "io.launcher.redirection" }
+{ $subsection "io.launcher.priority" }
{ $subsection "io.launcher.timeouts" } ;
ABOUT: "io.launcher"
USING: io io.backend io.timeouts system kernel namespaces
strings hashtables sequences assocs combinators vocabs.loader
init threads continuations math io.encodings io.streams.duplex
-io.nonblocking new-slots accessors ;
+io.nonblocking accessors concurrency.flags ;
IN: io.launcher
-
-TUPLE: process
+TUPLE: process < identity-tuple
command
detached
stdout
stderr
+priority
+
timeout
handle status
SYMBOL: +replace-environment+
SYMBOL: +append-environment+
+SYMBOL: +lowest-priority+
+SYMBOL: +low-priority+
+SYMBOL: +normal-priority+
+SYMBOL: +high-priority+
+SYMBOL: +highest-priority+
+SYMBOL: +realtime-priority+
+
: <process> ( -- process )
- process construct-empty
+ process new
H{ } clone >>environment
+append-environment+ >>environment-mode ;
[ H{ } clone processes set-global ] "io.launcher" add-init-hook
-HOOK: register-process io-backend ( process -- )
+HOOK: wait-for-processes io-backend ( -- ? )
+
+SYMBOL: wait-flag
-M: object register-process drop ;
+: wait-loop ( -- )
+ processes get assoc-empty?
+ [ wait-flag get-global lower-flag ]
+ [ wait-for-processes [ 100 sleep ] when ] if ;
+
+: start-wait-thread ( -- )
+ <flag> wait-flag set-global
+ [ wait-loop t ] "Process wait" spawn-server drop ;
+
+[ start-wait-thread ] "io.launcher" add-init-hook
: process-started ( process handle -- )
>>handle
- V{ } clone over processes get set-at
- register-process ;
-
-M: process equal? 2drop f ;
+ V{ } clone swap processes get set-at
+ wait-flag get-global raise-flag ;
M: process hashcode* process-handle hashcode* ;
: get-environment ( process -- env )
dup environment>>
swap environment-mode>> {
- { +prepend-environment+ [ os-envs union ] }
- { +append-environment+ [ os-envs swap union ] }
+ { +prepend-environment+ [ os-envs assoc-union ] }
+ { +append-environment+ [ os-envs swap assoc-union ] }
{ +replace-environment+ [ ] }
} case ;
run-detached
dup detached>> [ dup wait-for-process drop ] unless ;
-TUPLE: process-failed code ;
-
-: process-failed ( code -- * )
- \ process-failed construct-boa throw ;
+ERROR: process-failed code ;
: try-process ( desc -- )
run-process wait-for-process dup zero?
HOOK: (process-stream) io-backend ( process -- handle in out )
-TUPLE: process-stream process ;
+: <process-stream*> ( desc encoding -- stream process )
+ >r >process dup dup (process-stream) <reader&writer>
+ r> <encoder-duplex> -roll
+ process-started ;
: <process-stream> ( desc encoding -- stream )
- >r >process dup dup (process-stream)
- >r >r process-started process-stream construct-boa
- r> r> <reader&writer> r> <encoder-duplex>
- over set-delegate ;
+ <process-stream*> drop ; inline
: with-process-stream ( desc quot -- status )
- swap <process-stream>
+ swap <process-stream*> >r
[ swap with-stream ] keep
- process>> wait-for-process ; inline
+ r> wait-for-process ; inline
: notify-exit ( process status -- )
>>status
USING: io io.mmap io.files kernel tools.test continuations
-sequences io.encodings.ascii ;
+sequences io.encodings.ascii accessors ;
IN: io.mmap.tests
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
-[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
+[ ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
IN: io.monitors\r
-USING: help.markup help.syntax continuations ;\r
+USING: help.markup help.syntax continuations\r
+concurrency.mailboxes quotations ;\r
+\r
+HELP: with-monitors\r
+{ $values { "quot" quotation } }\r
+{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." }\r
+{ $errors "Throws an error if the platform does not support file system change monitors." } ;\r
\r
HELP: <monitor>\r
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } }\r
-{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported."\r
-$nl\r
-"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;\r
+{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." }\r
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
+\r
+HELP: (monitor)\r
+{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "mailbox" mailbox } { "monitor" "a new monitor" } }\r
+{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }\r
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
\r
HELP: next-change\r
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }\r
-{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;\r
+{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." }\r
+{ $errors "Throws an error if the monitor is closed from another thread." } ;\r
\r
HELP: with-monitor\r
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }\r
-{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ;\r
+{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." }\r
+{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;\r
\r
HELP: +add-file+\r
-{ $description "Indicates that the file has been added to the directory." } ;\r
+{ $description "Indicates that a file has been added to its parent directory." } ;\r
\r
HELP: +remove-file+\r
-{ $description "Indicates that the file has been removed from the directory." } ;\r
+{ $description "Indicates that a file has been removed from its parent directory." } ;\r
\r
HELP: +modify-file+\r
-{ $description "Indicates that the file contents have changed." } ;\r
+{ $description "Indicates that a file's contents have changed." } ;\r
+\r
+HELP: +rename-file-old+\r
+{ $description "Indicates that a file has been renamed, and this is the old name." } ;\r
+\r
+HELP: +rename-file-new+\r
+{ $description "Indicates that a file has been renamed, and this is the new name." } ;\r
\r
HELP: +rename-file+\r
-{ $description "Indicates that file has been renamed." } ;\r
+{ $description "Indicates that a file has been renamed." } ;\r
\r
ARTICLE: "io.monitors.descriptors" "File system change descriptors"\r
"Change descriptors output by " { $link next-change } ":"\r
{ $subsection +add-file+ }\r
{ $subsection +remove-file+ }\r
{ $subsection +modify-file+ }\r
-{ $subsection +rename-file+ }\r
-{ $subsection +add-file+ } ;\r
+{ $subsection +rename-file-old+ }\r
+{ $subsection +rename-file-new+ }\r
+{ $subsection +rename-file+ } ;\r
+\r
+ARTICLE: "io.monitors.platforms" "Monitors on different platforms"\r
+"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is platform-specific. User code should not assume either case."\r
+{ $heading "Mac OS X" }\r
+"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later."\r
+$nl\r
+{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."\r
+$nl\r
+"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."\r
+{ $heading "Windows" }\r
+"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows."\r
+$nl\r
+"Both recursive and non-recursive monitors are directly supported by the operating system."\r
+{ $heading "Linux" }\r
+"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later."\r
+$nl\r
+"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code."\r
+$nl\r
+"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory."\r
+{ $heading "BSD" }\r
+"Factor uses " { $snippet "kqueue" } " to implement monitors on BSD."\r
+$nl\r
+"The " { $snippet "kqueue" } " system is limited to monitoring individual files and directories. Monitoring a directory only notifies of files being added and removed to the directory itself, not of changes to file contents."\r
+{ $heading "Windows CE" }\r
+"Windows CE does not support monitors." ;\r
\r
ARTICLE: "io.monitors" "File system change monitors"\r
"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."\r
$nl\r
+"Monitoring operations must be wrapped in a combinator:"\r
+{ $subsection with-monitors }\r
"Creating a file system change monitor and listening for changes:"\r
{ $subsection <monitor> }\r
{ $subsection next-change }\r
+"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:"\r
+{ $subsection (monitor) }\r
{ $subsection "io.monitors.descriptors" }\r
-"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "."\r
-$nl\r
-"A utility combinator which opens a monitor and cleans it up after:"\r
+{ $subsection "io.monitors.platforms" } \r
+"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:"\r
{ $subsection with-monitor }\r
-"An example which watches the Factor directory for changes:"\r
+"Monitors support the " { $link "io.timeouts" } "."\r
+$nl\r
+"An example which watches a directory for changes:"\r
{ $code\r
"USE: io.monitors"\r
": watch-loop ( monitor -- )"\r
" dup next-change . . nl nl flush watch-loop ;"\r
""\r
- "\"\" resource-path f [ watch-loop ] with-monitor"\r
+ ": watch-directory ( path -- )"\r
+ " [ t [ watch-loop ] with-monitor ] with-monitors"\r
} ;\r
\r
ABOUT: "io.monitors"\r
--- /dev/null
+IN: io.monitors.tests
+USING: io.monitors tools.test io.files system sequences
+continuations namespaces concurrency.count-downs kernel io
+threads calendar prettyprint ;
+
+os { winnt linux macosx } member? [
+ [
+ [ "monitor-test" temp-file delete-tree ] ignore-errors
+
+ [ ] [ "monitor-test" temp-file make-directory ] unit-test
+
+ [ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
+
+ [ ] [ "monitor-test/a1" temp-file make-directory ] unit-test
+
+ [ ] [ "monitor-test/a2" temp-file make-directory ] unit-test
+
+ [ ] [ "monitor-test/a1" temp-file "monitor-test/a2" temp-file move-file-into ] unit-test
+
+ [ t ] [ "monitor-test/a2/a1" temp-file exists? ] unit-test
+
+ [ ] [ "monitor-test/a2/a1/a3.txt" temp-file touch-file ] unit-test
+
+ [ t ] [ "monitor-test/a2/a1/a3.txt" temp-file exists? ] unit-test
+
+ [ ] [ "monitor-test/a2/a1/a4.txt" temp-file touch-file ] unit-test
+ [ ] [ "monitor-test/a2/a1/a5.txt" temp-file touch-file ] unit-test
+ [ ] [ "monitor-test/a2/a1/a4.txt" temp-file delete-file ] unit-test
+ [ ] [ "monitor-test/a2/a1/a5.txt" temp-file "monitor-test/a2/a1/a4.txt" temp-file move-file ] unit-test
+
+ [ t ] [ "monitor-test/a2/a1/a4.txt" temp-file exists? ] unit-test
+
+ [ ] [ "m" get dispose ] unit-test
+ ] with-monitors
+
+ [
+ [ "monitor-test" temp-file delete-tree ] ignore-errors
+
+ [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test
+
+ [ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
+
+ [ ] [ 1 <count-down> "b" set ] unit-test
+
+ [ ] [ 1 <count-down> "c1" set ] unit-test
+
+ [ ] [ 1 <count-down> "c2" set ] unit-test
+
+ [ ] [
+ [
+ "b" get count-down
+
+ [
+ "m" get next-change drop
+ dup print flush
+ dup parent-directory
+ [ right-trim-separators "xyz" tail? ] either? not
+ ] [ ] [ ] while
+
+ "c1" get count-down
+
+ [
+ "m" get next-change drop
+ dup print flush
+ dup parent-directory
+ [ right-trim-separators "yxy" tail? ] either? not
+ ] [ ] [ ] while
+
+ "c2" get count-down
+ ] "Monitor test thread" spawn drop
+ ] unit-test
+
+ [ ] [ "b" get await ] unit-test
+
+ [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
+
+ [ ] [ "c1" get 1 minutes await-timeout ] unit-test
+
+ [ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test
+
+ [ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test
+
+ [ ] [ "c2" get 1 minutes await-timeout ] unit-test
+
+ ! Dispose twice
+ [ ] [ "m" get dispose ] unit-test
+
+ [ ] [ "m" get dispose ] unit-test
+ ] with-monitors
+
+ ! Out-of-scope disposal should not fail
+ [ "" resource-path t <monitor> ] with-monitors dispose
+] when
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: io.backend kernel continuations namespaces sequences\r
-assocs hashtables sorting arrays threads boxes io.timeouts ;\r
-IN: io.monitors\r
-\r
-<PRIVATE\r
-\r
-TUPLE: monitor queue closed? ;\r
-\r
-: check-monitor ( monitor -- )\r
- monitor-closed? [ "Monitor closed" throw ] when ;\r
-\r
-: (monitor) ( delegate -- monitor )\r
- H{ } clone {\r
- set-delegate\r
- set-monitor-queue\r
- } monitor construct ;\r
-\r
-GENERIC: fill-queue ( monitor -- )\r
-\r
-: changed-file ( changed path -- )\r
- namespace [ append ] change-at ;\r
-\r
-: dequeue-change ( assoc -- path changes )\r
- delete-any prune natural-sort >array ;\r
-\r
-M: monitor dispose\r
- dup check-monitor\r
- t over set-monitor-closed?\r
- delegate dispose ;\r
-\r
-! Simple monitor; used on Linux and Mac OS X. On Windows,\r
-! monitors are full-fledged ports.\r
-TUPLE: simple-monitor handle callback timeout ;\r
-\r
-M: simple-monitor timeout simple-monitor-timeout ;\r
-\r
-M: simple-monitor set-timeout set-simple-monitor-timeout ;\r
-\r
-: <simple-monitor> ( handle -- simple-monitor )\r
- f (monitor) <box> {\r
- set-simple-monitor-handle\r
- set-delegate\r
- set-simple-monitor-callback\r
- } simple-monitor construct ;\r
-\r
-: construct-simple-monitor ( handle class -- simple-monitor )\r
- >r <simple-monitor> r> construct-delegate ; inline\r
-\r
-: notify-callback ( simple-monitor -- )\r
- simple-monitor-callback [ resume ] if-box? ;\r
-\r
-M: simple-monitor timed-out\r
- notify-callback ;\r
-\r
-M: simple-monitor fill-queue ( monitor -- )\r
- [\r
- [ swap simple-monitor-callback >box ]\r
- "monitor" suspend drop\r
- ] with-timeout\r
- check-monitor ;\r
-\r
-M: simple-monitor dispose ( monitor -- )\r
- dup delegate dispose notify-callback ;\r
-\r
-PRIVATE>\r
-\r
-HOOK: <monitor> io-backend ( path recursive? -- monitor )\r
-\r
-: next-change ( monitor -- path changed )\r
- dup check-monitor\r
- dup monitor-queue dup assoc-empty? [\r
- drop dup fill-queue next-change\r
- ] [ nip dequeue-change ] if ;\r
-\r
-SYMBOL: +add-file+\r
-SYMBOL: +remove-file+\r
-SYMBOL: +modify-file+\r
-SYMBOL: +rename-file+\r
-\r
-: with-monitor ( path recursive? quot -- )\r
- >r <monitor> r> with-disposal ; inline\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend kernel continuations namespaces sequences
+assocs hashtables sorting arrays threads boxes io.timeouts
+accessors concurrency.mailboxes ;
+IN: io.monitors
+
+HOOK: init-monitors io-backend ( -- )
+
+M: object init-monitors ;
+
+HOOK: dispose-monitors io-backend ( -- )
+
+M: object dispose-monitors ;
+
+: with-monitors ( quot -- )
+ [
+ init-monitors
+ [ dispose-monitors ] [ ] cleanup
+ ] with-scope ; inline
+
+TUPLE: monitor < identity-tuple path queue timeout ;
+
+M: monitor hashcode* path>> hashcode* ;
+
+M: monitor timeout timeout>> ;
+
+M: monitor set-timeout (>>timeout) ;
+
+: new-monitor ( path mailbox class -- monitor )
+ new
+ swap >>queue
+ swap >>path ; inline
+
+: queue-change ( path changes monitor -- )
+ 3dup and and
+ [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ;
+
+HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
+
+: <monitor> ( path recursive? -- monitor )
+ <mailbox> (monitor) ;
+
+: next-change ( monitor -- path changed )
+ [ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ;
+
+SYMBOL: +add-file+
+SYMBOL: +remove-file+
+SYMBOL: +modify-file+
+SYMBOL: +rename-file-old+
+SYMBOL: +rename-file-new+
+SYMBOL: +rename-file+
+
+: with-monitor ( path recursive? quot -- )
+ >r <monitor> r> with-disposal ; inline
--- /dev/null
+USING: accessors math kernel namespaces continuations
+io.files io.monitors io.monitors.recursive io.backend
+concurrency.mailboxes
+tools.test ;
+IN: io.monitors.recursive.tests
+
+\ pump-thread must-infer
+
+SINGLETON: mock-io-backend
+
+TUPLE: counter i ;
+
+SYMBOL: dummy-monitor-created
+SYMBOL: dummy-monitor-disposed
+
+TUPLE: dummy-monitor < monitor ;
+
+M: dummy-monitor dispose
+ drop dummy-monitor-disposed get [ 1+ ] change-i drop ;
+
+M: mock-io-backend (monitor)
+ nip
+ over exists? [
+ dummy-monitor new-monitor
+ dummy-monitor-created get [ 1+ ] change-i drop
+ ] [
+ "Does not exist" throw
+ ] if ;
+
+M: mock-io-backend link-info
+ global [ link-info ] bind ;
+
+[ ] [ 0 counter boa dummy-monitor-created set ] unit-test
+[ ] [ 0 counter boa dummy-monitor-disposed set ] unit-test
+
+[ ] [
+ mock-io-backend io-backend [
+ "" resource-path <mailbox> <recursive-monitor> dispose
+ ] with-variable
+] unit-test
+
+[ t ] [ dummy-monitor-created get i>> 0 > ] unit-test
+
+[ t ] [ dummy-monitor-created get i>> dummy-monitor-disposed get i>> = ] unit-test
+
+[ "doesnotexist" temp-file delete-tree ] ignore-errors
+
+[
+ mock-io-backend io-backend [
+ "doesnotexist" temp-file <mailbox> <recursive-monitor> dispose
+ ] with-variable
+] must-fail
+
+[ ] [
+ mock-io-backend io-backend [
+ "" resource-path <mailbox> <recursive-monitor>
+ [ dispose ] [ dispose ] bi
+ ] with-variable
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors sequences assocs arrays continuations combinators kernel
+threads concurrency.messaging concurrency.mailboxes concurrency.promises
+io.files io.monitors debugger ;
+IN: io.monitors.recursive
+
+! Simulate recursive monitors on platforms that don't have them
+
+TUPLE: recursive-monitor < monitor children thread ready ;
+
+: notify? ( -- ? ) monitor tget ready>> promise-fulfilled? ;
+
+DEFER: add-child-monitor
+
+: qualify-path ( path -- path' )
+ monitor tget path>> prepend-path ;
+
+: add-child-monitors ( path -- )
+ #! We yield since this directory scan might take a while.
+ directory* [ first add-child-monitor ] each yield ;
+
+: add-child-monitor ( path -- )
+ notify? [ dup { +add-file+ } monitor tget queue-change ] when
+ qualify-path dup link-info type>> +directory+ eq? [
+ [ add-child-monitors ]
+ [
+ [
+ [ f my-mailbox (monitor) ] keep
+ monitor tget children>> set-at
+ ] curry ignore-errors
+ ] bi
+ ] [ drop ] if ;
+
+: remove-child-monitor ( monitor -- )
+ monitor tget children>> delete-at* [ dispose ] [ drop ] if ;
+
+M: recursive-monitor dispose
+ dup queue>> closed>> [
+ drop
+ ] [
+ [ "stop" swap thread>> send-synchronous drop ]
+ [ queue>> dispose ] bi
+ ] if ;
+
+: stop-pump ( -- )
+ monitor tget children>> [ nip dispose ] assoc-each ;
+
+: pump-step ( msg -- )
+ first3 path>> swap >r prepend-path r> monitor tget 3array
+ monitor tget queue>>
+ mailbox-put ;
+
+: child-added ( path monitor -- )
+ path>> prepend-path add-child-monitor ;
+
+: child-removed ( path monitor -- )
+ path>> prepend-path remove-child-monitor ;
+
+: update-hierarchy ( msg -- )
+ first3 swap [
+ {
+ { +add-file+ [ child-added ] }
+ { +remove-file+ [ child-removed ] }
+ { +rename-file-old+ [ child-removed ] }
+ { +rename-file-new+ [ child-added ] }
+ [ 3drop ]
+ } case
+ ] with with each ;
+
+: pump-loop ( -- )
+ receive dup synchronous? [
+ >r stop-pump t r> reply-synchronous
+ ] [
+ [ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi
+ pump-loop
+ ] if ;
+
+: monitor-ready ( error/t -- )
+ monitor tget ready>> fulfill ;
+
+: pump-thread ( monitor -- )
+ monitor tset
+ [ "" add-child-monitor t monitor-ready ]
+ [ [ self <linked-error> monitor-ready ] keep rethrow ]
+ recover
+ pump-loop ;
+
+: start-pump-thread ( monitor -- )
+ dup [ pump-thread ] curry
+ "Recursive monitor pump" spawn
+ >>thread drop ;
+
+: wait-for-ready ( monitor -- )
+ ready>> ?promise ?linked drop ;
+
+: <recursive-monitor> ( path mailbox -- monitor )
+ >r (normalize-path) r>
+ recursive-monitor new-monitor
+ H{ } clone >>children
+ <promise> >>ready
+ dup start-pump-thread
+ dup wait-for-ready ;
USING: io io.buffers io.backend help.markup help.syntax kernel
-byte-arrays sbufs words continuations byte-vectors ;
+byte-arrays sbufs words continuations byte-vectors classes ;
IN: io.nonblocking
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
$nl
"Ports have the following slots:"
{ $list
- { { $link port-handle } " - a native handle identifying the underlying native resource used by the port" }
- { { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
- { { $link port-type } " - a symbol identifying the port's intended purpose" }
- { { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
+ { { $snippet "handle" } " - a native handle identifying the underlying native resource used by the port" }
+ { { $snippet "error" } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
+ { { $snippet "type" } " - a symbol identifying the port's intended purpose" }
+ { { $snippet "eof" } " - a flag indicating if the port has reached the end of file while reading" }
} } ;
HELP: input-port
{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
HELP: <port>
-{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } }
-{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." }
+{ $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } }
+{ $description "Creates a new " { $link port } " with no buffer." }
$low-level-note ;
HELP: <buffered-port>
-{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } }
+{ $values { "handle" "a native handle identifying an I/O resource" } { "class" class } { "port" "a new " { $link port } } }
{ $description "Creates a new " { $link port } " using the specified native handle and a default-sized I/O buffer." }
$low-level-note ;
{ $values { "port" input-port } { "quot" "a quotation with stack effect " { $snippet "( port -- value )" } } { "value" object } }
{ $description "If the port has reached end of file, outputs " { $link f } ", otherwise applies the quotation to the port." } ;
-HELP: read-until-step
-{ $values { "separators" "a sequence of bytes" } { "port" input-port } { "byte-array/f" "a byte array or " { $link f } } { "separator/f" "a byte or " { $link f } } }
-{ $description "If the port has reached end of file, outputs " { $link f } { $link f } ", otherwise scans the buffer for a separator and outputs a string up to but not including the separator." } ;
-
-HELP: read-until-loop
-{ $values { "seps" "a sequence of bytes" } { "port" input-port } { "accum" byte-vector } { "separator/f" "a byte or " { $link f } } }
-{ $description "Accumulates data in the byte vector, calling " { $link (wait-to-read) } " as many times as necessary, until either an occurrence of a separator is read, or end of file is reached." } ;
-
HELP: can-write?
-{ $values { "len" "a positive integer" } { "writer" output-port } { "?" "a boolean" } }
+{ $values { "len" "a positive integer" } { "buffer" buffer } { "?" "a boolean" } }
{ $description "Tests if the port's output buffer can accomodate " { $snippet "len" } " bytes. If the buffer is empty, this always outputs " { $link t } ", since in that case the buffer will be grown automatically." } ;
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-IN: io.nonblocking
USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.streams.duplex io.encodings
io.backend continuations debugger classes byte-arrays namespaces
-splitting dlists assocs io.encodings.binary ;
+splitting dlists assocs io.encodings.binary inspector accessors ;
+IN: io.nonblocking
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
-! Common delegate of native stream readers and writers
-TUPLE: port
-handle
-error
-timeout
-type eof? ;
-
-M: port timeout port-timeout ;
-
-M: port set-timeout set-port-timeout ;
+TUPLE: port handle buffer error timeout closed eof ;
-SYMBOL: closed
+M: port timeout timeout>> ;
-PREDICATE: port input-port port-type input-port eq? ;
-PREDICATE: port output-port port-type output-port eq? ;
+M: port set-timeout (>>timeout) ;
GENERIC: init-handle ( handle -- )
+
GENERIC: close-handle ( handle -- )
-: <port> ( handle buffer type -- port )
- pick init-handle {
- set-port-handle
- set-delegate
- set-port-type
- } port construct ;
+: <port> ( handle class -- port )
+ new
+ swap dup init-handle >>handle ; inline
+
+: <buffered-port> ( handle class -- port )
+ <port>
+ default-buffer-size get <buffer> >>buffer ; inline
-: <buffered-port> ( handle type -- port )
- default-buffer-size get <buffer> swap <port> ;
+TUPLE: input-port < port ;
: <reader> ( handle -- input-port )
input-port <buffered-port> ;
+TUPLE: output-port < port ;
+
: <writer> ( handle -- output-port )
output-port <buffered-port> ;
swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ;
: pending-error ( port -- )
- dup port-error f rot set-port-error [ throw ] when* ;
+ [ f ] change-error drop [ throw ] when* ;
+
+ERROR: port-closed-error port ;
+
+M: port-closed-error summary
+ drop "Port has been closed" ;
+
+: check-closed ( port -- port )
+ dup closed>> [ port-closed-error ] when ;
HOOK: cancel-io io-backend ( port -- )
GENERIC: (wait-to-read) ( port -- )
: wait-to-read ( count port -- )
- tuck buffer-length > [ (wait-to-read) ] [ drop ] if ;
+ tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ;
: wait-to-read1 ( port -- )
1 swap wait-to-read ;
: unless-eof ( port quot -- value )
- >r dup buffer-empty? over port-eof? and
- [ f swap set-port-eof? f ] r> if ; inline
+ >r dup buffer>> buffer-empty? over eof>> and
+ [ f >>eof drop f ] r> if ; inline
M: input-port stream-read1
- dup wait-to-read1 [ buffer-pop ] unless-eof ;
+ check-closed
+ dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ;
: read-step ( count port -- byte-array/f )
[ wait-to-read ] 2keep
- [ dupd buffer> ] unless-eof nip ;
+ [ dupd buffer>> buffer-read ] unless-eof nip ;
: read-loop ( count port accum -- )
pick over length - dup 0 > [
] if ;
M: input-port stream-read
+ check-closed
>r 0 max >fixnum r>
2dup read-step dup [
pick over length > [
[ push-all ] keep
[ read-loop ] keep
B{ } like
- ] [
- 2nip
- ] if
- ] [
- 2nip
- ] if ;
-
-: read-until-step ( separators port -- byte-array/f separator/f )
- dup wait-to-read1
- dup port-eof? [
- f swap set-port-eof? drop f f
- ] [
- buffer-until
- ] if ;
-
-: read-until-loop ( seps port accum -- separator/f )
- 2over read-until-step over [
- >r over push-all r> dup [
- >r 3drop r>
- ] [
- drop read-until-loop
- ] if
- ] [
- >r 2drop 2drop r>
- ] if ;
-
-M: input-port stream-read-until ( seps port -- byte-array/f sep/f )
- 2dup read-until-step dup [
- >r 2nip r>
- ] [
- over [
- drop BV{ } like
- [ read-until-loop ] keep
- B{ } like swap
- ] [
- >r 2nip r>
- ] if
- ] if ;
+ ] [ 2nip ] if
+ ] [ 2nip ] if ;
M: input-port stream-read-partial ( max stream -- byte-array/f )
+ check-closed
>r 0 max >fixnum r> read-step ;
-: can-write? ( len writer -- ? )
+: can-write? ( len buffer -- ? )
[ buffer-fill + ] keep buffer-capacity <= ;
: wait-to-write ( len port -- )
- tuck can-write? [ drop ] [ stream-flush ] if ;
+ tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
M: output-port stream-write1
- 1 over wait-to-write byte>buffer ;
+ check-closed
+ 1 over wait-to-write
+ buffer>> byte>buffer ;
M: output-port stream-write
- over length over buffer-size > [
- [ buffer-size <groups> ] keep
- [ stream-write ] curry each
+ check-closed
+ over length over buffer>> buffer-size > [
+ [ buffer>> buffer-size <groups> ]
+ [ [ stream-write ] curry ] bi
+ each
] [
- over length over wait-to-write >buffer
+ [ >r length r> wait-to-write ]
+ [ buffer>> >buffer ] 2bi
] if ;
GENERIC: port-flush ( port -- )
M: output-port stream-flush ( port -- )
- dup port-flush pending-error ;
+ check-closed
+ [ port-flush ] [ pending-error ] bi ;
+
+GENERIC: close-port ( port -- )
+
+M: output-port close-port
+ [ port-flush ] [ call-next-method ] bi ;
-: close-port ( port type -- )
- output-port eq? [ dup port-flush ] when
+M: port close-port
dup cancel-io
- dup port-handle close-handle
- dup delegate [ buffer-free ] when*
- f swap set-delegate ;
+ dup handle>> close-handle
+ [ [ buffer-free ] when* f ] change-buffer drop ;
M: port dispose
- dup port-type closed eq?
- [ drop ]
- [ dup port-type >r closed over set-port-type r> close-port ]
- if ;
+ dup closed>> [ drop ] [ t >>closed close-port ] if ;
-TUPLE: server-port addr client client-addr encoding ;
+TUPLE: server-port < port addr client client-addr encoding ;
: <server-port> ( handle addr encoding -- server )
- rot f server-port <port>
- { set-server-port-addr set-server-port-encoding set-delegate }
- server-port construct ;
+ rot server-port <port>
+ swap >>encoding
+ swap >>addr ;
-: check-server-port ( port -- )
- port-type server-port assert= ;
+: check-server-port ( port -- port )
+ dup server-port? [ "Not a server port" throw ] unless ; inline
-TUPLE: datagram-port addr packet packet-addr ;
+TUPLE: datagram-port < port addr packet packet-addr ;
: <datagram-port> ( handle addr -- datagram )
- >r f datagram-port <port> r>
- { set-delegate set-datagram-port-addr }
- datagram-port construct ;
+ swap datagram-port <port>
+ swap >>addr ;
-: check-datagram-port ( port -- )
- port-type datagram-port assert= ;
+: check-datagram-port ( port -- port )
+ check-closed
+ dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
-: check-datagram-send ( packet addrspec port -- )
- dup check-datagram-port
- datagram-port-addr [ class ] 2apply assert=
- class byte-array assert= ;
+: check-datagram-send ( packet addrspec port -- packet addrspec port )
+ check-datagram-port
+ 2dup addr>> [ class ] bi@ assert=
+ pick class byte-array assert= ;
-USING: io.files kernel sequences new-slots accessors
+USING: io.files kernel sequences accessors
dlists arrays sequences.lib ;
IN: io.paths
TUPLE: directory-iterator path bfs queue ;
: qualified-directory ( path -- seq )
- dup directory [ first2 >r path+ r> 2array ] with map ;
+ dup directory [ first2 >r append-path r> 2array ] with map ;
: push-directory ( path iter -- )
>r qualified-directory r> [
] curry each ;
: <directory-iterator> ( path bfs? -- iterator )
- <dlist> directory-iterator construct-boa
+ <dlist> directory-iterator boa
dup path>> over push-directory ;
: next-file ( iter -- file/f )
: find-all-files ( path bfs? quot -- paths )
>r <directory-iterator> r>
- pusher >r iterate-directory drop r> ; inline
+ pusher >r [ f ] compose iterate-directory drop r> ; inline
: recursive-directory ( path bfs? -- paths )
[ ] accumulator >r each-file r> ;
LOG: accepted-connection NOTICE
-: with-client ( client quot -- )
+: with-client ( client addrspec quot -- )
[
- over client-stream-addr accepted-connection
+ swap accepted-connection
with-stream*
- ] curry with-disposal ; inline
+ ] 2curry with-disposal ; inline
\ with-client DEBUG add-error-logging
: accept-loop ( server quot -- )
[
- >r accept r> [ with-client ] 2curry "Client" spawn drop
+ >r accept r> [ with-client ] 3curry "Client" spawn drop
] 2keep accept-loop ; inline
: server-loop ( addrspec encoding quot -- )
-! Copyright (C) 2007 Doug Coleman, Slava Pestov
+! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays io.backend io.binary io.sockets
-kernel math math.parser sequences splitting system
-alien.c-types combinators namespaces alien parser ;
+io.encodings.ascii kernel math math.parser sequences splitting
+system alien.c-types alien.strings alien combinators namespaces
+parser ;
IN: io.sockets.impl
<< {
- { [ windows? ] [ "windows.winsock" ] }
- { [ unix? ] [ "unix" ] }
+ { [ os windows? ] [ "windows.winsock" ] }
+ { [ os unix? ] [ "unix" ] }
} cond use+ >>
GENERIC: protocol-family ( addrspec -- af )
M: inet6 inet-pton ( str addrspec -- data )
drop "::" split1
- [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] 2apply
- 2dup [ length ] 2apply + 8 swap - 0 <array> swap 3append
+ [ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] bi@
+ 2dup [ length ] bi@ + 8 swap - 0 <array> swap 3append
[ 2 >be ] map concat >byte-array ;
M: inet6 address-size drop 16 ;
{ [ dup AF_INET = ] [ T{ inet4 } ] }
{ [ dup AF_INET6 = ] [ T{ inet6 } ] }
{ [ dup AF_UNIX = ] [ T{ local } ] }
- { [ t ] [ f ] }
+ [ f ]
} cond nip ;
M: f parse-sockaddr nip ;
: addrinfo>addrspec ( addrinfo -- addrspec )
- dup addrinfo-addr
- swap addrinfo-family addrspec-of-family
+ [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi
parse-sockaddr ;
: parse-addrinfo-list ( addrinfo -- seq )
- [ dup ]
- [ dup addrinfo-next swap addrinfo>addrspec ]
- [ ] unfold nip [ ] subset ;
+ [ addrinfo-next ] follow
+ [ addrinfo>addrspec ] map
+ [ ] subset ;
: prepare-resolve-host ( host serv passive? -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
M: object host-name ( -- name )
256 <byte-array> dup dup length gethostname
zero? [ "gethostname failed" throw ] unless
- alien>char-string ;
+ ascii alien>string ;
"Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
{ $subsection <server> }
{ $subsection accept }
-"The stream returned by " { $link accept } " holds the address specifier of the remote client:"
-{ $subsection client-stream-addr }
"Server sockets are closed by calling " { $link dispose } "."
$nl
"Address specifiers have the following interpretation with connection-oriented networking words:"
{ $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;
HELP: accept
-{ $values { "server" "a handle" } { "client" "a bidirectional stream" } }
-{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor."
-$nl
-"The returned client stream responds to the " { $link client-stream-addr } " word with the address of the incoming connection." }
+{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "addrspec" "an address specifier" } }
+{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." }
{ $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;
HELP: <datagram>
--- /dev/null
+IN: io.sockets.tests
+USING: io.sockets sequences math tools.test ;
+
+[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test
! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel io.backend namespaces continuations
-sequences arrays io.encodings io.nonblocking ;
+sequences arrays io.encodings io.nonblocking accessors ;
IN: io.sockets
TUPLE: local path ;
-C: <local> local
+: <local> ( path -- addrspec )
+ normalize-path local boa ;
TUPLE: inet4 host port ;
C: <inet> inet
-TUPLE: client-stream addr ;
+HOOK: ((client)) io-backend ( addrspec -- client-in client-out )
-: <client-stream> ( addrspec delegate -- stream )
- { set-client-stream-addr set-delegate }
- client-stream construct ;
-
-HOOK: (client) io-backend ( addrspec -- client-in client-out )
-
-GENERIC: client* ( addrspec -- client-in client-out )
-M: array client* [ (client) 2array ] attempt-all first2 ;
-M: object client* (client) ;
+GENERIC: (client) ( addrspec -- client-in client-out )
+M: array (client) [ ((client)) 2array ] attempt-all first2 ;
+M: object (client) ((client)) ;
: <client> ( addrspec encoding -- stream )
- >r client* r> <encoder-duplex> ;
+ >r (client) r> <encoder-duplex> ;
HOOK: (server) io-backend ( addrspec -- handle )
HOOK: (accept) io-backend ( server -- addrspec handle )
-: accept ( server -- client )
- [ (accept) dup <reader&writer> ] keep
- server-port-encoding <encoder-duplex>
- <client-stream> ;
+: accept ( server -- client addrspec )
+ [ (accept) dup <reader&writer> ] [ encoding>> ] bi
+ <encoder-duplex> swap ;
HOOK: <datagram> io-backend ( addrspec -- datagram )
HOOK: host-name io-backend ( -- string )
-M: inet client*
- dup inet-host swap inet-port f resolve-host
- dup empty? [ "Host name lookup failed" throw ] when
- client* ;
+M: inet (client)
+ [ host>> ] [ port>> ] bi f resolve-host
+ [ empty? [ "Host name lookup failed" throw ] when ]
+ [ (client) ]
+ bi ;
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;\r
\r
ARTICLE: "io.timeouts" "I/O timeout protocol"\r
-"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."\r
+"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."\r
{ $subsection timeout }\r
{ $subsection set-timeout }\r
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."\r
{ $subsection timed-out }\r
"A combinator to be used in operations which can time out:"\r
{ $subsection with-timeout }\r
-{ $see-also "stream-protocol" "io.launcher" } ;\r
+{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ;\r
\r
ABOUT: "io.timeouts"\r
! Copyright (C) 2008 Slava Pestov, Doug Coleman\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel calendar alarms io.streams.duplex ;\r
+USING: kernel calendar alarms io.streams.duplex io.encodings ;\r
IN: io.timeouts\r
\r
! Won't need this with new slot accessors\r
duplex-stream-in set-timeout\r
duplex-stream-out set-timeout ;\r
\r
+M: decoder set-timeout decoder-stream set-timeout ;\r
+\r
+M: encoder set-timeout encoder-stream set-timeout ;\r
+\r
GENERIC: timed-out ( obj -- )\r
\r
M: object timed-out drop ;\r
io.nonblocking sequences strings structs sbufs
threads unix vectors io.buffers io.backend io.encodings
io.streams.duplex math.parser continuations system libc
-qualified namespaces io.timeouts io.encodings.utf8 ;
+qualified namespaces io.timeouts io.encodings.utf8 accessors ;
QUALIFIED: io
IN: io.unix.backend
-MIXIN: unix-io
-
! I/O tasks
TUPLE: io-task port callbacks ;
-: io-task-fd io-task-port port-handle ;
+: io-task-fd port>> handle>> ;
: <io-task> ( port continuation/f class -- task )
- >r [ 1vector ] [ V{ } clone ] if* io-task construct-boa
- r> construct-delegate ; inline
-
-TUPLE: input-task ;
-
-: <input-task> ( port continuation class -- task )
- >r input-task <io-task> r> construct-delegate ; inline
+ new
+ swap [ 1vector ] [ V{ } clone ] if* >>callbacks
+ swap >>port ; inline
-TUPLE: output-task ;
+TUPLE: input-task < io-task ;
-: <output-task> ( port continuation class -- task )
- >r output-task <io-task> r> construct-delegate ; inline
+TUPLE: output-task < io-task ;
GENERIC: do-io-task ( task -- ? )
GENERIC: io-task-container ( mx task -- hashtable )
! I/O multiplexers
TUPLE: mx fd reads writes ;
-M: input-task io-task-container drop mx-reads ;
+M: input-task io-task-container drop reads>> ;
-M: output-task io-task-container drop mx-writes ;
+M: output-task io-task-container drop writes>> ;
-: <mx> ( -- mx ) f H{ } clone H{ } clone mx construct-boa ;
-
-: construct-mx ( class -- obj ) <mx> swap construct-delegate ;
+: new-mx ( class -- obj )
+ new
+ H{ } clone >>reads
+ H{ } clone >>writes ; inline
GENERIC: register-io-task ( task mx -- )
GENERIC: unregister-io-task ( task mx -- )
: (io-error) ( -- * ) err_no strerror throw ;
+: check-errno ( -- )
+ err_no dup zero? [ drop ] [ strerror throw ] if ;
+
: check-null ( n -- ) zero? [ (io-error) ] when ;
: io-error ( n -- ) 0 < [ (io-error) ] when ;
close ;
: report-error ( error port -- )
- [ "Error on fd " % dup port-handle # ": " % swap % ] "" make
- swap set-port-error ;
+ [ "Error on fd " % dup handle>> # ": " % swap % ] "" make
+ >>error drop ;
: ignorable-error? ( n -- ? )
- dup EAGAIN number= swap EINTR number= or ;
+ [ EAGAIN number= ] [ EINTR number= ] bi or ;
: defer-error ( port -- ? )
#! Return t if it is an unrecoverable error.
: handle-timeout ( port mx assoc -- )
>r swap port-handle r> delete-at* [
- "I/O operation cancelled" over io-task-port report-error
+ "I/O operation cancelled" over port>> report-error
pop-callbacks
] [
2drop
] if ;
: cancel-io-tasks ( port mx -- )
- 2dup
- dup mx-reads handle-timeout
- dup mx-writes handle-timeout ;
+ [ dup reads>> handle-timeout ]
+ [ dup writes>> handle-timeout ] 2bi ;
-M: unix-io cancel-io ( port -- )
+M: unix cancel-io ( port -- )
mx get-global cancel-io-tasks ;
! Readers
: reader-eof ( reader -- )
- dup buffer-empty? [ t over set-port-eof? ] when drop ;
+ dup buffer>> buffer-empty? [ t >>eof ] when drop ;
: (refill) ( port -- n )
- dup port-handle over buffer-end rot buffer-capacity read ;
+ [ handle>> ]
+ [ buffer>> buffer-end ]
+ [ buffer>> buffer-capacity ] tri read ;
: refill ( port -- ? )
#! Return f if there is a recoverable error
- dup buffer-empty? [
+ dup buffer>> buffer-empty? [
dup (refill) dup 0 >= [
- swap n>buffer t
+ swap buffer>> n>buffer t
] [
drop defer-error
] if
drop t
] if ;
-TUPLE: read-task ;
+TUPLE: read-task < input-task ;
: <read-task> ( port continuation -- task )
- read-task <input-task> ;
+ read-task <io-task> ;
M: read-task do-io-task
io-task-port dup refill
! Writers
: write-step ( port -- ? )
- dup port-handle over buffer@ pick buffer-length write
- dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ;
+ dup
+ [ handle>> ]
+ [ buffer>> buffer@ ]
+ [ buffer>> buffer-length ] tri
+ write dup 0 >=
+ [ swap buffer>> buffer-consume f ]
+ [ drop defer-error ] if ;
-TUPLE: write-task ;
+TUPLE: write-task < output-task ;
: <write-task> ( port continuation -- task )
- write-task <output-task> ;
+ write-task <io-task> ;
M: write-task do-io-task
- io-task-port dup buffer-empty? over port-error or
- [ 0 swap buffer-reset t ] [ write-step ] if ;
+ io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
+ [ 0 swap buffer>> buffer-reset t ] [ write-step ] if ;
: add-write-io-task ( port continuation -- )
- over port-handle mx get-global mx-writes at*
+ over handle>> mx get-global writes>> at*
[ io-task-callbacks push drop ]
[ drop <write-task> add-io-task ] if ;
: (wait-to-write) ( port -- )
[ add-write-io-task ] with-port-continuation drop ;
-M: port port-flush ( port -- )
- dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
+M: output-port port-flush ( port -- )
+ dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
-M: unix-io io-multiplex ( ms/f -- )
+M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
-M: unix-io (init-stdio) ( -- )
+M: unix (init-stdio) ( -- )
0 <reader>
1 <writer>
2 <writer> ;
! mx io-task for embedding an fd-based mx inside another mx
-TUPLE: mx-port mx ;
+TUPLE: mx-port < port mx ;
: <mx-port> ( mx -- port )
- dup mx-fd f mx-port <port>
- { set-mx-port-mx set-delegate } mx-port construct ;
+ dup fd>> mx-port <port> swap >>mx ;
-TUPLE: mx-task ;
+TUPLE: mx-task < io-task ;
: <mx-task> ( port -- task )
f mx-task <io-task> ;
M: mx-task do-io-task
- io-task-port mx-port-mx 0 swap wait-for-events f ;
+ port>> mx>> 0 swap wait-for-events f ;
: multiplexer-error ( n -- )
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
+
+: ?flag ( n mask symbol -- n )
+ pick rot bitand 0 > [ , ] [ drop ] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: io.unix.bsd
-USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
-io.launcher io.unix.launcher namespaces kernel assocs
-threads continuations ;
+USING: namespaces system kernel accessors assocs continuations
+unix
+io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ;
-! On Mac OS X, we use select() for the top-level
-! multiplexer, and we hang a kqueue off of it for process exit
-! notification.
-
-! kqueue is buggy with files and ptys so we can't use it as the
-! main multiplexer.
-
-MIXIN: bsd-io
-
-INSTANCE: bsd-io unix-io
-
-M: bsd-io init-io ( -- )
+M: bsd init-io ( -- )
<select-mx> mx set-global
<kqueue-mx> kqueue-mx set-global
- kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd
- 2dup mx get-global mx-reads set-at
- mx get-global mx-writes set-at ;
+ kqueue-mx get-global <mx-port> <mx-task>
+ dup io-task-fd
+ [ mx get-global reads>> set-at ]
+ [ mx get-global writes>> set-at ] 2bi ;
-M: bsd-io register-process ( process -- )
- process-handle kqueue-mx get-global add-pid-task ;
+M: bsd (monitor) ( path recursive? mailbox -- )
+ swap [ "Recursive kqueue monitors not supported" throw ] when
+ <vnode-monitor> ;
namespaces structs ;
IN: io.unix.epoll
-TUPLE: epoll-mx events ;
+TUPLE: epoll-mx < mx events ;
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
256 ; inline
: <epoll-mx> ( -- mx )
- epoll-mx construct-mx
+ epoll-mx new-mx
max-events epoll_create dup io-error over set-mx-fd
max-events "epoll-event" <c-array> over set-epoll-mx-events ;
epoll_ctl io-error ;
M: epoll-mx register-io-task ( task mx -- )
- 2dup EPOLL_CTL_ADD do-epoll-ctl
- delegate register-io-task ;
+ [ EPOLL_CTL_ADD do-epoll-ctl ] [ call-next-method ] 2bi ;
M: epoll-mx unregister-io-task ( task mx -- )
- 2dup delegate unregister-io-task
- EPOLL_CTL_DEL do-epoll-ctl ;
+ [ call-next-method ] [ EPOLL_CTL_DEL do-epoll-ctl ] 2bi ;
: wait-event ( mx timeout -- n )
>r { mx-fd epoll-mx-events } get-slots max-events
[ "/" ] [ "/etc/" parent-directory ] unit-test
[ "/" ] [ "/etc" parent-directory ] unit-test
[ "/" ] [ "/" parent-directory ] unit-test
+
+[ f ] [ "" root-directory? ] unit-test
+[ t ] [ "/" root-directory? ] unit-test
+[ t ] [ "//" root-directory? ] unit-test
+[ t ] [ "///////" root-directory? ] unit-test
+
+[ "/" ] [ "/" file-name ] unit-test
+[ "///" ] [ "///" file-name ] unit-test
+
+[ "/" ] [ "/" "../.." append-path ] unit-test
+[ "/" ] [ "/" "../../" append-path ] unit-test
+[ "/lib" ] [ "/" "../lib" append-path ] unit-test
+[ "/lib/" ] [ "/" "../lib/" append-path ] unit-test
+[ "/lib" ] [ "/" "../../lib" append-path ] unit-test
+[ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
+
+[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
+[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
+[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
+[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
+[ t ] [ "/foo" absolute-path? ] unit-test
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.nonblocking io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
-math.bitfields byte-arrays alien combinators combinators.cleave
-calendar io.encodings.binary ;
+math.bitfields byte-arrays alien combinators calendar
+io.encodings.binary accessors sequences strings system
+io.files.private ;
IN: io.unix.files
-M: unix-io cwd
+M: unix cwd ( -- path )
MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
[ (io-error) ] unless* ;
-M: unix-io cd
+M: unix cd ( path -- )
chdir io-error ;
: read-flags O_RDONLY ; inline
: open-read ( path -- fd )
O_RDONLY file-mode open dup io-error ;
-M: unix-io (file-reader) ( path -- stream )
+M: unix (file-reader) ( path -- stream )
open-read <reader> ;
: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
: open-write ( path -- fd )
write-flags file-mode open dup io-error ;
-M: unix-io (file-writer) ( path -- stream )
+M: unix (file-writer) ( path -- stream )
open-write <writer> ;
: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
append-flags file-mode open dup io-error
[ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ;
-M: unix-io (file-appender) ( path -- stream )
+M: unix (file-appender) ( path -- stream )
open-append <writer> ;
-: touch-mode
+: touch-mode ( -- n )
{ O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
-M: unix-io touch-file ( path -- )
+M: unix touch-file ( path -- )
+ normalize-path
touch-mode file-mode open
dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
close ;
-M: unix-io move-file ( from to -- )
- rename io-error ;
+M: unix move-file ( from to -- )
+ [ normalize-path ] bi@ rename io-error ;
-M: unix-io delete-file ( path -- )
- unlink io-error ;
+M: unix delete-file ( path -- )
+ normalize-path unlink io-error ;
-M: unix-io make-directory ( path -- )
- OCT: 777 mkdir io-error ;
+M: unix make-directory ( path -- )
+ normalize-path OCT: 777 mkdir io-error ;
-M: unix-io delete-directory ( path -- )
- rmdir io-error ;
+M: unix delete-directory ( path -- )
+ normalize-path rmdir io-error ;
: (copy-file) ( from to -- )
dup parent-directory make-directories
] with-disposal
] with-disposal ;
-M: unix-io copy-file ( from to -- )
+M: unix copy-file ( from to -- )
+ [ normalize-path ] bi@
[ (copy-file) ]
- [ swap file-info file-info-permissions chmod io-error ]
+ [ swap file-info permissions>> chmod io-error ]
2bi ;
: stat>type ( stat -- type )
- stat-st_mode {
- { [ dup S_ISREG ] [ +regular-file+ ] }
- { [ dup S_ISDIR ] [ +directory+ ] }
- { [ dup S_ISCHR ] [ +character-device+ ] }
- { [ dup S_ISBLK ] [ +block-device+ ] }
- { [ dup S_ISFIFO ] [ +fifo+ ] }
- { [ dup S_ISLNK ] [ +symbolic-link+ ] }
- { [ dup S_ISSOCK ] [ +socket+ ] }
- { [ t ] [ +unknown+ ] }
- } cond nip ;
+ stat-st_mode S_IFMT bitand {
+ { S_IFREG [ +regular-file+ ] }
+ { S_IFDIR [ +directory+ ] }
+ { S_IFCHR [ +character-device+ ] }
+ { S_IFBLK [ +block-device+ ] }
+ { S_IFIFO [ +fifo+ ] }
+ { S_IFLNK [ +symbolic-link+ ] }
+ { S_IFSOCK [ +socket+ ] }
+ [ drop +unknown+ ]
+ } case ;
: stat>file-info ( stat -- info )
{
[ stat-st_mode ]
[ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
-M: unix-io file-info ( path -- info )
- stat* stat>file-info ;
+M: unix file-info ( path -- info )
+ normalize-path stat* stat>file-info ;
-M: unix-io link-info ( path -- info )
- lstat* stat>file-info ;
+M: unix link-info ( path -- info )
+ normalize-path lstat* stat>file-info ;
+
+M: unix make-link ( path1 path2 -- )
+ normalize-path symlink io-error ;
+
+M: unix read-link ( path -- path' )
+ normalize-path
+ PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
+ dup io-error head-slice >string ;
USING: kernel io.nonblocking io.unix.backend math.bitfields
-unix io.files.unique.backend ;
+unix io.files.unique.backend system ;
IN: io.unix.files.unique
: open-unique-flags ( -- flags )
{ O_RDWR O_CREAT O_EXCL } flags ;
-M: unix-io (make-unique-file) ( path -- duplex-stream )
- open-unique-flags file-mode open dup io-error
- <writer> ;
+M: unix (make-unique-file) ( path -- )
+ open-unique-flags file-mode open dup io-error close ;
-M: unix-io temporary-path ( -- path ) "/tmp" ;
+M: unix temporary-path ( -- path ) "/tmp" ;
-IN: io.unix.freebsd
-USING: io.unix.bsd io.backend ;
+USING: io.unix.bsd io.backend system ;
-TUPLE: freebsd-io ;
-
-INSTANCE: freebsd-io bsd-io
-
-T{ freebsd-io } set-io-backend
+freebsd set-io-backend
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel io.nonblocking io.unix.backend
-sequences assocs unix unix.time unix.kqueue unix.process math namespaces
-combinators threads vectors io.launcher
-io.unix.launcher ;
+USING: alien.c-types kernel math math.bitfields namespaces
+locals accessors combinators threads vectors hashtables
+sequences assocs continuations sets
+unix unix.time unix.kqueue unix.process
+io.nonblocking io.unix.backend io.launcher io.unix.launcher
+io.monitors ;
IN: io.unix.kqueue
-TUPLE: kqueue-mx events ;
+TUPLE: kqueue-mx < mx events monitors ;
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
256 ; inline
: <kqueue-mx> ( -- mx )
- kqueue-mx construct-mx
- kqueue dup io-error over set-mx-fd
- max-events "kevent" <c-array> over set-kqueue-mx-events ;
+ kqueue-mx new-mx
+ H{ } clone >>monitors
+ kqueue dup io-error >>fd
+ max-events "kevent" <c-array> >>events ;
GENERIC: io-task-filter ( task -- n )
M: output-task io-task-filter drop EVFILT_WRITE ;
+GENERIC: io-task-fflags ( task -- n )
+
+M: io-task io-task-fflags drop 0 ;
+
: make-kevent ( task flags -- event )
"kevent" <c-object>
tuck set-kevent-flags
over io-task-fd over set-kevent-ident
+ over io-task-fflags over set-kevent-fflags
swap io-task-filter over set-kevent-filter ;
: register-kevent ( kevent mx -- )
- mx-fd swap 1 f 0 f kevent
+ fd>> swap 1 f 0 f kevent
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
M: kqueue-mx register-io-task ( task mx -- )
- over EV_ADD make-kevent over register-kevent
- delegate register-io-task ;
+ [ >r EV_ADD make-kevent r> register-kevent ]
+ [ call-next-method ]
+ 2bi ;
M: kqueue-mx unregister-io-task ( task mx -- )
- 2dup delegate unregister-io-task
- swap EV_DELETE make-kevent swap register-kevent ;
+ [ call-next-method ]
+ [ >r EV_DELETE make-kevent r> register-kevent ]
+ 2bi ;
: wait-kevent ( mx timespec -- n )
- >r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent
+ >r [ fd>> f 0 ] keep events>> max-events r> kevent
dup multiplexer-error ;
-: kevent-read-task ( mx fd -- )
- over mx-reads at handle-io-task ;
+:: kevent-read-task ( mx fd kevent -- )
+ mx fd mx reads>> at handle-io-task ;
-: kevent-write-task ( mx fd -- )
- over mx-reads at handle-io-task ;
+:: kevent-write-task ( mx fd kevent -- )
+ mx fd mx writes>> at handle-io-task ;
-: kevent-proc-task ( pid -- )
- dup wait-for-pid swap find-process
+:: kevent-proc-task ( mx pid kevent -- )
+ pid wait-for-pid
+ pid find-process
dup [ swap notify-exit ] [ 2drop ] if ;
+: parse-action ( mask -- changed )
+ [
+ NOTE_DELETE +remove-file+ ?flag
+ NOTE_WRITE +modify-file+ ?flag
+ NOTE_EXTEND +modify-file+ ?flag
+ NOTE_ATTRIB +modify-file+ ?flag
+ NOTE_RENAME +rename-file+ ?flag
+ NOTE_REVOKE +remove-file+ ?flag
+ drop
+ ] { } make prune ;
+
+:: kevent-vnode-task ( mx kevent fd -- )
+ ""
+ kevent kevent-fflags parse-action
+ fd mx monitors>> at queue-change ;
+
: handle-kevent ( mx kevent -- )
- dup kevent-ident swap kevent-filter {
+ [ ] [ kevent-ident ] [ kevent-filter ] tri {
{ [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
{ [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
- { [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] }
+ { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
+ { [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
} cond ;
: handle-kevents ( mx n -- )
- [ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
+ [ over events>> kevent-nth handle-kevent ] with each ;
M: kqueue-mx wait-for-events ( ms mx -- )
swap dup [ make-timespec ] when
dupd wait-kevent handle-kevents ;
+! Procs
: make-proc-kevent ( pid -- kevent )
"kevent" <c-object>
tuck set-kevent-ident
EVFILT_PROC over set-kevent-filter
NOTE_EXIT over set-kevent-fflags ;
-: add-pid-task ( pid mx -- )
+: register-pid-task ( pid mx -- )
swap make-proc-kevent swap register-kevent ;
+
+! VNodes
+TUPLE: vnode-monitor < monitor fd ;
+
+: vnode-fflags ( -- n )
+ {
+ NOTE_DELETE
+ NOTE_WRITE
+ NOTE_EXTEND
+ NOTE_ATTRIB
+ NOTE_LINK
+ NOTE_RENAME
+ NOTE_REVOKE
+ } flags ;
+
+: make-vnode-kevent ( fd flags -- kevent )
+ "kevent" <c-object>
+ tuck set-kevent-flags
+ tuck set-kevent-ident
+ EVFILT_VNODE over set-kevent-filter
+ vnode-fflags over set-kevent-fflags ;
+
+: register-monitor ( monitor mx -- )
+ >r dup fd>> r>
+ [ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
+ [ monitors>> set-at ] 3bi ;
+
+: unregister-monitor ( monitor mx -- )
+ >r fd>> r>
+ [ monitors>> delete-at ]
+ [ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
+
+: <vnode-monitor> ( path mailbox -- monitor )
+ >r [ O_RDONLY 0 open dup io-error ] keep r>
+ vnode-monitor new-monitor swap >>fd
+ [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
+
+M: vnode-monitor dispose
+ [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;
IN: io.unix.launcher.tests
USING: io.files tools.test io.launcher arrays io namespaces
-continuations math io.encodings.ascii io.encodings.latin1
-accessors kernel sequences ;
+continuations math io.encodings.binary io.encodings.ascii
+accessors kernel sequences io.encodings.utf8 ;
[ ] [
[ "launcher-test-1" temp-file delete-file ] ignore-errors
[ ] [
2 [
- "launcher-test-1" temp-file ascii <file-appender> [
+ "launcher-test-1" temp-file binary <file-appender> [
<process>
swap >>stdout
"echo Hello" >>command
<process>
"env" >>command
{ { "A" "B" } } >>environment
- latin1 <process-stream> lines
+ ascii <process-stream> lines
"A=B" swap member?
] unit-test
"env" >>command
{ { "A" "B" } } >>environment
+replace-environment+ >>environment-mode
- latin1 <process-stream> lines
+ ascii <process-stream> lines
+] unit-test
+
+[ "hi\n" ] [
+ temp-directory [
+ [ "aloha" delete-file ] ignore-errors
+ <process>
+ { "echo" "hi" } >>command
+ "aloha" >>stdout
+ try-process
+ ] with-directory
+ temp-directory "aloha" append-path
+ utf8 file-contents
] unit-test
io.unix.files io.nonblocking sequences kernel namespaces math
system alien.c-types debugger continuations arrays assocs
combinators unix.process strings threads unix
-io.unix.launcher.parser io.encodings.latin1 accessors new-slots ;
+io.unix.launcher.parser accessors io.files io.files.private ;
IN: io.unix.launcher
! Search unix first
: assoc>env ( assoc -- env )
[ "=" swap 3append ] { } assoc>map ;
+: setup-priority ( process -- process )
+ dup priority>> [
+ H{
+ { +lowest-priority+ 20 }
+ { +low-priority+ 10 }
+ { +normal-priority+ 0 }
+ { +high-priority+ -10 }
+ { +highest-priority+ -20 }
+ { +realtime-priority+ -20 }
+ } at set-priority
+ ] when* ;
+
: redirect-fd ( oldfd fd -- )
2dup = [ 2drop ] [ dupd dup2 io-error close ] if ;
-: reset-fd ( fd -- ) F_SETFL 0 fcntl io-error ;
+: reset-fd ( fd -- )
+ #! We drop the error code because on *BSD, fcntl of
+ #! /dev/null fails.
+ F_SETFL 0 fcntl drop ;
: redirect-inherit ( obj mode fd -- )
2nip reset-fd ;
: redirect-file ( obj mode fd -- )
- >r file-mode open dup io-error r> redirect-fd ;
+ >r >r normalize-path r> file-mode
+ open dup io-error r> redirect-fd ;
: redirect-closed ( obj mode fd -- )
>r >r drop "/dev/null" r> r> redirect-file ;
{ [ pick string? ] [ redirect-file ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick +inherit+ eq? ] [ redirect-closed ] }
- { [ t ] [ redirect-stream ] }
+ [ redirect-stream ]
} cond ;
: ?closed dup +closed+ eq? [ drop "/dev/null" ] when ;
: setup-redirection ( process -- process )
dup stdin>> ?closed read-flags 0 redirect
dup stdout>> ?closed write-flags 1 redirect
- dup stderr>> dup +stdout+ eq?
- [ drop 1 2 dup2 io-error ] [ ?closed write-flags 2 redirect ] if ;
+ dup stderr>> dup +stdout+ eq? [
+ drop 1 2 dup2 io-error
+ ] [
+ ?closed write-flags 2 redirect
+ ] if ;
-: spawn-process ( process -- * )
- [
- setup-redirection
- dup pass-environment? [
- dup get-environment set-os-envs
- ] when
+: setup-environment ( process -- process )
+ dup pass-environment? [
+ dup get-environment set-os-envs
+ ] when ;
- get-arguments exec-args-with-path
- (io-error)
- ] [ 255 exit ] recover ;
+: spawn-process ( process -- * )
+ [ setup-priority ] [ 250 _exit ] recover
+ [ setup-redirection ] [ 251 _exit ] recover
+ [ current-directory get (normalize-path) cd ] [ 252 _exit ] recover
+ [ setup-environment ] [ 253 _exit ] recover
+ [ get-arguments exec-args-with-path ] [ 254 _exit ] recover
+ 255 _exit ;
-M: unix-io current-process-handle ( -- handle ) getpid ;
+M: unix current-process-handle ( -- handle ) getpid ;
-M: unix-io run-process* ( process -- pid )
+M: unix run-process* ( process -- pid )
[ spawn-process ] curry [ ] with-fork ;
-M: unix-io kill-process* ( pid -- )
+M: unix kill-process* ( pid -- )
SIGTERM kill io-error ;
: open-pipe ( -- pair )
2dup first close second close
>r first 0 dup2 drop r> second 1 dup2 drop ;
-M: unix-io (process-stream)
+M: unix (process-stream)
>r open-pipe open-pipe r>
[ >r setup-stdio-pipe r> spawn-process ] curry
[ -rot 2dup second close first close ]
! Inefficient process wait polling, used on Linux and Solaris.
! On BSD and Mac OS X, we use kqueue() which scales better.
-: wait-for-processes ( -- ? )
+M: unix wait-for-processes ( -- ? )
-1 0 <int> tuck WNOHANG waitpid
dup 0 <= [
2drop t
2drop f
] if
] if ;
-
-: start-wait-thread ( -- )
- [ wait-for-processes [ 250 sleep ] when t ]
- "Process reaper" spawn-server drop ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io.backend io.monitors io.monitors.private
-io.files io.buffers io.nonblocking io.timeouts io.unix.backend
-io.unix.select io.unix.launcher unix.linux.inotify assocs
-namespaces threads continuations init math
-alien.c-types alien vocabs.loader ;
+USING: kernel io.backend io.monitors io.unix.backend
+io.unix.select io.unix.linux.monitors system namespaces ;
IN: io.unix.linux
-TUPLE: linux-io ;
+M: linux init-io ( -- )
+ <select-mx> mx set-global ;
-INSTANCE: linux-io unix-io
-
-TUPLE: linux-monitor ;
-
-: <linux-monitor> ( wd -- monitor )
- linux-monitor construct-simple-monitor ;
-
-TUPLE: inotify watches ;
-
-: watches ( -- assoc ) inotify get-global inotify-watches ;
-
-: wd>monitor ( wd -- monitor ) watches at ;
-
-: <inotify> ( -- port/f )
- H{ } clone
- inotify_init dup 0 < [ 2drop f ] [
- inotify <buffered-port>
- { set-inotify-watches set-delegate } inotify construct
- ] if ;
-
-: inotify-fd inotify get-global port-handle ;
-
-: (add-watch) ( path mask -- wd )
- inotify-fd -rot inotify_add_watch dup io-error ;
-
-: check-existing ( wd -- )
- watches key? [
- "Cannot open multiple monitors for the same file" throw
- ] when ;
-
-: add-watch ( path mask -- monitor )
- (add-watch) dup check-existing
- [ <linux-monitor> dup ] keep watches set-at ;
-
-: remove-watch ( monitor -- )
- dup simple-monitor-handle watches delete-at
- simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ;
-
-: check-inotify
- inotify get [
- "inotify is not supported by this Linux release" throw
- ] unless ;
-
-M: linux-io <monitor> ( path recursive? -- monitor )
- check-inotify
- drop IN_CHANGE_EVENTS add-watch ;
-
-M: linux-monitor dispose ( monitor -- )
- dup delegate dispose remove-watch ;
-
-: ?flag ( n mask symbol -- n )
- pick rot bitand 0 > [ , ] [ drop ] if ;
-
-: parse-action ( mask -- changed )
- [
- IN_CREATE +add-file+ ?flag
- IN_DELETE +remove-file+ ?flag
- IN_DELETE_SELF +remove-file+ ?flag
- IN_MODIFY +modify-file+ ?flag
- IN_ATTRIB +modify-file+ ?flag
- IN_MOVED_FROM +rename-file+ ?flag
- IN_MOVED_TO +rename-file+ ?flag
- IN_MOVE_SELF +rename-file+ ?flag
- drop
- ] { } make ;
-
-: parse-file-notify ( buffer -- changed path )
- { inotify-event-name inotify-event-mask } get-slots
- parse-action swap alien>char-string ;
-
-: events-exhausted? ( i buffer -- ? )
- buffer-fill >= ;
-
-: inotify-event@ ( i buffer -- alien )
- buffer-ptr <displaced-alien> ;
-
-: next-event ( i buffer -- i buffer )
- 2dup inotify-event@
- inotify-event-len "inotify-event" heap-size +
- swap >r + r> ;
-
-: parse-file-notifications ( i buffer -- )
- 2dup events-exhausted? [ 2drop ] [
- 2dup inotify-event@ dup inotify-event-wd wd>monitor [
- monitor-queue [
- parse-file-notify changed-file
- ] bind
- ] keep notify-callback
- next-event parse-file-notifications
- ] if ;
-
-: read-notifications ( port -- )
- dup refill drop
- 0 over parse-file-notifications
- 0 swap buffer-reset ;
-
-TUPLE: inotify-task ;
-
-: <inotify-task> ( port -- task )
- f inotify-task <input-task> ;
-
-: init-inotify ( mx -- )
- <inotify> dup inotify set-global
- <inotify-task> swap register-io-task ;
-
-M: inotify-task do-io-task ( task -- )
- io-task-port read-notifications f ;
-
-M: linux-io init-io ( -- )
- <select-mx> dup mx set-global init-inotify ;
-
-T{ linux-io } set-io-backend
-
-[ start-wait-thread ] "io.unix.linux" add-init-hook
+linux set-io-backend
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io.backend io.monitors io.monitors.recursive
+io.files io.buffers io.monitors io.nonblocking io.timeouts
+io.unix.backend io.unix.select io.encodings.utf8
+unix.linux.inotify assocs namespaces threads continuations init
+math math.bitfields sets alien alien.strings alien.c-types
+vocabs.loader accessors system hashtables ;
+IN: io.unix.linux.monitors
+
+SYMBOL: watches
+
+SYMBOL: inotify
+
+TUPLE: linux-monitor < monitor wd inotify watches ;
+
+: <linux-monitor> ( wd path mailbox -- monitor )
+ linux-monitor new-monitor
+ inotify get >>inotify
+ watches get >>watches
+ swap >>wd ;
+
+: wd>monitor ( wd -- monitor ) watches get at ;
+
+: <inotify> ( -- port/f )
+ inotify_init dup 0 < [ drop f ] [ <reader> ] if ;
+
+: inotify-fd inotify get handle>> ;
+
+: check-existing ( wd -- )
+ watches get key? [
+ "Cannot open multiple monitors for the same file" throw
+ ] when ;
+
+: (add-watch) ( path mask -- wd )
+ inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
+
+: add-watch ( path mask mailbox -- monitor )
+ >r
+ >r (normalize-path) r>
+ [ (add-watch) ] [ drop ] 2bi r>
+ <linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
+
+: check-inotify
+ inotify get [
+ "Calling <monitor> outside with-monitors" throw
+ ] unless ;
+
+M: linux (monitor) ( path recursive? mailbox -- monitor )
+ swap [
+ <recursive-monitor>
+ ] [
+ check-inotify
+ IN_CHANGE_EVENTS swap add-watch
+ ] if ;
+
+M: linux-monitor dispose ( monitor -- )
+ dup inotify>> closed>> [ drop ] [
+ [ [ wd>> ] [ watches>> ] bi delete-at ]
+ [
+ [ inotify>> handle>> ] [ wd>> ] bi
+ inotify_rm_watch io-error
+ ] bi
+ ] if ;
+
+: ignore-flags? ( mask -- ? )
+ {
+ IN_DELETE_SELF
+ IN_MOVE_SELF
+ IN_UNMOUNT
+ IN_Q_OVERFLOW
+ IN_IGNORED
+ } flags bitand 0 > ;
+
+: parse-action ( mask -- changed )
+ [
+ IN_CREATE +add-file+ ?flag
+ IN_DELETE +remove-file+ ?flag
+ IN_MODIFY +modify-file+ ?flag
+ IN_ATTRIB +modify-file+ ?flag
+ IN_MOVED_FROM +rename-file-old+ ?flag
+ IN_MOVED_TO +rename-file-new+ ?flag
+ drop
+ ] { } make prune ;
+
+: parse-file-notify ( buffer -- path changed )
+ dup inotify-event-mask ignore-flags? [
+ drop f f
+ ] [
+ [ inotify-event-name utf8 alien>string ]
+ [ inotify-event-mask parse-action ] bi
+ ] if ;
+
+: events-exhausted? ( i buffer -- ? )
+ fill>> >= ;
+
+: inotify-event@ ( i buffer -- alien )
+ ptr>> <displaced-alien> ;
+
+: next-event ( i buffer -- i buffer )
+ 2dup inotify-event@
+ inotify-event-len "inotify-event" heap-size +
+ swap >r + r> ;
+
+: parse-file-notifications ( i buffer -- )
+ 2dup events-exhausted? [ 2drop ] [
+ 2dup inotify-event@ dup inotify-event-wd wd>monitor
+ >r parse-file-notify r> queue-change
+ next-event parse-file-notifications
+ ] if ;
+
+: inotify-read-loop ( port -- )
+ dup wait-to-read1
+ 0 over buffer>> parse-file-notifications
+ 0 over buffer>> buffer-reset
+ inotify-read-loop ;
+
+: inotify-read-thread ( port -- )
+ [ inotify-read-loop ] curry ignore-errors ;
+
+M: linux init-monitors
+ H{ } clone watches set
+ <inotify> [
+ [ inotify set ]
+ [
+ [ inotify-read-thread ] curry
+ "Linux monitor thread" spawn drop
+ ] bi
+ ] [
+ "Linux kernel version is too old" throw
+ ] if* ;
+
+M: linux dispose-monitors
+ inotify get dispose ;
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents
+continuations kernel sequences namespaces arrays system locals
+accessors ;
IN: io.unix.macosx
-USING: io.unix.bsd io.backend io.monitors io.monitors.private
-continuations kernel core-foundation.fsevents sequences
-namespaces arrays ;
-TUPLE: macosx-io ;
-
-INSTANCE: macosx-io bsd-io
-
-T{ macosx-io } set-io-backend
-
-TUPLE: macosx-monitor ;
+TUPLE: macosx-monitor < monitor handle ;
: enqueue-notifications ( triples monitor -- )
- tuck monitor-queue
- [ [ first { +modify-file+ } swap changed-file ] each ] bind
- notify-callback ;
+ [
+ >r first { +modify-file+ } r> queue-change
+ ] curry each ;
-M: macosx-io <monitor>
- drop
- f macosx-monitor construct-simple-monitor
+M:: macosx (monitor) ( path recursive? mailbox -- monitor )
+ path mailbox macosx-monitor new-monitor
dup [ enqueue-notifications ] curry
- rot 1array 0 0 <event-stream>
- over set-simple-monitor-handle ;
+ path 1array 0 0 <event-stream> >>handle ;
M: macosx-monitor dispose
- dup simple-monitor-handle dispose delegate dispose ;
+ handle>> dispose ;
+
+macosx set-io-backend
>r f -roll r> open-r/w [ 0 mmap ] keep
over MAP_FAILED = [ close (io-error) ] when ;
-M: unix-io <mapped-file> ( path length -- obj )
+M: unix <mapped-file> ( path length -- obj )
swap >r
dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
- r> mmap-open f mapped-file construct-boa ;
+ r> mmap-open f mapped-file boa ;
-M: unix-io close-mapped-file ( mmap -- )
+M: unix close-mapped-file ( mmap -- )
[ mapped-file-address ] keep
[ mapped-file-length munmap ] keep
mapped-file-handle close
-IN: io.unix.netbsd
-USING: io.unix.bsd io.backend ;
+USING: io.unix.bsd io.backend system ;
-TUPLE: netbsd-io ;
-
-INSTANCE: netbsd-io bsd-io
-
-T{ netbsd-io } set-io-backend
+netbsd set-io-backend
-IN: io.unix.openbsd
-USING: io.unix.bsd io.backend core-foundation.fsevents ;
+USING: io.unix.bsd io.backend system ;
-TUPLE: openbsd-io ;
-
-INSTANCE: openbsd-io bsd-io
-
-T{ openbsd-io } set-io-backend
+openbsd set-io-backend
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel io.nonblocking io.unix.backend
-bit-arrays sequences assocs unix math namespaces structs ;
+bit-arrays sequences assocs unix math namespaces structs
+accessors ;
IN: io.unix.select
-TUPLE: select-mx read-fdset write-fdset ;
+TUPLE: select-mx < mx read-fdset write-fdset ;
! Factor's bit-arrays are an array of bytes, OS X expects
! FD_SET to be an array of cells, so we have to account for
little-endian? [ BIN: 11000 bitxor ] unless ; inline
: <select-mx> ( -- mx )
- select-mx construct-mx
- FD_SETSIZE 8 * <bit-array> over set-select-mx-read-fdset
- FD_SETSIZE 8 * <bit-array> over set-select-mx-write-fdset ;
+ select-mx new-mx
+ FD_SETSIZE 8 * <bit-array> >>read-fdset
+ FD_SETSIZE 8 * <bit-array> >>write-fdset ;
: clear-nth ( n seq -- ? )
- [ nth ] 2keep f -rot set-nth ;
+ [ nth ] [ f -rot set-nth ] 2bi ;
: handle-fd ( fd task fdset mx -- )
roll munge rot clear-nth
[ handle-fd ] 2curry assoc-each ;
: init-fdset ( tasks fdset -- )
- ! dup clear-bits
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
: read-fdset/tasks
- { mx-reads select-mx-read-fdset } get-slots ;
+ [ reads>> ] [ read-fdset>> ] bi ;
: write-fdset/tasks
- { mx-writes select-mx-write-fdset } get-slots ;
+ [ writes>> ] [ write-fdset>> ] bi ;
-: max-fd dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
+: max-fd ( assoc -- n )
+ dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
: num-fds ( mx -- n )
- dup mx-reads max-fd swap mx-writes max-fd max 1+ ;
+ [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
: init-fdsets ( mx -- nfds read write except )
- [ num-fds ] keep
- [ read-fdset/tasks tuck init-fdset ] keep
- write-fdset/tasks tuck init-fdset
+ [ num-fds ]
+ [ read-fdset/tasks tuck init-fdset ]
+ [ write-fdset/tasks tuck init-fdset ] tri
f ;
M: select-mx wait-for-events ( ms mx -- )
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.strings generic kernel math
+namespaces threads sequences byte-arrays io.nonblocking
+io.binary io.unix.backend io.streams.duplex io.sockets.impl
+io.backend io.files io.files.private io.encodings.utf8
+math.parser continuations libc combinators system accessors
+qualified unix ;
+
+EXCLUDE: io => read write close ;
+EXCLUDE: io.sockets => accept ;
-! We need to fiddle with the exact search order here, since
-! unix::accept shadows streams::accept.
-USING: alien alien.c-types generic io kernel math namespaces
-io.nonblocking parser threads unix sequences
-byte-arrays io.sockets io.binary io.unix.backend
-io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators ;
IN: io.unix.sockets
: pending-init-error ( port -- )
: sockopt ( fd level opt -- )
1 <int> "int" heap-size setsockopt io-error ;
-M: unix-io addrinfo-error ( n -- )
+M: unix addrinfo-error ( n -- )
dup zero? [ drop ] [ gai_strerror throw ] if ;
! Client sockets - TCP and Unix domain
: init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE sockopt ;
-TUPLE: connect-task ;
+TUPLE: connect-task < output-task ;
: <connect-task> ( port continuation -- task )
- connect-task <output-task> ;
+ connect-task <io-task> ;
M: connect-task do-io-task
- io-task-port dup port-handle f 0 write
+ port>> dup handle>> f 0 write
0 < [ defer-error ] [ drop t ] if ;
: wait-to-connect ( port -- )
[ <connect-task> add-io-task ] with-port-continuation drop ;
-M: unix-io (client) ( addrspec -- client-in client-out )
+M: unix ((client)) ( addrspec -- client-in client-out )
dup make-sockaddr/size >r >r
protocol-family SOCK_STREAM socket-fd
dup r> r> connect
] if ;
! Server sockets - TCP and Unix domain
-USE: unix
-
: init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR sockopt ;
-TUPLE: accept-task ;
+TUPLE: accept-task < input-task ;
: <accept-task> ( port continuation -- task )
- accept-task <input-task> ;
+ accept-task <io-task> ;
: accept-sockaddr ( port -- fd sockaddr )
dup port-handle swap server-port-addr sockaddr-type
: wait-to-accept ( server -- )
[ <accept-task> add-io-task ] with-port-continuation drop ;
-USE: io.sockets
-
: server-fd ( addrspec type -- fd )
>r dup protocol-family r> socket-fd
dup init-server-socket
dup rot make-sockaddr/size bind
zero? [ dup close (io-error) ] unless ;
-M: unix-io (server) ( addrspec -- handle )
+M: unix (server) ( addrspec -- handle )
SOCK_STREAM server-fd
dup 10 listen zero? [ dup close (io-error) ] unless ;
-M: unix-io (accept) ( server -- addrspec handle )
+M: unix (accept) ( server -- addrspec handle )
#! Wait for a client connection.
- dup check-server-port
- dup wait-to-accept
- dup pending-error
- dup server-port-client-addr
- swap server-port-client ;
+ check-server-port
+ [ wait-to-accept ]
+ [ pending-error ]
+ [ [ client-addr>> ] [ client>> ] bi ] tri ;
! Datagram sockets - UDP and Unix domain
-M: unix-io <datagram>
+M: unix <datagram>
[ SOCK_DGRAM server-fd ] keep <datagram-port> ;
SYMBOL: receive-buffer
rot head
] if ;
-TUPLE: receive-task ;
+TUPLE: receive-task < input-task ;
: <receive-task> ( stream continuation -- task )
- receive-task <input-task> ;
+ receive-task <io-task> ;
M: receive-task do-io-task
io-task-port
: wait-receive ( stream -- )
[ <receive-task> add-io-task ] with-port-continuation drop ;
-M: unix-io receive ( datagram -- packet addrspec )
- dup check-datagram-port
- dup wait-receive
- dup pending-error
- dup datagram-port-packet
- swap datagram-port-packet-addr ;
+M: unix receive ( datagram -- packet addrspec )
+ check-datagram-port
+ [ wait-receive ]
+ [ pending-error ]
+ [ [ packet>> ] [ packet-addr>> ] bi ] tri ;
: do-send ( socket data sockaddr len -- n )
>r >r dup length 0 r> r> sendto ;
-TUPLE: send-task packet sockaddr len ;
+TUPLE: send-task < output-task packet sockaddr len ;
: <send-task> ( packet sockaddr len stream continuation -- task )
- send-task <output-task> [
+ send-task <io-task> [
{
set-send-task-packet
set-send-task-sockaddr
[ <send-task> add-io-task ] with-port-continuation
2drop 2drop ;
-M: unix-io send ( packet addrspec datagram -- )
- 3dup check-datagram-send
+M: unix send ( packet addrspec datagram -- )
+ check-datagram-send
[ >r make-sockaddr/size r> wait-send ] keep
pending-error ;
M: local sockaddr-type drop "sockaddr-un" c-type ;
M: local make-sockaddr
- local-path
+ path>> (normalize-path)
dup length 1 + max-un-path > [ "Path too long" throw ] when
"sockaddr-un" <c-object>
AF_UNIX over set-sockaddr-un-family
- dup sockaddr-un-path rot string>char-alien dup length memcpy ;
+ dup sockaddr-un-path rot utf8 string>alien dup length memcpy ;
M: local parse-sockaddr
drop
- sockaddr-un-path alien>char-string <local> ;
+ sockaddr-un-path utf8 alien>string <local> ;
socket-server <local>
ascii <server> [
- accept [
+ accept drop [
"Hello world" print flush
readln "XYZ" = "FOO" "BAR" ? print flush
] with-stream
USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
-io.unix.launcher io.unix.mmap io.backend
-combinators namespaces system vocabs.loader sequences ;
+io.unix.launcher io.unix.mmap io.backend combinators namespaces
+system vocabs.loader sequences words init ;
-"io.unix." os append require
+"io.unix." os word-name append require
: port-errored ( port -- )
win32-error-string swap set-port-error ;
-M: windows-ce-io io-multiplex ( ms -- )
+M: wince io-multiplex ( ms -- )
60 60 * 1000 * or (sleep) ;
-M: windows-ce-io add-completion ( handle -- ) drop ;
+M: wince add-completion ( handle -- ) drop ;
GENERIC: wince-read ( port port-handle -- )
dup dup port-handle wince-write port-flush
] if ;
-M: windows-ce-io init-io ( -- )
+M: wince init-io ( -- )
init-winsock ;
LIBRARY: libc
FUNCTION: void* _getstdfilex int fd ;
FUNCTION: void* _fileno void* file ;
-M: windows-ce-io (init-stdio) ( -- )
+M: wince (init-stdio) ( -- )
#! We support Windows NT too, to make this I/O backend
#! easier to debug.
512 default-buffer-size [
- winnt? [
+ os winnt? [
STD_INPUT_HANDLE GetStdHandle
STD_OUTPUT_HANDLE GetStdHandle
STD_ERROR_HANDLE GetStdHandle
1 _getstdfilex _fileno
2 _getstdfilex _fileno
] if [ f <win32-file> ] 3apply
- rot <reader> -rot [ <writer> ] 2apply
+ rot <reader> -rot [ <writer> ] bi@
] with-variable ;
-USING: io.backend io.windows io.windows.ce.backend
-io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher
-namespaces io.windows.mmap ;
-IN: io.windows.ce
-
+USE: io.backend
+USE: io.windows
+USE: io.windows.ce.backend
+USE: io.windows.ce.files
+USE: io.windows.ce.sockets
+USE: io.windows.ce.launcher
+USE: io.windows.mmap system
USE: io.windows.files
-T{ windows-ce-io } set-io-backend
+USE: system
+
+wince set-io-backend
USING: alien alien.c-types combinators io io.backend io.buffers
io.files io.nonblocking io.windows kernel libc math namespaces
prettyprint sequences strings threads threads.private
-windows windows.kernel32 io.windows.ce.backend ;
+windows windows.kernel32 io.windows.ce.backend system ;
IN: windows.ce.files
-! M: windows-ce-io normalize-pathname ( string -- string )
+! M: wince normalize-path ( string -- string )
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
-M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
+M: wince CreateFile-flags ( DWORD -- DWORD )
FILE_ATTRIBUTE_NORMAL bitor ;
-M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
+M: wince FileArgs-overlapped ( port -- f ) drop f ;
: finish-read ( port status bytes-ret -- )
swap [ drop port-errored ] [ swap n>buffer ] if ;
io.nonblocking io.sockets io.sockets.impl io.windows kernel libc
math namespaces prettyprint qualified sequences strings threads
threads.private windows windows.kernel32 io.windows.ce.backend
-byte-arrays ;
+byte-arrays system ;
QUALIFIED: windows.winsock
IN: io.windows.ce
-M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
+M: wince WSASocket-flags ( -- DWORD ) 0 ;
M: win32-socket wince-read ( port port-handle -- )
win32-file-handle over buffer-end pick buffer-capacity 0
windows.winsock:WSAConnect
windows.winsock:winsock-error!=0/f ;
-M: windows-ce-io (client) ( addrspec -- reader writer )
+M: wince (client) ( addrspec -- reader writer )
do-connect <win32-socket> dup <reader&writer> ;
-M: windows-ce-io (server) ( addrspec -- handle )
+M: wince (server) ( addrspec -- handle )
windows.winsock:SOCK_STREAM server-fd
dup listen-on-socket
<win32-socket> ;
-M: windows-ce-io (accept) ( server -- client )
+M: wince (accept) ( server -- client )
[
dup check-server-port
[
<win32-socket> <reader&writer>
] with-timeout ;
-M: windows-ce-io <datagram> ( addrspec -- datagram )
+M: wince <datagram> ( addrspec -- datagram )
[
windows.winsock:SOCK_DGRAM server-fd <win32-socket>
] keep <datagram-port> ;
packet-size <byte-array> receive-buffer set-global
-M: windows-ce-io receive ( datagram -- packet addrspec )
+M: wince receive ( datagram -- packet addrspec )
dup check-datagram-port
[
port-handle win32-file-handle
dup length receive-buffer rot pick memcpy
receive-buffer make-WSABUF ;
-M: windows-ce-io send ( packet addrspec datagram -- )
+M: wince send ( packet addrspec datagram -- )
3dup check-datagram-send
port-handle win32-file-handle
rot send-WSABUF
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types io.files io.windows kernel
-math windows windows.kernel32 combinators.cleave
-windows.time calendar combinators math.functions
-sequences namespaces words symbols ;
+USING: alien.c-types io.backend io.files io.windows kernel math
+windows windows.kernel32 windows.time calendar combinators
+math.functions sequences namespaces words symbols system
+combinators.lib io.nonblocking destructors math.bitfields.lib ;
IN: io.windows.files
SYMBOLS: +read-only+ +hidden+ +system+
[ WIN32_FIND_DATA-ftLastWriteTime FILETIME>timestamp ]
! [ WIN32_FIND_DATA-ftLastAccessTime FILETIME>timestamp ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
: find-first-file-stat ( path -- WIN32_FIND_DATA )
"WIN32_FIND_DATA" <c-object> [
[ BY_HANDLE_FILE_INFORMATION-ftLastWriteTime FILETIME>timestamp ]
! [ BY_HANDLE_FILE_INFORMATION-ftLastAccessTime FILETIME>timestamp ]
} cleave
- \ file-info construct-boa ;
+ \ file-info boa ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[
get-file-information BY_HANDLE_FILE_INFORMATION>file-info
] if ;
-M: windows-nt-io file-info ( path -- info )
- get-file-information-stat ;
+M: winnt file-info ( path -- info )
+ normalize-path get-file-information-stat ;
+M: winnt link-info ( path -- info )
+ file-info ;
+
+: file-times ( path -- timestamp timestamp timestamp )
+ [
+ normalize-path open-existing dup close-always
+ "FILETIME" <c-object>
+ "FILETIME" <c-object>
+ "FILETIME" <c-object>
+ [ GetFileTime win32-error=0/f ] 3keep
+ [ FILETIME>timestamp >local-time ] 3apply
+ ] with-destructors ;
+
+: (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
+ [ timestamp>FILETIME ] 3apply
+ SetFileTime win32-error=0/f ;
+
+: set-file-times ( path timestamp/f timestamp/f timestamp/f -- )
+ #! timestamp order: creation access write
+ [
+ >r >r >r
+ normalize-path open-existing dup close-always
+ r> r> r> (set-file-times)
+ ] with-destructors ;
+
+: set-file-create-time ( path timestamp -- )
+ f f set-file-times ;
+
+: set-file-access-time ( path timestamp -- )
+ >r f r> f set-file-times ;
+
+: set-file-write-time ( path timestamp -- )
+ >r f f r> set-file-times ;
+
+M: winnt touch-file ( path -- )
+ [
+ normalize-path
+ maybe-create-file over close-always
+ [ drop ] [ f now dup (set-file-times) ] if
+ ] with-destructors ;
USING: kernel system io.files.unique.backend
-windows.kernel32 io.windows io.nonblocking ;
+windows.kernel32 io.windows io.nonblocking windows ;
IN: io.windows.files.unique
-M: windows-io (make-unique-file) ( path -- stream )
- GENERIC_WRITE CREATE_NEW 0 open-file 0 <win32-file> <writer> ;
+M: windows (make-unique-file) ( path -- )
+ GENERIC_WRITE CREATE_NEW 0 open-file
+ CloseHandle win32-error=0/f ;
-M: windows-io temporary-path ( -- path )
+M: windows temporary-path ( -- path )
"TEMP" os-env ;
--- /dev/null
+IN: io.windows.launcher.tests\r
+USING: tools.test io.windows.launcher ;\r
+\r
+[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test\r
+\r
+[ "bob \"mac arthur\"" ] [ { "bob" "mac arthur" } join-arguments ] unit-test\r
+\r
+[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test\r
+\r
+[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test\r
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays continuations destructors io
+USING: alien alien.c-types arrays continuations io
io.windows io.windows.nt.pipes libc io.nonblocking
-io.streams.duplex windows.types math windows.kernel32 windows
-namespaces io.launcher kernel sequences windows.errors assocs
+io.streams.duplex windows.types math windows.kernel32
+namespaces io.launcher kernel sequences windows.errors
splitting system threads init strings combinators
-io.backend new-slots accessors concurrency.flags ;
+io.backend accessors concurrency.flags io.files assocs
+io.files.private windows destructors ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
stdout-pipe stdin-pipe ;
: default-CreateProcess-args ( -- obj )
- CreateProcess-args construct-empty
- 0 >>dwCreateFlags
+ CreateProcess-args new
"STARTUPINFO" <c-object>
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
- TRUE >>bInheritHandles ;
+ TRUE >>bInheritHandles
+ 0 >>dwCreateFlags ;
: call-CreateProcess ( CreateProcess-args -- )
{
lpProcessInformation>>
} get-slots CreateProcess win32-error=0/f ;
+: count-trailing-backslashes ( str n -- str n )
+ >r "\\" ?tail [
+ r> 1+ count-trailing-backslashes
+ ] [
+ r>
+ ] if ;
+
+: fix-trailing-backslashes ( str -- str' )
+ 0 count-trailing-backslashes
+ 2 * CHAR: \\ <repetition> append ;
+
: escape-argument ( str -- newstr )
- CHAR: \s over member? [ "\"" swap "\"" 3append ] when ;
+ CHAR: \s over member? [
+ "\"" swap fix-trailing-backslashes "\"" 3append
+ ] when ;
: join-arguments ( args -- cmd-line )
[ escape-argument ] map " " join ;
+: lookup-priority ( process -- n )
+ priority>> {
+ { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
+ { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
+ { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
+ { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
+ { +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
+ { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
+ [ drop f ]
+ } case ;
+
: app-name/cmd-line ( process -- app-name cmd-line )
command>> dup string? [
" " split1
: fill-dwCreateFlags ( process args -- process args )
0
pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
- pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when
+ pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
+ pick lookup-priority [ bitor ] when*
>>dwCreateFlags ;
: fill-lpEnvironment ( process args -- process args )
HOOK: fill-redirection io-backend ( process args -- )
-M: windows-ce-io fill-redirection 2drop ;
+M: wince fill-redirection 2drop ;
: make-CreateProcess-args ( process -- args )
default-CreateProcess-args
- wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
+ os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
fill-dwCreateFlags
fill-lpEnvironment
fill-startup-info
nip ;
-M: windows-io current-process-handle ( -- handle )
+M: windows current-process-handle ( -- handle )
GetCurrentProcessId ;
-M: windows-io run-process* ( process -- handle )
+M: windows run-process* ( process -- handle )
[
+ current-directory get (normalize-path) cd
+
dup make-CreateProcess-args
tuck fill-redirection
dup call-CreateProcess
lpProcessInformation>>
] with-destructors ;
-M: windows-io kill-process* ( handle -- )
+M: windows kill-process* ( handle -- )
PROCESS_INFORMATION-hProcess
255 TerminateProcess win32-error=0/f ;
over process-handle dispose-process
notify-exit ;
-: wait-for-processes ( processes -- ? )
- keys dup
+M: windows wait-for-processes ( -- ? )
+ processes get keys dup
[ process-handle PROCESS_INFORMATION-hProcess ] map
dup length swap >c-void*-array 0 0
WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
-
-SYMBOL: wait-flag
-
-: wait-loop ( -- )
- processes get dup assoc-empty?
- [ drop wait-flag get-global lower-flag ]
- [ wait-for-processes [ 100 sleep ] when ] if ;
-
-: start-wait-thread ( -- )
- <flag> wait-flag set-global
- [ wait-loop t ] "Process wait" spawn-server drop ;
-
-M: windows-io register-process
- drop wait-flag get-global raise-flag ;
-
-[ start-wait-thread ] "io.windows.launcher" add-init-hook
USING: alien alien.c-types alien.syntax arrays continuations
destructors generic io.mmap io.nonblocking io.windows
kernel libc math namespaces quotations sequences windows
-windows.advapi32 windows.kernel32 io.backend ;
+windows.advapi32 windows.kernel32 io.backend system ;
IN: io.windows.mmap
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
HOOK: with-privileges io-backend ( seq quot -- ) inline
-M: windows-nt-io with-privileges
+M: winnt with-privileges
over [ [ t set-privilege ] each ] curry compose
swap [ [ f set-privilege ] each ] curry [ ] cleanup ;
-M: windows-ce-io with-privileges
+M: wince with-privileges
nip call ;
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
dup close-later
] with-privileges ;
-M: windows-io <mapped-file> ( path length -- mmap )
+M: windows <mapped-file> ( path length -- mmap )
[
swap
GENERIC_WRITE GENERIC_READ bitor
PAGE_READWRITE SEC_COMMIT bitor
FILE_MAP_ALL_ACCESS mmap-open
-rot 2array
- f \ mapped-file construct-boa
+ f \ mapped-file boa
] with-destructors ;
-M: windows-io close-mapped-file ( mapped-file -- )
+M: windows close-mapped-file ( mapped-file -- )
[
dup mapped-file-handle [ close-always ] each
mapped-file-address UnmapViewOfFile win32-error=0/f
USING: alien alien.c-types arrays assocs combinators
continuations destructors io io.backend io.nonblocking
io.windows libc kernel math namespaces sequences
-threads tuples.lib windows windows.errors
+threads classes.tuple.lib windows windows.errors
windows.kernel32 strings splitting io.files qualified ascii
-combinators.lib ;
+combinators.lib system accessors ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
: <master-completion-port> ( -- handle )
INVALID_HANDLE_VALUE f <completion-port> ;
-M: windows-nt-io add-completion ( handle -- )
+M: winnt add-completion ( handle -- )
master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? )
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ 2drop t ] }
- { [ dup eof? ] [ drop t swap set-port-eof? f ] }
- { [ t ] [ (win32-error-string) throw ] }
+ { [ dup eof? ] [ drop t >>eof drop f ] }
+ [ (win32-error-string) throw ]
} cond
] [
drop t
] if ;
: get-overlapped-result ( overlapped port -- bytes-transferred )
- dup port-handle win32-file-handle rot 0 <uint>
+ dup handle>> handle>> rot 0 <uint>
[ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ;
: save-callback ( overlapped port -- )
] [
dup eof? [
drop lookup-callback
- dup io-callback-port t swap set-port-eof?
+ dup port>> t >>eof drop
] [
(win32-error-string) swap lookup-callback
- [ io-callback-port set-port-error ] keep
- ] if io-callback-thread resume f
+ [ port>> set-port-error ] keep
+ ] if thread>> resume f
] if
] [
lookup-callback
: drain-overlapped ( timeout -- )
handle-overlapped [ 0 drain-overlapped ] unless ;
-M: windows-nt-io cancel-io
- port-handle win32-file-handle CancelIo drop ;
+M: winnt cancel-io
+ handle>> handle>> CancelIo drop ;
-M: windows-nt-io io-multiplex ( ms -- )
+M: winnt io-multiplex ( ms -- )
drain-overlapped ;
-M: windows-nt-io init-io ( -- )
+M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
H{ } clone io-hash set-global
windows.winsock:init-winsock ;
--- /dev/null
+USING: io.files kernel tools.test io.backend
+io.windows.nt.files splitting sequences ;
+IN: io.windows.nt.files.tests
+
+[ f ] [ "\\foo" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
+[ t ] [ "c:\\foo" absolute-path? ] unit-test
+[ t ] [ "c:" absolute-path? ] unit-test
+
+[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
+[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
+[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
+! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
+[ "c:\\" ] [ "c:\\" parent-directory ] unit-test
+[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test
+[ "c:" ] [ "c:" parent-directory ] unit-test
+[ "Z:" ] [ "Z:" parent-directory ] unit-test
+
+[ f ] [ "" root-directory? ] unit-test
+[ t ] [ "\\" root-directory? ] unit-test
+[ t ] [ "\\\\" root-directory? ] unit-test
+[ t ] [ "/" root-directory? ] unit-test
+[ t ] [ "//" root-directory? ] unit-test
+[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test
+[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test
+[ f ] [ "c:\\foo" root-directory? ] unit-test
+[ f ] [ "." root-directory? ] unit-test
+[ f ] [ ".." root-directory? ] unit-test
+
+[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
+
+[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\log.txt" append-path normalize-path
+] unit-test
+
+[ "\\\\?\\C:\\builds\\" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\.." append-path normalize-path
+] unit-test
+
+[ "\\\\?\\C:\\builds\\" ] [
+ "C:\\builds\\factor\\12345\\"
+ "..\\.." append-path normalize-path
+] unit-test
+
+[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
+[ t ] [ "" resource-path 2 tail exists? ] unit-test
USING: continuations destructors io.buffers io.files io.backend
io.timeouts io.nonblocking io.windows io.windows.nt.backend
-kernel libc math threads windows windows.kernel32
-alien.c-types alien.arrays sequences combinators combinators.lib
-sequences.lib ascii splitting alien strings assocs ;
+kernel libc math threads windows windows.kernel32 system
+alien.c-types alien.arrays alien.strings sequences combinators
+combinators.lib sequences.lib ascii splitting alien strings
+assocs namespaces io.files.private accessors ;
IN: io.windows.nt.files
-M: windows-nt-io cwd
+M: winnt cwd
MAX_UNICODE_PATH dup "ushort" <c-array>
[ GetCurrentDirectory win32-error=0/f ] keep
- alien>u16-string ;
+ utf16n alien>string ;
-M: windows-nt-io cd
+M: winnt cd
SetCurrentDirectory win32-error=0/f ;
: unicode-prefix ( -- seq )
"\\\\?\\" ; inline
-M: windows-nt-io root-directory? ( path -- ? )
- dup length 2 = [
- dup first Letter?
- swap second CHAR: : = and
- ] [
- drop f
- ] if ;
+M: winnt root-directory? ( path -- ? )
+ {
+ { [ dup empty? ] [ f ] }
+ { [ dup [ path-separator? ] all? ] [ t ] }
+ { [ dup right-trim-separators
+ { [ dup length 2 = ] [ dup second CHAR: : = ] } && nip ] [
+ t
+ ] }
+ [ f ]
+ } cond nip ;
+ERROR: not-absolute-path ;
: root-directory ( string -- string' )
{
[ dup length 2 >= ]
[ dup second CHAR: : = ]
[ dup first Letter? ]
- } && [ 2 head ] [ "Not an absolute path" throw ] if ;
+ } && [ 2 head ] [ not-absolute-path ] if ;
: prepend-prefix ( string -- string' )
- unicode-prefix swap append ;
-
-: windows-path+ ( cwd path -- newpath )
- {
- ! empty
- { [ dup empty? ] [ drop ] }
- ! ..
- { [ dup ".." = ] [ drop parent-directory prepend-prefix ] }
- ! \\\\?\\c:\\foo
- { [ dup unicode-prefix head? ] [ nip ] }
- ! ..\\foo
- { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-path+ ] }
- ! .\\foo
- { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] }
- ! \\foo
- { [ dup "\\" head? ] [ >r root-directory r> append prepend-prefix ] }
- ! c:\\foo
- { [ dup ?second CHAR: : = ] [ nip prepend-prefix ] }
- ! foo.txt
- { [ t ] [
- >r right-trim-separators "\\" r>
- left-trim-separators
- 3append prepend-prefix
- ] }
- } cond ;
+ dup unicode-prefix head? [
+ unicode-prefix prepend
+ ] unless ;
-M: windows-nt-io normalize-pathname ( string -- string )
- dup string? [ "Pathname must be a string" throw ] unless
- dup empty? [ "Empty pathname" throw ] when
+M: winnt normalize-path ( string -- string' )
+ (normalize-path)
{ { CHAR: / CHAR: \\ } } substitute
- cwd swap windows-path+
- [ "/\\." member? ] right-trim
- dup peek CHAR: : = [ "\\" append ] when ;
+ prepend-prefix ;
-M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
+M: winnt CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;
-M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
+M: winnt FileArgs-overlapped ( port -- overlapped )
make-overlapped ;
: update-file-ptr ( n port -- )
dup pending-error
tuck get-overlapped-result
dup pick update-file-ptr
- swap buffer-consume ;
+ swap buffer>> buffer-consume ;
: (flush-output) ( port -- )
dup make-FileArgs
>r FileArgs-lpOverlapped r>
[ save-callback ] 2keep
[ finish-flush ] keep
- dup buffer-empty? [ drop ] [ (flush-output) ] if
+ dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if
] [
2drop
] if ;
[ [ (flush-output) ] with-timeout ] with-destructors ;
M: port port-flush
- dup buffer-empty? [ dup flush-output ] unless drop ;
+ dup buffer>> buffer-empty? [ dup flush-output ] unless drop ;
: finish-read ( overlapped port -- )
dup pending-error
tuck get-overlapped-result dup zero? [
- drop t swap set-port-eof?
+ drop t >>eof drop
] [
- dup pick n>buffer
+ dup pick buffer>> n>buffer
swap update-file-ptr
] if ;
IN: io.windows.launcher.nt.tests\r
USING: io.launcher tools.test calendar accessors\r
namespaces kernel system arrays io io.files io.encodings.ascii\r
-sequences parser assocs hashtables ;\r
+sequences parser assocs hashtables math ;\r
\r
[ ] [\r
<process>\r
\r
"HOME" swap at "XXX" =\r
] unit-test\r
+\r
+2 [\r
+ [ ] [\r
+ <process>\r
+ "cmd.exe /c dir" >>command\r
+ "dir.txt" temp-file >>stdout\r
+ try-process\r
+ ] unit-test\r
+\r
+ [ ] [ "dir.txt" temp-file delete-file ] unit-test\r
+] times\r
io.windows libc io.nonblocking io.streams.duplex windows.types
math windows.kernel32 windows namespaces io.launcher kernel
sequences windows.errors assocs splitting system strings
-io.windows.launcher io.windows.nt.pipes io.backend
-combinators shuffle accessors locals ;
+io.windows.launcher io.windows.nt.pipes io.backend io.files
+io.files.private combinators shuffle accessors locals ;
IN: io.windows.nt.launcher
: duplicate-handle ( handle -- handle' )
drop 2nip null-pipe ;
:: redirect-file ( default path access-mode create-mode -- handle )
- path normalize-pathname
+ path normalize-path
access-mode
share-mode
security-attributes-inherit
create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
- CreateFile dup invalid-handle? dup close-later ;
+ CreateFile dup invalid-handle? dup close-always ;
: set-inherit ( handle ? -- )
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
{ [ pick +inherit+ eq? ] [ redirect-inherit ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick string? ] [ redirect-file ] }
- { [ t ] [ redirect-stream ] }
+ [ redirect-stream ]
} cond ;
: default-stdout ( args -- handle )
dup pipe-out f set-inherit
>>stdin-pipe ;
-M: windows-nt-io fill-redirection ( process args -- )
+M: winnt fill-redirection ( process args -- )
[ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
[ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
[ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
2drop ;
-M: windows-nt-io (process-stream)
+M: winnt (process-stream)
[
+ current-directory get (normalize-path) cd
+
dup make-CreateProcess-args
fill-stdout-pipe
--- /dev/null
+IN: io.windows.nt.monitors.tests\r
+USING: io.windows.nt.monitors tools.test ;\r
+\r
+\ fill-queue-thread must-infer\r
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types destructors io.windows
-io.windows.nt.backend kernel math windows windows.kernel32
-windows.types libc assocs alien namespaces continuations
-io.monitors io.monitors.private io.nonblocking io.buffers
-io.files io.timeouts io sequences hashtables sorting arrays
-combinators math.bitfields strings ;
+USING: alien alien.c-types libc destructors locals
+kernel math assocs namespaces continuations sequences hashtables
+sorting arrays combinators math.bitfields strings system
+accessors threads
+io.backend io.windows io.windows.nt.backend io.monitors
+io.nonblocking io.buffers io.files io.timeouts io
+windows windows.kernel32 windows.types ;
IN: io.windows.nt.monitors
: open-directory ( path -- handle )
+ normalize-path
FILE_LIST_DIRECTORY
share-mode
f
dup add-completion
f <win32-file> ;
-TUPLE: win32-monitor path recursive? ;
+TUPLE: win32-monitor-port < input-port recursive ;
-: <win32-monitor> ( path recursive? port -- monitor )
- (monitor) {
- set-win32-monitor-path
- set-win32-monitor-recursive?
- set-delegate
- } win32-monitor construct ;
+TUPLE: win32-monitor < monitor port ;
-M: windows-nt-io <monitor> ( path recursive? -- monitor )
- [
- over open-directory win32-monitor <buffered-port>
- <win32-monitor>
- ] with-destructors ;
-
-: begin-reading-changes ( monitor -- overlapped )
- dup port-handle win32-file-handle
- over buffer-ptr
- pick buffer-size
- roll win32-monitor-recursive? 1 0 ?
+: begin-reading-changes ( port -- overlapped )
+ {
+ [ handle>> handle>> ]
+ [ buffer>> ptr>> ]
+ [ buffer>> size>> ]
+ [ recursive>> 1 0 ? ]
+ } cleave
FILE_NOTIFY_CHANGE_ALL
0 <uint>
(make-overlapped)
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;
-: read-changes ( monitor -- bytes )
+: read-changes ( port -- bytes )
[
- [
- dup begin-reading-changes
- swap [ save-callback ] 2keep
- dup check-monitor ! we may have closed it...
- get-overlapped-result
- ] with-timeout
+ dup begin-reading-changes
+ swap [ save-callback ] 2keep
+ check-closed ! we may have closed it...
+ dup eof>> [ "EOF??" throw ] when
+ get-overlapped-result
] with-destructors ;
: parse-action ( action -- changed )
{
- { [ dup FILE_ACTION_ADDED = ] [ +add-file+ ] }
- { [ dup FILE_ACTION_REMOVED = ] [ +remove-file+ ] }
- { [ dup FILE_ACTION_MODIFIED = ] [ +modify-file+ ] }
- { [ dup FILE_ACTION_RENAMED_OLD_NAME = ] [ +rename-file+ ] }
- { [ dup FILE_ACTION_RENAMED_NEW_NAME = ] [ +rename-file+ ] }
- { [ t ] [ +modify-file+ ] }
- } cond nip ;
+ { FILE_ACTION_ADDED [ +add-file+ ] }
+ { FILE_ACTION_REMOVED [ +remove-file+ ] }
+ { FILE_ACTION_MODIFIED [ +modify-file+ ] }
+ { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] }
+ { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] }
+ [ drop +modify-file+ ]
+ } case 1array ;
: memory>u16-string ( alien len -- string )
[ memory>byte-array ] keep 2/ c-ushort-array> >string ;
-: parse-file-notify ( buffer -- changed path )
- {
- FILE_NOTIFY_INFORMATION-FileName
- FILE_NOTIFY_INFORMATION-FileNameLength
- FILE_NOTIFY_INFORMATION-Action
- } get-slots parse-action 1array -rot memory>u16-string ;
-
-: (changed-files) ( buffer -- )
- dup parse-file-notify changed-file
- dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero?
- [ 2drop ] [ swap <displaced-alien> (changed-files) ] if ;
-
-M: win32-monitor fill-queue ( monitor -- )
- dup buffer-ptr over read-changes
- [ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc
- swap set-monitor-queue ;
+: parse-notify-record ( buffer -- path changed )
+ [
+ [ FILE_NOTIFY_INFORMATION-FileName ]
+ [ FILE_NOTIFY_INFORMATION-FileNameLength ]
+ bi memory>u16-string
+ ]
+ [ FILE_NOTIFY_INFORMATION-Action parse-action ] bi ;
+
+: (file-notify-records) ( buffer -- buffer )
+ dup ,
+ dup FILE_NOTIFY_INFORMATION-NextEntryOffset zero? [
+ [ FILE_NOTIFY_INFORMATION-NextEntryOffset ] keep <displaced-alien>
+ (file-notify-records)
+ ] unless ;
+
+: file-notify-records ( buffer -- seq )
+ [ (file-notify-records) drop ] { } make ;
+
+: parse-notify-records ( monitor buffer -- )
+ file-notify-records
+ [ parse-notify-record rot queue-change ] with each ;
+
+: fill-queue ( monitor -- )
+ dup port>> check-closed
+ [ buffer>> ptr>> ] [ read-changes zero? ] bi
+ [ 2dup parse-notify-records ] unless
+ 2drop ;
+
+: (fill-queue-thread) ( monitor -- )
+ dup fill-queue (fill-queue-thread) ;
+
+: fill-queue-thread ( monitor -- )
+ [ dup fill-queue (fill-queue-thread) ]
+ [ dup port-closed-error? [ 2drop ] [ rethrow ] if ] recover ;
+
+M:: winnt (monitor) ( path recursive? mailbox -- monitor )
+ [
+ path mailbox win32-monitor new-monitor
+ path open-directory \ win32-monitor-port <buffered-port>
+ recursive? >>recursive
+ >>port
+ dup [ fill-queue-thread ] curry
+ "Windows monitor thread" spawn drop
+ ] with-destructors ;
+
+M: win32-monitor dispose
+ port>> dispose ;
+++ /dev/null
-USING: io.files kernel tools.test io.backend
-io.windows.nt.files splitting ;
-IN: io.windows.nt.tests
-
-[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test
-[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test
-[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test
-! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing
-[ "c:" ] [ "c:\\" parent-directory ] unit-test
-[ "Z:" ] [ "Z:\\" parent-directory ] unit-test
-[ "c:" ] [ "c:" parent-directory ] unit-test
-[ "Z:" ] [ "Z:" parent-directory ] unit-test
-[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test
-[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test
-[ f ] [ "c:\\foo" root-directory? ] unit-test
-[ f ] [ "." root-directory? ] unit-test
-[ f ] [ ".." root-directory? ] unit-test
-
-[ ] [ "" resource-path cd ] unit-test
-
-[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test
-
-[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
- "C:\\builds\\factor\\12345\\"
- "..\\log.txt" windows-path+
-] unit-test
-
-[ "\\\\?\\C:\\builds\\" ] [
- "C:\\builds\\factor\\12345\\"
- "..\\.." windows-path+
-] unit-test
-
-[ "\\\\?\\C:\\builds\\" ] [
- "C:\\builds\\factor\\12345\\"
- "..\\.." windows-path+
-] unit-test
USE: io.windows.mmap
USE: io.windows.files
USE: io.backend
+USE: system
-T{ windows-nt-io } set-io-backend
+winnt set-io-backend
USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math windows.kernel32 windows namespaces kernel
sequences windows.errors assocs math.parser system random
-combinators new-slots accessors ;
+combinators accessors ;
IN: io.windows.nt.pipes
! This code is based on
[
>r over >r create-named-pipe dup close-later
r> r> open-other-end dup close-later
- pipe construct-boa
+ pipe boa
] with-destructors ;
: close-pipe ( pipe -- )
"\\\\.\\pipe\\factor-" %
pipe counter #
"-" %
- (random) #
+ 32 random-bits #
"-" %
millis #
] "" make ;
continuations destructors io.nonblocking io.timeouts io.sockets
io.sockets.impl io namespaces io.streams.duplex io.windows
io.windows.nt.backend windows.winsock kernel libc math sequences
-threads tuples.lib ;
+threads classes.tuple.lib system accessors ;
IN: io.windows.nt.sockets
: malloc-int ( object -- object )
"int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
-M: windows-nt-io WSASocket-flags ( -- DWORD )
+M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;
: get-ConnectEx-ptr ( socket -- void* )
2dup save-callback
get-overlapped-result drop ;
-M: windows-nt-io (client) ( addrspec -- client-in client-out )
+M: winnt ((client)) ( addrspec -- client-in client-out )
[
- \ ConnectEx-args construct-empty
+ \ ConnectEx-args new
over make-sockaddr/size pick init-connect
over tcp-socket over set-ConnectEx-args-s*
dup ConnectEx-args-s* add-completion
[ AcceptEx-args-sAcceptSocket* add-completion ] keep
AcceptEx-args-sAcceptSocket* <win32-socket> ;
-M: windows-nt-io (accept) ( server -- addrspec handle )
+M: winnt (accept) ( server -- addrspec handle )
[
[
- dup check-server-port
- \ AcceptEx-args construct-empty
+ check-server-port
+ \ AcceptEx-args new
[ init-accept ] keep
[ ((accept)) ] keep
[ accept-continuation ] keep
] with-timeout
] with-destructors ;
-M: windows-nt-io (server) ( addrspec -- handle )
+M: winnt (server) ( addrspec -- handle )
[
SOCK_STREAM server-fd dup listen-on-socket
dup add-completion
<win32-socket>
] with-destructors ;
-M: windows-nt-io <datagram> ( addrspec -- datagram )
+M: winnt <datagram> ( addrspec -- datagram )
[
[
SOCK_DGRAM server-fd
: init-WSARecvFrom ( datagram WSARecvFrom -- )
[ set-WSARecvFrom-args-port ] 2keep
[
- >r delegate port-handle delegate win32-file-handle r>
+ >r handle>> handle>> r>
set-WSARecvFrom-args-s*
] 2keep [
>r datagram-port-addr sockaddr-type heap-size r>
[ WSARecvFrom-args-lpFrom* ] keep
WSARecvFrom-args-port datagram-port-addr parse-sockaddr ;
-M: windows-nt-io receive ( datagram -- packet addrspec )
+M: winnt receive ( datagram -- packet addrspec )
[
- dup check-datagram-port
- \ WSARecvFrom-args construct-empty
+ check-datagram-port
+ \ WSARecvFrom-args new
[ init-WSARecvFrom ] keep
[ call-WSARecvFrom ] keep
[ WSARecvFrom-continuation ] keep
USE: io.sockets
-M: windows-nt-io send ( packet addrspec datagram -- )
+M: winnt send ( packet addrspec datagram -- )
[
- 3dup check-datagram-send
- \ WSASendTo-args construct-empty
+ check-datagram-send
+ \ WSASendTo-args new
[ init-WSASendTo ] keep
[ call-WSASendTo ] keep
[ WSASendTo-continuation ] keep
io.sockets.impl windows.errors strings io.streams.duplex
kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting
-continuations math.bitfields ;
+continuations math.bitfields system accessors ;
IN: io.windows
-TUPLE: windows-nt-io ;
-TUPLE: windows-ce-io ;
-UNION: windows-io windows-nt-io windows-ce-io ;
+M: windows destruct-handle CloseHandle drop ;
-M: windows-io destruct-handle CloseHandle drop ;
-
-M: windows-io destruct-socket closesocket drop ;
+M: windows destruct-socket closesocket drop ;
TUPLE: win32-file handle ptr ;
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
-M: windows-io normalize-directory ( string -- string )
- normalize-pathname "\\" ?tail drop "\\*" append ;
+M: windows normalize-directory ( string -- string )
+ normalize-path "\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum )
{
: default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object>
- "SECURITY_ATTRIBUTES" heap-size over set-SECURITY_ATTRIBUTES-nLength ;
+ "SECURITY_ATTRIBUTES" heap-size
+ over set-SECURITY_ATTRIBUTES-nLength ;
: security-attributes-inherit ( -- obj )
default-security-attributes
! Clean up resources (open handle) if add-completion fails
: open-file ( path access-mode create-mode flags -- handle )
[
- >r >r >r normalize-pathname r>
- share-mode security-attributes-inherit r> r> CreateFile-flags f CreateFile
+ >r >r share-mode security-attributes-inherit r> r>
+ CreateFile-flags f CreateFile
dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;
: open-pipe-r/w ( path -- handle )
- GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING 0 open-file ;
+ { GENERIC_READ GENERIC_WRITE } flags
+ OPEN_EXISTING 0 open-file ;
: open-read ( path -- handle length )
GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
: (open-append) ( path -- handle )
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
+: open-existing ( path -- handle )
+ { GENERIC_READ GENERIC_WRITE } flags
+ share-mode
+ f
+ OPEN_EXISTING
+ FILE_FLAG_BACKUP_SEMANTICS
+ f CreateFileW dup win32-error=0/f ;
+
+: maybe-create-file ( path -- handle ? )
+ #! return true if file was just created
+ { GENERIC_READ GENERIC_WRITE } flags
+ share-mode
+ f
+ OPEN_ALWAYS
+ 0 CreateFile-flags
+ f CreateFileW dup win32-error=0/f
+ GetLastError ERROR_ALREADY_EXISTS = not ;
+
: set-file-pointer ( handle length -- )
dupd d>w/w <uint> FILE_BEGIN SetFilePointer
INVALID_SET_FILE_POINTER = [
] when drop ;
: open-append ( path -- handle length )
- [ dup file-info file-info-size ] [ drop 0 ] recover
+ [ dup file-info size>> ] [ drop 0 ] recover
>r (open-append) r> 2dup set-file-pointer ;
TUPLE: FileArgs
- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;
+ hFile lpBuffer nNumberOfBytesToRead
+ lpNumberOfBytesRet lpOverlapped ;
C: <FileArgs> FileArgs
: make-FileArgs ( port -- <FileArgs> )
[ port-handle win32-file-handle ] keep
- [ delegate ] keep
+ [ buffer>> ] keep
[
- buffer-length
+ buffer>> buffer-length
"DWORD" <c-object>
] keep FileArgs-overlapped <FileArgs> ;
[ FileArgs-lpNumberOfBytesRet ] keep
FileArgs-lpOverlapped ;
-M: windows-io (file-reader) ( path -- stream )
+M: windows (file-reader) ( path -- stream )
open-read <win32-file> <reader> ;
-M: windows-io (file-writer) ( path -- stream )
+M: windows (file-writer) ( path -- stream )
open-write <win32-file> <writer> ;
-M: windows-io (file-appender) ( path -- stream )
+M: windows (file-appender) ( path -- stream )
open-append <win32-file> <writer> ;
-M: windows-io move-file ( from to -- )
- [ normalize-pathname ] 2apply MoveFile win32-error=0/f ;
+M: windows move-file ( from to -- )
+ [ normalize-path ] bi@ MoveFile win32-error=0/f ;
-M: windows-io delete-file ( path -- )
- normalize-pathname DeleteFile win32-error=0/f ;
+M: windows delete-file ( path -- )
+ normalize-path DeleteFile win32-error=0/f ;
-M: windows-io copy-file ( from to -- )
+M: windows copy-file ( from to -- )
dup parent-directory make-directories
- [ normalize-pathname ] 2apply 0 CopyFile win32-error=0/f ;
+ [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
-M: windows-io make-directory ( path -- )
- normalize-pathname
+M: windows make-directory ( path -- )
+ normalize-path
f CreateDirectory win32-error=0/f ;
-M: windows-io delete-directory ( path -- )
- normalize-pathname
+M: windows delete-directory ( path -- )
+ normalize-path
RemoveDirectory win32-error=0/f ;
HOOK: WSASocket-flags io-backend ( -- DWORD )
-TUPLE: win32-socket ;
+TUPLE: win32-socket < win32-file ;
: <win32-socket> ( handle -- win32-socket )
- f <win32-file>
- \ win32-socket construct-delegate ;
+ f win32-file boa ;
: open-socket ( family type -- socket )
0 f 0 WSASocket-flags WSASocket dup socket-error ;
M: win32-socket dispose ( stream -- )
win32-file-handle closesocket drop ;
-M: windows-io addrinfo-error ( n -- )
+M: windows addrinfo-error ( n -- )
winsock-return-check ;
: tcp-socket ( addrspec -- socket )
protocol-family SOCK_STREAM open-socket ;
-
! Copyright (C) 2007 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar io io.sockets kernel match namespaces
-sequences splitting strings continuations threads ascii
-io.encodings.utf8 ;
+USING: arrays calendar combinators channels concurrency.messaging fry io
+ io.encodings.8-bit io.sockets kernel math namespaces sequences
+ sequences.lib splitting strings threads
+ continuations classes.tuple ascii accessors ;
IN: irc
+! utils
+: split-at-first ( seq separators -- before after )
+ dupd '[ , member? ] find
+ [ cut 1 tail ]
+ [ swap ]
+ if ;
+
+: spawn-server-linked ( quot name -- thread )
+ >r '[ , [ ] [ ] while ] r>
+ spawn-linked ;
+! ---
+
+! Default irc port
+: irc-port 6667 ;
+
+! Message used when the client isn't running anymore
+SINGLETON: irc-end
+
! "setup" objects
-TUPLE: profile server port nickname password default-channels ;
-C: <profile> profile
+TUPLE: irc-profile server port nickname password default-channels ;
+C: <irc-profile> irc-profile
-TUPLE: channel-profile name password auto-rejoin ;
-C: <channel-profile> channel-profile
+TUPLE: irc-channel-profile name password auto-rejoin ;
+C: <irc-channel-profile> irc-channel-profile
! "live" objects
-TUPLE: irc-client profile nick stream stream-process controller-process ;
-C: <irc-client> irc-client
-
TUPLE: nick name channels log ;
C: <nick> nick
-TUPLE: channel name topic members log attributes ;
-C: <channel> channel
+TUPLE: irc-client profile nick stream stream-channel controller-channel
+ listeners is-running ;
+: <irc-client> ( profile -- irc-client )
+ f V{ } clone V{ } clone <nick>
+ f <channel> <channel> V{ } clone f irc-client boa ;
+
+USE: prettyprint
+TUPLE: irc-listener channel ;
+! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? )
+! tener la opción de dejar de correr un client??
+: <irc-listener> ( quot -- irc-listener )
+ <channel> irc-listener boa swap
+ [
+ [ channel>> '[ , from ] ]
+ [ '[ , curry f spawn drop ] ]
+ bi* compose "irc-listener" spawn-server-linked drop
+ ] [ drop ] 2bi ;
+
+! TUPLE: irc-channel name topic members log attributes ;
+! C: <irc-channel> irc-channel
! the delegate of all irc messages
-TUPLE: irc-message timestamp ;
+TUPLE: irc-message line prefix command parameters trailing timestamp ;
C: <irc-message> irc-message
! "irc message" objects
-TUPLE: logged-in name text ;
+TUPLE: logged-in < irc-message name ;
C: <logged-in> logged-in
-TUPLE: ping name ;
+TUPLE: ping < irc-message ;
C: <ping> ping
-TUPLE: join name channel ;
-C: <join> join
+TUPLE: join_ < irc-message ;
+C: <join> join_
-TUPLE: part name channel text ;
+TUPLE: part < irc-message name channel ;
C: <part> part
-TUPLE: quit text ;
+TUPLE: quit ;
C: <quit> quit
-TUPLE: privmsg name text ;
+TUPLE: privmsg < irc-message name ;
C: <privmsg> privmsg
-TUPLE: kick channel er ee text ;
+TUPLE: kick < irc-message channel who ;
C: <kick> kick
-TUPLE: roomlist channel names ;
+TUPLE: roomlist < irc-message channel names ;
C: <roomlist> roomlist
-TUPLE: nick-in-use name ;
+TUPLE: nick-in-use < irc-message name ;
C: <nick-in-use> nick-in-use
-TUPLE: notice type text ;
+TUPLE: notice < irc-message type ;
C: <notice> notice
-TUPLE: mode name channel mode text ;
+TUPLE: mode < irc-message name channel mode ;
C: <mode> mode
-! TUPLE: members
-TUPLE: unhandled text ;
+TUPLE: unhandled < irc-message ;
C: <unhandled> unhandled
-! "control message" objects
-TUPLE: command sender ;
-TUPLE: service predicate quot enabled? ;
-TUPLE: chat-command from to text ;
-TUPLE: join-command channel password ;
-TUPLE: part-command channel text ;
-
SYMBOL: irc-client
-: irc-stream> ( -- stream ) irc-client get irc-client-stream ;
-: trim-: ( seq -- seq ) [ CHAR: : = ] left-trim ;
+: irc-client> ( -- irc-client ) irc-client get ;
+: irc-stream> ( -- stream ) irc-client> stream>> ;
+
+: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
+
: parse-name ( string -- string )
- trim-: "!" split first ;
-: irc-split ( string -- seq )
- 1 swap [ [ CHAR: : = ] find* ] keep
- swap [ swap cut trim-: ] [ nip f ] if >r [ blank? ] trim trim-:
- " " split r> [ 1array append ] when* ;
+ remove-heading-: "!" split-at-first drop ;
+
+: sender>> ( obj -- string )
+ prefix>> parse-name ;
+
+: split-prefix ( string -- string/f string )
+ dup ":" head?
+ [ remove-heading-: " " split1 ]
+ [ f swap ]
+ if ;
+
+: split-trailing ( string -- string string/f )
+ ":" split1 ;
+
+: string>irc-message ( string -- object )
+ dup split-prefix split-trailing
+ [ [ blank? ] trim " " split unclip swap ] dip
+ now <irc-message> ;
+
: me? ( name -- ? )
- irc-client get irc-client-nick nick-name = ;
+ irc-client> nick>> name>> = ;
: irc-write ( s -- )
irc-stream> stream-write ;
: irc-print ( s -- )
irc-stream> [ stream-print ] keep stream-flush ;
-: nick ( nick -- )
+! Irc commands
+
+: NICK ( nick -- )
"NICK " irc-write irc-print ;
-: login ( nick -- )
- dup nick
+: LOGIN ( nick -- )
+ dup NICK
"USER " irc-write irc-write
" hostname servername :irc.factor" irc-print ;
-: connect* ( server port -- )
- <inet> utf8 <client> irc-client get set-irc-client-stream ;
-
-: connect ( server -- ) 6667 connect* ;
+: CONNECT ( server port -- stream )
+ <inet> latin1 <client> ;
-: join ( channel password -- )
+: JOIN ( channel password -- )
"JOIN " irc-write
- [ >r " :" r> 3append ] when* irc-print ;
+ [ " :" swap 3append ] when* irc-print ;
-: part ( channel text -- )
- >r "PART " irc-write irc-write r>
+: PART ( channel text -- )
+ [ "PART " irc-write irc-write ] dip
" :" irc-write irc-print ;
-: say ( line nick -- )
- "PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
+: KICK ( channel who -- )
+ [ "KICK " irc-write irc-write ] dip
+ " " irc-write irc-print ;
+
+: PRIVMSG ( nick line -- )
+ [ "PRIVMSG " irc-write irc-write ] dip
+ " :" irc-write irc-print ;
+
+: SAY ( nick line -- )
+ PRIVMSG ;
-: quit ( text -- )
+: ACTION ( nick line -- )
+ [ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ;
+
+: QUIT ( text -- )
"QUIT :" irc-write irc-print ;
+: join-channel ( channel-profile -- )
+ [ name>> ] keep password>> JOIN ;
+: irc-connect ( irc-client -- )
+ [ profile>> [ server>> ] keep port>> CONNECT ] keep
+ swap >>stream t >>is-running drop ;
+
GENERIC: handle-irc ( obj -- )
M: object handle-irc ( obj -- )
- "Unhandled irc object" print drop ;
+ drop ;
M: logged-in handle-irc ( obj -- )
- logged-in-name irc-client get [ irc-client-nick set-nick-name ] keep
-
- irc-client-profile profile-default-channels
- [
- [ channel-profile-name ] keep
- channel-profile-password join
- ] each ;
+ name>>
+ irc-client> [ nick>> swap >>name drop ] keep
+ profile>> default-channels>> [ join-channel ] each ;
M: ping handle-irc ( obj -- )
"PONG " irc-write
- ping-name irc-print ;
+ trailing>> irc-print ;
M: nick-in-use handle-irc ( obj -- )
- nick-in-use-name "_" append nick ;
-
-: delegate-timestamp ( obj -- obj )
- now <irc-message> over set-delegate ;
-
-MATCH-VARS: ?name ?name2 ?channel ?text ?mode ;
-SYMBOL: line
-: match-irc ( string -- )
- dup line set
- dup print flush
- irc-split
- {
- { { "PING" ?name }
- [ ?name <ping> ] }
- { { ?name "001" ?name2 ?text }
- [ ?name2 ?text <logged-in> ] }
- { { ?name "433" _ ?name2 "Nickname is already in use." }
- [ ?name2 <nick-in-use> ] }
-
- { { ?name "JOIN" ?channel }
- [ ?name ?channel <join> ] }
- { { ?name "PART" ?channel ?text }
- [ ?name ?channel ?text <part> ] }
- { { ?name "PRIVMSG" ?channel ?text }
- [ ?name ?channel ?text <privmsg> ] }
- { { ?name "QUIT" ?text }
- [ ?name ?text <quit> ] }
-
- { { "NOTICE" ?name ?text }
- [ ?name ?text <notice> ] }
- { { ?name "MODE" ?channel ?mode ?text }
- [ ?name ?channel ?mode ?text <mode> ] }
- { { ?name "KICK" ?channel ?name2 ?text }
- [ ?channel ?name ?name2 ?text <kick> ] }
-
- ! { { ?name "353" ?name2 _ ?channel ?text }
- ! [ ?text ?channel ?name2 make-member-list ] }
- { _ [ line get <unhandled> ] }
- } match-cond
- delegate-timestamp handle-irc flush ;
-
-: irc-loop ( -- )
- irc-stream> stream-readln
- [ match-irc irc-loop ] when* ;
-
+ name>> "_" append NICK ;
+
+: parse-irc-line ( string -- message )
+ string>irc-message
+ dup command>> {
+ { "PING" [ \ ping ] }
+ { "NOTICE" [ \ notice ] }
+ { "001" [ \ logged-in ] }
+ { "433" [ \ nick-in-use ] }
+ { "JOIN" [ \ join_ ] }
+ { "PART" [ \ part ] }
+ { "PRIVMSG" [ \ privmsg ] }
+ { "QUIT" [ \ quit ] }
+ { "MODE" [ \ mode ] }
+ { "KICK" [ \ kick ] }
+ [ drop \ unhandled ]
+ } case
+ [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
+
+! Reader
+: handle-reader-message ( irc-client irc-message -- )
+ dup handle-irc swap stream-channel>> to ;
+
+: reader-loop ( irc-client -- )
+ dup stream>> stream-readln [
+ dup print parse-irc-line handle-reader-message
+ ] [
+ f >>is-running
+ dup stream>> dispose
+ irc-end over controller-channel>> to
+ stream-channel>> irc-end swap to
+ ] if* ;
+
+! Controller commands
+GENERIC: handle-command ( obj -- )
+
+M: object handle-command ( obj -- )
+ . ;
+
+TUPLE: send-message to text ;
+C: <send-message> send-message
+M: send-message handle-command ( obj -- )
+ dup to>> swap text>> SAY ;
+
+TUPLE: send-action to text ;
+C: <send-action> send-action
+M: send-action handle-command ( obj -- )
+ dup to>> swap text>> ACTION ;
+
+TUPLE: send-quit text ;
+C: <send-quit> send-quit
+M: send-quit handle-command ( obj -- )
+ text>> QUIT ;
+
+: irc-listen ( irc-client quot -- )
+ [ listeners>> ] [ <irc-listener> ] bi* swap push ;
+
+! Controller loop
+: controller-loop ( irc-client -- )
+ controller-channel>> from handle-command ;
+
+! Multiplexer
+: multiplex-message ( irc-client message -- )
+ swap listeners>> [ channel>> ] map
+ [ '[ , , to ] "message" spawn drop ] each-with ;
+
+: multiplexer-loop ( irc-client -- )
+ dup stream-channel>> from multiplex-message ;
+
+! process looping and starting
+: (spawn-irc-loop) ( irc-client quot name -- )
+ [ over >r curry r> '[ @ , is-running>> ] ] dip
+ spawn-server-linked drop ;
+
+: spawn-irc-loop ( irc-client quot name -- )
+ '[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ]
+ f spawn drop ;
+
+: spawn-irc ( irc-client -- )
+ [ [ reader-loop ] "reader-loop" spawn-irc-loop ]
+ [ [ controller-loop ] "controller-loop" spawn-irc-loop ]
+ [ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ]
+ tri ;
+
: do-irc ( irc-client -- )
- dup irc-client set
- dup irc-client-profile profile-server
- over irc-client-profile profile-port connect*
- dup irc-client-profile profile-nickname login
- [ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ;
-
-: with-infinite-loop ( quot timeout -- quot timeout )
- "looping" print flush
- over [ drop ] recover dup sleep with-infinite-loop ;
-
-: start-irc ( irc-client -- )
- ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ;
- [ do-irc ] curry 3000 with-infinite-loop ;
-
-
-! For testing
-: make-factorbot
- "irc.freenode.org" 6667 "factorbot" f
- [
- "#concatenative-flood" f f <channel-profile> ,
- ] { } make <profile>
- f V{ } clone V{ } clone <nick>
- f f f <irc-client> ;
-
-: test-factorbot
- make-factorbot start-irc ;
-
+ irc-client [
+ irc-client>
+ [ irc-connect ]
+ [ profile>> nickname>> LOGIN ]
+ [ spawn-irc ]
+ tri
+ ] with-variable ;
\ No newline at end of file
: <jamshred> ( -- jamshred )
<random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
- jamshred construct-boa ;
+ jamshred boa ;
: jamshred-player ( jamshred -- player )
! TODO: support more than one player
TUPLE: oint location forward up left ;
: <oint> ( location forward up left -- oint )
- oint construct-boa ;
+ oint boa ;
! : x-rotation ( theta -- matrix )
! #! construct this matrix:
TUPLE: player name tunnel nearest-segment ;
: <player> ( name -- player )
- f f player construct-boa
+ f f player boa
F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <oint> over set-delegate ;
: turn-player ( player x-radians y-radians -- )
TUPLE: segment number color radius ;
: <segment> ( number color radius location forward up left -- segment )
- <oint> >r segment construct-boa r> over set-delegate ;
+ <oint> >r segment boa r> over set-delegate ;
: segment-vertex ( theta segment -- vertex )
tuck 2dup oint-up swap sin v*n
: sub-tunnel ( from to sements -- segments )
#! return segments between from and to, after clamping from and to to
#! valid values
- [ sequence-index-range [ clamp-to-range ] curry 2apply ] keep <slice> ;
+ [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
: nearer-segment ( segment segment oint -- segment )
#! return whichever of the two segments is nearer to the oint
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io.streams.string io strings splitting sequences math
- math.parser assocs tuples classes words namespaces
- hashtables ;
+ math.parser assocs classes words namespaces prettyprint
+ hashtables mirrors ;
IN: json.writer
#! Writes the object out to a stream in JSON format
M: integer json-print ( num -- )
number>string write ;
-M: sequence json-print ( array -- string )
+M: sequence json-print ( array -- )
CHAR: [ write1 [ >json ] map "," join write CHAR: ] write1 ;
-: (jsvar-encode) ( char -- char )
- #! Convert the given character to a character usable in
- #! javascript variable names.
- dup H{ { CHAR: - CHAR: _ } } at dup [ nip ] [ drop ] if ;
-
: jsvar-encode ( string -- string )
#! Convert the string so that it contains characters usable within
#! javascript variable names.
- [ (jsvar-encode) ] map ;
+ { { CHAR: - CHAR: _ } } substitute ;
-: slots ( object -- values names )
- #! Given an object return an array of slots names and a sequence of slot values
- #! the slot name and the slot value.
- [ tuple-slots ] keep class "slot-names" word-prop ;
-
-: slots>fields ( values names -- array )
- #! Convert the arrays containing the slot names and values
- #! to an array of strings suitable for describing that slot
- #! as a field in a javascript object.
- [
- [ jsvar-encode >json % " : " % >json % ] "" make
- ] 2map ;
-
-M: object json-print ( object -- string )
- CHAR: { write1 slots slots>fields "," join write CHAR: } write1 ;
-
-M: hashtable json-print ( hashtable -- string )
+: tuple>fields ( object -- seq )
+ <mirror> [
+ [ swap jsvar-encode >json % " : " % >json % ] "" make
+ ] { } assoc>map ;
+
+M: tuple json-print ( tuple -- )
+ CHAR: { write1 tuple>fields "," join write CHAR: } write1 ;
+
+M: hashtable json-print ( hashtable -- )
CHAR: { write1
[ [ swap jsvar-encode >json % CHAR: : , >json % ] "" make ]
{ } assoc>map "," join write
CHAR: } write1 ;
-
+
+M: object json-print ( object -- )
+ unparse json-print ;
USING: arrays assocs hashtables assocs io kernel math
math.vectors math.matrices math.matrices.elimination namespaces
parser prettyprint sequences words combinators math.parser
-splitting sorting shuffle symbols ;
+splitting sorting shuffle symbols sets ;
IN: koszul
! Utilities
{ [ dup number? ] [ { } associate ] }
{ [ dup array? ] [ 1 swap associate ] }
{ [ dup hashtable? ] [ ] }
- { [ t ] [ 1array >alt ] }
+ [ 1array >alt ]
} cond ;
: canonicalize
! Printing elements
: num-alt. ( n -- str )
{
- { [ dup 1 = ] [ drop " + " ] }
- { [ dup -1 = ] [ drop " - " ] }
- { [ t ] [ number>string " + " swap append ] }
- } cond ;
+ { 1 [ " + " ] }
+ { -1 [ " - " ] }
+ [ number>string " + " prepend ]
+ } case ;
: (alt.) ( basis n -- str )
over empty? [
terms get [ [ swap +@ ] assoc-each ] bind ;
: alt+ ( x y -- x+y )
- [ >alt ] 2apply [ (alt+) (alt+) ] with-terms ;
+ [ >alt ] bi@ [ (alt+) (alt+) ] with-terms ;
! Multiplication
: alt*n ( vec n -- vec )
] curry each ;
: duplicates? ( seq -- ? )
- dup prune [ length ] 2apply > ;
+ dup prune [ length ] bi@ > ;
: (wedge) ( n basis1 basis2 -- n basis )
append dup duplicates? [
] if ;
: wedge ( x y -- x.y )
- [ >alt ] 2apply [
+ [ >alt ] bi@ [
swap [
[
2swap [
: (tensor) ( seq1 seq2 -- seq )
[
- [ swap append natural-sort ] curry map
+ [ prepend natural-sort ] curry map
] with map concat ;
: tensor ( graded-basis1 graded-basis2 -- bigraded-basis )
[ length ] keep [ (graded-ker/im-d) ] curry map ;
: graded-betti ( generators -- seq )
- basis graded graded-ker/im-d flip first2 1 head* 0 add* v- ;
+ basis graded graded-ker/im-d flip first2 1 head* 0 prefix v- ;
! Bi-graded for two-step complexes
: (bigraded-ker/im-d) ( u-deg z-deg bigraded-basis -- null/rank )
] with map ;
: bigraded-betti ( u-generators z-generators -- seq )
- [ basis graded ] 2apply tensor bigraded-ker/im-d
+ [ basis graded ] bi@ tensor bigraded-ker/im-d
[ [ [ first ] map ] map ] keep
- [ [ second ] map 2 head* { 0 0 } swap append ] map
- 1 tail dup first length 0 <array> add
+ [ [ second ] map 2 head* { 0 0 } prepend ] map
+ 1 tail dup first length 0 <array> suffix
[ v- ] 2map ;
! Laplacian
] with map ;
: bigraded-laplacian ( u-generators z-generators quot -- seq )
- >r [ basis graded ] 2apply tensor bigraded-triples r>
+ >r [ basis graded ] bi@ tensor bigraded-triples r>
[ [ first3 ] swap compose map ] curry map ; inline
: bigraded-laplacian-betti ( u-generators z-generators -- seq )
TUPLE: lazy-cons car cdr ;
: lazy-cons ( car cdr -- promise )
- [ promise ] 2apply \ lazy-cons construct-boa
+ [ promise ] bi@ \ lazy-cons boa
T{ promise f f t f } clone
[ set-promise-value ] keep ;
swap [ cdr ] times car ;
: (llength) ( list acc -- n )
- over nil? [ nip ] [ >r cdr r> 1+ (llength) ] if ;
+ over nil? [ nip ] [ [ cdr ] dip 1+ (llength) ] if ;
: llength ( list -- n )
0 (llength) ;
: <memoized-cons> ( cons -- memoized-cons )
not-memoized not-memoized not-memoized
- memoized-cons construct-boa ;
+ memoized-cons boa ;
M: memoized-cons car ( memoized-cons -- car )
dup memoized-cons-car not-memoized? [
M: lazy-from-by cdr ( lazy-from-by -- cdr )
[ lazy-from-by-n ] keep
- lazy-from-by-quot dup >r call r> lfrom-by ;
+ lazy-from-by-quot dup slip lfrom-by ;
M: lazy-from-by nil? ( lazy-from-by -- bool )
drop f ;
{
{ [ dup sequence? ] [ 0 swap seq>list ] }
{ [ dup list? ] [ ] }
- { [ t ] [ "Could not convert object to a list" throw ] }
+ [ "Could not convert object to a list" throw ]
} cond ;
TUPLE: lazy-concat car cdr ;
drop nil
] [
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
- swap [ swap [ add ] lmap-with ] lmap-with lconcat
+ swap [ swap [ suffix ] lmap-with ] lmap-with lconcat
] reduce
] if ;
: lcomp ( list quot -- result )
- >r lcartesian-product* r> lmap ;
+ [ lcartesian-product* ] dip lmap ;
: lcomp* ( list guards quot -- result )
- >r >r lcartesian-product* r> [ lsubset ] each r> lmap ;
+ [ [ lcartesian-product* ] dip [ lsubset ] each ] dip lmap ;
DEFER: lmerge
[
dup [ car ] curry -rot
[
- >r cdr r> cdr lmerge
+ [ cdr ] bi@ lmerge
] 2curry lazy-cons
] 2curry lazy-cons ;
[ lazy-io-stream ] keep
[ lazy-io-quot ] keep
car [
- >r f f r> <lazy-io> [ swap set-lazy-io-cdr ] keep
+ [ f f ] dip <lazy-io> [ swap set-lazy-io-cdr ] keep
] [
3drop nil
] if
+++ /dev/null
-Elie Chaftari
+++ /dev/null
-## ADD a single entry to people level
-
-dn: cn=John Spider,ou=people,dc=example,dc=com
-objectclass: inetOrgPerson
-cn: John Spider
-sn: Spider
-uid: 1
-userpassword: jSpider
-carlicense: HISCAR 124
-homephone: 555-111-2223
-mail: j.spider@example.com
-# ou: Sales
-
-## ADD another single entry to people level
-
-dn: cn=Sheri Matsumo,ou=people,dc=example,dc=com
-objectclass: inetOrgPerson
-cn: Sheri Matsumo
-sn: Matsumo
-uid: 2
-userpassword: sMatsumo
-carlicense: HERCAR 125
-homephone: 555-111-2225
-mail: s.matsumo@example.com
-# ou: IT
\ No newline at end of file
+++ /dev/null
-# this is a comment # MUST be in FIRST column - very picky
-
-## DEFINE DIT ROOT/BASE/SUFFIX ####
-## uses RFC 2377 format
-## replace example and com as necessary below
-## or for experimentation leave as is
-
-## dcObject is an AUXILLIARY objectclass and MUST
-## have a STRUCTURAL objectclass (organization in this case)
-# this is an ENTRY sequence and is preceded by a BLANK line
-
-dn: dc=example,dc=com
-dc: example
-description: My wonderful company as much text as you want to place in this line up to 32K
- continuation data for the line above must have <CR> or <CR><LF> i.e. ENTER works
- on both Windows and *nix system - new line MUST begin with ONE SPACE
-objectClass: dcObject
-objectClass: organization
-o: Example, Inc.
-
-## FIRST Level hierarchy - people
-## uses mixed upper and lower case for objectclass
-# this is an ENTRY sequence and is preceded by a BLANK line
-
-dn: ou=people, dc=example,dc=com
-ou: people
-description: All people in organisation
-objectclass: organizationalunit
-
-## SECOND Level hierarchy
-## ADD a single entry under FIRST (people) level
-# this is an ENTRY sequence and is preceded by a BLANK line
-# the ou: Human Resources is the department name
-
-dn: cn=Robert Forest,ou=people,dc=example,dc=com
-objectclass: inetOrgPerson
-cn: Robert Forest
-sn: Forest
-uid: 0
-userpassword: rForest
-carlicense: HISCAR 123
-homephone: 555-111-2222
-mail: r.forest@example.com
-description: swell guy
-# ou: Human Resources
\ No newline at end of file
+++ /dev/null
-#
-###### SAMPLE 1 - SIMPLE DIRECTORY ############
-#
-# NOTES: inetorgperson picks up attributes and objectclasses
-# from all three schemas
-#
-# NB: RH Linux schemas in /etc/openldap
-#
-include /opt/local/etc/openldap/schema/core.schema
-include /opt/local/etc/openldap/schema/cosine.schema
-include /opt/local/etc/openldap/schema/inetorgperson.schema
-
-
-# NO SECURITY - no access clause
-# defaults to anonymous access for read
-# only rootdn can write
-
-# NO REFERRALS
-
-# DON'T bother with ARGS file unless you feel strongly
-# slapd scripts stop scripts need this to work
-pidfile /opt/local/var/run/run/slapd.pid
-
-# enable a lot of logging - we might need it
-# but generates huge logs
-loglevel -1
-
-# NO dynamic backend modules
-
-# NO TLS-enabled connections
-
-# backend definition not required
-
-#######################################################################
-# bdb database definitions
-#
-# replace example and com below with a suitable domain
-#
-# If you don't have a domain you can leave it since example.com
-# is reserved for experimentation or change them to my and inc
-#
-#######################################################################
-
-database bdb
-suffix "dc=example, dc=com"
-
-# root or superuser
-rootdn "cn=jimbob, dc=example, dc=com"
-rootpw secret
-# The database directory MUST exist prior to running slapd AND
-# change path as necessary
-directory /opt/local/var/run/openldap-data
-
-# Indices to maintain for this directory
-# unique id so equality match only
-index uid eq
-# allows general searching on commonname, givenname and email
-index cn,gn,mail eq,sub
-# allows multiple variants on surname searching
-index sn eq,sub,subany,subfinal
-# optimise department searches
-index ou eq
-# shows use of default index parameter
-index default eq,sub
-# indices missing - uses default eq,sub
-index telephonenumber
-
+++ /dev/null
-USING: alien alien.c-types io kernel ldap ldap.libldap
-namespaces prettyprint tools.test ;
-IN: ldap.tests
-
-"void*" <c-object> "ldap://localhost:389" initialize
-
-get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 <int> set-option
-
-[ 3 ] [
- get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" <c-object> [ get-option ] keep
- *int
-] unit-test
-
-[
- get-ldp "cn=jimbob,dc=example,dc=com" "secret" [
-
- ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0
- ! "void*" <c-object> [ search-s ] keep *int .
-
- [ 2 ] [
- get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0
- search
- ] unit-test
-
- ! get-ldp LDAP_RES_ANY 0 f "void*" <c-object> result .
-
- get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" <c-object> result
-
- ! get-message *int .
-
- "Message ID: " write
-
- get-message msgid .
-
- get-ldp get-message get-dn .
-
- "Entries count: " write
-
- get-ldp get-message count-entries .
-
- SYMBOL: entry
- SYMBOL: attr
-
- "Attribute: " write
-
- get-ldp get-message first-entry entry set get-ldp entry get
- "void*" <c-object> first-attribute dup . attr set
-
- "Value: " write
-
- get-ldp entry get attr get get-values *char* .
-
- get-ldp get-message first-message msgtype result-type
-
- get-ldp get-message next-message msgtype result-type
-
- ] with-bind
-] drop
+++ /dev/null
-! Copyright (C) 2007 Elie CHAFTARI
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Tested with OpenLDAP 2.2.7.0.21 on Mac OS X 10.4.9 PowerPC
-
-USING: alien alien.c-types assocs continuations hashtables io kernel
-ldap.libldap math namespaces sequences ;
-
-IN: ldap
-
-SYMBOL: message
-SYMBOL: ldp
-
-! =========================================================
-! Error interpretation routines
-! =========================================================
-
-: result-to-error ( ld res freeit -- num )
- ldap_result2error ;
-
-: err-to-string ( err -- str )
- ldap_err2string ;
-
-: check-result ( result -- )
- dup zero? [ drop ] [
- err-to-string throw
- ] if ;
-
-: result-type ( result -- )
- result-types >hashtable at print ;
-
-! =========================================================
-! Initialization routines
-! =========================================================
-
-! deprecated in favor of ldap_initialize
-: open ( host port -- ld )
- ldap_open ;
-
-! deprecated in favor of ldap_initialize
-: init ( host port -- ld )
- ldap_init ;
-
-: initialize ( ld url -- )
- dupd ldap_initialize swap *void* ldp set check-result ;
-
-: get-option ( ld option outvalue -- )
- ldap_get_option check-result ;
-
-: set-option ( ld option invalue -- )
- ldap_set_option check-result ;
-
-! =========================================================
-! Bind operations
-! =========================================================
-
-: simple-bind ( ld who passwd -- id )
- ldap_simple_bind ;
-
-: simple-bind-s ( ld who passwd -- )
- ldap_simple_bind_s check-result ;
-
-: unbind-s ( ld -- )
- ldap_unbind_s check-result ;
-
-: with-bind ( ld who passwd quot -- )
- -roll [ simple-bind-s [ ldp get unbind-s ] [ ] cleanup ] with-scope ; inline
-
-! =========================================================
-! Search operations
-! =========================================================
-
-: search ( ld base scope filter attrs attrsonly -- id )
- ldap_search ;
-
-: search-s ( ld base scope filter attrs attrsonly res -- )
- ldap_search_s check-result ;
-
-! =========================================================
-! Return results of asynchronous operation routines
-! =========================================================
-
-: result ( ld msgid all timeout result -- )
- [ ldap_result ] keep *void* message set result-type ;
-
-: parse-result ( ld result errcodep matcheddnp errmsgp referralsp serverctrlsp freeit -- )
- ldap_parse_result check-result ;
-
-: count-messages ( ld result -- count )
- ldap_count_messages ;
-
-: first-message ( ld result -- message )
- ldap_first_message ;
-
-: next-message ( ld message -- message )
- ldap_next_message ;
-
-: msgtype ( msg -- num )
- ldap_msgtype ;
-
-: msgid ( msg -- num )
- ldap_msgid ;
-
-: count-entries ( ld result -- count )
- ldap_count_entries ;
-
-: first-entry ( ld result -- entry )
- ldap_first_entry ;
-
-: next-entry ( ld entry -- entry )
- ldap_next_entry ;
-
-: first-attribute ( ld entry berptr -- str )
- ldap_first_attribute ;
-
-: next-attribute ( ld entry ber -- str )
- ldap_next_attribute ;
-
-: get-values ( ld entry attr -- values )
- ldap_get_values ;
-
-: get-dn ( ld entry -- str )
- ldap_get_dn ;
-
-! =========================================================
-! Public routines
-! =========================================================
-
-: get-message ( -- message )
- message get ;
-
-: get-ldp ( -- ldp )
- ldp get ;
+++ /dev/null
-Elie Chaftari
+++ /dev/null
-! Copyright (C) 2007 Elie CHAFTARI
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Tested with OpenLDAP 2.2.7.0.21 on Mac OS X 10.4.9 PowerPC
-!
-! export LD_LIBRARY_PATH=/opt/local/lib
-
-USING: alien alien.syntax combinators kernel system ;
-
-IN: ldap.libldap
-
-<< "libldap" {
- { [ win32? ] [ "libldap.dll" "stdcall" ] }
- { [ macosx? ] [ "libldap.dylib" "cdecl" ] }
- { [ unix? ] [ "libldap.so" "cdecl" ] }
-} cond add-library >>
-
-: LDAP_VERSION1 1 ; inline
-: LDAP_VERSION2 2 ; inline
-: LDAP_VERSION3 3 ; inline
-
-: LDAP_VERSION_MIN LDAP_VERSION2 ; inline
-: LDAP_VERSION LDAP_VERSION2 ; inline
-: LDAP_VERSION_MAX LDAP_VERSION3 ; inline
-
-: LDAP_PORT 389 ; inline ! ldap:/// default LDAP port
-: LDAPS_PORT 636 ; inline ! ldaps:/// default LDAP over TLS port
-
-: LDAP_SCOPE_BASE HEX: 0000 ; inline
-: LDAP_SCOPE_BASEOBJECT LDAP_SCOPE_BASE ; inline
-: LDAP_SCOPE_ONELEVEL HEX: 0001 ; inline
-: LDAP_SCOPE_ONE LDAP_SCOPE_ONELEVEL ; inline
-: LDAP_SCOPE_SUBTREE HEX: 0002 ; inline
-: LDAP_SCOPE_SUB LDAP_SCOPE_SUBTREE ; inline
-: LDAP_SCOPE_SUBORDINATE HEX: 0003 ; inline ! OpenLDAP extension
-: LDAP_SCOPE_CHILDREN LDAP_SCOPE_SUBORDINATE ; inline
-: LDAP_SCOPE_DEFAULT -1 ; inline ! OpenLDAP extension
-
-: LDAP_RES_ANY -1 ; inline
-: LDAP_RES_UNSOLICITED 0 ; inline
-
-! how many messages to retrieve results for
-: LDAP_MSG_ONE HEX: 00 ; inline
-: LDAP_MSG_ALL HEX: 01 ; inline
-: LDAP_MSG_RECEIVED HEX: 02 ; inline
-
-! the possible result types returned
-: LDAP_RES_BIND HEX: 61 ; inline
-: LDAP_RES_SEARCH_ENTRY HEX: 64 ; inline
-: LDAP_RES_SEARCH_REFERENCE HEX: 73 ; inline
-: LDAP_RES_SEARCH_RESULT HEX: 65 ; inline
-: LDAP_RES_MODIFY HEX: 67 ; inline
-: LDAP_RES_ADD HEX: 69 ; inline
-: LDAP_RES_DELETE HEX: 6b ; inline
-: LDAP_RES_MODDN HEX: 6d ; inline
-: LDAP_RES_COMPARE HEX: 6f ; inline
-: LDAP_RES_EXTENDED HEX: 78 ; inline
-: LDAP_RES_EXTENDED_PARTIAL HEX: 79 ; inline
-
-: result-types ( -- seq ) {
- { HEX: 61 "LDAP_RES_BIND" }
- { HEX: 64 "LDAP_RES_SEARCH_ENTRY" }
- { HEX: 73 "LDAP_RES_SEARCH_REFERENCE" }
- { HEX: 65 "LDAP_RES_SEARCH_RESULT" }
- { HEX: 67 "LDAP_RES_MODIFY" }
- { HEX: 69 "LDAP_RES_ADD" }
- { HEX: 6b "LDAP_RES_DELETE" }
- { HEX: 6d "LDAP_RES_MODDN" }
- { HEX: 6f "LDAP_RES_COMPARE" }
- { HEX: 78 "LDAP_RES_EXTENDED" }
- { HEX: 79 "LDAP_RES_EXTENDED_PARTIAL" }
-} ;
-
-: LDAP_OPT_PROTOCOL_VERSION HEX: 0011 ; inline
-
-C-STRUCT: ldap
- { "char" "ld_lberoptions" }
- { "int" "ld_deref" }
- { "int" "ld_timelimit" }
- { "int" "ld_sizelimit" }
- { "int" "ld_errno" }
- { "char*" "ld_error" }
- { "char*" "ld_matched" }
- { "int" "ld_refhoplimit" }
- { "ulong" "ld_options" } ;
-
-LIBRARY: libldap
-
-! ===============================================
-! ldap.h
-! ===============================================
-
-! Will be depreciated in a later release (ldap_init() is preferred)
-FUNCTION: void* ldap_open ( char* host, int port ) ;
-
-FUNCTION: void* ldap_init ( char* host, int port ) ;
-
-FUNCTION: int ldap_initialize ( ldap* ld, char* url ) ;
-
-FUNCTION: int ldap_get_option ( void* ld, int option, void* outvalue ) ;
-
-FUNCTION: int ldap_set_option ( void* ld, int option, void* invalue ) ;
-
-FUNCTION: int ldap_simple_bind ( void* ld, char* who, char* passwd ) ;
-
-FUNCTION: int ldap_simple_bind_s ( void* ld, char* who, char* passwd ) ;
-
-FUNCTION: int ldap_unbind_s ( void* ld ) ;
-
-FUNCTION: int ldap_result2error ( void* ld, void* res, int freeit ) ;
-
-FUNCTION: char* ldap_err2string ( int err ) ;
-
-FUNCTION: int ldap_search ( void* ld, char* base, int scope, char* filter,
- char* attrs, int attrsonly ) ;
-
-FUNCTION: int ldap_search_s ( void* ld, char* base, int scope, char* filter,
- char* attrs, int attrsonly, void* res ) ;
-
-FUNCTION: int ldap_result ( void* ld, int msgid, int all, void* timeout,
- void* result ) ;
-
-FUNCTION: int ldap_parse_result ( void* ld, void* result, int* errcodep,
- char* matcheddnp, char* errmsgp,
- char* referralsp, void* serverctrlsp,
- int freeit ) ;
-
-FUNCTION: int ldap_count_messages ( void* ld, void* result ) ;
-
-FUNCTION: void* ldap_first_message ( void* ld, void* result ) ;
-
-FUNCTION: void* ldap_next_message ( void* ld, void* message ) ;
-
-FUNCTION: int ldap_msgtype ( void* msg ) ;
-
-FUNCTION: int ldap_msgid ( void* msg ) ;
-
-FUNCTION: int ldap_count_entries ( void* ld, void* result ) ;
-
-FUNCTION: void* ldap_first_entry ( void* ld, void* result ) ;
-
-FUNCTION: void* ldap_next_entry ( void* ld, void* entry ) ;
-
-FUNCTION: char* ldap_first_attribute ( void* ld, void* entry, void* berptr ) ;
-
-FUNCTION: char* ldap_next_attribute ( void* ld, void* entry, void* ber ) ;
-
-FUNCTION: char** ldap_get_values ( void* ld, void* entry, char* attr ) ;
-
-FUNCTION: char* ldap_get_dn ( void* ld, void* entry ) ;
+++ /dev/null
-OpenLDAP binding
+++ /dev/null
-enterprise
-network
SYMBOL: costs
: init-d ( str1 str2 -- )
- [ length 1+ ] 2apply 2dup <matrix> d set
+ [ length 1+ ] bi@ 2dup <matrix> d set
[ 0 over ->d ] each
[ dup 0 ->d ] each ; inline
[
2dup init-d
2dup compute-costs
- [ length ] 2apply [
+ [ length ] bi@ [
[ levenshtein-step ] curry each
] with each
levenshtein-result
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: io lint kernel math tools.test ;
-IN: lint.tests
-
-! Don't write code like this
-: lint1
- [ "hi" print ] [ ] if ; ! when
-
-[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test
-
-: lint2
- 1 + ; ! 1+
-[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
-
-: lint3
- dup -rot ; ! tuck
-
-[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.accessors arrays assocs combinators.lib io kernel
-macros math namespaces prettyprint quotations sequences
-vectors vocabs words html.elements slots.private tar ;
-IN: lint
-
-SYMBOL: def-hash
-SYMBOL: def-hash-keys
-
-: set-hash-vector ( val key hash -- )
- 2dup at -rot >r >r ?push r> r> set-at ;
-
-: add-word-def ( word quot -- )
- dup callable? [
- def-hash get-global set-hash-vector
- ] [
- 2drop
- ] if ;
-
-: more-defs
- {
- { [ swap >r swap r> ] -rot }
- { [ swap swapd ] -rot }
- { [ >r swap r> swap ] rot }
- { [ swapd swap ] rot }
- { [ dup swap ] over }
- { [ dup -rot ] tuck }
- { [ >r swap r> ] swapd }
- { [ nip nip ] 2nip }
- { [ drop drop ] 2drop }
- { [ drop drop drop ] 3drop }
- { [ 0 = ] zero? }
- { [ pop drop ] pop* }
- { [ [ ] if ] when }
- } [ first2 swap add-word-def ] each ;
-
-: accessor-words ( -- seq )
-{
- alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
- alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
- <displaced-alien> alien-unsigned-cell set-alien-signed-cell
- set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
- set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
- set-alien-unsigned-8 set-alien-signed-8
- alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
- set-alien-float alien-float
-} ;
-
-: trivial-defs
- {
- [ get ] [ t ] [ { } ] [ . ] [ drop f ]
- [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
- [ ">" write-html ] [ <unimplemented-typeflag> throw ]
- [ "/>" write-html ]
- } ;
-
-H{ } clone def-hash set-global
-all-words [ dup word-def add-word-def ] each
-more-defs
-
-! Remove empty word defs
-def-hash get-global [
- drop empty? not
-] assoc-subset
-
-! Remove constants [ 1 ]
-[
- drop dup length 1 = swap first number? and not
-] assoc-subset
-
-! Remove set-alien-cell, etc.
-[
- drop [ accessor-words swap seq-diff ] keep [ length ] 2apply =
-] assoc-subset
-
-! Remove trivial defs
-[
- drop trivial-defs member? not
-] assoc-subset
-
-! Remove n m shift defs
-[
- drop dup length 3 = [
- dup first2 [ number? ] both?
- swap third \ shift = and not
- ] [ drop t ] if
-] assoc-subset
-
-! Remove [ n slot ]
-[
- drop dup length 2 = [
- first2 \ slot = swap number? and not
- ] [ drop t ] if
-] assoc-subset def-hash set-global
-
-: find-duplicates
- def-hash get-global [
- nip length 1 >
- ] assoc-subset ;
-
-def-hash get-global keys def-hash-keys set-global
-
-GENERIC: lint ( obj -- seq )
-
-M: object lint ( obj -- seq )
- drop f ;
-
-: subseq/member? ( subseq/member seq -- ? )
- { [ 2dup start ] [ 2dup member? ] } || 2nip ;
-
-M: callable lint ( quot -- seq )
- def-hash-keys get [
- swap subseq/member?
- ] with subset ;
-
-M: word lint ( word -- seq )
- word-def dup callable? [ lint ] [ drop f ] if ;
-
-: word-path. ( word -- )
- [ word-vocabulary ":" ] keep unparse 3append write nl ;
-
-: (lint.) ( pair -- )
- first2 >r word-path. r> [
- bl bl bl bl
- dup .
- "-----------------------------------" print
- def-hash get at [ bl bl bl bl word-path. ] each
- nl
- ] each nl nl ;
-
-: lint. ( alist -- )
- [ (lint.) ] each ;
-
-
-GENERIC: run-lint ( obj -- obj )
-
-: (trim-self)
- def-hash get-global at* [
- dupd remove empty? not
- ] [
- drop f
- ] if ;
-
-: trim-self ( seq -- newseq )
- [ [ (trim-self) ] subset ] assoc-map ;
-
-: filter-symbols ( alist -- alist )
- [
- nip first dup def-hash get at
- [ first ] 2apply literalize = not
- ] assoc-subset ;
-
-M: sequence run-lint ( seq -- seq )
- [
- global [ dup . flush ] bind
- dup lint
- ] { } map>assoc
- trim-self
- [ second empty? not ] subset
- filter-symbols ;
-
-M: word run-lint ( word -- seq )
- 1array run-lint ;
-
-: lint-all ( -- seq )
- all-words run-lint dup lint. ;
-
-: lint-vocab ( vocab -- seq )
- words run-lint dup lint. ;
-
-: lint-word ( word -- seq )
- 1array run-lint dup lint. ;
+++ /dev/null
-Finds potential mistakes in code
--- /dev/null
+IN: locals.backend.tests
+USING: tools.test locals.backend kernel arrays ;
+
+[ 3 ] [ 3 >r 1 get-local r> drop ] unit-test
+
+[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
+
+: get-local-test-1 3 >r 1 get-local r> drop ;
+
+{ 0 1 } [ get-local-test-1 ] must-infer-as
+
+[ 3 ] [ get-local-test-1 ] unit-test
+
+: get-local-test-2 3 4 >r >r 2 get-local 2 drop-locals ;
+
+{ 0 1 } [ get-local-test-2 ] must-infer-as
+
+[ 4 ] [ get-local-test-2 ] unit-test
+
+: get-local-test-3 3 4 >r >r 2 get-local r> r> 2array ;
+
+{ 0 2 } [ get-local-test-3 ] must-infer-as
+
+[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
+
+: get-local-test-4 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
+
+{ 0 2 } [ get-local-test-4 ] must-infer-as
+
+[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
+
+[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
+
+: load-locals-test-1 1 2 2 load-locals r> r> ;
+
+{ 0 2 } [ load-locals-test-1 ] must-infer-as
+
+[ 1 2 ] [ load-locals-test-1 ] unit-test
--- /dev/null
+USING: math kernel slots.private inference.known-words
+inference.backend sequences effects words ;
+IN: locals.backend
+
+: load-locals ( n -- )
+ dup zero? [ drop ] [ swap >r 1- load-locals ] if ;
+
+: get-local ( n -- value )
+ dup zero? [ drop dup ] [ r> swap 1- get-local swap >r ] if ;
+
+: local-value 2 slot ; inline
+
+: set-local-value 2 set-slot ; inline
+
+: drop-locals ( n -- )
+ dup zero? [ drop ] [ r> drop 1- drop-locals ] if ;
+
+\ load-locals [
+ pop-literal nip
+ [ dup reverse <effect> infer-shuffle ]
+ [ infer->r ]
+ bi
+] "infer" set-word-prop
+
+\ get-local [
+ pop-literal nip
+ [ infer-r> ]
+ [ dup 0 prefix <effect> infer-shuffle ]
+ [ infer->r ]
+ tri
+] "infer" set-word-prop
+
+\ drop-locals [
+ pop-literal nip
+ [ infer-r> ]
+ [ { } <effect> infer-shuffle ] bi
+] "infer" set-word-prop
+
+<<
+{ load-locals get-local drop-locals }
+[ t "no-compile" set-word-prop ] each
+>>
HELP: [let
{ $syntax "[let | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
-{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." }
+{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." }
{ $examples
{ $example
"USING: kernel locals math math.functions prettyprint sequences ;"
}
$with-locals-note ;
+HELP: [let*
+{ $syntax "[let* | binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n body... ]" }
+{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated sequentially, and may refer to previous bindings from the same " { $link POSTPONE: [let* } " form; for Lisp programmers, this means that " { $link POSTPONE: [let* } " is equivalent to the Lisp " { $snippet "let*" } ", not " { $snippet "let" } "." }
+{ $examples
+ { $example
+ "USING: kernel locals math math.functions prettyprint sequences ;"
+ ":: frobnicate ( n seq -- newseq )"
+ " [let* | a [ n 3 + ]"
+ " b [ a 4 * ] |"
+ " seq [ b / ] map ] ;"
+ "1 { 32 48 } frobnicate ."
+ "{ 2 3 }"
+ }
+}
+$with-locals-note ;
+
+{ POSTPONE: [let POSTPONE: [let* } related-words
+
HELP: [wlet
{ $syntax "[wlet | binding1 [ body1... ]\n binding2 [ body2... ]\n ... |\n body... ]" }
{ $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [wlet } " is equivalent to the Lisp " { $snippet "flet" } ", not " { $snippet "labels" } "." }
{ $subsection with-locals }
"Lexical binding forms:"
{ $subsection POSTPONE: [let }
+{ $subsection POSTPONE: [let* }
{ $subsection POSTPONE: [wlet }
"Lambda abstractions:"
{ $subsection POSTPONE: [| }
0 write-test-1 "q" set
+{ 1 1 } "q" get must-infer-as
+
[ 1 ] [ 1 "q" get call ] unit-test
[ 2 ] [ 1 "q" get call ] unit-test
] unit-test
[ 5 ] [ 10 xyzzy ] unit-test
+
+:: let*-test-1 ( a -- b )
+ [let* | b [ a 1+ ]
+ c [ b 1+ ] |
+ a b c 3array ] ;
+
+[ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
+
+:: let*-test-2 ( a -- b )
+ [let* | b [ a 1+ ]
+ c! [ b 1+ ] |
+ a b c 3array ] ;
+
+[ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
+
+:: let*-test-3 ( a -- b )
+ [let* | b [ a 1+ ]
+ c! [ b 1+ ] |
+ c 1+ c! a b c 3array ] ;
+
+[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
+
+:: let*-test-4 ( a b -- c d )
+ [let | a [ b ]
+ b [ a ] |
+ [let* | a' [ a ]
+ a'' [ a' ]
+ b' [ b ]
+ b'' [ b' ] |
+ a'' b'' ] ] ;
+
+[ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
+
USING: kernel namespaces sequences sequences.private assocs math
inference.transforms parser words quotations debugger macros
arrays macros splitting combinators prettyprint.backend
-definitions prettyprint hashtables combinators.lib
-prettyprint.sections sequences.private effects generic
-compiler.units combinators.cleave ;
+definitions prettyprint hashtables prettyprint.sections sets
+sequences.private effects generic compiler.units accessors
+locals.backend ;
IN: locals
! Inspired by
C: <lambda> lambda
-TUPLE: let bindings vars body ;
+TUPLE: let bindings body ;
C: <let> let
-TUPLE: wlet bindings vars body ;
+TUPLE: let* bindings body ;
+
+C: <let*> let*
+
+TUPLE: wlet bindings body ;
C: <wlet> wlet
-PREDICATE: word local "local?" word-prop ;
+PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )
#! Create a local variable identifier
f <word> dup t "local?" set-word-prop ;
-PREDICATE: word local-word "local-word?" word-prop ;
+PREDICATE: local-word < word "local-word?" word-prop ;
: <local-word> ( name -- word )
f <word> dup t "local-word?" set-word-prop ;
-PREDICATE: word local-reader "local-reader?" word-prop ;
+PREDICATE: local-reader < word "local-reader?" word-prop ;
: <local-reader> ( name -- word )
f <word> dup t "local-reader?" set-word-prop ;
-PREDICATE: word local-writer "local-writer?" word-prop ;
+PREDICATE: local-writer < word "local-writer?" word-prop ;
: <local-writer> ( reader -- word )
dup word-name "!" append f <word>
C: <quote> quote
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! read-local
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: local-index ( obj args -- n )
[ dup quote? [ quote-local ] when eq? ] with find drop ;
-: read-local ( obj args -- quot )
- local-index 1+
- dup [ r> ] <repetition> concat [ dup ] append
- swap [ swap >r ] <repetition> concat append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! localize
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: read-local-quot ( obj args -- quot )
+ local-index 1+ [ get-local ] curry ;
: localize-writer ( obj args -- quot )
- >r "local-reader" word-prop r> read-local [ 0 swap set-array-nth ] append ;
+ >r "local-reader" word-prop r>
+ read-local-quot [ set-local-value ] append ;
: localize ( obj args -- quot )
{
- { [ over local? ] [ read-local ] }
- { [ over quote? ] [ >r quote-local r> read-local ] }
- { [ over local-word? ] [ read-local [ call ] append ] }
- { [ over local-reader? ] [ read-local [ 0 swap array-nth ] append ] }
+ { [ over local? ] [ read-local-quot ] }
+ { [ over quote? ] [ >r quote-local r> read-local-quot ] }
+ { [ over local-word? ] [ read-local-quot [ call ] append ] }
+ { [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
{ [ over local-writer? ] [ localize-writer ] }
{ [ over \ lambda eq? ] [ 2drop [ ] ] }
{ [ t ] [ drop 1quotation ] }
} cond ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! point-free
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
UNION: special local quote local-word local-reader local-writer ;
-: load-local ( arg -- quot )
- local-reader? [ 1array >r ] [ >r ] ? ;
-
-: load-locals ( quot args -- quot )
- nip <reversed> [ load-local ] map concat ;
+: load-locals-quot ( args -- quot )
+ dup [ local-reader? ] contains? [
+ <reversed> [
+ local-reader? [ 1array >r ] [ >r ] ?
+ ] map concat
+ ] [
+ length [ load-locals ] curry >quotation
+ ] if ;
-: drop-locals ( args -- args quot )
- dup length [ r> drop ] <repetition> concat ;
+: drop-locals-quot ( args -- quot )
+ length [ drop-locals ] curry ;
: point-free-body ( quot args -- newquot )
>r 1 head-slice* r> [ localize ] curry map concat ;
: point-free-end ( quot args -- newquot )
over peek special?
- [ drop-locals >r >r peek r> localize r> append ]
- [ drop-locals nip swap peek add ]
+ [ dup drop-locals-quot >r >r peek r> localize r> append ]
+ [ dup drop-locals-quot nip swap peek suffix ]
if ;
: (point-free) ( quot args -- newquot )
- [ load-locals ] [ point-free-body ] [ point-free-end ]
+ [ nip load-locals-quot ]
+ [ point-free-body ]
+ [ point-free-end ]
2tri 3append >quotation ;
: point-free ( quot args -- newquot )
over empty? [ drop ] [ (point-free) ] if ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! free-vars
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
UNION: lexical local local-reader local-writer local-word ;
-GENERIC: free-vars ( form -- vars )
+GENERIC: free-vars* ( form -- )
-: add-if-free ( vars object -- vars )
+: free-vars ( form -- vars )
+ [ free-vars* ] { } make prune ;
+
+: add-if-free ( object -- )
{
- { [ dup local-writer? ] [ "local-reader" word-prop add ] }
- { [ dup lexical? ] [ add ] }
- { [ dup quote? ] [ quote-local add ] }
- { [ t ] [ free-vars append ] }
+ { [ dup local-writer? ] [ "local-reader" word-prop , ] }
+ { [ dup lexical? ] [ , ] }
+ { [ dup quote? ] [ local>> , ] }
+ { [ t ] [ free-vars* ] }
} cond ;
-M: object free-vars drop { } ;
-
-M: quotation free-vars { } [ add-if-free ] reduce ;
+M: object free-vars* drop ;
-M: lambda free-vars
- dup lambda-vars swap lambda-body free-vars seq-diff ;
+M: quotation free-vars* [ add-if-free ] each ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! lambda-rewrite
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+M: lambda free-vars*
+ [ vars>> ] [ body>> ] bi free-vars diff % ;
GENERIC: lambda-rewrite* ( obj -- )
M: callable local-rewrite*
[ [ local-rewrite* ] each ] [ ] make , ;
-M: lambda block-vars lambda-vars ;
+M: lambda block-vars vars>> ;
-M: lambda block-body lambda-body ;
+M: lambda block-body body>> ;
M: lambda local-rewrite*
- dup lambda-vars swap lambda-body
- [ local-rewrite* \ call , ] [ ] make <lambda> , ;
+ [ vars>> ] [ body>> ] bi
+ [ [ local-rewrite* ] each ] [ ] make <lambda> , ;
M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them
#! onto the body
dup free-vars [ <quote> ] map dup % [
- over block-vars swap append
+ over block-vars prepend
swap block-body [ [ lambda-rewrite* ] each ] [ ] make
swap point-free ,
] keep length \ curry <repetition> % ;
M: object local-rewrite* , ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: make-local ( name -- word )
+ "!" ?tail [
+ <local-reader>
+ dup <local-writer> dup word-name set
+ ] [ <local> ] if
+ dup dup word-name set ;
: make-locals ( seq -- words assoc )
- [
- "!" ?tail [ <local-reader> ] [ <local> ] if
- ] map dup [
- dup
- [ dup word-name set ] each
- [
- dup local-reader? [
- <local-writer> dup word-name set
- ] [
- drop
- ] if
- ] each
- ] H{ } make-assoc ;
-
-: make-local-words ( seq -- words assoc )
- [ dup <local-word> ] { } map>assoc
- dup values swap ;
+ [ [ make-local ] map ] H{ } make-assoc ;
+
+: make-local-word ( name -- word )
+ <local-word> dup dup word-name set ;
: push-locals ( assoc -- )
use get push ;
use get delete ;
: (parse-lambda) ( assoc end -- quot )
- over push-locals parse-until >quotation swap pop-locals ;
+ parse-until >quotation swap pop-locals ;
: parse-lambda ( -- lambda )
- "|" parse-tokens make-locals \ ] (parse-lambda) <lambda> ;
+ "|" parse-tokens make-locals dup push-locals
+ \ ] (parse-lambda) <lambda> ;
-: (parse-bindings) ( -- )
+: parse-binding ( -- pair/f )
scan dup "|" = [
- drop
+ drop f
] [
scan {
{ "[" [ \ ] parse-until >quotation ] }
{ "[|" [ parse-lambda ] }
- } case 2array ,
- (parse-bindings)
+ } case 2array
] if ;
-: parse-bindings ( -- alist )
- scan "|" assert= [ (parse-bindings) ] { } make dup keys ;
+: (parse-bindings) ( -- )
+ parse-binding [
+ first2 >r make-local r> 2array ,
+ (parse-bindings)
+ ] when* ;
+
+: parse-bindings ( -- bindings vars )
+ [
+ [ (parse-bindings) ] H{ } make-assoc
+ dup push-locals
+ ] { } make swap ;
-M: let local-rewrite*
- { let-bindings let-vars let-body } get-slots -rot
- [ <reversed> ] 2apply
+: parse-bindings* ( -- words assoc )
+ [
+ [
+ namespace push-locals
+
+ (parse-bindings)
+ ] { } make-assoc
+ ] { } make swap ;
+
+: (parse-wbindings) ( -- )
+ parse-binding [
+ first2 >r make-local-word r> 2array ,
+ (parse-wbindings)
+ ] when* ;
+
+: parse-wbindings ( -- bindings vars )
[
- 1array -rot second -rot <lambda>
- [ call ] curry compose
- ] 2each local-rewrite* \ call , ;
+ [ (parse-wbindings) ] H{ } make-assoc
+ dup push-locals
+ ] { } make swap ;
+
+: let-rewrite ( body bindings -- )
+ <reversed> [
+ >r 1array r> spin <lambda> [ call ] curry compose
+ ] assoc-each local-rewrite* \ call , ;
+
+M: let local-rewrite*
+ [ body>> ] [ bindings>> ] bi let-rewrite ;
+
+M: let* local-rewrite*
+ [ body>> ] [ bindings>> ] bi let-rewrite ;
M: wlet local-rewrite*
- dup wlet-bindings values over wlet-vars rot wlet-body
- <lambda> [ call ] curry compose local-rewrite* \ call , ;
+ [ body>> ] [ bindings>> ] bi
+ [ [ ] curry ] assoc-map
+ let-rewrite ;
-: parse-locals
+: parse-locals ( -- vars assoc )
parse-effect
word [ over "declared-effect" set-word-prop ] when*
- effect-in make-locals ;
+ effect-in make-locals dup push-locals ;
: parse-locals-definition ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
: [| parse-lambda parsed ; parsing
: [let
- parse-bindings
- make-locals \ ] (parse-lambda)
- <let> parsed ; parsing
+ scan "|" assert= parse-bindings
+\ ] (parse-lambda) <let> parsed ; parsing
+
+: [let*
+ scan "|" assert= parse-bindings*
+ >r \ ] parse-until >quotation <let*> parsed r> pop-locals ;
+ parsing
: [wlet
- parse-bindings
- make-local-words \ ] (parse-lambda)
- <wlet> parsed ; parsing
+ scan "|" assert= parse-wbindings
+ \ ] (parse-lambda) <wlet> parsed ; parsing
MACRO: with-locals ( form -- quot ) lambda-rewrite ;
M: lambda pprint*
<flow
\ [| pprint-word
- dup lambda-vars pprint-vars
+ dup vars>> pprint-vars
\ | pprint-word
- f <inset lambda-body pprint-elements block>
+ f <inset body>> pprint-elements block>
\ ] pprint-word
block> ;
-: pprint-let ( body vars bindings -- )
+: pprint-let ( let word -- )
+ pprint-word
+ [ body>> ] [ bindings>> ] bi
\ | pprint-word
t <inset
<block
- values [ <block >r pprint-var r> pprint* block> ] 2each
+ [ <block >r pprint-var r> pprint* block> ] assoc-each
block>
\ | pprint-word
<block pprint-elements block>
- block> ;
-
-M: let pprint*
- \ [let pprint-word
- { let-body let-vars let-bindings } get-slots pprint-let
+ block>
\ ] pprint-word ;
-M: wlet pprint*
- \ [wlet pprint-word
- { wlet-body wlet-vars wlet-bindings } get-slots pprint-let
- \ ] pprint-word ;
+M: let pprint* \ [let pprint-let ;
+
+M: wlet pprint* \ [wlet pprint-let ;
+
+M: let* pprint* \ [let* pprint-let ;
-PREDICATE: word lambda-word
+PREDICATE: lambda-word < word
"lambda" word-prop >boolean ;
M: lambda-word definer drop \ :: \ ; ;
M: lambda-word definition
- "lambda" word-prop lambda-body ;
+ "lambda" word-prop body>> ;
: lambda-word-synopsis ( word -- )
dup definer.
M: lambda-word synopsis* lambda-word-synopsis ;
-PREDICATE: macro lambda-macro
+PREDICATE: lambda-macro < macro
"lambda" word-prop >boolean ;
M: lambda-macro definer drop \ MACRO:: \ ; ;
M: lambda-macro definition
- "lambda" word-prop lambda-body ;
+ "lambda" word-prop body>> ;
M: lambda-macro synopsis* lambda-word-synopsis ;
-PREDICATE: method-body lambda-method
+PREDICATE: lambda-method < method-body
"lambda" word-prop >boolean ;
M: lambda-method definer drop \ M:: \ ; ;
M: lambda-method definition
- "lambda" word-prop lambda-body ;
+ "lambda" word-prop body>> ;
: method-stack-effect ( method -- effect )
- dup "lambda" word-prop lambda-vars
+ dup "lambda" word-prop vars>>
swap "method-generic" word-prop stack-effect
dup [ effect-out ] when
<effect> ;
{ DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ;\r
\r
: send-to-log-server ( array string -- )\r
- add* "log-server" get send ;\r
+ prefix "log-server" get send ;\r
\r
SYMBOL: log-service\r
\r
parse-log-line {\r
{ [ dup malformed? ] [ malformed-line ] }\r
{ [ dup multiline? ] [ add-multiline ] }\r
- { [ t ] [ , ] }\r
+ [ , ]\r
} cond\r
] each\r
] { } make ;\r
\ log-root get "logs" resource-path or ;\r
\r
: log-path ( service -- path )\r
- log-root swap path+ ;\r
+ log-root prepend-path ;\r
\r
: log# ( path n -- path' )\r
- number>string ".log" append path+ ;\r
+ number>string ".log" append append-path ;\r
\r
SYMBOL: log-files\r
\r
rot [ empty? not ] subset {\r
{ [ dup empty? ] [ 3drop ] }\r
{ [ dup length 1 = ] [ first -rot f (write-message) ] }\r
- { [ t ] [\r
+ [\r
[ first -rot f (write-message) ] 3keep\r
1 tail -rot [ t (write-message) ] 2curry each\r
- ] }\r
+ ]\r
} cond ;\r
\r
: (log-message) ( msg -- )\r
USING: kernel sequences quotations assocs math math.parser
- combinators.cleave combinators.lib vars lsys.strings ;
+ combinators.lib vars lsys.strings ;
IN: lsys.strings.interpret
USING: kernel sbufs strings sequences assocs math
- combinators.cleave combinators.lib vars lsys.strings ;
+ combinators.lib vars lsys.strings ;
IN: lsys.strings.rewrite
-USING: kernel sequences math combinators.cleave combinators.lib ;
+USING: kernel sequences math combinators.lib ;
IN: lsys.strings
{ 0.25 0.25 0.25 } ! dark grey
{ 0.75 0.75 0.75 } ! medium grey
{ 1 1 1 } ! white
-} [ 1 add ] map >color-table ;
+} [ 1 suffix ] map >color-table ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
handler> "L-system view" open-window
+500 sleep
+
slate> find-gl-context
1 glGenLists >model
: MACRO:
(:) define-macro ; parsing
-PREDICATE: word macro "macro" word-prop >boolean ;
+PREDICATE: macro < word "macro" word-prop >boolean ;
M: macro definer drop \ MACRO: \ ; ;
-Utility for defining compiler transforms, and short-circuiting boolean operators
+Utility for defining compiler transforms
! See http://factorcode.org/license.txt for BSD license.
!
! Based on pattern matching code from Paul Graham's book 'On Lisp'.
-USING: parser kernel words namespaces sequences tuples
+USING: parser kernel words namespaces sequences classes.tuple
combinators macros assocs math ;
IN: match
{ [ 2dup = ] [ 2drop t ] }
{ [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
{ [ 2dup [ sequence? ] both? ] [
- 2dup [ length ] 2apply =
+ 2dup [ length ] bi@ =
[ [ (match) ] 2all? ] [ 2drop f ] if ] }
{ [ 2dup [ tuple? ] both? ]
- [ [ tuple>array ] 2apply [ (match) ] 2all? ] }
+ [ [ tuple>array ] bi@ [ (match) ] 2all? ] }
{ [ t ] [ 2drop f ] }
} cond ;
{ [ dup match-var? ] [ get ] }
{ [ dup sequence? ] [ [ replace-patterns ] map ] }
{ [ dup tuple? ] [ tuple>array replace-patterns >tuple ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: match-replace ( object pattern1 pattern2 -- result )
-rot
match [ "Pattern does not match" throw ] unless*
[ replace-patterns ] bind ;
+
+: ?1-tail ( seq -- tail/f )
+ dup length zero? not [ 1 tail ] [ drop f ] if ;
+
+: (match-first) ( seq pattern-seq -- bindings leftover/f )
+ 2dup [ length ] bi@ < [ 2drop f f ]
+ [
+ 2dup length head over match
+ [ nip swap ?1-tail ] [ >r 1 tail r> (match-first) ] if*
+ ] if ;
+
+: match-first ( seq pattern-seq -- bindings )
+ (match-first) drop ;
+
+: (match-all) ( seq pattern-seq -- )
+ tuck (match-first) swap
+ [
+ , [ swap (match-all) ] [ drop ] if*
+ ] [ 2drop ] if* ;
+
+: match-all ( seq pattern-seq -- bindings-seq )
+ [ (match-all) ] { } make ;
+
USING: kernel math math.constants math.functions math.intervals
-math.vectors namespaces sequences combinators.cleave ;
+math.vectors namespaces sequences ;
IN: math.analysis
<PRIVATE
--- /dev/null
+USING: help.markup help.syntax kernel math sequences ;
+IN: math.bitfields.lib
+
+HELP: bits
+{ $values { "m" integer } { "n" integer } { "m'" integer } }
+{ $description "Keep only n bits from the integer m." }
+{ $example "USING: math.bitfields.lib prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ;
+
+HELP: bitroll
+{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
+{ $description "Roll n by s bits to the left, wrapping around after w bits." }
+{ $examples
+ { $example "USING: math.bitfields.lib prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
+ { $example "USING: math.bitfields.lib prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
+} ;
+
--- /dev/null
+USING: math.bitfields.lib tools.test ;
+IN: math.bitfields.lib.test
+
+[ 0 ] [ 1 0 0 bitroll ] unit-test
+[ 1 ] [ 1 0 1 bitroll ] unit-test
+[ 1 ] [ 1 1 1 bitroll ] unit-test
+[ 1 ] [ 1 0 2 bitroll ] unit-test
+[ 1 ] [ 1 0 1 bitroll ] unit-test
+[ 1 ] [ 1 20 2 bitroll ] unit-test
+[ 1 ] [ 1 8 8 bitroll ] unit-test
+[ 1 ] [ 1 -8 8 bitroll ] unit-test
+[ 1 ] [ 1 -32 8 bitroll ] unit-test
+[ 128 ] [ 1 -1 8 bitroll ] unit-test
+[ 8 ] [ 1 3 32 bitroll ] unit-test
--- /dev/null
+USING: hints kernel math ;
+IN: math.bitfields.lib
+
+: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
+: set-bit ( x n -- y ) 2^ bitor ; foldable
+: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
+: unmask ( x n -- ? ) bitnot bitand ; foldable
+: unmask? ( x n -- ? ) unmask 0 > ; foldable
+: mask ( x n -- ? ) bitand ; foldable
+: mask? ( x n -- ? ) mask 0 > ; foldable
+: wrap ( m n -- m' ) 1- bitand ; foldable
+: bits ( m n -- m' ) 2^ wrap ; inline
+: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
+
+: shift-mod ( n s w -- n )
+ >r shift r> 2^ wrap ; inline
+
+: bitroll ( x s w -- y )
+ [ wrap ] keep
+ [ shift-mod ]
+ [ [ - ] keep shift-mod ] 3bi bitor ; inline
+
+: bitroll-32 ( n s -- n' ) 32 bitroll ;
+
+HINTS: bitroll-32 bignum fixnum ;
+
+: bitroll-64 ( n s -- n' ) 64 bitroll ;
+
+HINTS: bitroll-64 bignum fixnum ;
+
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] unfold reverse 2nip ;
: (>permutation) ( seq n -- seq )
- [ [ dupd >= [ 1+ ] when ] curry map ] keep add* ;
+ [ [ dupd >= [ 1+ ] when ] curry map ] keep prefix ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
M: real real-part ;
M: real imaginary-part drop 0 ;
-M: complex absq >rect [ sq ] 2apply + ;
+M: complex absq >rect [ sq ] bi@ + ;
: 2>rect ( x y -- xr yr xi yi )
- [ [ real-part ] 2apply ] 2keep
- [ imaginary-part ] 2apply ; inline
+ [ [ real-part ] bi@ ] 2keep
+ [ imaginary-part ] bi@ ; inline
M: complex number=
2>rect number= [ number= ] [ 2drop f ] if ;
[ [ indices ] keep erato-bits [ f -rot set-nth ] curry each ] [ 2drop ] if ;
: <erato> ( n -- erato )
- dup ind 1+ <bit-array> 1 over set-bits erato construct-boa ;
+ dup ind 1+ <bit-array> 1 over set-bits erato boa ;
: next-prime ( erato -- prime/f )
[ erato-latest 2 + ] keep [ set-erato-latest ] 2keep
! Fast Fourier Transform, copyright (C) 2007 Hans Schmid
! http://dressguardmeister.blogspot.com/2007/01/fft.html
USING: arrays sequences math math.vectors math.constants
-math.functions kernel splitting ;
+math.functions kernel splitting columns ;
IN: math.fft
: n^v ( n v -- w ) [ ^ ] with map ;
{ $subsection gcd }
{ $subsection log2 }
{ $subsection next-power-of-2 }
+"Modular exponentiation:"
+{ $subsection ^mod }
+{ $subsection mod-inv }
"Tests:"
{ $subsection power-of-2? }
{ $subsection even? }
{ $subsection ceiling }
{ $subsection floor }
{ $subsection truncate }
-{ $subsection round } ;
+{ $subsection round }
+"Inexact comparison:"
+{ $subsection ~ } ;
ARTICLE: "power-functions" "Powers and logarithms"
"Squares:"
{ $values { "z" number } { "x" real } { "y" real } }
{ $description "Extracts the real and imaginary components of a complex number." } ;
-HELP: power-of-2?
-{ $values { "n" integer } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "n" } " is a power of 2." } ;
-
HELP: align
{ $values { "m" integer } { "w" "a power of 2" } { "n" "an integer multiple of " { $snippet "w" } } }
{ $description "Outputs the least multiple of " { $snippet "w" } " greater than " { $snippet "m" } "." }
[ 1/8 ] [ 2 -3 ^ ] unit-test
[ t ] [ 1 100 shift 2 100 ^ = ] unit-test
-[ t ] [ 256 power-of-2? ] unit-test
-[ f ] [ 123 power-of-2? ] unit-test
-
[ 1 ] [ 7/8 ceiling ] unit-test
[ 2 ] [ 3/2 ceiling ] unit-test
[ 0 ] [ -7/8 ceiling ] unit-test
2dup >r >r >r odd? r> call r> 2/ r> each-bit
] if ; inline
-: clear-bit ( x n -- y ) 2^ bitnot bitand ; foldable
-: set-bit ( x n -- y ) 2^ bitor ; foldable
-: bit-clear? ( x n -- ? ) 2^ bitand zero? ; foldable
-: bit-set? ( x n -- ? ) bit-clear? not ; foldable
-: unmask ( x n -- ? ) bitnot bitand ; foldable
-: unmask? ( x n -- ? ) unmask 0 > ; foldable
-: mask ( x n -- ? ) bitand ; foldable
-: mask? ( x n -- ? ) mask 0 > ; foldable
-
GENERIC: (^) ( x y -- z ) foldable
: ^n ( z w -- z^w )
>r - abs r> < ;
: ~rel ( x y epsilon -- ? )
- >r [ - abs ] 2keep [ abs ] 2apply + r> * < ;
+ >r [ - abs ] 2keep [ abs ] bi@ + r> * < ;
: ~ ( x y epsilon -- ? )
{
{ [ pick fp-nan? pick fp-nan? or ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] }
{ [ dup 0 < ] [ ~rel ] }
- { [ t ] [ ~abs ] }
+ [ ~abs ]
} cond ;
-: power-of-2? ( n -- ? )
- dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable
-
: >rect ( z -- x y ) dup real-part swap imaginary-part ; inline
: conjugate ( z -- z* ) >rect neg rect> ; inline
: arg ( z -- arg ) >float-rect swap fatan2 ; inline
: >polar ( z -- abs arg )
- >float-rect [ [ sq ] 2apply + fsqrt ] 2keep swap fatan2 ;
+ >float-rect [ [ sq ] bi@ + fsqrt ] 2keep swap fatan2 ;
inline
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/
-USING: sequences math kernel splitting ;
+USING: sequences math kernel splitting columns ;
IN: math.haar
: averages ( seq -- seq )
2 group dup averages [ differences ] keep ;
: haar ( seq -- seq )
- dup length 1 <= [ haar-step haar swap append ] unless ;
+ dup length 1 <= [ haar-step haar prepend ] unless ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel sequences math math.functions
-math.vectors combinators.cleave ;
+math.vectors ;
IN: math.matrices
! Matrices
USING: combinators combinators.lib io locals kernel math
math.functions math.ranges namespaces random sequences
-hashtables ;
+hashtables sets ;
IN: math.miller-rabin
SYMBOL: a
: next-odd ( m -- n )
dup even? [ 1+ ] [ 2 + ] if ;
-: random-bits ( m -- n ) 2^ random ; foldable
-
TUPLE: positive-even-expected n ;
: (factor-2s) ( r s -- r s )
{ [ dup 1 <= ] [ 3drop f ] }
{ [ dup 2 = ] [ 3drop t ] }
{ [ dup even? ] [ 3drop f ] }
- { [ t ] [ [ drop trials set t (miller-rabin) ] with-scope ] }
+ [ [ drop trials set t (miller-rabin) ] with-scope ]
} cond ;
: miller-rabin ( n -- ? ) 10 miller-rabin* ;
--- /dev/null
+
+USING: kernel arrays math.vectors ;
+
+IN: math.points
+
+<PRIVATE
+
+: X ( x -- point ) 0 0 3array ;
+: Y ( y -- point ) 0 swap 0 3array ;
+: Z ( z -- point ) 0 0 rot 3array ;
+
+PRIVATE>
+
+: v+x ( seq x -- seq ) X v+ ;
+: v-x ( seq x -- seq ) X v- ;
+
+: v+y ( seq y -- seq ) Y v+ ;
+: v-y ( seq y -- seq ) Y v- ;
+
+: v+z ( seq z -- seq ) Z v+ ;
+: v-z ( seq z -- seq ) Z v- ;
+
<PRIVATE
: 2pad-left ( p p n -- p p ) 0 [ pad-left swap ] 2keep pad-left swap ;
: 2pad-right ( p p n -- p p ) 0 [ pad-right swap ] 2keep pad-right swap ;
-: pextend ( p p -- p p ) 2dup [ length ] 2apply max 2pad-right ;
-: pextend-left ( p p -- p p ) 2dup [ length ] 2apply max 2pad-left ;
+: pextend ( p p -- p p ) 2dup [ length ] bi@ max 2pad-right ;
+: pextend-left ( p p -- p p ) 2dup [ length ] bi@ max 2pad-left ;
: unempty ( seq -- seq ) dup empty? [ drop { 0 } ] when ;
-: 2unempty ( seq seq -- seq seq ) [ unempty ] 2apply ;
+: 2unempty ( seq seq -- seq seq ) [ unempty ] bi@ ;
PRIVATE>
: p= ( p p -- ? ) pextend = ;
: ptrim ( p -- p )
- dup singleton? [ [ zero? ] right-trim ] unless ;
+ dup length 1 = [ [ zero? ] right-trim ] unless ;
-: 2ptrim ( p p -- p p ) [ ptrim ] 2apply ;
+: 2ptrim ( p p -- p p ) [ ptrim ] bi@ ;
: p+ ( p p -- p ) pextend v+ ;
: p- ( p p -- p ) pextend v- ;
: n*p ( n p -- n*p ) n*v ;
! convolution
: pextend-conv ( p p -- p p )
#! extend to: p_m + p_n - 1
- 2dup [ length ] 2apply + 1- 2pad-right [ >vector ] 2apply ;
+ 2dup [ length ] bi@ + 1- 2pad-right [ >vector ] bi@ ;
: p* ( p p -- p )
#! Multiply two polynomials.
: p/mod-setup ( p p -- p p n )
2ptrim
- 2dup [ length ] 2apply -
+ 2dup [ length ] bi@ -
dup 1 < [ drop 1 ] when
[ over length + 0 pad-left pextend ] keep 1+ ;
: /-last ( seq seq -- a )
#! divide the last two numbers in the sequences
- [ peek ] 2apply / ;
+ [ peek ] bi@ / ;
: (p/mod)
2dup /-last
] if ;
: pgcd ( p p -- p q )
- swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] 2apply ;
+ swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ;
: pdiff ( p -- p' )
#! Polynomial derivative.
{ [ dup 2 < ] [ drop { } ] }
{ [ dup 1000003 < ]
[ primes-under-million [ [ <=> ] binsearch 1+ 0 swap ] keep <slice> ] }
- { [ t ]
- [ primes-under-million 1000003 lprimes-from
- rot [ <= ] curry lwhile list>array append ] }
+ [ primes-under-million 1000003 lprimes-from
+ rot [ <= ] curry lwhile list>array append ]
} cond ; foldable
: primes-between ( low high -- seq )
primes-upto
- >r 1- next-prime r>
+ [ 1- next-prime ] dip
[ [ <=> ] binsearch ] keep [ length ] keep <slice> ; foldable
: coprime? ( a b -- ? ) gcd nip 1 = ; foldable
: ** conjugate * ; inline
-: 2q ( u v -- u' u'' v' v'' ) [ first2 ] 2apply ; inline
+: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
: q*a ( u v -- a ) 2q swapd ** >r * r> - ; inline
--- /dev/null
+USING: help.syntax help.markup ;
+
+IN: math.ranges
+
+ARTICLE: "ranges" "Ranges"
+
+ "A " { $emphasis "range" } " is a virtual sequence with elements "
+ "ranging from a to b by step."
+
+ $nl
+
+ "Creating ranges:"
+
+ { $subsection <range> }
+ { $subsection [a,b] }
+ { $subsection (a,b] }
+ { $subsection [a,b) }
+ { $subsection (a,b) }
+ { $subsection [0,b] }
+ { $subsection [1,b] }
+ { $subsection [0,b) } ;
\ No newline at end of file
-USING: kernel layouts math namespaces sequences sequences.private ;
+USING: kernel layouts math namespaces sequences
+sequences.private accessors ;
IN: math.ranges
TUPLE: range from length step ;
-: <range> ( from to step -- range )
+: <range> ( a b step -- range )
>r over - r>
[ / 1+ 0 max >integer ] keep
- range construct-boa ;
+ range boa ;
M: range length ( seq -- n )
- range-length ;
+ length>> ;
M: range nth-unsafe ( n range -- obj )
- [ range-step * ] keep range-from + ;
+ [ step>> * ] keep from>> + ;
INSTANCE: range immutable-sequence
: ,b) dup neg rot + swap ; inline
-: [a,b] twiddle <range> ;
+: [a,b] ( a b -- range ) twiddle <range> ;
-: (a,b] twiddle (a, <range> ;
+: (a,b] ( a b -- range ) twiddle (a, <range> ;
-: [a,b) twiddle ,b) <range> ;
+: [a,b) ( a b -- range ) twiddle ,b) <range> ;
-: (a,b) twiddle (a, ,b) <range> ;
+: (a,b) ( a b -- range ) twiddle (a, ,b) <range> ;
-: [0,b] 0 swap [a,b] ;
+: [0,b] ( b -- range ) 0 swap [a,b] ;
-: [1,b] 1 swap [a,b] ;
+: [1,b] ( b -- range ) 1 swap [a,b] ;
-: [0,b) 0 swap [a,b) ;
+: [0,b) ( b -- range ) 0 swap [a,b) ;
: range-increasing? ( range -- ? )
- range-step 0 > ;
+ step>> 0 > ;
: range-decreasing? ( range -- ? )
- range-step 0 < ;
+ step>> 0 < ;
: first-or-peek ( seq head? -- elt )
[ first ] [ peek ] if ;
dup range-decreasing? first-or-peek ;
: clamp-to-range ( n range -- n )
- tuck range-min max swap range-max min ;
+ [ range-min max ] [ range-max min ] bi ;
: sequence-index-range ( seq -- range )
length [0,b) ;
dup numerator swap denominator ; inline
: 2>fraction ( a/b c/d -- a c b d )
- [ >fraction ] 2apply swapd ; inline
+ [ >fraction ] bi@ swapd ; inline
<PRIVATE
dup zero? [
"Division by zero" throw
] [
- dup 0 < [ [ neg ] 2apply ] when
+ dup 0 < [ [ neg ] bi@ ] when
2dup gcd nip tuck /i >r /i r> fraction>
] if ;
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y))
- 0 [ [ >r pick r> swap - ] 2apply * + ] 2reduce 2nip ;
+ 0 [ [ >r pick r> swap - ] bi@ * + ] 2reduce 2nip ;
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
* recip >r [ ((r)) ] keep length 1- / r> * ;
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
- first2 [ [ [ mean ] 2apply ] 2keep ] 2keep [ std ] 2apply ;
+ first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;
: r ( {{x,y}...} -- r )
[r] (r) ;
] if ;
: recombine ( seq -- str )
- dup singleton? [
+ dup length 1 = [
first 3digits>text
] [
dup set-conjunction "" swap
: random-neighbour ( cell -- newcell ) choices random ;
: vertex ( pair -- )
- first2 [ 0.5 + line-width * ] 2apply glVertex2d ;
+ first2 [ 0.5 + line-width * ] bi@ glVertex2d ;
: (draw-maze) ( cell -- )
dup vertex
: MEMO:
CREATE-WORD parse-definition define-memoized ; parsing
-PREDICATE: word memoized "memoize" word-prop ;
+PREDICATE: memoized < word "memoize" word-prop ;
M: memoized definer drop \ MEMO: \ ; ;
M: memoized definition "memo-quot" word-prop ;
-USING: help.syntax help.markup kernel math classes tuples
+USING: help.syntax help.markup kernel math classes classes.tuple
calendar ;
IN: models
TUPLE: model-tester hit? ;
-: <model-tester> model-tester construct-empty ;
+: <model-tester> model-tester new ;
M: model-tester model-changed nip t swap set-model-tester-hit? ;
calendar ;
IN: models
-TUPLE: model value connections dependencies ref locked? ;
+TUPLE: model < identity-tuple
+value connections dependencies ref locked? ;
: <model> ( value -- model )
- V{ } clone V{ } clone 0 f model construct-boa ;
-
-M: model equal? 2drop f ;
+ V{ } clone V{ } clone 0 f model boa ;
M: model hashcode* drop model hashcode* ;
: parse-decimal ( str -- ratio )
"." split1
>r dup "-" head? [ drop t "0" ] [ f swap ] if r>
- [ dup empty? [ drop "0" ] when ] 2apply
+ [ dup empty? [ drop "0" ] when ] bi@
dup length
- >r [ string>number dup [ not-a-decimal ] unless ] 2apply r>
+ >r [ string>number dup [ not-a-decimal ] unless ] bi@ r>
10 swap ^ / + swap [ neg ] when ;
: DECIMAL:
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test kernel math arrays sequences
-prettyprint strings classes hashtables assocs namespaces
-debugger continuations ;
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ -1 ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ 0 ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ 1 ] [
- { object object } { number sequence } classes<
-] unit-test
-
-[
- {
- { { object integer } [ 1 ] }
- { { object object } [ 2 ] }
- { { POSTPONE: f POSTPONE: f } [ 3 ] }
- }
-] [
- {
- { { integer } [ 1 ] }
- { { } [ 2 ] }
- { { f f } [ 3 ] }
- } congruify-methods
-] unit-test
-
-GENERIC: first-test
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-TUPLE: paper ; INSTANCE: paper thing
-TUPLE: scissors ; INSTANCE: scissors thing
-TUPLE: rock ; INSTANCE: rock thing
-
-GENERIC: beats?
-
-METHOD: beats? { paper scissors } t ;
-METHOD: beats? { scissors rock } t ;
-METHOD: beats? { rock paper } t ;
-METHOD: beats? { thing thing } f ;
-
-: play ( obj1 obj2 -- ? ) beats? 2nip ;
-
-[ { } 3 play ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ ] [ error get error. ] unit-test
-[ t ] [ T{ paper } T{ scissors } play ] unit-test
-[ f ] [ T{ scissors } T{ paper } play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-GENERIC: legacy-test
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
-
-SYMBOL: some-var
-
-HOOK: hook-test some-var
-
-[ t ] [ \ hook-test hook-generic? ] unit-test
-
-METHOD: hook-test { array array } reverse ;
-METHOD: hook-test { array } class ;
-METHOD: hook-test { hashtable number } assoc-size ;
-
-{ 1 2 3 } some-var set
-[ { f t t } ] [ { t t f } hook-test ] unit-test
-[ fixnum ] [ 3 hook-test ] unit-test
-5.0 some-var set
-[ 0 ] [ H{ } hook-test ] unit-test
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-GENERIC: busted-sort
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences vectors classes combinators
-arrays words assocs parser namespaces definitions
+USING: kernel math sequences vectors classes classes.algebra
+combinators arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
-debugger io compiler.units kernel.private effects ;
+debugger io compiler.units kernel.private effects accessors
+hashtables sorting shuffle ;
IN: multi-methods
-GENERIC: generic-prologue ( combination -- quot )
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
-GENERIC: method-prologue ( combination -- quot )
+SYMBOL: args
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] subset
+ [ length <reversed> [ 1+ neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] subset
+ [ keys [ hooks get push-new ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ >r
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get + r>
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ >r total get object <array> dup <enum> r> update ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ >r canonicalize-specializer-0 r> ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ >r canonicalize-specializer-1 r> ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ >r canonicalize-specializer-2 r> ] assoc-map
+
+ args get hooks get length + total set
+
+ [ >r canonicalize-specializer-3 r> ] assoc-map
+
+ hooks get
+ ] with-scope ;
+
+: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
+
+: prepare-method ( method n -- quot )
+ [ 1quotation ] [ drop-n-quot ] bi* prepend ;
+
+: prepare-methods ( methods -- methods' prologue )
+ canonicalize-specializers
+ [ length [ prepare-method ] curry assoc-map ] keep
+ [ [ get ] curry ] map concat [ ] like ;
+
+! Part II: Topologically sorting specializers
: maximal-element ( seq quot -- n elt )
dupd [
swapd [ call 0 < ] 2curry subset empty?
{ [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] }
{ [ 2dup class< ] [ -1 ] }
{ [ 2dup swap class< ] [ 1 ] }
- { [ t ] [ 0 ] }
+ [ 0 ]
} cond 2nip
] 2map [ zero? not ] find nip 0 or ;
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
: picker ( n -- quot )
{
{ 0 [ [ dup ] ] }
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
+: argument-count ( methods -- n )
+ keys 0 [ length max ] reduce ;
+
+ERROR: no-method arguments generic ;
+
+: make-default-method ( methods generic -- quot )
+ >r argument-count r> [ >r narray r> no-method ] 2curry ;
+
+: multi-dispatch-quot ( methods generic -- quot )
+ [ make-default-method ]
+ [ drop [ >r multi-predicate r> ] assoc-map reverse ]
+ 2bi alist>quot ;
+
+! Generic words
+PREDICATE: generic < word
+ "multi-methods" word-prop >boolean ;
+
: methods ( word -- alist )
"multi-methods" word-prop >alist ;
-: make-method-def ( quot classes generic -- quot )
+: make-generic ( generic -- quot )
[
- swap [ declare ] curry %
- "multi-combination" word-prop method-prologue %
- %
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
] [ ] make ;
-TUPLE: method word def classes generic loc ;
+: update-generic ( word -- )
+ dup make-generic define ;
-PREDICATE: word method-body "multi-method" word-prop >boolean ;
+! Methods
+PREDICATE: method-body < word
+ "multi-method-generic" word-prop >boolean ;
M: method-body stack-effect
- "multi-method" word-prop method-generic stack-effect ;
+ "multi-method-generic" word-prop stack-effect ;
-: method-word-name ( classes generic -- string )
+M: method-body crossref?
+ drop t ;
+
+: method-word-name ( specializer generic -- string )
+ [ word-name % "-" % unparse % ] "" make ;
+
+: method-word-props ( specializer generic -- assoc )
[
- word-name %
- "-(" % [ "," % ] [ word-name % ] interleave ")" %
- ] "" make ;
-
-: <method-word> ( quot classes generic -- word )
- #! We xref here because the "multi-method" word-prop isn't
- #! set yet so crossref? yields f.
- [ make-method-def ] 2keep
+ "multi-method-generic" set
+ "multi-method-specializer" set
+ ] H{ } make-assoc ;
+
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
method-word-name f <word>
- dup rot define
- dup xref ;
+ [ set-word-props ] keep ;
-: <method> ( quot classes generic -- method )
- [ <method-word> ] 3keep f \ method construct-boa
- dup method-word over "multi-method" set-word-prop ;
+: with-methods ( word quot -- )
+ over >r >r "multi-methods" word-prop
+ r> call r> update-generic ; inline
-TUPLE: no-method arguments generic ;
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
-: no-method ( argument-count generic -- * )
- >r narray r> \ no-method construct-boa throw ; inline
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
-: argument-count ( methods -- n )
- dup assoc-empty? [ drop 0 ] [
- keys [ length ] map supremum
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
] if ;
-: multi-dispatch-quot ( methods generic -- quot )
- >r [
- [
- >r multi-predicate r> method-word 1quotation
- ] assoc-map
- ] keep argument-count
- r> [ no-method ] 2curry
- swap reverse alist>quot ;
-
-: congruify-methods ( alist -- alist' )
- dup argument-count [
- swap >r object pad-left [ \ f or ] map r>
- ] curry assoc-map ;
-
-: sorted-methods ( alist -- alist' )
- [ [ first ] 2apply classes< ] topological-sort ;
-
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
M: no-method error.
"Type check error" print
nl
- "Generic word " write dup no-method-generic pprint
+ "Generic word " write dup generic>> pprint
" does not have a method applicable to inputs:" print
- dup no-method-arguments short.
+ dup arguments>> short.
nl
"Inputs have signature:" print
- dup no-method-arguments [ class ] map niceify-method .
+ dup arguments>> [ class ] map niceify-method .
nl
- "Defined methods in topological order: " print
- no-method-generic
- methods congruify-methods sorted-methods keys
- [ niceify-method ] map stack. ;
-
-TUPLE: standard-combination ;
-
-M: standard-combination method-prologue drop [ ] ;
-
-M: standard-combination generic-prologue drop [ ] ;
+ "Available methods: " print
+ generic>> methods canonicalize-specializers drop sort-methods
+ keys [ niceify-method ] map stack. ;
-: make-generic ( generic -- quot )
- dup "multi-combination" word-prop generic-prologue swap
- [ methods congruify-methods sorted-methods ] keep
- multi-dispatch-quot append ;
-
-TUPLE: hook-combination var ;
-
-M: hook-combination method-prologue
- drop [ drop ] ;
-
-M: hook-combination generic-prologue
- hook-combination-var [ get ] curry ;
+: forget-method ( specializer generic -- )
+ [ delete-at ] with-methods ;
-: update-generic ( word -- )
- dup make-generic define ;
+: method>spec ( method -- spec )
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
-: define-generic ( word combination -- )
- over "multi-combination" word-prop over = [
- 2drop
+: define-generic ( word -- )
+ dup "multi-methods" word-prop [
+ drop
] [
- dupd "multi-combination" set-word-prop
- dup H{ } clone "multi-methods" set-word-prop
- update-generic
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ update-generic ]
+ bi
] if ;
-: define-standard-generic ( word -- )
- T{ standard-combination } define-generic ;
-
+! Syntax
: GENERIC:
- CREATE define-standard-generic ; parsing
-
-: define-hook-generic ( word var -- )
- hook-combination construct-boa define-generic ;
-
-: HOOK:
- CREATE scan-word define-hook-generic ; parsing
-
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: with-methods ( word quot -- )
- over >r >r "multi-methods" word-prop
- r> call r> update-generic ; inline
+ CREATE define-generic ; parsing
-: define-method ( quot classes generic -- )
- >r [ bootstrap-word ] map r>
- [ <method> ] 2keep
- [ set-at ] with-methods ;
+: parse-method ( -- quot classes generic )
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-: forget-method ( classes generic -- )
- [ delete-at ] with-methods ;
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-word ;
-: method>spec ( method -- spec )
- dup method-classes swap method-generic add* ;
+: CREATE-METHOD
+ scan-word scan-object swap create-method-in ;
-: parse-method ( -- quot classes generic )
- parse-definition dup 2 tail over second rot first ;
+: (METHOD:) CREATE-METHOD parse-definition ;
-: METHOD:
- location
- >r parse-method [ define-method ] 2keep add* r>
- remember-definition ; parsing
+: METHOD: (METHOD:) define ; parsing
! For compatibility
: M:
- scan-word 1array scan-word parse-definition
- -rot define-method ; parsing
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ; parsing
! Definition protocol. We qualify core generics here
USE: qualified
QUALIFIED: syntax
-PREDICATE: word generic
- "multi-combination" word-prop >boolean ;
-
-PREDICATE: word standard-generic
- "multi-combination" word-prop standard-combination? ;
-
-PREDICATE: word hook-generic
- "multi-combination" word-prop hook-combination? ;
-
-syntax:M: standard-generic definer drop \ GENERIC: f ;
+syntax:M: generic definer drop \ GENERIC: f ;
-syntax:M: standard-generic definition drop f ;
+syntax:M: generic definition drop f ;
-syntax:M: hook-generic definer drop \ HOOK: f ;
-
-syntax:M: hook-generic definition drop f ;
-
-syntax:M: hook-generic synopsis*
- dup definer.
- dup seeing-word
- dup pprint-word
- dup "multi-combination" word-prop
- hook-combination-var pprint-word stack-effect. ;
-
-PREDICATE: array method-spec
+PREDICATE: method-spec < array
unclip generic? >r [ class? ] all? r> and ;
syntax:M: method-spec where
- dup unclip method [ method-loc ] [ second where ] ?if ;
+ dup unclip method [ ] [ first ] ?if where ;
syntax:M: method-spec set-where
- unclip method set-method-loc ;
+ unclip method set-where ;
syntax:M: method-spec definer
- drop \ METHOD: \ ; ;
+ unclip method definer ;
syntax:M: method-spec definition
- unclip method dup [ method-def ] when ;
+ unclip method definition ;
syntax:M: method-spec synopsis*
- dup definer.
- unclip pprint* pprint* ;
+ unclip method synopsis* ;
syntax:M: method-spec forget*
- unclip forget-method ;
+ unclip method forget* ;
+
+syntax:M: method-body definer
+ drop \ METHOD: \ ; ;
+
+syntax:M: method-body synopsis*
+ dup definer.
+ [ "multi-method-generic" word-prop pprint-word ]
+ [ "multi-method-specializer" word-prop pprint* ] bi ;
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings ;
+
+[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
+
+: setup-canon-test
+ 0 args set
+ V{ } clone hooks set ;
+
+: canon-test-1
+ { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
+
+[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ ] with-scope
+] unit-test
+
+[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ ] with-scope
+] unit-test
+
+[ { integer sequence x86 } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ args get hooks get length + total set
+ canonicalize-specializer-3
+ ] with-scope
+] unit-test
+
+: example-1
+ {
+ { { { cpu x86 } { os linux } } "a" }
+ { { { cpu ppc } } "b" }
+ { { string { os windows } } "c" }
+ } ;
+
+[
+ {
+ { { object x86 linux } "a" }
+ { { object ppc object } "b" }
+ { { string object windows } "c" }
+ }
+ V{ cpu os }
+] [
+ example-1 canonicalize-specializers
+] unit-test
+
+[
+ {
+ { { object x86 linux } [ drop drop "a" ] }
+ { { object ppc object } [ drop drop "b" ] }
+ { { string object windows } [ drop drop "c" ] }
+ }
+ [ \ cpu get \ os get ]
+] [
+ example-1 prepare-methods
+] unit-test
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings words compiler.units quotations ;
+
+\ GENERIC: must-infer
+\ create-method-in must-infer
+
+DEFER: fake
+\ fake H{ } clone "multi-methods" set-word-prop
+
+[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+
+[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+[ { } \ fake method-word-props ] unit-test
+
+[ t ] [ { } \ fake <method> method-body? ] unit-test
+
+[
+ [ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test
+
+ [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
+
+ [ t ] [ \ fake make-generic quotation? ] unit-test
+
+ [ ] [ \ fake update-generic ] unit-test
+
+ DEFER: testing
+
+ [ ] [ \ testing define-generic ] unit-test
+
+ [ t ] [ \ testing generic? ] unit-test
+] with-compilation-unit
--- /dev/null
+IN: multi-methods.tests
+USING: math strings sequences tools.test ;
+
+GENERIC: legacy-test
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings definitions prettyprint debugger arrays
+hashtables continuations classes assocs accessors ;
+
+GENERIC: first-test
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+SINGLETON: paper INSTANCE: paper thing
+SINGLETON: scissors INSTANCE: scissors thing
+SINGLETON: rock INSTANCE: rock thing
+
+GENERIC: beats?
+
+METHOD: beats? { paper scissors } t ;
+METHOD: beats? { scissors rock } t ;
+METHOD: beats? { rock paper } t ;
+METHOD: beats? { thing thing } f ;
+
+: play ( obj1 obj2 -- ? ) beats? 2nip ;
+
+[ { } 3 play ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ ] [ error get error. ] unit-test
+[ { { } 3 } ] [ error get arguments>> ] unit-test
+[ t ] [ paper scissors play ] unit-test
+[ f ] [ scissors paper play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+SYMBOL: some-var
+
+GENERIC: hook-test
+
+METHOD: hook-test { array { some-var array } } reverse ;
+METHOD: hook-test { { some-var array } } class ;
+METHOD: hook-test { hashtable { some-var number } } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test
+
+"error" some-var set
+[ H{ } hook-test ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ { H{ } "error" } ] [ error get arguments>> ] unit-test
+
+MIXIN: busted
+
+TUPLE: busted-1 ;
+TUPLE: busted-2 ; INSTANCE: busted-2 busted
+TUPLE: busted-3 ;
+
+GENERIC: busted-sort
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
--- /dev/null
+IN: multi-methods.tests
+USING: kernel multi-methods tools.test math arrays sequences ;
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ -1 ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ 0 ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ 1 ] [
+ { object object } { number sequence } classes<
+] unit-test
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: effects words kernel sequences slots slots.private
-assocs parser mirrors namespaces math vocabs tuples ;
-IN: new-slots
-
-: create-accessor ( name effect -- word )
- >r "accessors" create dup r>
- "declared-effect" set-word-prop ;
-
-: reader-effect T{ effect f { "object" } { "value" } } ; inline
-
-: reader-word ( name -- word )
- ">>" append reader-effect create-accessor ;
-
-: define-reader ( class slot name -- )
- reader-word [ slot ] define-slot-word ;
-
-: writer-effect T{ effect f { "value" "object" } { } } ; inline
-
-: writer-word ( name -- word )
- "(>>" swap ")" 3append writer-effect create-accessor ;
-
-: define-writer ( class slot name -- )
- writer-word [ set-slot ] define-slot-word ;
-
-: setter-effect T{ effect f { "object" "value" } { "value" } } ; inline
-
-: setter-word ( name -- word )
- ">>" swap append setter-effect create-accessor ;
-
-: define-setter ( name -- )
- dup setter-word dup deferred? [
- [ \ over , swap writer-word , ] [ ] make define-inline
- ] [ 2drop ] if ;
-
-: changer-effect T{ effect f { "object" "quot" } { "object" } } ; inline
-
-: changer-word ( name -- word )
- "change-" swap append changer-effect create-accessor ;
-
-: define-changer ( name -- )
- dup changer-word dup deferred? [
- [
- [ over >r >r ] %
- over reader-word ,
- [ r> call r> swap ] %
- swap setter-word ,
- ] [ ] make define-inline
- ] [ 2drop ] if ;
-
-: define-new-slot ( class slot name -- )
- dup define-changer
- dup define-setter
- 3dup define-reader
- define-writer ;
-
-: define-new-slots ( tuple-class -- )
- [ "slot-names" word-prop <enum> >alist ] keep
- [ swap first2 >r 4 + r> define-new-slot ] curry each ;
-
-: TUPLE:
- CREATE-CLASS
- dup ";" parse-tokens define-tuple-class
- define-new-slots ; parsing
-
-"accessors" create-vocab drop
--- /dev/null
+
+USING: kernel sequences assocs qualified circular ;
+
+USING: math multi-methods ;
+
+QUALIFIED: sequences
+QUALIFIED: assocs
+QUALIFIED: circular
+
+IN: newfx
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Now, we can see a new world coming into view.
+! A world in which there is the very real prospect of a new world order.
+!
+! - George Herbert Walker Bush
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: at ( col key -- val )
+GENERIC: of ( key col -- val )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: grab ( col key -- col val )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: is ( col key val -- col )
+GENERIC: as ( col val key -- col )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: is-of ( key val col -- col )
+GENERIC: as-of ( val key col -- col )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: mutate-at ( col key val -- )
+GENERIC: mutate-as ( col val key -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: at-mutate ( key val col -- )
+GENERIC: as-mutate ( val key col -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! sequence
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at { sequence number } swap nth ;
+METHOD: of { number sequence } nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: grab { sequence number } dupd swap nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is { sequence number object } swap pick set-nth ;
+METHOD: as { sequence object number } pick set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is-of { number object sequence } dup >r swapd set-nth r> ;
+METHOD: as-of { object number sequence } dup >r set-nth r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: mutate-at { sequence number object } swap rot set-nth ;
+METHOD: mutate-as { sequence object number } rot set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at-mutate { number object sequence } swapd set-nth ;
+METHOD: as-mutate { object number sequence } set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! assoc
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at { assoc object } swap assocs:at ;
+METHOD: of { object assoc } assocs:at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: grab { assoc object } dupd swap assocs:at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is { assoc object object } swap pick set-at ;
+METHOD: as { assoc object object } pick set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is-of { object object assoc } dup >r swapd set-at r> ;
+METHOD: as-of { object object assoc } dup >r set-at r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: mutate-at { assoc object object } swap rot set-at ;
+METHOD: mutate-as { assoc object object } rot set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at-mutate { object object assoc } swapd set-at ;
+METHOD: as-mutate { object object assoc } set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: push ( seq obj -- seq ) over sequences:push ;
+: push-on ( obj seq -- seq ) tuck sequences:push ;
+: pushed ( seq obj -- ) swap sequences:push ;
+: pushed-on ( obj seq -- ) sequences:push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: member? ( seq obj -- ? ) swap sequences:member? ;
+: member-of? ( obj seq -- ? ) sequences:member? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete-at-key ( tbl key -- tbl ) over delete-at ;
+: delete-key-of ( key tbl -- tbl ) tuck delete-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete ( seq elt -- seq ) over sequences:delete ;
+: delete-from ( elt seq -- seq ) tuck sequences:delete ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: deleted ( seq elt -- ) swap sequences:delete ;
+: deleted-from ( elt seq -- ) sequences:delete ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remove ( seq obj -- seq ) swap sequences:remove ;
+: remove-from ( obj seq -- seq ) sequences:remove ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: subset-of ( quot seq -- seq ) swap subset ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: map-over ( quot seq -- seq ) swap map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: push-circular ( seq elt -- seq ) over circular:push-circular ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prefix-on ( elt seq -- seq ) swap prefix ;
+: suffix-on ( elt seq -- seq ) swap suffix ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 1st 0 at ;
+: 2nd 1 at ;
+: 3rd 2 at ;
+: 4th 3 at ;
+: 5th 4 at ;
+: 6th 5 at ;
+: 7th 6 at ;
+: 8th 7 at ;
+: 9th 8 at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A note about the 'mutate' qualifier. Other words also technically mutate
+! their primary object. However, the 'mutate' qualifier is supposed to
+! indicate that this is the main objective of the word, as a side effect.
\ No newline at end of file
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel alien alien.syntax combinators alien.c-types\r
- strings sequences namespaces words math threads ;\r
-IN: odbc\r
-\r
-"odbc" "odbc32.dll" "stdcall" add-library\r
-\r
-LIBRARY: odbc\r
-\r
-TYPEDEF: void* usb_dev_handle*\r
-TYPEDEF: short SQLRETURN\r
-TYPEDEF: short SQLSMALLINT\r
-TYPEDEF: short* SQLSMALLINT*\r
-TYPEDEF: ushort SQLUSMALLINT\r
-TYPEDEF: uint* SQLUINTEGER*\r
-TYPEDEF: int SQLINTEGER\r
-TYPEDEF: char SQLCHAR\r
-TYPEDEF: char* SQLCHAR*\r
-TYPEDEF: void* SQLHANDLE\r
-TYPEDEF: void* SQLHANDLE*\r
-TYPEDEF: void* SQLHENV\r
-TYPEDEF: void* SQLHDBC\r
-TYPEDEF: void* SQLHSTMT\r
-TYPEDEF: void* SQLHWND\r
-TYPEDEF: void* SQLPOINTER\r
-\r
-: SQL-HANDLE-ENV ( -- number ) 1 ; inline\r
-: SQL-HANDLE-DBC ( -- number ) 2 ; inline\r
-: SQL-HANDLE-STMT ( -- number ) 3 ; inline\r
-: SQL-HANDLE-DESC ( -- number ) 4 ; inline\r
-\r
-: SQL-NULL-HANDLE ( -- alien ) f ; inline\r
-\r
-: SQL-ATTR-ODBC-VERSION ( -- number ) 200 ; inline\r
-\r
-: SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline\r
-: SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline\r
-\r
-: SQL-SUCCESS ( -- number ) 0 ; inline\r
-: SQL-SUCCESS-WITH-INFO ( -- number ) 1 ; inline\r
-: SQL-NO-DATA-FOUND ( -- number ) 100 ; inline\r
-\r
-: SQL-DRIVER-NOPROMPT ( -- number ) 0 ; inline\r
-: SQL-DRIVER-PROMPT ( -- number ) 2 ; inline\r
-\r
-: SQL-C-DEFAULT ( -- number ) 99 ; inline\r
-\r
-SYMBOL: SQL-CHAR\r
-SYMBOL: SQL-VARCHAR\r
-SYMBOL: SQL-LONGVARCHAR\r
-SYMBOL: SQL-WCHAR\r
-SYMBOL: SQL-WCHARVAR\r
-SYMBOL: SQL-WLONGCHARVAR\r
-SYMBOL: SQL-DECIMAL\r
-SYMBOL: SQL-SMALLINT\r
-SYMBOL: SQL-NUMERIC\r
-SYMBOL: SQL-INTEGER\r
-SYMBOL: SQL-REAL\r
-SYMBOL: SQL-FLOAT\r
-SYMBOL: SQL-DOUBLE\r
-SYMBOL: SQL-BIT\r
-SYMBOL: SQL-TINYINT\r
-SYMBOL: SQL-BIGINT\r
-SYMBOL: SQL-BINARY\r
-SYMBOL: SQL-VARBINARY\r
-SYMBOL: SQL-LONGVARBINARY\r
-SYMBOL: SQL-TYPE-DATE\r
-SYMBOL: SQL-TYPE-TIME\r
-SYMBOL: SQL-TYPE-TIMESTAMP\r
-SYMBOL: SQL-TYPE-UTCDATETIME\r
-SYMBOL: SQL-TYPE-UTCTIME\r
-SYMBOL: SQL-INTERVAL-MONTH\r
-SYMBOL: SQL-INTERVAL-YEAR\r
-SYMBOL: SQL-INTERVAL-YEAR-TO-MONTH\r
-SYMBOL: SQL-INTERVAL-DAY\r
-SYMBOL: SQL-INTERVAL-HOUR\r
-SYMBOL: SQL-INTERVAL-MINUTE\r
-SYMBOL: SQL-INTERVAL-SECOND\r
-SYMBOL: SQL-INTERVAL-DAY-TO-HOUR\r
-SYMBOL: SQL-INTERVAL-DAY-TO-MINUTE\r
-SYMBOL: SQL-INTERVAL-DAY-TO-SECOND\r
-SYMBOL: SQL-INTERVAL-HOUR-TO-MINUTE\r
-SYMBOL: SQL-INTERVAL-HOUR-TO-SECOND\r
-SYMBOL: SQL-INTERVAL-MINUTE-TO-SECOND\r
-SYMBOL: SQL-GUID\r
-SYMBOL: SQL-TYPE-UNKNOWN\r
-\r
-: convert-sql-type ( number -- symbol )\r
- {\r
- { [ dup 1 = ] [ drop SQL-CHAR ] }\r
- { [ dup 12 = ] [ drop SQL-VARCHAR ] }\r
- { [ dup -1 = ] [ drop SQL-LONGVARCHAR ] }\r
- { [ dup -8 = ] [ drop SQL-WCHAR ] }\r
- { [ dup -9 = ] [ drop SQL-WCHARVAR ] }\r
- { [ dup -10 = ] [ drop SQL-WLONGCHARVAR ] }\r
- { [ dup 3 = ] [ drop SQL-DECIMAL ] }\r
- { [ dup 5 = ] [ drop SQL-SMALLINT ] }\r
- { [ dup 2 = ] [ drop SQL-NUMERIC ] }\r
- { [ dup 4 = ] [ drop SQL-INTEGER ] }\r
- { [ dup 7 = ] [ drop SQL-REAL ] }\r
- { [ dup 6 = ] [ drop SQL-FLOAT ] }\r
- { [ dup 8 = ] [ drop SQL-DOUBLE ] }\r
- { [ dup -7 = ] [ drop SQL-BIT ] }\r
- { [ dup -6 = ] [ drop SQL-TINYINT ] }\r
- { [ dup -5 = ] [ drop SQL-BIGINT ] }\r
- { [ dup -2 = ] [ drop SQL-BINARY ] }\r
- { [ dup -3 = ] [ drop SQL-VARBINARY ] } \r
- { [ dup -4 = ] [ drop SQL-LONGVARBINARY ] }\r
- { [ dup 91 = ] [ drop SQL-TYPE-DATE ] }\r
- { [ dup 92 = ] [ drop SQL-TYPE-TIME ] }\r
- { [ dup 93 = ] [ drop SQL-TYPE-TIMESTAMP ] }\r
- { [ t ] [ drop SQL-TYPE-UNKNOWN ] }\r
- } cond ;\r
-\r
-: succeeded? ( n -- bool )\r
- #! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)\r
- {\r
- { [ dup SQL-SUCCESS = ] [ drop t ] }\r
- { [ dup SQL-SUCCESS-WITH-INFO = ] [ drop t ] }\r
- { [ t ] [ drop f ] }\r
- } cond ; \r
-\r
-FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;\r
-FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;\r
-FUNCTION: SQLRETURN SQLDriverConnect ( SQLHDBC connectionHandle, SQLHWND windowHandle, SQLCHAR* inConnectionString, SQLSMALLINT stringLength, SQLCHAR* outConnectionString, SQLSMALLINT bufferLength, SQLSMALLINT* stringLength2Ptr, SQLUSMALLINT driverCompletion ) ; \r
-FUNCTION: SQLRETURN SQLDisconnect ( SQLHDBC connectionHandle ) ;\r
-FUNCTION: SQLRETURN SQLPrepare ( SQLHSTMT statementHandle, SQLCHAR* statementText, SQLINTEGER length ) ;\r
-FUNCTION: SQLRETURN SQLExecute ( SQLHSTMT statementHandle ) ;\r
-FUNCTION: SQLRETURN SQLFreeHandle ( SQLSMALLINT handleType, SQLHANDLE handle ) ;\r
-FUNCTION: SQLRETURN SQLFetch ( SQLHSTMT statementHandle ) ;\r
-FUNCTION: SQLRETURN SQLNumResultCols ( SQLHSTMT statementHandle, SQLSMALLINT* columnCountPtr ) ;\r
-FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr ) ;\r
-FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr ) ;\r
-\r
-: alloc-handle ( type parent -- handle )\r
- f <void*> [ SQLAllocHandle ] keep swap succeeded? [\r
- *void*\r
- ] [\r
- drop f\r
- ] if ;\r
-\r
-: alloc-env-handle ( -- handle )\r
- SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;\r
-\r
-: alloc-dbc-handle ( env -- handle )\r
- SQL-HANDLE-DBC swap alloc-handle ;\r
-\r
-: alloc-stmt-handle ( dbc -- handle )\r
- SQL-HANDLE-STMT swap alloc-handle ;\r
-\r
-: temp-string ( length -- byte-array length )\r
- [ CHAR: \space <string> string>char-alien ] keep ;\r
-\r
-: odbc-init ( -- env )\r
- alloc-env-handle\r
- [ \r
- SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr \r
- succeeded? [ "odbc-init failed" throw ] unless\r
- ] keep ;\r
-\r
-: odbc-connect ( env dsn -- dbc )\r
- >r alloc-dbc-handle dup r> \r
- f swap dup length 1024 temp-string 0 <short> SQL-DRIVER-NOPROMPT \r
- SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;\r
-\r
-: odbc-disconnect ( dbc -- )\r
- SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ; \r
-\r
-: odbc-prepare ( dbc string -- statement )\r
- >r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;\r
-\r
-: odbc-free-statement ( statement -- )\r
- SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;\r
-\r
-: odbc-execute ( statement -- )\r
- SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;\r
-\r
-: odbc-next-row ( statement -- bool )\r
- SQLFetch succeeded? ;\r
-\r
-: odbc-number-of-columns ( statement -- number )\r
- 0 <short> [ SQLNumResultCols succeeded? ] keep swap [\r
- *short\r
- ] [\r
- drop f\r
- ] if ;\r
-\r
-TUPLE: column nullable digits size type name number ;\r
-\r
-C: <column> column\r
-\r
-: odbc-describe-column ( statement n -- column )\r
- dup >r\r
- 1024 CHAR: \space <string> string>char-alien dup >r\r
- 1024 \r
- 0 <short>\r
- 0 <short> dup >r\r
- 0 <uint> dup >r\r
- 0 <short> dup >r\r
- 0 <short> dup >r\r
- SQLDescribeCol succeeded? [\r
- r> *short \r
- r> *short \r
- r> *uint \r
- r> *short convert-sql-type \r
- r> alien>char-string \r
- r> <column> \r
- ] [\r
- r> drop r> drop r> drop r> drop r> drop r> drop\r
- "odbc-describe-column failed" throw\r
- ] if ;\r
-\r
-: dereference-type-pointer ( byte-array column -- object )\r
- column-type {\r
- { [ dup SQL-CHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-VARCHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-LONGVARCHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-WCHAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-WCHARVAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-WLONGCHARVAR = ] [ drop alien>char-string ] }\r
- { [ dup SQL-SMALLINT = ] [ drop *short ] }\r
- { [ dup SQL-INTEGER = ] [ drop *long ] }\r
- { [ dup SQL-REAL = ] [ drop *float ] }\r
- { [ dup SQL-FLOAT = ] [ drop *double ] }\r
- { [ dup SQL-DOUBLE = ] [ drop *double ] }\r
- { [ dup SQL-TINYINT = ] [ drop *char ] }\r
- { [ dup SQL-BIGINT = ] [ drop *longlong ] }\r
- { [ t ] [ nip [ "Unknown SQL Type: " % word-name % ] "" make ] } \r
- } cond ;\r
-\r
-TUPLE: field value column ;\r
-\r
-C: <field> field\r
-\r
-: odbc-get-field ( statement column -- field )\r
- dup column? [ dupd odbc-describe-column ] unless dup >r column-number\r
- SQL-C-DEFAULT\r
- 8192 CHAR: \space <string> string>char-alien dup >r\r
- 8192 \r
- f SQLGetData succeeded? [\r
- r> r> [ dereference-type-pointer ] keep <field>\r
- ] [\r
- r> drop r> [ \r
- "SQLGetData Failed for Column: " % \r
- dup column-name % \r
- " of type: " % dup column-type word-name %\r
- ] "" make swap <field>\r
- ] if ;\r
-\r
-: odbc-get-row-fields ( statement -- seq )\r
- [\r
- dup odbc-number-of-columns [\r
- 1+ odbc-get-field field-value ,\r
- ] with each \r
- ] { } make ;\r
-\r
-: (odbc-get-all-rows) ( statement -- )\r
- dup odbc-next-row [ dup odbc-get-row-fields , yield (odbc-get-all-rows) ] [ drop ] if ; \r
- \r
-: odbc-get-all-rows ( statement -- seq )\r
- [ (odbc-get-all-rows) ] { } make ;\r
- \r
-: odbc-query ( string dsn -- result )\r
- odbc-init swap odbc-connect [\r
- swap odbc-prepare\r
- dup odbc-execute\r
- dup odbc-get-all-rows\r
- swap odbc-free-statement\r
- ] keep odbc-disconnect ;
\ No newline at end of file
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien alien.strings alien.syntax combinators
+alien.c-types strings sequences namespaces words math threads
+io.encodings.ascii ;
+IN: odbc
+
+<< "odbc" "odbc32.dll" "stdcall" add-library >>
+
+LIBRARY: odbc
+
+TYPEDEF: void* usb_dev_handle*
+TYPEDEF: short SQLRETURN
+TYPEDEF: short SQLSMALLINT
+TYPEDEF: short* SQLSMALLINT*
+TYPEDEF: ushort SQLUSMALLINT
+TYPEDEF: uint* SQLUINTEGER*
+TYPEDEF: int SQLINTEGER
+TYPEDEF: char SQLCHAR
+TYPEDEF: char* SQLCHAR*
+TYPEDEF: void* SQLHANDLE
+TYPEDEF: void* SQLHANDLE*
+TYPEDEF: void* SQLHENV
+TYPEDEF: void* SQLHDBC
+TYPEDEF: void* SQLHSTMT
+TYPEDEF: void* SQLHWND
+TYPEDEF: void* SQLPOINTER
+
+: SQL-HANDLE-ENV ( -- number ) 1 ; inline
+: SQL-HANDLE-DBC ( -- number ) 2 ; inline
+: SQL-HANDLE-STMT ( -- number ) 3 ; inline
+: SQL-HANDLE-DESC ( -- number ) 4 ; inline
+
+: SQL-NULL-HANDLE ( -- alien ) f ; inline
+
+: SQL-ATTR-ODBC-VERSION ( -- number ) 200 ; inline
+
+: SQL-OV-ODBC2 ( -- number ) 2 <alien> ; inline
+: SQL-OV-ODBC3 ( -- number ) 3 <alien> ; inline
+
+: SQL-SUCCESS ( -- number ) 0 ; inline
+: SQL-SUCCESS-WITH-INFO ( -- number ) 1 ; inline
+: SQL-NO-DATA-FOUND ( -- number ) 100 ; inline
+
+: SQL-DRIVER-NOPROMPT ( -- number ) 0 ; inline
+: SQL-DRIVER-PROMPT ( -- number ) 2 ; inline
+
+: SQL-C-DEFAULT ( -- number ) 99 ; inline
+
+SYMBOL: SQL-CHAR
+SYMBOL: SQL-VARCHAR
+SYMBOL: SQL-LONGVARCHAR
+SYMBOL: SQL-WCHAR
+SYMBOL: SQL-WCHARVAR
+SYMBOL: SQL-WLONGCHARVAR
+SYMBOL: SQL-DECIMAL
+SYMBOL: SQL-SMALLINT
+SYMBOL: SQL-NUMERIC
+SYMBOL: SQL-INTEGER
+SYMBOL: SQL-REAL
+SYMBOL: SQL-FLOAT
+SYMBOL: SQL-DOUBLE
+SYMBOL: SQL-BIT
+SYMBOL: SQL-TINYINT
+SYMBOL: SQL-BIGINT
+SYMBOL: SQL-BINARY
+SYMBOL: SQL-VARBINARY
+SYMBOL: SQL-LONGVARBINARY
+SYMBOL: SQL-TYPE-DATE
+SYMBOL: SQL-TYPE-TIME
+SYMBOL: SQL-TYPE-TIMESTAMP
+SYMBOL: SQL-TYPE-UTCDATETIME
+SYMBOL: SQL-TYPE-UTCTIME
+SYMBOL: SQL-INTERVAL-MONTH
+SYMBOL: SQL-INTERVAL-YEAR
+SYMBOL: SQL-INTERVAL-YEAR-TO-MONTH
+SYMBOL: SQL-INTERVAL-DAY
+SYMBOL: SQL-INTERVAL-HOUR
+SYMBOL: SQL-INTERVAL-MINUTE
+SYMBOL: SQL-INTERVAL-SECOND
+SYMBOL: SQL-INTERVAL-DAY-TO-HOUR
+SYMBOL: SQL-INTERVAL-DAY-TO-MINUTE
+SYMBOL: SQL-INTERVAL-DAY-TO-SECOND
+SYMBOL: SQL-INTERVAL-HOUR-TO-MINUTE
+SYMBOL: SQL-INTERVAL-HOUR-TO-SECOND
+SYMBOL: SQL-INTERVAL-MINUTE-TO-SECOND
+SYMBOL: SQL-GUID
+SYMBOL: SQL-TYPE-UNKNOWN
+
+: convert-sql-type ( number -- symbol )
+ {
+ { 1 [ SQL-CHAR ] }
+ { 12 [ SQL-VARCHAR ] }
+ { -1 [ SQL-LONGVARCHAR ] }
+ { -8 [ SQL-WCHAR ] }
+ { -9 [ SQL-WCHARVAR ] }
+ { -10 [ SQL-WLONGCHARVAR ] }
+ { 3 [ SQL-DECIMAL ] }
+ { 5 [ SQL-SMALLINT ] }
+ { 2 [ SQL-NUMERIC ] }
+ { 4 [ SQL-INTEGER ] }
+ { 7 [ SQL-REAL ] }
+ { 6 [ SQL-FLOAT ] }
+ { 8 [ SQL-DOUBLE ] }
+ { -7 [ SQL-BIT ] }
+ { -6 [ SQL-TINYINT ] }
+ { -5 [ SQL-BIGINT ] }
+ { -2 [ SQL-BINARY ] }
+ { -3 [ SQL-VARBINARY ] }
+ { -4 [ SQL-LONGVARBINARY ] }
+ { 91 [ SQL-TYPE-DATE ] }
+ { 92 [ SQL-TYPE-TIME ] }
+ { 93 [ SQL-TYPE-TIMESTAMP ] }
+ [ drop SQL-TYPE-UNKNOWN ]
+ } case ;
+
+: succeeded? ( n -- bool )
+ #! Did the call succeed (SQL-SUCCESS or SQL-SUCCESS-WITH-INFO)
+ {
+ { SQL-SUCCESS [ t ] }
+ { SQL-SUCCESS-WITH-INFO [ t ] }
+ [ drop f ]
+ } case ;
+
+FUNCTION: SQLRETURN SQLAllocHandle ( SQLSMALLINT handleType, SQLHANDLE inputHandle, SQLHANDLE* outputHandlePtr ) ;
+FUNCTION: SQLRETURN SQLSetEnvAttr ( SQLHENV environmentHandle, SQLINTEGER attribute, SQLPOINTER valuePtr, SQLINTEGER stringLength ) ;
+FUNCTION: SQLRETURN SQLDriverConnect ( SQLHDBC connectionHandle, SQLHWND windowHandle, SQLCHAR* inConnectionString, SQLSMALLINT stringLength, SQLCHAR* outConnectionString, SQLSMALLINT bufferLength, SQLSMALLINT* stringLength2Ptr, SQLUSMALLINT driverCompletion ) ;
+FUNCTION: SQLRETURN SQLDisconnect ( SQLHDBC connectionHandle ) ;
+FUNCTION: SQLRETURN SQLPrepare ( SQLHSTMT statementHandle, SQLCHAR* statementText, SQLINTEGER length ) ;
+FUNCTION: SQLRETURN SQLExecute ( SQLHSTMT statementHandle ) ;
+FUNCTION: SQLRETURN SQLFreeHandle ( SQLSMALLINT handleType, SQLHANDLE handle ) ;
+FUNCTION: SQLRETURN SQLFetch ( SQLHSTMT statementHandle ) ;
+FUNCTION: SQLRETURN SQLNumResultCols ( SQLHSTMT statementHandle, SQLSMALLINT* columnCountPtr ) ;
+FUNCTION: SQLRETURN SQLDescribeCol ( SQLHSTMT statementHandle, SQLSMALLINT columnNumber, SQLCHAR* columnName, SQLSMALLINT bufferLength, SQLSMALLINT* nameLengthPtr, SQLSMALLINT* dataTypePtr, SQLUINTEGER* columnSizePtr, SQLSMALLINT* decimalDigitsPtr, SQLSMALLINT* nullablePtr ) ;
+FUNCTION: SQLRETURN SQLGetData ( SQLHSTMT statementHandle, SQLUSMALLINT columnNumber, SQLSMALLINT targetType, SQLPOINTER targetValuePtr, SQLINTEGER bufferLength, SQLINTEGER* strlen_or_indPtr ) ;
+
+: alloc-handle ( type parent -- handle )
+ f <void*> [ SQLAllocHandle ] keep swap succeeded? [
+ *void*
+ ] [
+ drop f
+ ] if ;
+
+: alloc-env-handle ( -- handle )
+ SQL-HANDLE-ENV SQL-NULL-HANDLE alloc-handle ;
+
+: alloc-dbc-handle ( env -- handle )
+ SQL-HANDLE-DBC swap alloc-handle ;
+
+: alloc-stmt-handle ( dbc -- handle )
+ SQL-HANDLE-STMT swap alloc-handle ;
+
+: temp-string ( length -- byte-array length )
+ [ CHAR: \space <string> ascii string>alien ] keep ;
+
+: odbc-init ( -- env )
+ alloc-env-handle
+ [
+ SQL-ATTR-ODBC-VERSION SQL-OV-ODBC3 0 SQLSetEnvAttr
+ succeeded? [ "odbc-init failed" throw ] unless
+ ] keep ;
+
+: odbc-connect ( env dsn -- dbc )
+ >r alloc-dbc-handle dup r>
+ f swap dup length 1024 temp-string 0 <short> SQL-DRIVER-NOPROMPT
+ SQLDriverConnect succeeded? [ "odbc-connect failed" throw ] unless ;
+
+: odbc-disconnect ( dbc -- )
+ SQLDisconnect succeeded? [ "odbc-disconnect failed" throw ] unless ;
+
+: odbc-prepare ( dbc string -- statement )
+ >r alloc-stmt-handle dup r> dup length SQLPrepare succeeded? [ "odbc-prepare failed" throw ] unless ;
+
+: odbc-free-statement ( statement -- )
+ SQL-HANDLE-STMT swap SQLFreeHandle succeeded? [ "odbc-free-statement failed" throw ] unless ;
+
+: odbc-execute ( statement -- )
+ SQLExecute succeeded? [ "odbc-execute failed" throw ] unless ;
+
+: odbc-next-row ( statement -- bool )
+ SQLFetch succeeded? ;
+
+: odbc-number-of-columns ( statement -- number )
+ 0 <short> [ SQLNumResultCols succeeded? ] keep swap [
+ *short
+ ] [
+ drop f
+ ] if ;
+
+TUPLE: column nullable digits size type name number ;
+
+C: <column> column
+
+: odbc-describe-column ( statement n -- column )
+ dup >r
+ 1024 CHAR: \space <string> ascii string>alien dup >r
+ 1024
+ 0 <short>
+ 0 <short> dup >r
+ 0 <uint> dup >r
+ 0 <short> dup >r
+ 0 <short> dup >r
+ SQLDescribeCol succeeded? [
+ r> *short
+ r> *short
+ r> *uint
+ r> *short convert-sql-type
+ r> ascii alien>string
+ r> <column>
+ ] [
+ r> drop r> drop r> drop r> drop r> drop r> drop
+ "odbc-describe-column failed" throw
+ ] if ;
+
+: dereference-type-pointer ( byte-array column -- object )
+ column-type {
+ { SQL-CHAR [ ascii alien>string ] }
+ { SQL-VARCHAR [ ascii alien>string ] }
+ { SQL-LONGVARCHAR [ ascii alien>string ] }
+ { SQL-WCHAR [ ascii alien>string ] }
+ { SQL-WCHARVAR [ ascii alien>string ] }
+ { SQL-WLONGCHARVAR [ ascii alien>string ] }
+ { SQL-SMALLINT [ *short ] }
+ { SQL-INTEGER [ *long ] }
+ { SQL-REAL [ *float ] }
+ { SQL-FLOAT [ *double ] }
+ { SQL-DOUBLE [ *double ] }
+ { SQL-TINYINT [ *char ] }
+ { SQL-BIGINT [ *longlong ] }
+ [ nip [ "Unknown SQL Type: " % word-name % ] "" make ]
+ } case ;
+
+TUPLE: field value column ;
+
+C: <field> field
+
+: odbc-get-field ( statement column -- field )
+ dup column? [ dupd odbc-describe-column ] unless dup >r column-number
+ SQL-C-DEFAULT
+ 8192 CHAR: \space <string> ascii string>alien dup >r
+ 8192
+ f SQLGetData succeeded? [
+ r> r> [ dereference-type-pointer ] keep <field>
+ ] [
+ r> drop r> [
+ "SQLGetData Failed for Column: " %
+ dup column-name %
+ " of type: " % dup column-type word-name %
+ ] "" make swap <field>
+ ] if ;
+
+: odbc-get-row-fields ( statement -- seq )
+ [
+ dup odbc-number-of-columns [
+ 1+ odbc-get-field field-value ,
+ ] with each
+ ] { } make ;
+
+: (odbc-get-all-rows) ( statement -- )
+ dup odbc-next-row [ dup odbc-get-row-fields , yield (odbc-get-all-rows) ] [ drop ] if ;
+
+: odbc-get-all-rows ( statement -- seq )
+ [ (odbc-get-all-rows) ] { } make ;
+
+: odbc-query ( string dsn -- result )
+ odbc-init swap odbc-connect [
+ swap odbc-prepare
+ dup odbc-execute
+ dup odbc-get-all-rows
+ swap odbc-free-statement
+ ] keep odbc-disconnect ;
<<
"ogg" {
- { [ win32? ] [ "ogg.dll" ] }
- { [ macosx? ] [ "libogg.0.dylib" ] }
- { [ unix? ] [ "libogg.so" ] }
+ { [ os winnt? ] [ "ogg.dll" ] }
+ { [ os macosx? ] [ "libogg.0.dylib" ] }
+ { [ os unix? ] [ "libogg.so" ] }
} cond "cdecl" add-library
>>
num-audio-buffers-processed {\r
{ [ over player-buffers length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }\r
{ [ over player-buffers length 2 = over zero? and ] [ yield drop f ] }\r
- { [ t ] [ fill-processed-audio-buffer t ] }\r
+ [ fill-processed-audio-buffer t ]\r
} cond ;\r
\r
: start-audio ( player -- player bool )\r
decode-packet {\r
{ [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }\r
{ [ is-theora-packet? ] [ handle-initial-theora-header ] }\r
- { [ t ] [ handle-initial-unknown-header ] }\r
+ [ handle-initial-unknown-header ]\r
} cond t\r
] [\r
f\r
<<
"theora" {
- { [ win32? ] [ "theora.dll" ] }
- { [ macosx? ] [ "libtheora.0.dylib" ] }
- { [ unix? ] [ "libtheora.so" ] }
+ { [ os winnt? ] [ "theora.dll" ] }
+ { [ os macosx? ] [ "libtheora.0.dylib" ] }
+ { [ os unix? ] [ "libtheora.so" ] }
} cond "cdecl" add-library
>>
<<
"vorbis" {
- { [ win32? ] [ "vorbis.dll" ] }
- { [ macosx? ] [ "libvorbis.0.dylib" ] }
- { [ unix? ] [ "libvorbis.so" ] }
+ { [ os winnt? ] [ "vorbis.dll" ] }
+ { [ os macosx? ] [ "libvorbis.0.dylib" ] }
+ { [ os unix? ] [ "libvorbis.so" ] }
} cond "cdecl" add-library
>>
-USING: namespaces ;
+USING: namespaces system ;
IN: openal.backend
-SYMBOL: openal-backend
-HOOK: load-wav-file openal-backend ( filename -- format data size frequency )
-
-TUPLE: other-openal-backend ;
-T{ other-openal-backend } openal-backend set-global
+HOOK: load-wav-file os ( filename -- format data size frequency )
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-!\r
-IN: openal.macosx\r
-USING: alien.c-types kernel alien alien.syntax shuffle\r
-combinators.lib openal.backend namespaces ;\r
-\r
-TUPLE: macosx-openal-backend ;\r
-LIBRARY: alut\r
-\r
-T{ macosx-openal-backend } openal-backend set-global\r
-\r
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;\r
-\r
-M: macosx-openal-backend load-wav-file ( path -- format data size frequency )\r
- 0 <int> f <void*> 0 <int> 0 <int>\r
- [ alutLoadWAVFile ] 4keep\r
- >r >r >r *int r> *void* r> *int r> *int ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel alien alien.syntax shuffle
+combinators.lib openal.backend namespaces system ;
+IN: openal.macosx
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
+
+M: macosx load-wav-file ( path -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ alutLoadWAVFile ] 4keep
+ >r >r >r *int r> *void* r> *int r> *int ;
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-!
-IN: openal
USING: kernel alien system combinators alien.syntax namespaces
alien.c-types sequences vocabs.loader shuffle combinators.lib
openal.backend ;
+IN: openal
<< "alut" {
- { [ win32? ] [ "alut.dll" ] }
- { [ macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
- { [ unix? ] [ "libalut.so" ] }
+ { [ os windows? ] [ "alut.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
+ { [ os unix? ] [ "libalut.so" ] }
} cond "cdecl" add-library >>
<< "openal" {
- { [ win32? ] [ "OpenAL32.dll" ] }
- { [ macosx? ] [ "/System/Library/Frameworks/OpenAL.framework/OpenAL" ] }
- { [ unix? ] [ "libopenal.so" ] }
+ { [ os windows? ] [ "OpenAL32.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
+ { [ os unix? ] [ "libopenal.so" ] }
} cond "cdecl" add-library >>
LIBRARY: openal
"create-buffer-from-file failed" throw
] when ;
-macosx? "openal.macosx" "openal.other" ? require
+os macosx? "openal.macosx" "openal.other" ? require
: create-buffer-from-wav ( filename -- buffer )
gen-buffer dup rot load-wav-file
: source-playing? ( source -- bool )
AL_SOURCE_STATE get-source-param AL_PLAYING = ;
-
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-!\r
-IN: openal.other\r
-USING: openal.backend alien.c-types kernel alien alien.syntax shuffle combinators.lib ;\r
-\r
-LIBRARY: alut\r
-\r
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;\r
-\r
-M: other-openal-backend load-wav-file ( filename -- format data size frequency )\r
- 0 <int> f <void*> 0 <int> 0 <int>\r
- [ 0 <char> alutLoadWAVFile ] 4keep\r
- >r >r >r *int r> *void* r> *int r> *int ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: openal.backend alien.c-types kernel alien alien.syntax
+shuffle combinators.lib ;
+IN: openal.other
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
+
+M: object load-wav-file ( filename -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ 0 <char> alutLoadWAVFile ] 4keep
+ >r >r >r *int r> *void* r> *int r> *int ;
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting opengl.gl
-continuations math.parser math arrays ;
+continuations math.parser math arrays sets ;
IN: opengl.capabilities
: (require-gl) ( thing require-quot make-error-quot -- )
: has-gl-extensions? ( extensions -- ? )
gl-extensions swap [ over member? ] all? nip ;
: (make-gl-extensions-error) ( required-extensions -- )
- gl-extensions swap seq-diff
+ gl-extensions swap diff
"Required OpenGL extensions not supported:\n" %
[ " " % % "\n" % ] each ;
: require-gl-extensions ( extensions -- )
USING: arrays combinators.lib kernel math math.functions math.vectors namespaces
- opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render combinators.cleave ;
+ opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ;
IN: opengl.demo-support
: NEAR-PLANE 1.0 64.0 / ; inline
: demo-gadget-frustum ( -- -x x -y y near far )
FOV-RATIO NEAR-PLANE FOV / v*n
- first2 [ -+ ] 2apply NEAR-PLANE FAR-PLANE ;
+ first2 [ -+ ] bi@ NEAR-PLANE FAR-PLANE ;
: demo-gadget-set-matrices ( gadget -- )
GL_PROJECTION glMatrixMode
USING: alien alien.syntax combinators kernel parser sequences
-system words namespaces hashtables init math arrays assocs
-sequences.lib continuations ;
+system words namespaces hashtables init math arrays assocs
+continuations ;
+IN: opengl.gl.extensions
+
+ERROR: unknown-gl-platform ;
<< {
- { [ windows? ] [ "opengl.gl.windows" ] }
- { [ macosx? ] [ "opengl.gl.macosx" ] }
- { [ unix? ] [ "opengl.gl.unix" ] }
- { [ t ] [ "Unknown OpenGL platform" throw ] }
+ { [ os windows? ] [ "opengl.gl.windows" ] }
+ { [ os macosx? ] [ "opengl.gl.macosx" ] }
+ { [ os unix? ] [ "opengl.gl.unix" ] }
+ [ unknown-gl-platform ]
} cond use+ >>
-IN: opengl.gl.extensions
SYMBOL: +gl-function-number-counter+
SYMBOL: +gl-function-pointers+
: gl-function-pointer ( names n -- funptr )
gl-function-context 2array dup +gl-function-pointers+ get-global at
[ 2nip ] [
- >r [ gl-function-address ] attempt-each
+ >r [ gl-function-address ] map [ ] find nip
dup [ "OpenGL function not available" throw ] unless
dup r>
+gl-function-pointers+ get-global set-at
gl-function-calling-convention
scan
scan dup
- scan drop "}" parse-tokens swap add*
+ scan drop "}" parse-tokens swap prefix
gl-function-number
[ gl-function-pointer ] 2curry swap
";" parse-tokens [ "()" subseq? not ] subset
USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs vocabs.loader sequences ;
+opengl.gl assocs vocabs.loader sequences ;
IN: opengl
HELP: gl-color
splitting words byte-arrays assocs combinators.lib ;
IN: opengl
-: coordinates [ first2 ] 2apply ;
+: coordinates [ first2 ] bi@ ;
-: fix-coordinates [ first2 [ >fixnum ] 2apply ] 2apply ;
+: fix-coordinates [ first2 [ >fixnum ] bi@ ] bi@ ;
: gl-color ( color -- ) first4 glColor4d ; inline
: unit-circle dup [ sin ] map swap [ cos ] map ;
-: adjust-points [ [ 1 + 0.5 * ] map ] 2apply ;
+: adjust-points [ [ 1 + 0.5 * ] map ] bi@ ;
: scale-points 2array flip [ v* ] with map [ v+ ] with map ;
TUPLE: sprite loc dim dim2 dlist texture ;
: <sprite> ( loc dim dim2 -- sprite )
- f f sprite construct-boa ;
+ f f sprite boa ;
: sprite-size2 sprite-dim2 first2 ;
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
-assocs alien libc opengl math sequences combinators.lib
-combinators.cleave macros arrays ;
+assocs alien alien.strings libc opengl math sequences combinators
+combinators.lib macros arrays io.encodings.ascii ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
- swap string>char-alien malloc-byte-array [
- <void*> swap call
- ] keep free ; inline
+ swap ascii malloc-string [ <void*> swap call ] keep free ; inline
: <gl-shader> ( source kind -- shader )
glCreateShader dup rot
: gl-shader-info-log ( shader -- log )
dup gl-shader-info-log-length dup [
[ 0 <int> swap glGetShaderInfoLog ] keep
- alien>char-string
+ ascii alien>string
] with-malloc ;
: check-gl-shader ( shader -- shader )
: delete-gl-shader ( shader -- ) glDeleteShader ; inline
-PREDICATE: integer gl-shader (gl-shader?) ;
-PREDICATE: gl-shader vertex-shader (vertex-shader?) ;
-PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
+PREDICATE: gl-shader < integer (gl-shader?) ;
+PREDICATE: vertex-shader < gl-shader (vertex-shader?) ;
+PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
! Programs
: gl-program-info-log ( program -- log )
dup gl-program-info-log-length dup [
[ 0 <int> swap glGetProgramInfoLog ] keep
- alien>char-string
+ ascii alien>string
] with-malloc ;
: check-gl-program ( program -- program )
MACRO: with-gl-program ( uniforms quot -- )
(make-with-gl-program) ;
-PREDICATE: integer gl-program (gl-program?) ;
+PREDICATE: gl-program < integer (gl-program?) ;
: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
>r <vertex-shader> check-gl-shader
<<
"libcrypto" {
- { [ win32? ] [ "libeay32.dll" "cdecl" ] }
- { [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
- { [ unix? ] [ "libcrypto.so" "cdecl" ] }
+ { [ os winnt? ] [ "libeay32.dll" "cdecl" ] }
+ { [ os macosx? ] [ "libcrypto.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library
>>
IN: openssl.libssl
<< "libssl" {
- { [ win32? ] [ "ssleay32.dll" "cdecl" ] }
- { [ macosx? ] [ "libssl.dylib" "cdecl" ] }
- { [ unix? ] [ "libssl.so" "cdecl" ] }
+ { [ os winnt? ] [ "ssleay32.dll" "cdecl" ] }
+ { [ os macosx? ] [ "libssl.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libssl.so" "cdecl" ] }
} cond add-library >>
: X509_FILETYPE_PEM 1 ; inline
--- /dev/null
+
+USING: help.syntax help.markup ;
+
+IN: openssl
+
+ARTICLE: "openssl" "OpenSSL"
+
+"Factor on Windows has been tested with this version of OpenSSL: "
+
+{ $url "http://www.openssl.org/related/binaries.html" } ;
\ No newline at end of file
-USING: alien alien.c-types assocs bit-arrays hashtables io io.files
-io.sockets kernel mirrors openssl.libcrypto openssl.libssl
-namespaces math math.parser openssl prettyprint sequences tools.test ;
+USING: alien alien.c-types alien.strings assocs bit-arrays
+hashtables io io.files io.encodings.ascii io.sockets kernel
+mirrors openssl.libcrypto openssl.libssl namespaces math
+math.parser openssl prettyprint sequences tools.test ;
! =========================================================
! Some crypto functions (still to be turned into words)
]
[ "Hello world from the openssl binding" >md5 ] unit-test
-[
- B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49
- 82 115 0 }
-]
-[ "Hello world from the openssl binding" >sha1 ] unit-test
+! Not found on netbsd, windows -- why?
+! [
+ ! B{ 63 113 237 255 181 5 152 241 136 181 43 95 160 105 44 87 49
+ ! 82 115 0 }
+! ]
+! [ "Hello world from the openssl binding" >sha1 ] unit-test
! =========================================================
! Initialize context
[ ] [ ssl-v23 new-ctx ] unit-test
-[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
+[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
! TODO: debug 'Memory protection fault at address 6c'
! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
-[ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test
+[ ] [ get-ctx "password" ascii string>alien set-default-passwd-userdata ] unit-test
! Enter PEM pass phrase: password
-[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path
+[ ] [ get-ctx "extra/openssl/test/server.pem" resource-path
SSL_FILETYPE_PEM use-private-key ] unit-test
-[ ] [ get-ctx "/extra/openssl/test/root.pem" resource-path f
+[ ] [ get-ctx "extra/openssl/test/root.pem" resource-path f
verify-load-locations ] unit-test
[ ] [ get-ctx 1 set-verify-depth ] unit-test
! Load Diffie-Hellman parameters
! =========================================================
-[ ] [ "/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
+[ ] [ "extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
[ ] [ get-bio f f f read-pem-dh-params ] unit-test
! Dump errors to file
! =========================================================
-[ ] [ "/extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
+[ ] [ "extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
[ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
!
! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
-USING: alien alien.c-types assocs kernel libc namespaces
-openssl.libcrypto openssl.libssl sequences ;
+USING: alien alien.c-types alien.strings assocs kernel libc
+namespaces openssl.libcrypto openssl.libssl sequences
+io.encodings.ascii ;
IN: openssl
: password-cb ( -- alien )
"int" { "char*" "int" "int" "void*" } "cdecl"
- [ 3drop "password" string>char-alien 1023 memcpy
+ [ 3drop "password" ascii string>alien 1023 memcpy
"password" length ] alien-callback ;
! =========================================================
swap comment-node present-text ;
: comment, ( ? node text -- )
- rot [ \ comment construct-boa , ] [ 2drop ] if ;
+ rot [ \ comment boa , ] [ 2drop ] if ;
: values% ( prefix values -- )
swap [
M: #shuffle node>quot
dup node-in-d over node-out-d pretty-shuffle
[ , ] [ >r drop t r> ] if*
- dup effect-str "#shuffle: " swap append comment, ;
+ dup effect-str "#shuffle: " prepend comment, ;
: pushed-literals node-out-d [ value-literal literalize ] map ;
{ [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
- { [ t ] [ words-called ] }
+ [ words-called ]
} cond 1 -rot get at+
] [
drop
IN: oracle.liboci
"oci" {
- { [ win32? ] [ "oci.dll" "stdcall" ] }
- { [ macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] }
- { [ unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] }
+ { [ os winnt? ] [ "oci.dll" "stdcall" ] }
+ { [ os macosx? ] [ "$DYLD_LIBRARY_PATH/libclntsh.dylib" "cdecl" ] }
+ { [ os unix? ] [ "$DYLD_LIBRARY_PATH/libclntsh.so.10.1" "cdecl" ] }
} cond add-library
! ===============================================
! Adapted from oci.h and ociap.h
! Tested with Oracle version - 10.1.0.3 Instant Client
-USING: alien alien.c-types combinators kernel math namespaces oracle.liboci
-prettyprint sequences ;
+USING: alien alien.c-types alien.strings combinators kernel math
+namespaces oracle.liboci prettyprint sequences
+io.encodings.ascii ;
IN: oracle
: get-oci-error ( object -- * )
1 f "uint*" <c-object> dup >r 512 "uchar" <c-array> dup >r
512 OCI_HTYPE_ERROR OCIErrorGet r> r> *uint drop
- alien>char-string throw ;
+ ascii alien>string throw ;
: check-result ( result -- )
{
- { [ dup OCI_SUCCESS = ] [ drop ] }
- { [ dup OCI_ERROR = ] [ err get get-oci-error ] }
- { [ dup OCI_INVALID_HANDLE = ] [ "invalid handle" throw ] }
- { [ t ] [ "operation failed" throw ] }
- } cond ;
+ { OCI_SUCCESS [ ] }
+ { OCI_ERROR [ err get get-oci-error ] }
+ { OCI_INVALID_HANDLE [ "invalid handle" throw ] }
+ [ "operation failed" throw ]
+ } case ;
: check-status ( status -- bool )
{
- { [ dup OCI_SUCCESS = ] [ drop t ] }
- { [ dup OCI_ERROR = ] [ err get get-oci-error ] }
- { [ dup OCI_INVALID_HANDLE = ] [ "invalid handle" throw ] }
- { [ dup OCI_NO_DATA = ] [ drop f ] }
- { [ t ] [ "operation failed" throw ] }
- } cond ;
+ { OCI_SUCCESS [ t ] }
+ { OCI_ERROR [ err get get-oci-error ] }
+ { OCI_INVALID_HANDLE [ "invalid handle" throw ] }
+ { OCI_NO_DATA [ f ] }
+ [ "operation failed" throw ]
+ } case ;
! =========================================================
! Initialization and handle-allocation routines
: oci-log-on ( -- )
env get err get svc get
- con get connection-username dup length swap malloc-char-string swap
- con get connection-password dup length swap malloc-char-string swap
- con get connection-db dup length swap malloc-char-string swap
+ con get connection-username dup length swap ascii malloc-string swap
+ con get connection-password dup length swap ascii malloc-string swap
+ con get connection-db dup length swap ascii malloc-string swap
OCILogon check-result ;
! =========================================================
svc get OCI_HTYPE_SVCCTX srv get 0 OCI_ATTR_SERVER err get OCIAttrSet check-result ;
: set-username-attribute ( -- )
- ses get OCI_HTYPE_SESSION con get connection-username dup length swap malloc-char-string swap
+ ses get OCI_HTYPE_SESSION con get connection-username dup length swap ascii malloc-string swap
OCI_ATTR_USERNAME err get OCIAttrSet check-result ;
: set-password-attribute ( -- )
- ses get OCI_HTYPE_SESSION con get connection-password dup length swap malloc-char-string swap
+ ses get OCI_HTYPE_SESSION con get connection-password dup length swap ascii malloc-string swap
OCI_ATTR_PASSWORD err get OCIAttrSet check-result ;
: set-attributes ( -- )
check-result *void* stm set ;
: prepare-statement ( statement -- )
- >r stm get err get r> dup length swap malloc-char-string swap
+ >r stm get err get r> dup length swap ascii malloc-string swap
OCI_NTV_SYNTAX OCI_DEFAULT OCIStmtPrepare check-result ;
-: calculate-size ( type -- size object )
+: calculate-size ( type -- size )
{
- { [ dup SQLT_INT = ] [ "int" heap-size ] }
- { [ dup SQLT_FLT = ] [ "float" heap-size ] }
- { [ dup SQLT_CHR = ] [ "char" heap-size ] }
- { [ dup SQLT_NUM = ] [ "int" heap-size 10 * ] }
- { [ dup SQLT_STR = ] [ 64 ] }
- { [ dup SQLT_ODT = ] [ 256 ] }
- } cond ;
+ { SQLT_INT [ "int" heap-size ] }
+ { SQLT_FLT [ "float" heap-size ] }
+ { SQLT_CHR [ "char" heap-size ] }
+ { SQLT_NUM [ "int" heap-size 10 * ] }
+ { SQLT_STR [ 64 ] }
+ { SQLT_ODT [ 256 ] }
+ } case ;
: define-by-position ( position type -- )
>r >r stm get f <void*> err get
- r> r> calculate-size swap >r [ "char" malloc-array dup buf set ] keep 1+
+ r> r> dup calculate-size >r [ "char" malloc-array dup buf set ] keep 1+
r> f f f OCI_DEFAULT OCIDefineByPos check-result ;
: execute-statement ( -- bool )
: server-version ( -- )
srv get err get 512 "uchar" malloc-array dup >r 512 OCI_HTYPE_SERVER
- OCIServerVersion check-result r> alien>char-string . ;
+ OCIServerVersion check-result r> ascii alien>string . ;
! =========================================================
! Public routines
: fetch-each ( object -- object )
fetch-statement [
- buf get alien>char-string res get swap add res set
+ buf get ascii alien>string res get swap suffix res set
fetch-each
] [ ] if ;
: run-query ( object -- object )
execute-statement [
- buf get alien>char-string res get swap add res set
+ buf get ascii alien>string res get swap suffix res set
fetch-each
] [ ] if ;
USING: alien alien.c-types arrays assocs byte-arrays inference
-inference.transforms io io.binary io.streams.string kernel
-math math.parser namespaces parser prettyprint
-quotations sequences strings vectors
-words macros math.functions ;
+inference.transforms io io.binary io.streams.string kernel math
+math.parser namespaces parser prettyprint quotations sequences
+strings vectors words macros math.functions math.bitfields.lib ;
IN: pack
SYMBOL: big-endian
] if ;
: string= ( str1 str2 ignore-case -- ? )
- [ [ >upper ] 2apply ] when sequence= ;
+ [ [ >upper ] bi@ ] when sequence= ;
: string-head? ( str head ignore-case -- ? )
2over shorter? [
TUPLE: ensure-parser test ;
: ensure ( parser -- ensure )
- ensure-parser construct-boa ;
+ ensure-parser boa ;
M: ensure-parser parse ( input parser -- list )
2dup ensure-parser-test parse nil?
TUPLE: ensure-not-parser test ;
: ensure-not ( parser -- ensure )
- ensure-not-parser construct-boa ;
+ ensure-not-parser boa ;
M: ensure-not-parser parse ( input parser -- list )
2dup ensure-not-parser-test parse nil?
: <&> ( parser1 parser2 -- parser )
over and-parser? [
- >r and-parser-parsers r> add
+ >r and-parser-parsers r> suffix
] [
2array
- ] if and-parser construct-boa ;
+ ] if and-parser boa ;
: <and-parser> ( parsers -- parser )
- dup length 1 = [ first ] [ and-parser construct-boa ] if ;
+ dup length 1 = [ first ] [ and-parser boa ] if ;
: and-parser-parse ( list p1 -- list )
swap [
TUPLE: or-parser parsers ;
: <or-parser> ( parsers -- parser )
- dup length 1 = [ first ] [ or-parser construct-boa ] if ;
+ dup length 1 = [ first ] [ or-parser boa ] if ;
: <|> ( parser1 parser2 -- parser )
2array <or-parser> ;
: <:&> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
- <&> [ first2 add ] <@ ;
+ <&> [ first2 suffix ] <@ ;
: <&:> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
- <&> [ first2 swap add* ] <@ ;
+ <&> [ first2 swap prefix ] <@ ;
: <:&:> ( parser1 parser2 -- result )
#! Same as <&> except flatten the result.
TUPLE: only-first-parser p1 ;
LAZY: only-first ( parser -- parser )
- only-first-parser construct-boa ;
+ only-first-parser boa ;
M: only-first-parser parse ( input parser -- list )
#! Transform a parser into a parser that only yields
nonempty-list-of { } succeed <|> ;
LAZY: surrounded-by ( parser start end -- parser' )
- [ token ] 2apply swapd pack ;
+ [ token ] bi@ swapd pack ;
: exactly-n ( parser n -- parser' )
swap <repetition> <and-parser> [ flatten ] <@ ;
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.ebnf ;
+USING: kernel tools.test peg peg.ebnf words math math.parser sequences ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
{
T{ ebnf-rule f
"digit"
- V{
- T{ ebnf-choice f
- V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
- }
- f
+ T{ ebnf-choice f
+ V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
}
}
} [
{
T{ ebnf-rule f
"digit"
- V{
- T{ ebnf-sequence f
- V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
- }
- f
+ T{ ebnf-sequence f
+ V{ T{ ebnf-terminal f "1" } T{ ebnf-terminal f "2" } }
}
}
} [
}
}
} [
- "one {(two | three) four}" 'choice' parse parse-result-ast
+ "one ((two | three) four)*" 'choice' parse parse-result-ast
] unit-test
{
}
}
} [
- "one [ two ] three" 'choice' parse parse-result-ast
+ "one ( two )? three" 'choice' parse parse-result-ast
+] unit-test
+
+{ "foo" } [
+ "\"foo\"" 'identifier' parse parse-result-ast
+] unit-test
+
+{ "foo" } [
+ "'foo'" 'identifier' parse parse-result-ast
+] unit-test
+
+{ "foo" } [
+ "foo" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
+] unit-test
+
+{ "foo" } [
+ "foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
+] unit-test
+
+{ V{ "a" "b" } } [
+ "ab" [EBNF foo='a' 'b' EBNF] call parse-result-ast
+] unit-test
+
+{ V{ 1 "b" } } [
+ "ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call parse-result-ast
+] unit-test
+
+{ V{ 1 2 } } [
+ "ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call parse-result-ast
+] unit-test
+
+{ CHAR: A } [
+ "A" [EBNF foo=[A-Z] EBNF] call parse-result-ast
+] unit-test
+
+{ CHAR: Z } [
+ "Z" [EBNF foo=[A-Z] EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+ "0" [EBNF foo=[A-Z] EBNF] call
+] unit-test
+
+{ CHAR: 0 } [
+ "0" [EBNF foo=[^A-Z] EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+ "A" [EBNF foo=[^A-Z] EBNF] call
+] unit-test
+
+{ f } [
+ "Z" [EBNF foo=[^A-Z] EBNF] call
+] unit-test
+
+{ V{ "1" "+" "foo" } } [
+ "1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] call parse-result-ast
+] unit-test
+
+{ "foo" } [
+ "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] call parse-result-ast
+] unit-test
+
+{ "foo" } [
+ "1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast
+] unit-test
+
+{ "bar" } [
+ "1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast
+] unit-test
+
+{ 6 } [
+ "4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call parse-result-ast
+] unit-test
+
+{ 6 } [
+ "4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast
+] unit-test
+
+{ 10 } [
+ { 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+ { "a" 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call
] unit-test
+
+{ 3 } [
+ { 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+ "ab" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call
+] unit-test
+
+{ V{ "a" " " "b" } } [
+ "a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "\t" "b" } } [
+ "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "\n" "b" } } [
+ "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" f "b" } } [
+ "ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" " " "b" } } [
+ "a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+
+{ V{ "a" "\t" "b" } } [
+ "a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "\n" "b" } } [
+ "a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "b" } } [
+ "ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "b" } } [
+ "a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ V{ "a" "b" } } [
+ "a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
+] unit-test
+
+{ f } [
+ "axb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call
+] unit-test
+
+{ V{ V{ 49 } "+" V{ 49 } } } [
+ #! Test direct left recursion.
+ #! Using packrat, so first part of expr fails, causing 2nd choice to be used
+ "1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call parse-result-ast
+] unit-test
+
+{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
+ #! Test direct left recursion.
+ #! Using packrat, so first part of expr fails, causing 2nd choice to be used
+ "1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call parse-result-ast
+] unit-test
+
+{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
+ #! Test indirect left recursion.
+ #! Using packrat, so first part of expr fails, causing 2nd choice to be used
+ "1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast
+] unit-test
+
+{ t } [
+ "abcd='9' | ('8'):x => [[ drop x ]]" 'ebnf' parse parse-result-remaining empty?
+] unit-test
+
+EBNF: primary
+Primary = PrimaryNoNewArray
+PrimaryNoNewArray = ClassInstanceCreationExpression
+ | MethodInvocation
+ | FieldAccess
+ | ArrayAccess
+ | "this"
+ClassInstanceCreationExpression = "new" ClassOrInterfaceType "(" ")"
+ | Primary "." "new" Identifier "(" ")"
+MethodInvocation = Primary "." MethodName "(" ")"
+ | MethodName "(" ")"
+FieldAccess = Primary "." Identifier
+ | "super" "." Identifier
+ArrayAccess = Primary "[" Expression "]"
+ | ExpressionName "[" Expression "]"
+ClassOrInterfaceType = ClassName | InterfaceTypeName
+ClassName = "C" | "D"
+InterfaceTypeName = "I" | "J"
+Identifier = "x" | "y" | ClassOrInterfaceType
+MethodName = "m" | "n"
+ExpressionName = Identifier
+Expression = "i" | "j"
+main = Primary
+;EBNF
+
+{ "this" } [
+ "this" primary parse-result-ast
+] unit-test
+
+{ V{ "this" "." "x" } } [
+ "this.x" primary parse-result-ast
+] unit-test
+
+{ V{ V{ "this" "." "x" } "." "y" } } [
+ "this.x.y" primary parse-result-ast
+] unit-test
+
+{ V{ V{ "this" "." "x" } "." "m" "(" ")" } } [
+ "this.x.m()" primary parse-result-ast
+] unit-test
+
+{ V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [
+ "x[i][j].y" primary parse-result-ast
+] unit-test
+
+'ebnf' compile must-infer
! Copyright (C) 2007 Chris Double.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel parser words arrays strings math.parser sequences \r
+USING: kernel compiler.units parser words arrays strings math.parser sequences \r
quotations vectors namespaces math assocs continuations peg\r
- peg.parsers unicode.categories ;\r
+ peg.parsers unicode.categories multiline combinators.lib \r
+ splitting accessors effects sequences.deep peg.search ;\r
IN: peg.ebnf\r
\r
TUPLE: ebnf-non-terminal symbol ;\r
TUPLE: ebnf-terminal symbol ;\r
+TUPLE: ebnf-any-character ;\r
+TUPLE: ebnf-range pattern ;\r
+TUPLE: ebnf-ensure group ;\r
+TUPLE: ebnf-ensure-not group ;\r
TUPLE: ebnf-choice options ;\r
TUPLE: ebnf-sequence elements ;\r
TUPLE: ebnf-repeat0 group ;\r
-TUPLE: ebnf-optional elements ;\r
+TUPLE: ebnf-repeat1 group ;\r
+TUPLE: ebnf-optional group ;\r
TUPLE: ebnf-rule symbol elements ;\r
-TUPLE: ebnf-action word ;\r
+TUPLE: ebnf-action parser code ;\r
+TUPLE: ebnf-var parser name ;\r
+TUPLE: ebnf-semantic parser code ;\r
TUPLE: ebnf rules ;\r
\r
C: <ebnf-non-terminal> ebnf-non-terminal\r
C: <ebnf-terminal> ebnf-terminal\r
+C: <ebnf-any-character> ebnf-any-character\r
+C: <ebnf-range> ebnf-range\r
+C: <ebnf-ensure> ebnf-ensure\r
+C: <ebnf-ensure-not> ebnf-ensure-not\r
C: <ebnf-choice> ebnf-choice\r
C: <ebnf-sequence> ebnf-sequence\r
C: <ebnf-repeat0> ebnf-repeat0\r
+C: <ebnf-repeat1> ebnf-repeat1\r
C: <ebnf-optional> ebnf-optional\r
C: <ebnf-rule> ebnf-rule\r
C: <ebnf-action> ebnf-action\r
+C: <ebnf-var> ebnf-var\r
+C: <ebnf-semantic> ebnf-semantic\r
C: <ebnf> ebnf\r
\r
-SYMBOL: parsers\r
-SYMBOL: non-terminals\r
-SYMBOL: last-parser\r
-\r
-: reset-parser-generation ( -- ) \r
- V{ } clone parsers set \r
- H{ } clone non-terminals set \r
- f last-parser set ;\r
-\r
-: store-parser ( parser -- number )\r
- parsers get [ push ] keep length 1- ;\r
-\r
-: get-parser ( index -- parser )\r
- parsers get nth ;\r
+: syntax ( string -- parser )\r
+ #! Parses the string, ignoring white space, and\r
+ #! does not put the result in the AST.\r
+ token sp hide ;\r
+\r
+: syntax-pack ( begin parser end -- parser )\r
+ #! Parse 'parser' surrounded by syntax elements\r
+ #! begin and end.\r
+ [ syntax ] dipd syntax pack ;\r
+\r
+: 'identifier' ( -- parser )\r
+ #! Return a parser that parses an identifer delimited by\r
+ #! a quotation character. The quotation can be single\r
+ #! or double quotes. The AST produced is the identifier\r
+ #! between the quotes.\r
+ [\r
+ [ CHAR: " = not ] satisfy repeat1 "\"" "\"" surrounded-by ,\r
+ [ CHAR: ' = not ] satisfy repeat1 "'" "'" surrounded-by ,\r
+ ] choice* [ >string ] action ;\r
\r
-: non-terminal-index ( name -- number )\r
- dup non-terminals get at [\r
- nip\r
- ] [\r
- f store-parser [ swap non-terminals get set-at ] keep\r
- ] if* ;\r
-\r
-GENERIC: (generate-parser) ( ast -- id )\r
-\r
-: generate-parser ( ast -- id )\r
- (generate-parser) dup last-parser set ;\r
-\r
-M: ebnf-terminal (generate-parser) ( ast -- id )\r
- ebnf-terminal-symbol token sp store-parser ;\r
-\r
-M: ebnf-non-terminal (generate-parser) ( ast -- id )\r
+: 'non-terminal' ( -- parser )\r
+ #! A non-terminal is the name of another rule. It can\r
+ #! be any non-blank character except for characters used\r
+ #! in the EBNF syntax itself.\r
[\r
- ebnf-non-terminal-symbol dup non-terminal-index , \r
- parsers get , \ nth , [ search ] [ 2drop f ] recover , \ or ,\r
- ] [ ] make delay sp store-parser ;\r
-\r
-M: ebnf-choice (generate-parser) ( ast -- id )\r
- ebnf-choice-options [\r
- generate-parser get-parser \r
- ] map choice store-parser ;\r
-\r
-M: ebnf-sequence (generate-parser) ( ast -- id )\r
- ebnf-sequence-elements [\r
- generate-parser get-parser\r
- ] map seq store-parser ;\r
-\r
-M: ebnf-repeat0 (generate-parser) ( ast -- id )\r
- ebnf-repeat0-group generate-parser get-parser repeat0 store-parser ;\r
-\r
-M: ebnf-optional (generate-parser) ( ast -- id )\r
- ebnf-optional-elements generate-parser get-parser optional store-parser ;\r
-\r
-M: ebnf-rule (generate-parser) ( ast -- id )\r
- dup ebnf-rule-symbol non-terminal-index swap \r
- ebnf-rule-elements generate-parser get-parser ! nt-id body\r
- swap [ parsers get set-nth ] keep ;\r
+ {\r
+ [ dup blank? ]\r
+ [ dup CHAR: " = ]\r
+ [ dup CHAR: ' = ]\r
+ [ dup CHAR: | = ]\r
+ [ dup CHAR: { = ]\r
+ [ dup CHAR: } = ]\r
+ [ dup CHAR: = = ]\r
+ [ dup CHAR: ) = ]\r
+ [ dup CHAR: ( = ]\r
+ [ dup CHAR: ] = ]\r
+ [ dup CHAR: [ = ]\r
+ [ dup CHAR: . = ]\r
+ [ dup CHAR: ! = ]\r
+ [ dup CHAR: & = ]\r
+ [ dup CHAR: * = ]\r
+ [ dup CHAR: + = ]\r
+ [ dup CHAR: ? = ]\r
+ [ dup CHAR: : = ]\r
+ } || not nip \r
+ ] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;\r
\r
-M: ebnf-action (generate-parser) ( ast -- id )\r
- ebnf-action-word search 1quotation \r
- last-parser get get-parser swap action store-parser ;\r
-\r
-M: vector (generate-parser) ( ast -- id )\r
- [ generate-parser ] map peek ;\r
-\r
-M: f (generate-parser) ( ast -- id )\r
- drop last-parser get ;\r
-\r
-M: ebnf (generate-parser) ( ast -- id )\r
- ebnf-rules [\r
- generate-parser \r
- ] map peek ;\r
-\r
-DEFER: 'rhs'\r
+: 'terminal' ( -- parser )\r
+ #! A terminal is an identifier enclosed in quotations\r
+ #! and it represents the literal value of the identifier.\r
+ 'identifier' [ <ebnf-terminal> ] action ;\r
\r
-: 'non-terminal' ( -- parser )\r
- CHAR: a CHAR: z range "-" token [ first ] action 2array choice repeat1 [ >string <ebnf-non-terminal> ] action ;\r
+: 'any-character' ( -- parser )\r
+ #! A parser to match the symbol for any character match.\r
+ [ CHAR: . = ] satisfy [ drop <ebnf-any-character> ] action ;\r
\r
-: 'terminal' ( -- parser )\r
- "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string <ebnf-terminal> ] action ;\r
+: 'range-parser' ( -- parser )\r
+ #! Match the syntax for declaring character ranges\r
+ [\r
+ [ "[" syntax , "[" token ensure-not , ] seq* hide ,\r
+ [ CHAR: ] = not ] satisfy repeat1 , \r
+ "]" syntax ,\r
+ ] seq* [ first >string <ebnf-range> ] action ;\r
+ \r
+: ('element') ( -- parser )\r
+ #! An element of a rule. It can be a terminal or a \r
+ #! non-terminal but must not be followed by a "=". \r
+ #! The latter indicates that it is the beginning of a\r
+ #! new rule.\r
+ [\r
+ [ \r
+ 'non-terminal' ,\r
+ 'terminal' ,\r
+ 'range-parser' ,\r
+ 'any-character' ,\r
+ ] choice* ,\r
+ [\r
+ "=" syntax ensure-not ,\r
+ "=>" syntax ensure ,\r
+ ] choice* ,\r
+ ] seq* [ first ] action ;\r
\r
: 'element' ( -- parser )\r
- 'non-terminal' 'terminal' 2array choice ;\r
+ [\r
+ [ ('element') , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,\r
+ ('element') ,\r
+ ] choice* ;\r
\r
DEFER: 'choice'\r
\r
+: grouped ( quot suffix -- parser )\r
+ #! Parse a group of choices, with a suffix indicating\r
+ #! the type of group (repeat0, repeat1, etc) and\r
+ #! an quot that is the action that produces the AST.\r
+ "(" [ 'choice' sp ] delay ")" syntax-pack \r
+ swap 2seq \r
+ [ first ] rot compose action ;\r
+ \r
: 'group' ( -- parser )\r
- "(" token sp hide\r
- [ 'choice' sp ] delay\r
- ")" token sp hide \r
- 3array seq [ first ] action ;\r
+ #! A grouping with no suffix. Used for precedence.\r
+ [ ] [\r
+ "*" token sp ensure-not ,\r
+ "+" token sp ensure-not ,\r
+ "?" token sp ensure-not ,\r
+ ] seq* hide grouped ; \r
\r
: 'repeat0' ( -- parser )\r
- "{" token sp hide\r
- [ 'choice' sp ] delay\r
- "}" token sp hide \r
- 3array seq [ first <ebnf-repeat0> ] action ;\r
+ [ <ebnf-repeat0> ] "*" syntax grouped ;\r
+\r
+: 'repeat1' ( -- parser )\r
+ [ <ebnf-repeat1> ] "+" syntax grouped ;\r
\r
: 'optional' ( -- parser )\r
- "[" token sp hide\r
- [ 'choice' sp ] delay\r
- "]" token sp hide \r
- 3array seq [ first <ebnf-optional> ] action ;\r
+ [ <ebnf-optional> ] "?" syntax grouped ;\r
\r
-: 'sequence' ( -- parser )\r
+: 'factor-code' ( -- parser )\r
+ [\r
+ "]]" token ensure-not ,\r
+ "]?" token ensure-not ,\r
+ [ drop t ] satisfy ,\r
+ ] seq* [ first ] action repeat0 [ >string ] action ;\r
+\r
+: 'ensure-not' ( -- parser )\r
+ #! Parses the '!' syntax to ensure that \r
+ #! something that matches the following elements do\r
+ #! not exist in the parse stream.\r
+ [\r
+ "!" syntax ,\r
+ 'group' sp ,\r
+ ] seq* [ first <ebnf-ensure-not> ] action ;\r
+\r
+: 'ensure' ( -- parser )\r
+ #! Parses the '&' syntax to ensure that \r
+ #! something that matches the following elements does\r
+ #! exist in the parse stream.\r
+ [\r
+ "&" syntax ,\r
+ 'group' sp ,\r
+ ] seq* [ first <ebnf-ensure> ] action ;\r
+\r
+: ('sequence') ( -- parser )\r
+ #! A sequence of terminals and non-terminals, including\r
+ #! groupings of those. \r
[ \r
+ 'ensure-not' sp ,\r
+ 'ensure' sp ,\r
'element' sp ,\r
'group' sp , \r
'repeat0' sp ,\r
+ 'repeat1' sp ,\r
'optional' sp , \r
- ] { } make choice \r
- repeat1 [ \r
+ ] choice* ;\r
+\r
+: 'action' ( -- parser )\r
+ "[[" 'factor-code' "]]" syntax-pack ;\r
+\r
+: 'semantic' ( -- parser )\r
+ "?[" 'factor-code' "]?" syntax-pack ;\r
+\r
+: 'sequence' ( -- parser )\r
+ #! A sequence of terminals and non-terminals, including\r
+ #! groupings of those. \r
+ [\r
+ [ ('sequence') , 'action' , ] seq* [ first2 <ebnf-action> ] action ,\r
+ [ ('sequence') , 'semantic' , ] seq* [ first2 <ebnf-semantic> ] action ,\r
+ ('sequence') ,\r
+ ] choice* repeat1 [ \r
dup length 1 = [ first ] [ <ebnf-sequence> ] if\r
- ] action ; \r
+ ] action ;\r
\r
+: 'actioned-sequence' ( -- parser )\r
+ [\r
+ [ 'sequence' , "=>" syntax , 'action' , ] seq* [ first2 <ebnf-action> ] action ,\r
+ [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , "=>" syntax , 'action' , ] seq* [ first3 >r <ebnf-var> r> <ebnf-action> ] action ,\r
+ [ 'sequence' , ":" syntax , "a-zA-Z" range-pattern repeat1 [ >string ] action , ] seq* [ first2 <ebnf-var> ] action ,\r
+ 'sequence' ,\r
+ ] choice* ;\r
+ \r
: 'choice' ( -- parser )\r
- 'sequence' sp "|" token sp list-of [ \r
+ 'actioned-sequence' sp "|" token sp list-of [ \r
dup length 1 = [ first ] [ <ebnf-choice> ] if\r
- ] action ;\r
-\r
-: 'action' ( -- parser )\r
- "=>" token hide\r
- [ blank? ] satisfy ensure-not [ drop t ] satisfy 2array seq [ first ] action repeat1 [ >string ] action sp\r
- 2array seq [ first <ebnf-action> ] action ;\r
- \r
-: 'rhs' ( -- parser )\r
- 'choice' 'action' sp optional 2array seq ;\r
+ ] action ;\r
\r
: 'rule' ( -- parser )\r
- 'non-terminal' [ ebnf-non-terminal-symbol ] action \r
- "=" token sp hide \r
- 'rhs' \r
- 3array seq [ first2 <ebnf-rule> ] action ;\r
+ [\r
+ 'non-terminal' [ symbol>> ] action ,\r
+ "=" syntax ,\r
+ ">" token ensure-not ,\r
+ 'choice' ,\r
+ ] seq* [ first2 <ebnf-rule> ] action ;\r
\r
: 'ebnf' ( -- parser )\r
- 'rule' sp "." token sp hide list-of [ <ebnf> ] action ;\r
-\r
-: ebnf>quot ( string -- quot )\r
- 'ebnf' parse [\r
- parse-result-ast [\r
- reset-parser-generation\r
- generate-parser drop\r
- [\r
- non-terminals get\r
- [\r
- get-parser [\r
- swap , \ in , \ get , \ create ,\r
- 1quotation , \ define , \r
- ] [\r
- drop\r
- ] if*\r
- ] assoc-each\r
- ] [ ] make\r
- ] with-scope\r
- ] [\r
- f\r
- ] if* ;\r
-\r
-: <EBNF "EBNF>" parse-tokens " " join ebnf>quot call ; parsing\r
+ 'rule' sp repeat1 [ <ebnf> ] action ;\r
+\r
+GENERIC: (transform) ( ast -- parser )\r
+\r
+SYMBOL: parser\r
+SYMBOL: main\r
+\r
+: transform ( ast -- object )\r
+ H{ } clone dup dup [ parser set swap (transform) main set ] bind ;\r
+\r
+M: ebnf (transform) ( ast -- parser )\r
+ rules>> [ (transform) ] map peek ;\r
+ \r
+M: ebnf-rule (transform) ( ast -- parser )\r
+ dup elements>> \r
+ (transform) [\r
+ swap symbol>> set\r
+ ] keep ;\r
+\r
+M: ebnf-sequence (transform) ( ast -- parser )\r
+ elements>> [ (transform) ] map seq [ dup length 1 = [ first ] when ] action ;\r
+\r
+M: ebnf-choice (transform) ( ast -- parser )\r
+ options>> [ (transform) ] map choice ;\r
+\r
+M: ebnf-any-character (transform) ( ast -- parser )\r
+ drop any-char ;\r
+\r
+M: ebnf-range (transform) ( ast -- parser )\r
+ pattern>> range-pattern ;\r
+\r
+: transform-group ( ast -- parser ) \r
+ #! convert a ast node with groups to a parser for that group\r
+ group>> (transform) ;\r
+\r
+M: ebnf-ensure (transform) ( ast -- parser )\r
+ transform-group ensure ;\r
+\r
+M: ebnf-ensure-not (transform) ( ast -- parser )\r
+ transform-group ensure-not ;\r
+\r
+M: ebnf-repeat0 (transform) ( ast -- parser )\r
+ transform-group repeat0 ;\r
+\r
+M: ebnf-repeat1 (transform) ( ast -- parser )\r
+ transform-group repeat1 ;\r
+\r
+M: ebnf-optional (transform) ( ast -- parser )\r
+ transform-group optional ;\r
+\r
+GENERIC: build-locals ( code ast -- code )\r
+\r
+M: ebnf-sequence build-locals ( code ast -- code )\r
+ elements>> dup [ ebnf-var? ] subset empty? [\r
+ drop \r
+ ] [ \r
+ [\r
+ "USING: locals sequences ; [let* | " %\r
+ dup length swap [\r
+ dup ebnf-var? [\r
+ name>> % \r
+ " [ " % # " over nth ] " %\r
+ ] [\r
+ 2drop\r
+ ] if\r
+ ] 2each\r
+ " | " %\r
+ % \r
+ " ] with-locals" % \r
+ ] "" make \r
+ ] if ;\r
+\r
+M: ebnf-var build-locals ( code ast -- )\r
+ [\r
+ "USING: locals kernel ; [let* | " %\r
+ name>> % " [ dup ] " %\r
+ " | " %\r
+ % \r
+ " ] with-locals" % \r
+ ] "" make ;\r
+\r
+M: object build-locals ( code ast -- )\r
+ drop ;\r
+ \r
+M: ebnf-action (transform) ( ast -- parser )\r
+ [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals \r
+ string-lines parse-lines action ;\r
+\r
+M: ebnf-semantic (transform) ( ast -- parser )\r
+ [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals \r
+ string-lines parse-lines semantic ;\r
+\r
+M: ebnf-var (transform) ( ast -- parser )\r
+ parser>> (transform) ;\r
+\r
+M: ebnf-terminal (transform) ( ast -- parser )\r
+ symbol>> token ;\r
+\r
+: parser-not-found ( name -- * )\r
+ [\r
+ "Parser " % % " not found." %\r
+ ] "" make throw ;\r
+\r
+M: ebnf-non-terminal (transform) ( ast -- parser )\r
+ symbol>> [\r
+ , \ dup , parser get , \ at , [ parser-not-found ] , \ unless* , \ nip , \r
+ ] [ ] make box ;\r
+\r
+: transform-ebnf ( string -- object )\r
+ 'ebnf' parse parse-result-ast transform ;\r
+\r
+: check-parse-result ( result -- result )\r
+ dup [\r
+ dup parse-result-remaining [ blank? ] trim empty? [\r
+ [ \r
+ "Unable to fully parse EBNF. Left to parse was: " %\r
+ parse-result-remaining % \r
+ ] "" make throw\r
+ ] unless\r
+ ] [\r
+ "Could not parse EBNF" throw\r
+ ] if ;\r
+\r
+: ebnf>quot ( string -- hashtable quot )\r
+ 'ebnf' parse check-parse-result \r
+ parse-result-ast transform dup dup parser [ main swap at compile ] with-variable\r
+ [ compiled-parse ] curry [ with-scope ] curry ;\r
+\r
+: replace-escapes ( string -- string )\r
+ [\r
+ "\\t" token [ drop "\t" ] action ,\r
+ "\\n" token [ drop "\n" ] action ,\r
+ "\\r" token [ drop "\r" ] action ,\r
+ ] choice* replace ;\r
+\r
+: [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing\r
+\r
+: EBNF: \r
+ CREATE-WORD dup \r
+ ";EBNF" parse-multiline-string replace-escapes\r
+ ebnf>quot swapd 1 1 <effect> define-declared "ebnf-parser" set-word-prop ; parsing\r
+\r
+: rule ( name word -- parser )\r
+ #! Given an EBNF word produced from EBNF: return the EBNF rule\r
+ "ebnf-parser" word-prop at ;
\ No newline at end of file
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: kernel tools.test peg peg.expr multiline sequences ;
+IN: peg.expr.tests
+
+{ 5 } [
+ "2+3" eval-expr
+] unit-test
+
+{ 6 } [
+ "2*3" eval-expr
+] unit-test
+
+{ 14 } [
+ "2+3*4" eval-expr
+] unit-test
+
+{ 17 } [
+ "2+3*4+3" eval-expr
+] unit-test
+
+{ 23 } [
+ "2+3*(4+3)" eval-expr
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays strings math.parser sequences
+peg peg.ebnf peg.parsers memoize math ;
+IN: peg.expr
+
+EBNF: expr
+digit = [0-9] => [[ digit> ]]
+number = (digit)+ => [[ 10 digits>integer ]]
+value = number
+ | ("(" exp ")") => [[ second ]]
+
+fac = fac "*" value => [[ first3 nip * ]]
+ | fac "/" value => [[ first3 nip / ]]
+ | number
+
+exp = exp "+" fac => [[ first3 nip + ]]
+ | exp "-" fac => [[ first3 nip - ]]
+ | fac
+;EBNF
+
+: eval-expr ( string -- number )
+ expr parse-result-ast ;
+
--- /dev/null
+Simple expression evaluator using EBNF
} { $description
"Returns a parser that matches an string composed of a \", anything that is not \", and another \"."
} { $see-also 'integer' } ;
+
+HELP: range-pattern
+{ $values
+ { "pattern" "a string" }
+ { "parser" "a parser" }
+} { $description
+"Returns a parser that matches a single character based on the set "
+"of characters in the pattern string."
+"Any single character in the pattern matches that character. "
+"If the pattern begins with a ^ then the set is negated "
+"(the element matches any character not in the set). Any pair "
+"of characters separated with a dash (-) represents the "
+"range of characters from the first to the second, inclusive."
+{ $examples
+ { $example "USING: peg peg.parsers prettyprint strings ;" "\"a\" \"_a-zA-Z\" range-pattern parse parse-result-ast 1string ." "\"a\"" }
+ { $example "USING: peg peg.parsers prettyprint ;\n\"0\" \"^0-9\" range-pattern parse ." "f" }
+}
+} ;
[ V{ } ]
[ "" epsilon parse parse-result-ast ] unit-test
+
+{ "a" } [
+ "a" "a" token just parse parse-result-ast
+] unit-test
\ No newline at end of file
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings namespaces math assocs shuffle
- vectors arrays combinators.lib memoize math.parser match
- unicode.categories sequences.deep peg peg.private ;
+ vectors arrays combinators.lib math.parser
+ unicode.categories sequences.deep peg peg.private
+ peg.search math.ranges words memoize ;
IN: peg.parsers
TUPLE: just-parser p1 ;
: just-pattern
[
- dup [
+ execute dup [
dup parse-result-remaining empty? [ drop f ] unless
] when
] ;
-M: just-parser compile ( parser -- quot )
- just-parser-p1 compile just-pattern append ;
+M: just-parser (compile) ( parser -- quot )
+ just-parser-p1 compiled-parser just-pattern curry ;
MEMO: just ( parser -- parser )
- just-parser construct-boa init-parser ;
+ just-parser boa init-parser ;
-MEMO: 1token ( ch -- parser ) 1string token ;
+: 1token ( ch -- parser ) 1string token ;
<PRIVATE
-MEMO: (list-of) ( items separator repeat1? -- parser )
+: (list-of) ( items separator repeat1? -- parser )
>r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq
[ unclip 1vector swap first append ] action ;
PRIVATE>
-MEMO: list-of ( items separator -- parser )
+: list-of ( items separator -- parser )
hide f (list-of) ;
-MEMO: list-of-many ( items separator -- parser )
+: list-of-many ( items separator -- parser )
hide t (list-of) ;
-MEMO: epsilon ( -- parser ) V{ } token ;
+: epsilon ( -- parser ) V{ } token ;
-MEMO: any-char ( -- parser ) [ drop t ] satisfy ;
+: any-char ( -- parser ) [ drop t ] satisfy ;
<PRIVATE
MEMO: pack ( begin body end -- parser )
>r >r hide r> r> hide 3seq [ first ] action ;
-MEMO: surrounded-by ( parser begin end -- parser' )
- [ token ] 2apply swapd pack ;
+: surrounded-by ( parser begin end -- parser' )
+ [ token ] bi@ swapd pack ;
-MEMO: 'digit' ( -- parser )
+: 'digit' ( -- parser )
[ digit? ] satisfy [ digit> ] action ;
-MEMO: 'integer' ( -- parser )
+: 'integer' ( -- parser )
'digit' repeat1 [ 10 digits>integer ] action ;
-MEMO: 'string' ( -- parser )
+: 'string' ( -- parser )
[
[ CHAR: " = ] satisfy hide ,
[ CHAR: " = not ] satisfy repeat0 ,
[ CHAR: " = ] satisfy hide ,
- ] { } make seq [ first >string ] action ;
+ ] seq* [ first >string ] action ;
+
+: (range-pattern) ( pattern -- string )
+ #! Given a range pattern, produce a string containing
+ #! all characters within that range.
+ [
+ any-char ,
+ [ CHAR: - = ] satisfy hide ,
+ any-char ,
+ ] seq* [
+ first2 [a,b] >string
+ ] action
+ replace ;
+
+: range-pattern ( pattern -- parser )
+ #! 'pattern' is a set of characters describing the
+ #! parser to be produced. Any single character in
+ #! the pattern matches that character. If the pattern
+ #! begins with a ^ then the set is negated (the element
+ #! matches any character not in the set). Any pair of
+ #! characters separated with a dash (-) represents the
+ #! range of characters from the first to the second,
+ #! inclusive.
+ dup first CHAR: ^ = [
+ 1 tail (range-pattern) [ member? not ] curry satisfy
+ ] [
+ (range-pattern) [ member? ] curry satisfy
+ ] if ;
}\r
{ $description \r
"Given the input string, parse it using the given parser. The result is a <parse-result> object if "\r
- "the parse was successful, otherwise it is f." } ;\r
+ "the parse was successful, otherwise it is f." } \r
+{ $see-also compile } ;\r
+\r
+HELP: compile\r
+{ $values \r
+ { "parser" "a parser" } \r
+ { "word" "a word" } \r
+}\r
+{ $description \r
+ "Compile the parser to a word. The word will have stack effect ( -- result )."\r
+} \r
+{ $see-also parse } ;\r
\r
HELP: token\r
{ $values \r
"Returns a parser that parses 0 or 1 instances of the 'p1' parser. The AST produced is "\r
"'f' if 0 instances are parsed the AST produced is 'f', otherwise it is the AST produced by 'p1'." } ;\r
\r
+HELP: semantic\r
+{ $values \r
+ { "parser" "a parser" } \r
+ { "quot" "a quotation with stack effect ( object -- bool )" } \r
+}\r
+{ $description \r
+ "Returns a parser that succeeds if the 'p1' parser succeeds and the quotation called with "\r
+ "the AST produced by 'p1' on the stack returns true." }\r
+{ $examples \r
+ { $example "USING: kernel math peg prettyprint ;" "\"A\" [ drop t ] satisfy [ 66 > ] semantic parse ." "f" } \r
+ { $example "USING: kernel math peg prettyprint ;" "\"C\" [ drop t ] satisfy [ 66 > ] semantic parse parse-result-ast ." "67" } \r
+} ;\r
+\r
HELP: ensure\r
{ $values \r
{ "parser" "a parser" } \r
"Returns a parser that calls the 'p1' parser and applies the quotation to the AST resulting "\r
"from that parse. The result of the quotation is then used as the final AST. This can be used "\r
"for manipulating the parse tree to produce a AST better suited for the task at hand rather than "\r
- "the default AST." }\r
+ "the default AST. If the quotation returns " { $link fail } " then the parser fails." }\r
{ $code "CHAR: 0 CHAR: 9 range [ to-digit ] action" } ;\r
\r
HELP: sp\r
{ $description \r
"Delays the construction of a parser until it is actually required to parse. This " \r
"allows for calling a parser that results in a recursive call to itself. The quotation "\r
- "should return the constructed parser." } ;\r
+ "should return the constructed parser and is called the first time the parser is run."\r
+ "The compiled result is memoized for future runs. See " { $link box } " for a word "\r
+ "that calls the quotation at compile time." } ;\r
+\r
+HELP: box\r
+{ $values \r
+ { "quot" "a quotation" } \r
+ { "parser" "a parser" } \r
+}\r
+{ $description \r
+ "Delays the construction of a parser until the parser is compiled. The quotation "\r
+ "should return the constructed parser and is called when the parser is compiled."\r
+ "The compiled result is memoized for future runs. See " { $link delay } " for a word "\r
+ "that calls the quotation at runtime." } ;\r
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test strings namespaces arrays sequences peg peg.private ;
+USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ;
IN: peg.tests
-{ 0 1 2 } [
- 0 next-id set-global get-next-id get-next-id get-next-id
-] unit-test
-
{ f } [
"endbegin" "begin" token parse
] unit-test
"a]" "[" token hide "a" token "]" token hide 3array seq parse
] unit-test
+
+{ V{ "1" "-" "1" } V{ "1" "+" "1" } } [
+ [
+ [ "1" token , "-" token , "1" token , ] seq* ,
+ [ "1" token , "+" token , "1" token , ] seq* ,
+ ] choice*
+ "1-1" over parse parse-result-ast swap
+ "1+1" swap parse parse-result-ast
+] unit-test
+
+: expr ( -- parser )
+ #! Test direct left recursion. Currently left recursion should cause a
+ #! failure of that parser.
+ [ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
+
+{ V{ V{ "1" "+" "1" } "+" "1" } } [
+ "1+1+1" expr parse parse-result-ast
+] unit-test
+
+{ t } [
+ #! Ensure a circular parser doesn't loop infinitely
+ [ f , "a" token , ] seq*
+ dup parsers>>
+ dupd 0 swap set-nth compile word?
+] unit-test
+
+{ f } [
+ "A" [ drop t ] satisfy [ 66 >= ] semantic parse
+] unit-test
+
+{ CHAR: B } [
+ "B" [ drop t ] satisfy [ 66 >= ] semantic parse parse-result-ast
+] unit-test
+
-! Copyright (C) 2007 Chris Double.
+! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences strings namespaces math assocs shuffle
- vectors arrays combinators.lib memoize math.parser match
- unicode.categories sequences.lib compiler.units parser
- words ;
+USING: kernel sequences strings fry namespaces math assocs shuffle
+ vectors arrays math.parser
+ unicode.categories compiler.units parser
+ words quotations effects memoize accessors locals effects splitting ;
IN: peg
+USE: prettyprint
+
TUPLE: parse-result remaining ast ;
-GENERIC: compile ( parser -- quot )
+TUPLE: parser id compiled ;
-: (parse) ( state parser -- result )
- compile call ;
+M: parser equal? [ id>> ] bi@ = ;
+M: parser hashcode* id>> hashcode* ;
-<PRIVATE
+C: <parser> parser
-SYMBOL: packrat-cache
SYMBOL: ignore
-SYMBOL: not-in-cache
-
-: not-in-cache? ( result -- ? )
- not-in-cache = ;
: <parse-result> ( remaining ast -- parse-result )
- parse-result construct-boa ;
+ parse-result boa ;
-SYMBOL: next-id
+SYMBOL: packrat
+SYMBOL: pos
+SYMBOL: input
+SYMBOL: fail
+SYMBOL: lrstack
+SYMBOL: heads
-: get-next-id ( -- number )
- next-id get-global 0 or dup 1+ next-id set-global ;
+: failed? ( obj -- ? )
+ fail = ;
-TUPLE: parser id ;
+: delegates ( -- cache )
+ \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ;
-: init-parser ( parser -- parser )
- get-next-id parser construct-boa over set-delegate ;
+: reset-pegs ( -- )
+ H{ } clone \ delegates set-global ;
+
+reset-pegs
+
+TUPLE: memo-entry ans pos ;
+C: <memo-entry> memo-entry
+
+TUPLE: left-recursion seed rule head next ;
+C: <left-recursion> left-recursion
+
+TUPLE: peg-head rule involved-set eval-set ;
+C: <head> peg-head
+
+: rule-parser ( rule -- parser )
+ #! A rule is the parser compiled down to a word. It has
+ #! a "peg" property containing the original parser.
+ "peg" word-prop ;
-: from ( slice-or-string -- index )
+: input-slice ( -- slice )
+ #! Return a slice of the input from the current parse position
+ input get pos get tail-slice ;
+
+: input-from ( input -- n )
+ #! Return the index from the original string that the
+ #! input slice is based on.
dup slice? [ slice-from ] [ drop 0 ] if ;
-: get-cached ( input parser -- result )
- [ from ] dip parser-id packrat-cache get at at* [
- drop not-in-cache
- ] unless ;
+: input-cache ( parser -- cache )
+ #! From the packrat cache, obtain the cache for the parser
+ #! that maps the position to the parser result.
+ id>> packrat get [ drop H{ } clone ] cache ;
-: put-cached ( result input parser -- )
- parser-id dup packrat-cache get at [
- nip
+: process-rule-result ( p result -- result )
+ [
+ nip [ ast>> ] [ remaining>> ] bi input-from pos set
] [
- H{ } clone dup >r swap packrat-cache get set-at r>
- ] if*
- [ from ] dip set-at ;
-
-PRIVATE>
+ pos set fail
+ ] if* ;
+
+: eval-rule ( rule -- ast )
+ #! Evaluate a rule, return an ast resulting from it.
+ #! Return fail if the rule failed. The rule has
+ #! stack effect ( input -- parse-result )
+ pos get swap execute process-rule-result ; inline
+
+: memo ( pos rule -- memo-entry )
+ #! Return the result from the memo cache.
+ rule-parser input-cache at ;
+
+: set-memo ( memo-entry pos rule -- )
+ #! Store an entry in the cache
+ rule-parser input-cache set-at ;
+
+: update-m ( ast m -- )
+ swap >>ans pos get >>pos drop ;
+
+: stop-growth? ( ast m -- ? )
+ [ failed? pos get ] dip
+ pos>> <= or ;
+
+: setup-growth ( h p -- )
+ pos set dup involved-set>> clone >>eval-set drop ;
+
+: (grow-lr) ( h p r m -- )
+ >r >r [ setup-growth ] 2keep r> r>
+ >r dup eval-rule r> swap
+ dup pick stop-growth? [
+ 4drop drop
+ ] [
+ over update-m
+ (grow-lr)
+ ] if ; inline
+
+: grow-lr ( h p r m -- ast )
+ >r >r [ heads get set-at ] 2keep r> r>
+ pick over >r >r (grow-lr) r> r>
+ swap heads get delete-at
+ dup pos>> pos set ans>>
+ ; inline
+
+:: (setup-lr) ( r l s -- )
+ s head>> l head>> eq? [
+ l head>> s (>>head)
+ l head>> [ s rule>> suffix ] change-involved-set drop
+ r l s next>> (setup-lr)
+ ] unless ;
-: parse ( input parser -- result )
- packrat-cache get [
- 2dup get-cached dup not-in-cache? [
-! "cache missed: " write over parser-id number>string write " - " write nl ! pick .
- drop
- #! Protect against left recursion blowing the callstack
- #! by storing a failed parse in the cache.
- [ f ] dipd [ put-cached ] 2keep
- [ (parse) dup ] 2keep put-cached
- ] [
-! "cache hit: " write over parser-id number>string write " - " write nl ! pick .
- 2nip
+:: setup-lr ( r l -- )
+ l head>> [
+ r V{ } clone V{ } clone <head> l (>>head)
+ ] unless
+ r l lrstack get (setup-lr) ;
+
+:: lr-answer ( r p m -- ast )
+ [let* |
+ h [ m ans>> head>> ]
+ |
+ h rule>> r eq? [
+ m ans>> seed>> m (>>ans)
+ m ans>> failed? [
+ fail
+ ] [
+ h p r m grow-lr
+ ] if
+ ] [
+ m ans>> seed>>
+ ] if
+ ] ; inline
+
+:: recall ( r p -- memo-entry )
+ [let* |
+ m [ p r memo ]
+ h [ p heads get at ]
+ |
+ h [
+ m r h involved-set>> h rule>> suffix member? not and [
+ fail p <memo-entry>
+ ] [
+ r h eval-set>> member? [
+ h [ r swap remove ] change-eval-set drop
+ r eval-rule
+ m update-m
+ m
+ ] [
+ m
+ ] if
+ ] if
+ ] [
+ m
+ ] if
+ ] ; inline
+
+:: apply-non-memo-rule ( r p -- ast )
+ [let* |
+ lr [ fail r f lrstack get <left-recursion> ]
+ m [ lr lrstack set lr p <memo-entry> dup p r set-memo ]
+ ans [ r eval-rule ]
+ |
+ lrstack get next>> lrstack set
+ pos get m (>>pos)
+ lr head>> [
+ ans lr (>>seed)
+ r p m lr-answer
+ ] [
+ ans m (>>ans)
+ ans
] if
+ ] ; inline
+
+: apply-memo-rule ( r m -- ast )
+ [ ans>> ] [ pos>> ] bi pos set
+ dup left-recursion? [
+ [ setup-lr ] keep seed>>
] [
- (parse)
- ] if ;
+ nip
+ ] if ;
+
+: apply-rule ( r p -- ast )
+ 2dup recall [
+ nip apply-memo-rule
+ ] [
+ apply-non-memo-rule
+ ] if* ; inline
+
+: with-packrat ( input quot -- result )
+ #! Run the quotation with a packrat cache active.
+ swap [
+ input set
+ 0 pos set
+ f lrstack set
+ H{ } clone heads set
+ H{ } clone packrat set
+ ] H{ } make-assoc swap bind ; inline
+
+
+GENERIC: (compile) ( parser -- quot )
+
+: execute-parser ( word -- result )
+ pos get apply-rule dup failed? [
+ drop f
+ ] [
+ input-slice swap <parse-result>
+ ] if ; inline
+
+: parser-body ( parser -- quot )
+ #! Return the body of the word that is the compiled version
+ #! of the parser.
+ gensym 2dup swap (compile) 0 1 <effect> define-declared swap dupd "peg" set-word-prop
+ [ execute-parser ] curry ;
+
+: compiled-parser ( parser -- word )
+ #! Look to see if the given parser has been compiled.
+ #! If not, compile it to a temporary word, cache it,
+ #! and return it. Otherwise return the existing one.
+ #! Circular parsers are supported by getting the word
+ #! name and storing it in the cache, before compiling,
+ #! so it is picked up when re-entered.
+ dup compiled>> [
+ nip
+ ] [
+ gensym tuck >>compiled 2dup parser-body 0 1 <effect> define-declared dupd "peg" set-word-prop
+ ] if* ;
+
+SYMBOL: delayed
+
+: fixup-delayed ( -- )
+ #! Work through all delayed parsers and recompile their
+ #! words to have the correct bodies.
+ delayed get [
+ call compiled-parser 1quotation 0 1 <effect> define-declared
+ ] assoc-each ;
+
+: compile ( parser -- word )
+ [
+ H{ } clone delayed [
+ compiled-parser fixup-delayed
+ ] with-variable
+ ] with-compilation-unit ;
+
+: compiled-parse ( state word -- result )
+ swap [ execute ] with-packrat ; inline
-: packrat-parse ( input parser -- result )
- H{ } clone packrat-cache [ parse ] with-variable ;
+: parse ( input parser -- result )
+ dup word? [ compile ] unless compiled-parse ;
<PRIVATE
+SYMBOL: id
+
+: next-id ( -- n )
+ #! Return the next unique id for a parser
+ id get-global [
+ dup 1+ id set-global
+ ] [
+ 1 id set-global 0
+ ] if* ;
+
+: init-parser ( parser -- parser )
+ #! Set the delegate for the parser. Equivalent parsers
+ #! get a delegate with the same id.
+ dup clone delegates [
+ drop next-id f <parser>
+ ] cache over set-delegate ;
+
TUPLE: token-parser symbol ;
-MATCH-VARS: ?token ;
+: parse-token ( input string -- result )
+ #! Parse the string, returning a parse result
+ dup >r ?head-slice [
+ r> <parse-result>
+ ] [
+ r> 2drop f
+ ] if ;
-: token-pattern ( -- quot )
- [
- ?token 2dup head? [
- dup >r length tail-slice r> <parse-result>
- ] [
- 2drop f
- ] if
- ] ;
-
-M: token-parser compile ( parser -- quot )
- token-parser-symbol \ ?token token-pattern match-replace ;
-
+M: token-parser (compile) ( parser -- quot )
+ symbol>> '[ input-slice , parse-token ] ;
+
TUPLE: satisfy-parser quot ;
-MATCH-VARS: ?quot ;
+: parse-satisfy ( input quot -- result )
+ swap dup empty? [
+ 2drop f
+ ] [
+ unclip-slice rot dupd call [
+ <parse-result>
+ ] [
+ 2drop f
+ ] if
+ ] if ; inline
-: satisfy-pattern ( -- quot )
- [
- dup empty? [
- drop f
- ] [
- unclip-slice dup ?quot call [
- <parse-result>
- ] [
- 2drop f
- ] if
- ] if
- ] ;
-M: satisfy-parser compile ( parser -- quot )
- satisfy-parser-quot \ ?quot satisfy-pattern match-replace ;
+M: satisfy-parser (compile) ( parser -- quot )
+ quot>> '[ input-slice , parse-satisfy ] ;
TUPLE: range-parser min max ;
-MATCH-VARS: ?min ?max ;
-
-: range-pattern ( -- quot )
- [
- dup empty? [
+: parse-range ( input min max -- result )
+ pick empty? [
+ 3drop f
+ ] [
+ pick first -rot between? [
+ unclip-slice <parse-result>
+ ] [
drop f
- ] [
- 0 over nth dup
- ?min ?max between? [
- [ 1 tail-slice ] dip <parse-result>
- ] [
- 2drop f
- ] if
- ] if
- ] ;
+ ] if
+ ] if ;
-M: range-parser compile ( parser -- quot )
- T{ range-parser _ ?min ?max } range-pattern match-replace ;
+M: range-parser (compile) ( parser -- quot )
+ [ min>> ] [ max>> ] bi '[ input-slice , , parse-range ] ;
TUPLE: seq-parser parsers ;
-: seq-pattern ( -- quot )
+: ignore? ( ast -- bool )
+ ignore = ;
+
+: calc-seq-result ( prev-result current-result -- next-result )
[
- dup [
- dup parse-result-remaining ?quot call [
- [ parse-result-remaining swap set-parse-result-remaining ] 2keep
- parse-result-ast dup ignore = [
- drop
- ] [
- swap [ parse-result-ast push ] keep
- ] if
- ] [
- drop f
- ] if*
+ [ remaining>> swap (>>remaining) ] 2keep
+ ast>> dup ignore? [
+ drop
] [
- drop f
- ] if
- ] ;
+ swap [ ast>> push ] keep
+ ] if
+ ] [
+ drop f
+ ] if* ;
-M: seq-parser compile ( parser -- quot )
+: parse-seq-element ( result quot -- result )
+ over [
+ call calc-seq-result
+ ] [
+ 2drop f
+ ] if ; inline
+
+M: seq-parser (compile) ( parser -- quot )
[
- [ V{ } clone <parse-result> ] %
- seq-parser-parsers [ compile \ ?quot seq-pattern match-replace % ] each
+ [ input-slice V{ } clone <parse-result> ] %
+ parsers>> [ compiled-parser 1quotation , \ parse-seq-element , ] each
] [ ] make ;
TUPLE: choice-parser parsers ;
-: choice-pattern ( -- quot )
- [
- dup [
-
- ] [
- drop dup ?quot call
- ] if
- ] ;
-
-M: choice-parser compile ( parser -- quot )
- [
+M: choice-parser (compile) ( parser -- quot )
+ [
f ,
- choice-parser-parsers [ compile \ ?quot choice-pattern match-replace % ] each
- \ nip ,
+ parsers>> [ compiled-parser 1quotation , \ unless* , ] each
] [ ] make ;
TUPLE: repeat0-parser p1 ;
-: (repeat0) ( quot result -- result )
- 2dup parse-result-remaining swap call [
- [ parse-result-remaining swap set-parse-result-remaining ] 2keep
- parse-result-ast swap [ parse-result-ast push ] keep
- (repeat0)
- ] [
+: (repeat) ( quot result -- result )
+ over call [
+ [ remaining>> swap (>>remaining) ] 2keep
+ ast>> swap [ ast>> push ] keep
+ (repeat)
+ ] [
nip
] if* ; inline
-: repeat0-pattern ( -- quot )
- [
- ?quot swap (repeat0)
- ] ;
-
-M: repeat0-parser compile ( parser -- quot )
- [
- [ V{ } clone <parse-result> ] %
- repeat0-parser-p1 compile \ ?quot repeat0-pattern match-replace %
- ] [ ] make ;
+M: repeat0-parser (compile) ( parser -- quot )
+ p1>> compiled-parser 1quotation '[
+ input-slice V{ } clone <parse-result> , swap (repeat)
+ ] ;
TUPLE: repeat1-parser p1 ;
-: repeat1-pattern ( -- quot )
+: repeat1-empty-check ( result -- result )
[
- ?quot swap (repeat0) [
- dup parse-result-ast empty? [
- drop f
- ] when
- ] [
- f
- ] if*
- ] ;
+ dup ast>> empty? [ drop f ] when
+ ] [
+ f
+ ] if* ;
-M: repeat1-parser compile ( parser -- quot )
- [
- [ V{ } clone <parse-result> ] %
- repeat1-parser-p1 compile \ ?quot repeat1-pattern match-replace %
- ] [ ] make ;
+M: repeat1-parser (compile) ( parser -- quot )
+ p1>> compiled-parser 1quotation '[
+ input-slice V{ } clone <parse-result> , swap (repeat) repeat1-empty-check
+ ] ;
TUPLE: optional-parser p1 ;
-: optional-pattern ( -- quot )
- [
- dup ?quot call swap f <parse-result> or
- ] ;
+: check-optional ( result -- result )
+ [ input-slice f <parse-result> ] unless* ;
+
+M: optional-parser (compile) ( parser -- quot )
+ p1>> compiled-parser 1quotation '[ @ check-optional ] ;
+
+TUPLE: semantic-parser p1 quot ;
+
+: check-semantic ( result quot -- result )
+ over [
+ over ast>> swap call [ drop f ] unless
+ ] [
+ drop
+ ] if ; inline
-M: optional-parser compile ( parser -- quot )
- optional-parser-p1 compile \ ?quot optional-pattern match-replace ;
+M: semantic-parser (compile) ( parser -- quot )
+ [ p1>> compiled-parser 1quotation ] [ quot>> ] bi
+ '[ @ , check-semantic ] ;
TUPLE: ensure-parser p1 ;
-: ensure-pattern ( -- quot )
- [
- dup ?quot call [
- ignore <parse-result>
- ] [
- drop f
- ] if
- ] ;
+: check-ensure ( old-input result -- result )
+ [ ignore <parse-result> ] [ drop f ] if ;
-M: ensure-parser compile ( parser -- quot )
- ensure-parser-p1 compile \ ?quot ensure-pattern match-replace ;
+M: ensure-parser (compile) ( parser -- quot )
+ p1>> compiled-parser 1quotation '[ input-slice @ check-ensure ] ;
TUPLE: ensure-not-parser p1 ;
-: ensure-not-pattern ( -- quot )
- [
- dup ?quot call [
- drop f
- ] [
- ignore <parse-result>
- ] if
- ] ;
+: check-ensure-not ( old-input result -- result )
+ [ drop f ] [ ignore <parse-result> ] if ;
-M: ensure-not-parser compile ( parser -- quot )
- ensure-not-parser-p1 compile \ ?quot ensure-not-pattern match-replace ;
+M: ensure-not-parser (compile) ( parser -- quot )
+ p1>> compiled-parser 1quotation '[ input-slice @ check-ensure-not ] ;
TUPLE: action-parser p1 quot ;
-MATCH-VARS: ?action ;
-
-: action-pattern ( -- quot )
- [
- ?quot call dup [
- dup parse-result-ast ?action call
- swap [ set-parse-result-ast ] keep
- ] when
- ] ;
+: check-action ( result quot -- result )
+ over [
+ over ast>> swap call >>ast
+ ] [
+ drop
+ ] if ; inline
-M: action-parser compile ( parser -- quot )
- { action-parser-p1 action-parser-quot } get-slots [ compile ] dip
- 2array { ?quot ?action } action-pattern match-replace ;
+M: action-parser (compile) ( parser -- quot )
+ [ p1>> compiled-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
TUPLE: sp-parser p1 ;
-M: sp-parser compile ( parser -- quot )
- [
- \ left-trim-slice , sp-parser-p1 compile %
- ] [ ] make ;
+M: sp-parser (compile) ( parser -- quot )
+ p1>> compiled-parser 1quotation '[
+ input-slice left-trim-slice input-from pos set @
+ ] ;
TUPLE: delay-parser quot ;
-M: delay-parser compile ( parser -- quot )
- [
- delay-parser-quot % \ compile , \ call ,
- ] [ ] make ;
+M: delay-parser (compile) ( parser -- quot )
+ #! For efficiency we memoize the quotation.
+ #! This way it is run only once and the
+ #! parser constructed once at run time.
+ quot>> gensym [ delayed get set-at ] keep 1quotation ;
+
+TUPLE: box-parser quot ;
+
+M: box-parser (compile) ( parser -- quot )
+ #! Calls the quotation at compile time
+ #! to produce the parser to be compiled.
+ #! This differs from 'delay' which calls
+ #! it at run time. Due to using the runtime
+ #! environment at compile time, this parser
+ #! must not be cached, so we clear out the
+ #! delgates cache.
+ f >>compiled quot>> call compiled-parser 1quotation ;
PRIVATE>
-MEMO: token ( string -- parser )
- token-parser construct-boa init-parser ;
+: token ( string -- parser )
+ token-parser boa init-parser ;
: satisfy ( quot -- parser )
- satisfy-parser construct-boa init-parser ;
+ satisfy-parser boa init-parser ;
-MEMO: range ( min max -- parser )
- range-parser construct-boa init-parser ;
+: range ( min max -- parser )
+ range-parser boa init-parser ;
: seq ( seq -- parser )
- seq-parser construct-boa init-parser ;
+ seq-parser boa init-parser ;
: 2seq ( parser1 parser2 -- parser )
2array seq ;
{ } make seq ; inline
: choice ( seq -- parser )
- choice-parser construct-boa init-parser ;
+ choice-parser boa init-parser ;
: 2choice ( parser1 parser2 -- parser )
2array choice ;
: choice* ( quot -- paser )
{ } make choice ; inline
-MEMO: repeat0 ( parser -- parser )
- repeat0-parser construct-boa init-parser ;
+: repeat0 ( parser -- parser )
+ repeat0-parser boa init-parser ;
+
+: repeat1 ( parser -- parser )
+ repeat1-parser boa init-parser ;
-MEMO: repeat1 ( parser -- parser )
- repeat1-parser construct-boa init-parser ;
+: optional ( parser -- parser )
+ optional-parser boa init-parser ;
-MEMO: optional ( parser -- parser )
- optional-parser construct-boa init-parser ;
+: semantic ( parser quot -- parser )
+ semantic-parser boa init-parser ;
-MEMO: ensure ( parser -- parser )
- ensure-parser construct-boa init-parser ;
+: ensure ( parser -- parser )
+ ensure-parser boa init-parser ;
-MEMO: ensure-not ( parser -- parser )
- ensure-not-parser construct-boa init-parser ;
+: ensure-not ( parser -- parser )
+ ensure-not-parser boa init-parser ;
: action ( parser quot -- parser )
- action-parser construct-boa init-parser ;
+ action-parser boa init-parser ;
-MEMO: sp ( parser -- parser )
- sp-parser construct-boa init-parser ;
+: sp ( parser -- parser )
+ sp-parser boa init-parser ;
-MEMO: hide ( parser -- parser )
+: hide ( parser -- parser )
[ drop ignore ] action ;
-MEMO: delay ( quot -- parser )
- delay-parser construct-boa init-parser ;
+: delay ( quot -- parser )
+ delay-parser boa init-parser ;
+
+: box ( quot -- parser )
+ #! because a box has its quotation run at compile time
+ #! it must always have a new parser delgate created,
+ #! not a cached one. This is because the same box,
+ #! compiled twice can have a different compiled word
+ #! due to running at compile time.
+ #! Why the [ ] action at the end? Box parsers don't get
+ #! memoized during parsing due to all box parsers being
+ #! unique. This breaks left recursion detection during the
+ #! parse. The action adds an indirection with a parser type
+ #! that gets memoized and fixes this. Need to rethink how
+ #! to fix boxes so this isn't needed...
+ box-parser boa next-id f <parser> over set-delegate [ ] action ;
: PEG:
(:) [
[
- call compile
+ call compile [ compiled-parse ] curry
[ dup [ parse-result-ast ] [ "Parse failed" throw ] if ]
append define
] with-compilation-unit
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
-USING: kernel tools.test peg peg.pl0 ;
+USING: kernel tools.test peg peg.ebnf peg.pl0 multiline sequences ;
IN: peg.pl0.tests
-{ "abc" } [
- "abc" ident parse parse-result-ast
+{ t } [
+ "CONST foo = 1;" "block" \ pl0 rule parse parse-result-remaining empty?
] unit-test
-{ 55 } [
- "55abc" number parse parse-result-ast
+{ t } [
+ "VAR foo;" "block" \ pl0 rule parse parse-result-remaining empty?
] unit-test
+
+{ t } [
+ "VAR foo,bar , baz;" "block" \ pl0 rule parse parse-result-remaining empty?
+] unit-test
+
+{ t } [
+ "foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
+] unit-test
+
+{ t } [
+ "BEGIN foo := 5 END" "statement" \ pl0 rule parse parse-result-remaining empty?
+] unit-test
+
+{ t } [
+ "IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
+] unit-test
+
+{ t } [
+ "WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
+] unit-test
+
+{ t } [
+ "WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
+] unit-test
+
+{ t } [
+ "PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse parse-result-remaining empty?
+] unit-test
+
+{ t } [
+ <"
+VAR x, squ;
+
+PROCEDURE square;
+BEGIN
+ squ := x * x
+END;
+
+BEGIN
+ x := 1;
+ WHILE x <= 10 DO
+ BEGIN
+ CALL square;
+ x := x + 1;
+ END
+END.
+"> pl0 parse-result-remaining empty?
+] unit-test
+
+{ f } [
+ <"
+CONST
+ m = 7,
+ n = 85;
+
+VAR
+ x, y, z, q, r;
+
+PROCEDURE multiply;
+VAR a, b;
+
+BEGIN
+ a := x;
+ b := y;
+ z := 0;
+ WHILE b > 0 DO BEGIN
+ IF ODD b THEN z := z + a;
+ a := 2 * a;
+ b := b / 2;
+ END
+END;
+
+PROCEDURE divide;
+VAR w;
+BEGIN
+ r := x;
+ q := 0;
+ w := y;
+ WHILE w <= r DO w := 2 * w;
+ WHILE w > y DO BEGIN
+ q := 2 * q;
+ w := w / 2;
+ IF w <= r THEN BEGIN
+ r := r - w;
+ q := q + 1
+ END
+ END
+END;
+
+PROCEDURE gcd;
+VAR f, g;
+BEGIN
+ f := x;
+ g := y;
+ WHILE f # g DO BEGIN
+ IF f < g THEN g := g - f;
+ IF g < f THEN f := f - g;
+ END;
+ z := f
+END;
+
+BEGIN
+ x := m;
+ y := n;
+ CALL multiply;
+ x := 25;
+ y := 3;
+ CALL divide;
+ x := 84;
+ y := 36;
+ CALL gcd;
+END.
+ "> pl0 parse-result-remaining empty?
+] unit-test
\ No newline at end of file
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays strings math.parser sequences
-peg peg.ebnf peg.parsers memoize ;
+peg peg.ebnf peg.parsers memoize namespaces math ;
IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
-MEMO: ident ( -- parser )
- CHAR: a CHAR: z range
- CHAR: A CHAR: Z range 2array choice repeat1
- [ >string ] action ;
-MEMO: number ( -- parser )
- CHAR: 0 CHAR: 9 range repeat1 [ string>number ] action ;
+EBNF: pl0
+_ = (" " | "\t" | "\n")* => [[ drop ignore ]]
-<EBNF
-program = block '.' .
-block = [ 'const' ident '=' number { ',' ident '=' number } ';' ]
- [ 'var' ident { ',' ident } ';' ]
- { 'procedure' ident ';' [ block ';' ] } statement .
-statement = [ ident ':=' expression | 'call' ident |
- 'begin' statement {';' statement } 'end' |
- 'if' condition 'then' statement |
- 'while' condition 'do' statement ] .
-condition = 'odd' expression |
- expression ('=' | '#' | '<=' | '<' | '>=' | '>') expression .
-expression = ['+' | '-'] term {('+' | '-') term } .
-term = factor {('*' | '/') factor } .
-factor = ident | number | '(' expression ')'
-EBNF>
+BEGIN = "BEGIN" _
+CALL = "CALL" _
+CONST = "CONST" _
+DO = "DO" _
+END = "END" _
+IF = "IF" _
+THEN = "THEN" _
+ODD = "ODD" _
+PROCEDURE = "PROCEDURE" _
+VAR = "VAR" _
+WHILE = "WHILE" _
+EQ = "=" _
+LTEQ = "<=" _
+LT = "<" _
+GT = ">" _
+GTEQ = ">=" _
+NEQ = "#" _
+COMMA = "," _
+SEMICOLON = ";" _
+ASSIGN = ":=" _
+
+ADD = "+" _
+SUBTRACT = "-" _
+MULTIPLY = "*" _
+DIVIDE = "/" _
+
+LPAREN = "(" _
+RPAREN = ")" _
+
+block = ( CONST ident EQ number ( COMMA ident EQ number )* SEMICOLON )?
+ ( VAR ident ( COMMA ident )* SEMICOLON )?
+ ( PROCEDURE ident SEMICOLON ( block SEMICOLON )? )* statement
+statement = ( ident ASSIGN expression
+ | CALL ident
+ | BEGIN statement ( SEMICOLON statement )* END
+ | IF condition THEN statement
+ | WHILE condition DO statement )?
+condition = ODD expression
+ | expression (EQ | NEQ | LTEQ | LT | GTEQ | GT) expression
+expression = (ADD | SUBTRACT)? term ( (ADD | SUBTRACT) term )* _
+term = factor ( (MULTIPLY | DIVIDE) factor )*
+factor = ident | number | LPAREN expression RPAREN
+ident = (([a-zA-Z])+) _ => [[ >string ]]
+digit = ([0-9]) => [[ digit> ]]
+number = ((digit)+) _ => [[ 10 digits>integer ]]
+program = _ block "."
+;EBNF
{ [ 1 over consonant-end? not ] [ drop f ] }
{ [ 2 over consonant-end? ] [ drop f ] }
{ [ 3 over consonant-end? not ] [ drop f ] }
- { [ t ] [ "wxy" last-is? not ] }
+ [ "wxy" last-is? not ]
} cond ;
: r ( str oldsuffix newsuffix -- str )
{ [ "ies" ?tail ] [ "i" append ] }
{ [ dup "ss" tail? ] [ ] }
{ [ "s" ?tail ] [ ] }
- { [ t ] [ ] }
+ [ ]
} cond
] when ;
{
{ [ "ed" ?tail ] [ -ed ] }
{ [ "ing" ?tail ] [ -ing ] }
- { [ t ] [ f ] }
+ [ f ]
} cond
] [ -ed/ing ]
}
- { [ t ] [ ] }
+ [ ]
} cond ;
: step1c ( str -- newstr )
{ [ "iviti" ?tail ] [ "iviti" "ive" r ] }
{ [ "biliti" ?tail ] [ "biliti" "ble" r ] }
{ [ "logi" ?tail ] [ "logi" "log" r ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: step3 ( str -- newstr )
{ [ "ical" ?tail ] [ "ical" "ic" r ] }
{ [ "ful" ?tail ] [ "ful" "" r ] }
{ [ "ness" ?tail ] [ "ness" "" r ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: -ion ( str -- newstr )
{ [ "ous" ?tail ] [ ] }
{ [ "ive" ?tail ] [ ] }
{ [ "ize" ?tail ] [ ] }
- { [ t ] [ ] }
+ [ ]
} cond dup consonant-seq 1 > [ nip ] [ drop ] if ;
: remove-e? ( str -- ? )
{ [ dup peek CHAR: l = not ] [ ] }
{ [ dup length 1- over double-consonant? not ] [ ] }
{ [ dup consonant-seq 1 > ] [ butlast ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: step5 ( str -- newstr ) remove-e ll->l ;
--- /dev/null
+
+USING: kernel sequences ;
+
+IN: processing.color
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: rgba red green blue alpha ;
+
+C: <rgba> rgba
+
+: <rgb> ( r g b -- rgba ) 1 <rgba> ;
+
+: <gray> ( gray -- rgba ) dup dup 1 <rgba> ;
+
+: {rgb} ( seq -- rgba ) first3 <rgb> ;
+
+! : hex>rgba ( hex -- rgba )
+
+! : set-gl-color ( color -- )
+! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ;
+
--- /dev/null
+
+USING: kernel namespaces combinators
+ ui.gestures qualified accessors ui.gadgets.frame-buffer ;
+
+IN: processing.gadget
+
+QUALIFIED: ui.gadgets
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: processing-gadget button-down button-up key-down key-up ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: set-gadget-delegate ( tuple gadget -- tuple )
+ over ui.gadgets:set-gadget-delegate ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <processing-gadget> ( -- gadget )
+ processing-gadget new
+ <frame-buffer> set-gadget-delegate ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: mouse-pressed-value
+SYMBOL: key-pressed-value
+
+SYMBOL: button-value
+SYMBOL: key-value
+
+: key-pressed? ( -- ? ) key-pressed-value get ;
+: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
+
+: key ( -- key ) key-value get ;
+: button ( -- val ) button-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: processing-gadget handle-gesture* ( gadget gesture delegate -- ? )
+ rot drop swap ! delegate gesture
+ {
+ {
+ [ dup key-down? ]
+ [
+ key-down-sym key-value set
+ key-pressed-value on
+ key-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup key-up? ]
+ [
+ key-pressed-value off
+ drop
+ key-up>> dup [ call ] [ drop ] if
+ t
+ ] }
+ {
+ [ dup button-down? ]
+ [
+ button-down-# button-value set
+ mouse-pressed-value on
+ button-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup button-up? ]
+ [
+ mouse-pressed-value off
+ drop
+ button-up>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ { [ t ] [ 2drop t ] }
+ }
+ cond ;
\ No newline at end of file
--- /dev/null
+
+USING: kernel arrays sequences math qualified
+ sequences.lib circular processing ui newfx ;
+
+IN: processing.gallery.trails
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Example 33-15 from the Processing book
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point-list ( n -- seq ) [ drop 0 0 2array ] map <circular> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: dot ( pos percent -- ) 1 swap - 25 * 5 max circle ;
+
+: step ( seq -- )
+
+ no-stroke
+ { 1 0.4 } fill
+
+ 0 background
+
+ mouse push-circular
+ [ dot ]
+ each-percent ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: go* ( -- )
+
+ 500 500 size*
+
+ [
+ 100 point-list
+ [ step ]
+ curry
+ draw
+ ] setup
+
+ run ;
+
+: go ( -- ) [ go* ] with-ui ;
+
+MAIN: go
\ No newline at end of file
--- /dev/null
+
+USING: kernel namespaces threads combinators sequences arrays
+ math math.functions math.ranges random
+ opengl.gl opengl.glu vars multi-methods shuffle
+ ui
+ ui.gestures
+ ui.gadgets
+ combinators
+ combinators.lib
+ combinators.cleave
+ rewrite-closures fry accessors newfx
+ processing.color
+ processing.gadget ;
+
+IN: processing
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
+
+: 1random ( b -- num ) 0 swap 2random ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chance ( fraction -- ? ) 0 1 2random > ;
+
+: percent-chance ( percent -- ? ) 100 / chance ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
+
+: at-fraction ( seq fraction -- val ) over length 1- * at ;
+
+: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: fill-color
+VAR: stroke-color
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: set-color ( value -- )
+
+METHOD: set-color { number } dup dup glColor3d ;
+
+METHOD: set-color { array }
+ dup length
+ {
+ { 2 [ first2 >r dup dup r> glColor4d ] }
+ { 3 [ first3 glColor3d ] }
+ { 4 [ first4 glColor4d ] }
+ }
+ case ;
+
+METHOD: set-color { rgba }
+ { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave glColor4d ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: fill ( value -- ) >fill-color ;
+: stroke ( value -- ) >stroke-color ;
+
+: no-fill ( -- )
+ fill-color>
+ {
+ { [ dup number? ] [ 0 2array fill ] }
+ { [ t ]
+ [
+ [ drop 0 ] [ length 1- ] [ ] tri set-nth
+ ] }
+ }
+ cond ;
+
+: no-stroke ( -- )
+ stroke-color>
+ {
+ { [ dup number? ] [ 0 2array stroke ] }
+ { [ t ]
+ [
+ [ drop 0 ] [ length 1- ] [ ] tri set-nth
+ ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: stroke-weight ( w -- ) glLineWidth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: point* ( x y -- )
+ stroke-color> set-color
+ GL_POINTS glBegin
+ glVertex2d
+ glEnd ;
+
+: point ( seq -- ) first2 point* ;
+
+: line ( x1 y1 x2 y2 -- )
+ stroke-color> set-color
+ GL_LINES glBegin
+ glVertex2d
+ glVertex2d
+ glEnd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: triangle ( x1 y1 x2 y2 x3 y3 -- )
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ 6 ndup
+
+ GL_TRIANGLES glBegin
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glEnd
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> set-color
+
+ GL_TRIANGLES glBegin
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glEnd ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
+ GL_POLYGON glBegin
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glVertex2d
+ glEnd ;
+
+: quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
+
+ 8 ndup
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ quad-vertices
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> set-color
+
+ quad-vertices ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rect-vertices ( x y width height -- )
+ GL_POLYGON glBegin
+ [ 2drop glVertex2d ] 4keep
+ [ drop swap >r + 1- r> glVertex2d ] 4keep
+ [ >r swap >r + 1- r> r> + 1- glVertex2d ] 4keep
+ [ nip + 1- glVertex2d ] 4keep
+ 4drop
+ glEnd ;
+
+: rect ( x y width height -- )
+
+ 4dup
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ rect-vertices
+
+ GL_FRONT_AND_BACK GL_LINE glPolygonMode
+ stroke-color> set-color
+
+ rect-vertices ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ellipse-disk ( x y width height -- )
+ glPushMatrix
+ >r >r
+ 0 glTranslated
+ r> r> 1 glScaled
+ gluNewQuadric
+ dup 0 0.5 20 1 gluDisk
+ gluDeleteQuadric
+ glPopMatrix ;
+
+: ellipse-center ( x y width height -- )
+
+ 4dup
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ stroke-color> set-color
+
+ ellipse-disk
+
+ GL_FRONT_AND_BACK GL_FILL glPolygonMode
+ fill-color> set-color
+
+ [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
+
+ ellipse-disk ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: CENTER
+SYMBOL: RADIUS
+SYMBOL: CORNER
+SYMBOL: CORNERS
+
+SYMBOL: ellipse-mode-value
+
+: ellipse-mode ( val -- ) ellipse-mode-value set ;
+
+: ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
+
+: ellipse-corner ( x y width height -- )
+ [ drop nip 2 / + ] 4keep
+ [ nip rot drop 2 / + ] 4keep
+ [ >r >r 2drop r> r> ] 4keep
+ 4drop
+ ellipse-center ;
+
+: ellipse-corners ( x1 y1 x2 y2 -- )
+ [ drop nip + 2 / ] 4keep
+ [ nip rot drop + 2 / ] 4keep
+ [ drop nip - abs 1+ ] 4keep
+ [ nip rot drop - abs 1+ ] 4keep
+ 4drop
+ ellipse-center ;
+
+: ellipse ( a b c d -- )
+ ellipse-mode-value get
+ {
+ { CENTER [ ellipse-center ] }
+ { RADIUS [ ellipse-radius ] }
+ { CORNER [ ellipse-corner ] }
+ { CORNERS [ ellipse-corners ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: circle ( pos size -- ) [ first2 ] [ dup ] bi* ellipse ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: multi-methods ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: background ( value -- )
+
+METHOD: background { number }
+ dup dup 1 glClearColor
+ GL_COLOR_BUFFER_BIT glClear ;
+
+METHOD: background { array }
+ dup length
+ {
+ { 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ { 3 [ first3 1 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ { 4 [ first4 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
+ }
+ case ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: translate ( x y -- ) 0 glTranslated ;
+
+: rotate ( angle -- ) 0 0 1 glRotated ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mouse ( -- point ) hand-loc get ;
+
+: mouse-x mouse first ;
+: mouse-y mouse second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+VAR: frame-rate-value
+
+: frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! VAR: slate
+
+VAR: loop-flag
+
+: defaults ( -- )
+ 0.8 background
+ 0 >stroke-color
+ 1 >fill-color
+ CENTER ellipse-mode
+ 60 frame-rate ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: size-val
+
+: size ( seq -- ) size-val set ;
+
+: size* ( width height -- ) 2array size-val set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: setup-action
+SYMBOL: draw-action
+
+! : setup ( quot -- ) closed-quot setup-action set ;
+! : draw ( quot -- ) closed-quot draw-action set ;
+
+: setup ( quot -- ) setup-action set ;
+: draw ( quot -- ) draw-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: key-down-action
+SYMBOL: key-up-action
+
+: key-down ( quot -- ) closed-quot key-down-action set ;
+: key-up ( quot -- ) closed-quot key-up-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: button-down-action
+SYMBOL: button-up-action
+
+: button-down ( quot -- ) closed-quot button-down-action set ;
+: button-up ( quot -- ) closed-quot button-up-action set ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start-processing-thread ( -- )
+ loop-flag get not
+ [
+ loop-flag on
+ [
+ [ loop-flag get ]
+ processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
+ [ ]
+ while
+ ]
+ in-thread
+ ]
+ when ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: get-size ( -- size ) processing-gadget get rect-dim ;
+
+: width ( -- width ) get-size first ;
+: height ( -- height ) get-size second ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: setup-called
+
+: setup-called? ( -- ? ) setup-called get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run ( -- )
+
+ loop-flag off
+
+ 500 sleep
+
+ <processing-gadget>
+ size-val get >>dim
+ dup "Processing" open-window
+
+ 500 sleep
+
+ defaults
+
+ setup-called off
+
+ [
+ setup-called? not
+ [
+ setup-action get call
+ setup-called on
+ ]
+ [
+ draw-action get call
+ ]
+ if
+ ]
+ closed-quot >>action
+
+ key-down-action get >>key-down
+ key-up-action get >>key-up
+
+ button-down-action get >>button-down
+ button-up-action get >>button-up
+
+ processing-gadget set
+
+ start-processing-thread ;
\ No newline at end of file
: fib-upto* ( n -- seq )
0 1 [ pick over >= ] [ tuck + dup ] [ ] unfold 3nip
- 1 head-slice* { 0 1 } swap append ;
+ 1 head-slice* { 0 1 } prepend ;
: euler002a ( -- answer )
1000000 fib-upto* [ even? ] subset sum ;
! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math math.ranges project-euler.common sequences
- sorting ;
+ sorting sets ;
IN: project-euler.004
! http://projecteuler.net/index.php?section=problems&id=4
: abc ( p q -- triplet )
[
2dup * , ! a = p * q
- [ sq ] 2apply 2dup - 2 / , ! b = (p² - q²) / 2
+ [ sq ] bi@ 2dup - 2 / , ! b = (p² - q²) / 2
+ 2 / , ! c = (p² + q²) / 2
] { } make natural-sort ;
dup even? [ 2 / ] [ 3 * 1+ ] if ;
: longest ( seq seq -- seq )
- 2dup [ length ] 2apply > [ drop ] [ nip ] if ;
+ 2dup [ length ] bi@ > [ drop ] [ nip ] if ;
PRIVATE>
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math math.ranges project-euler.common sequences
- sorting ;
+ sorting sets ;
IN: project-euler.023
! http://projecteuler.net/index.php?section=problems&id=23
PRIVATE>
: euler023 ( -- answer )
- 20161 abundants-upto possible-sums source-023 seq-diff sum ;
+ 20161 abundants-upto possible-sums source-023 diff sum ;
! TODO: solution is still too slow, although it takes under 1 minute
: max-period ( seq -- elt n )
dup [ period-length ] map dup supremum
- over index [ swap nth ] curry 2apply ;
+ over index [ swap nth ] curry bi@ ;
PRIVATE>
: max-consecutive ( seq -- elt n )
dup [ first2 consecutive-primes ] map dup supremum
- over index [ swap nth ] curry 2apply ;
+ over index [ swap nth ] curry bi@ ;
PRIVATE>
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables kernel math.functions math.ranges project-euler.common
- sequences ;
+ sequences sets ;
IN: project-euler.029
! http://projecteuler.net/index.php?section=problems&id=29
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.functions
- math.parser math.ranges project-euler.common sequences ;
+ math.parser math.ranges project-euler.common sequences sets ;
IN: project-euler.032
! http://projecteuler.net/index.php?section=problems&id=32
10 99 [a,b] dup cartesian-product [ first2 < ] subset ;
: safe? ( ax xb -- ? )
- [ 10 /mod ] 2apply -roll = rot zero? not and nip ;
+ [ 10 /mod ] bi@ -roll = rot zero? not and nip ;
: ax/xb ( ax xb -- z/f )
- 2dup safe? [ [ 10 /mod ] 2apply 2nip / ] [ 2drop f ] if ;
+ 2dup safe? [ [ 10 /mod ] bi@ 2nip / ] [ 2drop f ] if ;
: curious? ( m n -- ? )
2dup / [ ax/xb ] dip = ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.combinatorics math.parser math.primes
- project-euler.common sequences sequences.lib ;
+ project-euler.common sequences sequences.lib sets ;
IN: project-euler.035
! http://projecteuler.net/index.php?section=problems&id=35
: possible? ( seq -- ? )
dup length 1 > [
- dup { 0 2 4 5 6 8 } swap seq-diff =
+ dup { 0 2 4 5 6 8 } swap diff =
] [
drop t
] if ;
: rotate ( seq n -- seq )
- cut* swap append ;
+ cut* prepend ;
: (circular?) ( seq n -- ? )
dup 0 > [
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.cleave combinators.lib kernel math math.ranges
+USING: arrays combinators.lib kernel math math.ranges
namespaces project-euler.common sequences ;
IN: project-euler.039
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.lib hashtables kernel math math.combinatorics math.parser
- math.ranges project-euler.common sequences sequences.lib sorting ;
+ math.ranges project-euler.common sequences sequences.lib sorting sets ;
IN: project-euler.043
! http://projecteuler.net/index.php?section=problems&id=43
dup first 2 tail* swap second 2 head = ;
: clean ( seq -- seq )
- [ unclip 1 head add* concat ] map [ all-unique? ] subset ;
+ [ unclip 1 head prefix concat ] map [ all-unique? ] subset ;
: add-missing-digit ( seq -- seq )
- dup natural-sort 10 seq-diff first add* ;
+ dup natural-sort 10 diff first prefix ;
: interesting-pandigitals ( -- seq )
17 candidates { 13 11 7 5 3 2 } [
dup 3 * 1- * 2 / ;
: sum-and-diff? ( m n -- ? )
- 2dup + -rot - [ pentagonal? ] 2apply and ;
+ 2dup + -rot - [ pentagonal? ] bi@ and ;
PRIVATE>
! See http://factorcode.org/license.txt for BSD license.
USING: arrays ascii assocs hashtables io.encodings.ascii io.files kernel math
math.parser namespaces sequences sequences.lib sequences.private sorting
- splitting strings ;
+ splitting strings sets ;
IN: project-euler.059
! http://projecteuler.net/index.php?section=problems&id=59
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators.cleave combinators.lib kernel math math.ranges
+USING: arrays combinators.lib kernel math math.ranges
namespaces project-euler.common sequences sequences.lib ;
IN: project-euler.075
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators kernel math sequences math.ranges locals ;
+IN: project-euler.076
+
+! http://projecteuler.net/index.php?section=problems&id=76
+
+! DESCRIPTION
+! -----------
+
+! How many different ways can one hundred be written as a
+! sum of at least two positive integers?
+
+! SOLUTION
+! --------
+
+! This solution uses dynamic programming and the following
+! recurence relation:
+
+! ways(0,_) = 1
+! ways(_,0) = 0
+! ways(n,i) = ways(n-i,i) + ways(n,i-1)
+
+<PRIVATE
+
+: init ( n -- table )
+ [1,b] [ 0 2array 0 ] H{ } map>assoc
+ 1 { 0 0 } pick set-at ;
+
+: use ( n i -- n i )
+ [ - dup ] keep min ; inline
+
+: ways ( n i table -- )
+ over zero? [
+ 3drop
+ ] [
+ [ [ 1- 2array ] dip at ]
+ [ [ use 2array ] dip at + ]
+ [ [ 2array ] dip set-at ] 3tri
+ ] if ;
+
+:: each-subproblem ( n quot -- )
+ n [1,b] [ dup [1,b] quot with each ] each ; inline
+
+PRIVATE>
+
+: (euler076) ( n -- m )
+ dup init
+ [ [ ways ] curry each-subproblem ]
+ [ [ dup 2array ] dip at 1- ] 2bi ;
+
+: euler076 ( -- m )
+ 100 (euler076) ;
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables io.files kernel math math.parser namespaces
-io.encodings.ascii sequences ;
+io.encodings.ascii sequences sets ;
IN: project-euler.079
! http://projecteuler.net/index.php?section=problems&id=79
] { } make ;
: find-source ( seq -- elt )
- dup values swap keys [ prune ] 2apply seq-diff
+ dup values swap keys [ prune ] bi@ diff
dup empty? [ "Topological sort failed" throw ] [ first ] if ;
: remove-source ( seq elt -- seq )
: topological-sort ( seq -- seq )
[ [ (topological-sort) ] { } make ] keep
- concat prune dupd seq-diff append ;
+ concat prune dupd diff append ;
: euler079 ( -- answer )
source-079 >edges topological-sort 10 digits>integer ;
! [ euler079 ] 100 ave-time
! 2 ms run / 0 ms GC ave time - 100 trials
-! TODO: prune and seq-diff are relatively slow; topological sort could be
+! TODO: prune and diff are relatively slow; topological sort could be
! cleaned up and generalized much better, but it works for this problem
MAIN: euler079
--- /dev/null
+USING: kernel sequences math.functions math ;
+IN: project-euler.100
+
+: euler100 ( -- n )
+ 1 1
+ [ dup dup 1- * 2 * 10 24 ^ <= ]
+ [ tuck 6 * swap - 2 - ] [ ] while nip ;
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.ranges sequences sequences.lib ;
+
+IN: project-euler.116
+
+! http://projecteuler.net/index.php?section=problems&id=116
+
+! DESCRIPTION
+! -----------
+
+! A row of five black square tiles is to have a number of its tiles replaced
+! with coloured oblong tiles chosen from red (length two), green (length
+! three), or blue (length four).
+
+! If red tiles are chosen there are exactly seven ways this can be done.
+! If green tiles are chosen there are three ways.
+! And if blue tiles are chosen there are two ways.
+
+! Assuming that colours cannot be mixed there are 7 + 3 + 2 = 12 ways of
+! replacing the black tiles in a row measuring five units in length.
+
+! How many different ways can the black tiles in a row measuring fifty units in
+! length be replaced if colours cannot be mixed and at least one coloured tile
+! must be used?
+
+! SOLUTION
+! --------
+
+! This solution uses a simple dynamic programming approach using the
+! following recurence relation
+
+! ways(n,_) = 0 | n < 0
+! ways(0,_) = 1
+! ways(n,i) = ways(n-i,i) + ways(n-1,i)
+! solution(n) = ways(n,1) - 1 + ways(n,2) - 1 + ways(n,3) - 1
+
+<PRIVATE
+
+: nth* ( n seq -- elt/0 )
+ [ length swap - 1- ] keep ?nth 0 or ;
+
+: next ( colortile seq -- )
+ [ nth* ] [ peek + ] [ push ] tri ;
+
+: ways ( length colortile -- permutations )
+ V{ 1 } clone [ [ next ] 2curry times ] keep peek 1- ;
+
+PRIVATE>
+
+: (euler116) ( length -- permutations )
+ 3 [1,b] [ ways ] with sigma ;
+
+: euler116 ( -- permutations )
+ 50 (euler116) ;
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math splitting sequences ;
+
+IN: project-euler.117
+
+! http://projecteuler.net/index.php?section=problems&id=117
+
+! DESCRIPTION
+! -----------
+
+! Using a combination of black square tiles and oblong tiles chosen
+! from: red tiles measuring two units, green tiles measuring three
+! units, and blue tiles measuring four units, it is possible to tile a
+! row measuring five units in length in exactly fifteen different ways.
+
+! How many ways can a row measuring fifty units in length be tiled?
+
+! SOLUTION
+! --------
+
+! This solution uses a simple dynamic programming approach using the
+! following recurence relation
+
+! ways(i) = 1 | i <= 0
+! ways(i) = ways(i-4) + ways(i-3) + ways(i-2) + ways(i-1)
+
+<PRIVATE
+
+: short ( seq n -- seq n )
+ over length min ;
+
+: next ( seq -- )
+ [ 4 short tail* sum ] keep push ;
+
+PRIVATE>
+
+: (euler117) ( n -- m )
+ V{ 1 } clone tuck [ next ] curry times peek ;
+
+: euler117 ( -- m )
+ 50 (euler117) ;
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions sequences sequences.lib ;
+
+IN: project-euler.148
+
+<PRIVATE
+
+: sum-1toN ( n -- sum )
+ dup 1+ * 2/ ; inline
+
+: >base7 ( x -- y )
+ [ dup 0 > ] [ 7 /mod ] [ ] unfold nip ;
+
+: (use-digit) ( prev x index -- next )
+ [ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;
+
+PRIVATE>
+
+: (euler148) ( x -- y )
+ >base7 0 [ (use-digit) ] reduce-index ;
+
+: euler148 ( -- y )
+ 10 9 ^ (euler148) ;
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences sequences.private locals hints ;
+IN: project-euler.150
+
+<PRIVATE
+
+! sequence helper functions
+
+: partial-sums ( seq -- sums )
+ 0 [ + ] accumulate swap suffix ; inline
+
+: (partial-sum-infimum) ( inf sum elt -- inf sum )
+ + [ min ] keep ; inline
+
+: partial-sum-infimum ( seq -- seq )
+ 0 0 rot [ (partial-sum-infimum) ] each drop ; inline
+
+: generate ( n quot -- seq )
+ [ drop ] swap compose map ; inline
+
+: map-infimum ( seq quot -- min )
+ [ min ] compose 0 swap reduce ; inline
+
+
+! triangle generator functions
+
+: next ( t -- new-t s )
+ 615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
+
+: sums-triangle ( -- seq )
+ 0 1000 [ 1+ [ next ] generate partial-sums ] map nip ;
+
+PRIVATE>
+
+:: (euler150) ( m -- n )
+ [let | table [ sums-triangle ] |
+ m [| x |
+ x 1+ [| y |
+ m x - [| z |
+ x z + table nth-unsafe
+ [ y z + 1+ swap nth-unsafe ]
+ [ y swap nth-unsafe ] bi -
+ ] map partial-sum-infimum
+ ] map-infimum
+ ] map-infimum
+ ] ;
+
+HINTS: (euler150) fixnum ;
+
+: euler150 ( -- n )
+ 1000 (euler150) ;
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences combinators kernel sequences.lib math assocs namespaces ;
+IN: project-euler.151
+
+SYMBOL: table
+
+: (pick-sheet) ( seq i -- newseq )
+ [
+ <=> sgn
+ {
+ { -1 [ ] }
+ { 0 [ 1- ] }
+ { 1 [ 1+ ] }
+ } case
+ ] curry map-index ;
+
+DEFER: (euler151)
+
+: pick-sheet ( seq i -- res )
+ 2dup swap nth dup zero? [
+ 3drop 0
+ ] [
+ [ (pick-sheet) (euler151) ] dip *
+ ] if ;
+
+: (euler151) ( x -- y )
+ table get [ {
+ { { 0 0 0 1 } [ 0 ] }
+ { { 0 0 1 0 } [ { 0 0 0 1 } (euler151) 1+ ] }
+ { { 0 1 0 0 } [ { 0 0 1 1 } (euler151) 1+ ] }
+ { { 1 0 0 0 } [ { 0 1 1 1 } (euler151) 1+ ] }
+ [ [ dup length [ pick-sheet ] with map sum ] [ sum ] bi / ]
+ } case ] cache ;
+
+: euler151 ( -- n )
+ [
+ H{ } clone table set
+ { 1 1 1 1 } (euler151)
+ ] with-scope ;
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs kernel math math.ranges sequences ;
+
+IN: project-euler.164
+
+! http://projecteuler.net/index.php?section=problems&id=164
+
+! DESCRIPTION
+! -----------
+
+! How many 20 digit numbers n (without any leading zero) exist such
+! that no three consecutive digits of n have a sum greater than 9?
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: next-keys ( key -- keys )
+ [ peek ] [ 10 swap sum - ] bi [ 2array ] with map ;
+
+: next-table ( assoc -- assoc )
+ H{ } clone swap
+ [ swap next-keys [ pick at+ ] with each ] assoc-each ;
+
+: init-table ( -- assoc )
+ 9 [1,b] [ 1array 1 ] H{ } map>assoc ;
+
+PRIVATE>
+
+: euler164 ( -- n )
+ init-table 19 [ next-table ] times values sum ;
{
{ [ dup 2 < ] [ drop 1 ] }
{ [ dup odd? ] [ 2/ fn ] }
- { [ t ] [ 2/ [ fn ] keep 1- fn + ] }
+ [ 2/ [ fn ] [ 1- fn ] bi + ]
} cond ;
: euler169 ( -- result )
{
{ [ dup integer? ] [ 1- 0 add-bits ] }
{ [ dup 1 < ] [ 1 over - / dupd compute 1 1 add-bits ] }
- { [ t ] [ [ 1 mod compute ] 2keep >integer 0 add-bits ] }
+ [ [ 1 mod compute ] 2keep >integer 0 add-bits ]
} cond ;
PRIVATE>
--- /dev/null
+USING: circular disjoint-set kernel math math.ranges
+ sequences sequences.lib ;
+IN: project-euler.186
+
+: (generator) ( k -- n )
+ dup sq 300007 * 200003 - * 100003 + 1000000 rem ;
+
+: <generator> ( -- lag )
+ 55 [1,b] [ (generator) ] map <circular> ;
+
+: advance ( lag -- )
+ [ { 0 31 } nths sum 1000000 rem ] keep push-circular ;
+
+: next ( lag -- n )
+ [ first ] [ advance ] bi ;
+
+: 2unless? ( x y ?quot quot -- )
+ >r 2keep rot [ 2drop ] r> if ; inline
+
+: (p186) ( generator counter unionfind -- counter )
+ 524287 over equiv-set-size 990000 <
+ [
+ pick [ next ] [ next ] bi
+ [ = ] [
+ pick equate
+ [ 1+ ] dip
+ ] 2unless? (p186)
+ ] [
+ drop nip
+ ] if ;
+
+: euler186 ( -- n )
+ <generator> 0 1000000 <disjoint-set> (p186) ;
+
+MAIN: euler186
--- /dev/null
+! Copyright (c) 2008 Eric Mertens
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences sequences.lib math math.functions math.ranges locals ;
+IN: project-euler.190
+
+! PROBLEM
+! -------
+
+! http://projecteuler.net/index.php?section=problems&id=190
+
+! Let Sm = (x1, x2, ... , xm) be the m-tuple of positive real numbers
+! with x1 + x2 + ... + xm = m for which Pm = x1 * x22 * ... * xmm is
+! maximised.
+
+! For example, it can be verified that [P10] = 4112 ([ ] is the integer
+! part function).
+
+! Find Σ[Pm] for 2 ≤ m ≤ 15.
+
+! SOLUTION
+! --------
+
+! Pm = x1 * x2^2 * x3^3 * ... * xm^m
+! fm = x1 + x2 + x3 + ... + xm - m = 0
+! Gm === Pm - L * fm
+! dG/dx_i = 0 = i * Pm / xi - L
+! xi = i * Pm / L
+
+! Sum(i=1 to m) xi = m
+! Sum(i=1 to m) i * Pm / L = m
+! Pm / L * Sum(i=1 to m) i = m
+! Pm / L * m*(m+1)/2 = m
+! Pm / L = 2 / (m+1)
+
+! xi = i * (2 / (m+1)) = 2*i/(m+1)
+
+<PRIVATE
+
+: PI ( seq quot -- n )
+ [ * ] compose 1 swap reduce ; inline
+
+PRIVATE>
+
+:: P_m ( m -- P_m )
+ m [1,b] [| i | 2 i * m 1+ / i ^ ] PI ;
+
+: euler190 ( -- n )
+ 2 15 [a,b] [ P_m truncate ] sigma ;
Aaron Schaefer
+Eric Mertens
: max-path ( triangle -- n )
dup length 1 > [
- 2 cut* first2 max-children [ + ] 2map add max-path
+ 2 cut* first2 max-children [ + ] 2map suffix max-path
] [
first first
] if ;
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
: propagate-all ( triangle -- newtriangle )
- reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap add ;
+ reverse [ first dup ] keep 1 tail [ propagate dup ] map nip reverse swap suffix ;
: sum-divisors ( n -- sum )
dup 4 < [ { 0 1 3 4 } nth ] [ (sum-divisors) ] if ;
number>string 3 CHAR: 0 pad-left ;
: solution-path ( n -- str/f )
- number>euler "project-euler." swap append
- vocab where dup [ first ?resource-path ] when ;
+ number>euler "project-euler." prepend
+ vocab where dup [ first ] when ;
PRIVATE>
: run-project-euler ( -- )
problem-prompt dup problem-solved? [
- dup number>euler "project-euler." swap append run
+ dup number>euler "project-euler." prepend run
"Answer: " swap dup number? [ number>string ] when append print
"Source: " swap solution-path append print
] [
TUPLE: promise quot forced? value ;
: promise ( quot -- promise )
- f f \ promise construct-boa ;
+ f f \ promise boa ;
: promise-with ( value quot -- promise )
curry promise ;
{ $description "Similar to " { $link POSTPONE: USE: } " but loads vocabulary with prefix." }
{ $examples { $code
"QUALIFIED: math\n1 2 math:+ ! ==> 3" } } ;
+
+HELP: QUALIFIED-WITH:
+{ $syntax "QUALIFIED-WITH: vocab prefix" }
+{ $description "Works like " { $link POSTPONE: QUALIFIED: } " but uses the specified prefix." }
+{ $examples { $code
+ "QUALIFIED-WITH: math m\n1 2 m:+ ! ==> 3" } } ;
+
+HELP: FROM:
+{ $syntax "FROM: vocab => words ... ;" }
+{ $description "Imports the specified words from vocab." }
+{ $examples { $code
+ "FROM: math.parser => bin> hex> ; ! imports only bin> and hex>" } } ;
+
+HELP: EXCLUDE:
+{ $syntax "EXCLUDE: vocab => words ... ;" }
+{ $description "Imports everything from vocab excluding the specified words" }
+{ $examples { $code
+ "EXCLUDE: math.parser => bin> hex> ; ! imports everythin but bin> and hex>" } } ;
+
+HELP: RENAME:
+{ $syntax "RENAME: word vocab => newname " }
+{ $description "Imports word from vocab, but renamed to newname." }
+{ $examples { $code
+ "RENAME: + math => -"
+ "2 3 - ! => 5" } } ;
+
: x 1 ;
IN: bar
: x 2 ;
+IN: baz
+: x 3 ;
+
QUALIFIED: foo
QUALIFIED: bar
-[ 1 2 2 ] [ foo:x bar:x x ] unit-test
+[ 1 2 3 ] [ foo:x bar:x x ] unit-test
+
+QUALIFIED-WITH: bar p
+[ 2 ] [ p:x ] unit-test
+
+RENAME: x baz => y
+[ 3 ] [ y ] unit-test
+
+FROM: baz => x ;
+[ 3 ] [ x ] unit-test
+
+EXCLUDE: bar => x ;
+[ 3 ] [ x ] unit-test
+
-USING: kernel sequences assocs parser vocabs namespaces
-vocabs.loader ;
+USING: kernel sequences assocs hashtables parser vocabs words namespaces
+vocabs.loader debugger sets ;
IN: qualified
-: define-qualified ( vocab-name -- )
- dup require
- dup vocab-words swap CHAR: : add
+: define-qualified ( vocab-name prefix-name -- )
+ [ load-vocab vocab-words ] [ CHAR: : suffix ] bi*
[ -rot >r append r> ] curry assoc-map
use get push ;
-
: QUALIFIED:
- scan define-qualified ; parsing
+ #! Syntax: QUALIFIED: vocab
+ scan dup define-qualified ; parsing
+
+: QUALIFIED-WITH:
+ #! Syntax: QUALIFIED-WITH: vocab prefix
+ scan scan define-qualified ; parsing
+
+: expect=> scan "=>" assert= ;
+
+: partial-vocab ( words name -- assoc )
+ dupd [
+ lookup [ "No such word: " swap append throw ] unless*
+ ] curry map zip ;
+
+: partial-vocab-ignoring ( words name -- assoc )
+ [ vocab-words keys diff ] keep partial-vocab ;
+
+: EXCLUDE:
+ #! Syntax: EXCLUDE: vocab => words ... ;
+ scan expect=>
+ ";" parse-tokens swap partial-vocab-ignoring use get push ; parsing
+
+: FROM:
+ #! Syntax: FROM: vocab => words... ;
+ scan expect=>
+ ";" parse-tokens swap partial-vocab use get push ; parsing
+
+: RENAME:
+ #! Syntax: RENAME: word vocab => newname
+ scan scan lookup [ "No such word" throw ] unless*
+ expect=>
+ scan associate use get push ; parsing
+
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math.constants ;
-IN: random-tester.databank
-
-: databank ( -- array )
- {
- ! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
- pi 1/0. -1/0. 0/0. [ ]
- f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
- C{ 2 2 } C{ 1/0. 1/0. }
- } ;
-
+++ /dev/null
-USING: compiler continuations io kernel math namespaces
-prettyprint quotations random sequences vectors
-compiler.units ;
-USING: random-tester.databank random-tester.safe-words ;
-IN: random-tester
-
-SYMBOL: errored
-SYMBOL: before
-SYMBOL: after
-SYMBOL: quot
-TUPLE: random-tester-error ;
-
-: setup-test ( #data #code -- data... quot )
- #! Variable stack effect
- >r [ databank random ] times r>
- [ drop \ safe-words get random ] map >quotation ;
-
-: test-compiler ! ( data... quot -- ... )
- errored off
- dup quot set
- datastack 1 head* before set
- [ call ] [ drop ] recover
- datastack after set
- clear
- before get [ ] each
- quot get [ compile-call ] [ errored on ] recover ;
-
-: do-test ! ( data... quot -- )
- .s flush test-compiler
- errored get [
- datastack after get 2dup = [
- 2drop
- ] [
- [ . ] each
- "--" print
- [ . ] each
- quot get .
- random-tester-error construct-empty throw
- ] if
- ] unless clear ;
-
-: random-test1 ( #data #code -- )
- setup-test do-test ;
-
-: random-test2 ( -- )
- 3 2 setup-test do-test ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel math sequences namespaces hashtables words
-arrays parser compiler syntax io prettyprint optimizer
-random math.constants math.functions layouts random-tester.utils ;
-IN: random-tester
-
-! Tweak me
-: max-length 15 ; inline
-: max-value 1000000000 ; inline
-
-! varying bit-length random number
-: random-bits ( n -- int )
- random 2 swap ^ random ;
-
-: random-seq ( -- seq )
- { [ ] { } V{ } "" } random
- [ max-length random [ max-value random , ] times ] swap make ;
-
-: random-string
- [ max-length random [ max-value random , ] times ] "" make ;
-
-: special-integers ( -- seq ) \ special-integers get ;
-[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
-{ } make \ special-integers set-global
-: special-floats ( -- seq ) \ special-floats get ;
-[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
-{ } make \ special-floats set-global
-: special-complexes ( -- seq ) \ special-complexes get ;
-[
- { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
- e , e neg , pi , pi neg ,
- 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
- pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
- e neg e neg rect> , e e rect> ,
-] { } make \ special-complexes set-global
-
-: random-fixnum ( -- fixnum )
- most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
-
-: random-bignum ( -- bignum )
- 400 random-bits first-bignum + 50% [ neg ] when ;
-
-: random-integer ( -- n )
- 50% [
- random-fixnum
- ] [
- 50% [ random-bignum ] [ special-integers get random ] if
- ] if ;
-
-: random-positive-integer ( -- int )
- random-integer dup 0 < [
- neg
- ] [
- dup 0 = [ 1 + ] when
- ] if ;
-
-: random-ratio ( -- ratio )
- 1000000000 dup [ random ] 2apply 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
-
-: random-float ( -- float )
- 50% [ random-ratio ] [ special-floats get random ] if
- 50%
- [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
- >float ;
-
-: random-number ( -- number )
- {
- [ random-integer ]
- [ random-ratio ]
- [ random-float ]
- } do-one ;
-
-: random-complex ( -- C )
- random-number random-number rect> ;
-
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: kernel namespaces sequences sorting vocabs ;
-USING: arrays assocs generic hashtables math math.intervals math.parser math.functions refs shuffle vectors words ;
-IN: random-tester.safe-words
-
-: ?-words
- {
- delegate
-
- /f
-
- bits>float bits>double
- float>bits double>bits
-
- >bignum >boolean >fixnum >float
-
- array? integer? complex? value-ref? ref? key-ref?
- interval? number?
- wrapper? tuple?
- [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? zero? assoc? curry? vector? callstack? ! clear 3.14 [ <vector> assoc? ] compile-1
- 2^ not
- ! arrays
- resize-array <array>
- ! assocs
- (assoc-stack)
- new-assoc
- assoc-like
- <hashtable>
- all-integers? (all-integers?) ! hangs?
- assoc-push-if
-
- (clone) assoc-clone-like ! SYMBOL: foo foo dup (clone) =
- } ;
-
-: bignum-words
- {
- next-power-of-2 (next-power-of-2)
- times
- hashcode hashcode*
- } ;
-
-: initialization-words
- {
- init-namespaces
- } ;
-
-: stack-words
- {
- dup
- drop 2drop 3drop
- roll -roll 2swap
-
- >r r>
- } ;
-
-: method-words
- {
- forget-word
- } ;
-
-: stateful-words
- {
- counter
- gensym
- } ;
-
-: foo-words
- {
- set-retainstack
- retainstack callstack
- datastack
- callstack>array
- } ;
-
-: exit-words
- {
- call-clear die
- } ;
-
-: bad-words ( -- array )
- [
- ?-words %
- bignum-words %
- initialization-words %
- stack-words %
- method-words %
- stateful-words %
- exit-words %
- foo-words %
- ] { } make ;
-
-: safe-words ( -- array )
- bad-words {
- "alists" "arrays" "assocs" ! "bit-arrays" "byte-arrays"
- ! "classes" "combinators" "compiler" "continuations"
- ! "core-foundation" "definitions" "documents"
- ! "float-arrays" "generic" "graphs" "growable"
- "hashtables" ! io.*
- "kernel" "math"
- "math.bitfields" "math.complex" "math.constants" "math.floats"
- "math.functions" "math.integers" "math.intervals" "math.libm"
- "math.parser" "math.ratios" "math.vectors"
- ! "namespaces" "quotations" "sbufs"
- ! "queues" "strings" "sequences"
- "vectors"
- ! "words"
- } [ words ] map concat seq-diff natural-sort ;
-
-safe-words \ safe-words set-global
-
-! foo dup (clone) = .
-! foo dup clone = .
-! f [ byte-array>bignum assoc-clone-like ] compile-1
-! 2 3.14 [ construct-empty number= ] compile-1
-! 3.14 [ <vector> assoc? ] compile-1
-! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1
-
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: arrays assocs combinators.lib continuations kernel
-math math.functions memoize namespaces quotations random sequences
-sequences.private shuffle ;
-IN: random-tester.utils
-
-: %chance ( n -- ? )
- 100 random > ;
-
-: 10% ( -- ? ) 10 %chance ;
-: 20% ( -- ? ) 20 %chance ;
-: 30% ( -- ? ) 30 %chance ;
-: 40% ( -- ? ) 40 %chance ;
-: 50% ( -- ? ) 50 %chance ;
-: 60% ( -- ? ) 60 %chance ;
-: 70% ( -- ? ) 70 %chance ;
-: 80% ( -- ? ) 80 %chance ;
-: 90% ( -- ? ) 90 %chance ;
-
-: call-if ( quot ? -- ) swap when ; inline
-
-: with-10% ( quot -- ) 10% call-if ; inline
-: with-20% ( quot -- ) 20% call-if ; inline
-: with-30% ( quot -- ) 30% call-if ; inline
-: with-40% ( quot -- ) 40% call-if ; inline
-: with-50% ( quot -- ) 50% call-if ; inline
-: with-60% ( quot -- ) 60% call-if ; inline
-: with-70% ( quot -- ) 70% call-if ; inline
-: with-80% ( quot -- ) 80% call-if ; inline
-: with-90% ( quot -- ) 90% call-if ; inline
-
-: random-key keys random ;
-: random-value [ random-key ] keep at ;
-
-: do-one ( seq -- ) random call ; inline
USING: kernel namespaces arrays quotations sequences assocs combinators
- mirrors math math.vectors random combinators.cleave macros bake ;
+ mirrors math math.vectors random macros bake ;
IN: random-weighted
+++ /dev/null
-Doug Coleman
--- /dev/null
+USING: kernel math tools.test namespaces random
+random.blum-blum-shub alien.c-types sequences splitting ;
+IN: blum-blum-shub.tests
+
+[ 887708070 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } clone random-32*
+] unit-test
+
+
+[ 887708070 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } clone [
+ 32 random-bits
+ little-endian? [ <uint> reverse *uint ] unless
+ ] with-random
+] unit-test
+
+[ 5726770047455156646 ] [
+ T{ blum-blum-shub f 590695557939 811977232793 } clone [
+ 64 random-bits
+ little-endian? [ <ulonglong> 4 group [ reverse ] map concat *ulonglong ] unless
+ ] with-random
+] unit-test
+
+[ 3716213681 ]
+[
+ 100 T{ blum-blum-shub f 200352954495 846054538649 } clone tuck [
+ random-32* drop
+ ] curry times
+ random-32*
+] unit-test
--- /dev/null
+USING: kernel math sequences namespaces
+math.miller-rabin combinators.lib
+math.functions accessors random ;
+IN: random.blum-blum-shub
+
+! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n
+! return low bit of x+1
+TUPLE: blum-blum-shub x n ;
+
+<PRIVATE
+
+: generate-bbs-primes ( numbits -- p q )
+ [ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
+
+: next-bbs-bit ( bbs -- bit )
+ [ [ x>> 2 ] [ n>> ] bi ^mod dup ] keep (>>x) 1 bitand ;
+
+PRIVATE>
+
+: <blum-blum-shub> ( numbits -- blum-blum-shub )
+ generate-bbs-primes *
+ [ find-relative-prime ] keep
+ blum-blum-shub boa ;
+
+M: blum-blum-shub random-32* ( bbs -- r )
+ 0 32 rot
+ [ next-bbs-bit swap 1 shift bitor ] curry times ;
--- /dev/null
+USING: kernel random math accessors random ;
+IN: random.dummy
+
+TUPLE: random-dummy i ;
+C: <random-dummy> random-dummy
+
+M: random-dummy seed-random ( seed obj -- )
+ (>>i) ;
+
+M: random-dummy random-32* ( obj -- r )
+ [ dup 1+ ] change-i drop ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: help.markup help.syntax math ;
+IN: random.mersenne-twister
+
+ARTICLE: "random-numbers" "Generating random integers"
+"The " { $vocab-link "random" } " vocabulary implements the ``Mersenne Twister'' pseudo-random number generator algorithm."
+! { $subsection init-random }
+{ $subsection (random) }
+{ $subsection random } ;
+
+ABOUT: "random-numbers"
+
+! HELP: init-random
+! { $values { "seed" integer } }
+! { $description "Initializes the random number generator with the given seed. This word is called on startup to initialize the random number generator with the current time." } ;
+
+HELP: (random)
+{ $values { "rand" "an integer between 0 and 2^32-1" } }
+{ $description "Generates a random 32-bit unsigned integer." } ;
+
+HELP: random
+{ $values { "seq" "a sequence" } { "elt" "a random element" } }
+{ $description "Outputs a random element of the sequence. If the sequence is empty, always outputs " { $link f } "." }
+{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ;
+
+HELP: big-random
+{ $values { "n" "an integer" } { "r" "a random integer" } }
+{ $description "Outputs an integer with n bytes worth of bits." } ;
+
+HELP: random-256
+{ $values { "r" "a random integer" } }
+{ $description "Outputs an random integer 256 bits in length." } ;
--- /dev/null
+USING: kernel math random namespaces random.mersenne-twister
+sequences tools.test ;
+IN: random.mersenne-twister.tests
+
+: check-random ( max -- ? )
+ dup >r random 0 r> between? ;
+
+[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test
+
+: make-100-randoms
+ [ 100 [ 100 random , ] times ] { } make ;
+
+: test-rng ( seed quot -- )
+ >r <mersenne-twister> r> with-random ;
+
+[ f ] [ 1234 [ make-100-randoms make-100-randoms = ] test-rng ] unit-test
+
+[ 1333075495 ] [
+ 0 [ 1000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng
+] unit-test
+
+[ 1575309035 ] [
+ 0 [ 10000 [ drop random-generator get random-32* drop ] each random-generator get random-32* ] test-rng
+] unit-test
+
+
+[ 3 ] [ 101 [ 3 random-bytes length ] test-rng ] unit-test
+[ 33 ] [ 101 [ 33 random-bytes length ] test-rng ] unit-test
+[ t ] [ 101 [ 100 random-bits log2 90 > ] test-rng ] unit-test
--- /dev/null
+! Copyright (C) 2005, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+! mersenne twister based on
+! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
+USING: arrays kernel math namespaces sequences system init
+accessors math.ranges random circular math.bitfields.lib
+combinators ;
+IN: random.mersenne-twister
+
+<PRIVATE
+
+TUPLE: mersenne-twister seq i ;
+
+: mt-n 624 ; inline
+: mt-m 397 ; inline
+: mt-a HEX: 9908b0df ; inline
+
+: calculate-y ( n seq -- y )
+ [ nth 32 mask-bit ]
+ [ [ 1+ ] [ nth ] bi* 31 bits ] 2bi bitor ; inline
+
+: (mt-generate) ( n seq -- next-mt )
+ [
+ calculate-y
+ [ 2/ ] [ odd? mt-a 0 ? ] bi bitxor
+ ] [
+ [ mt-m + ] [ nth ] bi*
+ ] 2bi bitxor ;
+
+: mt-generate ( mt -- )
+ [
+ mt-n swap seq>> [
+ [ (mt-generate) ] [ set-nth ] 2bi
+ ] curry each
+ ] [ 0 >>i drop ] bi ;
+
+: init-mt-formula ( i seq -- f(seq[i]) )
+ dupd nth dup -30 shift bitxor 1812433253 * + 1+ 32 bits ;
+
+: init-mt-rest ( seq -- )
+ mt-n 1- swap [
+ [ init-mt-formula ] [ >r 1+ r> set-nth ] 2bi
+ ] curry each ;
+
+: init-mt-seq ( seed -- seq )
+ 32 bits mt-n 0 <array> <circular>
+ [ set-first ] [ init-mt-rest ] [ ] tri ;
+
+: mt-temper ( y -- yt )
+ dup -11 shift bitxor
+ dup 7 shift HEX: 9d2c5680 bitand bitxor
+ dup 15 shift HEX: efc60000 bitand bitxor
+ dup -18 shift bitxor ; inline
+
+: next-index ( mt -- i )
+ dup i>> dup mt-n < [ nip ] [ drop mt-generate 0 ] if ;
+
+PRIVATE>
+
+: <mersenne-twister> ( seed -- obj )
+ init-mt-seq 0 mersenne-twister boa
+ dup mt-generate ;
+
+M: mersenne-twister seed-random ( mt seed -- )
+ init-mt-seq >>seq drop ;
+
+M: mersenne-twister random-32* ( mt -- r )
+ [ next-index ]
+ [ seq>> nth mt-temper ]
+ [ [ 1+ ] change-i drop ] tri ;
--- /dev/null
+Mersenne Twister random number generator
ARTICLE: "random-numbers" "Generating random integers"
"The " { $vocab-link "random" } " vocabulary implements the ``Mersenne Twister'' pseudo-random number generator algorithm."
-{ $subsection init-random }
-{ $subsection (random) }
{ $subsection random } ;
ABOUT: "random-numbers"
-HELP: init-random
-{ $values { "seed" integer } }
-{ $description "Initializes the random number generator with the given seed. This word is called on startup to initialize the random number generator with the current time." } ;
+HELP: seed-random
+{ $values { "tuple" "a random number generator" } { "seed" "an integer between 0 and 2^32-1" } }
+{ $description "Seed the random number generator." }
+{ $notes "Not supported on all random number generators." } ;
-HELP: (random)
-{ $values { "rand" "an integer between 0 and 2^32-1" } }
+HELP: random-32*
+{ $values { "tuple" "a random number generator" } { "r" "an integer between 0 and 2^32-1" } }
{ $description "Generates a random 32-bit unsigned integer." } ;
+HELP: random-bytes*
+{ $values { "n" "an integer" } { "tuple" "a random number generator" } { "byte-array" "a sequence of random bytes" } }
+{ $description "Generates a byte-array of random bytes." } ;
+
HELP: random
{ $values { "seq" "a sequence" } { "elt" "a random element" } }
{ $description "Outputs a random element of the sequence. If the sequence is empty, always outputs " { $link f } "." }
{ $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ;
-HELP: big-random
-{ $values { "n" "an integer" } { "r" "a random integer" } }
+HELP: random-bytes
+{ $values { "n" "an integer" } { "byte-array" "a random integer" } }
{ $description "Outputs an integer with n bytes worth of bits." } ;
-HELP: random-256
-{ $values { "r" "a random integer" } }
-{ $description "Outputs an random integer 256 bits in length." } ;
+HELP: random-bits
+{ $values { "n" "an integer" } { "r" "a random integer" } }
+{ $description "Outputs an random integer n bits in length." } ;
+
+HELP: with-random
+{ $values { "tuple" "a random generator" } { "quot" "a quotation" } }
+{ $description "Calls the quotation with the random generator in a dynamic variable. All random numbers will be generated using this random generator." } ;
+
+HELP: with-secure-random
+{ $values { "quot" "a quotation" } }
+{ $description "Calls the quotation with the secure random generator in a dynamic variable. All random numbers will be generated using this random generator." } ;
+
+{ with-random with-secure-random } related-words
-USING: kernel math random namespaces sequences tools.test ;
+USING: random sequences tools.test ;
IN: random.tests
-: check-random ( max -- ? )
- dup >r random 0 r> between? ;
+[ 4 ] [ 4 random-bytes length ] unit-test
+[ 7 ] [ 7 random-bytes length ] unit-test
-[ t ] [ 100 [ drop 674 check-random ] all? ] unit-test
-
-: make-100-randoms
- [ 100 [ 100 random , ] times ] { } make ;
-
-[ f ] [ make-100-randoms make-100-randoms = ] unit-test
-
-[ 1333075495 ] [ 0 init-random 1000 [ drop (random) drop ] each (random) ] unit-test
-[ 1575309035 ] [ 0 init-random 10000 [ drop (random) drop ] each (random) ] unit-test
+[ 4 ] [ [ 4 random-bytes length ] with-secure-random ] unit-test
+[ 7 ] [ [ 7 random-bytes length ] with-secure-random ] unit-test
-! Copyright (C) 2005, 2007 Doug Coleman.
+! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-
-! mersenne twister based on
-! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
-
-USING: arrays kernel math namespaces sequences
-system init alien.c-types ;
+USING: alien.c-types kernel math namespaces sequences
+io.backend io.binary combinators system vocabs.loader
+inspector ;
IN: random
-<PRIVATE
-
-TUPLE: mersenne-twister seed seq i ;
-
-C: <mersenne-twister> mersenne-twister
-
-: mt-n 624 ; inline
-: mt-m 397 ; inline
-: mt-a HEX: 9908b0df ; inline
-: mt-hi HEX: 80000000 ; inline
-: mt-lo HEX: 7fffffff ; inline
-
-SYMBOL: mt
-
-: mt-seq ( -- seq )
- mt get mersenne-twister-seq ; inline
-
-: mt-nth ( n -- nth )
- mt-seq nth ; inline
-
-: mt-i ( -- i )
- mt get mersenne-twister-i ; inline
-
-: mti-inc ( -- )
- mt get [ mersenne-twister-i 1+ ] keep set-mersenne-twister-i ; inline
+SYMBOL: system-random-generator
+SYMBOL: secure-random-generator
+SYMBOL: random-generator
-: set-mt-ith ( y i-get i-set -- )
- >r mt-nth >r
- [ 2/ ] keep odd? mt-a 0 ? r> bitxor bitxor r>
- mt-seq set-nth ; inline
+GENERIC: seed-random ( tuple seed -- )
+GENERIC: random-32* ( tuple -- r )
+GENERIC: random-bytes* ( n tuple -- byte-array )
-: mt-y ( y1 y2 -- y )
- mt-nth mt-lo bitand
- >r mt-nth mt-hi bitand r> bitor ; inline
+M: object random-bytes* ( n tuple -- byte-array )
+ swap [ drop random-32* ] with map >c-uint-array ;
-: mod* ( x n -- y )
- #! no floating point
- 2dup >= [ - ] [ drop ] if ; inline
+M: object random-32* ( tuple -- r ) 4 random-bytes* le> ;
-: (mt-generate) ( n -- y n n+(mt-m) )
- dup [ 1+ 624 mod* mt-y ] keep [ mt-m + 624 mod* ] keep ;
+ERROR: no-random-number-generator ;
-: mt-generate ( -- )
- mt-n [ (mt-generate) set-mt-ith ] each
- 0 mt get set-mersenne-twister-i ;
+M: no-random-number-generator summary
+ drop "Random number generator is not defined." ;
-: init-mt-first ( seed -- seq )
- >r mt-n 0 <array> r>
- HEX: ffffffff bitand 0 pick set-nth ;
+M: f random-bytes* ( n obj -- * ) no-random-number-generator ;
-: init-mt-formula ( seq i -- f(seq[i]) )
- dup rot nth dup -30 shift bitxor
- 1812433253 * + HEX: ffffffff bitand 1+ ; inline
+M: f random-32* ( obj -- * ) no-random-number-generator ;
-: init-mt-rest ( seq -- )
- mt-n 1 head* [
- [ init-mt-formula ] 2keep 1+ swap set-nth
- ] with each ;
-
-: mt-temper ( y -- yt )
- dup -11 shift bitxor
- dup 7 shift HEX: 9d2c5680 bitand bitxor
- dup 15 shift HEX: efc60000 bitand bitxor
- dup -18 shift bitxor ; inline
-
-PRIVATE>
-
-: init-random ( seed -- )
- global [
- dup init-mt-first
- [ init-mt-rest ] keep
- 0 <mersenne-twister> mt set
- mt-generate
- ] bind ;
-
-: (random) ( -- rand )
- global [
- mt-i dup mt-n < [ drop mt-generate 0 ] unless
- mt-nth mti-inc
- mt-temper
- ] bind ;
-
-: big-random ( n -- r )
- [ drop (random) ] map >c-uint-array byte-array>bignum ;
-
-: random-256 ( -- r ) 8 big-random ; inline
+: random-bytes ( n -- byte-array )
+ [
+ dup 4 rem zero? [ 1+ ] unless
+ random-generator get random-bytes*
+ ] keep head ;
: random ( seq -- elt )
dup empty? [
drop f
] [
[
- length dup log2 31 + 32 /i big-random swap mod
+ length dup log2 7 + 8 /i
+ random-bytes byte-array>bignum swap mod
] keep nth
] if ;
-[ millis init-random ] "random" add-init-hook
+: random-bits ( n -- r ) 2^ random ;
+
+: with-random ( tuple quot -- )
+ random-generator swap with-variable ; inline
+
+: with-system-random ( quot -- )
+ system-random-generator get swap with-random ; inline
+
+: with-secure-random ( quot -- )
+ secure-random-generator get swap with-random ; inline
+++ /dev/null
-Mersenne Twister random number generator
--- /dev/null
+USING: alien.c-types io io.files io.nonblocking kernel
+namespaces random io.encodings.binary init
+accessors system ;
+IN: random.unix
+
+TUPLE: unix-random path ;
+
+C: <unix-random> unix-random
+
+: file-read-unbuffered ( n path -- bytes )
+ over default-buffer-size [
+ binary <file-reader> [ read ] with-stream
+ ] with-variable ;
+
+M: unix-random random-bytes* ( n tuple -- byte-array )
+ path>> file-read-unbuffered ;
+
+os openbsd? [
+ [
+ "/dev/srandom" <unix-random> secure-random-generator set-global
+ "/dev/arandom" <unix-random> system-random-generator set-global
+ ] "random.unix" add-init-hook
+] [
+ [
+ "/dev/random" <unix-random> secure-random-generator set-global
+ "/dev/urandom" <unix-random> system-random-generator set-global
+ ] "random.unix" add-init-hook
+] if
--- /dev/null
+USING: accessors alien.c-types byte-arrays continuations
+kernel windows windows.advapi32 init namespaces random
+destructors locals ;
+USE: tools.walker
+IN: random.windows
+
+TUPLE: windows-rng provider type ;
+C: <windows-rng> windows-rng
+
+TUPLE: windows-crypto-context handle ;
+C: <windows-crypto-context> windows-crypto-context
+
+M: windows-crypto-context dispose ( tuple -- )
+ handle>> 0 CryptReleaseContext win32-error=0/f ;
+
+: factor-crypto-container ( -- string ) "FactorCryptoContainer" ; inline
+
+:: (acquire-crypto-context) ( provider type flags -- handle )
+ [let | handle [ "HCRYPTPROV" <c-object> ] |
+ handle
+ factor-crypto-container
+ provider
+ type
+ flags
+ CryptAcquireContextW win32-error=0/f
+ handle *void* ] ;
+
+: acquire-crypto-context ( provider type -- handle )
+ [ 0 (acquire-crypto-context) ]
+ [ drop CRYPT_NEWKEYSET (acquire-crypto-context) ] recover ;
+
+
+: windows-crypto-context ( provider type -- context )
+ acquire-crypto-context <windows-crypto-context> ;
+
+M: windows-rng random-bytes* ( n tuple -- bytes )
+ [
+ [ provider>> ] [ type>> ] bi
+ windows-crypto-context
+ dup add-always-destructor handle>>
+ swap dup <byte-array>
+ [ CryptGenRandom win32-error=0/f ] keep
+ ] with-destructors ;
+
+[
+ MS_DEF_PROV
+ PROV_RSA_FULL <windows-rng> system-random-generator set-global
+
+ MS_STRONG_PROV
+ PROV_RSA_FULL <windows-rng> secure-random-generator set-global
+
+ ! MS_ENH_RSA_AES_PROV
+ ! PROV_RSA_AES <windows-rng> secure-random-generator set-global
+] "random.windows" add-init-hook
USING: kernel namespaces threads sequences calendar
- combinators.cleave combinators.lib debugger ;
+ combinators.lib debugger ;
IN: raptor.cron
-USING: kernel namespaces threads arrays sequences combinators.cleave
+USING: kernel namespaces threads arrays sequences
raptor raptor.cron ;
IN: raptor
-USING: kernel parser namespaces threads arrays sequences unix unix.process
- combinators.cleave bake ;
+USING: kernel parser namespaces threads arrays sequences unix unix.process bake ;
IN: raptor
[ t ] [ "s@f" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
[ f ] [ "a" "[a-z.-]@[a-z]" f <regexp> matches? ] unit-test
[ t ] [ ".o" "\\.[a-z]" f <regexp> matches? ] unit-test
+
+! Bug in parsing word
+[ t ] [
+ "a"
+ R' a'
+ matches?
+] unit-test
: char-between?-quot ( ch1 ch2 -- quot )
ignore-case? get
- [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ]
+ [ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ]
[ [ between? ] ]
if 2curry ;
: or-predicates ( quots -- quot )
- [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
+ [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
: <@literal [ nip ] curry <@ ;
ignore-case? [
dup 'regexp' just parse-1
] with-variable
- ] keep regexp construct-boa ;
+ ] keep regexp boa ;
: do-ignore-case ( string regexp -- string regexp )
dup regexp-ignore-case? [ >r >upper r> ] when ;
} case ;
: parse-regexp ( accum end -- accum )
- lexer get dup skip-blank [
- [ index* dup 1+ swap ] 2keep swapd subseq swap
- ] change-column
- lexer get (parse-token) parse-options <regexp> parsed ;
+ lexer get dup skip-blank
+ [ [ index* dup 1+ swap ] 2keep swapd subseq swap ] change-lexer-column
+ lexer get dup still-parsing-line?
+ [ (parse-token) parse-options ] [ drop f ] if
+ <regexp> parsed ;
: R! CHAR: ! parse-regexp ; parsing
: R" CHAR: " parse-regexp ; parsing
: char-between?-quot ( ch1 ch2 -- quot )
ignore-case? get
- [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ]
+ [ [ ch>upper ] bi@ [ >r >r ch>upper r> r> between? ] ]
[ [ between? ] ]
if 2curry ;
: or-predicates ( quots -- quot )
- [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
+ [ \ dup prefix ] map [ [ t ] ] f short-circuit \ nip suffix ;
: literal-action [ nip ] curry action ;
USING: assocs math kernel shuffle combinators.lib\r
words quotations arrays combinators sequences math.vectors\r
-io.styles combinators.cleave prettyprint vocabs sorting io\r
-generic locals.private math.statistics ;\r
+io.styles prettyprint vocabs sorting io generic locals.private\r
+math.statistics ;\r
IN: reports.noise\r
\r
: badness ( word -- n )\r
{ -nrot 5 }\r
{ -roll 4 }\r
{ -rot 3 }\r
- { 2apply 1 }\r
+ { bi@ 1 }\r
{ 2curry 1 }\r
{ 2drop 1 }\r
{ 2dup 1 }\r
noise first2 {\r
{ [ over 4 <= ] [ >r drop 0 r> ] }\r
{ [ over 15 >= ] [ >r 2 * r> ] }\r
- { [ t ] [ ] }\r
+ [ ]\r
} cond\r
{\r
! short words are easier to read\r
{ [ dup 25 >= ] [ >r 2 * r> 20 max ] }\r
{ [ dup 20 >= ] [ >r 5/3 * r> ] }\r
{ [ dup 15 >= ] [ >r 3/2 * r> ] }\r
- { [ t ] [ ] }\r
+ [ ]\r
} cond noise-factor ;\r
\r
GENERIC: word-noise-factor ( word -- factor )\r
\r
: flatten-generics ( words -- words' )\r
[\r
- dup generic? [ methods values ] [ 1array ] if\r
+ dup generic? [ "methods" word-prop values ] [ 1array ] if\r
] map concat ;\r
\r
: noisy-words ( -- alist )\r
USING: assocs words sequences arrays compiler tools.time\r
io.styles io prettyprint vocabs kernel sorting generator\r
-optimizer math combinators.cleave ;\r
+optimizer math ;\r
IN: report.optimizer\r
\r
: count-optimization-passes ( nodes n -- n )\r
dup 1 3999 between? [
drop
] [
- roman-range-error construct-boa throw
+ roman-range-error boa throw
] if ;
: roman<= ( ch1 ch2 -- ? )
- [ 1string roman-digits index ] 2apply >= ;
+ [ 1string roman-digits index ] bi@ >= ;
: roman>n ( ch -- n )
1string roman-digits index roman-values nth ;
<PRIVATE
: 2roman> ( str1 str2 -- m n )
- [ roman> ] 2apply ;
+ [ roman> ] bi@ ;
: binary-roman-op ( str1 str2 quot -- str3 )
>r 2roman> r> call >roman ; inline
{
{ [ dup letter? ] [ CHAR: a rotate ] }
{ [ dup LETTER? ] [ CHAR: A rotate ] }
- { [ t ] [ ] }
+ [ ]
} cond ;
: rot13 ( string -- string ) [ rot-letter ] map ;
-USING: rss io kernel io.files tools.test io.encodings.utf8 ;
+USING: rss io kernel io.files tools.test io.encodings.utf8
+calendar ;
IN: rss.tests
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
- utf8 <file-reader> read-feed ;
+ utf8 file-contents read-feed ;
[ T{
feed
"http://example.org/2005/04/02/atom"
"\n <div xmlns=\"http://www.w3.org/1999/xhtml\">\n <p><i>[Update: The Atom draft is finished.]</i></p>\n </div>\n "
- "2003-12-13T08:29:29-04:00"
+ T{ timestamp f 2003 12 13 8 29 29 T{ duration f 0 0 0 -4 0 0 } }
}
}
} ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test
USING: xml.utilities kernel assocs xml.generator
strings sequences xml.data xml.writer
io.streams.string combinators xml xml.entities io.files io
- http.client namespaces xml.generator hashtables ;
-
-: ?children>string ( tag/f -- string/f )
- [ children>string ] [ f ] if* ;
+ http.client namespaces xml.generator hashtables
+ calendar.format accessors continuations ;
: any-tag-named ( tag names -- tag-inside )
f -rot [ tag-named nip dup ] with find 2drop ;
[ "link" tag-named children>string ] keep
[ "description" tag-named children>string ] keep
f "date" "http://purl.org/dc/elements/1.1/" <name>
- tag-named ?children>string
+ tag-named dup [ children>string rfc822>timestamp ] when
<entry> ;
: rss1.0 ( xml -- feed )
[ "link" tag-named ] keep
[ "guid" tag-named dupd ? children>string ] keep
[ "description" tag-named children>string ] keep
- "pubDate" tag-named children>string <entry> ;
+ "pubDate" tag-named children>string rfc822>timestamp <entry> ;
: rss2.0 ( xml -- feed )
"channel" tag-named
[ children>string ] if
] keep
{ "published" "updated" "issued" "modified" } any-tag-named
- children>string <entry> ;
+ children>string rfc3339>timestamp <entry> ;
: atom1.0 ( xml -- feed )
[ "title" tag-named children>string ] keep
{ "feed" [ atom1.0 ] }
} case ;
-: read-feed ( stream -- feed )
- [ read-xml ] with-html-entities xml>feed ;
+: read-feed ( string -- feed )
+ [ string>xml xml>feed ] with-html-entities ;
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
- http-get-stream rot success? [
- nip read-feed
- ] [
- 2drop "Error retrieving newsfeed file" throw
- ] if ;
+ http-get read-feed ;
! Atom generation
: simple-tag, ( content name -- )
"entry" [
dup entry-title "title" { { "type" "html" } } simple-tag*,
"link" over entry-link "href" associate contained*,
- dup entry-pub-date "published" simple-tag,
+ dup entry-pub-date timestamp>rfc3339 "published" simple-tag,
entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
] tag, ;
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors db.tuples hashtables kernel new-slots
+USING: accessors db.tuples hashtables kernel sets
semantic-db semantic-db.relations sequences sequences.deep ;
IN: semantic-db.hierarchy
"charlie" create-node* "charlie" set
"gertrude" create-node* "gertrude" set
[ t ] [ "adam" get "bob" get parent-child* integer? ] unit-test
- { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] 2apply parent-child ] each
+ { { "eve" "bob" } { "eve" "fran" } { "bob" "gertrude" } { "bob" "fran" } { "fran" "charlie" } } [ first2 [ get ] bi@ parent-child ] each
[ { "bob" "fran" } ] [ "eve" get children [ node-content ] map ] unit-test
[ { "adam" "eve" } ] [ "bob" get parents [ node-content ] map ] unit-test
[ "fran" { "charlie" } ] [ "fran" get get-node-hierarchy dup tree-id node-content swap tree-children [ tree-id node-content ] map ] unit-test
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser new-slots sequences ;
+USING: accessors arrays continuations db db.tuples db.types db.sqlite kernel math math.parser sequences ;
IN: semantic-db
TUPLE: node id content ;
: <node> ( content -- node )
- node construct-empty swap >>content ;
+ node new swap >>content ;
: <id-node> ( id -- node )
- node construct-empty swap >>id ;
+ node new swap >>id ;
node "node"
{
TUPLE: arc id relation subject object ;
: <arc> ( relation subject object -- arc )
- arc construct-empty swap >>object swap >>subject swap >>relation ;
+ arc new swap >>object swap >>subject swap >>relation ;
: <id-arc> ( id -- arc )
- arc construct-empty swap >>id ;
+ arc new swap >>id ;
: insert-arc ( arc -- )
f <node> dup insert-tuple id>> >>id insert-tuple ;
create-node-table create-arc-table create-bootstrap-nodes create-bootstrap-arcs ;
: param ( value key type -- param )
- swapd 3array ;
+ swapd <sqlite-low-level-binding> ;
: single-int-results ( bindings sql -- array )
f f <simple-statement> [ do-bound-query ] with-disposal
[ { { "foo" } "bar" } t ] [ { { "foo" } "bar" } [ array? ] deep-find* ] unit-test
: change-something ( seq -- newseq )
- dup array? [ "hi" add ] [ "hello" append ] if ;
+ dup array? [ "hi" suffix ] [ "hello" append ] if ;
[ { { "heyhello" "hihello" } "hihello" } ]
[ "hey" 1array 1array [ change-something ] deep-map ] unit-test
[ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test
[ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ]
[ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test
-[ f ] [ { } singleton? ] unit-test
-[ t ] [ { "asdf" } singleton? ] unit-test
-[ f ] [ { "asdf" "bsdf" } singleton? ] unit-test
[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
[ V{ } [ delete-random drop ] keep length ] must-fail
USING: combinators.lib kernel sequences math namespaces assocs
random sequences.private shuffle math.functions mirrors
arrays math.parser math.private sorting strings ascii macros
-assocs.lib quotations ;
+assocs.lib quotations hashtables ;
IN: sequences.lib
: each-withn ( seq quot n -- ) nwith each ; inline
#! quot: ( elt index -- obj )
prepare-index 2map ; inline
+: reduce-index ( seq identity quot -- )
+ #! quot: ( prev elt index -- next )
+ swapd each-index ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: each-percent ( seq quot -- )
+ >r
+ dup length
+ dup [ / ] curry
+ [ 1+ ] swap compose
+ r> compose
+ 2each ; inline
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: sigma ( seq quot -- n )
- [ rot slip + ] curry 0 swap reduce ; inline
+ [ + ] compose 0 swap reduce ; inline
: count ( seq quot -- n )
[ 1 0 ? ] compose sigma ; inline
: monotonic-split ( seq quot -- newseq )
[
- >r dup unclip add r>
+ >r dup unclip suffix r>
v, [ pick ,, call [ v, ] unless ] curry 2each ,v
] { } make ;
-: singleton? ( seq -- ? )
- length 1 = ;
-
: delete-random ( seq -- value )
[ length random ] keep [ nth ] 2keep delete-nth ;
[ find drop [ head-slice ] when* ] curry
[ dup ] swap compose keep like ;
+: replicate ( seq quot -- newseq )
+ #! quot: ( -- obj )
+ [ drop ] swap compose map ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
<PRIVATE
>r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ;
-: ?head* ( seq n -- seq/f ) (head) ?subseq ;
-: ?tail* ( seq n -- seq/f ) (tail) ?subseq ;
-
: accumulator ( quot -- quot vec )
V{ } clone [ [ push ] curry compose ] keep ; inline
: ?nth* ( n seq -- elt/f ? )
2dup bounds-check? [ nth-unsafe t ] [ 2drop f f ] if ; flushable
-: nths ( indices seq -- seq' )
- [ swap nth ] with map ;
+: nths ( seq indices -- seq' )
+ swap [ nth ] curry map ;
: replace ( str oldseq newseq -- str' )
- H{ } 2seq>assoc substitute ;
+ zip >hashtable substitute ;
+
+: remove-nth ( seq n -- seq' )
+ cut-slice 1 tail-slice append ;
+
+: short ( seq n -- seq n' )
+ over length min ; inline
--- /dev/null
+Non-core sequence words
: map-next ( seq quot -- newseq )
! quot: next-elt elt -- newelt
- over dup length swap new >r
+ over dup length swap new-sequence >r
iterate-seq [ (map-next) ] 2curry
r> [ collect ] keep ; inline
--- /dev/null
+Iteration with access to next element
! See http://factorcode.org/license.txt for BSD license.
!
USING: namespaces sequences kernel math io math.functions
-io.binary strings classes words sbufs tuples arrays vectors
-byte-arrays bit-arrays quotations hashtables assocs help.syntax
-help.markup float-arrays splitting io.streams.byte-array
-io.encodings.string io.encodings.utf8 io.encodings.binary
-combinators combinators.cleave new-slots accessors locals
-prettyprint compiler.units sequences.private tuples.private ;
+io.binary strings classes words sbufs classes.tuple arrays
+vectors byte-arrays bit-arrays quotations hashtables assocs
+help.syntax help.markup float-arrays splitting
+io.streams.byte-array io.encodings.string io.encodings.utf8
+io.encodings.binary combinators accessors locals prettyprint
+compiler.units sequences.private classes.tuple.private ;
IN: serialize
! Variable holding a assoc of objects already serialized
M: id hashcode* obj>> hashcode* ;
-M: id equal? over id? [ [ obj>> ] 2apply eq? ] [ 2drop f ] if ;
+M: id equal? over id? [ [ obj>> ] bi@ eq? ] [ 2drop f ] if ;
: add-object ( obj -- )
#! Add an object to the sequence of already serialized
read1 {
{ [ dup HEX: ff = ] [ drop deserialize-cell read be> ] }
{ [ dup HEX: 80 >= ] [ HEX: 80 bitxor ] }
- { [ t ] [ read be> ] }
+ [ read be> ]
} cond ;
: serialize-shared ( obj quot -- )
M: complex (serialize) ( obj -- )
CHAR: c write1
- dup real-part (serialize)
- imaginary-part (serialize) ;
+ [ real-part (serialize) ]
+ [ imaginary-part (serialize) ] bi ;
M: ratio (serialize) ( obj -- )
CHAR: r write1
- dup numerator (serialize)
- denominator (serialize) ;
+ [ numerator (serialize) ]
+ [ denominator (serialize) ] bi ;
: serialize-seq ( obj code -- )
[
M: quotation (serialize) ( obj -- )
[
- CHAR: q write1 [ >array (serialize) ] [ add-object ] bi
+ CHAR: q write1
+ [ >array (serialize) ] [ add-object ] bi
] serialize-shared ;
M: hashtable (serialize) ( obj -- )
{
{ [ dup t eq? ] [ serialize-true ] }
{ [ dup word-vocabulary not ] [ serialize-gensym ] }
- { [ t ] [ serialize-word ] }
+ [ serialize-word ]
} cond ;
M: wrapper (serialize) ( obj -- )
] if ;
: deserialize-gensym ( -- word )
- gensym
- dup intern-object
- dup (deserialize) define
- dup (deserialize) swap set-word-props ;
+ gensym {
+ [ intern-object ]
+ [ (deserialize) define ]
+ [ (deserialize) swap set-word-props ]
+ [ ]
+ } cleave ;
: deserialize-wrapper ( -- wrapper )
(deserialize) <wrapper> ;
:: (deserialize-seq) ( exemplar quot -- seq )
- deserialize-cell exemplar new
+ deserialize-cell exemplar new-sequence
[ intern-object ]
[ dup [ drop quot call ] change-each ] bi ; inline
[ ] tri ;
: copy-seq-to-tuple ( seq tuple -- )
- >r dup length [ 1+ ] map r> [ set-array-nth ] curry 2each ;
+ >r dup length r> [ set-array-nth ] curry 2each ;
: deserialize-tuple ( -- array )
#! Ugly because we have to intern the tuple before reading
#! slots
- (deserialize) construct-empty
+ (deserialize) new
[ intern-object ]
[
[ (deserialize) ]
--- /dev/null
+
+USING: kernel arrays strings sequences sequences.deep accessors peg peg.ebnf
+ newfx ;
+
+IN: shell.parser
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: basic-expr command stdin stdout background ;
+TUPLE: pipeline-expr commands stdin stdout background ;
+TUPLE: single-quoted-expr expr ;
+TUPLE: double-quoted-expr expr ;
+TUPLE: back-quoted-expr expr ;
+TUPLE: glob-expr expr ;
+TUPLE: variable-expr expr ;
+TUPLE: factor-expr expr ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ast>basic-expr ( ast -- obj ) first4 basic-expr boa ;
+
+: ast>pipeline-expr ( ast -- obj )
+ pipeline-expr new
+ over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
+ over 2nd >>stdin
+ over 5th >>stdout
+ swap 6th >>background ;
+
+: ast>single-quoted-expr ( ast -- obj )
+ 2nd >string single-quoted-expr boa ;
+
+: ast>double-quoted-expr ( ast -- obj )
+ 2nd >string double-quoted-expr boa ;
+
+: ast>back-quoted-expr ( ast -- obj )
+ 2nd >string back-quoted-expr boa ;
+
+: ast>glob-expr ( ast -- obj ) flatten concat glob-expr boa ;
+
+: ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ;
+
+: ast>factor-expr ( ast -- obj ) 2nd >string factor-expr boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+EBNF: expr
+
+space = " "
+
+tab = "\t"
+
+white = (space | tab)
+
+_ = (white)* => [[ drop ignore ]]
+
+sq = "'"
+dq = '"'
+bq = "`"
+
+single-quoted = sq (!(sq) .)* sq => [[ ast>single-quoted-expr ]]
+double-quoted = dq (!(dq) .)* dq => [[ ast>double-quoted-expr ]]
+back-quoted = bq (!(bq) .)* bq => [[ ast>back-quoted-expr ]]
+
+factor = "$(" (!(")") .)* ")" => [[ ast>factor-expr ]]
+
+variable = "$" other => [[ ast>variable-expr ]]
+
+glob-char = ("*" | "?")
+
+non-glob-char = !(glob-char | white) .
+
+glob-beginning-string = (non-glob-char)* => [[ >string ]]
+
+glob-rest-string = (non-glob-char)+ => [[ >string ]]
+
+glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ ast>glob-expr ]]
+
+other = (!(white | "&" | ">" | ">>" | "<" | "|") .)+ => [[ >string ]]
+
+element = (single-quoted | double-quoted | back-quoted | factor | variable | glob | other)
+
+command = (element _)+
+
+to-file = ">" _ other => [[ second ]]
+in-file = "<" _ other => [[ second ]]
+ap-file = ">>" _ other => [[ second ]]
+
+basic = _ command _ (in-file)? _ (to-file | ap-file)? _ ("&")? => [[ ast>basic-expr ]]
+
+pipeline = _ command _ (in-file)? _ "|" _ (command _ "|" _)* command _ (to-file | ap-file)? _ ("&")? => [[ ast>pipeline-expr ]]
+
+submission = (pipeline | basic)
+
+;EBNF
\ No newline at end of file
--- /dev/null
+
+USING: kernel parser words continuations namespaces debugger
+ sequences combinators splitting prettyprint
+ system io io.files io.launcher io.encodings.utf8 sequences.deep
+ accessors multi-methods newfx shell.parser ;
+
+IN: shell
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cd ( args -- )
+ dup empty?
+ [ drop home set-current-directory ]
+ [ first set-current-directory ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pwd ( args -- )
+ drop
+ current-directory get
+ print ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: swords ( -- seq ) { "cd" "pwd" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: expand ( expr -- expr )
+
+METHOD: expand { single-quoted-expr } expr>> ;
+
+METHOD: expand { double-quoted-expr } expr>> ;
+
+METHOD: expand { variable-expr } expr>> os-env ;
+
+METHOD: expand { glob-expr }
+ expr>>
+ dup "*" =
+ [ drop current-directory get directory [ first ] map ]
+ [ ]
+ if ;
+
+METHOD: expand { factor-expr } expr>> eval unparse ;
+
+DEFER: expansion
+
+METHOD: expand { back-quoted-expr }
+ expr>>
+ expr
+ ast>>
+ command>>
+ expansion
+ utf8 <process-stream>
+ contents
+ " \n" split
+ "" remove ;
+
+METHOD: expand { object } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: expansion ( command -- command ) [ expand ] map flatten ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-sword ( basic-expr -- )
+ command>> expansion unclip "shell" lookup execute ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-foreground ( process -- )
+ [ try-process ] [ print-error drop ] recover ;
+
+: run-background ( process -- ) run-detached drop ;
+
+: run-basic-expr ( basic-expr -- )
+ <process>
+ over command>> expansion >>command
+ over stdin>> >>stdin
+ over stdout>> >>stdout
+ swap background>>
+ [ run-background ]
+ [ run-foreground ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: basic-chant ( basic-expr -- )
+ dup command>> first swords member-of?
+ [ run-sword ]
+ [ run-basic-expr ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pipeline-chant ( pipeline-chant -- )
+ drop "ix: pipelines not supported" print ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chant ( obj -- )
+ dup basic-expr?
+ [ basic-chant ]
+ [ pipeline-chant ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prompt ( -- )
+ current-directory get write
+ " $ " write
+ flush ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: shell
+
+: handle ( input -- )
+ {
+ { [ dup f = ] [ drop ] }
+ { [ dup "exit" = ] [ drop ] }
+ { [ dup "" = ] [ drop shell ] }
+ { [ dup expr ] [ expr ast>> chant shell ] }
+ { [ t ] [ drop "ix: ignoring input" print shell ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: shell ( -- )
+ prompt
+ readln
+ handle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ix ( -- ) shell ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: ix
\ No newline at end of file
: put-effect ( word -- )
dup word-name "-" split1
- [ >array [ 1string ] map ] 2apply
+ [ >array [ 1string ] map ] bi@
<effect> "declared-effect" set-word-prop ;
: in-shuffle ( -- ) in get ".shuffle" append set-in ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: help.markup help.syntax kernel words ;
-IN: singleton
-
-HELP: SINGLETON:
-{ $syntax "SINGLETON: class"
-} { $values
- { "class" "a new singleton to define" }
-} { $description
- "Defines a new predicate class whose superclass is " { $link word } ". Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves. Methods may be defined on a singleton."
-} { $examples
- { $example "USING: singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
-} { $see-also
- POSTPONE: PREDICATE:
-} ;
-
-HELP: SINGLETONS:
-{ $syntax "SINGLETONS: classes... ;"
-} { $values
- { "classes" "new singletons to define" }
-} { $description
- "Defines a new singleton for each class in the list."
-} { $examples
- { $example "USE: singleton" "SINGLETONS: foo bar baz ;" "" }
-} { $see-also
- POSTPONE: SINGLETON:
-} ;
+++ /dev/null
-USING: kernel singleton tools.test ;
-IN: singleton.tests
-
-[ ] [ SINGLETON: bzzt ] unit-test
-[ t ] [ bzzt bzzt? ] unit-test
-[ t ] [ bzzt bzzt eq? ] unit-test
-GENERIC: zammo ( obj -- )
-[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
-[ "yes!" ] [ bzzt zammo ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes.predicate kernel namespaces parser quotations
-sequences words ;
-IN: singleton
-
-: define-singleton ( token -- )
- \ word swap create-class-in
- dup [ eq? ] curry define-predicate-class ;
-
-: SINGLETON:
- scan define-singleton ; parsing
-
-: SINGLETONS:
- ";" parse-tokens [ define-singleton ] each ; parsing
"220 OK\r\n" write flush t
] }
{ [ data-mode get ] [ dup global [ print ] bind t ] }
- { [ t ] [
+ [
"500 ERROR\r\n" write flush t
- ] }
+ ]
} cond nip [ process ] when ;
: mock-smtp-server ( port -- )
"Starting SMTP server on port " write dup . flush
"127.0.0.1" swap <inet4> ascii <server> [
- accept [
+ accept drop [
1 minutes stdio get set-timeout
"220 hello\r\n" write flush
process
assocs sorting ;
IN: smtp.tests
+[ t ] [
+ <email>
+ dup clone "a" "b" set-header drop
+ headers>> assoc-empty?
+] unit-test
+
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
[ "hello\nworld" validate-address ] must-fail
USING: namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings
math.parser random system calendar io.encodings.ascii
-calendar.format new-slots accessors ;
+calendar.format accessors sets ;
IN: smtp
SYMBOL: smtp-domain
-SYMBOL: smtp-server "localhost" 25 <inet> smtp-server set-global
+SYMBOL: smtp-server "localhost" "smtp" <inet> smtp-server set-global
SYMBOL: read-timeout 1 minutes read-timeout set-global
SYMBOL: esmtp t esmtp set-global
: crlf "\r\n" write ;
+: command ( string -- ) write crlf flush ;
+
: helo ( -- )
- esmtp get "EHLO " "HELO " ? write host-name write crlf ;
+ esmtp get "EHLO " "HELO " ? host-name append command ;
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
- dup "\r\n>" seq-intersect empty?
- [ "Bad e-mail address: " swap append throw ] unless ;
+ dup "\r\n>" intersect empty?
+ [ "Bad e-mail address: " prepend throw ] unless ;
: mail-from ( fromaddr -- )
- "MAIL FROM:<" write validate-address write ">" write crlf ;
+ "MAIL FROM:<" swap validate-address ">" 3append command ;
: rcpt-to ( to -- )
- "RCPT TO:<" write validate-address write ">" write crlf ;
+ "RCPT TO:<" swap validate-address ">" 3append command ;
: data ( -- )
- "DATA" write crlf ;
+ "DATA" command ;
: validate-message ( msg -- msg' )
"." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
string-lines
validate-message
[ write crlf ] each
- "." write crlf ;
+ "." command ;
: quit ( -- )
- "QUIT" write crlf ;
+ "QUIT" command ;
LOG: smtp-response DEBUG
{ [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
{ [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
{ [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
- { [ t ] [ "unknown error" throw ] }
+ [ "unknown error" throw ]
} cond ;
: multiline? ( response -- boolean )
readln
dup multiline? [ 3 head process-multiline ] when ;
-: get-ok ( -- ) flush receive-response check-response ;
+: get-ok ( -- ) receive-response check-response ;
: validate-header ( string -- string' )
- dup "\r\n" seq-intersect empty?
- [ "Invalid header string: " swap append throw ] unless ;
+ dup "\r\n" intersect empty?
+ [ "Invalid header string: " prepend throw ] unless ;
: write-header ( key value -- )
swap
TUPLE: email from to subject headers body ;
M: email clone
- (clone) [ clone ] change-headers ;
+ call-next-method [ clone ] change-headers ;
: (send) ( email -- )
[
: message-id ( -- string )
[
"<" %
- 2 big-random #
+ 64 random-bits #
"-" %
millis #
"@" %
dup to>> ", " join "To" set-header
[ [ extract-email ] map ] change-to
dup subject>> "Subject" set-header
- now timestamp>rfc822-string "Date" set-header
+ now timestamp>rfc822 "Date" set-header
message-id "Message-Id" set-header ;
: <email> ( -- email )
- email construct-empty
+ email new
H{ } clone >>headers ;
: send-email ( email -- )
! : (cram-md5-auth) ( -- response )
! swap challenge get
! string>md5-hmac hex-string
-! " " swap append append
+! " " prepend append
! >base64 ;
!
! : cram-md5-auth ( key login -- )
{ [ dup 184 238 within pick 0 223 within and ] [ 2drop green ] }
{ [ dup 240 247 within pick 16 133 within and ] [ 2drop green ] }
{ [ dup 247 215 - 247 184 - within pick 0 223 within and ] [ 2drop red ] }
- { [ t ] [ 2drop white ] }
+ [ 2drop white ]
} cond ;
: plot-bitmap-bits ( bitmap point byte bit -- )
USING: kernel combinators sequences arrays math math.vectors
- combinators.cleave shuffle vars ;
+ shuffle vars ;
IN: springies
6 nrot 6 nrot 2array
5 nrot 5 nrot 2array
0 0 2array <node>
- nodes> swap add >nodes ;
+ nodes> swap suffix >nodes ;
: spng ( id id-a id-b k damp rest-length -- )
6 nrot drop
5 nrot node-id
5 nrot node-id
<spring>
- springs> swap add >springs ;
+ springs> swap suffix >springs ;
-USING: kernel namespaces threads sequences math math.vectors combinators.cleave
+USING: kernel namespaces threads sequences math math.vectors
opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
bake rewrite-closures vars springies ;
! STATES: set-name state1 state2 ... ;
";" parse-tokens
[ length ] keep
- unclip add
+ unclip suffix
[ create-in swap 1quotation define ] 2each ; parsing
TUPLE: state place data ;
TUPLE: missing-state ;
-: missing-state \ missing-state construct-empty throw ;
+: missing-state \ missing-state new throw ;
M: missing-state error.
drop "Missing state" print ;
! * Errors\r
TUPLE: parsing-error line column ;\r
: <parsing-error> ( -- parsing-error )\r
- get-line get-column parsing-error construct-boa ;\r
+ get-line get-column parsing-error boa ;\r
\r
: construct-parsing-error ( ... slots class -- error )\r
construct <parsing-error> over set-delegate ; inline\r
#! advance spot to after the substring.\r
[ [\r
dup slip swap dup [ get-char , ] unless\r
- ] skip-until ] "" make nip ;\r
+ ] skip-until ] "" make nip ; inline\r
\r
: rest ( -- string )\r
[ f ] take-until ;\r
: >Upper ( str -- str )
dup empty? [
- unclip ch>upper 1string swap append
+ unclip ch>upper 1string prepend
] unless ;
: >Upper-dashes ( str -- str )
USING: tools.deploy.config ;
H{
+ { deploy-word-defs? f }
+ { deploy-random? f }
{ deploy-name "Sudoku" }
{ deploy-threads? f }
- { deploy-c-types? f }
{ deploy-compiler? t }
- { deploy-ui? f }
{ deploy-math? f }
- { deploy-reflection 1 }
- { deploy-word-defs? f }
+ { deploy-c-types? f }
{ deploy-io 2 }
- { deploy-word-props? f }
+ { deploy-reflection 1 }
+ { deploy-ui? f }
{ "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
! Based on http://www.ffconsultancy.com/ocaml/sudoku/index.html
USING: sequences namespaces kernel math math.parser io
-io.styles combinators ;
+io.styles combinators columns ;
IN: sudoku
SYMBOL: solutions
: cell-contains? ( n x y i -- ? ) 3 /mod pair+ board> = ;
: box-contains? ( n x y -- ? )
- [ 3 /i 3 * ] 2apply
+ [ 3 /i 3 * ] bi@
9 [ >r 3dup r> cell-contains? ] contains?
>r 3drop r> ;
{ [ 3dup nip row-contains? ] [ 3drop ] }
{ [ 3dup drop col-contains? ] [ 3drop ] }
{ [ 3dup box-contains? ] [ 3drop ] }
- { [ t ] [ assume ] }
+ [ assume ]
} cond ;
: solve ( x y -- ) 9 [ 1+ 2over attempt ] each 2drop ;
{ [ over 9 = ] [ >r drop 0 r> 1+ search ] }
{ [ over 0 = over 9 = and ] [ 2drop solution. ] }
{ [ 2dup board> ] [ >r 1+ r> search ] }
- { [ t ] [ solve ] }
+ [ solve ]
} cond ;
: sudoku ( board -- )
USING: combinators io io.files io.streams.duplex
io.streams.string kernel math math.parser continuations
namespaces pack prettyprint sequences strings system
-hexdump io.encodings.binary ;
+hexdump io.encodings.binary inspector accessors ;
IN: tar
: zero-checksum 256 ;
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
-: <tar-header> ( -- obj ) tar-header construct-empty ;
+: <tar-header> ( -- obj ) tar-header new ;
: tar-trim ( seq -- newseq )
[ "\0 " member? ] trim ;
: header-checksum ( seq -- x )
148 cut-slice 8 tail-slice
- [ sum ] 2apply + 256 + ;
+ [ sum ] bi@ + 256 + ;
TUPLE: checksum-error ;
TUPLE: malformed-block-error ;
: parse-tar-header ( seq -- obj )
[ header-checksum ] keep over zero-checksum = [
2drop
- \ tar-header construct-empty
+ \ tar-header new
0 over set-tar-header-size
0 over set-tar-header-checksum
] [
[ read-tar-header ] with-string-reader
[ tar-header-checksum = [
- \ checksum-error construct-empty throw
+ \ checksum-error new throw
] unless
] keep
] if ;
-TUPLE: unknown-typeflag str ;
-: <unknown-typeflag> ( ch -- obj )
- 1string \ unknown-typeflag construct-boa ;
+ERROR: unknown-typeflag ch ;
+M: unknown-typeflag summary ( obj -- str )
+ ch>> 1string
+ "Unknown typeflag: " prepend ;
-TUPLE: unimplemented-typeflag header ;
-: <unimplemented-typeflag> ( header -- obj )
- global [ "Unimplemented typeflag: " print dup . flush ] bind
- tar-header-typeflag
- 1string \ unimplemented-typeflag construct-boa ;
-
-: tar-path+ ( path -- newpath )
- base-dir get swap path+ ;
+: tar-append-path ( path -- newpath )
+ base-dir get prepend-path ;
! Normal file
: typeflag-0
- tar-header-name tar-path+ binary <file-writer>
+ name>> tar-append-path binary <file-writer>
[ read-data-blocks ] keep dispose ;
! Hard link
-: typeflag-1 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-1 ( header -- ) unknown-typeflag ;
! Symlink
-: typeflag-2 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-2 ( header -- ) unknown-typeflag ;
! character special
-: typeflag-3 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-3 ( header -- ) unknown-typeflag ;
! Block special
-: typeflag-4 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-4 ( header -- ) unknown-typeflag ;
! Directory
: typeflag-5 ( header -- )
- tar-header-name tar-path+ make-directories ;
+ tar-header-name tar-append-path make-directories ;
! FIFO
-: typeflag-6 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-6 ( header -- ) unknown-typeflag ;
! Contiguous file
-: typeflag-7 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-7 ( header -- ) unknown-typeflag ;
! Global extended header
-: typeflag-8 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-8 ( header -- ) unknown-typeflag ;
! Extended header
-: typeflag-9 ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-9 ( header -- ) unknown-typeflag ;
! Global POSIX header
-: typeflag-g ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-g ( header -- ) unknown-typeflag ;
! Extended POSIX header
-: typeflag-x ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-x ( header -- ) unknown-typeflag ;
! Solaris access control list
-: typeflag-A ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-A ( header -- ) unknown-typeflag ;
! GNU dumpdir
-: typeflag-D ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-D ( header -- ) unknown-typeflag ;
! Solaris extended attribute file
-: typeflag-E ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-E ( header -- ) unknown-typeflag ;
! Inode metadata
-: typeflag-I ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-I ( header -- ) unknown-typeflag ;
! Long link name
-: typeflag-K ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-K ( header -- ) unknown-typeflag ;
! Long file name
: typeflag-L ( header -- )
<string-writer> [ read-data-blocks ] keep
>string [ zero? ] right-trim filename set
global [ "long filename: " write filename get . flush ] bind
- filename get tar-path+ make-directories ;
+ filename get tar-append-path make-directories ;
! Multi volume continuation entry
-: typeflag-M ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-M ( header -- ) unknown-typeflag ;
! GNU long file name
-: typeflag-N ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-N ( header -- ) unknown-typeflag ;
! Sparse file
-: typeflag-S ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-S ( header -- ) unknown-typeflag ;
! Volume header
-: typeflag-V ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-V ( header -- ) unknown-typeflag ;
! Vendor extended header type
-: typeflag-X ( header -- )
- <unimplemented-typeflag> throw ;
+: typeflag-X ( header -- ) unknown-typeflag ;
: (parse-tar) ( -- )
512 read
{ CHAR: S [ typeflag-S ] }
{ CHAR: V [ typeflag-V ] }
{ CHAR: X [ typeflag-X ] }
- [ <unknown-typeflag> throw ]
+ [ unknown-typeflag ]
} case
! dup tar-header-size zero? [
! out-stream get [ dispose ] when
! drop
! ] [
! dup tar-header-name
- ! dup parent-dir base-dir swap path+
+ ! dup parent-dir base-dir prepend-path
! global [ dup [ . flush ] when* ] bind
! make-directories <file-writer>
! out-stream set
: parse-tar ( path -- obj )
binary [
- "tar-test" resource-path base-dir set
+ "resource:tar-test" base-dir set
global [ nl nl nl "Starting to parse .tar..." print flush ] bind
global [ "Expanding to: " write base-dir get . flush ] bind
(parse-tar)
TUPLE: tax-table single married ;
: <tax-table> ( single married class -- obj )
- >r tax-table construct-boa r> construct-delegate ;
+ >r tax-table boa r> construct-delegate ;
: tax-bracket-range dup second swap first - ;
[ drop f <array> ] with map ;
: <board> ( width height -- board )
- 2dup make-rows board construct-boa ;
+ 2dup make-rows board boa ;
#! A block is simply an array of form { x y } where { 0 0 } is the top-left of
#! the tetris board, and { 9 19 } is the bottom right on a 10x20 board.
: add-row ( board -- )
dup board-rows over board-width f <array>
- add* swap set-board-rows ;
+ prefix swap set-board-rows ;
: top-up-rows ( board -- )
dup board-height over board-rows length = [
! See http://factorcode.org/license.txt for BSD license.
USING: kernel words parser io inspector quotations sequences
prettyprint continuations effects definitions compiler.units
-namespaces assocs tools.walker ;
+namespaces assocs tools.walker generic ;
IN: tools.annotations
-: reset ( word -- )
+GENERIC: reset ( word -- )
+
+M: generic reset
+ [ call-next-method ]
+ [ subwords [ reset ] each ] bi ;
+
+M: word reset
dup "unannotated-def" word-prop [
[
dup dup "unannotated-def" word-prop define
: watch-vars ( word vars -- )
dupd [ (watch-vars) ] 2curry annotate ;
+GENERIC# annotate-methods 1 ( word quot -- )
+
+M: generic annotate-methods
+ >r "methods" word-prop values r> [ annotate ] curry each ;
+
+M: word annotate-methods
+ annotate ;
+
: breakpoint ( word -- )
- [ add-breakpoint ] annotate ;
+ [ add-breakpoint ] annotate-methods ;
: breakpoint-if ( word quot -- )
- [ [ [ break ] when ] rot 3append ] curry annotate ;
+ [ [ [ break ] when ] rot 3append ] curry annotate-methods ;
{ [ 2dup length 1- number= ] [ 2drop 4 ] }
{ [ 2dup >r 1- r> nth Letter? not ] [ 2drop 10 ] }
{ [ 2dup >r 1+ r> nth Letter? not ] [ 2drop 4 ] }
- { [ t ] [ 2drop 1 ] }
+ [ 2drop 1 ]
} cond ;
: score ( full fuzzy -- n )
dup [
- [ [ length ] 2apply - 15 swap [-] 3 /f ] 2keep
+ [ [ length ] bi@ - 15 swap [-] 3 /f ] 2keep
runs [
[ 0 [ pick score-1 max ] reduce nip ] keep
length * +
: complete ( full short -- score )
[ dupd fuzzy score ] 2keep
- [ <reversed> ] 2apply
+ [ <reversed> ] bi@
dupd fuzzy score max ;
: completion ( short candidate -- result )
quotations io.launcher words.private tools.deploy.config
bootstrap.image io.encodings.utf8 accessors ;
IN: tools.deploy.backend
+
+: copy-vm ( executable bundle-name extension -- vm )
+ [ prepend-path ] dip append vm over copy-file ;
+
+: copy-fonts ( name dir -- )
+ append-path "fonts/" resource-path swap copy-tree-into ;
+
+: image-name ( vocab bundle-name -- str )
+ prepend-path ".image" append ;
: (copy-lines) ( stream -- )
dup stream-readln dup
swap >>command
+stdout+ >>stderr
+closed+ >>stdin
- utf8 <process-stream>
- dup copy-lines
- process>> wait-for-process zero? [
+ +low-priority+ >>priority
+ utf8 <process-stream*>
+ >r copy-lines r> wait-for-process zero? [
"Deployment failed" throw
] unless ;
"compiler" deploy-compiler? get ?,
"ui" deploy-ui? get ?,
"io" native-io? ?,
+ "random" deploy-random? get ?,
] { } make ;
-: staging-image-name ( -- name )
+: staging-image-name ( profile -- name )
"staging."
- bootstrap-profile strip-word-names? [ "strip" add ] when
- "-" join ".image" 3append ;
+ swap strip-word-names? [ "strip" suffix ] when
+ "-" join ".image" 3append temp-file ;
-: staging-command-line ( config -- flags )
+DEFER: ?make-staging-image
+
+: staging-command-line ( profile -- flags )
[
- [
+ dup empty? [
"-i=" my-boot-image-name append ,
+ ] [
+ dup 1 head* ?make-staging-image
- "-output-image=" staging-image-name append ,
+ "-resource-path=" "" resource-path append ,
- "-include=" bootstrap-profile " " join append ,
+ "-i=" over 1 head* staging-image-name append ,
- strip-word-names? [ "-no-stack-traces" , ] when
+ "-run=tools.deploy.restage" ,
+ ] if
- "-no-user-init" ,
- ] { } make
- ] bind ;
+ "-output-image=" over staging-image-name append ,
+
+ "-include=" swap " " join append ,
+
+ strip-word-names? [ "-no-stack-traces" , ] when
+
+ "-no-user-init" ,
+ ] { } make ;
: run-factor ( vm flags -- )
- swap add* dup . run-with-output ; inline
+ swap prefix dup . run-with-output ; inline
-: make-staging-image ( config -- )
+: make-staging-image ( profile -- )
vm swap staging-command-line run-factor ;
-: ?make-staging-image ( config -- )
- dup [ staging-image-name ] bind exists?
+: ?make-staging-image ( profile -- )
+ dup staging-image-name exists?
[ drop ] [ make-staging-image ] if ;
: deploy-command-line ( image vocab config -- flags )
[
+ bootstrap-profile ?make-staging-image
+
[
- "-i=" staging-image-name append ,
+ "-i=" bootstrap-profile staging-image-name append ,
+
+ "-resource-path=" "" resource-path append ,
"-run=tools.deploy.shaker" ,
- "-deploy-vocab=" swap append ,
+ "-deploy-vocab=" prepend ,
- "-output-image=" swap append ,
+ "-output-image=" prepend ,
strip-word-names? [ "-no-stack-traces" , ] when
] { } make
: make-deploy-image ( vm image vocab config -- )
make-boot-image
- dup ?make-staging-image
deploy-command-line run-factor ;
-SYMBOL: deploy-implementation
-
-HOOK: deploy* deploy-implementation ( vocab -- )
+HOOK: deploy* os ( vocab -- )
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
{ $subsection deploy-compiler? }
+{ $subsection deploy-random? }
+{ $subsection deploy-threads? }
{ $subsection deploy-ui? }
"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:"
{ $subsection deploy-io }
$nl
"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
-HELP: deploy-threads?
-{ $description "Deploy flag. If set, the deployed image will contain support for threads."
-$nl
-"On by default. Often the programmer will use threads without realizing it. A small amount of space can be saved by stripping this feature out, but some code may require changes to work properly." } ;
-
HELP: deploy-compiler?
{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
$nl
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
+HELP: deploy-random?
+{ $description "Deploy flag. If set, the random number generator protocol is included, together with two implementations: a native OS-specific random number generator, and the Mersenne Twister."
+$nl
+"On by default. If your program does not generate random numbers you can disable this to save some space." } ;
+
+HELP: deploy-threads?
+{ $description "Deploy flag. If set, thread support will be included in the final image."
+$nl
+"On by default. Most programs depend on libraries which use threads even if they don't use threads directly; for example, alarms, non-blocking I/O, and the UI are built on top of threads. If after testing your program still works without threads, you can disable this feature to save some space." } ;
+
HELP: deploy-ui?
{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image."
$nl
SYMBOL: deploy-ui?
SYMBOL: deploy-compiler?
SYMBOL: deploy-math?
+SYMBOL: deploy-random?
SYMBOL: deploy-threads?
SYMBOL: deploy-io
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-threads? t }
+ { deploy-random? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-word-defs? f }
{ deploy-c-types? f }
! default value for deploy.macosx
{ "stop-after-last-window?" t }
- } union ;
+ } assoc-union ;
: deploy-config-path ( vocab -- string )
- vocab-dir "deploy.factor" path+ ;
+ vocab-dir "deploy.factor" append-path ;
: deploy-config ( vocab -- assoc )
dup default-config swap
dup deploy-config-path vocab-file-contents
- parse-fresh dup empty? [ drop ] [ first union ] if ;
+ parse-fresh dup empty? [ drop ] [ first assoc-union ] if ;
: set-deploy-config ( assoc vocab -- )
>r unparse-use string-lines r>
$nl
"For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:"
{ $code "\"hello-ui\" deploy" }
-"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". In both cases, running the program displays a window with a message."
+{ $list
+ { "On Mac OS X, this yields a program named " { $snippet "Hello world.app" } "." }
+ { "On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } "." }
+ { "On Unix-like systems (Linux, BSD, Solaris, etc), it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui" } "." }
+}
+"In all cases, running the program displays a window with a message."
$nl
"The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size."
$nl
IN: tools.deploy.tests\r
USING: tools.test system io.files kernel tools.deploy.config\r
-tools.deploy.backend math sequences io.launcher arrays ;\r
+tools.deploy.backend math sequences io.launcher arrays\r
+namespaces continuations layouts accessors ;\r
\r
: shake-and-bake ( vocab -- )\r
- "." resource-path [\r
+ [ "test.image" temp-file delete-file ] ignore-errors\r
+ "resource:" [\r
>r vm\r
"test.image" temp-file\r
r> dup deploy-config make-deploy-image\r
] with-directory ;\r
\r
: small-enough? ( n -- ? )\r
- >r "test.image" temp-file file-info file-info-size r> <= ;\r
+ >r "test.image" temp-file file-info size>> r> <= ;\r
\r
[ ] [ "hello-world" shake-and-bake ] unit-test\r
\r
[ t ] [\r
- 500000 small-enough?\r
+ cell 8 = 8 5 ? 100000 * small-enough?\r
] unit-test\r
\r
[ ] [ "sudoku" shake-and-bake ] unit-test\r
\r
[ t ] [\r
- 1500000 small-enough?\r
+ cell 8 = 30 15 ? 100000 * small-enough?\r
] unit-test\r
\r
[ ] [ "hello-ui" shake-and-bake ] unit-test\r
\r
+[ "staging.math-compiler-ui-strip.image" ] [\r
+ "hello-ui" deploy-config\r
+ [ bootstrap-profile staging-image-name file-name ] bind\r
+] unit-test\r
+\r
[ t ] [\r
- 2000000 small-enough?\r
+ cell 8 = 40 20 ? 100000 * small-enough?\r
] unit-test\r
\r
[ ] [ "bunny" shake-and-bake ] unit-test\r
\r
[ t ] [\r
- 3000000 small-enough?\r
+ cell 8 = 50 30 ? 100000 * small-enough?\r
] unit-test\r
\r
[ ] [\r
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.deploy.backend system vocabs.loader kernel ;
+USING: tools.deploy.backend system vocabs.loader kernel
+combinators ;
IN: tools.deploy
: deploy ( vocab -- ) deploy* ;
-macosx? [ "tools.deploy.macosx" require ] when
-winnt? [ "tools.deploy.windows" require ] when
+{
+ { [ os macosx? ] [ "tools.deploy.macosx" ] }
+ { [ os winnt? ] [ "tools.deploy.windows" ] }
+ { [ os unix? ] [ "tools.deploy.unix" ] }
+} cond require
\ No newline at end of file
USING: io io.files kernel namespaces sequences
system tools.deploy.backend tools.deploy.config assocs
hashtables prettyprint io.unix.backend cocoa io.encodings.utf8
-cocoa.application cocoa.classes cocoa.plists qualified ;
+io.backend cocoa.application cocoa.classes cocoa.plists
+qualified ;
IN: tools.deploy.macosx
: bundle-dir ( -- dir )
vm parent-directory parent-directory ;
: copy-bundle-dir ( bundle-name dir -- )
- bundle-dir over path+ -rot
- "Contents" swap path+ path+ copy-tree ;
+ bundle-dir over append-path -rot
+ "Contents" prepend-path append-path copy-tree ;
-: copy-vm ( executable bundle-name -- vm )
- "Contents/MacOS/" path+ swap path+ vm over copy-file ;
-
-: copy-fonts ( name -- )
- "fonts/" resource-path
- swap "Contents/Resources/" path+ copy-tree-into ;
-
-: app-plist ( executable bundle-name -- string )
+: app-plist ( executable bundle-name -- assoc )
[
- namespace {
- { "CFBundleInfoDictionaryVersion" "6.0" }
- { "CFBundlePackageType" "APPL" }
- } update
+ "6.0" "CFBundleInfoDictionaryVersion" set
+ "APPL" "CFBundlePackageType" set
file-name "CFBundleName" set
- dup "CFBundleExecutable" set
- "org.factor." swap append "CFBundleIdentifier" set
- ] H{ } make-assoc plist>string ;
+ [ "CFBundleExecutable" set ]
+ [ "org.factor." prepend "CFBundleIdentifier" set ] bi
+ ] H{ } make-assoc ;
-: create-app-plist ( vocab bundle-name -- )
+: create-app-plist ( executable bundle-name -- )
[ app-plist ] keep
- "Contents/Info.plist" path+
- utf8 set-file-contents ;
+ "Contents/Info.plist" append-path
+ write-plist ;
: create-app-dir ( vocab bundle-name -- vm )
- dup "Frameworks" copy-bundle-dir
- dup "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
- dup copy-fonts
- 2dup create-app-plist copy-vm ;
+ [
+ nip
+ [ "Frameworks" copy-bundle-dir ]
+ [ "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir ]
+ [ "Contents/Resources/" copy-fonts ] tri
+ ]
+ [ create-app-plist ]
+ [ "Contents/MacOS/" append-path "" copy-vm ] 2tri ;
: deploy.app-image ( vocab bundle-name -- str )
[ % "/Contents/Resources/" % % ".image" % ] "" make ;
: bundle-name ( -- string )
deploy-name get ".app" append ;
-TUPLE: macosx-deploy-implementation ;
-
-T{ macosx-deploy-implementation } deploy-implementation set-global
-
: show-in-finder ( path -- )
- NSWorkspace
- -> sharedWorkspace
- over <NSString> rot parent-directory <NSString>
+ [ NSWorkspace -> sharedWorkspace ]
+ [ normalize-path [ <NSString> ] [ parent-directory <NSString> ] bi ] bi*
-> selectFile:inFileViewerRootedAtPath: drop ;
-M: macosx-deploy-implementation deploy* ( vocab -- )
+M: macosx deploy* ( vocab -- )
".app deploy tool" assert.app
- "." resource-path cd
- dup deploy-config [
- bundle-name dup exists? [ delete-tree ] [ drop ] if
- [ bundle-name create-app-dir ] keep
- [ bundle-name deploy.app-image ] keep
- namespace make-deploy-image
- bundle-name show-in-finder
- ] bind ;
+ "resource:" [
+ dup deploy-config [
+ bundle-name dup exists? [ delete-tree ] [ drop ] if
+ [ bundle-name create-app-dir ] keep
+ [ bundle-name deploy.app-image ] keep
+ namespace make-deploy-image
+ bundle-name show-in-finder
+ ] bind
+ ] with-directory ;
--- /dev/null
+IN: tools.deploy.restage
+USING: bootstrap.stage2 namespaces memory ;
+
+: restage ( -- )
+ load-components
+ "output-image" get save-image-and-exit ;
+
+MAIN: restage
USING: qualified io.streams.c init fry namespaces assocs kernel
parser tools.deploy.config vocabs sequences words words.private
memory kernel.private continuations io prettyprint
-vocabs.loader debugger system strings ;
+vocabs.loader debugger system strings sets ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
+QUALIFIED: command-line
QUALIFIED: compiler.errors.private
QUALIFIED: compiler.units
QUALIFIED: continuations
QUALIFIED: libc.private
QUALIFIED: listener
QUALIFIED: prettyprint.config
-QUALIFIED: random.private
QUALIFIED: source-files
QUALIFIED: threads
QUALIFIED: vocabs
[
"class" ,
"metaclass" ,
- "slot-names" ,
+ "layout" ,
deploy-ui? get [
"gestures" ,
"commands" ,
set-global ;
: strip-vocab-globals ( except names -- words )
- [ child-vocabs [ words ] map concat ] map concat seq-diff ;
+ [ child-vocabs [ words ] map concat ] map concat diff ;
: stripped-globals ( -- seq )
[
- random.private:mt ,
-
{
bootstrap.stage2:bootstrap-time
continuations:error
{ } { "cpu" } strip-vocab-globals %
{
- vocabs:dictionary
- lexer-factory
- vocabs:load-vocab-hook
+ gensym
+ classes:class-and-cache
+ classes:class-not-cache
+ classes:class-or-cache
+ classes:class<-cache
+ classes:classes-intersect-cache
+ classes:update-map
+ command-line:main-vocab-hook
+ compiled-crossref
+ compiler.units:recompile-hook
+ compiler.units:update-tuples-hook
+ definitions:crossref
+ interactive-vocabs
layouts:num-tags
layouts:num-types
layouts:tag-mask
layouts:tag-numbers
layouts:type-numbers
- classes:typemap
+ lexer-factory
+ listener:listener-hook
+ root-cache
vocab-roots
- definitions:crossref
- compiled-crossref
- interactive-vocabs
+ vocabs:dictionary
+ vocabs:load-vocab-hook
word
- compiler.units:recompile-hook
- listener:listener-hook
- lexer-factory
- classes:update-map
- classes:class<map
} %
] when
deploy-ui? get [
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
+
+ "<computer>" "inference.dataflow" lookup [ , ] when*
+
+ "windows-messages" "windows.messages" lookup [ , ] when*
+
] { } make ;
: strip-globals ( stripped-globals -- )
[ "MiniFactor.nib" load-nib ] cocoa-init-hook set-global
! Only keeps those methods that we actually call
- sent-messages get super-sent-messages get union
- objc-methods [ intersect ] change
+ sent-messages get super-sent-messages get assoc-union
+ objc-methods [ assoc-intersect ] change
sent-messages get
super-sent-messages get
- [ keys [ objc-methods get at dup ] H{ } map>assoc ] 2apply
- super-message-senders [ intersect ] change
- message-senders [ intersect ] change
+ [ keys [ objc-methods get at dup ] H{ } map>assoc ] bi@
+ super-message-senders [ assoc-intersect ] change
+ message-senders [ assoc-intersect ] change
sent-messages off
super-sent-messages off
USING: libc.private ;
IN: libc
-: malloc (malloc) ;
+: malloc (malloc) check-ptr ;
-: free (free) ;
+: realloc (realloc) check-ptr ;
-: realloc (realloc) ;
+: calloc (calloc) check-ptr ;
-: calloc (calloc) ;
+: free (free) ;
USING: tools.deploy.config ;
H{
- { deploy-c-types? f }
- { deploy-io 2 }
- { deploy-reflection 1 }
- { deploy-threads? t }
- { deploy-word-props? f }
{ deploy-word-defs? f }
+ { deploy-random? f }
{ deploy-name "tools.deploy.test.1" }
- { deploy-math? t }
+ { deploy-threads? t }
{ deploy-compiler? t }
- { "stop-after-last-window?" t }
+ { deploy-math? t }
+ { deploy-c-types? f }
+ { deploy-io 2 }
+ { deploy-reflection 1 }
{ deploy-ui? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
USING: tools.deploy.config ;
H{
- { deploy-c-types? f }
- { deploy-io 2 }
- { deploy-reflection 1 }
- { deploy-threads? t }
- { deploy-word-props? f }
{ deploy-word-defs? f }
+ { deploy-random? f }
{ deploy-name "tools.deploy.test.2" }
- { deploy-math? t }
+ { deploy-threads? t }
{ deploy-compiler? t }
- { "stop-after-last-window?" t }
+ { deploy-math? t }
+ { deploy-c-types? f }
+ { deploy-io 2 }
+ { deploy-reflection 1 }
{ deploy-ui? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
\r
: deploy-test-3\r
"resource:extra/tools/deploy/test/3/3.factor"\r
- ?resource-path ascii file-contents drop ;\r
+ ascii file-contents drop ;\r
\r
MAIN: deploy-test-3\r
USING: tools.deploy.config ;
H{
- { deploy-math? t }
- { deploy-reflection 1 }
+ { deploy-word-defs? f }
+ { deploy-random? f }
{ deploy-name "tools.deploy.test.3" }
{ deploy-threads? t }
- { deploy-word-props? f }
- { "stop-after-last-window?" t }
- { deploy-ui? f }
- { deploy-io 3 }
{ deploy-compiler? t }
- { deploy-word-defs? f }
+ { deploy-math? t }
{ deploy-c-types? f }
+ { deploy-io 3 }
+ { deploy-reflection 1 }
+ { deploy-ui? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
}
--- /dev/null
+James Cash
--- /dev/null
+Deploying minimal stand-alone binaries on *nix-like systems
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.files io.backend kernel namespaces sequences
+system tools.deploy.backend tools.deploy.config assocs
+hashtables prettyprint ;
+IN: tools.deploy.unix
+
+: create-app-dir ( vocab bundle-name -- vm )
+ dup "" copy-fonts
+ "" copy-vm ;
+
+: bundle-name ( -- str )
+ deploy-name get ;
+
+M: unix deploy* ( vocab -- )
+ "." resource-path [
+ dup deploy-config [
+ [ bundle-name create-app-dir ] keep
+ [ bundle-name image-name ] keep
+ namespace make-deploy-image
+ bundle-name normalize-path [ "Binary deployed to " % % "." % ] "" make print
+ ] bind
+ ] with-directory ;
\ No newline at end of file
prettyprint windows.shell32 windows.user32 ;
IN: tools.deploy.windows
-: copy-vm ( executable bundle-name -- vm )
- swap path+ ".exe" append
- vm over copy-file ;
-
-: copy-fonts ( bundle-name -- )
- "fonts/" resource-path swap copy-tree-into ;
-
: copy-dlls ( bundle-name -- )
- { "freetype6.dll" "zlib1.dll" "factor.dll" }
- [ resource-path ] map
+ { "resource:freetype6.dll" "resource:zlib1.dll" "resource:factor.dll" }
swap copy-files-into ;
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dlls
- dup copy-fonts
- copy-vm ;
-
-: image-name ( vocab bundle-name -- str )
- swap path+ ".image" append ;
-
-TUPLE: windows-deploy-implementation ;
-
-T{ windows-deploy-implementation } deploy-implementation set-global
+ dup "" copy-fonts
+ ".exe" copy-vm ;
-M: windows-deploy-implementation deploy*
+M: winnt deploy*
"." resource-path [
dup deploy-config [
[ deploy-name get create-exe-dir ] keep
IN: tools.disassembler.tests\r
-USING: math tuples prettyprint.backend tools.disassembler\r
+USING: math classes.tuple prettyprint.backend tools.disassembler\r
tools.test strings ;\r
\r
[ ] [ \ + disassemble ] unit-test\r
M: method-spec make-disassemble-cmd
first2 method make-disassemble-cmd ;
+: gdb-binary ( -- string ) "gdb" ;
+
: run-gdb ( -- lines )
<process>
+closed+ >>stdin
out-file >>stdout
- [ "gdb" , "-x" , in-file , "-batch" , ] { } make >>command
+ [ gdb-binary , "-x" , in-file , "-batch" , ] { } make >>command
try-process
out-file ascii file-lines ;
"You can check an object's the heap memory usage:"
{ $subsection size }
"The garbage collector can be invoked manually:"
-{ $subsection data-gc }
-{ $subsection code-gc }
+{ $subsection gc }
{ $see-also "images" } ;
ABOUT: "tools.memory"
USING: tools.test tools.memory ;
IN: tools.memory.tests
+\ room. must-infer
+[ ] [ room. ] unit-test
+
+\ heap-stats. must-infer
[ ] [ heap-stats. ] unit-test
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences vectors arrays generic assocs io math
namespaces parser prettyprint strings io.styles vectors words
-system sorting splitting math.parser classes memory ;
+system sorting splitting math.parser classes memory combinators ;
IN: tools.memory
+<PRIVATE
+
+: write-size ( n -- )
+ number>string
+ dup length 4 > [ 3 cut* "," swap 3append ] when
+ " KB" append write-cell ;
+
: write-total/used/free ( free total str -- )
[
write-cell
- dup number>string write-cell
- over - number>string write-cell
- number>string write-cell
+ dup write-size
+ over - write-size
+ write-size
] with-row ;
: write-total ( n str -- )
[
write-cell
- number>string write-cell
+ write-size
[ ] with-cell
[ ] with-cell
] with-row ;
[ [ write-cell ] each ] with-row ;
: (data-room.) ( -- )
- data-room 2 <groups> 0 [
- "Generation " pick number>string append
- >r first2 r> write-total/used/free 1+
- ] reduce drop
+ data-room 2 <groups> dup length [
+ [ first2 ] [ number>string "Generation " prepend ] bi*
+ write-total/used/free
+ ] 2each
"Cards" write-total ;
+: write-labelled-size ( n string -- )
+ [ write-cell write-size ] with-row ;
+
: (code-room.) ( -- )
- code-room "Code space" write-total/used/free ;
+ code-room {
+ [ "Size:" write-labelled-size ]
+ [ "Used:" write-labelled-size ]
+ [ "Total free space:" write-labelled-size ]
+ [ "Largest free block:" write-labelled-size ]
+ } spread ;
+
+: heap-stat-step ( counts sizes obj -- )
+ [ dup size swap class rot at+ ] keep
+ 1 swap class rot at+ ;
+
+PRIVATE>
: room. ( -- )
+ "==== DATA HEAP" print
standard-table-style [
{ "" "Total" "Used" "Free" } write-headings
(data-room.)
+ ] tabular-output
+ nl
+ "==== CODE HEAP" print
+ standard-table-style [
(code-room.)
] tabular-output ;
-: heap-stat-step ( counts sizes obj -- )
- [ dup size swap class rot at+ ] keep
- 1 swap class rot at+ ;
-
: heap-stats ( -- counts sizes )
H{ } clone H{ } clone
[ >r 2dup r> heap-stat-step ] each-object ;
\ length profile-counter =
] unit-test
-[ ] [ [ 10 [ data-gc ] times ] profile ] unit-test
+[ ] [ [ 10 [ gc ] times ] profile ] unit-test
[ ] [ [ 1000 sleep ] profile ] unit-test
: threads. ( -- )\r
standard-table-style [\r
[\r
- { "ID" "Name" "Waiting on" "Remaining sleep" }\r
+ { "ID:" "Name:" "Waiting on:" "Remaining sleep:" }\r
[ [ write ] with-cell ] each\r
] with-row\r
\r
{
{ [ dup not ] [ drop "" ] }
{ [ dup vocab-main ] [ drop "[Runnable]" ] }
- { [ t ] [ drop "[Loaded]" ] }
+ [ drop "[Loaded]" ]
} cond ;
: write-status ( vocab -- )
] with-row ;
: root-heading. ( root -- )
- [ "Children from " swap append ] [ "Children" ] if*
+ [ "Children from " prepend ] [ "Children" ] if*
$heading ;
: vocabs. ( assoc -- )
: describe-help ( vocab -- )
vocab-help [
- "Documentation" $heading nl ($link)
+ "Documentation" $heading ($link)
] when* ;
: describe-children ( vocab -- )
: $describe-vocab ( element -- )
first
dup describe-children
- dup vocab-root over vocab-dir? [
+ dup find-vocab-root [
dup describe-summary
dup describe-tags
dup describe-authors
M: vocab-author >link ;
M: vocab-author article-title
- vocab-author-name "Vocabularies by " swap append ;
+ vocab-author-name "Vocabularies by " prepend ;
M: vocab-author article-name vocab-author-name ;
--- /dev/null
+USING: tools.test tools.vocabs.monitor io.files ;
+IN: tools.vocabs.monitor.tests
+
+[ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test
+[ "kernel" ] [ "core/kernel/" path>vocab ] unit-test
+[ "kernel" ] [ "core/kernel/" resource-path path>vocab ] unit-test
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: threads io.files io.monitors init kernel\r
-vocabs.loader tools.vocabs namespaces continuations ;\r
+vocabs vocabs.loader tools.vocabs namespaces continuations\r
+sequences splitting assocs command-line ;\r
IN: tools.vocabs.monitor\r
\r
-! Use file system change monitoring to flush the tags/authors\r
-! cache\r
-SYMBOL: vocab-monitor\r
+: vocab-dir>vocab-name ( path -- vocab )\r
+ left-trim-separators right-trim-separators\r
+ { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ;\r
+\r
+: path>vocab-name ( path -- vocab )\r
+ dup ".factor" tail? [ parent-directory ] when ;\r
+\r
+: chop-vocab-root ( path -- path' )\r
+ "resource:" prepend-path (normalize-path)\r
+ dup vocab-roots get\r
+ [ (normalize-path) ] map\r
+ [ head? ] with find nip\r
+ ?head drop ;\r
+\r
+: path>vocab ( path -- vocab )\r
+ chop-vocab-root path>vocab-name vocab-dir>vocab-name ;\r
+\r
+: monitor-loop ( monitor -- )\r
+ #! On OS X, monitors give us the full path, so we chop it\r
+ #! off if its there.\r
+ dup next-change drop path>vocab changed-vocab\r
+ reset-cache\r
+ monitor-loop ;\r
\r
: monitor-thread ( -- )\r
- vocab-monitor get-global\r
- next-change 2drop\r
- t sources-changed? set-global reset-cache ;\r
+ [\r
+ [\r
+ "" resource-path t <monitor>\r
+ \r
+ H{ } clone changed-vocabs set-global\r
+ vocabs [ changed-vocab ] each\r
+ \r
+ monitor-loop\r
+ ] with-monitors\r
+ ] ignore-errors ;\r
\r
-: start-monitor-thread\r
+: start-monitor-thread ( -- )\r
#! Silently ignore errors during monitor creation since\r
#! monitors are not supported on all platforms.\r
- [\r
- "" resource-path t <monitor> vocab-monitor set-global\r
- [ monitor-thread t ] "Vocabulary monitor" spawn-server drop\r
- ] ignore-errors ;\r
+ [ monitor-thread ] "Vocabulary monitor" spawn drop ;\r
\r
-[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook\r
+[\r
+ "-no-monitors" cli-args member? [\r
+ start-monitor-thread\r
+ ] unless\r
+] "tools.vocabs.monitor" add-init-hook\r
--- /dev/null
+IN: tools.vocabs.tests
+USING: tools.test tools.vocabs namespaces continuations ;
+
+[ ] [
+ changed-vocabs get-global
+ f changed-vocabs set-global
+ [ t ] [ "kernel" changed-vocab? ] unit-test
+ [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
+] unit-test
USING: io.files kernel io.encodings.utf8 vocabs.loader vocabs\r
sequences namespaces math.parser arrays hashtables assocs\r
memoize inspector sorting splitting combinators source-files\r
-io debugger continuations compiler.errors init io.crc32 ;\r
+io debugger continuations compiler.errors init io.crc32 \r
+sets ;\r
IN: tools.vocabs\r
\r
-: vocab-tests-file, ( vocab -- )\r
- dup "-tests.factor" vocab-dir+ vocab-path+\r
- dup resource-exists? [ , ] [ drop ] if ;\r
+: vocab-tests-file ( vocab -- path )\r
+ dup "-tests.factor" vocab-dir+ vocab-append-path dup\r
+ [ dup exists? [ drop f ] unless ] [ drop f ] if ;\r
\r
-: vocab-tests-dir, ( vocab -- )\r
- dup vocab-dir "tests" path+ vocab-path+\r
- dup resource-exists? [\r
- dup ?resource-path directory keys\r
- [ ".factor" tail? ] subset\r
- [ path+ , ] with each\r
- ] [ drop ] if ;\r
+: vocab-tests-dir ( vocab -- paths )\r
+ dup vocab-dir "tests" append-path vocab-append-path dup [\r
+ dup exists? [\r
+ dup directory keys\r
+ [ ".factor" tail? ] subset\r
+ [ append-path ] with map\r
+ ] [ drop f ] if\r
+ ] [ drop f ] if ;\r
\r
: vocab-tests ( vocab -- tests )\r
- dup vocab-root dup [\r
- [\r
- >vocab-link dup\r
- vocab-tests-file,\r
- vocab-tests-dir,\r
- ] { } make\r
- ] [ 2drop f ] if ;\r
+ [\r
+ [ vocab-tests-file [ , ] when* ]\r
+ [ vocab-tests-dir [ % ] when* ] bi\r
+ ] { } make ;\r
\r
: vocab-files ( vocab -- seq )\r
- dup find-vocab-root >vocab-link [\r
- dup vocab-source-path [ , ] when*\r
- dup vocab-docs-path [ , ] when*\r
- vocab-tests %\r
+ [\r
+ [ vocab-source-path [ , ] when* ]\r
+ [ vocab-docs-path [ , ] when* ]\r
+ [ vocab-tests % ] tri\r
] { } make ;\r
\r
-: source-modified? ( path -- ? )\r
- dup source-files get at [\r
- dup source-file-path ?resource-path utf8 file-lines lines-crc32\r
- swap source-file-checksum = not\r
- ] [\r
- resource-exists?\r
- ] ?if ;\r
-\r
-: modified ( seq quot -- seq )\r
- [ dup ] swap compose { } map>assoc\r
- [ nip ] assoc-subset\r
- [ nip source-modified? ] assoc-subset keys ; inline\r
-\r
-: modified-sources ( vocabs -- seq )\r
- [ vocab-source-path ] modified ;\r
-\r
-: modified-docs ( vocabs -- seq )\r
- [ vocab-docs-path ] modified ;\r
-\r
-: update-roots ( vocabs -- )\r
- [ dup find-vocab-root swap vocab set-vocab-root ] each ;\r
-\r
-: to-refresh ( prefix -- modified-sources modified-docs )\r
- child-vocabs\r
- dup update-roots\r
- dup modified-sources swap modified-docs ;\r
-\r
: vocab-heading. ( vocab -- )\r
nl\r
"==== " write\r
- dup vocab-name swap vocab write-object ":" print\r
+ [ vocab-name ] [ vocab write-object ] bi ":" print\r
nl ;\r
\r
: load-error. ( triple -- )\r
- dup first vocab-heading.\r
- dup second print-error\r
- drop ;\r
+ [ first vocab-heading. ] [ second print-error ] bi ;\r
\r
: load-failures. ( failures -- )\r
[ load-error. nl ] each ;\r
failures get\r
] with-compiler-errors ;\r
\r
-: do-refresh ( modified-sources modified-docs -- )\r
- 2dup\r
- [ f swap set-vocab-docs-loaded? ] each\r
- [ f swap set-vocab-source-loaded? ] each\r
- append prune require-all load-failures. ;\r
+: source-modified? ( path -- ? )\r
+ dup source-files get at [\r
+ dup source-file-path\r
+ dup exists? [\r
+ utf8 file-lines lines-crc32\r
+ swap source-file-checksum = not\r
+ ] [\r
+ 2drop f\r
+ ] if\r
+ ] [\r
+ exists?\r
+ ] ?if ;\r
+\r
+SYMBOL: changed-vocabs\r
\r
-: refresh ( prefix -- ) to-refresh do-refresh ;\r
+[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook\r
+\r
+: changed-vocab ( vocab -- )\r
+ dup vocab changed-vocabs get and\r
+ [ dup changed-vocabs get set-at ] [ drop ] if ;\r
+\r
+: unchanged-vocab ( vocab -- )\r
+ changed-vocabs get delete-at ;\r
+\r
+: unchanged-vocabs ( vocabs -- )\r
+ [ unchanged-vocab ] each ;\r
\r
-SYMBOL: sources-changed?\r
+: changed-vocab? ( vocab -- ? )\r
+ changed-vocabs get dup [ key? ] [ 2drop t ] if ;\r
\r
-[ t sources-changed? set-global ] "tools.vocabs" add-init-hook\r
+: filter-changed ( vocabs -- vocabs' )\r
+ [ changed-vocab? ] subset ;\r
\r
-: refresh-all ( -- )\r
- "" refresh f sources-changed? set-global ;\r
+SYMBOL: modified-sources\r
+SYMBOL: modified-docs\r
+\r
+: (to-refresh) ( vocab variable loaded? path -- )\r
+ dup [\r
+ swap [\r
+ pick changed-vocab? [\r
+ source-modified? [ get push ] [ 2drop ] if\r
+ ] [ 3drop ] if\r
+ ] [ drop get push ] if\r
+ ] [ 2drop 2drop ] if ;\r
+\r
+: to-refresh ( prefix -- modified-sources modified-docs unchanged )\r
+ [\r
+ V{ } clone modified-sources set\r
+ V{ } clone modified-docs set\r
+\r
+ child-vocabs [\r
+ [\r
+ [\r
+ [ modified-sources ]\r
+ [ vocab-source-loaded? ]\r
+ [ vocab-source-path ]\r
+ tri (to-refresh)\r
+ ] [\r
+ [ modified-docs ]\r
+ [ vocab-docs-loaded? ]\r
+ [ vocab-docs-path ]\r
+ tri (to-refresh)\r
+ ] bi\r
+ ] each\r
+\r
+ modified-sources get\r
+ modified-docs get\r
+ ]\r
+ [ modified-sources get modified-docs get append swap diff ] bi\r
+ ] with-scope ;\r
+\r
+: do-refresh ( modified-sources modified-docs unchanged -- )\r
+ unchanged-vocabs\r
+ [\r
+ [ [ f swap set-vocab-source-loaded? ] each ]\r
+ [ [ f swap set-vocab-docs-loaded? ] each ] bi*\r
+ ]\r
+ [\r
+ append prune\r
+ [ unchanged-vocabs ]\r
+ [ require-all load-failures. ] bi\r
+ ] 2bi ;\r
+\r
+: refresh ( prefix -- ) to-refresh do-refresh ;\r
\r
-MEMO: (vocab-file-contents) ( path -- lines )\r
- ?resource-path dup exists?\r
- [ utf8 file-lines ] [ drop f ] if ;\r
+: refresh-all ( -- ) "" refresh ;\r
\r
-: vocab-file-contents ( vocab name -- seq )\r
- vocab-path+ dup [ (vocab-file-contents) ] when ;\r
+MEMO: vocab-file-contents ( vocab name -- seq )\r
+ vocab-append-path dup\r
+ [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;\r
\r
: set-vocab-file-contents ( seq vocab name -- )\r
- dupd vocab-path+ [\r
- ?resource-path utf8 set-file-lines\r
+ dupd vocab-append-path [\r
+ utf8 set-file-lines\r
+ \ vocab-file-contents reset-memoized\r
] [\r
"The " swap vocab-name\r
" vocabulary was not loaded from the file system"\r
] ?if ;\r
\r
: vocab-summary-path ( vocab -- string )\r
- vocab-dir "summary.txt" path+ ;\r
+ vocab-dir "summary.txt" append-path ;\r
\r
: vocab-summary ( vocab -- summary )\r
dup dup vocab-summary-path vocab-file-contents\r
set-vocab-file-contents ;\r
\r
: vocab-tags-path ( vocab -- string )\r
- vocab-dir "tags.txt" path+ ;\r
+ vocab-dir "tags.txt" append-path ;\r
\r
: vocab-tags ( vocab -- tags )\r
dup vocab-tags-path vocab-file-contents ;\r
[ vocab-tags append prune ] keep set-vocab-tags ;\r
\r
: vocab-authors-path ( vocab -- string )\r
- vocab-dir "authors.txt" path+ ;\r
+ vocab-dir "authors.txt" append-path ;\r
\r
: vocab-authors ( vocab -- authors )\r
dup vocab-authors-path vocab-file-contents ;\r
directory [ second ] subset keys natural-sort ;\r
\r
: (all-child-vocabs) ( root name -- vocabs )\r
- [ vocab-dir path+ ?resource-path subdirs ] keep\r
+ [ vocab-dir append-path subdirs ] keep\r
dup empty? [\r
drop\r
] [\r
\r
: vocabs-in-dir ( root name -- )\r
dupd (all-child-vocabs) [\r
- 2dup vocab-dir? [ 2dup swap >vocab-link , ] when\r
+ 2dup vocab-dir? [ dup >vocab-link , ] when\r
vocabs-in-dir\r
] with each ;\r
\r
{ [ "editors." ?head ] [ t ] }\r
{ [ ".windows" ?tail ] [ t ] }\r
{ [ ".unix" ?tail ] [ t ] }\r
- { [ "unix." ?head ] [ t ] }\r
+ { [ "unix" ?head ] [ t ] }\r
{ [ ".linux" ?tail ] [ t ] }\r
{ [ ".bsd" ?tail ] [ t ] }\r
{ [ ".macosx" ?tail ] [ t ] }\r
{ [ ".test" ?tail ] [ t ] }\r
{ [ "raptor" ?head ] [ t ] }\r
{ [ dup "tools.deploy.app" = ] [ t ] }\r
- { [ t ] [ f ] }\r
+ [ f ]\r
} cond nip ;\r
\r
: filter-dangerous ( seq -- seq' )\r
try-everything load-failures. ;\r
\r
: unrooted-child-vocabs ( prefix -- seq )\r
- dup empty? [ CHAR: . add ] unless\r
+ dup empty? [ CHAR: . suffix ] unless\r
vocabs\r
- [ vocab-root not ] subset\r
+ [ find-vocab-root not ] subset\r
[\r
vocab-name swap ?head CHAR: . rot member? not and\r
] with subset\r
\r
: all-child-vocabs ( prefix -- assoc )\r
vocab-roots get [\r
- over dupd dupd (all-child-vocabs)\r
- swap [ >vocab-link ] curry map\r
+ dup pick (all-child-vocabs) [ >vocab-link ] map\r
] { } map>assoc\r
- f rot unrooted-child-vocabs 2array add ;\r
+ swap unrooted-child-vocabs f swap 2array suffix ;\r
\r
: all-child-vocabs-seq ( prefix -- assoc )\r
vocab-roots get swap [\r
all-vocabs-seq [ vocab-authors ] map>set ;\r
\r
: reset-cache ( -- )\r
- \ (vocab-file-contents) reset-memoized\r
+ root-cache get-global clear-assoc\r
+ \ vocab-file-contents reset-memoized\r
\ all-vocabs-seq reset-memoized\r
\ all-authors reset-memoized\r
\ all-tags reset-memoized ;\r
USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
-sequences.private assocs models combinators.cleave ;
+sequences.private assocs models arrays accessors
+generic generic.standard ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
2dup start-walker-thread
] if* ;
-USING: io.streams.c prettyprint ;
-
: show-walker ( -- thread )
get-walker-thread
[ show-walker-hook get call ] keep ;
{
{ [ dup continuation? ] [ (continue) ] }
{ [ dup quotation? ] [ call ] }
- { [ dup not ] [ "Single stepping abandoned" throw ] }
+ { [ dup not ] [ "Single stepping abandoned" rethrow ] }
} cond ;
: break ( -- )
\ break t "break?" set-word-prop
: walk ( quot -- quot' )
- \ break add* [ break rethrow ] recover ;
+ \ break prefix [ break rethrow ] recover ;
+
+GENERIC: add-breakpoint ( quot -- quot' )
+
+M: callable add-breakpoint
+ dup [ break ] head? [ \ break prefix ] unless ;
-: add-breakpoint ( quot -- quot' )
- dup [ break ] head? [ \ break add* ] unless ;
+M: array add-breakpoint
+ [ add-breakpoint ] map ;
+
+M: object add-breakpoint ;
: (step-into-quot) ( quot -- ) add-breakpoint call ;
: (step-into-dispatch) nth (step-into-quot) ;
: (step-into-execute) ( word -- )
- dup "step-into" word-prop [
- call
- ] [
- dup primitive? [
- execute break
- ] [
- word-def (step-into-quot)
- ] if
- ] ?if ;
+ {
+ { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
+ { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup primitive? ] [ execute break ] }
+ [ word-def (step-into-quot) ]
+ } cond ;
\ (step-into-execute) t "step-into?" set-word-prop
: (step-into-continuation)
- continuation callstack over set-continuation-call break ;
+ continuation callstack >>call break ;
! Messages sent to walker thread
SYMBOL: step
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
- >r clone r>
- over continuation-call clone
- [
- dup innermost-frame-scan 1+
- swap innermost-frame-quot
- rot call
- ] keep
- [ set-innermost-frame-quot ] keep
- over set-continuation-call ; inline
+ >r clone r> [
+ >r clone r>
+ [
+ >r
+ [ innermost-frame-scan 1+ ]
+ [ innermost-frame-quot ] bi
+ r> call
+ ]
+ [ drop set-innermost-frame-quot ]
+ [ drop ]
+ 2tri
+ ] curry change-call ; inline
: step-msg ( continuation -- continuation' )
[
] change-frame ;
: step-out-msg ( continuation -- continuation' )
- [ nip \ break add ] change-frame ;
+ [ nip \ break suffix ] change-frame ;
{
{ call [ (step-into-quot) ] }
>n ndrop >c c>
continue continue-with
stop yield suspend sleep (spawn)
- suspend
} [
dup [ execute break ] curry
"step-into" set-word-prop
swap % unclip {
{ [ dup \ break eq? ] [ , ] }
{ [ dup quotation? ] [ add-breakpoint , \ break , ] }
+ { [ dup array? ] [ add-breakpoint , \ break , ] }
{ [ dup word? ] [ literalize , \ (step-into-execute) , ] }
- { [ t ] [ , \ break , ] }
+ [ , \ break , ]
} cond %
] [ ] make
] change-frame ;
{ step-back [ f ] }
{ f [ +stopped+ set-status f ] }
[
- dup walker-continuation tget set-model
- step-into-msg
+ [ walker-continuation tget set-model ]
+ [ step-into-msg ] bi
]
} case
] handle-synchronous
] [ ] while ;
: step-back-msg ( continuation -- continuation' )
- walker-history tget dup pop*
- empty? [ drop walker-history tget pop ] unless ;
+ walker-history tget
+ [ pop* ]
+ [ dup empty? [ drop ] [ nip pop ] if ] bi ;
: walker-suspended ( continuation -- continuation' )
+suspended+ set-status
TUPLE: avl-node balance ;
: <avl-node> ( key value -- node )
- swap <node> 0 avl-node construct-boa tuck set-delegate ;
+ swap <node> 0 avl-node boa tuck set-delegate ;
: change-balance ( node amount -- )
over avl-node-balance + swap set-avl-node-balance ;
avl-node-balance {
{ [ dup zero? ] [ 2drop 0 0 ] }
{ [ over = ] [ neg 0 ] }
- { [ t ] [ 0 swap ] }
+ [ 0 swap ]
} cond ;
: double-rotate ( node -- node )
current-side get over avl-node-balance {
{ [ dup zero? ] [ drop neg over set-avl-node-balance f ] }
{ [ dupd = ] [ drop 0 over set-avl-node-balance t ] }
- { [ t ] [ dupd neg change-balance rebalance-delete ] }
+ [ dupd neg change-balance rebalance-delete ]
} cond ;
: avl-replace-with-extremity ( to-replace node -- node shorter? )
--- /dev/null
+collections
2dup get-splay [ 2nip set-node-value ] [
drop dup inc-count
2dup splay-split rot
- >r >r swapd r> node construct-boa r> set-tree-root
+ >r >r swapd r> node boa r> set-tree-root
] if ;
: new-root ( value key tree -- )
-Splay Trees
+Splay trees
TUPLE: tree root count ;
: <tree> ( -- tree )
- f 0 tree construct-boa ;
+ f 0 tree boa ;
: construct-tree ( class -- tree )
- construct-empty <tree> over set-delegate ; inline
+ new <tree> over set-delegate ; inline
INSTANCE: tree tree-mixin
TUPLE: node key value left right ;
: <node> ( key value -- node )
- f f node construct-boa ;
+ f f node boa ;
SYMBOL: current-side
[ 2drop t ] }
{ [ >r 2nip r> [ tree-call ] 2keep rot ]
[ drop [ node-key ] keep node-value t ] }
- { [ t ] [ >r node-right r> find-node ] }
+ [ >r node-right r> find-node ]
} cond ; inline
M: tree-mixin assoc-find ( tree quot -- key value ? )
! Copyright (C) 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: splitting tuples classes math kernel sequences arrays ;
+USING: splitting classes.tuple classes math kernel sequences
+arrays ;
IN: tuple-arrays
TUPLE: tuple-array example ;
swap tuple>array length over length - ;
: <tuple-array> ( length example -- tuple-array )
- prepare-example [ rot * { } new ] keep
+ prepare-example [ rot * { } new-sequence ] keep
<sliced-groups> tuple-array construct-delegate
[ set-tuple-array-example ] keep ;
: reconstruct ( seq example -- tuple )
- swap append >tuple ;
+ prepend >tuple ;
M: tuple-array nth
[ delegate nth ] keep
tuck >r >r tuple-array-example deconstruct r> r>
delegate set-nth ;
-M: tuple-array new tuple-array-example >tuple <tuple-array> ;
+M: tuple-array new-sequence tuple-array-example >tuple <tuple-array> ;
: >tuple-array ( seq -- tuple-array/seq )
dup empty? [
USING: kernel sequences slots parser words classes
-slots.private ;
+slots.private mirrors ;
IN: tuple-syntax
! TUPLE: foo bar baz ;
! TUPLE{ foo bar: 1 baz: 2 }
-: parse-object ( -- object )
- scan-word dup parsing? [ V{ } clone swap execute first ] when ;
-
: parse-slot-writer ( tuple -- slot# )
scan dup "}" = [ 2drop f ] [
- 1 head* swap class "slots" word-prop
- [ slot-spec-name = ] with find nip slot-spec-offset
+ 1 head* swap object-slots slot-named slot-spec-offset
] if ;
: parse-slots ( accum tuple -- accum tuple )
dup parse-slot-writer
- [ parse-object pick rot set-slot parse-slots ] when* ;
+ [ scan-object pick rot set-slot parse-slots ] when* ;
: TUPLE{
- scan-word construct-empty parse-slots parsed ; parsing
+ scan-word new parse-slots parsed ; parsing
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: help.syntax help.markup kernel prettyprint sequences ;
-IN: tuples.lib
-
-HELP: >tuple<
-{ $values { "class" "a tuple class" } }
-{ $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." }
-{ $example
- "USING: kernel prettyprint tuples.lib ;"
- "TUPLE: foo a b c ;"
- "1 2 3 \\ foo construct-boa \\ foo >tuple< .s"
- "1\n2\n3"
-}
-{ $notes "Words using " { $snippet ">tuple<" } " may be compiled." }
-{ $see-also >tuple*< } ;
-
-HELP: >tuple*<
-{ $values { "class" "a tuple class" } }
-{ $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." }
-{ $example
- "USING: kernel prettyprint tuples.lib ;"
- "TUPLE: foo a bb* ccc dddd* ;"
- "1 2 3 4 \\ foo construct-boa \\ foo >tuple*< .s"
- "2\n4"
-}
-{ $notes "Words using " { $snippet ">tuple*<" } " may be compiled." }
-{ $see-also >tuple< } ;
-
+++ /dev/null
-USING: kernel tools.test tuples.lib ;
-IN: tuples.lib.tests
-
-TUPLE: foo a b* c d* e f* ;
-
-[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple< ] unit-test
-[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo construct-boa \ foo >tuple*< ] unit-test
-
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel macros sequences slots words ;
-IN: tuples.lib
-
-: reader-slots ( seq -- quot )
- [ slot-spec-reader ] map [ get-slots ] curry ;
-
-MACRO: >tuple< ( class -- )
- "slots" word-prop 1 tail-slice reader-slots ;
-
-MACRO: >tuple*< ( class -- )
- "slots" word-prop
- [ slot-spec-name "*" tail? ] subset
- reader-slots ;
-
-
TUPLE: turtle ;
: <turtle> ( -- turtle )
-turtle construct-empty
+turtle new
{ 0 0 0 } clone <pos>
3 identity-matrix <ori>
rot
! Two text transfer buffers
TUPLE: clipboard contents ;
-: <clipboard> "" clipboard construct-boa ;
+: <clipboard> "" clipboard boa ;
GENERIC: paste-clipboard ( gadget clipboard -- )
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math arrays cocoa cocoa.application command-line
kernel memory namespaces cocoa.messages cocoa.runtime
core-foundation threads ;
IN: ui.cocoa
-TUPLE: cocoa-ui-backend ;
+TUPLE: handle view window ;
+
+C: <handle> handle
+
+SINGLETON: cocoa-ui-backend
SYMBOL: stop-after-last-window?
dup rot world>NSRect <ViewWindow>
dup install-window-delegate
over -> release
- 2array
+ <handle>
] keep set-world-handle ;
M: cocoa-ui-backend set-title ( string world -- )
- world-handle second swap <NSString> -> setTitle: ;
+ world-handle handle-window swap <NSString> -> setTitle: ;
: enter-fullscreen ( world -- )
- world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ;
+ world-handle handle-view
+ NSScreen -> mainScreen
+ f -> enterFullScreenMode:withOptions:
+ drop ;
: exit-fullscreen ( world -- )
- world-handle first f -> exitFullScreenModeWithOptions: ;
+ world-handle handle-view f -> exitFullScreenModeWithOptions: ;
M: cocoa-ui-backend set-fullscreen* ( ? world -- )
swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
M: cocoa-ui-backend fullscreen* ( world -- ? )
- world-handle first -> isInFullScreenMode zero? not ;
+ world-handle handle-view -> isInFullScreenMode zero? not ;
: auto-position ( world -- )
dup world-loc { 0 0 } = [
- world-handle second -> center
+ world-handle handle-window -> center
] [
drop
] if ;
M: cocoa-ui-backend (open-window) ( world -- )
dup gadget-window
dup auto-position
- world-handle second f -> makeKeyAndOrderFront: ;
+ world-handle handle-window f -> makeKeyAndOrderFront: ;
M: cocoa-ui-backend (close-window) ( handle -- )
- first unregister-window ;
+ handle-window -> release ;
M: cocoa-ui-backend close-window ( gadget -- )
find-world [
- world-handle second f -> performClose:
+ world-handle [
+ handle-window f -> performClose:
+ ] when*
] when* ;
M: cocoa-ui-backend raise-window* ( world -- )
world-handle [
- second dup f -> orderFront: -> makeKeyWindow
+ handle-window dup f -> orderFront: -> makeKeyWindow
NSApp 1 -> activateIgnoringOtherApps:
] when* ;
M: cocoa-ui-backend select-gl-context ( handle -- )
- first -> openGLContext -> makeCurrentContext ;
+ handle-view -> openGLContext -> makeCurrentContext ;
M: cocoa-ui-backend flush-gl-context ( handle -- )
- first -> openGLContext -> flushBuffer ;
+ handle-view -> openGLContext -> flushBuffer ;
SYMBOL: cocoa-init-hook
] ui-running
] with-cocoa ;
-T{ cocoa-ui-backend } ui-backend set-global
+cocoa-ui-backend ui-backend set-global
[ running.app? "ui" "listener" ? ] main-vocab-hook set-global
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs cocoa kernel math cocoa.messages
cocoa.subclassing cocoa.classes cocoa.views cocoa.application
cocoa.pasteboard cocoa.types cocoa.windows sequences ui
ui.gadgets ui.gadgets.worlds ui.gestures core-foundation
-threads ;
+threads combinators ;
IN: ui.cocoa.views
: send-mouse-moved ( view event -- )
{ +name+ "FactorView" }
{ +protocols+ { "NSTextInput" } }
}
+
+! Rendering
+! Rendering
+{ "drawRect:" "void" { "id" "SEL" "id" "NSRect" }
+ [ 3drop window relayout-1 ]
+}
+
! Events
{ "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
[ 3drop 1 ]
[ [ nip T{ select-all-action } send-action$ ] ui-try ]
}
+! Multi-touch gestures: this is undocumented.
+! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
+{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaZ sgn {
+ { 1 [ T{ zoom-in-action } send-action$ ] }
+ { -1 [ T{ zoom-out-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+}
+
+{ "swipeWithEvent:" "void" { "id" "SEL" "id" }
+ [
+ nip
+ dup -> deltaX sgn {
+ { 1 [ T{ left-action } send-action$ ] }
+ { -1 [ T{ right-action } send-action$ ] }
+ { 0
+ [
+ dup -> deltaY sgn {
+ { 1 [ T{ up-action } send-action$ ] }
+ { -1 [ T{ down-action } send-action$ ] }
+ { 0 [ 2drop ] }
+ } case
+ ]
+ }
+ } case
+ ]
+}
+
+! "rotateWithEvent:" "void" { "id" "SEL" "id" }}
+
{ "acceptsFirstResponder" "bool" { "id" "SEL" }
[ 2drop 1 ]
}
{ "dealloc" "void" { "id" "SEL" }
[
drop
+ dup unregister-window
dup remove-observer
SUPER-> dealloc
]
{ "windowShouldClose:" "bool" { "id" "SEL" "id" }
[
- 2nip -> contentView window ungraft t
+ 3drop t
+ ]
+}
+
+{ "windowWillClose:" "void" { "id" "SEL" "id" }
+ [
+ 2nip -> object -> contentView window ungraft
]
} ;
: command-map. ( command-map -- )
[ command-map-row ] map
{ "Shortcut" "Command" "Word" "Notes" }
- [ \ $strong swap ] { } map>assoc add*
+ [ \ $strong swap ] { } map>assoc prefix
$table ;
: $command-map ( element -- )
SYMBOL: +listener+
SYMBOL: +description+
-PREDICATE: word listener-command +listener+ word-prop ;
+PREDICATE: listener-command < word +listener+ word-prop ;
GENERIC: invoke-command ( target command -- )
H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
: define-command ( word hash -- )
- default-flags swap union >r word-props r> update ;
+ [ word-props ] [ default-flags swap assoc-union ] bi* update ;
: command-quot ( target command -- quot )
dup 1quotation swap +nullary+ word-prop
\ freetype get-global expired? [ init-freetype ] when
\ freetype get-global ;
-TUPLE: font ascent descent height handle widths ;
-
-M: font equal? 2drop f ;
+TUPLE: font < identity-tuple
+ascent descent height handle widths ;
M: font hashcode* drop font hashcode* ;
} at ;
: ttf-path ( name -- string )
- "/fonts/" swap ".ttf" 3append resource-path ;
+ "resource:fonts/" swap ".ttf" 3append ;
: (open-face) ( path length -- face )
#! We use FT_New_Memory_Face, not FT_New_Face, since
TUPLE: border size fill ;
: <border> ( child gap -- border )
- dup 2array { 0 0 } border construct-boa
+ dup 2array { 0 0 } border boa
<gadget> over set-delegate
tuck add-gadget ;
<rect> ;
: scale-rect ( rect vec -- loc dim )
- [ v* ] curry >r rect-bounds r> 2apply ;
+ [ v* ] curry >r rect-bounds r> bi@ ;
: average-rects ( rect1 rect2 weight -- rect )
tuck >r >r scale-rect r> r> { 1 1 } swap v- scale-rect
ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render kernel math models namespaces sequences strings
-quotations assocs combinators classes colors tuples opengl
-math.vectors ;
+quotations assocs combinators classes colors classes.tuple
+opengl math.vectors ;
IN: ui.gadgets.buttons
TUPLE: button pressed? selected? quot ;
} set-gestures
: <button> ( gadget quot -- button )
- button construct-empty
+ button new
[ set-button-quot ] keep
[ set-gadget-delegate ] keep ;
{ [ dup button-pressed? ] [ drop button-paint-pressed ] }
{ [ dup button-selected? ] [ drop button-paint-selected ] }
{ [ dup button-rollover? ] [ drop button-paint-rollover ] }
- { [ t ] [ drop button-paint-plain ] }
+ [ drop button-paint-plain ]
} cond ;
M: button-paint draw-interior
: <repeat-button> ( label quot -- button )
#! Button that calls the quotation every 100ms as long as
#! the mouse is held down.
- repeat-button construct-empty
+ repeat-button new
[ >r <bevel-button> r> set-gadget-delegate ] keep ;
TUPLE: checkmark-paint color ;
! See http://factorcode.org/license.txt for BSD license.
USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib
ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
-tuples colors ;
+classes.tuple colors ;
IN: ui.gadgets.canvas
TUPLE: canvas dlist ;
dup editor-caret-color gl-color
dup caret-loc origin get v+
swap caret-dim over v+
- [ { 0.5 -0.5 } v+ ] 2apply gl-line
+ [ { 0.5 -0.5 } v+ ] bi@ gl-line
] when ;
: line-translation ( n -- loc )
--- /dev/null
+
+USING: kernel alien.c-types combinators sequences splitting
+ opengl.gl ui.gadgets ui.render
+ math math.vectors accessors ;
+
+IN: ui.gadgets.frame-buffer
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: frame-buffer action dim last-dim graft ungraft pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: init-frame-buffer-pixels ( frame-buffer -- frame-buffer )
+ dup
+ rect-dim product "uint[4]" <c-array>
+ >>pixels ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: <frame-buffer> ( -- frame-buffer )
+ frame-buffer construct-gadget
+ [ ] >>action
+ { 100 100 } >>dim
+ [ ] >>graft
+ [ ] >>ungraft ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: draw-pixels ( fb -- fb )
+ dup >r
+ dup >r
+ rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels
+ r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: read-pixels ( fb -- fb )
+ dup >r
+ dup >r
+ >r
+ 0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels
+ r> ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer pref-dim* dim>> ;
+M: frame-buffer graft* graft>> call ;
+M: frame-buffer ungraft* ungraft>> call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: copy-row ( old new -- )
+ 2dup min-length swap >r head-slice 0 r> copy ;
+
+! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
+! [ group ] 2bi@
+! [ copy-row ] 2each ;
+
+! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
+! [ 16 * group ] 2bi@
+! [ copy-row ] 2each ;
+
+: copy-pixels ( old-pixels old-width new-pixels new-width -- )
+ [ 16 * <sliced-groups> ] 2bi@
+ [ copy-row ] 2each ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer layout* ( fb -- )
+ {
+ {
+ [ dup last-dim>> f = ]
+ [
+ init-frame-buffer-pixels
+ dup
+ rect-dim >>last-dim
+ drop
+ ]
+ }
+ {
+ [ dup [ rect-dim ] [ last-dim>> ] bi = not ]
+ [
+ dup [ pixels>> ] [ last-dim>> first ] bi
+
+ rot init-frame-buffer-pixels
+ dup rect-dim >>last-dim
+
+ [ pixels>> ] [ rect-dim first ] bi
+
+ copy-pixels
+ ]
+ }
+ { [ t ] [ drop ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+M: frame-buffer draw-gadget* ( fb -- )
+
+ dup rect-dim { 0 1 } v* first2 glRasterPos2i
+
+ draw-pixels
+
+ dup action>> call
+
+ glFlush
+
+ read-pixels
+
+ drop ;
+
USING: help.syntax help.markup ui.gadgets kernel arrays
-quotations tuples ui.gadgets.grids ;
+quotations classes.tuple ui.gadgets.grids ;
IN: ui.gadgets.frames
: $ui-frame-constant ( element -- )
: @bottom-right 2 2 ;
: <frame> ( -- frame )
- frame construct-empty
+ frame new
<frame-grid> <grid> over set-gadget-delegate ;
: (fill-center) ( vec n -- )
USING: help.markup help.syntax opengl kernel strings
-tuples classes quotations models ;
+classes.tuple classes quotations models ;
IN: ui.gadgets
HELP: rect
IN: ui.gadgets.tests
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
-namespaces models kernel dlists math
+namespaces models kernel dlists math sets
math.parser ui sequences hashtables assocs io arrays
prettyprint io.streams.string ;
TUPLE: mock-gadget graft-called ungraft-called ;
: <mock-gadget>
- 0 0 mock-gadget construct-boa <gadget> over set-delegate ;
+ 0 0 mock-gadget boa <gadget> over set-delegate ;
M: mock-gadget graft*
dup mock-gadget-graft-called 1+
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
- [ rect-extent ] 2apply swapd ;
+ [ rect-extent ] bi@ swapd ;
: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
: rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ;
-TUPLE: gadget
+TUPLE: gadget < identity-tuple
pref-dim parent children orientation focus
-visible? root? clipped? layout-state graft-state
+visible? root? clipped? layout-state graft-state graft-node
interior boundary
model ;
-M: gadget equal? 2drop f ;
-
M: gadget hashcode* drop gadget hashcode* ;
M: gadget model-changed 2drop ;
: fast-children-on ( rect axis children -- from to )
3dup
>r >r dup rect-loc swap rect-dim v+
- r> r> (fast-children-on) [ 1+ ] [ 0 ] if*
+ r> r> (fast-children-on) ?1+
>r
>r >r rect-loc
r> r> (fast-children-on) 0 or
: graft-queue \ graft-queue get ;
: unqueue-graft ( gadget -- )
- dup graft-queue dlist-delete [ "Not queued" throw ] unless
+ graft-queue over gadget-graft-node delete-node
dup gadget-graft-state first { t t } { f f } ?
swap set-gadget-graft-state ;
+: (queue-graft) ( gadget flags -- )
+ over set-gadget-graft-state
+ dup graft-queue push-front* swap set-gadget-graft-node
+ notify-ui-thread ;
+
: queue-graft ( gadget -- )
- { f t } over set-gadget-graft-state
- graft-queue push-front notify-ui-thread ;
+ { f t } (queue-graft) ;
: queue-ungraft ( gadget -- )
- { t f } over set-gadget-graft-state
- graft-queue push-front notify-ui-thread ;
+ { t f } (queue-graft) ;
: graft-later ( gadget -- )
dup gadget-graft-state {
swap [ over (add-gadget) ] each relayout ;
: parents ( gadget -- seq )
- [ dup ] [ [ gadget-parent ] keep ] [ ] unfold nip ;
+ [ gadget-parent ] follow ;
: each-parent ( gadget quot -- ? )
>r parents r> all? ; inline
{
{ [ 2dup eq? ] [ 2drop t ] }
{ [ dup not ] [ 2drop f ] }
- { [ t ] [ gadget-parent child? ] }
+ [ gadget-parent child? ]
} cond ;
GENERIC: focusable-child* ( gadget -- child/t )
M: f request-focus-on 2drop ;
: request-focus ( gadget -- )
- dup focusable-child swap request-focus-on ;
+ [ focusable-child ] keep request-focus-on ;
: focus-path ( world -- seq )
- [ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ;
+ [ gadget-focus ] follow ;
: make-gadget ( quot gadget -- gadget )
[ \ make-gadget rot with-variable ] keep ; inline
grid-dim get spin set-axis ;
: draw-grid-lines ( gaps orientation -- )
- grid get rot grid-positions grid get rect-dim add [
+ grid get rot grid-positions grid get rect-dim suffix [
grid-line-from/to gl-line
] with each ;
[ { 100 200 } ] [
100x100
100x100
- [ 1array ] 2apply 2array <grid> pref-dim
+ [ 1array ] bi@ 2array <grid> pref-dim
] unit-test
[ ] [
100x100
100x100
- [ 1array ] 2apply 2array <grid> layout
+ [ 1array ] bi@ 2array <grid> layout
] unit-test
[ { 230 120 } { 100 100 } { 100 100 } ] [
! Copyright (C) 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences words io
-io.streams.string math.vectors ui.gadgets ;
+io.streams.string math.vectors ui.gadgets columns ;
IN: ui.gadgets.grids
TUPLE: grid children gap fill? ;
ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.tracks ui.gadgets.theme ui.gadgets.frames
ui.gadgets.grids io kernel math models namespaces prettyprint
-sequences sequences words tuples ui.gadgets ui.render colors ;
+sequences sequences words classes.tuple ui.gadgets ui.render
+colors ;
IN: ui.gadgets.labelled
TUPLE: labelled-gadget content ;
: <labelled-gadget> ( gadget title -- newgadget )
- labelled-gadget construct-empty
+ labelled-gadget new
[
<label> dup reverse-video-theme f track,
g-> set-labelled-gadget-content 1 track,
[ [ closable-gadget? ] is? ] find-parent ;
: <closable-gadget> ( gadget title quot -- gadget )
- closable-gadget construct-empty
+ closable-gadget new
[
<title-bar> @top frame,
g-> set-closable-gadget-content @center frame,
ui.gadgets.labels ui.gadgets.scrollers
kernel sequences models opengl math namespaces
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
-math.vectors tuples ;
+math.vectors classes.tuple ;
IN: ui.gadgets.lists
TUPLE: list index presenter color hook ;
swap set-list-index ;
: list-presentation-hook ( list -- quot )
- list-hook [ [ [ list? ] is? ] find-parent ] swap append ;
+ list-hook [ [ [ list? ] is? ] find-parent ] prepend ;
: <list-presentation> ( hook elt presenter -- gadget )
keep <presentation>
-USING: ui.gadgets help.markup help.syntax generic kernel tuples
-quotations ;
+USING: ui.gadgets help.markup help.syntax generic kernel
+classes.tuple quotations ;
IN: ui.gadgets.packs
HELP: pack
IN: ui.gadgets.panes.tests
USING: alien ui.gadgets.panes ui.gadgets namespaces
-kernel sequences io io.streams.string tools.test prettyprint
-definitions help help.syntax help.markup splitting
-tools.test.ui models ;
+kernel sequences io io.styles io.streams.string tools.test
+prettyprint definitions help help.syntax help.markup
+help.stylesheet splitting tools.test.ui models math inspector ;
: #children "pane" get gadget-children length ;
[ t ] [ #children "num-children" get = ] unit-test
: test-gadget-text
- dup make-pane gadget-text
- swap with-string-writer "\n" ?tail drop "\n" ?tail drop = ;
+ dup make-pane gadget-text dup print "======" print
+ swap with-string-writer dup print "\n" ?tail drop "\n" ?tail drop = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [ "hello" pprint ] with-nesting
+ ] test-gadget-text
+] unit-test
+[ t ] [
+ [
+ H{ { wrap-margin 100 } } [
+ H{ } [
+ "hello" pprint
+ ] with-style
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
[ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
+[ t ] [ [ \ + describe ] test-gadget-text ] unit-test
[ t ] [ [ \ = see ] test-gadget-text ] unit-test
[ t ] [ [ \ = help ] test-gadget-text ] unit-test
-ARTICLE: "test-article" "This is a test article"
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+
+[ t ] [
+ [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ "Hello world" write
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+[ t ] [
+ [
+ title-style get [
+ title-style get [
+ [ "Hello world" write ] ($block)
+ ] with-nesting
+ ] with-style
+ ] test-gadget-text
+] unit-test
+
+ARTICLE: "test-article-1" "This is a test article"
+"Hello world, how are you today." ;
+
+[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
+
+[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
+
+ARTICLE: "test-article-2" "This is a test article"
"Hello world, how are you today."
{ $table { "a" "b" } { "c" "d" } } ;
-[ t ] [ [ "test-article" help ] test-gadget-text ] unit-test
+[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
<pane> [ \ = see ] with-pane
<pane> [ \ = help ] with-pane
quotations math opengl combinators math.vectors
io.streams.duplex sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
-ui.gadgets.grid-lines tuples models continuations ;
+ui.gadgets.grid-lines classes.tuple models continuations ;
IN: ui.gadgets.panes
TUPLE: pane output current prototype scrolls?
selection-color swap set-pane-selection-color ;
: <pane> ( -- pane )
- pane construct-empty
+ pane new
<pile> over set-delegate
<shelf> over set-pane-prototype
<pile> <incremental> over add-output
dup gadget-children {
{ [ dup empty? ] [ 2drop "" <label> ] }
{ [ dup length 1 = ] [ nip first ] }
- { [ t ] [ drop ] }
+ [ drop ]
} cond ;
: smash-pane ( pane -- gadget ) pane-output smash-line ;
M: pane-stream stream-flush drop ;
M: pane-stream make-span-stream
- <style-stream> <ignore-close-stream> ;
+ swap <style-stream> <ignore-close-stream> ;
! Character styles
: sloppy-pick-up ( loc gadget -- path )
2dup sloppy-pick-up* dup
- [ [ wet-and-sloppy sloppy-pick-up ] keep add* ]
+ [ [ wet-and-sloppy sloppy-pick-up ] keep prefix ]
[ 3drop { } ]
if ;
IN: ui.gadgets.presentations.tests
USING: math ui.gadgets.presentations ui.gadgets tools.test
prettyprint ui.gadgets.buttons io io.streams.string kernel
-tuples ;
+classes.tuple ;
[ t ] [
"Hi" \ + <presentation> [ gadget? ] is?
dup presentation-object over show-summary button-update ;
: <presentation> ( label object -- button )
- presentation construct-empty
+ presentation new
[ drop ] over set-presentation-hook
[ set-presentation-object ] keep
swap [ invoke-primary ] <roll-button>
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gadgets
-ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids
-ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math
-namespaces sequences models combinators math.vectors ;
+USING: accessors arrays ui.gadgets ui.gadgets.viewports
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
+ui.gadgets.sliders ui.gestures kernel math namespaces sequences
+models combinators math.vectors classes.tuple ;
IN: ui.gadgets.scrollers
TUPLE: scroller viewport x y follows ;
: find-scroller ( gadget -- scroller/f )
- [ scroller? ] find-parent ;
+ [ [ scroller? ] is? ] find-parent ;
: scroll-up-page scroller-y -1 swap slide-by-page ;
2dup control-value = [ 2drop ] [ set-control-value ] if ;
: rect-min ( rect1 rect2 -- rect )
- >r [ rect-loc ] keep r> [ rect-dim ] 2apply vmin <rect> ;
+ >r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin <rect> ;
: (scroll>rect) ( rect scroller -- )
[
{ [ dup t eq? ] [ drop (scroll>bottom) ] }
{ [ dup rect? ] [ swap (scroll>rect) ] }
{ [ dup ] [ swap (scroll>gadget) ] }
- { [ t ] [ drop dup scroller-value swap scroll ] }
+ [ drop dup scroller-value swap scroll ]
} cond ;
M: scroller layout*
M: scroller model-changed
nip f swap set-scroller-follows ;
+
+TUPLE: limited-scroller dim ;
+
+: <limited-scroller> ( gadget -- scroller )
+ <scroller>
+ limited-scroller new
+ [ set-gadget-delegate ] keep ;
+
+M: limited-scroller pref-dim*
+ dim>> ;
IN: ui.gadgets.slate
-TUPLE: slate action dim graft ungraft ;
+TUPLE: slate action dim graft ungraft
+ button-down
+ button-up
+ key-down
+ key-up ;
: <slate> ( action -- slate )
slate construct-gadget
M: slate graft* ( slate -- ) slate-graft call ;
-M: slate ungraft* ( slate -- ) slate-ungraft call ;
\ No newline at end of file
+M: slate ungraft* ( slate -- ) slate-ungraft call ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: key-pressed-value
+
+: key-pressed? ( -- ? ) key-pressed-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: mouse-pressed-value
+
+: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: key-value
+
+: key ( -- key ) key-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYMBOL: button-value
+
+: button ( -- val ) button-value get ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: combinators ui.gestures accessors ;
+
+! M: slate handle-gesture* ( gadget gesture delegate -- ? )
+! drop nip
+! {
+! {
+! [ dup key-down? ]
+! [
+
+! key-down-sym key-value set
+! key-pressed-value on
+! t
+! ]
+! }
+! { [ dup key-up? ] [ drop key-pressed-value off t ] }
+! {
+! [ dup button-down? ]
+! [
+! button-down-# mouse-button-value set
+! mouse-pressed-value on
+! t
+! ]
+! }
+! { [ dup button-up? ] [ drop mouse-pressed-value off t ] }
+! { [ t ] [ drop t ] }
+! }
+! cond ;
+
+M: slate handle-gesture* ( gadget gesture delegate -- ? )
+ rot drop swap ! delegate gesture
+ {
+ {
+ [ dup key-down? ]
+ [
+ key-down-sym key-value set
+ key-pressed-value on
+ key-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup key-up? ]
+ [
+ key-pressed-value off
+ drop
+ key-up>> dup [ call ] [ drop ] if
+ t
+ ] }
+ {
+ [ dup button-down? ]
+ [
+ button-down-# button-value set
+ mouse-pressed-value on
+ button-down>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ {
+ [ dup button-up? ]
+ [
+ mouse-pressed-value off
+ drop
+ button-up>> dup [ call ] [ drop ] if
+ t
+ ]
+ }
+ { [ t ] [ 2drop t ] }
+ }
+ cond ;
\ No newline at end of file
} define-command
: <slot-editor> ( ref -- gadget )
- slot-editor construct-empty
+ slot-editor new
[ set-slot-editor-ref ] keep
[
toolbar,
} set-gestures
: <editable-slot> ( gadget ref -- editable-slot )
- editable-slot construct-empty
+ editable-slot new
{ 1 0 } <track> over set-gadget-delegate
[ drop <gadget> ] over set-editable-slot-printer
[ set-editable-slot-ref ] keep
USING: ui.gadgets.packs help.markup help.syntax ui.gadgets
-arrays kernel quotations tuples ;
+arrays kernel quotations classes.tuple ;
IN: ui.gadgets.tracks
HELP: track
ui.gadgets ui.gestures ui.render ui.backend inspector ;
IN: ui.gadgets.worlds
-TUPLE: world
+TUPLE: world < identity-tuple
active? focused?
glass
title status
t over set-gadget-root?
dup request-focus ;
-M: world equal? 2drop f ;
-
M: world hashcode* drop world hashcode* ;
-M: world pref-dim*
- delegate pref-dim* [ >fixnum ] map { 1024 768 } vmin ;
-
M: world layout*
dup delegate layout*
dup world-glass [
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs kernel math models namespaces
sequences words strings system hashtables math.parser
-math.vectors tuples classes ui.gadgets combinators.lib boxes
-calendar alarms symbols ;
+math.vectors classes.tuple classes ui.gadgets boxes
+calendar alarms symbols combinators sets columns ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
TUPLE: gain-focus ; C: <gain-focus> gain-focus
! Higher-level actions
-TUPLE: cut-action ; C: <cut-action> cut-action
-TUPLE: copy-action ; C: <copy-action> copy-action
-TUPLE: paste-action ; C: <paste-action> paste-action
-TUPLE: delete-action ; C: <delete-action> delete-action
-TUPLE: select-all-action ; C: <select-all-action> select-all-action
+TUPLE: cut-action ; C: <cut-action> cut-action
+TUPLE: copy-action ; C: <copy-action> copy-action
+TUPLE: paste-action ; C: <paste-action> paste-action
+TUPLE: delete-action ; C: <delete-action> delete-action
+TUPLE: select-all-action ; C: <select-all-action> select-all-action
+
+TUPLE: left-action ; C: <left-action> left-action
+TUPLE: right-action ; C: <right-action> right-action
+TUPLE: up-action ; C: <up-action> up-action
+TUPLE: down-action ; C: <down-action> down-action
+
+TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
+TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
: generalize-gesture ( gesture -- newgesture )
tuple>array 1 head* >tuple ;
TUPLE: key-down mods sym ;
: <key-gesture> ( mods sym action? class -- mods' sym' )
- >r [ S+ rot remove swap ] unless r> construct-boa ; inline
+ >r [ S+ rot remove swap ] unless r> boa ; inline
: <key-down> ( mods sym action? -- key-down )
key-down <key-gesture> ;
: multi-click? ( button -- ? )
{
- [ multi-click-timeout? ]
- [ multi-click-button? ]
- [ multi-click-position? ]
- [ multi-click-position? ]
- } && nip ;
+ { [ multi-click-timeout? not ] [ f ] }
+ { [ multi-click-button? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ { [ multi-click-position? not ] [ f ] }
+ [ t ]
+ } cond nip ;
: update-click# ( button -- )
global [
button-down-# [ " " % # ] when*
] "" make ;
+M: left-action gesture>string drop "Swipe left" ;
+
+M: right-action gesture>string drop "Swipe right" ;
+
+M: up-action gesture>string drop "Swipe up" ;
+
+M: down-action gesture>string drop "Swipe down" ;
+
+M: zoom-in-action gesture>string drop "Zoom in" ;
+
+M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
+
M: object gesture>string drop f ;
: my-pprint pprint ;
-[ drop t ] \ my-pprint [ ] [ ] f operation construct-boa "op" set
+[ drop t ] \ my-pprint [ ] [ ] f operation boa "op" set
[ [ 3 my-pprint ] ] [
3 "op" get operation-command command-quot
[ "3" ] [ [ 3 "op" get invoke-command ] with-string-writer ] unit-test
-[ drop t ] \ my-pprint [ ] [ editor-string ] f operation construct-boa
+[ drop t ] \ my-pprint [ ] [ editor-string ] f operation boa
"op" set
[ "\"4\"" ] [
set-operation-hook
} operation construct ;
-PREDICATE: operation listener-operation
+PREDICATE: listener-operation < operation
dup operation-command listener-command?
swap operation-listener? or ;
H{ { +keyboard+ f } { +primary+ f } { +secondary+ f } } ;
: define-operation ( pred command flags -- )
- default-flags swap union
+ default-flags swap assoc-union
dupd define-command <operation>
operations get push ;
{
{ [ dup gadget-visible? not ] [ drop ] }
{ [ dup gadget-clipped? not ] [ (draw-gadget) ] }
- { [ t ] [ [ (draw-gadget) ] with-clipping ] }
+ [ [ (draw-gadget) ] with-clipping ]
} cond ;
! Pen paint properties
swap set-browser-gadget-history ;
: <browser-gadget> ( -- gadget )
- browser-gadget construct-empty
+ browser-gadget new
dup init-history [
toolbar,
g <help-pane> g-> set-browser-gadget-pane
{ T{ key-down f { A+ } "v" } com-vocabularies }
{ T{ key-down f f "F1" } browser-help }
} define-command-map
+
+browser-gadget "multi-touch" f {
+ { T{ left-action } com-back }
+ { T{ right-action } com-forward }
+} define-command-map
] make-filled-pile ;
: <debugger> ( error restarts restart-hook -- gadget )
- debugger construct-empty
+ debugger new
[
toolbar,
<restart-list> g-> set-debugger-restarts
deploy-compiler? get "Use optimizing compiler" <checkbox> gadget,
deploy-math? get "Rational and complex number support" <checkbox> gadget,
deploy-threads? get "Threading support" <checkbox> gadget,
+ deploy-random? get "Random number generator support" <checkbox> gadget,
deploy-word-props? get "Retain all word properties" <checkbox> gadget,
deploy-word-defs? get "Retain all word definitions" <checkbox> gadget,
deploy-c-types? get "Retain all C types" <checkbox> gadget, ;
[
bundle-name
deploy-ui
- macosx? [ exit-when-windows-closed ] when
+ os macosx? [ exit-when-windows-closed ] when
io-settings
reflection-settings
advanced-settings
g <toolbar> { 10 10 } over set-pack-gap gadget, ;
: <deploy-gadget> ( vocab -- gadget )
- f deploy-gadget construct-boa [
+ f deploy-gadget boa [
dup <deploy-settings>
g-> set-deploy-gadget-settings gadget,
buttons,
] with-pane ;
: <inspector-gadget> ( -- gadget )
- inspector-gadget construct-empty
+ inspector-gadget new
[
toolbar,
<pane> g-> set-inspector-gadget-pane <scroller> 1 track,
{ T{ key-down f f "F1" } inspector-help }
} define-command-map
+inspector-gadget "multi-touch" f {
+ { T{ left-action } &back }
+} define-command-map
+
M: inspector-gadget tool-scroller
inspector-gadget-pane find-scroller ;
IN: ui.tools.interactor.tests
-USING: ui.tools.interactor tools.test ;
+USING: ui.tools.interactor ui.gadgets.panes namespaces
+ui.gadgets.editors concurrency.promises threads listener
+tools.test kernel calendar parser ;
-\ <interactor> must-infer
+[
+ \ <interactor> must-infer
+
+ [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+ [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
+
+ [ ] [ <promise> "promise" set ] unit-test
+
+ [
+ "interactor" get stream-read-quot "promise" get fulfill
+ ] "Interactor test" spawn drop
+
+ ! This should not throw an exception
+ [ ] [ "interactor" get evaluate-input ] unit-test
+
+ [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
+
+ [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
+
+ [ ] [ "interactor" get evaluate-input ] unit-test
+
+ [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
+] with-interactive-vocabs
USING: arrays assocs combinators continuations documents
hashtables io io.styles kernel math
math.vectors models namespaces parser prettyprint quotations
-sequences sequences.lib strings threads listener
-tuples ui.commands ui.gadgets ui.gadgets.editors
+sequences strings threads listener
+classes.tuple ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions boxes calendar concurrency.flags ui.tools.workspace ;
+definitions boxes calendar concurrency.flags ui.tools.workspace
+accessors ;
IN: ui.tools.interactor
TUPLE: interactor history output flag thread help ;
] curry "input" suspend ;
M: interactor stream-readln
- [ interactor-yield ] keep interactor-finish ?first ;
+ [ interactor-yield ] keep interactor-finish
+ dup [ first ] when ;
: interactor-call ( quot interactor -- )
dup interactor-busy? [
stream-read ;
: go-to-error ( interactor error -- )
- dup parse-error-line 1- swap parse-error-col 2array
+ [ line>> 1- ] [ column>> ] bi 2array
over set-caret
mark>caret ;
: handle-parse-error ( interactor error -- )
- dup parse-error? [ 2dup go-to-error delegate ] when
+ dup parse-error? [ 2dup go-to-error error>> ] when
swap find-workspace debugger-popup ;
: try-parse ( lines interactor -- quot/error/f )
drop parse-lines-interactive
] [
2nip
- dup delegate unexpected-eof? [ drop f ] when
+ dup parse-error? [
+ dup error>> unexpected-eof? [ drop f ] when
+ ] when
] recover ;
: handle-interactive ( lines interactor -- quot/f ? )
tuck try-parse {
{ [ dup quotation? ] [ nip t ] }
{ [ dup not ] [ drop "\n" swap user-input f f ] }
- { [ t ] [ handle-parse-error f f ] }
+ [ handle-parse-error f f ]
} cond ;
M: interactor stream-read-quot
[ interactor-yield ] keep {
{ [ over not ] [ drop ] }
{ [ over callable? ] [ drop ] }
- { [ t ] [
+ [
[ handle-interactive ] keep swap
[ interactor-finish ] [ nip stream-read-quot ] if
- ] }
+ ]
} cond ;
M: interactor pref-dim*
ui.tools.listener hashtables kernel namespaces parser sequences
tools.test ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.panes vocabs words tools.test.ui slots.private
-threads ;
+threads arrays generic ;
IN: ui.tools.listener.tests
[ f ] [ "word" source-editor command-map empty? ] unit-test
"listener" get [
[ "dup" ] [
- \ dup "listener" get word-completion-string
+ \ dup word-completion-string
] unit-test
- [ "USE: slots.private slot" ]
- [ \ slot "listener" get word-completion-string ] unit-test
+ [ "equal?" ]
+ [ \ array \ equal? method word-completion-string ] unit-test
<pane> <interactor> "i" set
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: inspector ui.tools.interactor ui.tools.inspector
ui.tools.workspace help.markup io io.streams.duplex io.styles
ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words
-prettyprint listener debugger threads boxes concurrency.flags ;
+prettyprint listener debugger threads boxes concurrency.flags
+math arrays generic accessors combinators ;
IN: ui.tools.listener
TUPLE: listener-gadget input output stack ;
: listener-input, ( -- )
g <listener-input> g-> set-listener-gadget-input
- <scroller> "Input" <labelled-gadget> f track, ;
+ <limited-scroller> { 0 100 } >>dim
+ "Input" <labelled-gadget> f track, ;
: welcome. ( -- )
"If this is your first time with Factor, please read the " print
: clear-stack ( listener -- )
[ clear ] swap (call-listener) ;
-: word-completion-string ( word listener -- string )
- >r dup word-name swap word-vocabulary dup vocab-words r>
- listener-gadget-input interactor-use memq?
- [ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
+GENERIC: word-completion-string ( word -- string )
+
+M: word word-completion-string
+ word-name ;
+
+M: method-body word-completion-string
+ "method-generic" word-prop word-completion-string ;
+
+USE: generic.standard.engines.tuple
+
+M: engine-word word-completion-string
+ "engine-generic" word-prop word-completion-string ;
+
+: use-if-necessary ( word seq -- )
+ >r word-vocabulary vocab-words r>
+ {
+ { [ dup not ] [ 2drop ] }
+ { [ 2dup memq? ] [ 2drop ] }
+ [ push ]
+ } cond ;
: insert-word ( word -- )
- get-workspace
- workspace-listener
- [ word-completion-string ] keep
- listener-gadget-input user-input ;
+ get-workspace workspace-listener input>>
+ [ >r word-completion-string r> user-input ]
+ [ interactor-use use-if-necessary ]
+ 2bi ;
: quot-action ( interactor -- lines )
dup control-value
TUPLE: stack-display ;
: <stack-display> ( -- gadget )
- stack-display construct-empty
+ stack-display new
g workspace-listener swap [
dup <toolbar> f track,
listener-gadget-stack [ stack. ]
f <model> swap set-listener-gadget-stack ;
: <listener-gadget> ( -- gadget )
- listener-gadget construct-empty dup init-listener
+ listener-gadget new dup init-listener
[ listener-output, listener-input, ] { 0 1 } build-track ;
: listener-help "ui-listener" help-window ;
TUPLE: profiler-gadget pane ;
: <profiler-gadget> ( -- gadget )
- profiler-gadget construct-empty
+ profiler-gadget new
[
toolbar,
<pane> g-> set-profiler-gadget-pane
ui.tools.workspace help help.topics io.files io.styles kernel
models namespaces prettyprint quotations sequences sorting
source-files definitions strings tools.completion tools.crossref
-tuples ui.commands ui.gadgets ui.gadgets.editors
+classes.tuple ui.commands ui.gadgets ui.gadgets.editors
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
ui.gestures ui.operations vocabs words vocabs.loader
tools.vocabs unicode.case calendar ui ;
swap <list> ;
: <live-search> ( string seq limited? presenter -- gadget )
- live-search construct-empty
+ live-search new
[
<search-field> g-> set-live-search-field f track,
<search-list> g-> set-live-search-list
parser prettyprint tools.profiler tools.walker ui.commands
ui.gadgets.editors ui.gadgets.panes ui.gadgets.presentations
ui.gadgets.slots ui.operations ui.tools.browser
-ui.tools.interactor ui.tools.listener ui.tools.operations
-ui.tools.profiler ui.tools.walker ui.tools.workspace vocabs ;
+ui.tools.interactor ui.tools.inspector ui.tools.listener
+ui.tools.operations ui.tools.profiler ui.tools.walker
+ui.tools.workspace vocabs ;
IN: ui.tools
ARTICLE: "ui-presentations" "Presentations in the UI"
$nl
"The slot editor has a toolbar containing various commands."
{ $command-map slot-editor "toolbar" }
+{ $command-map inspector-gadget "multi-touch" }
"The following commands are also available."
{ $command-map source-editor "word" } ;
ARTICLE: "ui-browser" "UI browser"
"The browser is used to display Factor code, documentation, and vocabularies."
{ $command-map browser-gadget "toolbar" }
+{ $command-map browser-gadget "multi-touch" }
"Browsers are instances of " { $link browser-gadget } "." ;
ARTICLE: "ui-profiler" "UI profiler"
{ $command-map workspace "tool-switching" }
{ $command-map workspace "scrolling" }
{ $command-map workspace "workflow" }
+{ $command-map workspace "multi-touch" }
{ $heading "Implementation" }
"Workspaces are instances of " { $link workspace } "." ;
{ T{ key-down f { A+ } "4" } com-profiler }
} define-command-map
+workspace "multi-touch" f {
+ { T{ zoom-out-action } com-listener }
+ { T{ up-action } refresh-all }
+} define-command-map
+
\ workspace-window
H{ { +nullary+ t } } define-command
: <variables-gadget> ( model -- gadget )
<namestack-display> <scroller>
- variables-gadget construct-empty
+ variables-gadget new
[ set-gadget-delegate ] keep ;
M: variables-gadget pref-dim* drop { 400 400 } ;
IN: ui.tools.walker\r
USING: help.markup help.syntax ui.commands ui.operations\r
-tools.walker ;\r
+ui.render tools.walker sequences ;\r
+\r
+ARTICLE: "ui-walker-step" "Stepping through code"\r
+"If the current position points to a word, the various stepping commands behave as follows:"\r
+{ $list\r
+ { { $link com-step } " executes the word and moves the current position one word further." }\r
+ { { $link com-into } " enters the word's definition, unless it is a primitive, in which case it behaves like " { $link com-step } "." }\r
+ { { $link com-out } " executes until the end of the current quotation." }\r
+}\r
+"If the current position points to a literal, the various stepping commands behave as follows:"\r
+{ $list\r
+ { { $link com-step } " pushes the literal on the data stack." }\r
+ { { $link com-into } " pushes the literal. If it is a quotation, a breakpoint is inserted at the beginning of the quotation, and if it is an array of quotations, a breakpoint is inserted at the beginning of each quotation element." }\r
+ { { $link com-out } " executes until the end of the current quotation." }\r
+}\r
+"The behavior of the " { $link com-into } " command is useful when debugging code using combinators. Instead of stepping into the definition of a combinator, which may be quite complex, you can set a breakpoint on the quotation and continue. For example, suppose the following quotation is being walked:"\r
+{ $code "{ 10 20 30 } [ 3 + . ] each" }\r
+"If the current position is on the quotation and " { $link com-into } " is invoked, the following quotation is pushed on the stack:"\r
+{ $code "[ break 3 + . ]" }\r
+"Invoking " { $link com-continue } " will continue execution until the breakpoint is hit, which in this case happens immediately. The stack can then be inspected to verify that the first element of the array, 10, was pushed. Invoking " { $link com-continue } " proceeds until the breakpoint is hit on the second iteration, at which time the top of the stack will contain the value 20. Invoking " { $link com-continue } " a third time will proceed on to the final iteration where 30 is at the top of the stack. Invoking " { $link com-continue } " again will end the walk of this code snippet, since no more iterations remain the quotation will never be called again and the breakpoint will not be hit."\r
+$nl\r
+"The " { $link com-back } " command travels backwards through time, and restore stacks. This does not undo side effects (modifying array entries, writing to files, formatting the hard drive, etc) and therefore can only be used reliably on referentially transparent code." ;\r
+\r
+ARTICLE: "breakpoints" "Setting breakpoints"\r
+"In addition to invoking the walker explicitly through the UI, it is possible to set breakpoints on words. See " { $link "tools.annotations" } "."\r
+$nl\r
+"Breakpoints can be inserted directly into code:"\r
+{ $subsection break }\r
+"Note that because the walker calls various core library and UI words while rendering its own user interface, setting a breakpoint on a word such as " { $link append } " or " { $link draw-gadget } " will hang the UI." ;\r
\r
ARTICLE: "ui-walker" "UI walker"\r
"The walker single-steps through quotations. To use the walker, enter a piece of code in the listener's input area and press " { $operation walk } "."\r
$nl\r
-"The walker can travel backwards through time, and restore stacks. This does not undo side effects and therefore can only be used reliably on referentially transparent code."\r
-{ $command-map walker-gadget "toolbar" }\r
-"Walkers are instances of " { $link walker-gadget } "." ;\r
+"Walkers are instances of " { $link walker-gadget } "."\r
+{ $subsection "ui-walker-step" }\r
+{ $subsection "breakpoints" }\r
+{ $command-map walker-gadget "toolbar" } ;\r
+\r
+ABOUT: "ui-walker"\r
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
ui.gadgets.tracks ui.commands ui.gadgets models
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
-namespaces tools.walker assocs combinators combinators.cleave ;
+namespaces tools.walker assocs combinators ;
IN: ui.tools.walker
TUPLE: walker-gadget
[ walker-state-string ] curry <filter> <label-control> ;
: <walker-gadget> ( status continuation thread -- gadget )
- over <traceback-gadget> f walker-gadget construct-boa [
+ over <traceback-gadget> f walker-gadget boa [
toolbar,
g walker-gadget-status self <thread-status> f track,
g walker-gadget-traceback 1 track,
{
{ [ dup walker-gadget? not ] [ 2drop f ] }
{ [ dup walker-gadget-closing? ] [ 2drop f ] }
- { [ t ] [ walker-gadget-thread eq? ] }
+ [ walker-gadget-thread eq? ]
} cond ;
: find-walker-window ( thread -- world/f )
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
-ui.commands ui.gestures assocs arrays namespaces ;
+ui.commands ui.gestures assocs arrays namespaces accessors ;
IN: ui.tools.workspace
TUPLE: workspace book listener popup ;
get-workspace find-tool nip ;
: help-window ( topic -- )
- [ <pane> [ [ help ] with-pane ] keep <scroller> ] keep
+ [
+ <pane> [ [ help ] with-pane ] keep
+ <limited-scroller> { 550 700 } >>dim
+ ] keep
article-title open-window ;
: hide-popup ( workspace -- )
: traverse-step ( path gadget -- path' gadget' )
>r unclip r> gadget-children ?nth ;
-: make-node ( quot -- ) { } make node construct-boa , ; inline
+: make-node ( quot -- ) { } make node boa , ; inline
: traverse-to-path ( topath gadget -- )
dup not [
{ [ pick empty? ] [ rot drop traverse-to-path ] }
{ [ over empty? ] [ nip traverse-from-path ] }
{ [ pick first pick first = ] [ traverse-child ] }
- { [ t ] [ traverse-middle ] }
+ [ traverse-middle ]
} cond ;
: gadget-subtree ( frompath topath gadget -- seq )
prettyprint dlists sequences threads sequences words
debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
ui.gestures ui.backend ui.render continuations init combinators
-hashtables concurrency.flags ;
+hashtables concurrency.flags sets ;
IN: ui
! Assoc mapping aliens to gadgets
! Copyright (C) 2005, 2006 Doug Coleman.
+! Portions copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays assocs ui ui.gadgets
-ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
-math math.vectors namespaces prettyprint sequences strings
-vectors words windows.kernel32 windows.gdi32 windows.user32
-windows.opengl32 windows.messages windows.types windows.nt
-windows threads libc combinators continuations command-line
-shuffle opengl ui.render unicode.case ascii math.bitfields
-locals symbols ;
+USING: alien alien.c-types alien.strings arrays assocs ui
+ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
+ui.gestures io kernel math math.vectors namespaces prettyprint
+sequences strings vectors words windows.kernel32 windows.gdi32
+windows.user32 windows.opengl32 windows.messages windows.types
+windows.nt windows threads libc combinators continuations
+command-line shuffle opengl ui.render unicode.case ascii
+math.bitfields locals symbols accessors ;
IN: ui.windows
-TUPLE: windows-ui-backend ;
+SINGLETON: windows-ui-backend
: crlf>lf CHAR: \r swap remove ;
: lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
CF_UNICODETEXT GetClipboardData dup win32-error=0/f
dup GlobalLock dup win32-error=0/f
GlobalUnlock win32-error=0/f
- alien>u16-string
+ utf16n alien>string
] if
] with-clipboard
crlf>lf ;
: copy ( str -- )
lf>crlf [
- string>u16-alien
+ utf16n string>alien
EmptyClipboard win32-error=0/f
GMEM_MOVEABLE over length 1+ GlobalAlloc
dup win32-error=0/f
wParam keystroke>gesture <key-up>
hWnd window-focus send-gesture drop ;
+: set-window-active ( hwnd uMsg wParam lParam ? -- n )
+ >r 4dup r> 2nip nip
+ swap window set-world-active? DefWindowProc ;
+
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
- dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;
+ {
+ { [ over SC_MINIMIZE = ] [ f set-window-active ] }
+ { [ over SC_RESTORE = ] [ t set-window-active ] }
+ { [ over SC_MAXIMIZE = ] [ t set-window-active ] }
+ { [ dup alpha? ] [ 4drop 0 ] }
+ { [ t ] [ DefWindowProc ] }
+ } cond ;
: cleanup-window ( handle -- )
dup win-title [ free ] when*
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
-! ! ! !
-: set-world-dim ( dim world -- )
- swap >r world-handle win-hWnd HWND_TOP 20 20 r> first2 0
- SetWindowPos drop ;
-USE: random
-USE: arrays
-
-: twiddle
- 100 500 random +
- 100 500 random +
- 2array
- "x" get-global find-world
- set-world-dim
- yield ;
-! ! ! !
-
: event-loop ( msg -- )
{
{ [ windows get empty? ] [ drop ] }
{ [ dup peek-message? ] [ ui-wait event-loop ] }
{ [ dup MSG-message WM_QUIT = ] [ drop ] }
- { [ t ] [
+ [
dup TranslateMessage drop
dup DispatchMessage drop
event-loop
- ] }
+ ]
} cond ;
: register-wndclassex ( -- class )
0 over set-WNDCLASSEX-cbClsExtra
0 over set-WNDCLASSEX-cbWndExtra
f GetModuleHandle over set-WNDCLASSEX-hInstance
- f GetModuleHandle "fraptor" string>u16-alien LoadIcon
+ f GetModuleHandle "fraptor" utf16n string>alien LoadIcon
over set-WNDCLASSEX-hIcon
f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
: init-win32-ui ( -- )
V{ } clone nc-buttons set-global
"MSG" malloc-object msg-obj set-global
- "Factor-window" malloc-u16-string class-name-ptr set-global
+ "Factor-window" utf16n malloc-string class-name-ptr set-global
register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ;
M: windows-ui-backend set-title ( string world -- )
world-handle
dup win-title [ free ] when*
- >r malloc-u16-string r>
+ >r utf16n malloc-string r>
2dup set-win-title
win-hWnd WM_SETTEXT 0 roll alien-address SendMessage drop ;
] [ cleanup-win32-ui ] [ ] cleanup
] ui-running ;
-T{ windows-ui-backend } ui-backend set-global
+windows-ui-backend ui-backend set-global
[ "ui" ] main-vocab-hook set-global
! Copyright (C) 2005, 2007 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays ui ui.gadgets ui.gestures
-ui.backend ui.clipboards ui.gadgets.worlds assocs kernel math
-namespaces opengl sequences strings x11.xlib x11.events x11.xim
-x11.glx x11.clipboard x11.constants x11.windows io.encodings.string
-io.encodings.utf8 combinators debugger system command-line
-ui.render math.vectors tuples opengl.gl threads ;
+ui.backend ui.clipboards ui.gadgets.worlds ui.render assocs
+kernel math namespaces opengl sequences strings x11.xlib
+x11.events x11.xim x11.glx x11.clipboard x11.constants
+x11.windows io.encodings.string io.encodings.ascii
+io.encodings.utf8 combinators debugger command-line qualified
+math.vectors classes.tuple opengl.gl threads ;
+QUALIFIED: system
IN: ui.x11
-TUPLE: x11-ui-backend ;
+SINGLETON: x11-ui-backend
: XA_NET_WM_NAME "_NET_WM_NAME" x-atom ;
{
{ [ dup XA_PRIMARY = ] [ drop selection get ] }
{ [ dup XA_CLIPBOARD = ] [ drop clipboard get ] }
- { [ t ] [ drop <clipboard> ] }
+ [ drop <clipboard> ]
} cond ;
: encode-clipboard ( string type -- bytes )
- XSelectionRequestEvent-target XA_UTF8_STRING =
- [ utf8 encode ] [ string>char-alien ] if ;
+ XSelectionRequestEvent-target
+ XA_UTF8_STRING = utf8 ascii ? encode ;
: set-selection-prop ( evt -- )
dpy get swap
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
{ [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
{ [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
- { [ t ] [ drop send-notify-failure ] }
+ [ drop send-notify-failure ]
} cond ;
M: x11-ui-backend (close-window) ( handle -- )
] with-x
] ui-running ;
-T{ x11-ui-backend } ui-backend set-global
+x11-ui-backend ui-backend set-global
-[ "DISPLAY" os-env "ui" "listener" ? ]
+[ "DISPLAY" system:os-env "ui" "listener" ? ]
main-vocab-hook set-global
USING: unicode.categories kernel math combinators splitting
sequences math.parser io.files io assocs arrays namespaces
-combinators.lib assocs.lib math.ranges unicode.normalize
+math.ranges unicode.normalize
unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ;
IN: unicode.breaks
} case ;
: trim-blank ( str -- newstr )
- dup [ blank? not ] find-last 1+* head ;
+ [ blank? ] right-trim ;
: process-other-extend ( lines -- set )
[ "#" split1 drop ";" split1 drop trim-blank ] map
[ empty? not ] subset
- [ ".." split1 [ dup ] unless* [ hex> ] 2apply [a,b] ] map
- concat >set ;
+ [ ".." split1 [ dup ] unless* [ hex> ] bi@ [a,b] ] map
+ concat [ dup ] H{ } map>assoc ;
: other-extend-lines ( -- lines )
"extra/unicode/PropList.txt" resource-path ascii file-lines ;
CATEGORY: (extend) Me Mn ;
: extend? ( ch -- ? )
- [ (extend)? ] [ other-extend key? ] either ;
+ dup (extend)? [ ] [ other-extend key? ] ?if ;
: grapheme-class ( ch -- class )
{
{ [ dup jamo? ] [ jamo-class ] }
{ [ dup grapheme-control? ] [ control-class ] }
{ [ extend? ] [ Extend ] }
- { [ t ] [ Any ] }
+ [ Any ]
} cond ;
: init-grapheme-table ( -- table )
grapheme-table nth nth not ;
: chars ( i str n -- str[i] str[i+n] )
- swap >r dupd + r> [ ?nth ] curry 2apply ;
+ swap >r dupd + r> [ ?nth ] curry bi@ ;
: find-index ( seq quot -- i ) find drop ; inline
: find-last-index ( seq quot -- i ) find-last drop ; inline
: last-grapheme ( str -- i )
unclip-last-slice grapheme-class swap
- [ grapheme-class dup rot grapheme-break? ] find-last-index
- nip -1 or 1+ ;
+ [ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
[
other-extend-lines process-other-extend \ other-extend set-value
USING: kernel unicode.data sequences sequences.next namespaces
-assocs.lib unicode.normalize math unicode.categories combinators
+unicode.normalize math unicode.categories combinators
assocs strings splitting ;
IN: unicode.case
+: at-default ( key assoc -- value/key ) over >r at r> or ;
+
: ch>lower ( ch -- lower ) simple-lower at-default ;
: ch>upper ( ch -- upper ) simple-upper at-default ;
: ch>title ( ch -- title ) simple-title at-default ;
drop dot-over =
dup CHAR: i HEX: 131 ? ,
] }
- { [ t ] [ , drop f ] }
+ [ , drop f ]
} cond ;
: turk>lower ( string -- lower-i )
>upper >lower ;
: insensitive= ( str1 str2 -- ? )
- [ >case-fold ] 2apply = ;
+ [ >case-fold ] bi@ = ;
: lower? ( string -- ? )
dup >lower = ;
USING: assocs math kernel sequences io.files hashtables
-quotations splitting arrays math.parser combinators.lib hash2
+quotations splitting arrays math.parser hash2
byte-arrays words namespaces words compiler.units parser io.encodings.ascii ;
IN: unicode.data
>>
! Convenience functions
-: 1+* ( n/f _ -- n+1 )
- drop [ 1+ ] [ 0 ] if* ;
-
: ?between? ( n/f from to -- ? )
pick [ between? ] [ 3drop f ] if ;
dup [ swap (chain-decomposed) ] curry assoc-map ;
: first* ( seq -- ? )
- second [ empty? ] [ first ] either ;
+ second dup empty? [ ] [ first ] ?if ;
: (process-decomposed) ( data -- alist )
5 swap (process-data)
dup process-names \ name-map set-value
13 over process-data \ simple-lower set-value
12 over process-data tuck \ simple-upper set-value
-14 over process-data swapd union \ simple-title set-value
+14 over process-data swapd assoc-union \ simple-title set-value
dup process-combining \ class-map set-value
dup process-canonical \ canonical-map set-value
\ combine-map set-value
-USING: sequences namespaces unicode.data kernel combinators.lib
-math arrays ;
+USING: sequences namespaces unicode.data kernel math arrays ;
IN: unicode.normalize
! Conjoining Jamo behavior
! These numbers come from UAX 29
: initial? ( ch -- ? )
- [ HEX: 1100 HEX: 1159 ?between? ] [ HEX: 115F = ] either ;
+ dup HEX: 1100 HEX: 1159 ?between? [ ] [ HEX: 115F = ] ?if ;
: medial? ( ch -- ? ) HEX: 1160 HEX: 11A2 ?between? ;
: final? ( ch -- ? ) HEX: 11A8 HEX: 11F9 ?between? ;
: (insert) ( seq n quot -- )
over 0 = [ 3drop ] [
- [ >r dup 1- rot [ nth ] curry 2apply r> 2apply > ] 3keep
+ [ >r dup 1- rot [ nth ] curry bi@ r> bi@ > ] 3keep
roll [ 3drop ]
[ >r [ dup 1- rot exchange ] 2keep 1- r> (insert) ] if
] if ; inline
0 reorder-loop ;
: reorder-back ( string i -- )
- over [ non-starter? not ] find-last* 1+* reorder-next 2drop ;
+ over [ non-starter? not ] find-last* drop ?1+ reorder-next 2drop ;
: decompose ( string quot -- decomposed )
! When there are 8 and 32-bit strings, this'll be
] [ ] make ;
: define-category ( word categories -- )
- [category] fixnum -rot define-predicate-class ;
+ [category] integer swap define-predicate-class ;
: CATEGORY:
CREATE ";" parse-tokens define-category ; parsing
[ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test
[ t ] [ 3 m d-recip 1/3 { } { m } <dimensioned> = ] unit-test
-! I want these to work, Dan
-
: km/L km 1 L d/ ;
: mpg miles 1 gallons d/ ;
-! [ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test
+[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test
USING: arrays io kernel math namespaces splitting prettyprint
sequences sorting vectors words inverse inspector shuffle
-math.functions ;
+math.functions sets ;
IN: units
TUPLE: dimensioned value top bot ;
TUPLE: dimensions-not-equal ;
: dimensions-not-equal ( -- * )
- \ dimensions-not-equal construct-empty throw ;
+ \ dimensions-not-equal new throw ;
M: dimensions-not-equal summary drop "Dimensions do not match" ;
1array split1 append ;
: 2remove-one ( seq seq obj -- seq seq )
- [ remove-one ] curry 2apply ;
+ [ remove-one ] curry bi@ ;
: symbolic-reduce ( seq seq -- seq seq )
- 2dup seq-intersect dup empty?
+ 2dup intersect dup empty?
[ drop ] [ first 2remove-one symbolic-reduce ] if ;
: <dimensioned> ( n top bot -- obj )
symbolic-reduce
- [ natural-sort ] 2apply
- dimensioned construct-boa ;
+ [ natural-sort ] bi@
+ dimensioned boa ;
: >dimensioned< ( d -- n top bot )
{ dimensioned-value dimensioned-top dimensioned-bot }
{ dimensioned-top dimensioned-bot } get-slots ;
: check-dimensions ( d d -- )
- [ dimensions 2array ] 2apply =
+ [ dimensions 2array ] bi@ =
[ dimensions-not-equal ] unless ;
-: 2values [ dimensioned-value ] 2apply ;
+: 2values [ dimensioned-value ] bi@ ;
: <dimension-op
2dup check-dimensions dup dimensions 2swap 2values ;
{ } { } <dimensioned> ;
: d* ( d d -- d )
- [ dup number? [ scalar ] when ] 2apply
- [ [ dimensioned-top ] 2apply append ] 2keep
- [ [ dimensioned-bot ] 2apply append ] 2keep
+ [ dup number? [ scalar ] when ] bi@
+ [ [ dimensioned-top ] bi@ append ] 2keep
+ [ [ dimensioned-bot ] bi@ append ] 2keep
2values * dimension-op> ;
: d-neg ( d -- d ) -1 d* ;
: d-infimum ( v -- d ) unclip-slice [ d-min ] reduce ;
: d-supremum ( v -- d ) unclip-slice [ d-max ] reduce ;
+
+\ d+ [ d- ] [ d- ] define-math-inverse
+\ d- [ d+ ] [ d- ] define-math-inverse
+\ d* [ d/ ] [ d/ ] define-math-inverse
+\ d/ [ d* ] [ d/ ] define-math-inverse
+\ d-recip [ d-recip ] define-inverse
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax combinators system vocabs.loader ;
IN: unix
-USING: alien.syntax ;
! FreeBSD
: O_TRUNC HEX: 0400 ; inline
: O_EXCL HEX: 0800 ; inline
-: FD_SETSIZE 1024 ; inline
-
: SOL_SOCKET HEX: ffff ; inline
: SO_REUSEADDR HEX: 4 ; inline
: SO_OOBINLINE HEX: 100 ; inline
: F_SETFL 4 ; inline
: O_NONBLOCK 4 ; inline
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "addrinfo*" "next" } ;
-
C-STRUCT: sockaddr-in
{ "uchar" "len" }
{ "uchar" "family" }
: SEEK_SET 0 ; inline
: SEEK_CUR 1 ; inline
: SEEK_END 2 ; inline
+
+os {
+ { macosx [ "unix.bsd.macosx" require ] }
+ { freebsd [ "unix.bsd.freebsd" require ] }
+ { openbsd [ "unix.bsd.openbsd" require ] }
+ { netbsd [ "unix.bsd.netbsd" require ] }
+} case
--- /dev/null
+USING: alien.syntax ;
+IN: unix
+
+: FD_SETSIZE 1024 ;
+
+C-STRUCT: addrinfo
+ { "int" "flags" }
+ { "int" "family" }
+ { "int" "socktype" }
+ { "int" "protocol" }
+ { "socklen_t" "addrlen" }
+ { "char*" "canonname" }
+ { "void*" "addr" }
+ { "addrinfo*" "next" } ;
--- /dev/null
+USING: alien.syntax ;
+IN: unix
+
+: FD_SETSIZE 1024 ; inline
+
+C-STRUCT: addrinfo
+ { "int" "flags" }
+ { "int" "family" }
+ { "int" "socktype" }
+ { "int" "protocol" }
+ { "socklen_t" "addrlen" }
+ { "char*" "canonname" }
+ { "void*" "addr" }
+ { "addrinfo*" "next" } ;
--- /dev/null
+USING: alien.syntax ;
+IN: unix
+
+: FD_SETSIZE 256 ; inline
+
+C-STRUCT: addrinfo
+ { "int" "flags" }
+ { "int" "family" }
+ { "int" "socktype" }
+ { "int" "protocol" }
+ { "socklen_t" "addrlen" }
+ { "char*" "canonname" }
+ { "void*" "addr" }
+ { "addrinfo*" "next" } ;
--- /dev/null
+USING: alien.syntax ;
+IN: unix
+
+: FD_SETSIZE 1024 ; inline
+
+C-STRUCT: addrinfo
+ { "int" "flags" }
+ { "int" "family" }
+ { "int" "socktype" }
+ { "int" "protocol" }
+ { "socklen_t" "addrlen" }
+ { "void*" "addr" }
+ { "char*" "canonname" }
+ { "addrinfo*" "next" } ;
--- /dev/null
+USE: alien.syntax
+IN: unix.kqueue
+
+C-STRUCT: kevent
+ { "ulong" "ident" } ! identifier for this event
+ { "short" "filter" } ! filter for event
+ { "ushort" "flags" } ! action flags for kqueue
+ { "uint" "fflags" } ! filter flag value
+ { "long" "data" } ! filter data value
+ { "void*" "udata" } ! opaque user data identifier
+;
+
+FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
+
+: EVFILT_READ -1 ; inline
+: EVFILT_WRITE -2 ; inline
+: EVFILT_AIO -3 ; inline ! attached to aio requests
+: EVFILT_VNODE -4 ; inline ! attached to vnodes
+: EVFILT_PROC -5 ; inline ! attached to struct proc
+: EVFILT_SIGNAL -6 ; inline ! attached to struct proc
+: EVFILT_TIMER -7 ; inline ! timers
+: EVFILT_NETDEV -8 ; inline ! Mach ports
+: EVFILT_FS -9 ; inline ! Filesystem events
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax system sequences vocabs.loader words ;
IN: unix.kqueue
-FUNCTION: int kqueue ( ) ;
-
-FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
+<< "unix.kqueue." os word-name append require >>
-C-STRUCT: kevent
- { "ulong" "ident" } ! identifier for this event
- { "short" "filter" } ! filter for event
- { "ushort" "flags" } ! action flags for kqueue
- { "uint" "fflags" } ! filter flag value
- { "long" "data" } ! filter data value
- { "void*" "udata" } ! opaque user data identifier
-;
-
-: EVFILT_READ -1 ; inline
-: EVFILT_WRITE -2 ; inline
-: EVFILT_AIO -3 ; inline ! attached to aio requests
-: EVFILT_VNODE -4 ; inline ! attached to vnodes
-: EVFILT_PROC -5 ; inline ! attached to struct proc
-: EVFILT_SIGNAL -6 ; inline ! attached to struct proc
-: EVFILT_TIMER -7 ; inline ! timers
-: EVFILT_MACHPORT -8 ; inline ! Mach ports
-: EVFILT_FS -9 ; inline ! Filesystem events
+FUNCTION: int kqueue ( ) ;
! actions
: EV_ADD HEX: 1 ; inline ! add event to kq (implies enable)
--- /dev/null
+USE: alien.syntax
+IN: unix.kqueue
+
+C-STRUCT: kevent
+ { "ulong" "ident" } ! identifier for this event
+ { "short" "filter" } ! filter for event
+ { "ushort" "flags" } ! action flags for kqueue
+ { "uint" "fflags" } ! filter flag value
+ { "long" "data" } ! filter data value
+ { "void*" "udata" } ! opaque user data identifier
+;
+
+FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
+
+: EVFILT_READ -1 ; inline
+: EVFILT_WRITE -2 ; inline
+: EVFILT_AIO -3 ; inline ! attached to aio requests
+: EVFILT_VNODE -4 ; inline ! attached to vnodes
+: EVFILT_PROC -5 ; inline ! attached to struct proc
+: EVFILT_SIGNAL -6 ; inline ! attached to struct proc
+: EVFILT_TIMER -7 ; inline ! timers
+: EVFILT_MACHPORT -8 ; inline ! Mach ports
+: EVFILT_FS -9 ; inline ! Filesystem events
--- /dev/null
+USE: alien.syntax
+IN: unix.kqueue
+
+C-STRUCT: kevent
+ { "ulong" "ident" } ! identifier for this event
+ { "uint" "filter" } ! filter for event
+ { "uint" "flags" } ! action flags for kqueue
+ { "uint" "fflags" } ! filter flag value
+ { "longlong" "data" } ! filter data value
+ { "void*" "udata" } ! opaque user data identifier
+;
+
+FUNCTION: int kevent ( int kq, kevent* changelist, size_t nchanges, kevent* eventlist, size_t nevents, timespec* timeout ) ;
+
+: EVFILT_READ 0 ; inline
+: EVFILT_WRITE 1 ; inline
+: EVFILT_AIO 2 ; inline ! attached to aio requests
+: EVFILT_VNODE 3 ; inline ! attached to vnodes
+: EVFILT_PROC 4 ; inline ! attached to struct proc
+: EVFILT_SIGNAL 5 ; inline ! attached to struct proc
+: EVFILT_TIMER 6 ; inline ! timers
+: EVFILT_SYSCOUNT 7 ; inline ! Filesystem events
--- /dev/null
+USE: alien.syntax
+IN: unix.kqueue
+
+C-STRUCT: kevent
+ { "uint" "ident" } ! identifier for this event
+ { "short" "filter" } ! filter for event
+ { "ushort" "flags" } ! action flags for kqueue
+ { "uint" "fflags" } ! filter flag value
+ { "int" "data" } ! filter data value
+ { "void*" "udata" } ! opaque user data identifier
+;
+
+FUNCTION: int kevent ( int kq, kevent* changelist, int nchanges, kevent* eventlist, int nevents, timespec* timeout ) ;
+
+: EVFILT_READ -1 ; inline
+: EVFILT_WRITE -2 ; inline
+: EVFILT_AIO -3 ; inline ! attached to aio requests
+: EVFILT_VNODE -4 ; inline ! attached to vnodes
+: EVFILT_PROC -5 ; inline ! attached to struct proc
+: EVFILT_SIGNAL -6 ; inline ! attached to struct proc
+: EVFILT_TIMER -7 ; inline ! timers
: set-if-addr ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFADDR rot ioctl drop ;
: set-if-flags ( name flags -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap <short> over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFFLAGS rot ioctl drop ;
: set-if-dst-addr ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFDSTADDR rot ioctl drop ;
: set-if-brd-addr ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFBRDADDR rot ioctl drop ;
: set-if-netmask ( name addr -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap 0 <inet4> make-sockaddr over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFNETMASK rot ioctl drop ;
: set-if-metric ( name metric -- )
"struct-ifreq" <c-object>
- rot string>char-alien over set-struct-ifreq-ifr-ifrn
+ rot ascii string>alien over set-struct-ifreq-ifr-ifrn
swap <int> over set-struct-ifreq-ifr-ifru
AF_INET SOCK_DGRAM 0 socket SIOCSIFMETRIC rot ioctl drop ;
\ No newline at end of file
-USING: kernel alien.c-types sequences math unix
-combinators.cleave vectors kernel namespaces continuations
-threads assocs vectors io.unix.backend ;
-
+USING: kernel alien.c-types alien.strings sequences math unix
+vectors kernel namespaces continuations threads assocs vectors
+io.unix.backend io.encodings.utf8 ;
IN: unix.process
! Low-level Unix process launching utilities. These are used
! io.launcher instead.
: >argv ( seq -- alien )
- [ malloc-char-string ] map f add >c-void*-array ;
+ [ utf8 malloc-string ] map f suffix >c-void*-array ;
: exec ( pathname argv -- int )
- [ malloc-char-string ] [ >argv ] bi* execv ;
+ [ utf8 malloc-string ] [ >argv ] bi* execv ;
: exec-with-path ( filename argv -- int )
- [ malloc-char-string ] [ >argv ] bi* execvp ;
+ [ utf8 malloc-string ] [ >argv ] bi* execvp ;
: exec-with-env ( filename argv envp -- int )
- [ malloc-char-string ] [ >argv ] [ >argv ] tri* execve ;
+ [ utf8 malloc-string ] [ >argv ] [ >argv ] tri* execve ;
: exec-args ( seq -- int )
[ first ] [ ] bi exec ;
fork dup io-error dup zero? -roll swap curry if ; inline
: wait-for-pid ( pid -- status )
- 0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
\ No newline at end of file
+ 0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
+
+: set-priority ( n -- )
+ 0 0 rot setpriority io-error ;
\ No newline at end of file
--- /dev/null
+USING: kernel alien.syntax math ;
+
+IN: unix.stat
+
+! FreeBSD 8.0-CURRENT
+
+C-STRUCT: stat
+ { "__dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "__dev_t" "st_rdev" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "off_t" "st_size" }
+ { "blkcnt_t" "st_blocks" }
+ { "blksize_t" "st_blksize" }
+ { "fflags_t" "st_flags" }
+ { "__uint32_t" "st_gen" }
+ { "__int32_t" "st_lspare" }
+ { "timespec" "st_birthtimespec" }
+! not sure about the padding here.
+ { "__uint32_t" "pad0" }
+ { "__uint32_t" "pad1" } ;
+
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
\ No newline at end of file
--- /dev/null
+USING: kernel alien.syntax math ;
+IN: unix.stat
+
+! FreeBSD 8.0-CURRENT
+! untested
+
+C-STRUCT: stat
+ { "__dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "__dev_t" "st_rdev" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "off_t" "st_size" }
+ { "blkcnt_t" "st_blocks" }
+ { "blksize_t" "st_blksize" }
+ { "fflags_t" "st_flags" }
+ { "__uint32_t" "st_gen" }
+ { "__int32_t" "st_lspare" }
+ { "timespec" "st_birthtimespec" }
+! not sure about the padding here.
+ { "__uint32_t" "pad0" }
+ { "__uint32_t" "pad1" } ;
+
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
-USING: kernel alien.syntax math ;
-
+USING: layouts combinators vocabs.loader ;
IN: unix.stat
-! FreeBSD 8.0-CURRENT
-
-C-STRUCT: stat
- { "__dev_t" "st_dev" }
- { "ino_t" "st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "__dev_t" "st_rdev" }
- { "timespec" "st_atim" }
- { "timespec" "st_mtim" }
- { "timespec" "st_ctim" }
- { "off_t" "st_size" }
- { "blkcnt_t" "st_blocks" }
- { "blksize_t" "st_blksize" }
- { "fflags_t" "st_flags" }
- { "__uint32_t" "st_gen" }
- { "__int32_t" "st_lspare" }
- { "timespec" "st_birthtimespec" }
-! not sure about the padding here.
- { "__uint32_t" "pad0" }
- { "__uint32_t" "pad1" } ;
-
-FUNCTION: int stat ( char* pathname, stat* buf ) ;
-FUNCTION: int lstat ( char* pathname, stat* buf ) ;
\ No newline at end of file
+cell-bits {
+ { 32 [ "unix.stat.freebsd.32" require ] }
+ { 64 [ "unix.stat.freebsd.64" require ] }
+} case
FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
-: stat ( pathname buf -- int ) 3 -rot __xstat ;
-: lstat ( pathname buf -- int ) 3 -rot __lxstat ;
\ No newline at end of file
+: stat ( pathname buf -- int ) 1 -rot __xstat ;
+: lstat ( pathname buf -- int ) 1 -rot __lxstat ;
--- /dev/null
+USING: kernel alien.syntax math ;
+IN: unix.stat
+
+! NetBSD 4.0
+
+C-STRUCT: stat
+ { "dev_t" "st_dev" }
+ { "mode_t" "st_mode" }
+ { "ino_t" "st_ino" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "dev_t" "st_rdev" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "timespec" "st_birthtim" }
+ { "off_t" "st_size" }
+ { "blkcnt_t" "st_blocks" }
+ { "blksize_t" "st_blksize" }
+ { "uint32_t" "st_flags" }
+ { "uint32_t" "st_gen" }
+ { { "uint32_t" 2 } "st_qspare" } ;
+
+FUNCTION: int __stat30 ( char* pathname, stat* buf ) ;
+FUNCTION: int __lstat30 ( char* pathname, stat* buf ) ;
+
+: stat __stat30 ;
+: lstat __lstat30 ;
--- /dev/null
+USING: kernel alien.syntax math ;
+IN: unix.stat
+
+! NetBSD 4.0
+
+C-STRUCT: stat
+ { "dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "dev_t" "st_rdev" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "off_t" "st_size" }
+ { "blkcnt_t" "st_blocks" }
+ { "blksize_t" "st_blksize" }
+ { "uint32_t" "st_flags" }
+ { "uint32_t" "st_gen" }
+ { "uint32_t" "st_spare0" }
+ { "timespec" "st_birthtim" } ;
+
+FUNCTION: int __stat13 ( char* pathname, stat* buf ) ;
+FUNCTION: int __lstat13 ( char* pathname, stat* buf ) ;
+
+: stat __stat13 ; inline
+: lstat __lstat13 ; inline
--- /dev/null
+USING: layouts combinators vocabs.loader ;
+IN: unix.stat
+
+cell-bits {
+ { 32 [ "unix.stat.netbsd.32" require ] }
+ { 64 [ "unix.stat.netbsd.64" require ] }
+} case
--- /dev/null
+USING: kernel alien.syntax math ;
+IN: unix.stat
+
+! OpenBSD 4.2
+
+C-STRUCT: stat
+ { "dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "mode_t" "st_mode" }
+ { "nlink_t" "st_nlink" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "dev_t" "st_rdev" }
+ { "int32_t" "st_lspare0" }
+ { "timespec" "st_atim" }
+ { "timespec" "st_mtim" }
+ { "timespec" "st_ctim" }
+ { "off_t" "st_size" }
+ { "int64_t" "st_blocks" }
+ { "u_int32_t" "st_blksize" }
+ { "u_int32_t" "st_flags" }
+ { "u_int32_t" "st_gen" }
+ { "int32_t" "st_lspare1" }
+ { "timespec" "st_birthtim" }
+ { { "int64_t" 2 } "st_qspare" } ;
+
+FUNCTION: int stat ( char* pathname, stat* buf ) ;
+FUNCTION: int lstat ( char* pathname, stat* buf ) ;
: S_IFMT OCT: 170000 ; ! These bits determine file type.
-: S_IFDIR OCT: 40000 ; ! Directory.
-: S_IFCHR OCT: 20000 ; ! Character device.
-: S_IFBLK OCT: 60000 ; ! Block device.
-: S_IFREG OCT: 100000 ; ! Regular file.
-: S_IFIFO OCT: 010000 ; ! FIFO.
-: S_IFLNK OCT: 120000 ; ! Symbolic link.
-: S_IFSOCK OCT: 140000 ; ! Socket.
-
-: S_ISTYPE ( mode mask -- val ) >r S_IFMT bitand r> = ;
-
-: S_ISREG ( mode -- value ) S_IFREG S_ISTYPE ;
-: S_ISDIR ( mode -- value ) S_IFDIR S_ISTYPE ;
-: S_ISCHR ( mode -- value ) S_IFCHR S_ISTYPE ;
-: S_ISBLK ( mode -- value ) S_IFBLK S_ISTYPE ;
-: S_ISFIFO ( mode -- value ) S_IFIFO S_ISTYPE ;
-: S_ISLNK ( mode -- value ) S_IFLNK S_ISTYPE ;
-: S_ISSOCK ( mode -- value ) S_IFSOCK S_ISTYPE ;
+: S_IFDIR OCT: 40000 ; inline ! Directory.
+: S_IFCHR OCT: 20000 ; inline ! Character device.
+: S_IFBLK OCT: 60000 ; inline ! Block device.
+: S_IFREG OCT: 100000 ; inline ! Regular file.
+: S_IFIFO OCT: 010000 ; inline ! FIFO.
+: S_IFLNK OCT: 120000 ; inline ! Symbolic link.
+: S_IFSOCK OCT: 140000 ; inline ! Socket.
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! File Access Permissions
<<
os
{
- { "linux" [ "unix.stat.linux" require ] }
- { "macosx" [ "unix.stat.macosx" require ] }
- { "freebsd" [ "unix.stat.freebsd" require ] }
- [ drop ]
+ { linux [ "unix.stat.linux" require ] }
+ { macosx [ "unix.stat.macosx" require ] }
+ { freebsd [ "unix.stat.freebsd" require ] }
+ { netbsd [ "unix.stat.netbsd" require ] }
+ { openbsd [ "unix.stat.openbsd" require ] }
}
case
>>
--- /dev/null
+USING: alien.syntax ;
+IN: unix.types
+
+! NetBSD 4.0
+
+TYPEDEF: __uint64_t ino_t
--- /dev/null
+USING: alien.syntax ;
+IN: unix.types
+
+! NetBSD 4.0
+
+TYPEDEF: __uint32_t ino_t
--- /dev/null
+USING: alien.syntax combinators layouts vocabs.loader ;
+IN: unix.types
+
+! NetBSD 4.0
+
+TYPEDEF: short __int16_t
+TYPEDEF: ushort __uint16_t
+TYPEDEF: int __int32_t
+TYPEDEF: uint __uint32_t
+TYPEDEF: longlong __int64_t
+TYPEDEF: longlong __uint64_t
+
+TYPEDEF: int int32_t
+TYPEDEF: uint uint32_t
+TYPEDEF: uint u_int32_t
+TYPEDEF: longlong int64_t
+TYPEDEF: ulonglong u_int64_t
+
+TYPEDEF: __uint32_t __dev_t
+TYPEDEF: __uint32_t dev_t
+TYPEDEF: __uint32_t mode_t
+TYPEDEF: __uint32_t nlink_t
+TYPEDEF: __uint32_t uid_t
+TYPEDEF: __uint32_t gid_t
+TYPEDEF: __int64_t off_t
+TYPEDEF: __int64_t blkcnt_t
+TYPEDEF: __uint32_t blksize_t
+TYPEDEF: long ssize_t
+TYPEDEF: int pid_t
+TYPEDEF: int time_t
+
+cell-bits {
+ { 32 [ "unix.types.netbsd.32" require ] }
+ { 64 [ "unix.types.netbsd.64" require ] }
+} case
+
--- /dev/null
+USING: alien.syntax ;
+IN: unix.types
+
+! OpenBSD 4.2
+
+TYPEDEF: short __int16_t
+TYPEDEF: ushort __uint16_t
+TYPEDEF: int __int32_t
+TYPEDEF: uint __uint32_t
+TYPEDEF: longlong __int64_t
+TYPEDEF: longlong __uint64_t
+
+TYPEDEF: int int32_t
+TYPEDEF: uint u_int32_t
+TYPEDEF: uint uint32_t
+TYPEDEF: longlong int64_t
+TYPEDEF: ulonglong u_int64_t
+
+TYPEDEF: __uint32_t __dev_t
+TYPEDEF: __uint32_t dev_t
+TYPEDEF: __uint32_t ino_t
+TYPEDEF: __uint32_t mode_t
+TYPEDEF: __uint32_t nlink_t
+TYPEDEF: __uint32_t uid_t
+TYPEDEF: __uint32_t gid_t
+TYPEDEF: __int64_t off_t
+TYPEDEF: __int64_t blkcnt_t
+TYPEDEF: __uint32_t blksize_t
+TYPEDEF: __uint32_t fflags_t
+TYPEDEF: int ssize_t
+TYPEDEF: int pid_t
+TYPEDEF: int time_t
-
-USING: kernel system alien.syntax combinators vocabs.loader ;
-
+USING: kernel system alien.syntax combinators vocabs.loader
+system ;
IN: unix.types
TYPEDEF: void* caddr_t
-os
- {
- { "linux" [ "unix.types.linux" require ] }
- { "macosx" [ "unix.types.macosx" require ] }
- { "freebsd" [ "unix.types.freebsd" require ] }
- [ drop ]
- }
-case
\ No newline at end of file
+os {
+ { linux [ "unix.types.linux" require ] }
+ { macosx [ "unix.types.macosx" require ] }
+ { freebsd [ "unix.types.freebsd" require ] }
+ { openbsd [ "unix.types.openbsd" require ] }
+ { netbsd [ "unix.types.netbsd" require ] }
+ { winnt [ ] }
+} case
! ! ! Unix functions
LIBRARY: factor
FUNCTION: int err_no ( ) ;
+FUNCTION: void clear_err_no ( ) ;
LIBRARY: libc
FUNCTION: int execv ( char* path, char** argv ) ;
FUNCTION: int execvp ( char* path, char** argv ) ;
FUNCTION: int execve ( char* path, char** argv, char** envp ) ;
+: _exit ( status -- * )
+ #! We throw to give this a terminating stack effect.
+ "int" f "_exit" { "int" } alien-invoke "Exit failed" throw ;
FUNCTION: int fchdir ( int fd ) ;
FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ;
FUNCTION: int fcntl ( int fd, int cmd, int arg ) ;
FUNCTION: int pipe ( int* filedes ) ;
FUNCTION: void* popen ( char* command, char* type ) ;
FUNCTION: ssize_t read ( int fd, void* buf, size_t nbytes ) ;
+FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
FUNCTION: ssize_t recv ( int s, void* buf, size_t nbytes, int flags ) ;
FUNCTION: ssize_t recvfrom ( int s, void* buf, size_t nbytes, int flags, sockaddr-in* from, socklen_t* fromlen ) ;
FUNCTION: int rename ( char* from, char* to ) ;
FUNCTION: int setuid ( uid_t uid ) ;
FUNCTION: int socket ( int domain, int type, int protocol ) ;
FUNCTION: char* strerror ( int errno ) ;
+FUNCTION: int symlink ( char* path1, char* path2 ) ;
FUNCTION: int system ( char* command ) ;
FUNCTION: int unlink ( char* path ) ;
FUNCTION: int utimes ( char* path, timeval[2] times ) ;
FUNCTION: int kill ( pid_t pid, int sig ) ;
+: PATH_MAX 1024 ; inline
+
+: PRIO_PROCESS 0 ; inline
+: PRIO_PGRP 1 ; inline
+: PRIO_USER 2 ; inline
+
+: PRIO_MIN -20 ; inline
+: PRIO_MAX 20 ; inline
+
+! which/who = 0 for current process
+FUNCTION: int getpriority ( int which, int who ) ;
+FUNCTION: int setpriority ( int which, int who, int prio ) ;
+
! Flags for waitpid
: WNOHANG 1 ; inline
FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ;
{
- { [ linux? ] [ "unix.linux" require ] }
- { [ bsd? ] [ "unix.bsd" require ] }
- { [ solaris? ] [ "unix.solaris" require ] }
- { [ t ] [ ] }
+ { [ os linux? ] [ "unix.linux" require ] }
+ { [ os bsd? ] [ "unix.bsd" require ] }
+ { [ os solaris? ] [ "unix.solaris" require ] }
} cond
--- /dev/null
+
+USING: kernel system sequences io.files io.launcher bootstrap.image
+ http.client
+ builder.util builder.release.branch ;
+
+IN: update
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-command ( cmd -- ) to-strings try-process ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: git-pull-clean ( -- )
+ image parent-directory
+ [
+ { "git" "pull" "git://factorcode.org/git/factor.git" branch-name }
+ run-command
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remote-clean-image ( -- url )
+ "http://factorcode.org/images/clean/" my-boot-image-name append ;
+
+: download-clean-image ( -- ) remote-clean-image download ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: make-clean ( -- ) { gnu-make "clean" } run-command ;
+: make ( -- ) { gnu-make } run-command ;
+: boot ( -- ) { "./factor" { "-i=" my-boot-image-name } } run-command ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: rebuild ( -- )
+ image parent-directory
+ [
+ download-clean-image
+ make-clean
+ make
+ boot
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: update ( -- )
+ image parent-directory
+ [
+ git-id
+ git-pull-clean
+ git-id
+ = not
+ [ rebuild ]
+ when
+ ]
+ with-directory ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: update
\ No newline at end of file
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel sequences io.files io.sockets
+db.sqlite smtp namespaces db
+http.server.db
+http.server.sessions
+http.server.auth.login
+http.server.auth.providers.db
+http.server.sessions.storage.db
+http.server.boilerplate
+http.server.templating.chloe ;
+IN: webapps.factor-website
+
+: factor-template ( path -- template )
+ "resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
+
+: test-db "todo.db" resource-path sqlite-db ;
+
+: <factor-boilerplate> ( responder -- responder' )
+ <login>
+ users-in-db >>users
+ allow-registration
+ allow-password-recovery
+ allow-edit-profile
+ <boilerplate>
+ "page" factor-template >>template
+ <url-sessions>
+ sessions-in-db >>sessions
+ test-db <db-persistence> ;
+
+: init-factor-website ( -- )
+ "factorcode.org" 25 <inet> smtp-server set-global
+ "todo@factorcode.org" lost-password-from set-global
+
+ test-db [
+ init-sessions-table
+ init-users-table
+ ] with-db ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+ <t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <head>
+ <t:write-title />
+
+ <t:style>
+ body, button {
+ font:9pt "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+ color:#444;
+ }
+
+ .link-button {
+ padding: 0px;
+ background: none;
+ border: none;
+ }
+
+ a, .link {
+ color: #222;
+ border-bottom:1px dotted #666;
+ text-decoration:none;
+ }
+
+ a:hover, .link:hover {
+ border-bottom:1px solid #66a;
+ }
+
+ .error { color: #a00; }
+
+ .field-label {
+ text-align: right;
+ }
+
+ .inline {
+ display: inline;
+ }
+
+ .navbar {
+ background-color: #eee;
+ padding: 5px;
+ border: 1px solid #ccc;
+ }
+ </t:style>
+
+ <t:write-style />
+ </head>
+
+ <body>
+ <t:call-next-template />
+ </body>
+
+ </t:chloe>
+
+</html>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Planet Factor Administration</t:title>
+
+ <t:summary component="blogroll" />
+
+ <p>
+ <t:a href="edit-blog">Add Blog</t:a> | <t:a href="update">Update</t:a>
+ </p>
+
+</t:chloe>
--- /dev/null
+Slava Pestov
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:a href="view-blog" query="id"><t:view component="name" /></t:a>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Blog</t:title>
+
+ <t:form action="edit-blog">
+
+ <t:edit component="id" />
+
+ <table>
+
+ <tr>
+ <th class="field-label">Blog name:</th>
+ <td><t:edit component="name" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Home page:</th>
+ <td><t:edit component="www-url" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Atom feed:</th>
+ <td><t:edit component="atom-url" /></td>
+ </tr>
+
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+
+ </t:form>
+
+ <t:a href="view" query="id">View</t:a>
+ |
+ <t:form action="delete-blog" class="inline">
+ <t:edit component="id" />
+ <button type="submit" class="link-button link">Delete</button>
+ </t:form>
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <p class="news">
+ <strong><t:view component="title" /></strong> <br/>
+ <t:a value="link" class="more">Read More...</t:a>
+ </p>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <h2 class="posting-title">
+ <t:a value="link"><t:view component="title" /></t:a>
+ </h2>
+
+ <p class="posting-body">
+ <t:view component="description" />
+ </p>
+
+ <p class="posting-date">
+ <t:a value="link"><t:view component="pub-date" /></t:a>
+ </p>
+
+</t:chloe>
--- /dev/null
+h1.planet-title {
+ font-size:300%;
+}
+
+.posting-title {
+ background-color:#f5f5f5;
+}
+
+pre, code {
+ color:#000000;
+ font-size:120%;
+}
+
+.infobox {
+ border-left: 1px solid #C1DAD7;
+}
+
+.posting-date {
+ text-align: right;
+ font-size:90%;
+}
+
+a.more {
+ display:block;
+ padding:0 0 5px 0;
+ color:#333;
+ text-decoration:none;
+ text-align:right;
+ border:none;
+}
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences sorting locals math
+calendar alarms logging concurrency.combinators namespaces
+db.types db.tuples db
+rss xml.writer
+http.server
+http.server.crud
+http.server.forms
+http.server.actions
+http.server.boilerplate
+http.server.templating.chloe
+http.server.components
+http.server.auth.login
+webapps.factor-website ;
+IN: webapps.planet
+
+TUPLE: planet-factor < dispatcher postings ;
+
+: planet-template ( name -- template )
+ "resource:extra/webapps/planet/" swap ".xml" 3append <chloe> ;
+
+TUPLE: blog id name www-url atom-url ;
+
+M: blog link-title name>> ;
+
+M: blog link-href www-url>> ;
+
+blog "BLOGS"
+{
+ { "id" "ID" INTEGER +native-id+ }
+ { "name" "NAME" { VARCHAR 256 } +not-null+ }
+ { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
+ { "atom-url" "ATOMURL" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: init-blog-table blog ensure-table ;
+
+: <blog> ( id -- todo )
+ blog new
+ swap >>id ;
+
+: blogroll ( -- seq )
+ f <blog> select-tuples [ [ name>> ] compare ] sort ;
+
+: <entry-form> ( -- form )
+ "entry" <form>
+ "entry" planet-template >>view-template
+ "entry-summary" planet-template >>summary-template
+ "title" <string> add-field
+ "description" <html-text> add-field
+ "pub-date" <date> add-field ;
+
+: <blog-form> ( -- form )
+ "blog" <form>
+ "edit-blog" planet-template >>edit-template
+ "view-blog" planet-template >>view-template
+ "blog-admin-link" planet-template >>summary-template
+ "id" <integer>
+ hidden >>renderer
+ add-field
+ "name" <string>
+ t >>required
+ add-field
+ "www-url" <url>
+ t >>required
+ add-field
+ "atom-url" <url>
+ t >>required
+ add-field ;
+
+: <planet-factor-form> ( -- form )
+ "planet-factor" <form>
+ "postings" planet-template >>view-template
+ "postings-summary" planet-template >>summary-template
+ "postings" <entry-form> +plain+ <list> add-field
+ "blogroll" "blog" <link> +unordered+ <list> add-field ;
+
+: <admin-form> ( -- form )
+ "admin" <form>
+ "admin" planet-template >>view-template
+ "blogroll" <blog-form> +unordered+ <list> add-field ;
+
+:: <edit-blogroll-action> ( planet -- action )
+ [let | form [ <admin-form> ] |
+ <action>
+ [
+ blank-values
+
+ blogroll "blogroll" set-value
+
+ form view-form
+ ] >>display
+ ] ;
+
+:: <planet-action> ( planet -- action )
+ [let | form [ <planet-factor-form> ] |
+ <action>
+ [
+ blank-values
+
+ planet postings>> "postings" set-value
+ blogroll "blogroll" set-value
+
+ form view-form
+ ] >>display
+ ] ;
+
+: safe-head ( seq n -- seq' )
+ over length min head ;
+
+:: planet-feed ( planet -- feed )
+ feed new
+ "[ planet-factor ]" >>title
+ "http://planet.factorcode.org" >>link
+ planet postings>> 16 safe-head >>entries ;
+
+:: <feed-action> ( planet -- action )
+ <action>
+ [
+ "text/xml" <content>
+ [ planet planet-feed feed>xml write-xml ] >>body
+ ] >>display ;
+
+: <posting> ( name entry -- entry' )
+ clone [ ": " swap 3append ] change-title ;
+
+: fetch-feed ( url -- feed )
+ download-feed entries>> ;
+
+\ fetch-feed DEBUG add-error-logging
+
+: fetch-blogroll ( blogroll -- entries )
+ dup
+ [ atom-url>> fetch-feed ] parallel-map
+ [ >r name>> r> [ <posting> ] with map ] 2map concat ;
+
+: sort-entries ( entries -- entries' )
+ [ [ pub-date>> ] compare ] sort <reversed> ;
+
+: update-cached-postings ( planet -- )
+ "webapps.planet" [
+ blogroll fetch-blogroll sort-entries 8 safe-head
+ >>postings drop
+ ] with-logging ;
+
+:: <update-action> ( planet -- action )
+ <action>
+ [
+ planet update-cached-postings
+ "" f <temporary-redirect>
+ ] >>display ;
+
+:: <planet-factor-admin> ( planet-factor -- responder )
+ [let | blog-form [ <blog-form> ]
+ blog-ctor [ [ <blog> ] ] |
+ <dispatcher>
+ planet-factor <edit-blogroll-action> >>default
+
+ ! Administrative CRUD
+ blog-ctor "" <delete-action> "delete-blog" add-responder
+ blog-form blog-ctor <view-action> "view-blog" add-responder
+ blog-form blog-ctor "view-blog" <edit-action> "edit-blog" add-responder
+ ] ;
+
+: <planet-factor> ( -- responder )
+ planet-factor new-dispatcher
+ dup <planet-action> >>default
+ dup <feed-action> "feed.xml" add-responder
+ dup <update-action> "update" add-responder
+ dup <planet-factor-admin> <protected> "admin" add-responder
+ <boilerplate>
+ "planet" planet-template >>template ;
+
+: <planet-app> ( -- responder )
+ <planet-factor> <factor-boilerplate> ;
+
+: start-update-task ( planet -- )
+ [ update-cached-postings ] curry 10 minutes every drop ;
+
+: init-planet ( -- )
+ test-db [
+ init-blog-table
+ ] with-db
+
+ <dispatcher>
+ <planet-app> "planet" add-responder
+ main-responder set-global ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<t:comment>
+ <t:atom title="Planet Factor - Atom" href="feed.xml" />
+</t:comment>
+ <t:style include="resource:extra/webapps/planet/planet.css" />
+
+ <div class="navbar">
+ <t:a href="list">Front Page</t:a>
+ | <t:a href="feed.xml">Atom Feed</t:a>
+
+ | <t:a href="admin">Admin</t:a>
+
+ <t:comment>
+ <t:if code="http.server.auth.login:allow-edit-profile?">
+ | <t:a href="edit-profile">Edit Profile</t:a>
+ </t:if>
+
+ <t:form action="logout" class="inline">
+ | <button type="submit" class="link-button link">Logout</button>
+ </t:form>
+ </t:comment>
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:summary component="postings" />
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Planet Factor</t:title>
+
+ <table width="100%" cellpadding="10">
+ <tr>
+ <td> <t:view component="postings" /> </td>
+
+ <td valign="top" width="25%" class="infobox">
+ <h2>Blogroll</h2>
+
+ <t:summary component="blogroll" />
+ </td>
+ </tr>
+ </table>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>View Blog</t:title>
+
+ <table>
+
+ <tr>
+ <th class="field-label">Blog name:</th>
+ <td><t:view component="name" /></td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Home page:</th>
+ <td>
+ <t:a value="www-url">
+ <t:view component="www-url" />
+ </t:a>
+ </td>
+ </tr>
+
+ <tr>
+ <th class="field-label">Atom feed:</th>
+ <td>
+ <t:a value="atom-url">
+ <t:view component="atom-url" />
+ </t:a>
+ </td>
+ </tr>
+
+ </table>
+
+ <t:a href="edit-blog" query="id">Edit</t:a>
+ |
+ <t:form action="delete-blog" class="inline">
+ <t:edit component="id" />
+ <button type="submit" class="link-button link">Delete</button>
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>Edit Item</t:title>
+
+ <t:form action="edit">
+ <t:edit component="id" />
+
+ <table>
+ <tr><th class="field-label">Summary: </th><td><t:edit component="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:edit component="priority" /></td></tr>
+ <tr><th class="field-label big-field-label">Description:</th><td><t:edit component="description" /></td></tr>
+ </table>
+
+ <input type="SUBMIT" value="Done" />
+ </t:form>
+
+ <t:a href="view" query="id">View</t:a>
+ |
+ <t:form action="delete" class="inline">
+ <t:edit component="id" />
+ <button type="submit" class="link-button link">Delete</button>
+ </t:form>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>My Todo List</t:title>
+
+ <table class="todo-list">
+ <tr><th>Summary</th><th>Priority</th><th>View</th><th>Edit</th></tr>
+ <t:summary component="list" />
+ </table>
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <tr>
+ <td>
+ <t:view component="summary" />
+ </td>
+ <td>
+ <t:view component="priority" />
+ </td>
+ <td>
+ <t:a href="view" query="id">View</t:a>
+ </td>
+ <td>
+ <t:a href="edit" query="id">Edit</t:a>
+ </td>
+ </tr>
+
+</t:chloe>
--- /dev/null
+.big-field-label {
+ vertical-align: top;
+}
+
+.description {
+ border: 1px dashed #ccc;
+ background-color: #f5f5f5;
+ padding: 5px;
+ font-size: 150%;
+ color: #000000;
+}
+
+pre {
+ font-size: 75%;
+}
+
+.todo-list {
+ border-style: none;
+}
+
+.todo-list td, .todo-list th {
+ border-width: 1px;
+ padding: 2px;
+ border-style: solid;
+}
--- /dev/null
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals sequences namespaces
+db db.types db.tuples
+http.server.components http.server.components.farkup
+http.server.forms http.server.templating.chloe
+http.server.boilerplate http.server.crud http.server.auth
+http.server.actions http.server.db
+http.server.auth.login
+http.server
+webapps.factor-website ;
+IN: webapps.todo
+
+TUPLE: todo uid id priority summary description ;
+
+todo "TODO"
+{
+ { "uid" "UID" { VARCHAR 256 } +not-null+ }
+ { "id" "ID" +native-id+ }
+ { "priority" "PRIORITY" INTEGER +not-null+ }
+ { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
+ { "description" "DESCRIPTION" { VARCHAR 256 } }
+} define-persistent
+
+: init-todo-table todo ensure-table ;
+
+: <todo> ( id -- todo )
+ todo new
+ swap >>id
+ uid >>uid ;
+
+: todo-template ( name -- template )
+ "resource:extra/webapps/todo/" swap ".xml" 3append <chloe> ;
+
+: <todo-form> ( -- form )
+ "todo" <form>
+ "view-todo" todo-template >>view-template
+ "edit-todo" todo-template >>edit-template
+ "todo-summary" todo-template >>summary-template
+ "id" <integer>
+ hidden >>renderer
+ add-field
+ "summary" <string>
+ t >>required
+ add-field
+ "priority" <integer>
+ t >>required
+ 0 >>default
+ 0 >>min-value
+ 10 >>max-value
+ add-field
+ "description" <farkup>
+ add-field ;
+
+: <todo-list-form> ( -- form )
+ "todo-list" <form>
+ "todo-list" todo-template >>view-template
+ "list" <todo-form> +plain+ <list>
+ add-field ;
+
+TUPLE: todo-responder < dispatcher ;
+
+:: <todo-responder> ( -- responder )
+ [let | todo-form [ <todo-form> ]
+ list-form [ <todo-list-form> ]
+ ctor [ [ <todo> ] ] |
+ todo-responder new-dispatcher
+ list-form ctor <list-action> "list" add-main-responder
+ todo-form ctor <view-action> "view" add-responder
+ todo-form ctor "view" <edit-action> "edit" add-responder
+ ctor "list" <delete-action> "delete" add-responder
+ <boilerplate>
+ "todo" todo-template >>template
+ ] ;
+
+: <todo-app> ( -- responder )
+ <todo-responder> <protected> <factor-boilerplate> ;
+
+: init-todo ( -- )
+ test-db [
+ init-todo-table
+ ] with-db
+
+ <dispatcher>
+ <todo-app> "todo" add-responder
+ main-responder set-global ;
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:style include="resource:extra/webapps/todo/todo.css" />
+
+ <t:style include="resource:extra/xmode/code2html/stylesheet.css" />
+
+ <div class="navbar">
+ <t:a href="list">List Items</t:a>
+ | <t:a href="edit">Add Item</t:a>
+
+ <t:if code="http.server.auth.login:allow-edit-profile?">
+ | <t:a href="edit-profile">Edit Profile</t:a>
+ </t:if>
+
+ <t:form action="logout" class="inline">
+ | <button type="submit" class="link-button link">Logout</button>
+ </t:form>
+ </div>
+
+ <h1><t:write-title /></h1>
+
+ <t:call-next-template />
+
+</t:chloe>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+ <t:title>View Item</t:title>
+
+ <table>
+ <tr><th class="field-label">Summary: </th><td><t:view component="summary" /></td></tr>
+ <tr><th class="field-label">Priority: </th><td><t:view component="priority" /></td></tr>
+ </table>
+
+ <div class="description">
+ <t:view component="description" />
+ </div>
+
+ <t:a href="edit" query="id">Edit</t:a>
+ |
+ <t:form action="delete" class="inline">
+ <t:edit component="id" />
+ <button class="link-button link">Delete</button>
+ </t:form>
+
+</t:chloe>
-USING: alien.syntax kernel math windows.types math.bitfields ;\r
-IN: windows.advapi32\r
-LIBRARY: advapi32\r
-\r
-! : I_ScGetCurrentGroupStateW ;\r
-! : A_SHAFinal ;\r
-! : A_SHAInit ;\r
-! : A_SHAUpdate ;\r
-! : AbortSystemShutdownA ;\r
-! : AbortSystemShutdownW ;\r
-! : AccessCheck ;\r
-! : AccessCheckAndAuditAlarmA ;\r
-! : AccessCheckAndAuditAlarmW ;\r
-! : AccessCheckByType ;\r
-! : AccessCheckByTypeAndAuditAlarmA ;\r
-! : AccessCheckByTypeAndAuditAlarmW ;\r
-! : AccessCheckByTypeResultList ;\r
-! : AccessCheckByTypeResultListAndAuditAlarmA ;\r
-! : AccessCheckByTypeResultListAndAuditAlarmByHandleA ;\r
-! : AccessCheckByTypeResultListAndAuditAlarmByHandleW ;\r
-! : AccessCheckByTypeResultListAndAuditAlarmW ;\r
-! : AddAccessAllowedAce ;\r
-! : AddAccessAllowedAceEx ;\r
-! : AddAccessAllowedObjectAce ;\r
-! : AddAccessDeniedAce ;\r
-! : AddAccessDeniedAceEx ;\r
-! : AddAccessDeniedObjectAce ;\r
-! : AddAce ;\r
-! : AddAuditAccessAce ;\r
-! : AddAuditAccessAceEx ;\r
-! : AddAuditAccessObjectAce ;\r
-! : AddUsersToEncryptedFile ;\r
-! : AdjustTokenGroups ;\r
-FUNCTION: BOOL AdjustTokenPrivileges ( HANDLE TokenHandle,\r
- BOOL DisableAllPrivileges,\r
- PTOKEN_PRIVILEGES NewState,\r
- DWORD BufferLength,\r
- PTOKEN_PRIVILEGES PreviousState,\r
- PDWORD ReturnLength ) ;\r
-\r
-! : AllocateAndInitializeSid ;\r
-! : AllocateLocallyUniqueId ;\r
-! : AreAllAccessesGranted ;\r
-! : AreAnyAccessesGranted ;\r
-! : BackupEventLogA ;\r
-! : BackupEventLogW ;\r
-! : BuildExplicitAccessWithNameA ;\r
-! : BuildExplicitAccessWithNameW ;\r
-! : BuildImpersonateExplicitAccessWithNameA ;\r
-! : BuildImpersonateExplicitAccessWithNameW ;\r
-! : BuildImpersonateTrusteeA ;\r
-! : BuildImpersonateTrusteeW ;\r
-! : BuildSecurityDescriptorA ;\r
-! : BuildSecurityDescriptorW ;\r
-! : BuildTrusteeWithNameA ;\r
-! : BuildTrusteeWithNameW ;\r
-! : BuildTrusteeWithObjectsAndNameA ;\r
-! : BuildTrusteeWithObjectsAndNameW ;\r
-! : BuildTrusteeWithObjectsAndSidA ;\r
-! : BuildTrusteeWithObjectsAndSidW ;\r
-! : BuildTrusteeWithSidA ;\r
-! : BuildTrusteeWithSidW ;\r
-! : CancelOverlappedAccess ;\r
-! : ChangeServiceConfig2A ;\r
-! : ChangeServiceConfig2W ;\r
-! : ChangeServiceConfigA ;\r
-! : ChangeServiceConfigW ;\r
-! : CheckTokenMembership ;\r
-! : ClearEventLogA ;\r
-! : ClearEventLogW ;\r
-! : CloseCodeAuthzLevel ;\r
-! : CloseEncryptedFileRaw ;\r
-! : CloseEventLog ;\r
-! : CloseServiceHandle ;\r
-! : CloseTrace ;\r
-! : CommandLineFromMsiDescriptor ;\r
-! : ComputeAccessTokenFromCodeAuthzLevel ;\r
-! : ControlService ;\r
-! : ControlTraceA ;\r
-! : ControlTraceW ;\r
-! : ConvertAccessToSecurityDescriptorA ;\r
-! : ConvertAccessToSecurityDescriptorW ;\r
-! : ConvertSDToStringSDRootDomainA ;\r
-! : ConvertSDToStringSDRootDomainW ;\r
-! : ConvertSecurityDescriptorToAccessA ;\r
-! : ConvertSecurityDescriptorToAccessNamedA ;\r
-! : ConvertSecurityDescriptorToAccessNamedW ;\r
-! : ConvertSecurityDescriptorToAccessW ;\r
-! : ConvertSecurityDescriptorToStringSecurityDescriptorA ;\r
-! : ConvertSecurityDescriptorToStringSecurityDescriptorW ;\r
-! : ConvertSidToStringSidA ;\r
-! : ConvertSidToStringSidW ;\r
-! : ConvertStringSDToSDDomainA ;\r
-! : ConvertStringSDToSDDomainW ;\r
-! : ConvertStringSDToSDRootDomainA ;\r
-! : ConvertStringSDToSDRootDomainW ;\r
-! : ConvertStringSecurityDescriptorToSecurityDescriptorA ;\r
-! : ConvertStringSecurityDescriptorToSecurityDescriptorW ;\r
-! : ConvertStringSidToSidA ;\r
-! : ConvertStringSidToSidW ;\r
-! : ConvertToAutoInheritPrivateObjectSecurity ;\r
-! : CopySid ;\r
-! : CreateCodeAuthzLevel ;\r
-! : CreatePrivateObjectSecurity ;\r
-! : CreatePrivateObjectSecurityEx ;\r
-! : CreatePrivateObjectSecurityWithMultipleInheritance ;\r
-! : CreateProcessAsUserA ;\r
-! : CreateProcessAsUserSecure ;\r
-! : CreateProcessAsUserW ;\r
-! : CreateProcessWithLogonW ;\r
-! : CreateRestrictedToken ;\r
-! : CreateServiceA ;\r
-! : CreateServiceW ;\r
-! : CreateTraceInstanceId ;\r
-! : CreateWellKnownSid ;\r
-! : CredDeleteA ;\r
-! : CredDeleteW ;\r
-! : CredEnumerateA ;\r
-! : CredEnumerateW ;\r
-! : CredFree ;\r
-! : CredGetSessionTypes ;\r
-! : CredGetTargetInfoA ;\r
-! : CredGetTargetInfoW ;\r
-! : CredIsMarshaledCredentialA ;\r
-! : CredIsMarshaledCredentialW ;\r
-! : CredMarshalCredentialA ;\r
-! : CredMarshalCredentialW ;\r
-! : CredProfileLoaded ;\r
-! : CredReadA ;\r
-! : CredReadDomainCredentialsA ;\r
-! : CredReadDomainCredentialsW ;\r
-! : CredReadW ;\r
-! : CredRenameA ;\r
-! : CredRenameW ;\r
-! : CredUnmarshalCredentialA ;\r
-! : CredUnmarshalCredentialW ;\r
-! : CredWriteA ;\r
-! : CredWriteDomainCredentialsA ;\r
-! : CredWriteDomainCredentialsW ;\r
-! : CredWriteW ;\r
-! : CredpConvertCredential ;\r
-! : CredpConvertTargetInfo ;\r
-! : CredpDecodeCredential ;\r
-! : CredpEncodeCredential ;\r
-! : CryptAcquireContextA ;\r
-! : CryptAcquireContextW ;\r
-! : CryptContextAddRef ;\r
-! : CryptCreateHash ;\r
-! : CryptDecrypt ;\r
-! : CryptDeriveKey ;\r
-! : CryptDestroyHash ;\r
-! : CryptDestroyKey ;\r
-! : CryptDuplicateHash ;\r
-! : CryptDuplicateKey ;\r
-! : CryptEncrypt ;\r
-! : CryptEnumProviderTypesA ;\r
-! : CryptEnumProviderTypesW ;\r
-! : CryptEnumProvidersA ;\r
-! : CryptEnumProvidersW ;\r
-! : CryptExportKey ;\r
-! : CryptGenKey ;\r
-! : CryptGenRandom ;\r
-! : CryptGetDefaultProviderA ;\r
-! : CryptGetDefaultProviderW ;\r
-! : CryptGetHashParam ;\r
-! : CryptGetKeyParam ;\r
-! : CryptGetProvParam ;\r
-! : CryptGetUserKey ;\r
-! : CryptHashData ;\r
-! : CryptHashSessionKey ;\r
-! : CryptImportKey ;\r
-! : CryptReleaseContext ;\r
-! : CryptSetHashParam ;\r
-! : CryptSetKeyParam ;\r
-! : CryptSetProvParam ;\r
-! : CryptSetProviderA ;\r
-! : CryptSetProviderExA ;\r
-! : CryptSetProviderExW ;\r
-! : CryptSetProviderW ;\r
-! : CryptSignHashA ;\r
-! : CryptSignHashW ;\r
-! : CryptVerifySignatureA ;\r
-! : CryptVerifySignatureW ;\r
-! : DecryptFileA ;\r
-! : DecryptFileW ;\r
-! : DeleteAce ;\r
-! : DeleteService ;\r
-! : DeregisterEventSource ;\r
-! : DestroyPrivateObjectSecurity ;\r
-! : DuplicateEncryptionInfoFile ;\r
-! : DuplicateToken ;\r
-! : DuplicateTokenEx ;\r
-! : ElfBackupEventLogFileA ;\r
-! : ElfBackupEventLogFileW ;\r
-! : ElfChangeNotify ;\r
-! : ElfClearEventLogFileA ;\r
-! : ElfClearEventLogFileW ;\r
-! : ElfCloseEventLog ;\r
-! : ElfDeregisterEventSource ;\r
-! : ElfFlushEventLog ;\r
-! : ElfNumberOfRecords ;\r
-! : ElfOldestRecord ;\r
-! : ElfOpenBackupEventLogA ;\r
-! : ElfOpenBackupEventLogW ;\r
-! : ElfOpenEventLogA ;\r
-! : ElfOpenEventLogW ;\r
-! : ElfReadEventLogA ;\r
-! : ElfReadEventLogW ;\r
-! : ElfRegisterEventSourceA ;\r
-! : ElfRegisterEventSourceW ;\r
-! : ElfReportEventA ;\r
-! : ElfReportEventW ;\r
-! : EnableTrace ;\r
-! : EncryptFileA ;\r
-! : EncryptFileW ;\r
-! : EncryptedFileKeyInfo ;\r
-! : EncryptionDisable ;\r
-! : EnumDependentServicesA ;\r
-! : EnumDependentServicesW ;\r
-! : EnumServiceGroupW ;\r
-! : EnumServicesStatusA ;\r
-! : EnumServicesStatusExA ;\r
-! : EnumServicesStatusExW ;\r
-! : EnumServicesStatusW ;\r
-! : EnumerateTraceGuids ;\r
-! : EqualDomainSid ;\r
-! : EqualPrefixSid ;\r
-! : EqualSid ;\r
-! : FileEncryptionStatusA ;\r
-! : FileEncryptionStatusW ;\r
-! : FindFirstFreeAce ;\r
-! : FlushTraceA ;\r
-! : FlushTraceW ;\r
-! : FreeEncryptedFileKeyInfo ;\r
-! : FreeEncryptionCertificateHashList ;\r
-! : FreeInheritedFromArray ;\r
-! : FreeSid ;\r
-! : GetAccessPermissionsForObjectA ;\r
-! : GetAccessPermissionsForObjectW ;\r
-! : GetAce ;\r
-! : GetAclInformation ;\r
-! : GetAuditedPermissionsFromAclA ;\r
-! : GetAuditedPermissionsFromAclW ;\r
-! : GetCurrentHwProfileA ;\r
-! : GetCurrentHwProfileW ;\r
-! : GetEffectiveRightsFromAclA ;\r
-! : GetEffectiveRightsFromAclW ;\r
-! : GetEventLogInformation ;\r
-! : GetExplicitEntriesFromAclA ;\r
-! : GetExplicitEntriesFromAclW ;\r
-! : GetFileSecurityA ;\r
-! : GetFileSecurityW ;\r
-! : GetInformationCodeAuthzLevelW ;\r
-! : GetInformationCodeAuthzPolicyW ;\r
-! : GetInheritanceSourceA ;\r
-! : GetInheritanceSourceW ;\r
-! : GetKernelObjectSecurity ;\r
-! : GetLengthSid ;\r
-! : GetLocalManagedApplicationData ;\r
-! : GetLocalManagedApplications ;\r
-! : GetManagedApplicationCategories ;\r
-! : GetManagedApplications ;\r
-! : GetMultipleTrusteeA ;\r
-! : GetMultipleTrusteeOperationA ;\r
-! : GetMultipleTrusteeOperationW ;\r
-! : GetMultipleTrusteeW ;\r
-! : GetNamedSecurityInfoA ;\r
-! : GetNamedSecurityInfoExA ;\r
-! : GetNamedSecurityInfoExW ;\r
-! : GetNamedSecurityInfoW ;\r
-! : GetNumberOfEventLogRecords ;\r
-! : GetOldestEventLogRecord ;\r
-! : GetOverlappedAccessResults ;\r
-! : GetPrivateObjectSecurity ;\r
-! : GetSecurityDescriptorControl ;\r
-! : GetSecurityDescriptorDacl ;\r
-! : GetSecurityDescriptorGroup ;\r
-! : GetSecurityDescriptorLength ;\r
-! : GetSecurityDescriptorOwner ;\r
-! : GetSecurityDescriptorRMControl ;\r
-! : GetSecurityDescriptorSacl ;\r
-! : GetSecurityInfo ;\r
-! : GetSecurityInfoExA ;\r
-! : GetSecurityInfoExW ;\r
-! : GetServiceDisplayNameA ;\r
-! : GetServiceDisplayNameW ;\r
-! : GetServiceKeyNameA ;\r
-! : GetServiceKeyNameW ;\r
-! : GetSidIdentifierAuthority ;\r
-! : GetSidLengthRequired ;\r
-! : GetSidSubAuthority ;\r
-! : GetSidSubAuthorityCount ;\r
-! : GetTokenInformation ;\r
-! : GetTraceEnableFlags ;\r
-! : GetTraceEnableLevel ;\r
-! : GetTraceLoggerHandle ;\r
-! : GetTrusteeFormA ;\r
-! : GetTrusteeFormW ;\r
-! : GetTrusteeNameA ;\r
-! : GetTrusteeNameW ;\r
-! : GetTrusteeTypeA ;\r
-! : GetTrusteeTypeW ;\r
-\r
-! : GetUserNameA ;\r
-FUNCTION: BOOL GetUserNameW ( LPCTSTR lpBuffer, LPDWORD lpnSize ) ;\r
-: GetUserName GetUserNameW ;\r
-\r
-! : GetWindowsAccountDomainSid ;\r
-! : I_ScIsSecurityProcess ;\r
-! : I_ScPnPGetServiceName ;\r
-! : I_ScSendTSMessage ;\r
-! : I_ScSetServiceBitsA ;\r
-! : I_ScSetServiceBitsW ;\r
-! : IdentifyCodeAuthzLevelW ;\r
-! : ImpersonateAnonymousToken ;\r
-! : ImpersonateLoggedOnUser ;\r
-! : ImpersonateNamedPipeClient ;\r
-! : ImpersonateSelf ;\r
-! : InitializeAcl ;\r
-! : InitializeSecurityDescriptor ;\r
-! : InitializeSid ;\r
-! : InitiateSystemShutdownA ;\r
-! : InitiateSystemShutdownExA ;\r
-! : InitiateSystemShutdownExW ;\r
-! : InitiateSystemShutdownW ;\r
-! : InstallApplication ;\r
-! : IsTextUnicode ;\r
-! : IsTokenRestricted ;\r
-! : IsTokenUntrusted ;\r
-! : IsValidAcl ;\r
-! : IsValidSecurityDescriptor ;\r
-! : IsValidSid ;\r
-! : IsWellKnownSid ;\r
-! : LockServiceDatabase ;\r
-! : LogonUserA ;\r
-! : LogonUserExA ;\r
-! : LogonUserExW ;\r
-! : LogonUserW ;\r
-! : LookupAccountNameA ;\r
-! : LookupAccountNameW ;\r
-! : LookupAccountSidA ;\r
-! : LookupAccountSidW ;\r
-! : LookupPrivilegeDisplayNameA ;\r
-! : LookupPrivilegeDisplayNameW ;\r
-! : LookupPrivilegeNameA ;\r
-! : LookupPrivilegeNameW ;\r
-! : LookupPrivilegeValueA ;\r
-FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName,\r
- LPCTSTR lpName,\r
- PLUID lpLuid ) ;\r
-: LookupPrivilegeValue LookupPrivilegeValueW ;\r
-\r
-! : LookupSecurityDescriptorPartsA ;\r
-! : LookupSecurityDescriptorPartsW ;\r
-! : LsaAddAccountRights ;\r
-! : LsaAddPrivilegesToAccount ;\r
-! : LsaClearAuditLog ;\r
-! : LsaClose ;\r
-! : LsaCreateAccount ;\r
-! : LsaCreateSecret ;\r
-! : LsaCreateTrustedDomain ;\r
-! : LsaCreateTrustedDomainEx ;\r
-! : LsaDelete ;\r
-! : LsaDeleteTrustedDomain ;\r
-! : LsaEnumerateAccountRights ;\r
-! : LsaEnumerateAccounts ;\r
-! : LsaEnumerateAccountsWithUserRight ;\r
-! : LsaEnumeratePrivileges ;\r
-! : LsaEnumeratePrivilegesOfAccount ;\r
-! : LsaEnumerateTrustedDomains ;\r
-! : LsaEnumerateTrustedDomainsEx ;\r
-! : LsaFreeMemory ;\r
-! : LsaGetQuotasForAccount ;\r
-! : LsaGetRemoteUserName ;\r
-! : LsaGetSystemAccessAccount ;\r
-! : LsaGetUserName ;\r
-! : LsaICLookupNames ;\r
-! : LsaICLookupNamesWithCreds ;\r
-! : LsaICLookupSids ;\r
-! : LsaICLookupSidsWithCreds ;\r
-! : LsaLookupNames2 ;\r
-! : LsaLookupNames ;\r
-! : LsaLookupPrivilegeDisplayName ;\r
-! : LsaLookupPrivilegeName ;\r
-! : LsaLookupPrivilegeValue ;\r
-! : LsaLookupSids ;\r
-! : LsaNtStatusToWinError ;\r
-! : LsaOpenAccount ;\r
-! : LsaOpenPolicy ;\r
-! : LsaOpenPolicySce ;\r
-! : LsaOpenSecret ;\r
-! : LsaOpenTrustedDomain ;\r
-! : LsaOpenTrustedDomainByName ;\r
-! : LsaQueryDomainInformationPolicy ;\r
-! : LsaQueryForestTrustInformation ;\r
-! : LsaQueryInfoTrustedDomain ;\r
-! : LsaQueryInformationPolicy ;\r
-! : LsaQuerySecret ;\r
-! : LsaQuerySecurityObject ;\r
-! : LsaQueryTrustedDomainInfo ;\r
-! : LsaQueryTrustedDomainInfoByName ;\r
-! : LsaRemoveAccountRights ;\r
-! : LsaRemovePrivilegesFromAccount ;\r
-! : LsaRetrievePrivateData ;\r
-! : LsaSetDomainInformationPolicy ;\r
-! : LsaSetForestTrustInformation ;\r
-! : LsaSetInformationPolicy ;\r
-! : LsaSetInformationTrustedDomain ;\r
-! : LsaSetQuotasForAccount ;\r
-! : LsaSetSecret ;\r
-! : LsaSetSecurityObject ;\r
-! : LsaSetSystemAccessAccount ;\r
-! : LsaSetTrustedDomainInfoByName ;\r
-! : LsaSetTrustedDomainInformation ;\r
-! : LsaStorePrivateData ;\r
-! : MD4Final ;\r
-! : MD4Init ;\r
-! : MD4Update ;\r
-! : MD5Final ;\r
-! : MD5Init ;\r
-! : MD5Update ;\r
-! : MSChapSrvChangePassword2 ;\r
-! : MSChapSrvChangePassword ;\r
-! : MakeAbsoluteSD2 ;\r
-! : MakeAbsoluteSD ;\r
-! : MakeSelfRelativeSD ;\r
-! : MapGenericMask ;\r
-! : NotifyBootConfigStatus ;\r
-! : NotifyChangeEventLog ;\r
-! : ObjectCloseAuditAlarmA ;\r
-! : ObjectCloseAuditAlarmW ;\r
-! : ObjectDeleteAuditAlarmA ;\r
-! : ObjectDeleteAuditAlarmW ;\r
-! : ObjectOpenAuditAlarmA ;\r
-! : ObjectOpenAuditAlarmW ;\r
-! : ObjectPrivilegeAuditAlarmA ;\r
-! : ObjectPrivilegeAuditAlarmW ;\r
-! : OpenBackupEventLogA ;\r
-! : OpenBackupEventLogW ;\r
-! : OpenEncryptedFileRawA ;\r
-! : OpenEncryptedFileRawW ;\r
-! : OpenEventLogA ;\r
-! : OpenEventLogW ;\r
-\r
-! typedef enum _TOKEN_INFORMATION_CLASS {\r
-: TokenUser 1 ;\r
-: TokenGroups 2 ;\r
-: TokenPrivileges 3 ;\r
-: TokenOwner 4 ;\r
-: TokenPrimaryGroup 5 ;\r
-: TokenDefaultDacl 6 ;\r
-: TokenSource 7 ;\r
-: TokenType 8 ;\r
-: TokenImpersonationLevel 9 ;\r
-: TokenStatistics 10 ;\r
-: TokenRestrictedSids 11 ;\r
-: TokenSessionId 12 ;\r
-: TokenGroupsAndPrivileges 13 ;\r
-: TokenSessionReference 14 ;\r
-: TokenSandBoxInert 15 ;\r
-! } TOKEN_INFORMATION_CLASS;\r
-\r
-: DELETE HEX: 00010000 ; inline\r
-: READ_CONTROL HEX: 00020000 ; inline\r
-: WRITE_DAC HEX: 00040000 ; inline\r
-: WRITE_OWNER HEX: 00080000 ; inline\r
-: SYNCHRONIZE HEX: 00100000 ; inline\r
-: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline\r
-\r
-: STANDARD_RIGHTS_READ READ_CONTROL ; inline\r
-: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline\r
-: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline\r
-\r
-: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline\r
-: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline\r
-: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline\r
-: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline\r
-: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline\r
-: TOKEN_DUPLICATE HEX: 0002 ; inline\r
-: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline\r
-: TOKEN_IMPERSONATE HEX: 0004 ; inline\r
-: TOKEN_QUERY HEX: 0008 ; inline\r
-: TOKEN_QUERY_SOURCE HEX: 0010 ; inline\r
-: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline\r
-: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;\r
-\r
-: TOKEN_WRITE\r
- {\r
- STANDARD_RIGHTS_WRITE\r
- TOKEN_ADJUST_PRIVILEGES\r
- TOKEN_ADJUST_GROUPS\r
- TOKEN_ADJUST_DEFAULT\r
- } flags ; foldable\r
-\r
-: TOKEN_ALL_ACCESS\r
- {\r
- STANDARD_RIGHTS_REQUIRED\r
- TOKEN_ASSIGN_PRIMARY\r
- TOKEN_DUPLICATE\r
- TOKEN_IMPERSONATE\r
- TOKEN_QUERY\r
- TOKEN_QUERY_SOURCE\r
- TOKEN_ADJUST_PRIVILEGES\r
- TOKEN_ADJUST_GROUPS\r
- TOKEN_ADJUST_SESSIONID\r
- TOKEN_ADJUST_DEFAULT\r
- } flags ; foldable\r
-\r
-FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle,\r
- DWORD DesiredAccess,\r
- PHANDLE TokenHandle ) ;\r
-! : OpenSCManagerA ;\r
-! : OpenSCManagerW ;\r
-! : OpenServiceA ;\r
-! : OpenServiceW ;\r
-FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL OpenAsSelf, PHANDLE TokenHandle ) ;\r
-! : OpenTraceA ;\r
-! : OpenTraceW ;\r
-! : PrivilegeCheck ;\r
-! : PrivilegedServiceAuditAlarmA ;\r
-! : PrivilegedServiceAuditAlarmW ;\r
-! : ProcessIdleTasks ;\r
-! : ProcessTrace ;\r
-! : QueryAllTracesA ;\r
-! : QueryAllTracesW ;\r
-! : QueryRecoveryAgentsOnEncryptedFile ;\r
-! : QueryServiceConfig2A ;\r
-! : QueryServiceConfig2W ;\r
-! : QueryServiceConfigA ;\r
-! : QueryServiceConfigW ;\r
-! : QueryServiceLockStatusA ;\r
-! : QueryServiceLockStatusW ;\r
-! : QueryServiceObjectSecurity ;\r
-! : QueryServiceStatus ;\r
-! : QueryServiceStatusEx ;\r
-! : QueryTraceA ;\r
-! : QueryTraceW ;\r
-! : QueryUsersOnEncryptedFile ;\r
-! : QueryWindows31FilesMigration ;\r
-! : ReadEncryptedFileRaw ;\r
-! : ReadEventLogA ;\r
-! : ReadEventLogW ;\r
-! : RegCloseKey ;\r
-! : RegConnectRegistryA ;\r
-! : RegConnectRegistryW ;\r
-! : RegCreateKeyA ;\r
-! : RegCreateKeyExA ;\r
-! : RegCreateKeyExW ;\r
-! : RegCreateKeyW ;\r
-! : RegDeleteKeyA ;\r
-! : RegDeleteKeyW ;\r
-! : RegDeleteValueA ;\r
-! : RegDeleteValueW ;\r
-! : RegDisablePredefinedCache ;\r
-! : RegEnumKeyA ;\r
-! : RegEnumKeyExA ;\r
-! : RegEnumKeyExW ;\r
-! : RegEnumKeyW ;\r
-! : RegEnumValueA ;\r
-! : RegEnumValueW ;\r
-! : RegFlushKey ;\r
-! : RegGetKeySecurity ;\r
-! : RegLoadKeyA ;\r
-! : RegLoadKeyW ;\r
-! : RegNotifyChangeKeyValue ;\r
-! : RegOpenCurrentUser ;\r
-! : RegOpenKeyA ;\r
-! : RegOpenKeyExA ;\r
-! : RegOpenKeyExW ;\r
-! : RegOpenKeyW ;\r
-! : RegOpenUserClassesRoot ;\r
-! : RegOverridePredefKey ;\r
-! : RegQueryInfoKeyA ;\r
-! : RegQueryInfoKeyW ;\r
-! : RegQueryMultipleValuesA ;\r
-! : RegQueryMultipleValuesW ;\r
-! : RegQueryValueA ;\r
-! : RegQueryValueExA ;\r
-! : RegQueryValueExW ;\r
-! : RegQueryValueW ;\r
-! : RegReplaceKeyA ;\r
-! : RegReplaceKeyW ;\r
-! : RegRestoreKeyA ;\r
-! : RegRestoreKeyW ;\r
-! : RegSaveKeyA ;\r
-! : RegSaveKeyExA ;\r
-! : RegSaveKeyExW ;\r
-! : RegSaveKeyW ;\r
-! : RegSetKeySecurity ;\r
-! : RegSetValueA ;\r
-! : RegSetValueExA ;\r
-! : RegSetValueExW ;\r
-! : RegSetValueW ;\r
-! : RegUnLoadKeyA ;\r
-! : RegUnLoadKeyW ;\r
-! : RegisterEventSourceA ;\r
-! : RegisterEventSourceW ;\r
-! : RegisterIdleTask ;\r
-! : RegisterServiceCtrlHandlerA ;\r
-! : RegisterServiceCtrlHandlerExA ;\r
-! : RegisterServiceCtrlHandlerExW ;\r
-! : RegisterServiceCtrlHandlerW ;\r
-! : RegisterTraceGuidsA ;\r
-! : RegisterTraceGuidsW ;\r
-! : RemoveTraceCallback ;\r
-! : RemoveUsersFromEncryptedFile ;\r
-! : ReportEventA ;\r
-! : ReportEventW ;\r
-! : RevertToSelf ;\r
-! : SaferCloseLevel ;\r
-! : SaferComputeTokenFromLevel ;\r
-! : SaferCreateLevel ;\r
-! : SaferGetLevelInformation ;\r
-! : SaferGetPolicyInformation ;\r
-! : SaferIdentifyLevel ;\r
-! : SaferRecordEventLogEntry ;\r
-! : SaferSetLevelInformation ;\r
-! : SaferSetPolicyInformation ;\r
-! : SaferiChangeRegistryScope ;\r
-! : SaferiCompareTokenLevels ;\r
-! : SaferiIsExecutableFileType ;\r
-! : SaferiPopulateDefaultsInRegistry ;\r
-! : SaferiRecordEventLogEntry ;\r
-! : SaferiReplaceProcessThreadTokens ;\r
-! : SaferiSearchMatchingHashRules ;\r
-! : SetAclInformation ;\r
-! : SetEntriesInAccessListA ;\r
-! : SetEntriesInAccessListW ;\r
-! : SetEntriesInAclA ;\r
-! : SetEntriesInAclW ;\r
-! : SetEntriesInAuditListA ;\r
-! : SetEntriesInAuditListW ;\r
-! : SetFileSecurityA ;\r
-! : SetFileSecurityW ;\r
-! : SetInformationCodeAuthzLevelW ;\r
-! : SetInformationCodeAuthzPolicyW ;\r
-! : SetKernelObjectSecurity ;\r
-! : SetNamedSecurityInfoA ;\r
-! : SetNamedSecurityInfoExA ;\r
-! : SetNamedSecurityInfoExW ;\r
-! : SetNamedSecurityInfoW ;\r
-! : SetPrivateObjectSecurity ;\r
-! : SetPrivateObjectSecurityEx ;\r
-! : SetSecurityDescriptorControl ;\r
-! : SetSecurityDescriptorDacl ;\r
-! : SetSecurityDescriptorGroup ;\r
-! : SetSecurityDescriptorOwner ;\r
-! : SetSecurityDescriptorRMControl ;\r
-! : SetSecurityDescriptorSacl ;\r
-! : SetSecurityInfo ;\r
-! : SetSecurityInfoExA ;\r
-! : SetSecurityInfoExW ;\r
-! : SetServiceBits ;\r
-! : SetServiceObjectSecurity ;\r
-! : SetServiceStatus ;\r
-! : SetThreadToken ;\r
-! : SetTokenInformation ;\r
-! : SetTraceCallback ;\r
-! : SetUserFileEncryptionKey ;\r
-! : StartServiceA ;\r
-! : StartServiceCtrlDispatcherA ;\r
-! : StartServiceCtrlDispatcherW ;\r
-! : StartServiceW ;\r
-! : StartTraceA ;\r
-! : StartTraceW ;\r
-! : StopTraceA ;\r
-! : StopTraceW ;\r
-! : SynchronizeWindows31FilesAndWindowsNTRegistry ;\r
-! : SystemFunction001 ;\r
-! : SystemFunction002 ;\r
-! : SystemFunction003 ;\r
-! : SystemFunction004 ;\r
-! : SystemFunction005 ;\r
-! : SystemFunction006 ;\r
-! : SystemFunction007 ;\r
-! : SystemFunction008 ;\r
-! : SystemFunction009 ;\r
-! : SystemFunction010 ;\r
-! : SystemFunction011 ;\r
-! : SystemFunction012 ;\r
-! : SystemFunction013 ;\r
-! : SystemFunction014 ;\r
-! : SystemFunction015 ;\r
-! : SystemFunction016 ;\r
-! : SystemFunction017 ;\r
-! : SystemFunction018 ;\r
-! : SystemFunction019 ;\r
-! : SystemFunction020 ;\r
-! : SystemFunction021 ;\r
-! : SystemFunction022 ;\r
-! : SystemFunction023 ;\r
-! : SystemFunction024 ;\r
-! : SystemFunction025 ;\r
-! : SystemFunction026 ;\r
-! : SystemFunction027 ;\r
-! : SystemFunction028 ;\r
-! : SystemFunction029 ;\r
-! : SystemFunction030 ;\r
-! : SystemFunction031 ;\r
-! : SystemFunction032 ;\r
-! : SystemFunction033 ;\r
-! : SystemFunction034 ;\r
-! : SystemFunction035 ;\r
-! : SystemFunction036 ;\r
-! : SystemFunction040 ;\r
-! : SystemFunction041 ;\r
-! : TraceEvent ;\r
-! : TraceEventInstance ;\r
-! : TraceMessage ;\r
-! : TraceMessageVa ;\r
-! : TreeResetNamedSecurityInfoA ;\r
-! : TreeResetNamedSecurityInfoW ;\r
-! : TrusteeAccessToObjectA ;\r
-! : TrusteeAccessToObjectW ;\r
-! : UninstallApplication ;\r
-! : UnlockServiceDatabase ;\r
-! : UnregisterIdleTask ;\r
-! : UnregisterTraceGuids ;\r
-! : UpdateTraceA ;\r
-! : UpdateTraceW ;\r
-! : WdmWmiServiceMain ;\r
-! : WmiCloseBlock ;\r
-! : WmiCloseTraceWithCursor ;\r
-! : WmiConvertTimestamp ;\r
-! : WmiDevInstToInstanceNameA ;\r
-! : WmiDevInstToInstanceNameW ;\r
-! : WmiEnumerateGuids ;\r
-! : WmiExecuteMethodA ;\r
-! : WmiExecuteMethodW ;\r
-! : WmiFileHandleToInstanceNameA ;\r
-! : WmiFileHandleToInstanceNameW ;\r
-! : WmiFreeBuffer ;\r
-! : WmiGetFirstTraceOffset ;\r
-! : WmiGetNextEvent ;\r
-! : WmiGetTraceHeader ;\r
-! : WmiMofEnumerateResourcesA ;\r
-! : WmiMofEnumerateResourcesW ;\r
-! : WmiNotificationRegistrationA ;\r
-! : WmiNotificationRegistrationW ;\r
-! : WmiOpenBlock ;\r
-! : WmiOpenTraceWithCursor ;\r
-! : WmiParseTraceEvent ;\r
-! : WmiQueryAllDataA ;\r
-! : WmiQueryAllDataMultipleA ;\r
-! : WmiQueryAllDataMultipleW ;\r
-! : WmiQueryAllDataW ;\r
-! : WmiQueryGuidInformation ;\r
-! : WmiQuerySingleInstanceA ;\r
-! : WmiQuerySingleInstanceMultipleA ;\r
-! : WmiQuerySingleInstanceMultipleW ;\r
-! : WmiQuerySingleInstanceW ;\r
-! : WmiReceiveNotificationsA ;\r
-! : WmiReceiveNotificationsW ;\r
-! : WmiSetSingleInstanceA ;\r
-! : WmiSetSingleInstanceW ;\r
-! : WmiSetSingleItemA ;\r
-! : WmiSetSingleItemW ;\r
-! : Wow64Win32ApiEntry ;\r
-! : WriteEncryptedFileRaw ;\r
-\r
-\r
+USING: alien.syntax kernel math windows.types math.bitfields ;
+IN: windows.advapi32
+LIBRARY: advapi32
+
+: PROV_RSA_FULL 1 ; inline
+: PROV_RSA_SIG 2 ; inline
+: PROV_DSS 3 ; inline
+: PROV_FORTEZZA 4 ; inline
+: PROV_MS_EXCHANGE 5 ; inline
+: PROV_SSL 6 ; inline
+: PROV_RSA_SCHANNEL 12 ; inline
+: PROV_DSS_DH 13 ; inline
+: PROV_EC_ECDSA_SIG 14 ; inline
+: PROV_EC_ECNRA_SIG 15 ; inline
+: PROV_EC_ECDSA_FULL 16 ; inline
+: PROV_EC_ECNRA_FULL 17 ; inline
+: PROV_DH_SCHANNEL 18 ; inline
+: PROV_SPYRUS_LYNKS 20 ; inline
+: PROV_RNG 21 ; inline
+: PROV_INTEL_SEC 22 ; inline
+: PROV_REPLACE_OWF 23 ; inline
+: PROV_RSA_AES 24 ; inline
+
+: MS_DEF_DH_SCHANNEL_PROV
+ "Microsoft DH Schannel Cryptographic Provider" ; inline
+
+: MS_DEF_DSS_DH_PROV
+ "Microsoft Base DSS and Diffie-Hellman Cryptographic Provider" ; inline
+
+: MS_DEF_DSS_PROV
+ "Microsoft Base DSS Cryptographic Provider" ; inline
+
+: MS_DEF_PROV
+ "Microsoft Base Cryptographic Provider v1.0" ; inline
+
+: MS_DEF_RSA_SCHANNEL_PROV
+ "Microsoft RSA Schannel Cryptographic Provider" ; inline
+
+! Unsupported (!)
+: MS_DEF_RSA_SIG_PROV
+ "Microsoft RSA Signature Cryptographic Provider" ; inline
+
+: MS_ENH_DSS_DH_PROV
+ "Microsoft Enhanced DSS and Diffie-Hellman Cryptographic Provider" ; inline
+
+: MS_ENH_RSA_AES_PROV
+ "Microsoft Enhanced RSA and AES Cryptographic Provider" ; inline
+
+: MS_ENHANCED_PROV
+ "Microsoft Enhanced Cryptographic Provider v1.0" ; inline
+
+: MS_SCARD_PROV
+ "Microsoft Base Smart Card Crypto Provider" ; inline
+
+: MS_STRONG_PROV
+ "Microsoft Strong Cryptographic Provider" ; inline
+
+: CRYPT_VERIFYCONTEXT HEX: F0000000 ; inline
+: CRYPT_NEWKEYSET HEX: 8 ; inline
+: CRYPT_DELETEKEYSET HEX: 10 ; inline
+: CRYPT_MACHINE_KEYSET HEX: 20 ; inline
+: CRYPT_SILENT HEX: 40 ; inline
+
+C-STRUCT: ACL
+ { "BYTE" "AclRevision" }
+ { "BYTE" "Sbz1" }
+ { "WORD" "AclSize" }
+ { "WORD" "AceCount" }
+ { "WORD" "Sbz2" } ;
+
+TYPEDEF: ACL* PACL
+
+: ACCESS_ALLOWED_ACE_TYPE 0 ; inline
+: ACCESS_DENIED_ACE_TYPE 1 ; inline
+: SYSTEM_AUDIT_ACE_TYPE 2 ; inline
+: SYSTEM_ALARM_ACE_TYPE 3 ; inline
+
+: OBJECT_INHERIT_ACE HEX: 1 ; inline
+: CONTAINER_INHERIT_ACE HEX: 2 ; inline
+: NO_PROPAGATE_INHERIT_ACE HEX: 4 ; inline
+: INHERIT_ONLY_ACE HEX: 8 ; inline
+: VALID_INHERIT_FLAGS HEX: f ; inline
+
+C-STRUCT: ACE_HEADER
+ { "BYTE" "AceType" }
+ { "BYTE" "AceFlags" }
+ { "WORD" "AceSize" } ;
+
+TYPEDEF: ACE_HEADER* PACE_HEADER
+
+C-STRUCT: ACCESS_ALLOWED_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: ACCESS_ALLOWED_ACE* PACCESS_ALLOWED_ACE
+
+C-STRUCT: ACCESS_DENIED_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+TYPEDEF: ACCESS_DENIED_ACE* PACCESS_DENIED_ACE
+
+
+C-STRUCT: SYSTEM_AUDIT_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: SYSTEM_AUDIT_ACE* PSYSTEM_AUDIT_ACE
+
+C-STRUCT: SYSTEM_ALARM_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: SYSTEM_ALARM_ACE* PSYSTEM_ALARM_ACE
+
+C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
+ { "ACE_HEADER" "Header" }
+ { "DWORD" "Mask" }
+ { "DWORD" "SidStart" } ;
+
+TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
+
+
+! typedef enum _TOKEN_INFORMATION_CLASS {
+: TokenUser 1 ; inline
+: TokenGroups 2 ; inline
+: TokenPrivileges 3 ; inline
+: TokenOwner 4 ; inline
+: TokenPrimaryGroup 5 ; inline
+: TokenDefaultDacl 6 ; inline
+: TokenSource 7 ; inline
+: TokenType 8 ; inline
+: TokenImpersonationLevel 9 ; inline
+: TokenStatistics 10 ; inline
+: TokenRestrictedSids 11 ; inline
+: TokenSessionId 12 ; inline
+: TokenGroupsAndPrivileges 13 ; inline
+: TokenSessionReference 14 ; inline
+: TokenSandBoxInert 15 ; inline
+! } TOKEN_INFORMATION_CLASS;
+
+: DELETE HEX: 00010000 ; inline
+: READ_CONTROL HEX: 00020000 ; inline
+: WRITE_DAC HEX: 00040000 ; inline
+: WRITE_OWNER HEX: 00080000 ; inline
+: SYNCHRONIZE HEX: 00100000 ; inline
+: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
+
+: STANDARD_RIGHTS_READ READ_CONTROL ; inline
+: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
+: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
+
+: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
+: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
+: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
+: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
+: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
+: TOKEN_DUPLICATE HEX: 0002 ; inline
+: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
+: TOKEN_IMPERSONATE HEX: 0004 ; inline
+: TOKEN_QUERY HEX: 0008 ; inline
+: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
+: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
+: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
+
+: TOKEN_WRITE
+ {
+ STANDARD_RIGHTS_WRITE
+ TOKEN_ADJUST_PRIVILEGES
+ TOKEN_ADJUST_GROUPS
+ TOKEN_ADJUST_DEFAULT
+ } flags ; foldable
+
+: TOKEN_ALL_ACCESS
+ {
+ STANDARD_RIGHTS_REQUIRED
+ TOKEN_ASSIGN_PRIMARY
+ TOKEN_DUPLICATE
+ TOKEN_IMPERSONATE
+ TOKEN_QUERY
+ TOKEN_QUERY_SOURCE
+ TOKEN_ADJUST_PRIVILEGES
+ TOKEN_ADJUST_GROUPS
+ TOKEN_ADJUST_SESSIONID
+ TOKEN_ADJUST_DEFAULT
+ } flags ; foldable
+
+
+! : I_ScGetCurrentGroupStateW ;
+! : A_SHAFinal ;
+! : A_SHAInit ;
+! : A_SHAUpdate ;
+! : AbortSystemShutdownA ;
+! : AbortSystemShutdownW ;
+! : AccessCheck ;
+! : AccessCheckAndAuditAlarmA ;
+! : AccessCheckAndAuditAlarmW ;
+! : AccessCheckByType ;
+! : AccessCheckByTypeAndAuditAlarmA ;
+! : AccessCheckByTypeAndAuditAlarmW ;
+! : AccessCheckByTypeResultList ;
+! : AccessCheckByTypeResultListAndAuditAlarmA ;
+! : AccessCheckByTypeResultListAndAuditAlarmByHandleA ;
+! : AccessCheckByTypeResultListAndAuditAlarmByHandleW ;
+! : AccessCheckByTypeResultListAndAuditAlarmW ;
+! : AddAccessAllowedAce ;
+! : AddAccessAllowedAceEx ;
+! : AddAccessAllowedObjectAce ;
+! : AddAccessDeniedAce ;
+! : AddAccessDeniedAceEx ;
+! : AddAccessDeniedObjectAce ;
+FUNCTION: BOOL AddAce ( PACL pAcl, DWORD dwAceRevision, DWORD dwStartingAceIndex, LPVOID pAceList, DWORD nAceListLength ) ;
+! : AddAuditAccessAce ;
+! : AddAuditAccessAceEx ;
+! : AddAuditAccessObjectAce ;
+! : AddUsersToEncryptedFile ;
+! : AdjustTokenGroups ;
+FUNCTION: BOOL AdjustTokenPrivileges ( HANDLE TokenHandle,
+ BOOL DisableAllPrivileges,
+ PTOKEN_PRIVILEGES NewState,
+ DWORD BufferLength,
+ PTOKEN_PRIVILEGES PreviousState,
+ PDWORD ReturnLength ) ;
+
+! : AllocateAndInitializeSid ;
+! : AllocateLocallyUniqueId ;
+! : AreAllAccessesGranted ;
+! : AreAnyAccessesGranted ;
+! : BackupEventLogA ;
+! : BackupEventLogW ;
+! : BuildExplicitAccessWithNameA ;
+! : BuildExplicitAccessWithNameW ;
+! : BuildImpersonateExplicitAccessWithNameA ;
+! : BuildImpersonateExplicitAccessWithNameW ;
+! : BuildImpersonateTrusteeA ;
+! : BuildImpersonateTrusteeW ;
+! : BuildSecurityDescriptorA ;
+! : BuildSecurityDescriptorW ;
+! : BuildTrusteeWithNameA ;
+! : BuildTrusteeWithNameW ;
+! : BuildTrusteeWithObjectsAndNameA ;
+! : BuildTrusteeWithObjectsAndNameW ;
+! : BuildTrusteeWithObjectsAndSidA ;
+! : BuildTrusteeWithObjectsAndSidW ;
+! : BuildTrusteeWithSidA ;
+! : BuildTrusteeWithSidW ;
+! : CancelOverlappedAccess ;
+! : ChangeServiceConfig2A ;
+! : ChangeServiceConfig2W ;
+! : ChangeServiceConfigA ;
+! : ChangeServiceConfigW ;
+! : CheckTokenMembership ;
+! : ClearEventLogA ;
+! : ClearEventLogW ;
+! : CloseCodeAuthzLevel ;
+! : CloseEncryptedFileRaw ;
+! : CloseEventLog ;
+! : CloseServiceHandle ;
+! : CloseTrace ;
+! : CommandLineFromMsiDescriptor ;
+! : ComputeAccessTokenFromCodeAuthzLevel ;
+! : ControlService ;
+! : ControlTraceA ;
+! : ControlTraceW ;
+! : ConvertAccessToSecurityDescriptorA ;
+! : ConvertAccessToSecurityDescriptorW ;
+! : ConvertSDToStringSDRootDomainA ;
+! : ConvertSDToStringSDRootDomainW ;
+! : ConvertSecurityDescriptorToAccessA ;
+! : ConvertSecurityDescriptorToAccessNamedA ;
+! : ConvertSecurityDescriptorToAccessNamedW ;
+! : ConvertSecurityDescriptorToAccessW ;
+! : ConvertSecurityDescriptorToStringSecurityDescriptorA ;
+! : ConvertSecurityDescriptorToStringSecurityDescriptorW ;
+! : ConvertSidToStringSidA ;
+! : ConvertSidToStringSidW ;
+! : ConvertStringSDToSDDomainA ;
+! : ConvertStringSDToSDDomainW ;
+! : ConvertStringSDToSDRootDomainA ;
+! : ConvertStringSDToSDRootDomainW ;
+! : ConvertStringSecurityDescriptorToSecurityDescriptorA ;
+! : ConvertStringSecurityDescriptorToSecurityDescriptorW ;
+! : ConvertStringSidToSidA ;
+! : ConvertStringSidToSidW ;
+! : ConvertToAutoInheritPrivateObjectSecurity ;
+! : CopySid ;
+! : CreateCodeAuthzLevel ;
+! : CreatePrivateObjectSecurity ;
+! : CreatePrivateObjectSecurityEx ;
+! : CreatePrivateObjectSecurityWithMultipleInheritance ;
+! : CreateProcessAsUserA ;
+! : CreateProcessAsUserSecure ;
+! : CreateProcessAsUserW ;
+! : CreateProcessWithLogonW ;
+! : CreateRestrictedToken ;
+! : CreateServiceA ;
+! : CreateServiceW ;
+! : CreateTraceInstanceId ;
+! : CreateWellKnownSid ;
+! : CredDeleteA ;
+! : CredDeleteW ;
+! : CredEnumerateA ;
+! : CredEnumerateW ;
+! : CredFree ;
+! : CredGetSessionTypes ;
+! : CredGetTargetInfoA ;
+! : CredGetTargetInfoW ;
+! : CredIsMarshaledCredentialA ;
+! : CredIsMarshaledCredentialW ;
+! : CredMarshalCredentialA ;
+! : CredMarshalCredentialW ;
+! : CredProfileLoaded ;
+! : CredReadA ;
+! : CredReadDomainCredentialsA ;
+! : CredReadDomainCredentialsW ;
+! : CredReadW ;
+! : CredRenameA ;
+! : CredRenameW ;
+! : CredUnmarshalCredentialA ;
+! : CredUnmarshalCredentialW ;
+! : CredWriteA ;
+! : CredWriteDomainCredentialsA ;
+! : CredWriteDomainCredentialsW ;
+! : CredWriteW ;
+! : CredpConvertCredential ;
+! : CredpConvertTargetInfo ;
+! : CredpDecodeCredential ;
+! : CredpEncodeCredential ;
+! : CryptAcquireContextA ;
+FUNCTION: BOOL CryptAcquireContextW ( HCRYPTPROV* phProv,
+ LPCTSTR pszContainer,
+ LPCTSTR pszProvider,
+ DWORD dwProvType,
+ DWORD dwFlags ) ;
+
+: CryptAcquireContext CryptAcquireContextW ;
+! : CryptContextAddRef ;
+! : CryptCreateHash ;
+! : CryptDecrypt ;
+! : CryptDeriveKey ;
+! : CryptDestroyHash ;
+! : CryptDestroyKey ;
+! : CryptDuplicateHash ;
+! : CryptDuplicateKey ;
+! : CryptEncrypt ;
+! : CryptEnumProviderTypesA ;
+! : CryptEnumProviderTypesW ;
+! : CryptEnumProvidersA ;
+! : CryptEnumProvidersW ;
+! : CryptExportKey ;
+! : CryptGenKey ;
+FUNCTION: BOOL CryptGenRandom ( HCRYPTPROV hProv, DWORD dwLen, BYTE* pbBuffer ) ;
+! : CryptGetDefaultProviderA ;
+! : CryptGetDefaultProviderW ;
+! : CryptGetHashParam ;
+! : CryptGetKeyParam ;
+! : CryptGetProvParam ;
+! : CryptGetUserKey ;
+! : CryptHashData ;
+! : CryptHashSessionKey ;
+! : CryptImportKey ;
+FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ;
+! : CryptSetHashParam ;
+! : CryptSetKeyParam ;
+! : CryptSetProvParam ;
+! : CryptSetProviderA ;
+! : CryptSetProviderExA ;
+! : CryptSetProviderExW ;
+! : CryptSetProviderW ;
+! : CryptSignHashA ;
+! : CryptSignHashW ;
+! : CryptVerifySignatureA ;
+! : CryptVerifySignatureW ;
+! : DecryptFileA ;
+! : DecryptFileW ;
+! : DeleteAce ;
+! : DeleteService ;
+! : DeregisterEventSource ;
+! : DestroyPrivateObjectSecurity ;
+! : DuplicateEncryptionInfoFile ;
+! : DuplicateToken ;
+! : DuplicateTokenEx ;
+! : ElfBackupEventLogFileA ;
+! : ElfBackupEventLogFileW ;
+! : ElfChangeNotify ;
+! : ElfClearEventLogFileA ;
+! : ElfClearEventLogFileW ;
+! : ElfCloseEventLog ;
+! : ElfDeregisterEventSource ;
+! : ElfFlushEventLog ;
+! : ElfNumberOfRecords ;
+! : ElfOldestRecord ;
+! : ElfOpenBackupEventLogA ;
+! : ElfOpenBackupEventLogW ;
+! : ElfOpenEventLogA ;
+! : ElfOpenEventLogW ;
+! : ElfReadEventLogA ;
+! : ElfReadEventLogW ;
+! : ElfRegisterEventSourceA ;
+! : ElfRegisterEventSourceW ;
+! : ElfReportEventA ;
+! : ElfReportEventW ;
+! : EnableTrace ;
+! : EncryptFileA ;
+! : EncryptFileW ;
+! : EncryptedFileKeyInfo ;
+! : EncryptionDisable ;
+! : EnumDependentServicesA ;
+! : EnumDependentServicesW ;
+! : EnumServiceGroupW ;
+! : EnumServicesStatusA ;
+! : EnumServicesStatusExA ;
+! : EnumServicesStatusExW ;
+! : EnumServicesStatusW ;
+! : EnumerateTraceGuids ;
+! : EqualDomainSid ;
+! : EqualPrefixSid ;
+! : EqualSid ;
+! : FileEncryptionStatusA ;
+! : FileEncryptionStatusW ;
+! : FindFirstFreeAce ;
+! : FlushTraceA ;
+! : FlushTraceW ;
+! : FreeEncryptedFileKeyInfo ;
+! : FreeEncryptionCertificateHashList ;
+! : FreeInheritedFromArray ;
+! : FreeSid ;
+! : GetAccessPermissionsForObjectA ;
+! : GetAccessPermissionsForObjectW ;
+! : GetAce ;
+! : GetAclInformation ;
+! : GetAuditedPermissionsFromAclA ;
+! : GetAuditedPermissionsFromAclW ;
+! : GetCurrentHwProfileA ;
+! : GetCurrentHwProfileW ;
+! : GetEffectiveRightsFromAclA ;
+! : GetEffectiveRightsFromAclW ;
+! : GetEventLogInformation ;
+! : GetExplicitEntriesFromAclA ;
+! : GetExplicitEntriesFromAclW ;
+! : GetFileSecurityA ;
+! : GetFileSecurityW ;
+! : GetInformationCodeAuthzLevelW ;
+! : GetInformationCodeAuthzPolicyW ;
+! : GetInheritanceSourceA ;
+! : GetInheritanceSourceW ;
+! : GetKernelObjectSecurity ;
+! : GetLengthSid ;
+! : GetLocalManagedApplicationData ;
+! : GetLocalManagedApplications ;
+! : GetManagedApplicationCategories ;
+! : GetManagedApplications ;
+! : GetMultipleTrusteeA ;
+! : GetMultipleTrusteeOperationA ;
+! : GetMultipleTrusteeOperationW ;
+! : GetMultipleTrusteeW ;
+! : GetNamedSecurityInfoA ;
+! : GetNamedSecurityInfoExA ;
+! : GetNamedSecurityInfoExW ;
+! : GetNamedSecurityInfoW ;
+! : GetNumberOfEventLogRecords ;
+! : GetOldestEventLogRecord ;
+! : GetOverlappedAccessResults ;
+! : GetPrivateObjectSecurity ;
+! : GetSecurityDescriptorControl ;
+! : GetSecurityDescriptorDacl ;
+! : GetSecurityDescriptorGroup ;
+! : GetSecurityDescriptorLength ;
+! : GetSecurityDescriptorOwner ;
+! : GetSecurityDescriptorRMControl ;
+! : GetSecurityDescriptorSacl ;
+! : GetSecurityInfo ;
+! : GetSecurityInfoExA ;
+! : GetSecurityInfoExW ;
+! : GetServiceDisplayNameA ;
+! : GetServiceDisplayNameW ;
+! : GetServiceKeyNameA ;
+! : GetServiceKeyNameW ;
+! : GetSidIdentifierAuthority ;
+! : GetSidLengthRequired ;
+! : GetSidSubAuthority ;
+! : GetSidSubAuthorityCount ;
+! : GetTokenInformation ;
+! : GetTraceEnableFlags ;
+! : GetTraceEnableLevel ;
+! : GetTraceLoggerHandle ;
+! : GetTrusteeFormA ;
+! : GetTrusteeFormW ;
+! : GetTrusteeNameA ;
+! : GetTrusteeNameW ;
+! : GetTrusteeTypeA ;
+! : GetTrusteeTypeW ;
+
+! : GetUserNameA ;
+FUNCTION: BOOL GetUserNameW ( LPCTSTR lpBuffer, LPDWORD lpnSize ) ;
+: GetUserName GetUserNameW ;
+
+! : GetWindowsAccountDomainSid ;
+! : I_ScIsSecurityProcess ;
+! : I_ScPnPGetServiceName ;
+! : I_ScSendTSMessage ;
+! : I_ScSetServiceBitsA ;
+! : I_ScSetServiceBitsW ;
+! : IdentifyCodeAuthzLevelW ;
+! : ImpersonateAnonymousToken ;
+! : ImpersonateLoggedOnUser ;
+! : ImpersonateNamedPipeClient ;
+! : ImpersonateSelf ;
+FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
+! : InitializeSecurityDescriptor ;
+! : InitializeSid ;
+! : InitiateSystemShutdownA ;
+! : InitiateSystemShutdownExA ;
+! : InitiateSystemShutdownExW ;
+! : InitiateSystemShutdownW ;
+! : InstallApplication ;
+! : IsTextUnicode ;
+! : IsTokenRestricted ;
+! : IsTokenUntrusted ;
+! : IsValidAcl ;
+! : IsValidSecurityDescriptor ;
+! : IsValidSid ;
+! : IsWellKnownSid ;
+! : LockServiceDatabase ;
+! : LogonUserA ;
+! : LogonUserExA ;
+! : LogonUserExW ;
+! : LogonUserW ;
+! : LookupAccountNameA ;
+! : LookupAccountNameW ;
+! : LookupAccountSidA ;
+! : LookupAccountSidW ;
+! : LookupPrivilegeDisplayNameA ;
+! : LookupPrivilegeDisplayNameW ;
+! : LookupPrivilegeNameA ;
+! : LookupPrivilegeNameW ;
+! : LookupPrivilegeValueA ;
+FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName,
+ LPCTSTR lpName,
+ PLUID lpLuid ) ;
+: LookupPrivilegeValue LookupPrivilegeValueW ;
+
+! : LookupSecurityDescriptorPartsA ;
+! : LookupSecurityDescriptorPartsW ;
+! : LsaAddAccountRights ;
+! : LsaAddPrivilegesToAccount ;
+! : LsaClearAuditLog ;
+! : LsaClose ;
+! : LsaCreateAccount ;
+! : LsaCreateSecret ;
+! : LsaCreateTrustedDomain ;
+! : LsaCreateTrustedDomainEx ;
+! : LsaDelete ;
+! : LsaDeleteTrustedDomain ;
+! : LsaEnumerateAccountRights ;
+! : LsaEnumerateAccounts ;
+! : LsaEnumerateAccountsWithUserRight ;
+! : LsaEnumeratePrivileges ;
+! : LsaEnumeratePrivilegesOfAccount ;
+! : LsaEnumerateTrustedDomains ;
+! : LsaEnumerateTrustedDomainsEx ;
+! : LsaFreeMemory ;
+! : LsaGetQuotasForAccount ;
+! : LsaGetRemoteUserName ;
+! : LsaGetSystemAccessAccount ;
+! : LsaGetUserName ;
+! : LsaICLookupNames ;
+! : LsaICLookupNamesWithCreds ;
+! : LsaICLookupSids ;
+! : LsaICLookupSidsWithCreds ;
+! : LsaLookupNames2 ;
+! : LsaLookupNames ;
+! : LsaLookupPrivilegeDisplayName ;
+! : LsaLookupPrivilegeName ;
+! : LsaLookupPrivilegeValue ;
+! : LsaLookupSids ;
+! : LsaNtStatusToWinError ;
+! : LsaOpenAccount ;
+! : LsaOpenPolicy ;
+! : LsaOpenPolicySce ;
+! : LsaOpenSecret ;
+! : LsaOpenTrustedDomain ;
+! : LsaOpenTrustedDomainByName ;
+! : LsaQueryDomainInformationPolicy ;
+! : LsaQueryForestTrustInformation ;
+! : LsaQueryInfoTrustedDomain ;
+! : LsaQueryInformationPolicy ;
+! : LsaQuerySecret ;
+! : LsaQuerySecurityObject ;
+! : LsaQueryTrustedDomainInfo ;
+! : LsaQueryTrustedDomainInfoByName ;
+! : LsaRemoveAccountRights ;
+! : LsaRemovePrivilegesFromAccount ;
+! : LsaRetrievePrivateData ;
+! : LsaSetDomainInformationPolicy ;
+! : LsaSetForestTrustInformation ;
+! : LsaSetInformationPolicy ;
+! : LsaSetInformationTrustedDomain ;
+! : LsaSetQuotasForAccount ;
+! : LsaSetSecret ;
+! : LsaSetSecurityObject ;
+! : LsaSetSystemAccessAccount ;
+! : LsaSetTrustedDomainInfoByName ;
+! : LsaSetTrustedDomainInformation ;
+! : LsaStorePrivateData ;
+! : MD4Final ;
+! : MD4Init ;
+! : MD4Update ;
+! : MD5Final ;
+! : MD5Init ;
+! : MD5Update ;
+! : MSChapSrvChangePassword2 ;
+! : MSChapSrvChangePassword ;
+! : MakeAbsoluteSD2 ;
+! : MakeAbsoluteSD ;
+! : MakeSelfRelativeSD ;
+! : MapGenericMask ;
+! : NotifyBootConfigStatus ;
+! : NotifyChangeEventLog ;
+! : ObjectCloseAuditAlarmA ;
+! : ObjectCloseAuditAlarmW ;
+! : ObjectDeleteAuditAlarmA ;
+! : ObjectDeleteAuditAlarmW ;
+! : ObjectOpenAuditAlarmA ;
+! : ObjectOpenAuditAlarmW ;
+! : ObjectPrivilegeAuditAlarmA ;
+! : ObjectPrivilegeAuditAlarmW ;
+! : OpenBackupEventLogA ;
+! : OpenBackupEventLogW ;
+! : OpenEncryptedFileRawA ;
+! : OpenEncryptedFileRawW ;
+! : OpenEventLogA ;
+! : OpenEventLogW ;
+
+FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle,
+ DWORD DesiredAccess,
+ PHANDLE TokenHandle ) ;
+! : OpenSCManagerA ;
+! : OpenSCManagerW ;
+! : OpenServiceA ;
+! : OpenServiceW ;
+FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL OpenAsSelf, PHANDLE TokenHandle ) ;
+! : OpenTraceA ;
+! : OpenTraceW ;
+! : PrivilegeCheck ;
+! : PrivilegedServiceAuditAlarmA ;
+! : PrivilegedServiceAuditAlarmW ;
+! : ProcessIdleTasks ;
+! : ProcessTrace ;
+! : QueryAllTracesA ;
+! : QueryAllTracesW ;
+! : QueryRecoveryAgentsOnEncryptedFile ;
+! : QueryServiceConfig2A ;
+! : QueryServiceConfig2W ;
+! : QueryServiceConfigA ;
+! : QueryServiceConfigW ;
+! : QueryServiceLockStatusA ;
+! : QueryServiceLockStatusW ;
+! : QueryServiceObjectSecurity ;
+! : QueryServiceStatus ;
+! : QueryServiceStatusEx ;
+! : QueryTraceA ;
+! : QueryTraceW ;
+! : QueryUsersOnEncryptedFile ;
+! : QueryWindows31FilesMigration ;
+! : ReadEncryptedFileRaw ;
+! : ReadEventLogA ;
+! : ReadEventLogW ;
+! : RegCloseKey ;
+! : RegConnectRegistryA ;
+! : RegConnectRegistryW ;
+! : RegCreateKeyA ;
+! : RegCreateKeyExA ;
+! : RegCreateKeyExW ;
+! : RegCreateKeyW ;
+! : RegDeleteKeyA ;
+! : RegDeleteKeyW ;
+! : RegDeleteValueA ;
+! : RegDeleteValueW ;
+! : RegDisablePredefinedCache ;
+! : RegEnumKeyA ;
+! : RegEnumKeyExA ;
+! : RegEnumKeyExW ;
+! : RegEnumKeyW ;
+! : RegEnumValueA ;
+! : RegEnumValueW ;
+! : RegFlushKey ;
+! : RegGetKeySecurity ;
+! : RegLoadKeyA ;
+! : RegLoadKeyW ;
+! : RegNotifyChangeKeyValue ;
+! : RegOpenCurrentUser ;
+! : RegOpenKeyA ;
+! : RegOpenKeyExA ;
+! : RegOpenKeyExW ;
+! : RegOpenKeyW ;
+! : RegOpenUserClassesRoot ;
+! : RegOverridePredefKey ;
+! : RegQueryInfoKeyA ;
+! : RegQueryInfoKeyW ;
+! : RegQueryMultipleValuesA ;
+! : RegQueryMultipleValuesW ;
+! : RegQueryValueA ;
+! : RegQueryValueExA ;
+! : RegQueryValueExW ;
+! : RegQueryValueW ;
+! : RegReplaceKeyA ;
+! : RegReplaceKeyW ;
+! : RegRestoreKeyA ;
+! : RegRestoreKeyW ;
+! : RegSaveKeyA ;
+! : RegSaveKeyExA ;
+! : RegSaveKeyExW ;
+! : RegSaveKeyW ;
+! : RegSetKeySecurity ;
+! : RegSetValueA ;
+! : RegSetValueExA ;
+! : RegSetValueExW ;
+! : RegSetValueW ;
+! : RegUnLoadKeyA ;
+! : RegUnLoadKeyW ;
+! : RegisterEventSourceA ;
+! : RegisterEventSourceW ;
+! : RegisterIdleTask ;
+! : RegisterServiceCtrlHandlerA ;
+! : RegisterServiceCtrlHandlerExA ;
+! : RegisterServiceCtrlHandlerExW ;
+! : RegisterServiceCtrlHandlerW ;
+! : RegisterTraceGuidsA ;
+! : RegisterTraceGuidsW ;
+! : RemoveTraceCallback ;
+! : RemoveUsersFromEncryptedFile ;
+! : ReportEventA ;
+! : ReportEventW ;
+! : RevertToSelf ;
+! : SaferCloseLevel ;
+! : SaferComputeTokenFromLevel ;
+! : SaferCreateLevel ;
+! : SaferGetLevelInformation ;
+! : SaferGetPolicyInformation ;
+! : SaferIdentifyLevel ;
+! : SaferRecordEventLogEntry ;
+! : SaferSetLevelInformation ;
+! : SaferSetPolicyInformation ;
+! : SaferiChangeRegistryScope ;
+! : SaferiCompareTokenLevels ;
+! : SaferiIsExecutableFileType ;
+! : SaferiPopulateDefaultsInRegistry ;
+! : SaferiRecordEventLogEntry ;
+! : SaferiReplaceProcessThreadTokens ;
+! : SaferiSearchMatchingHashRules ;
+! : SetAclInformation ;
+! : SetEntriesInAccessListA ;
+! : SetEntriesInAccessListW ;
+! : SetEntriesInAclA ;
+! : SetEntriesInAclW ;
+! : SetEntriesInAuditListA ;
+! : SetEntriesInAuditListW ;
+! : SetFileSecurityA ;
+! : SetFileSecurityW ;
+! : SetInformationCodeAuthzLevelW ;
+! : SetInformationCodeAuthzPolicyW ;
+! : SetKernelObjectSecurity ;
+! : SetNamedSecurityInfoA ;
+! : SetNamedSecurityInfoExA ;
+! : SetNamedSecurityInfoExW ;
+! : SetNamedSecurityInfoW ;
+! : SetPrivateObjectSecurity ;
+! : SetPrivateObjectSecurityEx ;
+! : SetSecurityDescriptorControl ;
+! : SetSecurityDescriptorDacl ;
+! : SetSecurityDescriptorGroup ;
+! : SetSecurityDescriptorOwner ;
+! : SetSecurityDescriptorRMControl ;
+! : SetSecurityDescriptorSacl ;
+! : SetSecurityInfo ;
+! : SetSecurityInfoExA ;
+! : SetSecurityInfoExW ;
+! : SetServiceBits ;
+! : SetServiceObjectSecurity ;
+! : SetServiceStatus ;
+! : SetThreadToken ;
+! : SetTokenInformation ;
+! : SetTraceCallback ;
+! : SetUserFileEncryptionKey ;
+! : StartServiceA ;
+! : StartServiceCtrlDispatcherA ;
+! : StartServiceCtrlDispatcherW ;
+! : StartServiceW ;
+! : StartTraceA ;
+! : StartTraceW ;
+! : StopTraceA ;
+! : StopTraceW ;
+! : SynchronizeWindows31FilesAndWindowsNTRegistry ;
+! : SystemFunction001 ;
+! : SystemFunction002 ;
+! : SystemFunction003 ;
+! : SystemFunction004 ;
+! : SystemFunction005 ;
+! : SystemFunction006 ;
+! : SystemFunction007 ;
+! : SystemFunction008 ;
+! : SystemFunction009 ;
+! : SystemFunction010 ;
+! : SystemFunction011 ;
+! : SystemFunction012 ;
+! : SystemFunction013 ;
+! : SystemFunction014 ;
+! : SystemFunction015 ;
+! : SystemFunction016 ;
+! : SystemFunction017 ;
+! : SystemFunction018 ;
+! : SystemFunction019 ;
+! : SystemFunction020 ;
+! : SystemFunction021 ;
+! : SystemFunction022 ;
+! : SystemFunction023 ;
+! : SystemFunction024 ;
+! : SystemFunction025 ;
+! : SystemFunction026 ;
+! : SystemFunction027 ;
+! : SystemFunction028 ;
+! : SystemFunction029 ;
+! : SystemFunction030 ;
+! : SystemFunction031 ;
+! : SystemFunction032 ;
+! : SystemFunction033 ;
+! : SystemFunction034 ;
+! : SystemFunction035 ;
+! : SystemFunction036 ;
+! : SystemFunction040 ;
+! : SystemFunction041 ;
+! : TraceEvent ;
+! : TraceEventInstance ;
+! : TraceMessage ;
+! : TraceMessageVa ;
+! : TreeResetNamedSecurityInfoA ;
+! : TreeResetNamedSecurityInfoW ;
+! : TrusteeAccessToObjectA ;
+! : TrusteeAccessToObjectW ;
+! : UninstallApplication ;
+! : UnlockServiceDatabase ;
+! : UnregisterIdleTask ;
+! : UnregisterTraceGuids ;
+! : UpdateTraceA ;
+! : UpdateTraceW ;
+! : WdmWmiServiceMain ;
+! : WmiCloseBlock ;
+! : WmiCloseTraceWithCursor ;
+! : WmiConvertTimestamp ;
+! : WmiDevInstToInstanceNameA ;
+! : WmiDevInstToInstanceNameW ;
+! : WmiEnumerateGuids ;
+! : WmiExecuteMethodA ;
+! : WmiExecuteMethodW ;
+! : WmiFileHandleToInstanceNameA ;
+! : WmiFileHandleToInstanceNameW ;
+! : WmiFreeBuffer ;
+! : WmiGetFirstTraceOffset ;
+! : WmiGetNextEvent ;
+! : WmiGetTraceHeader ;
+! : WmiMofEnumerateResourcesA ;
+! : WmiMofEnumerateResourcesW ;
+! : WmiNotificationRegistrationA ;
+! : WmiNotificationRegistrationW ;
+! : WmiOpenBlock ;
+! : WmiOpenTraceWithCursor ;
+! : WmiParseTraceEvent ;
+! : WmiQueryAllDataA ;
+! : WmiQueryAllDataMultipleA ;
+! : WmiQueryAllDataMultipleW ;
+! : WmiQueryAllDataW ;
+! : WmiQueryGuidInformation ;
+! : WmiQuerySingleInstanceA ;
+! : WmiQuerySingleInstanceMultipleA ;
+! : WmiQuerySingleInstanceMultipleW ;
+! : WmiQuerySingleInstanceW ;
+! : WmiReceiveNotificationsA ;
+! : WmiReceiveNotificationsW ;
+! : WmiSetSingleInstanceA ;
+! : WmiSetSingleInstanceW ;
+! : WmiSetSingleItemA ;
+! : WmiSetSingleItemW ;
+! : Wow64Win32ApiEntry ;
+! : WriteEncryptedFileRaw ;
+
+
-USING: alien alien.c-types kernel windows.ole32\r
-combinators.lib parser splitting sequences.lib\r
-sequences namespaces new-slots combinators.cleave\r
-assocs quotations shuffle accessors words macros\r
-alien.syntax fry ;\r
+USING: alien alien.c-types kernel windows.ole32 combinators.lib\r
+parser splitting sequences.lib sequences namespaces assocs\r
+quotations shuffle accessors words macros alien.syntax fry ;\r
IN: windows.com.syntax\r
\r
<PRIVATE\r
: (parse-com-function) ( tokens -- definition )\r
[ second ]\r
[ first ]\r
- [ 3 tail 2 group [ first ] map "void*" add* ]\r
+ [ 3 tail 2 group [ first ] map "void*" prefix ]\r
tri\r
<com-function-definition> ;\r
\r
: OF_REOPEN 32768 ;
: OF_VERIFY 1024 ;
-
: INFINITE HEX: FFFFFFFF ; inline
! From C:\cygwin\usr\include\w32api\winbase.h
: FILE_MAP_WRITE 2 ;
: FILE_MAP_COPY 1 ;
+: THREAD_MODE_BACKGROUND_BEGIN HEX: 10000 ; inline
+: THREAD_MODE_BACKGROUND_END HEX: 20000 ; inline
+: THREAD_PRIORITY_ABOVE_NORMAL 1 ; inline
+: THREAD_PRIORITY_BELOW_NORMAL -1 ; inline
+: THREAD_PRIORITY_HIGHEST 2 ; inline
+: THREAD_PRIORITY_IDLE -15 ; inline
+: THREAD_PRIORITY_LOWEST -2 ; inline
+: THREAD_PRIORITY_NORMAL 0 ; inline
+: THREAD_PRIORITY_TIME_CRITICAL 15 ; inline
+
C-STRUCT: OVERLAPPED
{ "int" "internal" }
{ "int" "internal-high" }
! FUNCTION: GetNumberOfConsoleMouseButtons
! FUNCTION: GetOEMCP
FUNCTION: BOOL GetOverlappedResult ( HANDLE hFile, LPOVERLAPPED lpOverlapped, LPDWORD lpNumberOfBytesTransferred, BOOL bWait ) ;
-! FUNCTION: GetPriorityClass
+FUNCTION: DWORD GetPriorityClass ( HANDLE hProcess ) ;
! FUNCTION: GetPrivateProfileIntA
! FUNCTION: GetPrivateProfileIntW
! FUNCTION: GetPrivateProfileSectionA
! FUNCTION: GetThreadContext
! FUNCTION: GetThreadIOPendingFlag
! FUNCTION: GetThreadLocale
-! FUNCTION: GetThreadPriority
-! FUNCTION: GetThreadPriorityBoost
+FUNCTION: int GetThreadPriority ( HANDLE hThread ) ;
+FUNCTION: BOOL GetThreadPriorityBoost ( HANDLE hThread, PBOOL pDisablePriorityBoost ) ;
! FUNCTION: GetThreadSelectorEntry
! FUNCTION: GetThreadTimes
! FUNCTION: GetTickCount
! FUNCTION: SetMailslotInfo
! FUNCTION: SetMessageWaitingIndicator
! FUNCTION: SetNamedPipeHandleState
-! FUNCTION: SetPriorityClass
+FUNCTION: BOOL SetPriorityClass ( HANDLE hProcess, DWORD dwPriorityClass ) ;
! FUNCTION: SetProcessAffinityMask
-! FUNCTION: SetProcessPriorityBoost
+FUNCTION: BOOL SetProcessPriorityBoost ( HANDLE hProcess, BOOL disablePriorityBoost ) ;
! FUNCTION: SetProcessShutdownParameters
! FUNCTION: SetProcessWorkingSetSize
! FUNCTION: SetStdHandle
! FUNCTION: SetThreadExecutionState
! FUNCTION: SetThreadIdealProcessor
! FUNCTION: SetThreadLocale
-! FUNCTION: SetThreadPriority
-! FUNCTION: SetThreadPriorityBoost
+FUNCTION: BOOL SetThreadPriority ( HANDLE hThread, int nPriority ) ;
+FUNCTION: BOOL SetThreadPriorityBoost ( HANDLE hThread, BOOL disablePriorityBoost ) ;
! FUNCTION: SetThreadUILanguage
! FUNCTION: SetTimerQueueTimer
! FUNCTION: SetTimeZoneInformation
: LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline
: LM_SETITEM WM_USER HEX: 0302 + ; inline
: LM_GETITEM WM_USER HEX: 0303 + ; inline
+
+
+: WA_INACTIVE 0 ; inline
+: WA_ACTIVE 1 ; inline
+: WA_CLICKACTIVE 2 ; inline
+
+: SC_SIZE HEX: f000 ; inline
+: SC_MOVE HEX: f010 ; inline
+: SC_MINIMIZE HEX: f020 ; inline
+: SC_MAXIMIZE HEX: f030 ; inline
+: SC_NEXTWINDOW HEX: f040 ; inline
+: SC_PREVWINDOW HEX: f050 ; inline
+: SC_CLOSE HEX: f060 ; inline
+: SC_VSCROLL HEX: f070 ; inline
+: SC_HSCROLL HEX: f080 ; inline
+: SC_MOUSEMENU HEX: f090 ; inline
+: SC_KEYMENU HEX: f100 ; inline
+: SC_ARRANGE HEX: f110 ; inline
+: SC_RESTORE HEX: f120 ; inline
+: SC_TASKLIST HEX: f130 ; inline
+: SC_SCREENSAVE HEX: f140 ; inline
+: SC_HOTKEY HEX: f150 ; inline
-USING: alien alien.syntax alien.c-types math kernel sequences\r
-windows windows.types combinators.lib ;\r
+USING: alien alien.syntax alien.c-types alien.strings math\r
+kernel sequences windows windows.types combinators.lib ;\r
IN: windows.ole32\r
\r
LIBRARY: ole32\r
\r
TYPEDEF: void* REFGUID\r
TYPEDEF: void* LPUNKNOWN\r
-TYPEDEF: ushort* LPOLESTR\r
-TYPEDEF: ushort* LPCOLESTR\r
+TYPEDEF: wchar_t* LPOLESTR\r
+TYPEDEF: wchar_t* LPCOLESTR\r
\r
TYPEDEF: REFGUID REFIID\r
TYPEDEF: REFGUID REFCLSID\r
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline\r
\r
: string>guid ( string -- guid )\r
- string>u16-alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;\r
+ utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;\r
: guid>string ( guid -- string )\r
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep\r
- [ StringFromGUID2 drop ] { 2 } multikeep alien>u16-string ;\r
+ [ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ;\r
\r
-USING: alien alien.c-types alien.syntax combinators
+USING: alien alien.c-types alien.strings alien.syntax combinators
kernel windows windows.user32 windows.ole32
-windows.com windows.com.syntax ;
+windows.com windows.com.syntax io.files ;
IN: windows.shell32
: CSIDL_DESKTOP HEX: 00 ; inline
: ShellExecute ShellExecuteW ; inline
: open-in-explorer ( dir -- )
- f "open" rot f f SW_SHOWNORMAL ShellExecute drop ;
+ f "open" rot (normalize-path) f f SW_SHOWNORMAL ShellExecute drop ;
: shell32-error ( n -- )
ole32-error ; inline
: shell32-directory ( n -- str )
f swap f SHGFP_TYPE_DEFAULT
MAX_UNICODE_PATH "ushort" <c-array>
- [ SHGetFolderPath shell32-error ] keep alien>u16-string ;
+ [ SHGetFolderPath shell32-error ] keep utf16n alien>string ;
: desktop ( -- str )
CSIDL_DESKTOPDIRECTORY shell32-directory ;
32 shift bitor ;
: windows-1601 ( -- timestamp )
- 1601 1 1 0 0 0 0 <timestamp> ;
+ 1601 1 1 0 0 0 instant <timestamp> ;
: FILETIME>windows-time ( FILETIME -- n )
[ FILETIME-dwLowDateTime ] keep
TYPEDEF: WCHAR TCHAR
TYPEDEF: TCHAR TBYTE
-! TYPEDEF: uchar* LPCSTR
-TYPEDEF: ushort* LPCSTR
-TYPEDEF: ushort* LPWSTR
+TYPEDEF: wchar_t* LPCSTR
+TYPEDEF: wchar_t* LPWSTR
TYPEDEF: HANDLE WINSTA ! MS docs say typedef HANDLE WINSTA ;
TYPEDEF: HANDLE HWINSTA ! typo??
TYPEDEF: HANDLE HWND
+TYPEDEF: HANDLE HCRYPTPROV
TYPEDEF: WORD LANGID
TYPEDEF: DWORD LCID
TYPEDEF: DWORD LCTYPE
! TYPEDEF: WCHAR* LPWSTR
TYPEDEF: WCHAR* LPSTR
-TYPEDEF: ushort* LPCTSTR
-TYPEDEF: ushort* LPWTSTR
+TYPEDEF: wchar_t* LPCTSTR
+TYPEDEF: wchar_t* LPWTSTR
-TYPEDEF: ushort* LPTSTR
+TYPEDEF: wchar_t* LPTSTR
TYPEDEF: LPCSTR PCTSTR
TYPEDEF: LPSTR PTSTR
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax alien.c-types arrays combinators
-kernel math namespaces parser prettyprint sequences
+USING: alien alien.syntax alien.c-types alien.strings arrays
+combinators kernel math namespaces parser prettyprint sequences
windows.errors windows.types windows.kernel32 words ;
IN: windows
: (win32-error-string) ( n -- string )
error_message
- dup alien>u16-string
+ dup utf16n alien>string
swap LocalFree drop ;
: win32-error-string ( -- str )
: win32-error ( -- )
GetLastError (win32-error) ;
-: win32-error=0/f { 0 f } member? [ win32-error ] when ;
-: win32-error>0 0 > [ win32-error ] when ;
-: win32-error<0 0 < [ win32-error ] when ;
-: win32-error<>0 zero? [ win32-error ] unless ;
+: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ;
+: win32-error>0 ( n -- ) 0 > [ win32-error ] when ;
+: win32-error<0 ( n -- ) 0 < [ win32-error ] when ;
+: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ;
: invalid-handle? ( handle -- )
INVALID_HANDLE_VALUE = [
! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
-USING: alien alien.c-types alien.syntax arrays byte-arrays
-kernel math sequences windows.types windows.kernel32
+USING: alien alien.c-types alien.strings alien.syntax arrays
+byte-arrays kernel math sequences windows.types windows.kernel32
windows.errors structs windows math.bitfields ;
IN: windows.winsock
: (winsock-error-string) ( n -- str )
! #! WSAStartup returns the error code 'n' directly
dup winsock-expected-error?
- [ drop f ] [ error_message alien>u16-string ] if ;
+ [ drop f ] [ error_message utf16n alien>string ] if ;
: winsock-error-string ( -- string/f )
WSAGetLastError (winsock-error-string) ;
broken-lines "\n" join ;
: indented-break ( string width indent -- newstring )
- [ length - broken-lines ] keep [ swap append ] curry map "\n" join ;
+ [ length - broken-lines ] keep [ prepend ] curry map "\n" join ;
-USING: kernel io alien alien.c-types namespaces threads
+USING: kernel io alien alien.c-types alien.strings namespaces threads
arrays sequences assocs math vars combinators.lib
- x11.constants x11.events x11.xlib mortar slot-accessors geom.rect ;
+ x11.constants x11.events x11.xlib mortar slot-accessors geom.rect
+ io.encodings.ascii ;
IN: x
<display> "create" !( name <display> -- display ) [
new-empty swap >>name
- dup $name dup [ string>char-alien ] [ ] if XOpenDisplay
+ dup $name dup [ ascii string>alien ] [ ] if XOpenDisplay
dup [ >>ptr ] [ "XOpenDisplay error" throw ] if
dup $ptr XDefaultScreen >>default-screen
dup $ptr XDefaultRootWindow dupd <window> new >>default-root
<window> "fetch-name" !( window -- name-or-f )
[ <- raw f <void*> dup >r XFetchName drop r>
- dup *void* alien-address 0 = [ drop f ] [ *char* ] if ]
+ dup *void* [ drop f ] [ *void* ascii alien>string ] if ]
add-method
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax arrays kernel math
-namespaces sequences io.encodings.string io.encodings.utf8 x11.xlib
-x11.constants ;
+USING: alien alien.c-types alien.strings alien.syntax arrays
+kernel math namespaces sequences io.encodings.string
+io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants ;
IN: x11.clipboard
! This code was based on by McCLIM's Backends/CLX/port.lisp
TUPLE: x-clipboard atom contents ;
: <x-clipboard> ( atom -- clipboard )
- "" x-clipboard construct-boa ;
+ "" x-clipboard boa ;
: selection-property ( -- n )
"org.factorcode.Factor.SELECTION" x-atom ;
CurrentTime XConvertSelection drop ;
: snarf-property ( prop-return -- string )
- dup *void* [ *char* ] [ drop f ] if ;
+ dup *void* [ *void* ascii alien>string ] [ drop f ] if ;
: window-property ( win prop delete? -- string )
>r dpy get -rot 0 -1 r> AnyPropertyType
: handle-event ( event window -- )
over XAnyEvent-type {
- { [ dup Expose = ] [ drop expose-event ] }
- { [ dup ConfigureNotify = ] [ drop configure-event ] }
- { [ dup ButtonPress = ] [ drop button-down-event$ ] }
- { [ dup ButtonRelease = ] [ drop button-up-event$ ] }
- { [ dup EnterNotify = ] [ drop enter-event ] }
- { [ dup LeaveNotify = ] [ drop leave-event ] }
- { [ dup MotionNotify = ] [ drop motion-event ] }
- { [ dup KeyPress = ] [ drop key-down-event ] }
- { [ dup KeyRelease = ] [ drop key-up-event ] }
- { [ dup FocusIn = ] [ drop focus-in-event ] }
- { [ dup FocusOut = ] [ drop focus-out-event ] }
- { [ dup SelectionNotify = ] [ drop selection-notify-event ] }
- { [ dup SelectionRequest = ] [ drop selection-request-event ] }
- { [ dup ClientMessage = ] [ drop client-event ] }
- { [ t ] [ 3drop ] }
- } cond ;
+ { Expose [ expose-event ] }
+ { ConfigureNotify [ configure-event ] }
+ { ButtonPress [ button-down-event$ ] }
+ { ButtonRelease [ button-up-event$ ] }
+ { EnterNotify [ enter-event ] }
+ { LeaveNotify [ leave-event ] }
+ { MotionNotify [ motion-event ] }
+ { KeyPress [ key-down-event ] }
+ { KeyRelease [ key-up-event ] }
+ { FocusIn [ focus-in-event ] }
+ { FocusOut [ focus-out-event ] }
+ { SelectionNotify [ selection-notify-event ] }
+ { SelectionRequest [ selection-request-event ] }
+ { ClientMessage [ client-event ] }
+ [ 3drop ]
+ } case ;
: configured-loc ( event -- dim )
dup XConfigureEvent-x swap XConfigureEvent-y 2array ;
! modify, just find the function or data structure in the manual
! and note the section.
-USING: kernel arrays alien alien.c-types alien.syntax
-math math.bitfields words sequences namespaces continuations ;
+USING: kernel arrays alien alien.c-types alien.strings
+alien.syntax math math.bitfields words sequences namespaces
+continuations io.encodings.ascii ;
IN: x11.xlib
LIBRARY: xlib
: initialize-x ( display-string -- )
init-locale
- dup [ string>char-alien ] when
+ dup [ ascii string>alien ] when
XOpenDisplay check-display dpy set-global
dpy get XDefaultScreen scr set-global
dpy get scr get XRootWindow root set-global ;
[ "Integers must fit in 32 bits" throw ] unless
number>string "i4" build-tag ;
-PREDICATE: object boolean { t f } member? ;
+PREDICATE: boolean < object { t f } member? ;
M: boolean item>xml
"1" "0" ? "boolean" build-tag ;
TUPLE: server-error tag message ;
: server-error ( tag message -- * )
- \ server-error construct-boa throw ;
+ \ server-error boa throw ;
M: server-error error.
"Error in XML supplied to server" print
dup children>string {
{ [ dup "1" = ] [ 2drop t ] }
{ [ "0" = ] [ drop f ] }
- { [ t ] [ "Bad boolean" server-error ] }
+ [ "Bad boolean" server-error ]
} cond ;
: unstruct-member ( tag -- )
] if* ;
M: attrs assoc-size attrs-alist length ;
-M: attrs new-assoc drop V{ } new <attrs> ;
+M: attrs new-assoc drop V{ } new-sequence <attrs> ;
M: attrs >alist attrs-alist ;
: >attrs ( assoc -- attrs )
: <contained-tag> ( name attrs -- tag )
f <tag> ;
-PREDICATE: tag contained-tag tag-children not ;
-PREDICATE: tag open-tag tag-children ;
+PREDICATE: contained-tag < tag tag-children not ;
+PREDICATE: open-tag < tag tag-children ;
T{ bad-version T{ parsing-error f 1 28 } "5 million" } "<?xml version='5 million'?><x/>" xml-error-test
T{ notags f } "" xml-error-test
T{ multitags f } "<x/><y/>" xml-error-test
-T{ bad-prolog T{ parsing-error f 1 26 } T{ prolog f "1.0" "iso-8859-1" f }
+T{ bad-prolog T{ parsing-error f 1 26 } T{ prolog f "1.0" "UTF-8" f }
} "<x/><?xml version='1.0'?>" xml-error-test
T{ capitalized-prolog T{ parsing-error f 1 6 } "XmL" } "<?XmL version='1.0'?><x/>"
xml-error-test
sample-doc string>xml dup template xml>string
] with-scope ;
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test
+[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><html xmlns:f=\"http://littledan.onigirihouse.com/namespaces/replace\"><body><span f:sub=\"foo\">foo</span><div f:sub=\"bar\">blah<a/></div><p f:sub=\"baz\"/></body></html>" ] [ test-refs ] unit-test
continuations assocs sequences.deep ;
! This is insufficient
+\ read-xml must-infer
+
SYMBOL: xml-file
[ ] [ "extra/xml/tests/test.xml" resource-path
[ file>xml ] with-html-entities xml-file set ] unit-test
] unit-test
[ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test
[ "that" ] [ xml-file get "this" swap at ] unit-test
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><a b=\"c\"/>" ]
+[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
[ "<a b='c'/>" string>xml xml>string ] unit-test
[ "abcd" ] [
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml
at swap "z" >r tuck r> swap set-at
T{ name f "blah" "z" f } swap at ] unit-test
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?><foo>bar baz</foo>" ]
+[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
[ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
-[ "<?xml version=\"1.0\" encoding=\"iso-8859-1\"?>\n<foo>\n bar\n</foo>" ]
+[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo>\n bar\n</foo>" ]
[ "<foo> bar </foo>" string>xml pprint-xml>string ] unit-test
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: xml.errors xml.data xml.utilities xml.char-classes
+USING: xml.errors xml.data xml.utilities xml.char-classes sets
xml.entities kernel state-parser kernel namespaces strings math
math.parser sequences assocs arrays splitting combinators unicode.case ;
IN: xml.tokenize
{ [ dup not ] [ 2drop ] }
{ [ 2dup = ] [ 2drop next ] }
{ [ dup CHAR: & = ] [ drop parse-entity (parse-char) ] }
- { [ t ] [ , next (parse-char) ] }
+ [ , next (parse-char) ]
} cond ;
: parse-char ( ch -- string )
T{ name f "" "version" f }
T{ name f "" "encoding" f }
T{ name f "" "standalone" f }
- } swap seq-diff
+ } swap diff
dup empty? [ drop ] [ <extra-attrs> throw ] if ;
: good-version ( version -- version )
[ T{ name f "" "version" f } swap at
[ good-version ] [ <versionless-prolog> throw ] if* ] keep
[ T{ name f "" "encoding" f } swap at
- "iso-8859-1" or ] keep
+ "UTF-8" or ] keep
T{ name f "" "standalone" f } swap at
[ yes/no>bool ] [ f ] if*
<prolog> ;
{
{ [ get-char dup CHAR: ! = ] [ drop next direct ] }
{ [ CHAR: ? = ] [ next instruct ] }
- { [ t ] [
+ [
start-tag [ dup add-ns pop-ns <closer> ]
[ middle-tag end-tag ] if
CHAR: > expect
- ] }
+ ]
} cond ;
: run-process ( tag word -- )
2dup "xtable" word-prop
>r dup name-tag r> at* [ 2nip call ] [
- drop \ process-missing construct-boa throw
+ drop \ process-missing boa throw
] if ;
: PROCESS:
>r 1array r> build-tag* ;
: standard-prolog ( -- prolog )
- T{ prolog f "1.0" "iso-8859-1" f } ;
+ T{ prolog f "1.0" "UTF-8" f } ;
: build-xml ( tag -- xml )
standard-prolog { } rot { } <xml> ;
! Copyright (C) 2005, 2006 Daniel Ehrenberg\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: hashtables kernel math namespaces sequences strings\r
-io io.streams.string xml.data assocs wrap xml.entities\r
-unicode.categories ;\r
+assocs combinators io io.streams.string\r
+xml.data wrap xml.entities unicode.categories ;\r
IN: xml.writer\r
\r
SYMBOL: xml-pprint?\r
xml-pprint? get [ -1 indentation +@ ] when ;\r
\r
: trim-whitespace ( string -- no-whitespace )\r
- [ [ blank? not ] find drop 0 or ] keep\r
- [ [ blank? not ] find-last drop [ 1+ ] [ 0 ] if* ] keep\r
- subseq ;\r
+ [ blank? ] trim ;\r
\r
: ?filter-children ( children -- no-whitespace )\r
xml-pprint? get [\r
?indent CHAR: < write1\r
dup print-name tag-attrs print-attrs ;\r
\r
+: write-start-tag ( tag -- )\r
+ write-tag ">" write ;\r
+\r
M: contained-tag write-item\r
write-tag "/>" write ;\r
\r
?indent "</" write print-name CHAR: > write1 ;\r
\r
M: open-tag write-item\r
- xml-pprint? [ [\r
- over sensitive? not and xml-pprint? set\r
- dup write-tag CHAR: > write1\r
- dup write-children write-end-tag\r
- ] keep ] change ;\r
+ xml-pprint? get >r\r
+ {\r
+ [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
+ [ write-start-tag ]\r
+ [ write-children ]\r
+ [ write-end-tag ]\r
+ } cleave\r
+ r> xml-pprint? set ;\r
\r
M: comment write-item\r
"<!--" write comment-text write "-->" write ;\r
[ write-item ] each ;\r
\r
: write-xml ( xml -- )\r
- dup xml-prolog write-prolog\r
- dup xml-before write-chunk\r
- dup write-item\r
- xml-after write-chunk ;\r
+ {\r
+ [ xml-prolog write-prolog ]\r
+ [ xml-before write-chunk ]\r
+ [ write-item ]\r
+ [ xml-after write-chunk ]\r
+ } cleave ;\r
\r
: print-xml ( xml -- )\r
write-xml nl ;\r
V{ } clone xml-stack set f push-xml ;
: default-prolog ( -- prolog )
- "1.0" "iso-8859-1" f <prolog> ;
+ "1.0" "UTF-8" f <prolog> ;
: reset-prolog ( -- )
default-prolog prolog-data set ;
TAG: MODE
"NAME" over at >r
- mode construct-empty {
+ mode new {
{ "FILE" f set-mode-file }
{ "FILE_NAME_GLOB" f set-mode-file-name-glob }
{ "FIRST_LINE_GLOB" f set-mode-first-line-glob }
f \ modes set-global ;
MEMO: (load-mode) ( name -- rule-sets )
- modes at mode-file
- "extra/xmode/modes/" swap append
- resource-path utf8 <file-reader> parse-mode ;
+ modes at [
+ mode-file
+ "extra/xmode/modes/" prepend
+ resource-path utf8 <file-reader> parse-mode
+ ] [
+ "text" (load-mode)
+ ] if* ;
SYMBOL: rule-sets
: no-such-rule-set ( name -- * )
- "No such rule set: " swap append throw ;
+ "No such rule set: " prepend throw ;
: get-rule-set ( name -- rule-sets rules )
dup "::" split1 [ swap (load-mode) ] [ rule-sets get ] if*
over [ dupd update ] [ nip clone ] if ;
: import-keywords ( parent child -- )
- over >r [ rule-set-keywords ] 2apply ?update
+ over >r [ rule-set-keywords ] bi@ ?update
r> set-rule-set-keywords ;
: import-rules ( parent child -- )
! See http://factorcode.org/license.txt for BSD license.\r
USING: io.files io.encodings.utf8 namespaces http.server\r
http.server.static http xmode.code2html kernel html sequences\r
-accessors fry combinators.cleave ;\r
+accessors fry ;\r
IN: xmode.code2html.responder\r
\r
: <sources> ( root -- responder )\r
USING: kernel strings assocs sequences hashtables sorting
- unicode.case unicode.categories ;
+ unicode.case unicode.categories sets ;
IN: xmode.keyword-map
! Based on org.gjt.sp.jedit.syntax.KeywordMap
] keep ;
: merge-rule-set-props ( props rule-set -- )
- [ rule-set-props union ] keep set-rule-set-props ;
+ [ rule-set-props assoc-union ] keep set-rule-set-props ;
! Top-level entry points
: parse-mode-tag ( tag -- rule-sets )
} set-slots ;
: <rule-set> ( -- ruleset )
- rule-set construct-empty dup init-rule-set ;
+ rule-set new dup init-rule-set ;
MEMO: standard-rule-set ( id -- ruleset )
<rule-set> [ set-rule-set-default ] keep ;
;
: construct-rule ( class -- rule )
- >r rule construct-empty r> construct-delegate ; inline
+ >r rule new r> construct-delegate ; inline
TUPLE: seq-rule ;
: rule-chars* ( rule -- string )
dup rule-chars
swap rule-start matcher-text
- text-hash-char [ add ] when* ;
+ text-hash-char [ suffix ] when* ;
: add-rule ( rule ruleset -- )
>r dup rule-chars* >upper swap
TUPLE: company employees type ;
-: <company> V{ } clone f company construct-boa ;
+: <company> V{ } clone f company boa ;
: add-employee company-employees push ;
TUPLE: employee name description ;
TAG: employee
- employee construct-empty
+ employee new
{ { "name" f set-employee-name } { f set-employee-description } }
init-from-tag swap add-employee ;
-/*
- * Copyright (C) 2003, 2007 Slava Pestov and friends.
- *
- * Redistribution and use in source and binary forms, with or without
- * modification, are permitted provided that the following conditions are met:
- *
- * 1. Redistributions of source code must retain the above copyright notice,
- * this list of conditions and the following disclaimer.
- *
- * 2. Redistributions in binary form must reproduce the above copyright notice,
- * this list of conditions and the following disclaimer in the documentation
- * and/or other materials provided with the distribution.
- *
- * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
- * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
- * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
- * DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
- * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
- * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
- * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
- * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
- * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
- * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
- */
+Copyright (C) 2003, 2008 Slava Pestov and friends.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the documentation
+ and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+++ /dev/null
-#!/usr/bin/env bash
-
-# Programs returning != 0 will not cause script to exit
-set +e
-
-# Case insensitive string comparison
-shopt -s nocaseglob
-#shopt -s nocasematch
-
-OS=
-ARCH=
-WORD=
-NO_UI=
-GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
-GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
-
-test_program_installed() {
- if ! [[ -n `type -p $1` ]] ; then
- return 0;
- fi
- return 1;
-}
-
-ensure_program_installed() {
- installed=0;
- for i in $* ;
- do
- echo -n "Checking for $i..."
- test_program_installed $i
- if [[ $? -eq 0 ]]; then
- echo -n "not "
- else
- installed=$(( $installed + 1 ))
- fi
- echo "found!"
- done
- if [[ $installed -eq 0 ]] ; then
- echo -n "Install "
- if [[ $# -eq 1 ]] ; then
- echo -n $1
- else
- echo -n "any of [ $* ]"
- fi
- echo " and try again."
- exit 1
- fi
-}
-
-check_ret() {
- RET=$?
- if [[ $RET -ne 0 ]] ; then
- echo $1 failed
- exit 2
- fi
-}
-
-check_gcc_version() {
- echo -n "Checking gcc version..."
- GCC_VERSION=`$CC --version`
- check_ret gcc
- if [[ $GCC_VERSION == *3.3.* ]] ; then
- echo "bad!"
- echo "You have a known buggy version of gcc (3.3)"
- echo "Install gcc 3.4 or higher and try again."
- exit 3
- fi
- echo "ok."
-}
-
-set_downloader() {
- test_program_installed wget curl
- if [[ $? -ne 0 ]] ; then
- DOWNLOADER=wget
- else
- DOWNLOADER="curl -O"
- fi
-}
-
-set_md5sum() {
- test_program_installed md5sum
- if [[ $? -ne 0 ]] ; then
- MD5SUM=md5sum
- else
- MD5SUM="md5 -r"
- fi
-}
-
-set_gcc() {
- case $OS in
- openbsd) ensure_program_installed egcc; CC=egcc;;
- *) CC=gcc;;
- esac
-}
-
-set_make() {
- case $OS in
- netbsd) MAKE='gmake';;
- freebsd) MAKE='gmake';;
- openbsd) MAKE='gmake';;
- dragonflybsd) MAKE='gmake';;
- *) MAKE='make';;
- esac
- if ! [[ $MAKE -eq 'gmake' ]] ; then
- ensure_program_installed gmake
- fi
-}
-
-check_installed_programs() {
- ensure_program_installed chmod
- ensure_program_installed uname
- ensure_program_installed git
- ensure_program_installed wget curl
- ensure_program_installed gcc
- ensure_program_installed make gmake
- ensure_program_installed md5sum md5
- ensure_program_installed cut
- check_gcc_version
-}
-
-check_library_exists() {
- GCC_TEST=factor-library-test.c
- GCC_OUT=factor-library-test.out
- echo -n "Checking for library $1..."
- echo "int main(){return 0;}" > $GCC_TEST
- $CC $GCC_TEST -o $GCC_OUT -l $1
- if [[ $? -ne 0 ]] ; then
- echo "not found!"
- echo "Warning: library $1 not found."
- echo "***Factor will compile NO_UI=1"
- NO_UI=1
- fi
- rm -f $GCC_TEST
- check_ret rm
- rm -f $GCC_OUT
- check_ret rm
- echo "found."
-}
-
-check_X11_libraries() {
- check_library_exists freetype
- check_library_exists GLU
- check_library_exists GL
- check_library_exists X11
-}
-
-check_libraries() {
- case $OS in
- linux) check_X11_libraries;;
- esac
-}
-
-check_factor_exists() {
- if [[ -d "factor" ]] ; then
- echo "A directory called 'factor' already exists."
- echo "Rename or delete it and try again."
- exit 4
- fi
-}
-
-find_os() {
- echo "Finding OS..."
- uname_s=`uname -s`
- check_ret uname
- case $uname_s in
- CYGWIN_NT-5.2-WOW64) OS=winnt;;
- *CYGWIN_NT*) OS=winnt;;
- *CYGWIN*) OS=winnt;;
- *darwin*) OS=macosx;;
- *Darwin*) OS=macosx;;
- *linux*) OS=linux;;
- *Linux*) OS=linux;;
- *NetBSD*) OS=netbsd;;
- *FreeBSD*) OS=freebsd;;
- *OpenBSD*) OS=openbsd;;
- *DragonFly*) OS=dragonflybsd;;
- esac
-}
-
-find_architecture() {
- echo "Finding ARCH..."
- uname_m=`uname -m`
- check_ret uname
- case $uname_m in
- i386) ARCH=x86;;
- i686) ARCH=x86;;
- amd64) ARCH=x86;;
- *86) ARCH=x86;;
- *86_64) ARCH=x86;;
- "Power Macintosh") ARCH=ppc;;
- esac
-}
-
-write_test_program() {
- echo "#include <stdio.h>" > $C_WORD.c
- echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
-}
-
-find_word_size() {
- echo "Finding WORD..."
- C_WORD=factor-word-size
- write_test_program
- gcc -o $C_WORD $C_WORD.c
- WORD=$(./$C_WORD)
- check_ret $C_WORD
- rm -f $C_WORD*
-}
-
-set_factor_binary() {
- case $OS in
- # winnt) FACTOR_BINARY=factor-nt;;
- # macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;;
- *) FACTOR_BINARY=factor;;
- esac
-}
-
-echo_build_info() {
- echo OS=$OS
- echo ARCH=$ARCH
- echo WORD=$WORD
- echo FACTOR_BINARY=$FACTOR_BINARY
- echo MAKE_TARGET=$MAKE_TARGET
- echo BOOT_IMAGE=$BOOT_IMAGE
- echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
- echo GIT_PROTOCOL=$GIT_PROTOCOL
- echo GIT_URL=$GIT_URL
- echo DOWNLOADER=$DOWNLOADER
- echo CC=$CC
- echo MAKE=$MAKE
-}
-
-set_build_info() {
- if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
- echo "OS: $OS"
- echo "ARCH: $ARCH"
- echo "WORD: $WORD"
- echo "OS, ARCH, or WORD is empty. Please report this"
- exit 5
- fi
-
- MAKE_TARGET=$OS-$ARCH-$WORD
- MAKE_IMAGE_TARGET=$ARCH.$WORD
- BOOT_IMAGE=boot.$ARCH.$WORD.image
- if [[ $OS == macosx && $ARCH == ppc ]] ; then
- MAKE_IMAGE_TARGET=$OS-$ARCH
- MAKE_TARGET=$OS-$ARCH
- BOOT_IMAGE=boot.macosx-ppc.image
- fi
- if [[ $OS == linux && $ARCH == ppc ]] ; then
- MAKE_IMAGE_TARGET=$OS-$ARCH
- MAKE_TARGET=$OS-$ARCH
- BOOT_IMAGE=boot.linux-ppc.image
- fi
-}
-
-find_build_info() {
- find_os
- find_architecture
- find_word_size
- set_factor_binary
- set_build_info
- set_downloader
- set_gcc
- set_make
- echo_build_info
-}
-
-invoke_git() {
- git $*
- check_ret git
-}
-
-git_clone() {
- echo "Downloading the git repository from factorcode.org..."
- invoke_git clone $GIT_URL
-}
-
-git_pull_factorcode() {
- echo "Updating the git repository from factorcode.org..."
- invoke_git pull $GIT_URL master
-}
-
-cd_factor() {
- cd factor
- check_ret cd
-}
-
-invoke_make() {
- $MAKE $*
- check_ret $MAKE
-}
-
-make_clean() {
- invoke_make clean
-}
-
-make_factor() {
- invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5
-}
-
-update_boot_images() {
- echo "Deleting old images..."
- rm checksums.txt* > /dev/null 2>&1
- rm $BOOT_IMAGE.* > /dev/null 2>&1
- rm staging.*.image > /dev/null 2>&1
- if [[ -f $BOOT_IMAGE ]] ; then
- get_url http://factorcode.org/images/latest/checksums.txt
- factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
- set_md5sum
- disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`;
- echo "Factorcode md5: $factorcode_md5";
- echo "Disk md5: $disk_md5";
- if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
- echo "Your disk boot image matches the one on factorcode.org."
- else
- rm $BOOT_IMAGE > /dev/null 2>&1
- get_boot_image;
- fi
- else
- get_boot_image
- fi
-}
-
-get_boot_image() {
- echo "Downloading boot image $BOOT_IMAGE."
- get_url http://factorcode.org/images/latest/$BOOT_IMAGE
-}
-
-get_url() {
- if [[ $DOWNLOADER -eq "" ]] ; then
- set_downloader;
- fi
- echo $DOWNLOADER $1 ;
- $DOWNLOADER $1
- check_ret $DOWNLOADER
-}
-
-maybe_download_dlls() {
- if [[ $OS == winnt ]] ; then
- get_url http://factorcode.org/dlls/freetype6.dll
- get_url http://factorcode.org/dlls/zlib1.dll
- get_url http://factorcode.org/dlls/OpenAL32.dll
- get_url http://factorcode.org/dlls/alut.dll
- get_url http://factorcode.org/dlls/ogg.dll
- get_url http://factorcode.org/dlls/theora.dll
- get_url http://factorcode.org/dlls/vorbis.dll
- get_url http://factorcode.org/dlls/sqlite3.dll
- chmod 777 *.dll
- check_ret chmod
- fi
-}
-
-get_config_info() {
- find_build_info
- check_installed_programs
- check_libraries
-}
-
-bootstrap() {
- ./$FACTOR_BINARY -i=$BOOT_IMAGE
-}
-
-install() {
- check_factor_exists
- get_config_info
- git_clone
- cd_factor
- make_factor
- get_boot_image
- maybe_download_dlls
- bootstrap
-}
-
-
-update() {
- get_config_info
- git_pull_factorcode
- make_clean
- make_factor
-}
-
-update_bootstrap() {
- update_boot_images
- bootstrap
-}
-
-refresh_image() {
- ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit"
- check_ret factor
-}
-
-make_boot_image() {
- ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit"
- check_ret factor
-
-}
-
-install_build_system_apt() {
- ensure_program_installed yes
- yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
- check_ret sudo
-}
-
-install_build_system_port() {
- test_program_installed git
- if [[ $? -ne 1 ]] ; then
- ensure_program_installed yes
- echo "git not found."
- echo "This script requires either git-core or port."
- echo "If it fails, install git-core or port and try again."
- ensure_program_installed port
- echo "Installing git-core with port...this will take awhile."
- yes | sudo port install git-core
- fi
-}
-
-usage() {
- echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|net-bootstrap"
- echo "If you are behind a firewall, invoke as:"
- echo "env GIT_PROTOCOL=http $0 <command>"
-}
-
-case "$1" in
- install) install ;;
- install-x11) install_build_system_apt; install ;;
- install-macosx) install_build_system_port; install ;;
- self-update) update; make_boot_image; bootstrap;;
- quick-update) update; refresh_image ;;
- update) update; update_bootstrap ;;
- bootstrap) get_config_info; bootstrap ;;
- net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
- *) usage ;;
-esac
+++ /dev/null
-#!/bin/sh
-
-if [ \( `uname -s ` = FreeBSD \) -a \( `uname -p` = i386 \) ]
-then
- echo freebsd-x86-32
-elif [ \( `uname -s` = Darwin \) -a \( `uname -p` = powerpc \) ]
-then
- echo macosx-ppc
-elif [ `uname -s` = Darwin ]
-then
- echo macosx-x86-`./misc/wordsize`
-elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ]
-then
- echo linux-x86-32
-elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ]
-then
- echo linux-x86-64
-elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ]
-then
- echo winnt-x86-`./misc/wordsize`
-else
- echo help
-fi
+++ /dev/null
-export VERSION=0.92
+++ /dev/null
-
-#include <stdio.h>
-
-int main ()
-{
- printf("%d", 8*sizeof(void*));
- return 0;
-}
--- /dev/null
+Elie Chaftari
--- /dev/null
+## ADD a single entry to people level
+
+dn: cn=John Spider,ou=people,dc=example,dc=com
+objectclass: inetOrgPerson
+cn: John Spider
+sn: Spider
+uid: 1
+userpassword: jSpider
+carlicense: HISCAR 124
+homephone: 555-111-2223
+mail: j.spider@example.com
+# ou: Sales
+
+## ADD another single entry to people level
+
+dn: cn=Sheri Matsumo,ou=people,dc=example,dc=com
+objectclass: inetOrgPerson
+cn: Sheri Matsumo
+sn: Matsumo
+uid: 2
+userpassword: sMatsumo
+carlicense: HERCAR 125
+homephone: 555-111-2225
+mail: s.matsumo@example.com
+# ou: IT
\ No newline at end of file
--- /dev/null
+# this is a comment # MUST be in FIRST column - very picky
+
+## DEFINE DIT ROOT/BASE/SUFFIX ####
+## uses RFC 2377 format
+## replace example and com as necessary below
+## or for experimentation leave as is
+
+## dcObject is an AUXILLIARY objectclass and MUST
+## have a STRUCTURAL objectclass (organization in this case)
+# this is an ENTRY sequence and is preceded by a BLANK line
+
+dn: dc=example,dc=com
+dc: example
+description: My wonderful company as much text as you want to place in this line up to 32K
+ continuation data for the line above must have <CR> or <CR><LF> i.e. ENTER works
+ on both Windows and *nix system - new line MUST begin with ONE SPACE
+objectClass: dcObject
+objectClass: organization
+o: Example, Inc.
+
+## FIRST Level hierarchy - people
+## uses mixed upper and lower case for objectclass
+# this is an ENTRY sequence and is preceded by a BLANK line
+
+dn: ou=people, dc=example,dc=com
+ou: people
+description: All people in organisation
+objectclass: organizationalunit
+
+## SECOND Level hierarchy
+## ADD a single entry under FIRST (people) level
+# this is an ENTRY sequence and is preceded by a BLANK line
+# the ou: Human Resources is the department name
+
+dn: cn=Robert Forest,ou=people,dc=example,dc=com
+objectclass: inetOrgPerson
+cn: Robert Forest
+sn: Forest
+uid: 0
+userpassword: rForest
+carlicense: HISCAR 123
+homephone: 555-111-2222
+mail: r.forest@example.com
+description: swell guy
+# ou: Human Resources
\ No newline at end of file
--- /dev/null
+#
+###### SAMPLE 1 - SIMPLE DIRECTORY ############
+#
+# NOTES: inetorgperson picks up attributes and objectclasses
+# from all three schemas
+#
+# NB: RH Linux schemas in /etc/openldap
+#
+include /opt/local/etc/openldap/schema/core.schema
+include /opt/local/etc/openldap/schema/cosine.schema
+include /opt/local/etc/openldap/schema/inetorgperson.schema
+
+
+# NO SECURITY - no access clause
+# defaults to anonymous access for read
+# only rootdn can write
+
+# NO REFERRALS
+
+# DON'T bother with ARGS file unless you feel strongly
+# slapd scripts stop scripts need this to work
+pidfile /opt/local/var/run/run/slapd.pid
+
+# enable a lot of logging - we might need it
+# but generates huge logs
+loglevel -1
+
+# NO dynamic backend modules
+
+# NO TLS-enabled connections
+
+# backend definition not required
+
+#######################################################################
+# bdb database definitions
+#
+# replace example and com below with a suitable domain
+#
+# If you don't have a domain you can leave it since example.com
+# is reserved for experimentation or change them to my and inc
+#
+#######################################################################
+
+database bdb
+suffix "dc=example, dc=com"
+
+# root or superuser
+rootdn "cn=jimbob, dc=example, dc=com"
+rootpw secret
+# The database directory MUST exist prior to running slapd AND
+# change path as necessary
+directory /opt/local/var/run/openldap-data
+
+# Indices to maintain for this directory
+# unique id so equality match only
+index uid eq
+# allows general searching on commonname, givenname and email
+index cn,gn,mail eq,sub
+# allows multiple variants on surname searching
+index sn eq,sub,subany,subfinal
+# optimise department searches
+index ou eq
+# shows use of default index parameter
+index default eq,sub
+# indices missing - uses default eq,sub
+index telephonenumber
+
--- /dev/null
+USING: alien alien.c-types io kernel ldap ldap.libldap
+namespaces prettyprint tools.test ;
+IN: ldap.tests
+
+"void*" <c-object> "ldap://localhost:389" initialize
+
+get-ldp LDAP_OPT_PROTOCOL_VERSION LDAP_VERSION3 <int> set-option
+
+[ 3 ] [
+ get-ldp LDAP_OPT_PROTOCOL_VERSION "int*" <c-object> [ get-option ] keep
+ *int
+] unit-test
+
+[
+ get-ldp "cn=jimbob,dc=example,dc=com" "secret" [
+
+ ! get-ldp "dc=example,dc=com" LDAP_SCOPE_ONELEVEL "(objectclass=*)" f 0
+ ! "void*" <c-object> [ search-s ] keep *int .
+
+ [ 2 ] [
+ get-ldp "dc=example,dc=com" LDAP_SCOPE_SUBTREE "(objectclass=*)" f 0
+ search
+ ] unit-test
+
+ ! get-ldp LDAP_RES_ANY 0 f "void*" <c-object> result .
+
+ get-ldp LDAP_RES_ANY LDAP_MSG_ALL f "void*" <c-object> result
+
+ ! get-message *int .
+
+ "Message ID: " write
+
+ get-message msgid .
+
+ get-ldp get-message get-dn .
+
+ "Entries count: " write
+
+ get-ldp get-message count-entries .
+
+ SYMBOL: entry
+ SYMBOL: attr
+
+ "Attribute: " write
+
+ get-ldp get-message first-entry entry set get-ldp entry get
+ "void*" <c-object> first-attribute dup . attr set
+
+ "Value: " write
+
+ get-ldp entry get attr get get-values *char* .
+
+ get-ldp get-message first-message msgtype result-type
+
+ get-ldp get-message next-message msgtype result-type
+
+ ] with-bind
+] drop
--- /dev/null
+! Copyright (C) 2007 Elie CHAFTARI
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Tested with OpenLDAP 2.2.7.0.21 on Mac OS X 10.4.9 PowerPC
+
+USING: alien alien.c-types assocs continuations hashtables io kernel
+ldap.libldap math namespaces sequences ;
+
+IN: ldap
+
+SYMBOL: message
+SYMBOL: ldp
+
+! =========================================================
+! Error interpretation routines
+! =========================================================
+
+: result-to-error ( ld res freeit -- num )
+ ldap_result2error ;
+
+: err-to-string ( err -- str )
+ ldap_err2string ;
+
+: check-result ( result -- )
+ dup zero? [ drop ] [
+ err-to-string throw
+ ] if ;
+
+: result-type ( result -- )
+ result-types >hashtable at print ;
+
+! =========================================================
+! Initialization routines
+! =========================================================
+
+! deprecated in favor of ldap_initialize
+: open ( host port -- ld )
+ ldap_open ;
+
+! deprecated in favor of ldap_initialize
+: init ( host port -- ld )
+ ldap_init ;
+
+: initialize ( ld url -- )
+ dupd ldap_initialize swap *void* ldp set check-result ;
+
+: get-option ( ld option outvalue -- )
+ ldap_get_option check-result ;
+
+: set-option ( ld option invalue -- )
+ ldap_set_option check-result ;
+
+! =========================================================
+! Bind operations
+! =========================================================
+
+: simple-bind ( ld who passwd -- id )
+ ldap_simple_bind ;
+
+: simple-bind-s ( ld who passwd -- )
+ ldap_simple_bind_s check-result ;
+
+: unbind-s ( ld -- )
+ ldap_unbind_s check-result ;
+
+: with-bind ( ld who passwd quot -- )
+ -roll [ simple-bind-s [ ldp get unbind-s ] [ ] cleanup ] with-scope ; inline
+
+! =========================================================
+! Search operations
+! =========================================================
+
+: search ( ld base scope filter attrs attrsonly -- id )
+ ldap_search ;
+
+: search-s ( ld base scope filter attrs attrsonly res -- )
+ ldap_search_s check-result ;
+
+! =========================================================
+! Return results of asynchronous operation routines
+! =========================================================
+
+: result ( ld msgid all timeout result -- )
+ [ ldap_result ] keep *void* message set result-type ;
+
+: parse-result ( ld result errcodep matcheddnp errmsgp referralsp serverctrlsp freeit -- )
+ ldap_parse_result check-result ;
+
+: count-messages ( ld result -- count )
+ ldap_count_messages ;
+
+: first-message ( ld result -- message )
+ ldap_first_message ;
+
+: next-message ( ld message -- message )
+ ldap_next_message ;
+
+: msgtype ( msg -- num )
+ ldap_msgtype ;
+
+: msgid ( msg -- num )
+ ldap_msgid ;
+
+: count-entries ( ld result -- count )
+ ldap_count_entries ;
+
+: first-entry ( ld result -- entry )
+ ldap_first_entry ;
+
+: next-entry ( ld entry -- entry )
+ ldap_next_entry ;
+
+: first-attribute ( ld entry berptr -- str )
+ ldap_first_attribute ;
+
+: next-attribute ( ld entry ber -- str )
+ ldap_next_attribute ;
+
+: get-values ( ld entry attr -- values )
+ ldap_get_values ;
+
+: get-dn ( ld entry -- str )
+ ldap_get_dn ;
+
+! =========================================================
+! Public routines
+! =========================================================
+
+: get-message ( -- message )
+ message get ;
+
+: get-ldp ( -- ldp )
+ ldp get ;
--- /dev/null
+Elie Chaftari
--- /dev/null
+! Copyright (C) 2007 Elie CHAFTARI
+! See http://factorcode.org/license.txt for BSD license.
+!
+! Tested with OpenLDAP 2.2.7.0.21 on Mac OS X 10.4.9 PowerPC
+!
+! export LD_LIBRARY_PATH=/opt/local/lib
+
+USING: alien alien.syntax combinators kernel system ;
+
+IN: ldap.libldap
+
+<< "libldap" {
+ { [ win32? ] [ "libldap.dll" "stdcall" ] }
+ { [ macosx? ] [ "libldap.dylib" "cdecl" ] }
+ { [ unix? ] [ "libldap.so" "cdecl" ] }
+} cond add-library >>
+
+: LDAP_VERSION1 1 ; inline
+: LDAP_VERSION2 2 ; inline
+: LDAP_VERSION3 3 ; inline
+
+: LDAP_VERSION_MIN LDAP_VERSION2 ; inline
+: LDAP_VERSION LDAP_VERSION2 ; inline
+: LDAP_VERSION_MAX LDAP_VERSION3 ; inline
+
+: LDAP_PORT 389 ; inline ! ldap:/// default LDAP port
+: LDAPS_PORT 636 ; inline ! ldaps:/// default LDAP over TLS port
+
+: LDAP_SCOPE_BASE HEX: 0000 ; inline
+: LDAP_SCOPE_BASEOBJECT LDAP_SCOPE_BASE ; inline
+: LDAP_SCOPE_ONELEVEL HEX: 0001 ; inline
+: LDAP_SCOPE_ONE LDAP_SCOPE_ONELEVEL ; inline
+: LDAP_SCOPE_SUBTREE HEX: 0002 ; inline
+: LDAP_SCOPE_SUB LDAP_SCOPE_SUBTREE ; inline
+: LDAP_SCOPE_SUBORDINATE HEX: 0003 ; inline ! OpenLDAP extension
+: LDAP_SCOPE_CHILDREN LDAP_SCOPE_SUBORDINATE ; inline
+: LDAP_SCOPE_DEFAULT -1 ; inline ! OpenLDAP extension
+
+: LDAP_RES_ANY -1 ; inline
+: LDAP_RES_UNSOLICITED 0 ; inline
+
+! how many messages to retrieve results for
+: LDAP_MSG_ONE HEX: 00 ; inline
+: LDAP_MSG_ALL HEX: 01 ; inline
+: LDAP_MSG_RECEIVED HEX: 02 ; inline
+
+! the possible result types returned
+: LDAP_RES_BIND HEX: 61 ; inline
+: LDAP_RES_SEARCH_ENTRY HEX: 64 ; inline
+: LDAP_RES_SEARCH_REFERENCE HEX: 73 ; inline
+: LDAP_RES_SEARCH_RESULT HEX: 65 ; inline
+: LDAP_RES_MODIFY HEX: 67 ; inline
+: LDAP_RES_ADD HEX: 69 ; inline
+: LDAP_RES_DELETE HEX: 6b ; inline
+: LDAP_RES_MODDN HEX: 6d ; inline
+: LDAP_RES_COMPARE HEX: 6f ; inline
+: LDAP_RES_EXTENDED HEX: 78 ; inline
+: LDAP_RES_EXTENDED_PARTIAL HEX: 79 ; inline
+
+: result-types ( -- seq ) {
+ { HEX: 61 "LDAP_RES_BIND" }
+ { HEX: 64 "LDAP_RES_SEARCH_ENTRY" }
+ { HEX: 73 "LDAP_RES_SEARCH_REFERENCE" }
+ { HEX: 65 "LDAP_RES_SEARCH_RESULT" }
+ { HEX: 67 "LDAP_RES_MODIFY" }
+ { HEX: 69 "LDAP_RES_ADD" }
+ { HEX: 6b "LDAP_RES_DELETE" }
+ { HEX: 6d "LDAP_RES_MODDN" }
+ { HEX: 6f "LDAP_RES_COMPARE" }
+ { HEX: 78 "LDAP_RES_EXTENDED" }
+ { HEX: 79 "LDAP_RES_EXTENDED_PARTIAL" }
+} ;
+
+: LDAP_OPT_PROTOCOL_VERSION HEX: 0011 ; inline
+
+C-STRUCT: ldap
+ { "char" "ld_lberoptions" }
+ { "int" "ld_deref" }
+ { "int" "ld_timelimit" }
+ { "int" "ld_sizelimit" }
+ { "int" "ld_errno" }
+ { "char*" "ld_error" }
+ { "char*" "ld_matched" }
+ { "int" "ld_refhoplimit" }
+ { "ulong" "ld_options" } ;
+
+LIBRARY: libldap
+
+! ===============================================
+! ldap.h
+! ===============================================
+
+! Will be depreciated in a later release (ldap_init() is preferred)
+FUNCTION: void* ldap_open ( char* host, int port ) ;
+
+FUNCTION: void* ldap_init ( char* host, int port ) ;
+
+FUNCTION: int ldap_initialize ( ldap* ld, char* url ) ;
+
+FUNCTION: int ldap_get_option ( void* ld, int option, void* outvalue ) ;
+
+FUNCTION: int ldap_set_option ( void* ld, int option, void* invalue ) ;
+
+FUNCTION: int ldap_simple_bind ( void* ld, char* who, char* passwd ) ;
+
+FUNCTION: int ldap_simple_bind_s ( void* ld, char* who, char* passwd ) ;
+
+FUNCTION: int ldap_unbind_s ( void* ld ) ;
+
+FUNCTION: int ldap_result2error ( void* ld, void* res, int freeit ) ;
+
+FUNCTION: char* ldap_err2string ( int err ) ;
+
+FUNCTION: int ldap_search ( void* ld, char* base, int scope, char* filter,
+ char* attrs, int attrsonly ) ;
+
+FUNCTION: int ldap_search_s ( void* ld, char* base, int scope, char* filter,
+ char* attrs, int attrsonly, void* res ) ;
+
+FUNCTION: int ldap_result ( void* ld, int msgid, int all, void* timeout,
+ void* result ) ;
+
+FUNCTION: int ldap_parse_result ( void* ld, void* result, int* errcodep,
+ char* matcheddnp, char* errmsgp,
+ char* referralsp, void* serverctrlsp,
+ int freeit ) ;
+
+FUNCTION: int ldap_count_messages ( void* ld, void* result ) ;
+
+FUNCTION: void* ldap_first_message ( void* ld, void* result ) ;
+
+FUNCTION: void* ldap_next_message ( void* ld, void* message ) ;
+
+FUNCTION: int ldap_msgtype ( void* msg ) ;
+
+FUNCTION: int ldap_msgid ( void* msg ) ;
+
+FUNCTION: int ldap_count_entries ( void* ld, void* result ) ;
+
+FUNCTION: void* ldap_first_entry ( void* ld, void* result ) ;
+
+FUNCTION: void* ldap_next_entry ( void* ld, void* entry ) ;
+
+FUNCTION: char* ldap_first_attribute ( void* ld, void* entry, void* berptr ) ;
+
+FUNCTION: char* ldap_next_attribute ( void* ld, void* entry, void* ber ) ;
+
+FUNCTION: char** ldap_get_values ( void* ld, void* entry, char* attr ) ;
+
+FUNCTION: char* ldap_get_dn ( void* ld, void* entry ) ;
--- /dev/null
+OpenLDAP binding
--- /dev/null
+enterprise
+network
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: io lint kernel math tools.test ;
+IN: lint.tests
+
+! Don't write code like this
+: lint1
+ [ "hi" print ] [ ] if ; ! when
+
+[ { [ [ ] if ] } ] [ \ lint1 lint ] unit-test
+
+: lint2
+ 1 + ; ! 1+
+[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
+
+: lint3
+ dup -rot ; ! tuck
+
+[ { [ dup -rot ] } ] [ \ lint3 lint ] unit-test
+
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.accessors arrays assocs combinators.lib io kernel
+macros math namespaces prettyprint quotations sequences
+vectors vocabs words html.elements slots.private tar ;
+IN: lint
+
+SYMBOL: def-hash
+SYMBOL: def-hash-keys
+
+: set-hash-vector ( val key hash -- )
+ 2dup at -rot >r >r ?push r> r> set-at ;
+
+: add-word-def ( word quot -- )
+ dup callable? [
+ def-hash get-global set-hash-vector
+ ] [
+ 2drop
+ ] if ;
+
+: more-defs
+ {
+ { [ swap >r swap r> ] -rot }
+ { [ swap swapd ] -rot }
+ { [ >r swap r> swap ] rot }
+ { [ swapd swap ] rot }
+ { [ dup swap ] over }
+ { [ dup -rot ] tuck }
+ { [ >r swap r> ] swapd }
+ { [ nip nip ] 2nip }
+ { [ drop drop ] 2drop }
+ { [ drop drop drop ] 3drop }
+ { [ 0 = ] zero? }
+ { [ pop drop ] pop* }
+ { [ [ ] if ] when }
+ } [ first2 swap add-word-def ] each ;
+
+: accessor-words ( -- seq )
+{
+ alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
+ alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
+ <displaced-alien> alien-unsigned-cell set-alien-signed-cell
+ set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
+ set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
+ set-alien-unsigned-8 set-alien-signed-8
+ alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
+ set-alien-float alien-float
+} ;
+
+: trivial-defs
+ {
+ [ get ] [ t ] [ { } ] [ . ] [ drop f ]
+ [ drop ] [ f ] [ first ] [ second ] [ third ] [ fourth ]
+ [ ">" write-html ] [ <unimplemented-typeflag> throw ]
+ [ "/>" write-html ]
+ } ;
+
+H{ } clone def-hash set-global
+all-words [ dup word-def add-word-def ] each
+more-defs
+
+! Remove empty word defs
+def-hash get-global [
+ drop empty? not
+] assoc-subset
+
+! Remove constants [ 1 ]
+[
+ drop dup length 1 = swap first number? and not
+] assoc-subset
+
+! Remove set-alien-cell, etc.
+[
+ drop [ accessor-words swap seq-diff ] keep [ length ] bi@ =
+] assoc-subset
+
+! Remove trivial defs
+[
+ drop trivial-defs member? not
+] assoc-subset
+
+! Remove n m shift defs
+[
+ drop dup length 3 = [
+ dup first2 [ number? ] both?
+ swap third \ shift = and not
+ ] [ drop t ] if
+] assoc-subset
+
+! Remove [ n slot ]
+[
+ drop dup length 2 = [
+ first2 \ slot = swap number? and not
+ ] [ drop t ] if
+] assoc-subset def-hash set-global
+
+: find-duplicates
+ def-hash get-global [
+ nip length 1 >
+ ] assoc-subset ;
+
+def-hash get-global keys def-hash-keys set-global
+
+GENERIC: lint ( obj -- seq )
+
+M: object lint ( obj -- seq )
+ drop f ;
+
+: subseq/member? ( subseq/member seq -- ? )
+ { [ 2dup start ] [ 2dup member? ] } || 2nip ;
+
+M: callable lint ( quot -- seq )
+ def-hash-keys get [
+ swap subseq/member?
+ ] with subset ;
+
+M: word lint ( word -- seq )
+ word-def dup callable? [ lint ] [ drop f ] if ;
+
+: word-path. ( word -- )
+ [ word-vocabulary ":" ] keep unparse 3append write nl ;
+
+: (lint.) ( pair -- )
+ first2 >r word-path. r> [
+ bl bl bl bl
+ dup .
+ "-----------------------------------" print
+ def-hash get at [ bl bl bl bl word-path. ] each
+ nl
+ ] each nl nl ;
+
+: lint. ( alist -- )
+ [ (lint.) ] each ;
+
+
+GENERIC: run-lint ( obj -- obj )
+
+: (trim-self)
+ def-hash get-global at* [
+ dupd remove empty? not
+ ] [
+ drop f
+ ] if ;
+
+: trim-self ( seq -- newseq )
+ [ [ (trim-self) ] subset ] assoc-map ;
+
+: filter-symbols ( alist -- alist )
+ [
+ nip first dup def-hash get at
+ [ first ] bi@ literalize = not
+ ] assoc-subset ;
+
+M: sequence run-lint ( seq -- seq )
+ [
+ global [ dup . flush ] bind
+ dup lint
+ ] { } map>assoc
+ trim-self
+ [ second empty? not ] subset
+ filter-symbols ;
+
+M: word run-lint ( word -- seq )
+ 1array run-lint ;
+
+: lint-all ( -- seq )
+ all-words run-lint dup lint. ;
+
+: lint-vocab ( vocab -- seq )
+ words run-lint dup lint. ;
+
+: lint-word ( word -- seq )
+ 1array run-lint dup lint. ;
--- /dev/null
+Finds potential mistakes in code
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel math.constants ;
+IN: random-tester.databank
+
+: databank ( -- array )
+ {
+ ! V{ } H{ } V{ 3 } { 3 } { } "" "asdf"
+ pi 1/0. -1/0. 0/0. [ ]
+ f t "" 0 0.0 3.14 2 -3 -7 20 3/4 -3/4 1.2/3 3.5
+ C{ 2 2 } C{ 1/0. 1/0. }
+ } ;
+
--- /dev/null
+USING: compiler continuations io kernel math namespaces
+prettyprint quotations random sequences vectors
+compiler.units ;
+USING: random-tester.databank random-tester.safe-words ;
+IN: random-tester
+
+SYMBOL: errored
+SYMBOL: before
+SYMBOL: after
+SYMBOL: quot
+TUPLE: random-tester-error ;
+
+: setup-test ( #data #code -- data... quot )
+ #! Variable stack effect
+ >r [ databank random ] times r>
+ [ drop \ safe-words get random ] map >quotation ;
+
+: test-compiler ! ( data... quot -- ... )
+ errored off
+ dup quot set
+ datastack 1 head* before set
+ [ call ] [ drop ] recover
+ datastack after set
+ clear
+ before get [ ] each
+ quot get [ compile-call ] [ errored on ] recover ;
+
+: do-test ! ( data... quot -- )
+ .s flush test-compiler
+ errored get [
+ datastack after get 2dup = [
+ 2drop
+ ] [
+ [ . ] each
+ "--" print
+ [ . ] each
+ quot get .
+ random-tester-error construct-empty throw
+ ] if
+ ] unless clear ;
+
+: random-test1 ( #data #code -- )
+ setup-test do-test ;
+
+: random-test2 ( -- )
+ 3 2 setup-test do-test ;
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel math sequences namespaces hashtables words
+arrays parser compiler syntax io prettyprint optimizer
+random math.constants math.functions layouts random-tester.utils ;
+IN: random-tester
+
+! Tweak me
+: max-length 15 ; inline
+: max-value 1000000000 ; inline
+
+! varying bit-length random number
+: random-bits ( n -- int )
+ random 2 swap ^ random ;
+
+: random-seq ( -- seq )
+ { [ ] { } V{ } "" } random
+ [ max-length random [ max-value random , ] times ] swap make ;
+
+: random-string
+ [ max-length random [ max-value random , ] times ] "" make ;
+
+: special-integers ( -- seq ) \ special-integers get ;
+[ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ]
+{ } make \ special-integers set-global
+: special-floats ( -- seq ) \ special-floats get ;
+[ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
+{ } make \ special-floats set-global
+: special-complexes ( -- seq ) \ special-complexes get ;
+[
+ { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
+ e , e neg , pi , pi neg ,
+ 0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
+ pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
+ e neg e neg rect> , e e rect> ,
+] { } make \ special-complexes set-global
+
+: random-fixnum ( -- fixnum )
+ most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
+
+: random-bignum ( -- bignum )
+ 400 random-bits first-bignum + 50% [ neg ] when ;
+
+: random-integer ( -- n )
+ 50% [
+ random-fixnum
+ ] [
+ 50% [ random-bignum ] [ special-integers get random ] if
+ ] if ;
+
+: random-positive-integer ( -- int )
+ random-integer dup 0 < [
+ neg
+ ] [
+ dup 0 = [ 1 + ] when
+ ] if ;
+
+: random-ratio ( -- ratio )
+ 1000000000 dup [ random ] bi@ 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
+
+: random-float ( -- float )
+ 50% [ random-ratio ] [ special-floats get random ] if
+ 50%
+ [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
+ >float ;
+
+: random-number ( -- number )
+ {
+ [ random-integer ]
+ [ random-ratio ]
+ [ random-float ]
+ } do-one ;
+
+: random-complex ( -- C )
+ random-number random-number rect> ;
+
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: kernel namespaces sequences sorting vocabs ;
+USING: arrays assocs generic hashtables math math.intervals math.parser math.functions refs shuffle vectors words ;
+IN: random-tester.safe-words
+
+: ?-words
+ {
+ delegate
+
+ /f
+
+ bits>float bits>double
+ float>bits double>bits
+
+ >bignum >boolean >fixnum >float
+
+ array? integer? complex? value-ref? ref? key-ref?
+ interval? number?
+ wrapper? tuple?
+ [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? zero? assoc? curry? vector? callstack? ! clear 3.14 [ <vector> assoc? ] compile-1
+ 2^ not
+ ! arrays
+ resize-array <array>
+ ! assocs
+ (assoc-stack)
+ new-assoc
+ assoc-like
+ <hashtable>
+ all-integers? (all-integers?) ! hangs?
+ assoc-push-if
+
+ (clone) assoc-clone-like ! SYMBOL: foo foo dup (clone) =
+ } ;
+
+: bignum-words
+ {
+ next-power-of-2 (next-power-of-2)
+ times
+ hashcode hashcode*
+ } ;
+
+: initialization-words
+ {
+ init-namespaces
+ } ;
+
+: stack-words
+ {
+ dup
+ drop 2drop 3drop
+ roll -roll 2swap
+
+ >r r>
+ } ;
+
+: stateful-words
+ {
+ counter
+ gensym
+ } ;
+
+: foo-words
+ {
+ set-retainstack
+ retainstack callstack
+ datastack
+ callstack>array
+ } ;
+
+: exit-words
+ {
+ call-clear die
+ } ;
+
+: bad-words ( -- array )
+ [
+ ?-words %
+ bignum-words %
+ initialization-words %
+ stack-words %
+ stateful-words %
+ exit-words %
+ foo-words %
+ ] { } make ;
+
+: safe-words ( -- array )
+ bad-words {
+ "alists" "arrays" "assocs" ! "bit-arrays" "byte-arrays"
+ ! "classes" "combinators" "compiler" "continuations"
+ ! "core-foundation" "definitions" "documents"
+ ! "float-arrays" "generic" "graphs" "growable"
+ "hashtables" ! io.*
+ "kernel" "math"
+ "math.bitfields" "math.complex" "math.constants" "math.floats"
+ "math.functions" "math.integers" "math.intervals" "math.libm"
+ "math.parser" "math.ratios" "math.vectors"
+ ! "namespaces" "quotations" "sbufs"
+ ! "queues" "strings" "sequences"
+ "vectors"
+ ! "words"
+ } [ words ] map concat seq-diff natural-sort ;
+
+safe-words \ safe-words set-global
+
+! foo dup (clone) = .
+! foo dup clone = .
+! f [ byte-array>bignum assoc-clone-like ] compile-1
+! 2 3.14 [ construct-empty number= ] compile-1
+! 3.14 [ <vector> assoc? ] compile-1
+! -3 [ ] 2 [ byte-array>bignum denominator ] compile-1
+
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: arrays assocs combinators.lib continuations kernel
+math math.functions memoize namespaces quotations random sequences
+sequences.private shuffle ;
+IN: random-tester.utils
+
+: %chance ( n -- ? )
+ 100 random > ;
+
+: 10% ( -- ? ) 10 %chance ;
+: 20% ( -- ? ) 20 %chance ;
+: 30% ( -- ? ) 30 %chance ;
+: 40% ( -- ? ) 40 %chance ;
+: 50% ( -- ? ) 50 %chance ;
+: 60% ( -- ? ) 60 %chance ;
+: 70% ( -- ? ) 70 %chance ;
+: 80% ( -- ? ) 80 %chance ;
+: 90% ( -- ? ) 90 %chance ;
+
+: call-if ( quot ? -- ) swap when ; inline
+
+: with-10% ( quot -- ) 10% call-if ; inline
+: with-20% ( quot -- ) 20% call-if ; inline
+: with-30% ( quot -- ) 30% call-if ; inline
+: with-40% ( quot -- ) 40% call-if ; inline
+: with-50% ( quot -- ) 50% call-if ; inline
+: with-60% ( quot -- ) 60% call-if ; inline
+: with-70% ( quot -- ) 70% call-if ; inline
+: with-80% ( quot -- ) 80% call-if ; inline
+: with-90% ( quot -- ) 90% call-if ; inline
+
+: random-key keys random ;
+: random-value [ random-key ] keep at ;
+
+: do-one ( seq -- ) random call ; inline
include vm/Config.unix
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-openbsd.o
+CC = egcc
CFLAGS += -export-dynamic
-LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS)
+LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) -lz
-#ifndef DEBUG
- CFLAGS += -fomit-frame-pointer
-#endif
+CFLAGS += -fomit-frame-pointer
EXE_SUFFIX =
DLL_PREFIX = lib
build_free_list(heap,heap->segment->size);
}
-/* Compute total sum of sizes of free blocks */
-CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status)
+/* Compute total sum of sizes of free blocks, and size of largest free block */
+void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free)
{
- CELL size = 0;
+ *used = 0;
+ *total_free = 0;
+ *max_free = 0;
+
F_BLOCK *scan = first_block(heap);
while(scan)
{
- if(scan->status == status)
- size += scan->size;
+ switch(scan->status)
+ {
+ case B_ALLOCATED:
+ *used += scan->size;
+ break;
+ case B_FREE:
+ *total_free += scan->size;
+ if(scan->size > *max_free)
+ *max_free = scan->size;
+ break;
+ default:
+ critical_error("Invalid scan->status",(CELL)scan);
+ }
+
scan = next_block(heap,scan);
}
-
- return size;
}
/* The size of the heap, not including the last block if it's free */
/* Push the free space and total size of the code heap */
DEFINE_PRIMITIVE(code_room)
{
- dpush(tag_fixnum(heap_usage(&code_heap,B_FREE) / 1024));
+ CELL used, total_free, max_free;
+ heap_usage(&code_heap,&used,&total_free,&max_free);
dpush(tag_fixnum((code_heap.segment->size) / 1024));
-}
-
-void code_gc(void)
-{
- garbage_collection(TENURED,true,false,0);
-}
-
-DEFINE_PRIMITIVE(code_gc)
-{
- code_gc();
+ dpush(tag_fixnum(used / 1024));
+ dpush(tag_fixnum(total_free / 1024));
+ dpush(tag_fixnum(max_free / 1024));
}
/* Dump all code blocks for debugging */
void compact_code_heap(void)
{
/* Free all unreachable code blocks */
- code_gc();
+ gc();
fprintf(stderr,"*** Code heap compaction...\n");
fflush(stderr);
CELL heap_allot(F_HEAP *heap, CELL size);
void unmark_marked(F_HEAP *heap);
void free_unmarked(F_HEAP *heap);
-CELL heap_usage(F_HEAP *heap, F_BLOCK_STATUS status);
+void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
CELL heap_size(F_HEAP *heap);
INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
void collect_literals(void);
void recursive_mark(F_BLOCK *block);
void dump_heap(F_HEAP *heap);
-void code_gc(void);
void compact_code_heap(void);
DECLARE_PRIMITIVE(code_room);
-DECLARE_PRIMITIVE(code_gc);
/* If allocation failed, do a code GC */
if(start == 0)
{
- code_gc();
+ gc();
start = heap_allot(&code_heap,size);
/* Insufficient room even after code GC, give up */
if(start == 0)
+ {
+ CELL used, total_free, max_free;
+ heap_usage(&code_heap,&used,&total_free,&max_free);
+
+ fprintf(stderr,"Code heap stats:\n");
+ fprintf(stderr,"Used: %ld\n",used);
+ fprintf(stderr,"Total free space: %ld\n",total_free);
+ fprintf(stderr,"Largest free block: %ld\n",max_free);
fatal_error("Out of memory in add-compiled-block",0);
+ }
}
return start;
#include "master.h"
+#define ALLOC_DATA_HEAP "alloc_data_heap: gens=%ld, young_size=%ld, aging_size=%ld, tenured_size=%ld\n"
+#define GC_REQUESTED "garbage_collection: growing_data_heap=%d, requested_bytes=%ld\n"
+#define BEGIN_GC "begin_gc: growing_data_heap=%d, collecting_gen=%ld\n"
+#define END_GC "end_gc: gc_elapsed=%ld\n"
+#define END_AGING_GC "end_gc: aging_collections=%ld, cards_scanned=%ld\n"
+#define END_NURSERY_GC "end_gc: nursery_collections=%ld, cards_scanned=%ld\n"
+
+#ifdef GC_DEBUG
+ #define GC_PRINT printf
+#else
+ INLINE void GC_PRINT() { }
+#endif
+
CELL init_zone(F_ZONE *z, CELL size, CELL start)
{
z->size = size;
- (data_heap->segment->start >> CARD_BITS);
}
-F_DATA_HEAP *alloc_data_heap(CELL gens, CELL young_size, CELL aging_size)
+F_DATA_HEAP *alloc_data_heap(CELL gens,
+ CELL young_size,
+ CELL aging_size,
+ CELL tenured_size)
{
+ GC_PRINT(ALLOC_DATA_HEAP,gens,young_size,aging_size,tenured_size);
+
young_size = align_page(young_size);
aging_size = align_page(aging_size);
+ tenured_size = align_page(tenured_size);
F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
data_heap->young_size = young_size;
data_heap->aging_size = aging_size;
+ data_heap->tenured_size = tenured_size;
data_heap->gen_count = gens;
CELL total_size;
if(data_heap->gen_count == 1)
- total_size = 2 * aging_size;
+ total_size = 2 * tenured_size;
else if(data_heap->gen_count == 2)
- total_size = (gens - 1) * young_size + 2 * aging_size;
+ total_size = young_size + 2 * tenured_size;
else if(data_heap->gen_count == 3)
- total_size = gens * young_size + 2 * aging_size;
+ total_size = young_size + 2 * aging_size + 2 * tenured_size;
else
{
fatal_error("Invalid number of generations",data_heap->gen_count);
data_heap->segment = alloc_segment(total_size);
- data_heap->generations = safe_malloc(sizeof(F_ZONE) * gens);
- data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * gens);
+ data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
+ data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
CELL cards_size = total_size / CARD_SIZE;
data_heap->cards = safe_malloc(cards_size);
CELL alloter = data_heap->segment->start;
- alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
-
- alloter = init_zone(&data_heap->generations[TENURED],aging_size,alloter);
- alloter = init_zone(&data_heap->semispaces[TENURED],aging_size,alloter);
-
- int i;
+ alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
- if(data_heap->gen_count > 2)
+ if(data_heap->gen_count == 3)
{
- alloter = init_zone(&data_heap->generations[AGING],young_size,alloter);
- alloter = init_zone(&data_heap->semispaces[AGING],young_size,alloter);
-
- for(i = gens - 3; i >= 0; i--)
- {
- alloter = init_zone(&data_heap->generations[i],
- young_size,alloter);
- }
+ alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
}
- else
+
+ if(data_heap->gen_count >= 2)
{
- for(i = gens - 2; i >= 0; i--)
- {
- alloter = init_zone(&data_heap->generations[i],
- young_size,alloter);
- }
+ alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
+ alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
}
if(alloter != data_heap->segment->end)
F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
{
- CELL new_young_size = (data_heap->young_size * 2) + requested_bytes;
- CELL new_aging_size = (data_heap->aging_size * 2) + requested_bytes;
+ CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
return alloc_data_heap(data_heap->gen_count,
- new_young_size,
- new_aging_size);
+ data_heap->young_size,
+ data_heap->aging_size,
+ new_tenured_size);
}
void dealloc_data_heap(F_DATA_HEAP *data_heap)
void set_data_heap(F_DATA_HEAP *data_heap_)
{
data_heap = data_heap_;
- nursery = &data_heap->generations[NURSERY];
+ nursery = data_heap->generations[NURSERY];
init_cards_offset();
clear_cards(NURSERY,TENURED);
}
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
+ CELL tenured_size,
bool secure_gc_)
{
- set_data_heap(alloc_data_heap(gens,young_size,aging_size));
+ set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
gc_locals_region = alloc_segment(getpagesize());
gc_locals = gc_locals_region->start - CELLS;
extra_roots = extra_roots_region->start - CELLS;
gc_time = 0;
- minor_collections = 0;
+ aging_collections = 0;
+ nursery_collections = 0;
cards_scanned = 0;
secure_gc = secure_gc_;
}
/* Size of the data area of an object pointed to by an untagged pointer */
CELL unaligned_object_size(CELL pointer)
{
+ F_TUPLE *tuple;
+ F_TUPLE_LAYOUT *layout;
+
switch(untag_header(get(pointer)))
{
case ARRAY_TYPE:
- case TUPLE_TYPE:
case BIGNUM_TYPE:
return array_size(array_capacity((F_ARRAY*)pointer));
case BYTE_ARRAY_TYPE:
float_array_capacity((F_FLOAT_ARRAY*)pointer));
case STRING_TYPE:
return string_size(string_capacity((F_STRING*)pointer));
+ case TUPLE_TYPE:
+ tuple = untag_object(pointer);
+ layout = untag_object(tuple->layout);
+ return tuple_size(layout);
case QUOTATION_TYPE:
return sizeof(F_QUOTATION);
case WORD_TYPE:
case CALLSTACK_TYPE:
return callstack_size(
untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
+ case TUPLE_LAYOUT_TYPE:
+ return sizeof(F_TUPLE_LAYOUT);
default:
critical_error("Invalid header",pointer);
return -1; /* can't happen */
for(gen = 0; gen < data_heap->gen_count; gen++)
{
- F_ZONE *z = &data_heap->generations[gen];
+ F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
}
DEFINE_PRIMITIVE(begin_scan)
{
- data_gc();
+ gc();
begin_scan();
}
callstack snapshot */
void collect_callstack(F_CONTEXT *stacks)
{
- if(collecting_code)
+ if(collecting_gen == TENURED)
{
CELL top = (CELL)stacks->callstack_top;
CELL bottom = (CELL)stacks->callstack_bottom;
{
do_slots(scan,copy_handle);
- if(collecting_code)
+ if(collecting_gen == TENURED)
do_code_slots(scan);
return scan + untagged_object_size(scan);
INLINE void reset_generation(CELL i)
{
- F_ZONE *z = &data_heap->generations[i];
+ F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
z->here = z->start;
if(secure_gc)
memset((void*)z->start,69,z->size);
old_data_heap = data_heap;
set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
- newspace = &data_heap->generations[collecting_gen];
+ newspace = &data_heap->generations[TENURED];
}
else if(collecting_accumulation_gen_p())
{
so we set the newspace so the next generation. */
newspace = &data_heap->generations[collecting_gen + 1];
}
-}
-void major_gc_message(void)
-{
- fprintf(stderr,"*** %s GC (%ld minor, %ld cards)\n",
- collecting_code ? "Code and data" : "Data",
- minor_collections,cards_scanned);
- fflush(stderr);
- minor_collections = 0;
- cards_scanned = 0;
+#ifdef GC_DEBUG
+ printf("\n");
+ dump_generations();
+ printf("Newspace: ");
+ dump_zone(newspace);
+ printf("\n");
+#endif
}
void end_gc(void)
dealloc_data_heap(old_data_heap);
old_data_heap = NULL;
growing_data_heap = false;
-
- fprintf(stderr,"*** Data heap resized to %lu bytes\n",
- data_heap->segment->size);
}
if(collecting_accumulation_gen_p())
reset_generations(NURSERY,collecting_gen - 1);
if(collecting_gen == TENURED)
- major_gc_message();
+ {
+ GC_PRINT(END_AGING_GC,aging_collections,cards_scanned);
+ aging_collections = 0;
+ cards_scanned = 0;
+ }
else if(HAVE_AGING_P && collecting_gen == AGING)
- minor_collections++;
+ {
+ aging_collections++;
+
+ GC_PRINT(END_NURSERY_GC,nursery_collections,cards_scanned);
+ nursery_collections = 0;
+ cards_scanned = 0;
+ }
}
else
{
collected are now empty */
reset_generations(NURSERY,collecting_gen);
- minor_collections++;
+ nursery_collections++;
}
- if(collecting_code)
+ if(collecting_gen == TENURED)
{
/* now that all reachable code blocks have been marked,
deallocate the rest */
If growing_data_heap_ is true, we must grow the data heap to such a size that
an allocation of requested_bytes won't fail */
void garbage_collection(CELL gen,
- bool code_gc,
bool growing_data_heap_,
CELL requested_bytes)
{
return;
}
+ GC_PRINT(GC_REQUESTED,growing_data_heap_,requested_bytes);
+
s64 start = current_millis();
performing_gc = true;
- collecting_code = code_gc;
growing_data_heap = growing_data_heap_;
collecting_gen = gen;
growing_data_heap = true;
/* see the comment in unmark_marked() */
- if(collecting_code)
- unmark_marked(&code_heap);
+ unmark_marked(&code_heap);
}
/* we try collecting AGING space twice before going on to
collect TENURED */
}
}
+ GC_PRINT(BEGIN_GC,growing_data_heap,collecting_gen);
begin_gc(requested_bytes);
/* initialize chase pointer */
/* collect objects referenced from stacks and environment */
collect_roots();
-
/* collect objects referenced from older generations */
collect_cards();
- if(!collecting_code)
+ if(collecting_gen != TENURED)
{
/* don't scan code heap unless it has pointers to this
generation or younger */
while(scan < newspace->here)
scan = collect_next(scan);
+ CELL gc_elapsed = (current_millis() - start);
+
+ GC_PRINT(END_GC,gc_elapsed);
end_gc();
- gc_time += (current_millis() - start);
+ gc_time += gc_elapsed;
performing_gc = false;
}
-void data_gc(void)
+void gc(void)
{
- garbage_collection(TENURED,false,false,0);
+ garbage_collection(TENURED,false,0);
}
-DEFINE_PRIMITIVE(data_gc)
+void minor_gc(void)
{
- data_gc();
+ garbage_collection(NURSERY,false,0);
}
-/* Push total time spent on GC */
-DEFINE_PRIMITIVE(gc_time)
+DEFINE_PRIMITIVE(gc)
{
- box_unsigned_8(gc_time);
+ gc();
}
-void simple_gc(void)
+/* Push total time spent on GC */
+DEFINE_PRIMITIVE(gc_time)
{
- maybe_gc(0);
+ box_unsigned_8(gc_time);
}
DEFINE_PRIMITIVE(become)
forward_object(old_obj,new_obj);
}
- data_gc();
+ gc();
+}
+
+CELL find_all_words(void)
+{
+ GROWABLE_ARRAY(words);
+
+ begin_scan();
+
+ CELL obj;
+ while((obj = next_object()) != F)
+ {
+ if(type_of(obj) == WORD_TYPE)
+ GROWABLE_ADD(words,obj);
+ }
+
+ /* End heap scan */
+ gc_off = false;
+
+ GROWABLE_TRIM(words);
+
+ return words;
}
DECLARE_PRIMITIVE(next_object);
DECLARE_PRIMITIVE(end_scan);
+void gc(void);
+DLLEXPORT void minor_gc(void);
+
/* generational copying GC divides memory into zones */
typedef struct {
/* allocation pointer is 'here'; its offset is hardcoded in the
CELL young_size;
CELL aging_size;
+ CELL tenured_size;
CELL gen_count;
F_ZONE *newspace;
/* new objects are allocated here */
-DLLEXPORT F_ZONE *nursery;
+DLLEXPORT F_ZONE nursery;
INLINE bool in_zone(F_ZONE *z, CELL pointer)
{
void init_data_heap(CELL gens,
CELL young_size,
CELL aging_size,
+ CELL tenured_size,
bool secure_gc_);
/* statistics */
s64 gc_time;
-CELL minor_collections;
+CELL nursery_collections;
+CELL aging_collections;
CELL cards_scanned;
/* only meaningful during a GC */
bool performing_gc;
CELL collecting_gen;
-bool collecting_code;
/* if true, we collecting AGING space for the second time, so if it is still
full, we go on to collect TENURED */
}
}
-/* test if the pointer is in generation being collected, or a younger one.
-init_data_heap() arranges things so that the older generations are first,
-so we have to check that the pointer occurs after the beginning of
-the requested generation. */
+/* test if the pointer is in generation being collected, or a younger one. */
INLINE bool should_copy(CELL untagged)
{
if(in_zone(newspace,untagged))
else if(HAVE_AGING_P && collecting_gen == AGING)
return !in_zone(&data_heap->generations[TENURED],untagged);
else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
- return in_zone(&data_heap->generations[NURSERY],untagged);
+ return in_zone(&nursery,untagged);
else
{
critical_error("Bug in should_copy",untagged);
bool gc_off;
void garbage_collection(volatile CELL gen,
- bool code_gc,
bool growing_data_heap_,
CELL requested_bytes);
registers) does not run out of memory */
#define ALLOT_BUFFER_ZONE 1024
-INLINE void maybe_gc(CELL a)
-{
- /* If we are requesting a huge object, grow immediately */
- if(nursery->size - ALLOT_BUFFER_ZONE <= a)
- garbage_collection(TENURED,false,true,a);
- /* If we have enough space in the nursery, just return.
- Otherwise, perform a GC - this may grow the heap if
- tenured space cannot hold all live objects from the nursery
- even after a full GC */
- else if(a + ALLOT_BUFFER_ZONE + nursery->here > nursery->end)
- garbage_collection(NURSERY,false,false,0);
- /* There is now sufficient room in the nursery for 'a' */
-}
-
/*
* It is up to the caller to fill in the object's fields in a meaningful
* fashion!
*/
-INLINE void* allot_object(CELL type, CELL length)
+INLINE void* allot_object(CELL type, CELL a)
{
- maybe_gc(length);
- CELL* object = allot_zone(nursery,length);
+ CELL *object;
+
+ if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a)
+ {
+ /* If there is insufficient room, collect the nursery */
+ if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end)
+ garbage_collection(NURSERY,false,0);
+
+ CELL h = nursery.here;
+ nursery.here = h + align8(a);
+ object = (void*)h;
+ }
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ else
+ {
+ F_ZONE *tenured = &data_heap->generations[TENURED];
+
+ /* If tenured space does not have enough room, collect */
+ if(tenured->here + a > tenured->end)
+ {
+ gc();
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ /* If it still won't fit, grow the heap */
+ if(tenured->here + a > tenured->end)
+ {
+ garbage_collection(TENURED,true,a);
+ tenured = &data_heap->generations[TENURED];
+ }
+
+ object = allot_zone(tenured,a);
+
+ /* We have to do this */
+ allot_barrier((CELL)object);
+
+ /* Allows initialization code to store old->new pointers
+ without hitting the write barrier in the common case of
+ a nursery allocation */
+ write_barrier((CELL)object);
+ }
+
*object = tag_header(type);
return object;
}
CELL collect_next(CELL scan);
-DLLEXPORT void simple_gc(void);
-
-void data_gc(void);
-
-DECLARE_PRIMITIVE(data_gc);
+DECLARE_PRIMITIVE(gc);
DECLARE_PRIMITIVE(gc_time);
DECLARE_PRIMITIVE(become);
+
+CELL find_all_words(void);
printf("...");
}
+void print_tuple(F_TUPLE* tuple, CELL nesting)
+{
+ F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
+ CELL length = to_fixnum(layout->size);
+
+ printf(" ");
+ print_nested_obj(layout->class,nesting);
+
+ CELL i;
+ bool trimmed;
+
+ if(length > 10)
+ {
+ trimmed = true;
+ length = 10;
+ }
+ else
+ trimmed = false;
+
+ for(i = 0; i < length; i++)
+ {
+ printf(" ");
+ print_nested_obj(tuple_nth(tuple,i),nesting);
+ }
+
+ if(trimmed)
+ printf("...");
+}
+
void print_nested_obj(CELL obj, F_FIXNUM nesting)
{
if(nesting <= 0)
break;
case TUPLE_TYPE:
printf("T{");
- print_array(untag_object(obj),nesting - 1);
+ print_tuple(untag_object(obj),nesting - 1);
printf(" }");
break;
case ARRAY_TYPE:
}
}
+void print_datastack(void)
+{
+ printf("==== DATA STACK:\n");
+ print_objects(ds_bot,ds);
+}
+
+void print_retainstack(void)
+{
+ printf("==== RETAIN STACK:\n");
+ print_objects(rs_bot,rs);
+}
+
void print_stack_frame(F_STACK_FRAME *frame)
{
print_obj(frame_executing(frame));
void print_callstack(void)
{
+ printf("==== CALL STACK:\n");
CELL bottom = (CELL)stack_chain->callstack_bottom;
CELL top = (CELL)stack_chain->callstack_top;
iterate_callstack(top,bottom,print_stack_frame);
dump_cell(from);
}
-void dump_zone(F_ZONE z)
+void dump_zone(F_ZONE *z)
{
- printf("start=%lx, size=%lx, end=%lx, here=%lx\n",
- z.start,z.size,z.end,z.here - z.start);
+ printf("start=%ld, size=%ld, here=%ld\n",
+ z->start,z->size,z->here - z->start);
}
void dump_generations(void)
{
int i;
- for(i = 0; i < data_heap->gen_count; i++)
+
+ printf("Nursery: ");
+ dump_zone(&nursery);
+
+ for(i = 1; i < data_heap->gen_count; i++)
{
printf("Generation %d: ",i);
- dump_zone(data_heap->generations[i]);
+ dump_zone(&data_heap->generations[i]);
}
for(i = 0; i < data_heap->gen_count; i++)
{
printf("Semispace %d: ",i);
- dump_zone(data_heap->semispaces[i]);
+ dump_zone(&data_heap->semispaces[i]);
}
printf("Cards: base=%lx, size=%lx\n",
void dump_objects(F_FIXNUM type)
{
- data_gc();
+ gc();
begin_scan();
CELL obj;
printf("push <addr> -- push object on data stack - NOT SAFE\n");
printf("code -- code heap dump\n");
+ bool seen_command = false;
+
for(;;)
{
char cmd[1024];
fflush(stdout);
if(scanf("%1000s",cmd) <= 0)
+ {
+ if(!seen_command)
+ {
+ /* If we exit with an EOF immediately, then
+ dump stacks. This is useful for builder and
+ other cases where Factor is run with stdin
+ redirected to /dev/null */
+ print_datastack();
+ print_retainstack();
+ print_callstack();
+ }
+
exit(1);
+ }
+
+ seen_command = true;
if(strcmp(cmd,"d") == 0)
{
else if(strcmp(cmd,"r") == 0)
dump_memory(rs_bot,rs);
else if(strcmp(cmd,".s") == 0)
- print_objects(ds_bot,ds);
+ print_datastack();
else if(strcmp(cmd,".r") == 0)
- print_objects(rs_bot,rs);
+ print_retainstack();
else if(strcmp(cmd,".c") == 0)
print_callstack();
else if(strcmp(cmd,"e") == 0)
void print_nested_obj(CELL obj, F_FIXNUM nesting);
void dump_generations(void);
void factorbug(void);
+void dump_zone(F_ZONE *z);
DECLARE_PRIMITIVE(die);
general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
else if(in_page(addr, rs_bot, rs_size, 0))
general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
- else if(in_page(addr, nursery->end, 0, 0))
+ else if(in_page(addr, nursery.end, 0, 0))
critical_error("allot_object() missed GC check",0);
else if(in_page(addr, gc_locals_region->start, 0, -1))
critical_error("gc locals underflow",0);
{
throw_impl(dpop(),stack_chain->callstack_bottom);
}
+
+/* For testing purposes */
+DEFINE_PRIMITIVE(unimplemented)
+{
+ not_implemented_error();
+}
void memory_signal_handler_impl(void);
void divide_by_zero_signal_handler_impl(void);
void misc_signal_handler_impl(void);
+
+DECLARE_PRIMITIVE(unimplemented);
p->gen_count = 2;
p->code_size = 4;
p->young_size = 1;
- p->aging_size = 6;
+ p->aging_size = 1;
+ p->tenured_size = 6;
#else
p->ds_size = 32 * CELLS;
p->rs_size = 32 * CELLS;
p->gen_count = 3;
p->code_size = 8 * CELLS;
- p->young_size = 2 * CELLS;
- p->aging_size = 4 * CELLS;
+ p->young_size = CELLS / 4;
+ p->aging_size = CELLS / 2;
+ p->tenured_size = 4 * CELLS;
#endif
p->secure_gc = false;
fprintf(stderr,"*** Stage 2 early init... ");
fflush(stderr);
- begin_scan();
+ CELL words = find_all_words();
- CELL obj;
- while((obj = next_object()) != F)
+ REGISTER_ROOT(words);
+
+ CELL i;
+ CELL length = array_capacity(untag_object(words));
+ for(i = 0; i < length; i++)
{
- if(type_of(obj) == WORD_TYPE)
- {
- F_WORD *word = untag_object(obj);
- default_word_code(word,false);
- update_word_xt(word);
- }
+ F_WORD *word = untag_word(array_nth(untag_array(words),i));
+ REGISTER_UNTAGGED(word);
+ default_word_code(word,false);
+ UNREGISTER_UNTAGGED(word);
+ update_word_xt(word);
}
- /* End heap scan */
- gc_off = false;
+ UNREGISTER_ROOT(words);
iterate_code_heap(relocate_code_block);
/* Megabytes */
p->young_size <<= 20;
p->aging_size <<= 20;
+ p->tenured_size <<= 20;
p->code_size <<= 20;
/* Disable GC during init as a sanity check */
else if(factor_arg(argv[i],STR_FORMAT("-generations=%d"),&p.gen_count));
else if(factor_arg(argv[i],STR_FORMAT("-young=%d"),&p.young_size));
else if(factor_arg(argv[i],STR_FORMAT("-aging=%d"),&p.aging_size));
+ else if(factor_arg(argv[i],STR_FORMAT("-tenured=%d"),&p.tenured_size));
else if(factor_arg(argv[i],STR_FORMAT("-codeheap=%d"),&p.code_size));
else if(STRCMP(argv[i],STR_FORMAT("-securegc")) == 0)
p.secure_gc = true;
{
return x.x;
}
+
+static int global_var;
+
+void ffi_test_36_point_5(void)
+{
+ printf("ffi_test_36_point_5\n");
+ global_var = 0;
+}
+
+int ffi_test_37(int (*f)(int, int, int))
+{
+ printf("ffi_test_37\n");
+ printf("global_var is %d\n",global_var);
+ global_var = f(global_var,global_var * 2,global_var * 3);
+ printf("global_var is %d\n",global_var);
+ fflush(stdout);
+ return global_var;
+}
+
+unsigned long long ffi_test_38(unsigned long long x, unsigned long long y)
+{
+ return x * y;
+}
+
+
struct test_struct_12 { int a; double x; };
DLLEXPORT double ffi_test_36(struct test_struct_12 x);
+
+DLLEXPORT void ffi_test_36_point_5(void);
+
+DLLEXPORT int ffi_test_37(int (*f)(int, int, int));
+
+DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y);
{
CELL good_size = h->data_size + (1 << 20);
- if(good_size > p->aging_size)
- p->aging_size = good_size;
+ if(good_size > p->tenured_size)
+ p->tenured_size = good_size;
- init_data_heap(p->gen_count,p->young_size,p->aging_size,p->secure_gc);
+ init_data_heap(p->gen_count,
+ p->young_size,
+ p->aging_size,
+ p->tenured_size,
+ p->secure_gc);
F_ZONE *tenured = &data_heap->generations[TENURED];
DEFINE_PRIMITIVE(save_image)
{
/* do a full GC to push everything into tenured space */
- code_gc();
+ gc();
save_image(unbox_native_string());
}
/* Initialize an object in a newly-loaded image */
void relocate_object(CELL relocating)
{
- do_slots(relocating,data_fixup);
+ /* Tuple relocation is a bit trickier; we have to fix up the
+ fixup object before we can get the tuple size, so do_slots is
+ out of the question */
+ if(untag_header(get(relocating)) == TUPLE_TYPE)
+ {
+ data_fixup((CELL *)relocating + 1);
+
+ CELL scan = relocating + 2 * CELLS;
+ CELL size = untagged_object_size(relocating);
+ CELL end = relocating + size;
- switch(untag_header(get(relocating)))
+ while(scan < end)
+ {
+ data_fixup((CELL *)scan);
+ scan += CELLS;
+ }
+ }
+ else
{
- case WORD_TYPE:
- fixup_word((F_WORD *)relocating);
- break;
- case QUOTATION_TYPE:
- fixup_quotation((F_QUOTATION *)relocating);
- break;
- case DLL_TYPE:
- ffi_dlopen((F_DLL *)relocating);
- break;
- case ALIEN_TYPE:
- fixup_alien((F_ALIEN *)relocating);
- break;
- case CALLSTACK_TYPE:
- fixup_callstack_object((F_CALLSTACK *)relocating);
- break;
+ do_slots(relocating,data_fixup);
+
+ switch(untag_header(get(relocating)))
+ {
+ case WORD_TYPE:
+ fixup_word((F_WORD *)relocating);
+ break;
+ case QUOTATION_TYPE:
+ fixup_quotation((F_QUOTATION *)relocating);
+ break;
+ case DLL_TYPE:
+ ffi_dlopen((F_DLL *)relocating);
+ break;
+ case ALIEN_TYPE:
+ fixup_alien((F_ALIEN *)relocating);
+ break;
+ case CALLSTACK_TYPE:
+ fixup_callstack_object((F_CALLSTACK *)relocating);
+ break;
+ }
}
}
typedef struct {
const F_CHAR* image;
CELL ds_size, rs_size;
- CELL gen_count, young_size, aging_size;
+ CELL gen_count, young_size, aging_size, tenured_size;
CELL code_size;
bool secure_gc;
bool fep;
{
return errno;
}
+
+void clear_err_no(void)
+{
+ errno = 0;
+}
void init_c_io(void);
void io_error(void);
int err_no(void);
+void clear_err_no(void);
DECLARE_PRIMITIVE(fopen);
DECLARE_PRIMITIVE(fgetc);
/* Platform specific primitives */
DECLARE_PRIMITIVE(open_file);
-DECLARE_PRIMITIVE(stat);
+DECLARE_PRIMITIVE(existsp);
DECLARE_PRIMITIVE(read_dir);
#define ALIEN_TYPE 16
#define WORD_TYPE 17
#define BYTE_ARRAY_TYPE 18
+#define TUPLE_LAYOUT_TYPE 19
-#define TYPE_COUNT 19
+#define TYPE_COUNT 20
INLINE bool immediate_p(CELL obj)
{
/* Frame size in bytes */
CELL size;
} F_STACK_FRAME;
+
+typedef struct
+{
+ CELL header;
+ /* tagged fixnum */
+ CELL hashcode;
+ /* tagged */
+ CELL class;
+ /* tagged fixnum */
+ CELL size;
+ /* tagged array */
+ CELL superclasses;
+ /* tagged fixnum */
+ CELL echelon;
+} F_TUPLE_LAYOUT;
+
+typedef struct
+{
+ CELL header;
+ /* tagged layout */
+ CELL layout;
+} F_TUPLE;
#include "layouts.h"
#include "platform.h"
#include "primitives.h"
-#include "debug.h"
#include "run.h"
#include "profiler.h"
#include "errors.h"
#include "bignumint.h"
#include "bignum.h"
#include "data_gc.h"
+#include "debug.h"
#include "types.h"
#include "math.h"
#include "float_bits.h"
--- /dev/null
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.mc_rsp;
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
+#include <ucontext.h>
+
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
+}
+
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[7];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[15];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
--- /dev/null
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[7];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
--- /dev/null
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[15];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov */
+#include <ucontext.h>
+
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2)
#define MACH_EXC_STATE_TYPE ppc_exception_state_t
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov */
+#include <ucontext.h>
+
#define MACH_EXC_STATE_TYPE i386_exception_state_t
#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov and Daniel Ehrenberg */
+#include <ucontext.h>
+
#define MACH_EXC_STATE_TYPE x86_exception_state64_t
#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64
#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT
#ifndef environ
extern char ***_NSGetEnviron(void);
#define environ (*_NSGetEnviron())
-#endif
\ No newline at end of file
+#endif
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return ucontext->uc_stack.ss_sp;
+}
--- /dev/null
+#include <ucontext.h>
+
+#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
--- /dev/null
+#include <ucontext.h>
+
+#define ucontext_stack_pointer(uap) \
+ ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
#include <ucontext.h>
-#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
+#include <i386/signal.h>
+
INLINE void *openbsd_stack_pointer(void *uap)
{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->sc_esp;
+ struct sigcontext *sc = (struct sigcontext*) uap;
+ return (void *)sc->sc_esp;
}
#define ucontext_stack_pointer openbsd_stack_pointer
+#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
+#include <amd64/signal.h>
+
INLINE void *openbsd_stack_pointer(void *uap)
{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->sc_rsp;
+ struct sigcontext *sc = (struct sigcontext*) uap;
+ return (void *)sc->sc_rsp;
}
#define ucontext_stack_pointer openbsd_stack_pointer
+#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
+
+#ifndef environ
+ extern char **environ;
+#endif
--- /dev/null
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[ESP];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP])
--- /dev/null
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[RSP];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP])
#define UNKNOWN_TYPE_P(file) 1
#define DIRECTORY_P(file) 0
+
+extern char **environ;
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return ucontext->uc_stack.ss_sp;
-}
dll->dll = NULL;
}
-DEFINE_PRIMITIVE(stat)
+DEFINE_PRIMITIVE(existsp)
{
struct stat sb;
-
- if(stat(unbox_char_string(),&sb) < 0)
- {
- dpush(F);
- dpush(F);
- dpush(F);
- dpush(F);
- }
- else
- {
- box_boolean(S_ISDIR(sb.st_mode));
- box_signed_4(sb.st_mode & ~S_IFMT);
- box_unsigned_8(sb.st_size);
- box_unsigned_8(sb.st_mtime);
- }
+ box_boolean(stat(unbox_char_string(),&sb) >= 0);
}
/* Allocates memory */
dpush(result);
}
+DEFINE_PRIMITIVE(os_env)
+{
+ char *name = unbox_char_string();
+ char *value = getenv(name);
+ if(value == NULL)
+ dpush(F);
+ else
+ box_char_string(value);
+}
+
DEFINE_PRIMITIVE(os_envs)
{
GROWABLE_ARRAY(result);
dpush(result);
}
+DEFINE_PRIMITIVE(set_os_env)
+{
+ char *key = unbox_char_string();
+ REGISTER_C_STRING(key);
+ char *value = unbox_char_string();
+ UNREGISTER_C_STRING(key);
+ setenv(key, value, 1);
+}
+
+DEFINE_PRIMITIVE(unset_os_env)
+{
+ char *key = unbox_char_string();
+ unsetenv(key);
+}
+
DEFINE_PRIMITIVE(set_os_envs)
{
F_ARRAY *array = untag_array(dpop());
return safe_strdup(full_path);
}
-void stat_not_found(void)
-{
- dpush(F);
- dpush(F);
- dpush(F);
- dpush(F);
-}
-
void find_file_stat(F_CHAR *path)
{
// FindFirstFile is the only call that can stat c:\pagefile.sys
HANDLE h;
if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
- stat_not_found();
+ dpush(F);
else
{
- box_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
- dpush(tag_fixnum(0));
- box_unsigned_8(
- (u64)st.nFileSizeLow | (u64)st.nFileSizeHigh << 32);
-
- u64 lo = st.ftLastWriteTime.dwLowDateTime;
- u64 hi = st.ftLastWriteTime.dwHighDateTime;
- u64 modTime = (hi << 32) + lo;
-
- box_unsigned_8((modTime - EPOCH_OFFSET) / 10000000);
FindClose(h);
+ dpush(T);
}
}
-DEFINE_PRIMITIVE(stat)
+DEFINE_PRIMITIVE(existsp)
{
- HANDLE h;
BY_HANDLE_FILE_INFORMATION bhfi;
F_CHAR *path = unbox_u16_string();
//wprintf(L"path = %s\n", path);
- h = CreateFileW(path,
- GENERIC_READ,
- FILE_SHARE_READ,
- NULL,
- OPEN_EXISTING,
- FILE_FLAG_BACKUP_SEMANTICS,
- NULL);
+ HANDLE h = CreateFileW(path,
+ GENERIC_READ,
+ FILE_SHARE_READ,
+ NULL,
+ OPEN_EXISTING,
+ FILE_FLAG_BACKUP_SEMANTICS,
+ NULL);
+
if(h == INVALID_HANDLE_VALUE)
{
- find_file_stat(path);
+ // FindFirstFile is the only call that can stat c:\pagefile.sys
+ WIN32_FIND_DATA st;
+ HANDLE h;
+
+ if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
+ dpush(F);
+ else
+ {
+ FindClose(h);
+ dpush(T);
+ }
return;
}
- if(!GetFileInformationByHandle(h, &bhfi))
- stat_not_found();
- else {
- box_boolean(bhfi.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
- dpush(tag_fixnum(0));
- box_unsigned_8(
- (u64)bhfi.nFileSizeLow | (u64)bhfi.nFileSizeHigh << 32);
- u64 lo = bhfi.ftLastWriteTime.dwLowDateTime;
- u64 hi = bhfi.ftLastWriteTime.dwHighDateTime;
- u64 modTime = (hi << 32) + lo;
-
- box_unsigned_8((modTime - EPOCH_OFFSET) / 10000000);
- }
+ box_boolean(GetFileInformationByHandle(h, &bhfi));
CloseHandle(h);
}
Sleep(msec);
}
-DECLARE_PRIMITIVE(set_os_envs)
+DEFINE_PRIMITIVE(os_env)
+{
+ F_CHAR *key = unbox_u16_string();
+ F_CHAR *value = safe_malloc(MAX_UNICODE_PATH * 2);
+ int ret;
+ ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH * 2);
+ if(ret == 0)
+ dpush(F);
+ else
+ dpush(tag_object(from_u16_string(value)));
+ free(value);
+}
+
+DEFINE_PRIMITIVE(set_os_env)
+{
+ F_CHAR *key = unbox_u16_string();
+ REGISTER_C_STRING(key);
+ F_CHAR *value = unbox_u16_string();
+ UNREGISTER_C_STRING(key);
+ if(!SetEnvironmentVariable(key, value))
+ general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
+}
+
+DEFINE_PRIMITIVE(unset_os_env)
+{
+ if(!SetEnvironmentVariable(unbox_u16_string(), NULL)
+ && GetLastError() != ERROR_ENVVAR_NOT_FOUND)
+ general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
+}
+
+DEFINE_PRIMITIVE(set_os_envs)
{
not_implemented_error();
}
#include "os-unix.h"
#ifdef __APPLE__
- #include "os-unix-ucontext.h"
#include "os-macosx.h"
#include "mach_signal.h"
#if defined(FACTOR_X86)
#include "os-freebsd-x86.32.h"
+ #elif defined(FACTOR_AMD64)
+ #include "os-freebsd-x86.64.h"
#else
#error "Unsupported FreeBSD flavor"
#endif
#endif
#elif defined(__NetBSD__)
#define FACTOR_OS_STRING "netbsd"
+
+ #if defined(FACTOR_X86)
+ #include "os-netbsd-x86.32.h"
+ #elif defined(FACTOR_AMD64)
+ #include "os-netbsd-x86.64.h"
+ #else
+ #error "Unsupported NetBSD flavor"
+ #endif
+
#include "os-netbsd.h"
#elif defined(linux)
#define FACTOR_OS_STRING "linux"
#include "os-linux.h"
#if defined(FACTOR_X86)
- #include "os-linux-x86-32.h"
+ #include "os-linux-x86.32.h"
#elif defined(FACTOR_PPC)
- #include "os-unix-ucontext.h"
#include "os-linux-ppc.h"
#elif defined(FACTOR_ARM)
#include "os-linux-arm.h"
#elif defined(FACTOR_AMD64)
- #include "os-linux-x86-64.h"
+ #include "os-linux-x86.64.h"
#else
#error "Unsupported Linux flavor"
#endif
#elif defined(__SVR4) && defined(sun)
#define FACTOR_OS_STRING "solaris"
+
+ #if defined(FACTOR_X86)
+ #include "os-solaris-x86.32.h"
+ #elif defined(FACTOR_AMD64)
+ #incluide "os-solaris-x86.64.h"
+ #else
+ #error "Unsupported Solaris flavor"
+ #endif
+
#include "os-solaris.h"
- #include "os-unix-ucontext.h"
#else
#error "Unsupported OS"
#endif
primitive_eq,
primitive_getenv,
primitive_setenv,
- primitive_stat,
+ primitive_existsp,
primitive_read_dir,
- primitive_data_gc,
- primitive_code_gc,
+ primitive_gc,
primitive_gc_time,
primitive_save_image,
primitive_save_image_and_exit,
primitive_code_room,
primitive_os_env,
primitive_millis,
- primitive_type,
primitive_tag,
primitive_modify_code_heap,
primitive_dlopen,
primitive_set_alien_double,
primitive_alien_cell,
primitive_set_alien_cell,
- primitive_alien_to_char_string,
- primitive_string_to_char_alien,
- primitive_alien_to_u16_string,
- primitive_string_to_u16_alien,
primitive_throw,
primitive_alien_address,
primitive_slot,
primitive_wrapper,
primitive_clone,
primitive_string,
- primitive_to_tuple,
primitive_array_to_quotation,
primitive_quotation_xt,
primitive_tuple,
- primitive_tuple_to_array,
+ primitive_tuple_layout,
primitive_profiling,
primitive_become,
primitive_sleep,
primitive_float_array,
primitive_tuple_boa,
- primitive_class_hash,
primitive_callstack_to_array,
primitive_innermost_stack_frame_quot,
primitive_innermost_stack_frame_scan,
primitive_set_innermost_stack_frame_quot,
primitive_call_clear,
primitive_os_envs,
+ primitive_set_os_env,
+ primitive_unset_os_env,
primitive_set_os_envs,
primitive_resize_byte_array,
primitive_resize_bit_array,
primitive_resize_float_array,
primitive_dll_validp,
+ primitive_unimplemented,
};
profiling_p = profiling;
- /* Push everything to tenured space so that we can heap scan,
- also code GC so that we can allocate profiling blocks if
- necessary */
- code_gc();
+ /* Push everything to tenured space so that we can heap scan
+ and allocate profiling blocks if necessary */
+ gc();
- /* Update word XTs and saved callstack objects */
- begin_scan();
+ CELL words = find_all_words();
- CELL obj;
- while((obj = next_object()) != F)
+ REGISTER_ROOT(words);
+
+ CELL i;
+ CELL length = array_capacity(untag_object(words));
+ for(i = 0; i < length; i++)
{
- if(type_of(obj) == WORD_TYPE)
- update_word_xt(untag_object(obj));
+ F_WORD *word = untag_word(array_nth(untag_array(words),i));
+ update_word_xt(word);
}
- gc_off = false; /* end heap scan */
+ UNREGISTER_ROOT(words);
/* Update XTs in code heap */
iterate_code_heap(relocate_code_block);
be stored in registers, so callbacks must save and restore the correct values */
void save_stacks(void)
{
- stack_chain->datastack = ds;
- stack_chain->retainstack = rs;
+ if(stack_chain)
+ {
+ stack_chain->datastack = ds;
+ stack_chain->retainstack = rs;
+ }
}
/* called on entry into a compiled callback */
exit(to_fixnum(dpop()));
}
-DEFINE_PRIMITIVE(os_env)
-{
- char *name = unbox_char_string();
- char *value = getenv(name);
- if(value == NULL)
- dpush(F);
- else
- box_char_string(value);
-}
-
DEFINE_PRIMITIVE(eq)
{
CELL lhs = dpop();
sleep_millis(to_cell(dpop()));
}
-DEFINE_PRIMITIVE(type)
-{
- drepl(tag_fixnum(type_of(dpeek())));
-}
-
DEFINE_PRIMITIVE(tag)
{
drepl(tag_fixnum(TAG(dpeek())));
}
-DEFINE_PRIMITIVE(class_hash)
-{
- CELL obj = dpeek();
- CELL tag = TAG(obj);
- if(tag == TUPLE_TYPE)
- {
- F_WORD *class = untag_object(get(SLOT(obj,2)));
- drepl(class->hashcode);
- }
- else if(tag == OBJECT_TYPE)
- drepl(get(UNTAG(obj)));
- else
- drepl(tag_fixnum(tag));
-}
-
DEFINE_PRIMITIVE(slot)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
DECLARE_PRIMITIVE(exit);
DECLARE_PRIMITIVE(os_env);
DECLARE_PRIMITIVE(os_envs);
+DECLARE_PRIMITIVE(set_os_env);
+DECLARE_PRIMITIVE(unset_os_env);
DECLARE_PRIMITIVE(set_os_envs);
DECLARE_PRIMITIVE(eq);
DECLARE_PRIMITIVE(millis);
DECLARE_PRIMITIVE(sleep);
-DECLARE_PRIMITIVE(type);
DECLARE_PRIMITIVE(tag);
-DECLARE_PRIMITIVE(class_hash);
DECLARE_PRIMITIVE(slot);
DECLARE_PRIMITIVE(set_slot);
UNREGISTER_ROOT(name);
UNREGISTER_ROOT(vocab);
- word->hashcode = tag_fixnum(rand());
+ word->hashcode = tag_fixnum((rand() << 16) ^ rand());
word->vocabulary = vocab;
word->name = name;
word->def = userenv[UNDEFINED_ENV];
word->counter = tag_fixnum(0);
word->compiledp = F;
word->profiling = NULL;
+ word->code = NULL;
REGISTER_UNTAGGED(word);
default_word_code(word,true);
memset((void*)AREF(array,0),'\0',capacity * CELLS);
else
{
+ /* No need for write barrier here. Either the object is in
+ the nursery, or it was allocated directly in tenured space
+ and the write barrier is already hit for us in that case. */
for(i = 0; i < capacity; i++)
- set_array_nth(array,i,fill);
+ put(AREF(array,i),fill);
}
return array;
}
memcpy(new_array + 1,array + 1,to_copy * CELLS);
for(i = to_copy; i < capacity; i++)
- set_array_nth(new_array,i,fill);
+ put(AREF(new_array,i),fill);
return new_array;
}
UNREGISTER_UNTAGGED(elts);
+ write_barrier((CELL)result);
+
memcpy((void*)AREF(result,*result_count),(void*)AREF(elts,0),elts_size * CELLS);
*result_count += elts_size;
dpush(tag_object(reallot_float_array(array,capacity)));
}
+/* Tuple layouts */
+DEFINE_PRIMITIVE(tuple_layout)
+{
+ F_TUPLE_LAYOUT *layout = allot_object(TUPLE_LAYOUT_TYPE,sizeof(F_TUPLE_LAYOUT));
+ layout->echelon = dpop();
+ layout->superclasses = dpop();
+ layout->size = dpop();
+ layout->class = dpop();
+ layout->hashcode = untag_word(layout->class)->hashcode;
+ dpush(tag_object(layout));
+}
+
/* Tuples */
/* push a new tuple on the stack */
+F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
+{
+ REGISTER_UNTAGGED(layout);
+ F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout));
+ UNREGISTER_UNTAGGED(layout);
+ tuple->layout = tag_object(layout);
+ return tuple;
+}
+
DEFINE_PRIMITIVE(tuple)
{
- CELL size = unbox_array_size();
- F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
- set_array_nth(array,0,dpop());
- dpush(tag_tuple(array));
+ F_TUPLE_LAYOUT *layout = untag_object(dpop());
+ F_FIXNUM size = to_fixnum(layout->size);
+
+ F_TUPLE *tuple = allot_tuple(layout);
+ F_FIXNUM i;
+ for(i = size - 1; i >= 0; i--)
+ put(AREF(tuple,i),F);
+
+ dpush(tag_tuple(tuple));
}
/* push a new tuple on the stack, filling its slots from the stack */
DEFINE_PRIMITIVE(tuple_boa)
{
- CELL size = unbox_array_size();
- F_ARRAY *array = allot_array(TUPLE_TYPE,size,F);
- set_array_nth(array,0,dpop());
+ F_TUPLE_LAYOUT *layout = untag_object(dpop());
+ F_FIXNUM size = to_fixnum(layout->size);
- CELL i;
- for(i = size - 1; i >= 2; i--)
- set_array_nth(array,i,dpop());
+ REGISTER_UNTAGGED(layout);
+ F_TUPLE *tuple = allot_tuple(layout);
+ UNREGISTER_UNTAGGED(layout);
- dpush(tag_tuple(array));
-}
+ /* set delegate slot */
+ put(AREF(tuple,0),F);
-DEFINE_PRIMITIVE(tuple_to_array)
-{
- CELL object = dpeek();
- type_check(TUPLE_TYPE,object);
- object = RETAG(clone(object),OBJECT_TYPE);
- set_slot(object,0,tag_header(ARRAY_TYPE));
- drepl(object);
-}
+ F_FIXNUM i;
+ for(i = size - 1; i >= 1; i--)
+ put(AREF(tuple,i),dpop());
-DEFINE_PRIMITIVE(to_tuple)
-{
- CELL object = RETAG(clone(dpeek()),TUPLE_TYPE);
- set_slot(object,0,tag_header(TUPLE_TYPE));
- drepl(object);
+ dpush(tag_tuple(tuple));
}
/* Strings */
untag_fixnum_fast(string->length)
* sizeof(u16));
UNREGISTER_UNTAGGED(string);
+
+ write_barrier((CELL)string);
string->aux = tag_object(aux);
}
}
REGISTER_UNTAGGED(string);
REGISTER_UNTAGGED(new_string);
F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
- new_string->aux = tag_object(new_aux);
UNREGISTER_UNTAGGED(new_string);
UNREGISTER_UNTAGGED(string);
+ new_string->aux = tag_object(new_aux);
+
F_BYTE_ARRAY *aux = untag_object(string->aux);
memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
}
void box_##type##_string(const type *str) \
{ \
dpush(str ? tag_object(from_##type##_string(str)) : F); \
- } \
- DEFINE_PRIMITIVE(alien_to_##type##_string) \
- { \
- drepl(tag_object(from_##type##_string(alien_offset(dpeek())))); \
}
MEMORY_TO_STRING(char,u8)
type *unbox_##type##_string(void) \
{ \
return to_##type##_string(untag_string(dpop()),true); \
- } \
- DEFINE_PRIMITIVE(string_to_##type##_alien) \
- { \
- CELL string, t; \
- string = dpeek(); \
- t = type_of(string); \
- if(t != ALIEN_TYPE && t != BYTE_ARRAY_TYPE && t != F_TYPE) \
- drepl(tag_object(string_to_##type##_alien(untag_string(string),true))); \
}
STRING_TO_MEMORY(char);
DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
-INLINE CELL tag_tuple(F_ARRAY *tuple)
+INLINE CELL tag_tuple(F_TUPLE *tuple)
{
return RETAG(tuple,TUPLE_TYPE);
}
+INLINE F_TUPLE *untag_tuple(CELL object)
+{
+ type_check(TUPLE_TYPE,object);
+ return untag_object(object);
+}
+
+INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout)
+{
+ CELL size = untag_fixnum_fast(layout->size);
+ return sizeof(F_TUPLE) + size * CELLS;
+}
+
+INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot)
+{
+ return get(AREF(tuple,slot));
+}
+
+INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value)
+{
+ put(AREF(tuple,slot),value);
+ write_barrier((CELL)tuple);
+}
+
/* Prototypes */
DLLEXPORT void box_boolean(bool value);
DLLEXPORT bool to_boolean(CELL value);
DECLARE_PRIMITIVE(array);
DECLARE_PRIMITIVE(tuple);
DECLARE_PRIMITIVE(tuple_boa);
+DECLARE_PRIMITIVE(tuple_layout);
DECLARE_PRIMITIVE(byte_array);
DECLARE_PRIMITIVE(bit_array);
DECLARE_PRIMITIVE(float_array);
DECLARE_PRIMITIVE(clone);
-DECLARE_PRIMITIVE(tuple_to_array);
-DECLARE_PRIMITIVE(to_tuple);
F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity, CELL fill);
DECLARE_PRIMITIVE(resize_array);
F_STRING *memory_to_char_string(const char *string, CELL length);
F_STRING *from_char_string(const char *c_string);
DLLEXPORT void box_char_string(const char *c_string);
-DECLARE_PRIMITIVE(alien_to_char_string);
F_STRING *memory_to_u16_string(const u16 *string, CELL length);
F_STRING *from_u16_string(const u16 *c_string);
DLLEXPORT void box_u16_string(const u16 *c_string);
-DECLARE_PRIMITIVE(alien_to_u16_string);
void char_string_to_memory(F_STRING *s, char *string);
F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check);
char* to_char_string(F_STRING *s, bool check);
DLLEXPORT char *unbox_char_string(void);
-DECLARE_PRIMITIVE(string_to_char_alien);
void u16_string_to_memory(F_STRING *s, u16 *string);
F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
u16* to_u16_string(F_STRING *s, bool check);
DLLEXPORT u16 *unbox_u16_string(void);
-DECLARE_PRIMITIVE(string_to_u16_alien);
/* String getters and setters */
CELL string_nth(F_STRING* string, CELL index);